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