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