C4/Ris.pm

   1 package C4::Ris;
   2
   3 # Original script :
   4 ## marc2ris: converts MARC21 and UNIMARC datasets to RIS format
   5 ##           See comments below for compliance with other MARC dialects
   6 ##
   7 ## usage: perl marc2ris < infile.marc > outfile.ris
   8 ##
   9 ## Dependencies: perl 5.6.0 or later
  10 ##               MARC::Record
  11 ##               MARC::Charset
  12 ##
  13 ## markus@mhoenicka.de 2002-11-16
  14
  15 ##   This program is free software; you can redistribute it and/or modify
  16 ##   it under the terms of the GNU General Public License as published by
  17 ##   the Free Software Foundation; either version 2 of the License, or
  18 ##   (at your option) any later version.
  19 ##
  20 ##   This program is distributed in the hope that it will be useful,
  21 ##   but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ##   GNU General Public License for more details.
  24
  25 ##   You should have received a copy of the GNU General Public License
  26 ##   along with this program; if not, write to the Free Software
  27 ##   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  28
  29 ## Some background about MARC as understood by this script
  30 ## The default input format used in this script is MARC21, which
  31 ## superseded USMARC and CANMARC. The specification can be found at:
  32 ## http://lcweb.loc.gov/marc/
  33 ## UNIMARC follows the specification at:
  34 ## http://www.ifla.org/VI/3/p1996-1/sec-uni.htm
  35 ## UKMARC support is a bit shaky because there is no specification available
  36 ## for free. The wisdom used in this script was taken from a PDF document
  37 ## comparing UKMARC to MARC21 found at:
  38 ## www.bl.uk/services/bibliographic/marcchange.pdf
  39
  40
  41 # Modified 2008 by BibLibre for Koha
  42 #
  43 # This file is part of Koha.
  44 #
  45 # Koha is free software; you can redistribute it and/or modify it under the
  46 # terms of the GNU General Public License as published by the Free Software
  47 # Foundation; either version 2 of the License, or (at your option) any later
  48 # version.
  49 #
  50 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  51 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  52 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  53 #
  54 # You should have received a copy of the GNU General Public License along with
  55 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  56 # Suite 330, Boston, MA  02111-1307 USA
  57 #
  58 #
  59
  60 #use strict;
  61 #use warnings; FIXME - Bug 2505
  62
  63 use vars qw($VERSION @ISA @EXPORT);
  64
  65 # set the version for version checking
  66 $VERSION = 3.00;
  67
  68 @ISA = qw(Exporter);
  69
  70 # only export API methods
  71
  72 @EXPORT = qw(
  73   &marc2ris
  74 );
  75
  76
  77 =head1 marc2bibtex - Convert from UNIMARC to RIS
  78
  79   my ($ris) = marc2ris($record);
  80
  81 Returns a RIS scalar
  82
  83 C<$record> - a MARC::Record object
  84
  85 =cut
  86
  87 sub marc2ris {
  88     my ($record) = @_;
  89     my $output;
  90
  91     my $marcflavour = C4::Context->preference("marcflavour");
  92     my $intype = lc($marcflavour);
  93     my $marcprint = 1; # Debug
  94
  95     # Let's redirect stdout
  96     open my $oldout, ">&STDOUT";
  97     my $outvar;
  98     close STDOUT;
  99     open STDOUT,'>', \$outvar;
 100
 101
 102         ## First we should check the character encoding. This may be
 103         ## MARC-8 or UTF-8. The former is indicated by a blank, the latter
 104         ## by 'a' at position 09 (zero-based) of the leader
 105         my $leader = $record->leader();
 106         if ($intype eq "marc21") {
 107             if ($leader =~ /^.{9}a/) {
 108                 print "<marc>---\n<marc>UTF-8 data\n" if $marcprint;
 109                 $utf = 1;
 110             }
 111             else {
 112                 print "<marc>---\n<marc>MARC-8 data\n" if $marcprint;
 113             }
 114         }
 115         ## else: other MARC formats do not specify the character encoding
 116         ## we assume it's *not* UTF-8
 117
 118         ## start RIS dataset
 119         &print_typetag($leader);
 120
 121         ## retrieve all author fields and collect them in a list
 122         my @author_fields;
 123
 124         if ($intype eq "unimarc") {
 125             ## Fields 700, 701, and 702 can contain author names
 126             @author_fields = ($record->field('700'), $record->field('701'), $record->field('702'));
 127         }
 128         else {  ## marc21, ukmarc
 129             ## Field 100 sometimes carries main author
 130             ## Field(s) 700 carry added entries - personal names
 131             @author_fields = ($record->field('100'), $record->field('700'));
 132         }
 133
 134         ## loop over all author fields
 135         foreach my $field (@author_fields) {
 136             if (length($field)) {
 137                 my $author = &get_author($field);
 138                 print "AU  - ",&charconv($author),"\n";
 139             }
 140         }
 141
 142         # ToDo: should we specify anonymous as author if we didn't find
 143         # one? or use one of the corporate/meeting names below?
 144
 145         ## add corporate names or meeting names as editors ??
 146         my @editor_fields;
 147
 148         if ($intype eq "unimarc") {
 149             ## Fields 710, 711, and 712 can carry corporate names
 150             ## Field(s) 720, 721, 722, 730 have additional candidates
 151             @editor_fields = ($record->field('710'), $record->field('711'), $record->field('712'), $record->field('720'), $record->field('721'), $record->field('722'), $record->field('730'));
 152         }
 153         else { ## marc21, ukmarc
 154             ## Fields 110 and 111 carry the main entries - corporate name and
 155             ## meeting name, respectively
 156             ## Field(s) 710, 711 carry added entries - personal names
 157             @editor_fields = ($record->field('110'), $record->field('111'), $record->field('710'), $record->field('711'));
 158         }
 159
 160         ## loop over all editor fields
 161         foreach my $field (@editor_fields) {
 162             if (length($field)) {
 163                 my $editor = &get_editor($field);
 164                 print "ED  - ",&charconv($editor),"\n";
 165             }
 166         }
 167
 168         ## get info from the title field
 169         if ($intype eq "unimarc") {
 170             &print_title($record->field('200'));
 171         }
 172         else { ## marc21, ukmarc
 173             &print_title($record->field('245'));
 174         }
 175
 176         ## series title
 177         if ($intype eq "unimarc") {
 178             &print_stitle($record->field('225'));
 179         }
 180         else { ## marc21, ukmarc
 181             &print_stitle($record->field('210'));
 182         }
 183
 184         ## ISBN/ISSN
 185         if ($intype eq "unimarc") {
 186             &print_isbn($record->field('010'));
 187             &print_issn($record->field('011'));
 188         }
 189         elsif ($intype eq "ukmarc") {
 190             &print_isbn($record->field('021'));
 191             ## this is just an assumption
 192             &print_issn($record->field('022'));
 193         }
 194         else { ## assume marc21
 195             &print_isbn($record->field('020'));
 196             &print_issn($record->field('022'));
 197         }
 198
 199         if ($intype eq "marc21") {
 200             &print_loc_callno($record->field('050'));
 201             &print_dewey($record->field('082'));
 202         }
 203         ## else: unimarc, ukmarc do not seem to store call numbers?
 204
 205         ## publication info
 206         if ($intype eq "unimarc") {
 207             &print_pubinfo($record->field('210'));
 208         }
 209         else { ## marc21, ukmarc
 210             &print_pubinfo($record->field('260'));
 211         }
 212
 213         ## 6XX fields contain KW candidates. We add all of them to a
 214         ## hash to eliminate duplicates
 215         my %kwpool;
 216
 217         if ($intype eq "unimarc") {
 218             foreach ('600', '601', '602', '604', '605', '606','607', '608', '610', '615', '620', '660'. '661', '670', '675', '676', '680', '686') {
 219                 &get_keywords(\%kwpool, "$_",$record->field($_));
 220             }
 221         }
 222         elsif ($intype eq "ukmarc") {
 223             foreach ('600', '610', '611', '630', '650', '651','653', '655', '660', '661', '668', '690', '691', '692', '695') {
 224                 &get_keywords(\%kwpool, "$_",$record->field($_));
 225             }
 226         }
 227         else { ## assume marc21
 228             foreach ('600', '610', '611', '630', '650', '651','653', '654', '655', '656', '657', '658') {
 229                 &get_keywords(\%kwpool, "$_",$record->field($_));
 230             }
 231         }
 232
 233         ## print all keywords found in the hash. The value of each hash
 234         ## entry is the number of occurrences, but we're not really interested
 235         ## in that and rather print the key
 236         while (my ($key, $value) = each %kwpool) {
 237             print "KW  - ", &charconv($key), "\n";
 238         }
 239
 240         ## 5XX have various candidates for notes and abstracts. We pool
 241         ## all notes-like stuff in one list.
 242         my @notepool;
 243
 244         ## these fields have notes candidates
 245         if ($intype eq "unimarc") {
 246             foreach ('300', '301', '302', '303', '304', '305', '306', '307', '308', '310', '311', '312', '313', '314', '315', '316', '317', '318', '320', '321', '322', '323', '324', '325', '326', '327', '328', '332', '333', '336', '337', '345') {
 247                 &pool_subx(\@notepool, $_, $record->field($_));
 248             }
 249         }
 250         elsif ($intype eq "ukmarc") {
 251             foreach ('500', '501', '502', '503', '504', '505', '506', '508', '514', '515', '516', '521', '524', '525', '528', '530', '531', '532', '533', '534', '535', '537', '538', '540', '541', '542', '544', '554', '555', '556', '557', '561', '563', '580', '583', '584', '586') {
 252                 &pool_subx(\@notepool, $_, $record->field($_));
 253             }
 254         }
 255         else { ## assume marc21
 256             foreach ('500', '501', '502', '504', '505', '506', '507', '508', '510', '511', '513', '514', '515', '516', '518', '521', '522', '524', '525', '526', '530', '533', '534', '535') {
 257                 &pool_subx(\@notepool, $_, $record->field($_));
 258             }
 259         }
 260
 261         my $allnotes = join "; ", @notepool;
 262
 263         if (length($allnotes) > 0) {
 264             print "N1  - ", &charconv($allnotes), "\n";
 265         }
 266
 267         ## 320/520 have the abstract
 268         if ($intype eq "unimarc") {
 269             &print_abstract($record->field('320'));
 270         }
 271         elsif ($intype eq "ukmarc") {
 272             &print_abstract($record->field('512'), $record->field('513'));
 273         }
 274         else { ## assume marc21
 275             &print_abstract($record->field('520'));
 276         }
 277
 278         ## end RIS dataset
 279         print "ER  - \n";
 280
 281     warn $outvar;
 282
 283     # Let's re-redirect stdout
 284     close STDOUT;
 285     open STDOUT, ">&", $oldout;
 286
 287     return $outvar;
 288
 289 }
 290
 291
 292 ##********************************************************************
 293 ## print_typetag(): prints the first line of a RIS dataset including
 294 ## the preceeding newline
 295 ## Argument: the leader of a MARC dataset
 296 ## Returns: the value at leader position 06
 297 ##********************************************************************
 298 sub print_typetag {
 299     ## the keys of typehash are the allowed values at position 06
 300     ## of the leader of a MARC record, the values are the RIS types
 301     ## that might appropriately represent these types.
 302     my %ustypehash = (
 303                     "a" => "BOOK",
 304                     "c" => "MUSIC",
 305                     "d" => "MUSIC",
 306                     "e" => "MAP",
 307                     "f" => "MAP",
 308                     "g" => "ADVS",
 309                     "i" => "SOUND",
 310                     "j" => "SOUND",
 311                     "k" => "ART",
 312                     "m" => "DATA",
 313                     "o" => "GEN",
 314                     "p" => "GEN",
 315                     "r" => "ART",
 316                     "t" => "GEN",
 317                 );
 318
 319     my %unitypehash = (
 320                     "a" => "BOOK",
 321                     "b" => "BOOK",
 322                     "c" => "MUSIC",
 323                     "d" => "MUSIC",
 324                     "e" => "MAP",
 325                     "f" => "MAP",
 326                     "g" => "ADVS",
 327                     "i" => "SOUND",
 328                     "j" => "SOUND",
 329                     "k" => "ART",
 330                     "l" => "ELEC",
 331                     "m" => "ADVS",
 332                     "r" => "ART",
 333                 );
 334
 335     ## The type of a MARC record is found at position 06 of the leader
 336     my $typeofrecord = substr("@_", 6, 1);
 337
 338     ## ToDo: for books, field 008 positions 24-27 might have a few more
 339     ## hints
 340
 341     my $typehash;
 342
 343     ## the ukmarc here is just a guess
 344     if ($intype eq "marc21" || $intype eq "ukmarc") {
 345         $typehash = $ustypehash;
 346     }
 347     elsif ($intype eq "unimarc") {
 348         $typehash = $unitypehash;
 349     }
 350     else {
 351         ## assume MARC21 as default
 352         $typehash = $ustypehash;
 353     }
 354
 355     if (!exists $typehash{$typeofrecord}) {
 356         print "\nTY  - BOOK\n"; ## most reasonable default
 357         warn ("no type found - assume BOOK");
 358     }
 359     else {
 360         print "\nTY  - $typehash{$typeofrecord}\n";
 361     }
 362
 363     ## use $typeofrecord as the return value, just in case
 364     $typeofrecord;
 365 }
 366
 367 ##********************************************************************
 368 ## normalize_author(): normalizes an authorname
 369 ## Arguments: authorname subfield a
 370 ##            authorname subfield b
 371 ##            authorname subfield c
 372 ##            name type if known: 0=direct order
 373 ##                               1=only surname or full name in
 374 ##                                 inverted order
 375 ##                               3=family, clan, dynasty name
 376 ## Returns: the normalized authorname
 377 ##********************************************************************
 378 sub normalize_author {
 379     my($rawauthora, $rawauthorb, $rawauthorc, $nametype) = @_;
 380
 381     if ($nametype == 0) {
 382         # ToDo: convert every input to Last[,(F.|First)[ (M.|Middle)[,Suffix]]]
 383         warn("name >>$rawauthora<< in direct order - leave as is");
 384         return $rawauthora;
 385     }
 386     elsif ($nametype == 1) {
 387         ## start munging subfield a (the real name part)
 388         ## remove spaces after separators
 389         $rawauthora =~ s%([,.]+) *%$1%g;
 390
 391         ## remove trailing separators after spaces
 392         $rawauthora =~ s% *[,;:/]*$%%;
 393
 394         ## remove periods after a non-abbreviated name
 395         $rawauthora =~ s%(\w{2,})\.%$1%g;
 396
 397         ## start munging subfield b (something like the suffix)
 398         ## remove trailing separators after spaces
 399         $rawauthorb =~ s% *[,;:/]*$%%;
 400
 401         ## we currently ignore subfield c until someone complains
 402         if (length($rawauthorb) > 0) {
 403             return join ",", ($rawauthora, $rawauthorb);
 404         }
 405         else {
 406             return $rawauthora;
 407         }
 408     }
 409     elsif ($nametype == 3) {
 410         return $rawauthora;
 411     }
 412 }
 413
 414 ##********************************************************************
 415 ## get_author(): gets authorname info from MARC fields 100, 700
 416 ## Argument: field (100 or 700)
 417 ## Returns: an author string in the format found in the record
 418 ##********************************************************************
 419 sub get_author {
 420     my ($authorfield) = @_;
 421     my ($indicator);
 422
 423     ## the sequence of the name parts is encoded either in indicator
 424     ## 1 (marc21) or 2 (unimarc)
 425     if ($intype eq "unimarc") {
 426         $indicator = 2;
 427     }
 428     else { ## assume marc21
 429         $indicator = 1;
 430     }
 431
 432     print "<marc>:Author(Ind$indicator): ", $authorfield->indicator("$indicator"),"\n" if $marcprint;
 433     print "<marc>:Author(\$a): ", $authorfield->subfield('a'),"\n" if $marcprint;
 434     print "<marc>:Author(\$b): ", $authorfield->subfield('b'),"\n" if $marcprint;
 435     print "<marc>:Author(\$c): ", $authorfield->subfield('c'),"\n" if $marcprint;
 436     print "<marc>:Author(\$h): ", $authorfield->subfield('h'),"\n" if $marcprint;
 437     if ($intype eq "ukmarc") {
 438         my $authorname = $authorfield->subfield('a') . "," . $authorfield->subfield('h');
 439         normalize_author($authorname, $authorfield->subfield('b'), $authorfield->subfield('c'), $authorfield->indicator("$indicator"));
 440     }
 441     else {
 442         normalize_author($authorfield->subfield('a'), $authorfield->subfield('b'), $authorfield->subfield('c'), $authorfield->indicator("$indicator"));
 443     }
 444 }
 445
 446 ##********************************************************************
 447 ## get_editor(): gets editor info from MARC fields 110, 111, 710, 711
 448 ## Argument: field (110, 111, 710, or 711)
 449 ## Returns: an author string in the format found in the record
 450 ##********************************************************************
 451 sub get_editor {
 452     my ($editorfield) = @_;
 453
 454     if ($editorfield == undef) {
 455         return undef;
 456     }
 457     else {
 458         print "<marc>Editor(\$a): ", $editorfield->subfield('a'),"\n" if $marcprint;
 459         print "<marc>Editor(\$b): ", $editorfield->subfield('b'),"\n" if $marcprint;
 460         print "<marc>editor(\$c): ", $editorfield->subfield('c'),"\n" if $marcprint;
 461         return $editorfield->subfield('a');
 462     }
 463 }
 464
 465 ##********************************************************************
 466 ## print_title(): gets info from MARC field 245
 467 ## Arguments: field (245)
 468 ## Returns:
 469 ##********************************************************************
 470 sub print_title {
 471     my ($titlefield) = @_;
 472     if ($titlefield == undef) {
 473         print "<marc>empty title field (245)\n" if $marcprint;
 474         warn("empty title field (245)");
 475         @_;
 476     }
 477     else {
 478         print "<marc>Title(\$a): ",$titlefield->subfield('a'),"\n" if $marcprint;
 479         print "<marc>Title(\$b): ",$titlefield->subfield('b'),"\n" if $marcprint;
 480         print "<marc>Title(\$c): ",$titlefield->subfield('c'),"\n" if $marcprint;
 481
 482         ## The title is usually written in a very odd notation. The title
 483         ## proper ($a) often ends with a space followed by a separator like
 484         ## a slash or a colon. The subtitle ($b) doesn't start with a space
 485         ## so simple concatenation looks odd. We have to conditionally remove
 486         ## the separator and make sure there's a space between title and
 487         ## subtitle
 488
 489         my $clean_title = $titlefield->subfield('a');
 490
 491         my $clean_subtitle = $titlefield->subfield('b');
 492         $clean_title =~ s% *[/:;.]$%%;
 493         $clean_subtitle =~ s%^ *(.*) *[/:;.]$%$1%;
 494
 495         if (length($clean_title) > 0
 496             || (length($clean_subtitle) > 0 && $intype ne "unimarc")) {
 497             print "TI  - ", &charconv($clean_title);
 498
 499             ## subfield $b is relevant only for marc21/ukmarc
 500             if (length($clean_subtitle) > 0 && $intype ne "unimarc") {
 501                 print ": ",&charconv($clean_subtitle);
 502             }
 503             print "\n";
 504         }
 505
 506         ## The statement of responsibility is just this: horrors. There is
 507         ## no formal definition how authors, editors and the like should
 508         ## be written and designated. The field is free-form and resistant
 509         ## to all parsing efforts, so this information is lost on me
 510     }
 511  }
 512
 513 ##********************************************************************
 514 ## print_stitle(): prints info from series title field
 515 ## Arguments: field
 516 ## Returns:
 517 ##********************************************************************
 518 sub print_stitle {
 519     my ($titlefield) = @_;
 520
 521     if ($titlefield == undef) {
 522         print "<marc>empty series title field\n" if $marcprint;
 523         warn("empty series title field");
 524         @_;
 525     }
 526     else {
 527         print "<marc>Series title(\$a): ",$titlefield->subfield('a'),"\n" if $marcprint;
 528         my $clean_title = $titlefield->subfield('a');
 529
 530         $clean_title =~ s% *[/:;.]$%%;
 531
 532         if (length($clean_title) > 0) {
 533             print "T2  - ", &charconv($clean_title);
 534         }
 535
 536         if ($intype eq "unimarc") {
 537             print "<marc>Series vol(\$v): ",$titlefield->subfield('v'),"\n" if $marcprint;
 538             if (length($titlefield->subfield('v')) > 0) {
 539                 print "VL  - ", &charconv($titlefield->subfield('v'));
 540             }
 541         }
 542     }
 543  }
 544
 545 ##********************************************************************
 546 ## print_isbn(): gets info from MARC field 020
 547 ## Arguments: field (020)
 548 ##********************************************************************
 549 sub print_isbn {
 550     my($isbnfield) = @_;
 551
 552     if ($isbnfield == undef ||length ($isbnfield->subfield('a')) == 0) {
 553         print "<marc>no isbn found (020\$a)\n" if $marcprint;
 554         warn("no isbn found");
 555     }
 556     else {
 557         if (length ($isbnfield->subfield('a')) < 10) {
 558             print "<marc>truncated isbn (020\$a)\n" if $marcprint;
 559             warn("truncated isbn");
 560         }
 561
 562         my $isbn = substr($isbnfield->subfield('a'), 0, 10);
 563         print "SN  - ", &charconv($isbn), "\n";
 564     }
 565 }
 566
 567 ##********************************************************************
 568 ## print_issn(): gets info from MARC field 022
 569 ## Arguments: field (022)
 570 ##********************************************************************
 571 sub print_issn {
 572     my($issnfield) = @_;
 573
 574     if ($issnfield == undef ||length ($issnfield->subfield('a')) == 0) {
 575         print "<marc>no issn found (022\$a)\n" if $marcprint;
 576         warn("no issn found");
 577     }
 578     else {
 579         if (length ($issnfield->subfield('a')) < 9) {
 580             print "<marc>truncated issn (022\$a)\n" if $marcprint;
 581             warn("truncated issn");
 582         }
 583
 584         my $issn = substr($issnfield->subfield('a'), 0, 9);
 585         print "SN  - ", &charconv($issn), "\n";
 586     }
 587 }
 588
 589 ##********************************************************************
 590 ## print_loc_callno(): gets info from MARC field 050
 591 ## Arguments: field (050)
 592 ##********************************************************************
 593 sub print_loc_callno {
 594     my($callnofield) = @_;
 595
 596     if ($callnofield == undef || length ($callnofield->subfield('a')) == 0) {
 597         print "<marc>no LOC call number found (050\$a)\n" if $marcprint;
 598         warn("no LOC call number found");
 599     }
 600     else {
 601         print "AV  - ", &charconv($callnofield->subfield('a')), " ", &charconv($callnofield->subfield('b')), "\n";
 602     }
 603 }
 604
 605 ##********************************************************************
 606 ## print_dewey(): gets info from MARC field 082
 607 ## Arguments: field (082)
 608 ##********************************************************************
 609 sub print_dewey {
 610     my($deweyfield) = @_;
 611
 612     if ($deweyfield == undef || length ($deweyfield->subfield('a')) == 0) {
 613         print "<marc>no Dewey number found (082\$a)\n" if $marcprint;
 614         warn("no Dewey number found");
 615     }
 616     else {
 617         print "U1  - ", &charconv($deweyfield->subfield('a')), " ", &charconv($deweyfield->subfield('2')), "\n";
 618     }
 619 }
 620
 621 ##********************************************************************
 622 ## print_pubinfo(): gets info from MARC field 260
 623 ## Arguments: field (260)
 624 ##********************************************************************
 625 sub print_pubinfo {
 626     my($pubinfofield) = @_;
 627
 628     if ($pubinfofield == undef) {
 629         print "<marc>no publication information found (260)\n" if $marcprint;
 630         warn("no publication information found");
 631     }
 632     else {
 633         ## the following information is available in MARC21:
 634         ## $a place -> CY
 635         ## $b publisher -> PB
 636         ## $c date -> PY
 637         ## the corresponding subfields for UNIMARC:
 638         ## $a place -> CY
 639         ## $c publisher -> PB
 640         ## $d date -> PY
 641
 642         ## all of them are repeatable. We pool all places into a
 643         ## comma-separated list in CY. We also pool all publishers
 644         ## into a comma-separated list in PB.  We break the rule with
 645         ## the date field because this wouldn't make much sense. In
 646         ## this case, we use the first occurrence for PY, the second
 647         ## for Y2, and ignore the rest
 648
 649         my @pubsubfields = $pubinfofield->subfields();
 650         my @cities;
 651         my @publishers;
 652         my $pycounter = 0;
 653
 654         my $pubsub_place;
 655         my $pubsub_publisher;
 656         my $pubsub_date;
 657
 658         if ($intype eq "unimarc") {
 659             $pubsub_place = "a";
 660             $pubsub_publisher = "c";
 661             $pubsub_date = "d";
 662         }
 663         else { ## assume marc21
 664             $pubsub_place = "a";
 665             $pubsub_publisher = "b";
 666             $pubsub_date = "c";
 667         }
 668
 669         ## loop over all subfield list entries
 670         for my $tuple (@pubsubfields) {
 671             ## each tuple consists of the subfield code and the value
 672             if (@$tuple[0] eq $pubsub_place) {
 673                 ## strip any trailing crap
 674                 $_ = @$tuple[1];
 675                 s% *[,;:/]$%%;
 676                 ## pool all occurrences in a list
 677                 push (@cities, $_);
 678             }
 679             elsif (@$tuple[0] eq $pubsub_publisher) {
 680                 ## strip any trailing crap
 681                 $_ = @$tuple[1];
 682                 s% *[,;:/]$%%;
 683                 ## pool all occurrences in a list
 684                 push (@publishers, $_);
 685             }
 686             elsif (@$tuple[0] eq $pubsub_date) {
 687                 ## the dates are free-form, so we want to extract
 688                 ## a four-digit year and leave the rest as
 689                 ## "other info"
 690                 $protoyear = @$tuple[1];
 691                 print "<marc>Year (260\$c): $protoyear\n" if $marcprint;
 692
 693                 ## strip any separator chars at the end
 694                 $protoyear =~ s% *[\.;:/]*$%%;
 695
 696                 ## isolate a four-digit year. We discard anything
 697                 ## preceeding the year, but keep everything after
 698                 ## the year as other info.
 699                 $protoyear =~ s%\D*([0-9\-]{4})(.*)%$1///$2%;
 700
 701                 ## check what we've got. If there is no four-digit
 702                 ## year, make it up. If digits are replaced by '-',
 703                 ## replace those with 0s
 704
 705                 if (index($protoyear, "/") == 4) {
 706                     ## have year info
 707                     ## replace all '-' in the four-digit year
 708                     ## by '0'
 709                     substr($protoyear,0,4) =~ s!-!0!g;
 710                 }
 711                 else {
 712                     ## have no year info
 713                     print "<marc>no four-digit year found, use 0000\n" if $marcprint;
 714                     $protoyear = "0000///$protoyear";
 715                     warn("no four-digit year found, use 0000");
 716                 }
 717
 718                 if ($pycounter == 0 && length($protoyear)) {
 719                     print "PY  - $protoyear\n";
 720                 }
 721                 elsif ($pycounter == 1 && length($_)) {
 722                     print "Y2  - $protoyear\n";
 723                 }
 724                 ## else: discard
 725             }
 726             ## else: discard
 727         }
 728
 729         ## now dump the collected CY and PB lists
 730         if (@cities > 0) {
 731             print "CY  - ", &charconv(join(", ", @cities)), "\n";
 732         }
 733         if (@publishers > 0) {
 734             print "PB  - ", &charconv(join(", ", @publishers)), "\n";
 735         }
 736     }
 737 }
 738
 739 ##********************************************************************
 740 ## get_keywords(): prints info from MARC fields 6XX
 741 ## Arguments: list of fields (6XX)
 742 ##********************************************************************
 743 sub get_keywords {
 744     my($href, $fieldname, @keywords) = @_;
 745
 746     ## a list of all possible subfields
 747     my @subfields = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'x', 'y', 'z', '2', '3', '4');
 748
 749     ## loop over all 6XX fields
 750     foreach $kwfield (@keywords) {
 751         if ($kwfield != undef) {
 752             ## authornames get special treatment
 753             if ($fieldname eq "600") {
 754                 my $val = normalize_author($kwfield->subfield('a'), $kwfield->subfield('b'), $kwfield->subfield('c'), $kwfield->indicator('1'));
 755                 ${$href}{$val} += 1;
 756                 print "<marc>Field $kwfield subfield a:", $kwfield->subfield('a'), "\n<marc>Field $kwfield subfield b:", $kwfield->subfield('b'), "\n<marc>Field $kwfield subfield c:", $kwfield->subfield('c'), "\n" if $marcprint;
 757             }
 758             else {
 759                 ## retrieve all available subfields
 760                 @kwsubfields = $kwfield->subfields();
 761
 762                 ## loop over all available subfield tuples
 763                 foreach $kwtuple (@kwsubfields) {
 764                     ## loop over all subfields to check
 765                     foreach $subfield (@subfields) {
 766                         ## [0] contains subfield code
 767                         if (@$kwtuple[0] eq $subfield) {
 768                             ## [1] contains value, remove trailing separators
 769                             @$kwtuple[1] =~ s% *[,;.:/]*$%%;
 770                             if (length(@$kwtuple[1]) > 0) {
 771                                 ## add to hash
 772                                 ${$href}{@$kwtuple[1]} += 1;
 773                                 print "<marc>Field $fieldname subfield $subfield:", @$kwtuple[1], "\n" if $marcprint;
 774                             }
 775                             ## we can leave the subfields loop here
 776                             last;
 777                         }
 778                     }
 779                 }
 780             }
 781         }
 782     }
 783 }
 784
 785 ##********************************************************************
 786 ## pool_subx(): adds contents of several subfields to a list
 787 ## Arguments: reference to a list
 788 ##            field name
 789 ##            list of fields (5XX)
 790 ##********************************************************************
 791 sub pool_subx {
 792     my($aref, $fieldname, @notefields) = @_;
 793
 794     ## we use a list that contains the interesting subfields
 795     ## for each field
 796     # ToDo: this is apparently correct only for marc21
 797     my @subfields;
 798
 799     if ($fieldname eq "500") {
 800         @subfields = ('a');
 801     }
 802     elsif ($fieldname eq "501") {
 803         @subfields = ('a');
 804     }
 805     elsif ($fieldname eq "502") {
 806         @subfields = ('a');
 807             }
 808     elsif ($fieldname eq "504") {
 809         @subfields = ('a', 'b');
 810     }
 811     elsif ($fieldname eq "505") {
 812         @subfields = ('a', 'g', 'r', 't', 'u');
 813     }
 814     elsif ($fieldname eq "506") {
 815         @subfields = ('a', 'b', 'c', 'd', 'e');
 816     }
 817     elsif ($fieldname eq "507") {
 818         @subfields = ('a', 'b');
 819     }
 820     elsif ($fieldname eq "508") {
 821         @subfields = ('a');
 822     }
 823     elsif ($fieldname eq "510") {
 824         @subfields = ('a', 'b', 'c', 'x', '3');
 825     }
 826     elsif ($fieldname eq "511") {
 827         @subfields = ('a');
 828     }
 829     elsif ($fieldname eq "513") {
 830         @subfields = ('a', 'b');
 831     }
 832     elsif ($fieldname eq "514") {
 833         @subfields = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'm', 'u', 'z');
 834     }
 835     elsif ($fieldname eq "515") {
 836         @subfields = ('a');
 837     }
 838     elsif ($fieldname eq "516") {
 839         @subfields = ('a');
 840     }
 841     elsif ($fieldname eq "518") {
 842         @subfields = ('a', '3');
 843     }
 844     elsif ($fieldname eq "521") {
 845         @subfields = ('a', 'b', '3');
 846     }
 847     elsif ($fieldname eq "522") {
 848         @subfields = ('a');
 849     }
 850     elsif ($fieldname eq "524") {
 851         @subfields = ('a', '2', '3');
 852     }
 853     elsif ($fieldname eq "525") {
 854         @subfields = ('a');
 855     }
 856     elsif ($fieldname eq "526") {
 857         @subfields = ('a', 'b', 'c', 'd', 'i', 'x', 'z', '5');
 858     }
 859     elsif ($fieldname eq "530") {
 860         @subfields = ('a', 'b', 'c', 'd', 'u', '3');
 861     }
 862     elsif ($fieldname eq "533") {
 863         @subfields = ('a', 'b', 'c', 'd', 'e', 'f', 'm', 'n', '3');
 864     }
 865     elsif ($fieldname eq "534") {
 866         @subfields = ('a', 'b', 'c', 'e', 'f', 'k', 'l', 'm', 'n', 'p', 't', 'x', 'z');
 867     }
 868     elsif ($fieldname eq "535") {
 869         @subfields = ('a', 'b', 'c', 'd', 'g', '3');
 870     }
 871
 872     ## loop over all notefields
 873     foreach $notefield (@notefields) {
 874         if ($notefield != undef) {
 875             ## retrieve all available subfield tuples
 876             @notesubfields = $notefield->subfields();
 877
 878             ## loop over all subfield tuples
 879             foreach $notetuple (@notesubfields) {
 880                 ## loop over all subfields to check
 881                 foreach $subfield (@subfields) {
 882                     ## [0] contains subfield code
 883                     if (@$notetuple[0] eq $subfield) {
 884                         ## [1] contains value, remove trailing separators
 885                         print "<marc>field $fieldname subfield $subfield: ", @$notetuple[1], "\n" if $marcprint;
 886                         @$notetuple[1] =~ s% *[,;.:/]*$%%;
 887                         if (length(@$notetuple[1]) > 0) {
 888                             ## add to list
 889                             push @{$aref}, @$notetuple[1];
 890                         }
 891                         last;
 892                     }
 893                 }
 894             }
 895         }
 896     }
 897 }
 898
 899 ##********************************************************************
 900 ## print_abstract(): prints abstract fields
 901 ## Arguments: list of fields (520)
 902 ##********************************************************************
 903 sub print_abstract {
 904     # ToDo: take care of repeatable subfields
 905     my(@abfields) = @_;
 906
 907     ## we check the following subfields
 908     my @subfields = ('a', 'b');
 909
 910     ## we generate a list for all useful strings
 911     my @abstrings;
 912
 913     ## loop over all abfields
 914     foreach $abfield (@abfields) {
 915         foreach $field (@subfields) {
 916             if (length ($abfield->subfield($field)) > 0) {
 917                 my $ab = $abfield->subfield($field);
 918
 919                 print "<marc>field 520 subfield $field: $ab\n" if $marcprint;
 920
 921                 ## strip trailing separators
 922                 $ab =~ s% *[;,:./]*$%%;
 923
 924                 ## add string to the list
 925                 push (@abstrings, $ab);
 926             }
 927         }
 928     }
 929
 930     my $allabs = join "; ", @abstrings;
 931
 932     if (length($allabs) > 0) {
 933         print "N2  - ", &charconv($allabs), "\n";
 934     }
 935
 936 }
 937
 938 ##********************************************************************
 939 ## charconv(): converts to a different charset based on a global var
 940 ## Arguments: string
 941 ## Returns: string
 942 ##********************************************************************
 943 sub charconv {
 944     if ($utf) {
 945         ## return unaltered if already utf-8
 946         return @_;
 947     }
 948     elsif ($uniout eq "t") {
 949         ## convert to utf-8
 950         warn "marc8_to_utf8";
 951         return marc8_to_utf8("@_");
 952     }
 953     else {
 954         ## return unaltered if no utf-8 requested
 955         return @_;
 956     }
 957 }
 958 1;