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