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