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 }
 562
 563 ##********************************************************************
 564 ## print_stitle(): prints info from series title field
 565 ## Arguments: field
 566 ## Returns:
 567 ##********************************************************************
 568 sub print_stitle {
 569     my ($titlefield) = @_;
 570
 571     if (!$titlefield) {
 572         print "<marc>empty series title field\r\n" if $marcprint;
 573     }
 574     else {
 575         print "<marc>Series title(\$a): ",$titlefield->subfield('a'),"\r\n" if $marcprint;
 576         my $clean_title = $titlefield->subfield('a');
 577
 578         $clean_title =~ s% *[/:;.]$%%;
 579
 580         if (length($clean_title) > 0) {
 581             print "T2  - ", $clean_title,"\r\n";
 582         }
 583
 584     my $marcflavour = C4::Context->preference("marcflavour");
 585     my $intype = lc($marcflavour);
 586         if ($intype eq "unimarc") {
 587             print "<marc>Series vol(\$v): ",$titlefield->subfield('v'),"\r\n" if $marcprint;
 588             if (length($titlefield->subfield('v')) > 0) {
 589                 print "VL  - ", $titlefield->subfield('v'),"\r\n";
 590             }
 591         }
 592     }
 593 }
 594
 595 ##********************************************************************
 596 ## print_isbn(): gets info from MARC field 020
 597 ## Arguments: field (020)
 598 ##********************************************************************
 599 sub print_isbn {
 600     my($isbnfield) = @_;
 601
 602     if (!$isbnfield || length ($isbnfield->subfield('a')) == 0) {
 603         print "<marc>no isbn found (020\$a)\r\n" if $marcprint;
 604         warn("no isbn found") if $marcprint;
 605     }
 606     else {
 607         if (length ($isbnfield->subfield('a')) < 10) {
 608             print "<marc>truncated isbn (020\$a)\r\n" if $marcprint;
 609             warn("truncated isbn") if $marcprint;
 610         }
 611
 612     my $isbn = $isbnfield->subfield('a');
 613         print "SN  - ", $isbn, "\r\n";
 614     }
 615 }
 616
 617 ##********************************************************************
 618 ## print_issn(): gets info from MARC field 022
 619 ## Arguments: field (022)
 620 ##********************************************************************
 621 sub print_issn {
 622     my($issnfield) = @_;
 623
 624     if (!$issnfield || length ($issnfield->subfield('a')) == 0) {
 625         print "<marc>no issn found (022\$a)\r\n" if $marcprint;
 626         warn("no issn found") if $marcprint;
 627     }
 628     else {
 629         if (length ($issnfield->subfield('a')) < 9) {
 630             print "<marc>truncated issn (022\$a)\r\n" if $marcprint;
 631             warn("truncated issn") if $marcprint;
 632         }
 633
 634         my $issn = substr($issnfield->subfield('a'), 0, 9);
 635         print "SN  - ", $issn, "\r\n";
 636     }
 637 }
 638
 639 ###
 640 # print_uri() prints info from 856 u
 641 ###
 642 sub print_uri {
 643     my @f856s = @_;
 644
 645     foreach my $f856 (@f856s) {
 646         if (my $uri = $f856->subfield('u')) {
 647                 print "UR  - ", $uri, "\r\n";
 648         }
 649     }
 650 }
 651
 652 ##********************************************************************
 653 ## print_loc_callno(): gets info from MARC field 050
 654 ## Arguments: field (050)
 655 ##********************************************************************
 656 sub print_loc_callno {
 657     my($callnofield) = @_;
 658
 659     if (!$callnofield || length ($callnofield->subfield('a')) == 0) {
 660         print "<marc>no LOC call number found (050\$a)\r\n" if $marcprint;
 661         warn("no LOC call number found") if $marcprint;
 662     }
 663     else {
 664         print "AV  - ", $callnofield->subfield('a'), " ", $callnofield->subfield('b'), "\r\n";
 665     }
 666 }
 667
 668 ##********************************************************************
 669 ## print_dewey(): gets info from MARC field 082
 670 ## Arguments: field (082)
 671 ##********************************************************************
 672 sub print_dewey {
 673     my($deweyfield) = @_;
 674
 675     if (!$deweyfield || length ($deweyfield->subfield('a')) == 0) {
 676         print "<marc>no Dewey number found (082\$a)\r\n" if $marcprint;
 677         warn("no Dewey number found") if $marcprint;
 678     }
 679     else {
 680         print "U1  - ", $deweyfield->subfield('a'), " ", $deweyfield->subfield('2'), "\r\n";
 681     }
 682 }
 683
 684 ##********************************************************************
 685 ## print_pubinfo(): gets info from MARC field 260
 686 ## Arguments: field (260)
 687 ##********************************************************************
 688 sub print_pubinfo {
 689     my($pubinfofield) = @_;
 690
 691     if (!$pubinfofield) {
 692     print "<marc>no publication information found (260/264)\r\n" if $marcprint;
 693         warn("no publication information found") if $marcprint;
 694     }
 695     else {
 696         ## the following information is available in MARC21:
 697         ## $a place -> CY
 698         ## $b publisher -> PB
 699         ## $c date -> PY
 700         ## the corresponding subfields for UNIMARC:
 701         ## $a place -> CY
 702         ## $c publisher -> PB
 703         ## $d date -> PY
 704
 705         ## all of them are repeatable. We pool all places into a
 706         ## comma-separated list in CY. We also pool all publishers
 707         ## into a comma-separated list in PB.  We break the rule with
 708         ## the date field because this wouldn't make much sense. In
 709         ## this case, we use the first occurrence for PY, the second
 710         ## for Y2, and ignore the rest
 711
 712         my @pubsubfields = $pubinfofield->subfields();
 713         my @cities;
 714         my @publishers;
 715         my $pycounter = 0;
 716
 717         my $pubsub_place;
 718         my $pubsub_publisher;
 719         my $pubsub_date;
 720
 721     my $marcflavour = C4::Context->preference("marcflavour");
 722     my $intype = lc($marcflavour);
 723         if ($intype eq "unimarc") {
 724             $pubsub_place = "a";
 725             $pubsub_publisher = "c";
 726             $pubsub_date = "d";
 727         }
 728         else { ## assume marc21
 729             $pubsub_place = "a";
 730             $pubsub_publisher = "b";
 731             $pubsub_date = "c";
 732         }
 733
 734         ## loop over all subfield list entries
 735         for my $tuple (@pubsubfields) {
 736             ## each tuple consists of the subfield code and the value
 737             if (@$tuple[0] eq $pubsub_place) {
 738                 ## strip any trailing crap
 739                 $_ = @$tuple[1];
 740                 s% *[,;:/]$%%;
 741                 ## pool all occurrences in a list
 742                 push (@cities, $_);
 743             }
 744             elsif (@$tuple[0] eq $pubsub_publisher) {
 745                 ## strip any trailing crap
 746                 $_ = @$tuple[1];
 747                 s% *[,;:/]$%%;
 748                 ## pool all occurrences in a list
 749                 push (@publishers, $_);
 750             }
 751             elsif (@$tuple[0] eq $pubsub_date) {
 752                 ## the dates are free-form, so we want to extract
 753                 ## a four-digit year and leave the rest as
 754                 ## "other info"
 755         my $protoyear = @$tuple[1];
 756                 print "<marc>Year (260\$c): $protoyear\r\n" if $marcprint;
 757
 758                 ## strip any separator chars at the end
 759                 $protoyear =~ s% *[\.;:/]*$%%;
 760
 761                 ## isolate a four-digit year. We discard anything
 762         ## preceding the year, but keep everything after
 763                 ## the year as other info.
 764                 $protoyear =~ s%\D*([0-9\-]{4})(.*)%$1///$2%;
 765
 766                 ## check what we've got. If there is no four-digit
 767                 ## year, make it up. If digits are replaced by '-',
 768                 ## replace those with 0s
 769
 770                 if (index($protoyear, "/") == 4) {
 771                     ## have year info
 772                     ## replace all '-' in the four-digit year
 773                     ## by '0'
 774                     substr($protoyear,0,4) =~ s!-!0!g;
 775                 }
 776                 else {
 777                     ## have no year info
 778                     print "<marc>no four-digit year found, use 0000\r\n" if $marcprint;
 779                     $protoyear = "0000///$protoyear";
 780                     warn("no four-digit year found, use 0000") if $marcprint;
 781                 }
 782
 783                 if ($pycounter == 0 && length($protoyear)) {
 784                     print "PY  - $protoyear\r\n";
 785                 }
 786                 elsif ($pycounter == 1 && length($_)) {
 787                     print "Y2  - $protoyear\r\n";
 788                 }
 789                 ## else: discard
 790             }
 791             ## else: discard
 792         }
 793
 794         ## now dump the collected CY and PB lists
 795         if (@cities > 0) {
 796             print "CY  - ", join(", ", @cities), "\r\n";
 797         }
 798         if (@publishers > 0) {
 799             print "PB  - ", join(", ", @publishers), "\r\n";
 800         }
 801     }
 802 }
 803
 804 ##********************************************************************
 805 ## get_keywords(): prints info from MARC fields 6XX
 806 ## Arguments: list of fields (6XX)
 807 ##********************************************************************
 808 sub get_keywords {
 809     my($fieldname, @keywords) = @_;
 810
 811     my @kw;
 812     ## a list of all possible subfields
 813     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');
 814
 815     ## loop over all 6XX fields
 816     foreach my $kwfield (@keywords) {
 817         if ($kwfield != undef) {
 818             ## authornames get special treatment
 819             if ($fieldname eq "600") {
 820                 my $val = normalize_author($kwfield->subfield('a'), $kwfield->subfield('b'), $kwfield->subfield('c'), $kwfield->indicator('1'));
 821                 push @kw, $val;
 822                 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;
 823             }
 824             else {
 825                 ## retrieve all available subfields
 826                 my @kwsubfields = $kwfield->subfields();
 827
 828                 ## loop over all available subfield tuples
 829                 foreach my $kwtuple (@kwsubfields) {
 830                     ## loop over all subfields to check
 831                     foreach my $subfield (@subfields) {
 832                         ## [0] contains subfield code
 833                         if (@$kwtuple[0] eq $subfield) {
 834                             ## [1] contains value, remove trailing separators
 835                             @$kwtuple[1] =~ s% *[,;.:/]*$%%;
 836                             if (length(@$kwtuple[1]) > 0) {
 837                                 push @kw, @$kwtuple[1];
 838                                 print "<marc>Field $fieldname subfield $subfield:", @$kwtuple[1], "\r\n" if $marcprint;
 839                             }
 840                             ## we can leave the subfields loop here
 841                             last;
 842                         }
 843                     }
 844                 }
 845             }
 846         }
 847     }
 848     return @kw;
 849 }
 850
 851 ##********************************************************************
 852 ## pool_subx(): adds contents of several subfields to a list
 853 ## Arguments: reference to a list
 854 ##            field name
 855 ##            list of fields (5XX)
 856 ##********************************************************************
 857 sub pool_subx {
 858     my($aref, $fieldname, @notefields) = @_;
 859
 860     ## we use a list that contains the interesting subfields
 861     ## for each field
 862     # ToDo: this is apparently correct only for marc21
 863     my @subfields;
 864
 865     if ($fieldname eq "500") {
 866         @subfields = ('a');
 867     }
 868     elsif ($fieldname eq "501") {
 869         @subfields = ('a');
 870     }
 871     elsif ($fieldname eq "502") {
 872         @subfields = ('a');
 873             }
 874     elsif ($fieldname eq "504") {
 875         @subfields = ('a', 'b');
 876     }
 877     elsif ($fieldname eq "505") {
 878         @subfields = ('a', 'g', 'r', 't', 'u');
 879     }
 880     elsif ($fieldname eq "506") {
 881         @subfields = ('a', 'b', 'c', 'd', 'e');
 882     }
 883     elsif ($fieldname eq "507") {
 884         @subfields = ('a', 'b');
 885     }
 886     elsif ($fieldname eq "508") {
 887         @subfields = ('a');
 888     }
 889     elsif ($fieldname eq "510") {
 890         @subfields = ('a', 'b', 'c', 'x', '3');
 891     }
 892     elsif ($fieldname eq "511") {
 893         @subfields = ('a');
 894     }
 895     elsif ($fieldname eq "513") {
 896         @subfields = ('a', 'b');
 897     }
 898     elsif ($fieldname eq "514") {
 899         @subfields = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'm', 'u', 'z');
 900     }
 901     elsif ($fieldname eq "515") {
 902         @subfields = ('a');
 903     }
 904     elsif ($fieldname eq "516") {
 905         @subfields = ('a');
 906     }
 907     elsif ($fieldname eq "518") {
 908         @subfields = ('a', '3');
 909     }
 910     elsif ($fieldname eq "521") {
 911         @subfields = ('a', 'b', '3');
 912     }
 913     elsif ($fieldname eq "522") {
 914         @subfields = ('a');
 915     }
 916     elsif ($fieldname eq "524") {
 917         @subfields = ('a', '2', '3');
 918     }
 919     elsif ($fieldname eq "525") {
 920         @subfields = ('a');
 921     }
 922     elsif ($fieldname eq "526") {
 923         @subfields = ('a', 'b', 'c', 'd', 'i', 'x', 'z', '5');
 924     }
 925     elsif ($fieldname eq "530") {
 926         @subfields = ('a', 'b', 'c', 'd', 'u', '3');
 927     }
 928     elsif ($fieldname eq "533") {
 929         @subfields = ('a', 'b', 'c', 'd', 'e', 'f', 'm', 'n', '3');
 930     }
 931     elsif ($fieldname eq "534") {
 932         @subfields = ('a', 'b', 'c', 'e', 'f', 'k', 'l', 'm', 'n', 'p', 't', 'x', 'z');
 933     }
 934     elsif ($fieldname eq "535") {
 935         @subfields = ('a', 'b', 'c', 'd', 'g', '3');
 936     }
 937
 938     ## loop over all notefields
 939     foreach my $notefield (@notefields) {
 940         if (defined $notefield) {
 941             ## retrieve all available subfield tuples
 942             my @notesubfields = $notefield->subfields();
 943
 944             ## loop over all subfield tuples
 945             foreach my $notetuple (@notesubfields) {
 946                 ## loop over all subfields to check
 947                 foreach my $subfield (@subfields) {
 948                     ## [0] contains subfield code
 949                     if (@$notetuple[0] eq $subfield) {
 950                         ## [1] contains value, remove trailing separators
 951                         print "<marc>field $fieldname subfield $subfield: ", @$notetuple[1], "\r\n" if $marcprint;
 952                         @$notetuple[1] =~ s% *[,;.:/]*$%%;
 953                         if (length(@$notetuple[1]) > 0) {
 954                             ## add to list
 955                             push @{$aref}, @$notetuple[1];
 956                         }
 957                         last;
 958                     }
 959                 }
 960             }
 961         }
 962     }
 963 }
 964
 965 ##********************************************************************
 966 ## print_abstract(): prints abstract fields
 967 ## Arguments: list of fields (520)
 968 ##********************************************************************
 969 sub print_abstract {
 970     # ToDo: take care of repeatable subfields
 971     my(@abfields) = @_;
 972
 973     ## we check the following subfields
 974     my @subfields = ('a', 'b');
 975
 976     ## we generate a list for all useful strings
 977     my @abstrings;
 978
 979     ## loop over all abfields
 980     foreach my $abfield (@abfields) {
 981         foreach my $field (@subfields) {
 982             if ( length( $abfield->subfield($field) ) > 0 ) {
 983                 my $ab = $abfield->subfield($field);
 984
 985                 print "<marc>field 520 subfield $field: $ab\r\n" if $marcprint;
 986
 987                 ## strip trailing separators
 988                 $ab =~ s% *[;,:./]*$%%;
 989
 990                 ## add string to the list
 991                 push( @abstrings, $ab );
 992             }
 993         }
 994     }
 995
 996     my $allabs = join "; ", @abstrings;
 997
 998     if (length($allabs) > 0) {
 999         print "N2  - ", $allabs, "\r\n";
1000     }
1001
1002 }
1003
1004 1;