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