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 = 0; # Debug flag;
  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>---\r\n<marc>UTF-8 data\r\n" if $marcprint;
 109                 $utf = 1;
 110             }
 111             else {
 112                 print "<marc>---\r\n<marc>MARC-8 data\r\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),"\r\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),"\r\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('490'));
 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), "\r\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), "\r\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  - \r\n";
 280
 281     # Let's re-redirect stdout
 282     close STDOUT;
 283     open STDOUT, ">&", $oldout;
 284
 285     return $outvar;
 286
 287 }
 288
 289
 290 ##********************************************************************
 291 ## print_typetag(): prints the first line of a RIS dataset including
 292 ## the preceeding newline
 293 ## Argument: the leader of a MARC dataset
 294 ## Returns: the value at leader position 06
 295 ##********************************************************************
 296 sub print_typetag {
 297   my ($leader)= @_;
 298     ## the keys of typehash are the allowed values at position 06
 299     ## of the leader of a MARC record, the values are the RIS types
 300     ## that might appropriately represent these types.
 301     my %ustypehash = (
 302                     "a" => "BOOK",
 303                     "c" => "MUSIC",
 304                     "d" => "MUSIC",
 305                     "e" => "MAP",
 306                     "f" => "MAP",
 307                     "g" => "ADVS",
 308                     "i" => "SOUND",
 309                     "j" => "SOUND",
 310                     "k" => "ART",
 311                     "m" => "DATA",
 312                     "o" => "GEN",
 313                     "p" => "GEN",
 314                     "r" => "ART",
 315                     "t" => "GEN",
 316                 );
 317
 318     my %unitypehash = (
 319                     "a" => "BOOK",
 320                     "b" => "BOOK",
 321                     "c" => "MUSIC",
 322                     "d" => "MUSIC",
 323                     "e" => "MAP",
 324                     "f" => "MAP",
 325                     "g" => "ADVS",
 326                     "i" => "SOUND",
 327                     "j" => "SOUND",
 328                     "k" => "ART",
 329                     "l" => "ELEC",
 330                     "m" => "ADVS",
 331                     "r" => "ART",
 332                 );
 333
 334     ## The type of a MARC record is found at position 06 of the leader
 335     my $typeofrecord = substr($leader, 6, 1);
 336
 337     ## ToDo: for books, field 008 positions 24-27 might have a few more
 338     ## hints
 339
 340     my %typehash;
 341
 342     ## the ukmarc here is just a guess
 343     if ($intype eq "marc21" || $intype eq "ukmarc") {
 344         %typehash = %ustypehash;
 345     }
 346     elsif ($intype eq "unimarc") {
 347         %typehash = %unitypehash;
 348     }
 349     else {
 350         ## assume MARC21 as default
 351         %typehash = %ustypehash;
 352     }
 353
 354     if (!exists $typehash{$typeofrecord}) {
 355         print "TY  - BOOK\r\n"; ## most reasonable default
 356         warn ("no type found - assume BOOK") if $marcprint;
 357     }
 358     else {
 359         print "TY  - $typehash{$typeofrecord}\r\n";
 360     }
 361
 362     ## use $typeofrecord as the return value, just in case
 363     $typeofrecord;
 364 }
 365
 366 ##********************************************************************
 367 ## normalize_author(): normalizes an authorname
 368 ## Arguments: authorname subfield a
 369 ##            authorname subfield b
 370 ##            authorname subfield c
 371 ##            name type if known: 0=direct order
 372 ##                               1=only surname or full name in
 373 ##                                 inverted order
 374 ##                               3=family, clan, dynasty name
 375 ## Returns: the normalized authorname
 376 ##********************************************************************
 377 sub normalize_author {
 378     my($rawauthora, $rawauthorb, $rawauthorc, $nametype) = @_;
 379
 380     if ($nametype == 0) {
 381         # ToDo: convert every input to Last[,(F.|First)[ (M.|Middle)[,Suffix]]]
 382         warn("name >>$rawauthora<< in direct order - leave as is") if $marcprint;
 383         return $rawauthora;
 384     }
 385     elsif ($nametype == 1) {
 386         ## start munging subfield a (the real name part)
 387         ## remove spaces after separators
 388         $rawauthora =~ s%([,.]+) *%$1%g;
 389
 390         ## remove trailing separators after spaces
 391         $rawauthora =~ s% *[,;:/]*$%%;
 392
 393         ## remove periods after a non-abbreviated name
 394         $rawauthora =~ s%(\w{2,})\.%$1%g;
 395
 396         ## start munging subfield b (something like the suffix)
 397         ## remove trailing separators after spaces
 398         $rawauthorb =~ s% *[,;:/]*$%%;
 399
 400         ## we currently ignore subfield c until someone complains
 401         if (length($rawauthorb) > 0) {
 402             return join ",", ($rawauthora, $rawauthorb);
 403         }
 404         else {
 405             return $rawauthora;
 406         }
 407     }
 408     elsif ($nametype == 3) {
 409         return $rawauthora;
 410     }
 411 }
 412
 413 ##********************************************************************
 414 ## get_author(): gets authorname info from MARC fields 100, 700
 415 ## Argument: field (100 or 700)
 416 ## Returns: an author string in the format found in the record
 417 ##********************************************************************
 418 sub get_author {
 419     my ($authorfield) = @_;
 420     my ($indicator);
 421
 422     ## the sequence of the name parts is encoded either in indicator
 423     ## 1 (marc21) or 2 (unimarc)
 424     if ($intype eq "unimarc") {
 425         $indicator = 2;
 426     }
 427     else { ## assume marc21
 428         $indicator = 1;
 429     }
 430
 431     print "<marc>:Author(Ind$indicator): ", $authorfield->indicator("$indicator"),"\r\n" if $marcprint;
 432     print "<marc>:Author(\$a): ", $authorfield->subfield('a'),"\r\n" if $marcprint;
 433     print "<marc>:Author(\$b): ", $authorfield->subfield('b'),"\r\n" if $marcprint;
 434     print "<marc>:Author(\$c): ", $authorfield->subfield('c'),"\r\n" if $marcprint;
 435     print "<marc>:Author(\$h): ", $authorfield->subfield('h'),"\r\n" if $marcprint;
 436     if ($intype eq "ukmarc") {
 437         my $authorname = $authorfield->subfield('a') . "," . $authorfield->subfield('h');
 438         normalize_author($authorname, $authorfield->subfield('b'), $authorfield->subfield('c'), $authorfield->indicator("$indicator"));
 439     }
 440     else {
 441         normalize_author($authorfield->subfield('a'), $authorfield->subfield('b'), $authorfield->subfield('c'), $authorfield->indicator("$indicator"));
 442     }
 443 }
 444
 445 ##********************************************************************
 446 ## get_editor(): gets editor info from MARC fields 110, 111, 710, 711
 447 ## Argument: field (110, 111, 710, or 711)
 448 ## Returns: an author string in the format found in the record
 449 ##********************************************************************
 450 sub get_editor {
 451     my ($editorfield) = @_;
 452
 453     if (!$editorfield) {
 454         return;
 455     }
 456     else {
 457         print "<marc>Editor(\$a): ", $editorfield->subfield('a'),"\r\n" if $marcprint;
 458         print "<marc>Editor(\$b): ", $editorfield->subfield('b'),"\r\n" if $marcprint;
 459         print "<marc>editor(\$c): ", $editorfield->subfield('c'),"\r\n" if $marcprint;
 460         return $editorfield->subfield('a');
 461     }
 462 }
 463
 464 ##********************************************************************
 465 ## print_title(): gets info from MARC field 245
 466 ## Arguments: field (245)
 467 ## Returns:
 468 ##********************************************************************
 469 sub print_title {
 470     my ($titlefield) = @_;
 471     if (!$titlefield) {
 472         print "<marc>empty title field (245)\r\n" if $marcprint;
 473         warn("empty title field (245)") if $marcprint;
 474     }
 475     else {
 476         print "<marc>Title(\$a): ",$titlefield->subfield('a'),"\r\n" if $marcprint;
 477         print "<marc>Title(\$b): ",$titlefield->subfield('b'),"\r\n" if $marcprint;
 478         print "<marc>Title(\$c): ",$titlefield->subfield('c'),"\r\n" if $marcprint;
 479
 480         ## The title is usually written in a very odd notation. The title
 481         ## proper ($a) often ends with a space followed by a separator like
 482         ## a slash or a colon. The subtitle ($b) doesn't start with a space
 483         ## so simple concatenation looks odd. We have to conditionally remove
 484         ## the separator and make sure there's a space between title and
 485         ## subtitle
 486
 487         my $clean_title = $titlefield->subfield('a');
 488
 489         my $clean_subtitle = $titlefield->subfield('b');
 490         $clean_title =~ s% *[/:;.]$%%;
 491         $clean_subtitle =~ s%^ *(.*) *[/:;.]$%$1%;
 492
 493         if (length($clean_title) > 0
 494             || (length($clean_subtitle) > 0 && $intype ne "unimarc")) {
 495             print "TI  - ", &charconv($clean_title);
 496
 497             ## subfield $b is relevant only for marc21/ukmarc
 498             if (length($clean_subtitle) > 0 && $intype ne "unimarc") {
 499                 print ": ",&charconv($clean_subtitle);
 500             }
 501             print "\r\n";
 502         }
 503
 504         ## The statement of responsibility is just this: horrors. There is
 505         ## no formal definition how authors, editors and the like should
 506         ## be written and designated. The field is free-form and resistant
 507         ## to all parsing efforts, so this information is lost on me
 508     }
 509 }
 510
 511 ##********************************************************************
 512 ## print_stitle(): prints info from series title field
 513 ## Arguments: field
 514 ## Returns:
 515 ##********************************************************************
 516 sub print_stitle {
 517     my ($titlefield) = @_;
 518
 519     if (!$titlefield) {
 520         print "<marc>empty series title field\r\n" if $marcprint;
 521     }
 522     else {
 523         print "<marc>Series title(\$a): ",$titlefield->subfield('a'),"\r\n" if $marcprint;
 524         my $clean_title = $titlefield->subfield('a');
 525
 526         $clean_title =~ s% *[/:;.]$%%;
 527
 528         if (length($clean_title) > 0) {
 529             print "T2  - ", &charconv($clean_title),"\r\n";
 530         }
 531
 532         if ($intype eq "unimarc") {
 533             print "<marc>Series vol(\$v): ",$titlefield->subfield('v'),"\r\n" if $marcprint;
 534             if (length($titlefield->subfield('v')) > 0) {
 535                 print "VL  - ", &charconv($titlefield->subfield('v')),"\r\n";
 536             }
 537         }
 538     }
 539 }
 540
 541 ##********************************************************************
 542 ## print_isbn(): gets info from MARC field 020
 543 ## Arguments: field (020)
 544 ##********************************************************************
 545 sub print_isbn {
 546     my($isbnfield) = @_;
 547
 548     if (!$isbnfield || length ($isbnfield->subfield('a')) == 0) {
 549         print "<marc>no isbn found (020\$a)\r\n" if $marcprint;
 550         warn("no isbn found") if $marcprint;
 551     }
 552     else {
 553         if (length ($isbnfield->subfield('a')) < 10) {
 554             print "<marc>truncated isbn (020\$a)\r\n" if $marcprint;
 555             warn("truncated isbn") if $marcprint;
 556         }
 557
 558         my $isbn = substr($isbnfield->subfield('a'), 0, 10);
 559         print "SN  - ", &charconv($isbn), "\r\n";
 560     }
 561 }
 562
 563 ##********************************************************************
 564 ## print_issn(): gets info from MARC field 022
 565 ## Arguments: field (022)
 566 ##********************************************************************
 567 sub print_issn {
 568     my($issnfield) = @_;
 569
 570     if (!$issnfield || length ($issnfield->subfield('a')) == 0) {
 571         print "<marc>no issn found (022\$a)\r\n" if $marcprint;
 572         warn("no issn found") if $marcprint;
 573     }
 574     else {
 575         if (length ($issnfield->subfield('a')) < 9) {
 576             print "<marc>truncated issn (022\$a)\r\n" if $marcprint;
 577             warn("truncated issn") if $marcprint;
 578         }
 579
 580         my $issn = substr($issnfield->subfield('a'), 0, 9);
 581         print "SN  - ", &charconv($issn), "\r\n";
 582     }
 583 }
 584
 585 ##********************************************************************
 586 ## print_loc_callno(): gets info from MARC field 050
 587 ## Arguments: field (050)
 588 ##********************************************************************
 589 sub print_loc_callno {
 590     my($callnofield) = @_;
 591
 592     if (!$callnofield || length ($callnofield->subfield('a')) == 0) {
 593         print "<marc>no LOC call number found (050\$a)\r\n" if $marcprint;
 594         warn("no LOC call number found") if $marcprint;
 595     }
 596     else {
 597         print "AV  - ", &charconv($callnofield->subfield('a')), " ", &charconv($callnofield->subfield('b')), "\r\n";
 598     }
 599 }
 600
 601 ##********************************************************************
 602 ## print_dewey(): gets info from MARC field 082
 603 ## Arguments: field (082)
 604 ##********************************************************************
 605 sub print_dewey {
 606     my($deweyfield) = @_;
 607
 608     if (!$deweyfield || length ($deweyfield->subfield('a')) == 0) {
 609         print "<marc>no Dewey number found (082\$a)\r\n" if $marcprint;
 610         warn("no Dewey number found") if $marcprint;
 611     }
 612     else {
 613         print "U1  - ", &charconv($deweyfield->subfield('a')), " ", &charconv($deweyfield->subfield('2')), "\r\n";
 614     }
 615 }
 616
 617 ##********************************************************************
 618 ## print_pubinfo(): gets info from MARC field 260
 619 ## Arguments: field (260)
 620 ##********************************************************************
 621 sub print_pubinfo {
 622     my($pubinfofield) = @_;
 623
 624     if (!$pubinfofield) {
 625         print "<marc>no publication information found (260)\r\n" if $marcprint;
 626         warn("no publication information found") if $marcprint;
 627     }
 628     else {
 629         ## the following information is available in MARC21:
 630         ## $a place -> CY
 631         ## $b publisher -> PB
 632         ## $c date -> PY
 633         ## the corresponding subfields for UNIMARC:
 634         ## $a place -> CY
 635         ## $c publisher -> PB
 636         ## $d date -> PY
 637
 638         ## all of them are repeatable. We pool all places into a
 639         ## comma-separated list in CY. We also pool all publishers
 640         ## into a comma-separated list in PB.  We break the rule with
 641         ## the date field because this wouldn't make much sense. In
 642         ## this case, we use the first occurrence for PY, the second
 643         ## for Y2, and ignore the rest
 644
 645         my @pubsubfields = $pubinfofield->subfields();
 646         my @cities;
 647         my @publishers;
 648         my $pycounter = 0;
 649
 650         my $pubsub_place;
 651         my $pubsub_publisher;
 652         my $pubsub_date;
 653
 654         if ($intype eq "unimarc") {
 655             $pubsub_place = "a";
 656             $pubsub_publisher = "c";
 657             $pubsub_date = "d";
 658         }
 659         else { ## assume marc21
 660             $pubsub_place = "a";
 661             $pubsub_publisher = "b";
 662             $pubsub_date = "c";
 663         }
 664
 665         ## loop over all subfield list entries
 666         for my $tuple (@pubsubfields) {
 667             ## each tuple consists of the subfield code and the value
 668             if (@$tuple[0] eq $pubsub_place) {
 669                 ## strip any trailing crap
 670                 $_ = @$tuple[1];
 671                 s% *[,;:/]$%%;
 672                 ## pool all occurrences in a list
 673                 push (@cities, $_);
 674             }
 675             elsif (@$tuple[0] eq $pubsub_publisher) {
 676                 ## strip any trailing crap
 677                 $_ = @$tuple[1];
 678                 s% *[,;:/]$%%;
 679                 ## pool all occurrences in a list
 680                 push (@publishers, $_);
 681             }
 682             elsif (@$tuple[0] eq $pubsub_date) {
 683                 ## the dates are free-form, so we want to extract
 684                 ## a four-digit year and leave the rest as
 685                 ## "other info"
 686                 $protoyear = @$tuple[1];
 687                 print "<marc>Year (260\$c): $protoyear\r\n" if $marcprint;
 688
 689                 ## strip any separator chars at the end
 690                 $protoyear =~ s% *[\.;:/]*$%%;
 691
 692                 ## isolate a four-digit year. We discard anything
 693                 ## preceeding the year, but keep everything after
 694                 ## the year as other info.
 695                 $protoyear =~ s%\D*([0-9\-]{4})(.*)%$1///$2%;
 696
 697                 ## check what we've got. If there is no four-digit
 698                 ## year, make it up. If digits are replaced by '-',
 699                 ## replace those with 0s
 700
 701                 if (index($protoyear, "/") == 4) {
 702                     ## have year info
 703                     ## replace all '-' in the four-digit year
 704                     ## by '0'
 705                     substr($protoyear,0,4) =~ s!-!0!g;
 706                 }
 707                 else {
 708                     ## have no year info
 709                     print "<marc>no four-digit year found, use 0000\r\n" if $marcprint;
 710                     $protoyear = "0000///$protoyear";
 711                     warn("no four-digit year found, use 0000") if $marcprint;
 712                 }
 713
 714                 if ($pycounter == 0 && length($protoyear)) {
 715                     print "PY  - $protoyear\r\n";
 716                 }
 717                 elsif ($pycounter == 1 && length($_)) {
 718                     print "Y2  - $protoyear\r\n";
 719                 }
 720                 ## else: discard
 721             }
 722             ## else: discard
 723         }
 724
 725         ## now dump the collected CY and PB lists
 726         if (@cities > 0) {
 727             print "CY  - ", &charconv(join(", ", @cities)), "\r\n";
 728         }
 729         if (@publishers > 0) {
 730             print "PB  - ", &charconv(join(", ", @publishers)), "\r\n";
 731         }
 732     }
 733 }
 734
 735 ##********************************************************************
 736 ## get_keywords(): prints info from MARC fields 6XX
 737 ## Arguments: list of fields (6XX)
 738 ##********************************************************************
 739 sub get_keywords {
 740     my($href, $fieldname, @keywords) = @_;
 741
 742     ## a list of all possible subfields
 743     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');
 744
 745     ## loop over all 6XX fields
 746     foreach $kwfield (@keywords) {
 747         if ($kwfield != undef) {
 748             ## authornames get special treatment
 749             if ($fieldname eq "600") {
 750                 my $val = normalize_author($kwfield->subfield('a'), $kwfield->subfield('b'), $kwfield->subfield('c'), $kwfield->indicator('1'));
 751                 ${$href}{$val} += 1;
 752                 print "<marc>Field $kwfield subfield a:", $kwfield->subfield('a'), "\r\n<marc>Field $kwfield subfield b:", $kwfield->subfield('b'), "\r\n<marc>Field $kwfield subfield c:", $kwfield->subfield('c'), "\r\n" if $marcprint;
 753             }
 754             else {
 755                 ## retrieve all available subfields
 756                 @kwsubfields = $kwfield->subfields();
 757
 758                 ## loop over all available subfield tuples
 759                 foreach $kwtuple (@kwsubfields) {
 760                     ## loop over all subfields to check
 761                     foreach $subfield (@subfields) {
 762                         ## [0] contains subfield code
 763                         if (@$kwtuple[0] eq $subfield) {
 764                             ## [1] contains value, remove trailing separators
 765                             @$kwtuple[1] =~ s% *[,;.:/]*$%%;
 766                             if (length(@$kwtuple[1]) > 0) {
 767                                 ## add to hash
 768                                 ${$href}{@$kwtuple[1]} += 1;
 769                                 print "<marc>Field $fieldname subfield $subfield:", @$kwtuple[1], "\r\n" if $marcprint;
 770                             }
 771                             ## we can leave the subfields loop here
 772                             last;
 773                         }
 774                     }
 775                 }
 776             }
 777         }
 778     }
 779 }
 780
 781 ##********************************************************************
 782 ## pool_subx(): adds contents of several subfields to a list
 783 ## Arguments: reference to a list
 784 ##            field name
 785 ##            list of fields (5XX)
 786 ##********************************************************************
 787 sub pool_subx {
 788     my($aref, $fieldname, @notefields) = @_;
 789
 790     ## we use a list that contains the interesting subfields
 791     ## for each field
 792     # ToDo: this is apparently correct only for marc21
 793     my @subfields;
 794
 795     if ($fieldname eq "500") {
 796         @subfields = ('a');
 797     }
 798     elsif ($fieldname eq "501") {
 799         @subfields = ('a');
 800     }
 801     elsif ($fieldname eq "502") {
 802         @subfields = ('a');
 803             }
 804     elsif ($fieldname eq "504") {
 805         @subfields = ('a', 'b');
 806     }
 807     elsif ($fieldname eq "505") {
 808         @subfields = ('a', 'g', 'r', 't', 'u');
 809     }
 810     elsif ($fieldname eq "506") {
 811         @subfields = ('a', 'b', 'c', 'd', 'e');
 812     }
 813     elsif ($fieldname eq "507") {
 814         @subfields = ('a', 'b');
 815     }
 816     elsif ($fieldname eq "508") {
 817         @subfields = ('a');
 818     }
 819     elsif ($fieldname eq "510") {
 820         @subfields = ('a', 'b', 'c', 'x', '3');
 821     }
 822     elsif ($fieldname eq "511") {
 823         @subfields = ('a');
 824     }
 825     elsif ($fieldname eq "513") {
 826         @subfields = ('a', 'b');
 827     }
 828     elsif ($fieldname eq "514") {
 829         @subfields = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'm', 'u', 'z');
 830     }
 831     elsif ($fieldname eq "515") {
 832         @subfields = ('a');
 833     }
 834     elsif ($fieldname eq "516") {
 835         @subfields = ('a');
 836     }
 837     elsif ($fieldname eq "518") {
 838         @subfields = ('a', '3');
 839     }
 840     elsif ($fieldname eq "521") {
 841         @subfields = ('a', 'b', '3');
 842     }
 843     elsif ($fieldname eq "522") {
 844         @subfields = ('a');
 845     }
 846     elsif ($fieldname eq "524") {
 847         @subfields = ('a', '2', '3');
 848     }
 849     elsif ($fieldname eq "525") {
 850         @subfields = ('a');
 851     }
 852     elsif ($fieldname eq "526") {
 853         @subfields = ('a', 'b', 'c', 'd', 'i', 'x', 'z', '5');
 854     }
 855     elsif ($fieldname eq "530") {
 856         @subfields = ('a', 'b', 'c', 'd', 'u', '3');
 857     }
 858     elsif ($fieldname eq "533") {
 859         @subfields = ('a', 'b', 'c', 'd', 'e', 'f', 'm', 'n', '3');
 860     }
 861     elsif ($fieldname eq "534") {
 862         @subfields = ('a', 'b', 'c', 'e', 'f', 'k', 'l', 'm', 'n', 'p', 't', 'x', 'z');
 863     }
 864     elsif ($fieldname eq "535") {
 865         @subfields = ('a', 'b', 'c', 'd', 'g', '3');
 866     }
 867
 868     ## loop over all notefields
 869     foreach $notefield (@notefields) {
 870         if ($notefield != undef) {
 871             ## retrieve all available subfield tuples
 872             @notesubfields = $notefield->subfields();
 873
 874             ## loop over all subfield tuples
 875             foreach $notetuple (@notesubfields) {
 876                 ## loop over all subfields to check
 877                 foreach $subfield (@subfields) {
 878                     ## [0] contains subfield code
 879                     if (@$notetuple[0] eq $subfield) {
 880                         ## [1] contains value, remove trailing separators
 881                         print "<marc>field $fieldname subfield $subfield: ", @$notetuple[1], "\r\n" if $marcprint;
 882                         @$notetuple[1] =~ s% *[,;.:/]*$%%;
 883                         if (length(@$notetuple[1]) > 0) {
 884                             ## add to list
 885                             push @{$aref}, @$notetuple[1];
 886                         }
 887                         last;
 888                     }
 889                 }
 890             }
 891         }
 892     }
 893 }
 894
 895 ##********************************************************************
 896 ## print_abstract(): prints abstract fields
 897 ## Arguments: list of fields (520)
 898 ##********************************************************************
 899 sub print_abstract {
 900     # ToDo: take care of repeatable subfields
 901     my(@abfields) = @_;
 902
 903     ## we check the following subfields
 904     my @subfields = ('a', 'b');
 905
 906     ## we generate a list for all useful strings
 907     my @abstrings;
 908
 909     ## loop over all abfields
 910     foreach $abfield (@abfields) {
 911         foreach $field (@subfields) {
 912             if (length ($abfield->subfield($field)) > 0) {
 913                 my $ab = $abfield->subfield($field);
 914
 915                 print "<marc>field 520 subfield $field: $ab\r\n" if $marcprint;
 916
 917                 ## strip trailing separators
 918                 $ab =~ s% *[;,:./]*$%%;
 919
 920                 ## add string to the list
 921                 push (@abstrings, $ab);
 922             }
 923         }
 924     }
 925
 926     my $allabs = join "; ", @abstrings;
 927
 928     if (length($allabs) > 0) {
 929         print "N2  - ", &charconv($allabs), "\r\n";
 930     }
 931
 932 }
 933
 934 ##********************************************************************
 935 ## charconv(): converts to a different charset based on a global var
 936 ## Arguments: string
 937 ## Returns: string
 938 ##********************************************************************
 939 sub charconv {
 940     if ($utf) {
 941         ## return unaltered if already utf-8
 942         return @_;
 943     }
 944     elsif ($uniout eq "t") {
 945         ## convert to utf-8
 946         return marc8_to_utf8("@_");
 947     }
 948     else {
 949         ## return unaltered if no utf-8 requested
 950         return @_;
 951     }
 952 }
 953 1;