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