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($VERSION @ISA @EXPORT);
  66
  67 use C4::Biblio qw(GetMarcSubfieldStructureFromKohaField);
  68 use Koha::SimpleMARC qw(read_field);
  69
  70 # set the version for version checking
  71 $VERSION = 3.07.00.049;
  72
  73 @ISA = qw(Exporter);
  74
  75 # only export API methods
  76
  77 @EXPORT = qw(
  78   &marc2ris
  79 );
  80
  81 our $marcprint = 0; # Debug flag;
  82
  83 =head1 marc2bibtex - Convert from UNIMARC to RIS
  84
  85   my ($ris) = marc2ris($record);
  86
  87 Returns a RIS scalar
  88
  89 C<$record> - a MARC::Record object
  90
  91 =cut
  92
  93 sub marc2ris {
  94     my ($record) = @_;
  95     my $output;
  96
  97     my $marcflavour = C4::Context->preference("marcflavour");
  98     my $intype = lc($marcflavour);
  99
 100     # Let's redirect stdout
 101     open my $oldout, ">&STDOUT";
 102     my $outvar;
 103     close STDOUT;
 104     open STDOUT,'>:encoding(utf8)', \$outvar;
 105
 106     ## First we should check the character encoding. This may be
 107     ## MARC-8 or UTF-8. The former is indicated by a blank, the latter
 108     ## by 'a' at position 09 (zero-based) of the leader
 109     my $leader = $record->leader();
 110     if ( $intype eq "marc21" ) {
 111         if ( $leader =~ /^.{9}a/ ) {
 112             print "<marc>---\r\n<marc>UTF-8 data\r\n" if $marcprint;
 113         }
 114         else {
 115             print "<marc>---\r\n<marc>MARC-8 data\r\n" if $marcprint;
 116         }
 117     }
 118     ## else: other MARC formats do not specify the character encoding
 119     ## we assume it's *not* UTF-8
 120
 121     my $RisExportAdditionalFields = C4::Context->preference('RisExportAdditionalFields');
 122     my $ris_additional_fields;
 123     if ($RisExportAdditionalFields) {
 124         $RisExportAdditionalFields = "$RisExportAdditionalFields\n\n";
 125         $ris_additional_fields = eval { YAML::Load($RisExportAdditionalFields); };
 126         if ($@) {
 127             warn "Unable to parse RisExportAdditionalFields : $@";
 128             $ris_additional_fields = undef;
 129         }
 130     }
 131
 132     ## start RIS dataset
 133     if ( $ris_additional_fields && $ris_additional_fields->{TY} ) {
 134         my ( $f, $sf ) = split( /\$/, $ris_additional_fields->{TY} );
 135         my ( $type ) = read_field( { record => $record, field => $f, subfield => $sf, field_numbers => [1] } );
 136         if ($type) {
 137             print "TY  - $type\r\n";
 138         }
 139         else {
 140             &print_typetag($leader);
 141         }
 142     }
 143     else {
 144         &print_typetag($leader);
 145     }
 146
 147         ## retrieve all author fields and collect them in a list
 148         my @author_fields;
 149
 150         if ($intype eq "unimarc") {
 151             ## Fields 700, 701, and 702 can contain author names
 152             @author_fields = ($record->field('700'), $record->field('701'), $record->field('702'));
 153         }
 154         else {  ## marc21, ukmarc
 155             ## Field 100 sometimes carries main author
 156             ## Field(s) 700 carry added entries - personal names
 157             @author_fields = ($record->field('100'), $record->field('700'));
 158         }
 159
 160         ## loop over all author fields
 161         foreach my $field (@author_fields) {
 162             if (length($field)) {
 163                 my $author = &get_author($field);
 164                 print "AU  - ",$author,"\r\n";
 165             }
 166         }
 167
 168         # ToDo: should we specify anonymous as author if we didn't find
 169         # one? or use one of the corporate/meeting names below?
 170
 171         ## add corporate names or meeting names as editors ??
 172         my @editor_fields;
 173
 174         if ($intype eq "unimarc") {
 175             ## Fields 710, 711, and 712 can carry corporate names
 176             ## Field(s) 720, 721, 722, 730 have additional candidates
 177             @editor_fields = ($record->field('710'), $record->field('711'), $record->field('712'), $record->field('720'), $record->field('721'), $record->field('722'), $record->field('730'));
 178         }
 179         else { ## marc21, ukmarc
 180             ## Fields 110 and 111 carry the main entries - corporate name and
 181             ## meeting name, respectively
 182             ## Field(s) 710, 711 carry added entries - personal names
 183             @editor_fields = ($record->field('110'), $record->field('111'), $record->field('710'), $record->field('711'));
 184         }
 185
 186         ## loop over all editor fields
 187         foreach my $field (@editor_fields) {
 188             if (length($field)) {
 189                 my $editor = &get_editor($field);
 190                 print "ED  - ",$editor,"\r\n";
 191             }
 192         }
 193
 194         ## get info from the title field
 195         if ($intype eq "unimarc") {
 196             &print_title($record->field('200'));
 197         }
 198         else { ## marc21, ukmarc
 199             &print_title($record->field('245'));
 200         }
 201
 202         ## series title
 203         if ($intype eq "unimarc") {
 204             &print_stitle($record->field('225'));
 205         }
 206         else { ## marc21, ukmarc
 207             &print_stitle($record->field('490'));
 208         }
 209
 210         ## ISBN/ISSN
 211         if ($intype eq "unimarc") {
 212             &print_isbn($record->field('010'));
 213             &print_issn($record->field('011'));
 214         }
 215         elsif ($intype eq "ukmarc") {
 216             &print_isbn($record->field('021'));
 217             ## this is just an assumption
 218             &print_issn($record->field('022'));
 219         }
 220         else { ## assume marc21
 221             &print_isbn($record->field('020'));
 222             &print_issn($record->field('022'));
 223         }
 224
 225         if ($intype eq "marc21") {
 226             &print_loc_callno($record->field('050'));
 227             &print_dewey($record->field('082'));
 228         }
 229         ## else: unimarc, ukmarc do not seem to store call numbers?
 230
 231         ## publication info
 232         if ($intype eq "unimarc") {
 233             &print_pubinfo($record->field('210'));
 234         }
 235         else { ## marc21, ukmarc
 236             if ($record->field('264')) {
 237                  &print_pubinfo($record->field('264'));
 238             }
 239             else {
 240             &print_pubinfo($record->field('260'));
 241             }
 242         }
 243
 244         ## 6XX fields contain KW candidates. We add all of them to a
 245
 246     my @field_list;
 247     if ($intype eq "unimarc") {
 248         @field_list = ('600', '601', '602', '604', '605', '606','607', '608', '610', '615', '620', '660', '661', '670', '675', '676', '680', '686');
 249     } elsif ($intype eq "ukmarc") {
 250         @field_list = ('600', '610', '611', '630', '650', '651','653', '655', '660', '661', '668', '690', '691', '692', '695');
 251     } else { ## assume marc21
 252         @field_list = ('600', '610', '611', '630', '650', '651','653', '654', '655', '656', '657', '658');
 253     }
 254
 255     my @kwpool;
 256     for my $f ( @field_list ) {
 257         my @fields = $record->field($f);
 258         push @kwpool, ( get_keywords("$f",$record->field($f)) );
 259     }
 260
 261     # Remove duplicate
 262     @kwpool = uniq @kwpool;
 263
 264     for my $kw ( @kwpool ) {
 265         print "KW  - ", $kw, "\r\n";
 266     }
 267
 268         ## 5XX have various candidates for notes and abstracts. We pool
 269         ## all notes-like stuff in one list.
 270         my @notepool;
 271
 272         ## these fields have notes candidates
 273         if ($intype eq "unimarc") {
 274             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') {
 275                 &pool_subx(\@notepool, $_, $record->field($_));
 276             }
 277         }
 278         elsif ($intype eq "ukmarc") {
 279             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') {
 280                 &pool_subx(\@notepool, $_, $record->field($_));
 281         }
 282         }
 283         else { ## assume marc21
 284             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') {
 285                 &pool_subx(\@notepool, $_, $record->field($_));
 286             }
 287         }
 288
 289         my $allnotes = join "; ", @notepool;
 290
 291         if (length($allnotes) > 0) {
 292             print "N1  - ", $allnotes, "\r\n";
 293         }
 294
 295         ## 320/520 have the abstract
 296         if ($intype eq "unimarc") {
 297             &print_abstract($record->field('320'));
 298         }
 299         elsif ($intype eq "ukmarc") {
 300             &print_abstract($record->field('512'), $record->field('513'));
 301         }
 302         else { ## assume marc21
 303             &print_abstract($record->field('520'));
 304         }
 305
 306     # 856u has the URI
 307     if ($record->field('856')) {
 308         print_uri($record->field('856'));
 309     }
 310
 311     if ($ris_additional_fields) {
 312         foreach my $ris_tag ( keys %$ris_additional_fields ) {
 313             next if $ris_tag eq 'TY';
 314
 315             my @fields =
 316               ref( $ris_additional_fields->{$ris_tag} ) eq 'ARRAY'
 317               ? @{ $ris_additional_fields->{$ris_tag} }
 318               : $ris_additional_fields->{$ris_tag};
 319
 320             for my $tag (@fields) {
 321                 my ( $f, $sf ) = split( /\$/, $tag );
 322                 my @values = read_field( { record => $record, field => $f, subfield => $sf } );
 323                 foreach my $v (@values) {
 324                     print "$ris_tag  - $v\r\n";
 325                 }
 326             }
 327         }
 328     }
 329
 330         ## end RIS dataset
 331         print "ER  - \r\n";
 332
 333     # Let's re-redirect stdout
 334     close STDOUT;
 335     open STDOUT, ">&", $oldout;
 336
 337     return $outvar;
 338
 339 }
 340
 341
 342 ##********************************************************************
 343 ## print_typetag(): prints the first line of a RIS dataset including
 344 ## the preceding newline
 345 ## Argument: the leader of a MARC dataset
 346 ## Returns: the value at leader position 06
 347 ##********************************************************************
 348 sub print_typetag {
 349   my ($leader)= @_;
 350     ## the keys of typehash are the allowed values at position 06
 351     ## of the leader of a MARC record, the values are the RIS types
 352     ## that might appropriately represent these types.
 353     my %ustypehash = (
 354                     "a" => "BOOK",
 355                     "c" => "MUSIC",
 356                     "d" => "MUSIC",
 357                     "e" => "MAP",
 358                     "f" => "MAP",
 359                     "g" => "ADVS",
 360                     "i" => "SOUND",
 361                     "j" => "SOUND",
 362                     "k" => "ART",
 363                     "m" => "DATA",
 364                     "o" => "GEN",
 365                     "p" => "GEN",
 366                     "r" => "ART",
 367                     "t" => "GEN",
 368                 );
 369
 370     my %unitypehash = (
 371                     "a" => "BOOK",
 372                     "b" => "BOOK",
 373                     "c" => "MUSIC",
 374                     "d" => "MUSIC",
 375                     "e" => "MAP",
 376                     "f" => "MAP",
 377                     "g" => "ADVS",
 378                     "i" => "SOUND",
 379                     "j" => "SOUND",
 380                     "k" => "ART",
 381                     "l" => "ELEC",
 382                     "m" => "ADVS",
 383                     "r" => "ART",
 384                 );
 385
 386     ## The type of a MARC record is found at position 06 of the leader
 387     my $typeofrecord = defined($leader) && length $leader >=6 ?
 388                        substr($leader, 6, 1): undef;
 389
 390     ## ToDo: for books, field 008 positions 24-27 might have a few more
 391     ## hints
 392
 393     my %typehash;
 394     my $marcflavour = C4::Context->preference("marcflavour");
 395     my $intype = lc($marcflavour);
 396     if ($intype eq "unimarc") {
 397         %typehash = %unitypehash;
 398     }
 399     else {
 400         %typehash = %ustypehash;
 401     }
 402
 403     if (!defined $typeofrecord || !exists $typehash{$typeofrecord}) {
 404         print "TY  - BOOK\r\n"; ## most reasonable default
 405         warn ("no type found - assume BOOK") if $marcprint;
 406     }
 407     else {
 408         print "TY  - $typehash{$typeofrecord}\r\n";
 409     }
 410
 411     ## use $typeofrecord as the return value, just in case
 412     $typeofrecord;
 413 }
 414
 415 ##********************************************************************
 416 ## normalize_author(): normalizes an authorname
 417 ## Arguments: authorname subfield a
 418 ##            authorname subfield b
 419 ##            authorname subfield c
 420 ##            name type if known: 0=direct order
 421 ##                               1=only surname or full name in
 422 ##                                 inverted order
 423 ##                               3=family, clan, dynasty name
 424 ## Returns: the normalized authorname
 425 ##********************************************************************
 426 sub normalize_author {
 427     my($rawauthora, $rawauthorb, $rawauthorc, $nametype) = @_;
 428
 429     if ($nametype == 0) {
 430         # ToDo: convert every input to Last[,(F.|First)[ (M.|Middle)[,Suffix]]]
 431         warn("name >>$rawauthora<< in direct order - leave as is") if $marcprint;
 432         return $rawauthora;
 433     }
 434     elsif ($nametype == 1) {
 435         ## start munging subfield a (the real name part)
 436         ## remove spaces after separators
 437         $rawauthora =~ s%([,.]+) *%$1%g;
 438
 439         ## remove trailing separators after spaces
 440         $rawauthora =~ s% *[,;:/]*$%%;
 441
 442         ## remove periods after a non-abbreviated name
 443         $rawauthora =~ s%(\w{2,})\.%$1%g;
 444
 445         ## start munging subfield b (something like the suffix)
 446         ## remove trailing separators after spaces
 447         $rawauthorb =~ s% *[,;:/]*$%%;
 448
 449         ## we currently ignore subfield c until someone complains
 450         if (length($rawauthorb) > 0) {
 451         return join ", ", ($rawauthora, $rawauthorb);
 452         }
 453         else {
 454             return $rawauthora;
 455         }
 456     }
 457     elsif ($nametype == 3) {
 458         return $rawauthora;
 459     }
 460 }
 461
 462 ##********************************************************************
 463 ## get_author(): gets authorname info from MARC fields 100, 700
 464 ## Argument: field (100 or 700)
 465 ## Returns: an author string in the format found in the record
 466 ##********************************************************************
 467 sub get_author {
 468     my ($authorfield) = @_;
 469     my ($indicator);
 470
 471     ## the sequence of the name parts is encoded either in indicator
 472     ## 1 (marc21) or 2 (unimarc)
 473     my $marcflavour = C4::Context->preference("marcflavour");
 474     my $intype = lc($marcflavour);
 475     if ($intype eq "unimarc") {
 476         $indicator = 2;
 477     }
 478     else { ## assume marc21
 479         $indicator = 1;
 480     }
 481
 482     print "<marc>:Author(Ind$indicator): ", $authorfield->indicator("$indicator"),"\r\n" if $marcprint;
 483     print "<marc>:Author(\$a): ", $authorfield->subfield('a'),"\r\n" if $marcprint;
 484     print "<marc>:Author(\$b): ", $authorfield->subfield('b'),"\r\n" if $marcprint;
 485     print "<marc>:Author(\$c): ", $authorfield->subfield('c'),"\r\n" if $marcprint;
 486     print "<marc>:Author(\$h): ", $authorfield->subfield('h'),"\r\n" if $marcprint;
 487     if ($intype eq "ukmarc") {
 488         my $authorname = $authorfield->subfield('a') . "," . $authorfield->subfield('h');
 489         normalize_author($authorname, $authorfield->subfield('b'), $authorfield->subfield('c'), $authorfield->indicator("$indicator"));
 490     }
 491     else {
 492         normalize_author($authorfield->subfield('a') // '', $authorfield->subfield('b') // '', $authorfield->subfield('c') // '', $authorfield->indicator("$indicator"));
 493     }
 494 }
 495
 496 ##********************************************************************
 497 ## get_editor(): gets editor info from MARC fields 110, 111, 710, 711
 498 ## Argument: field (110, 111, 710, or 711)
 499 ## Returns: an author string in the format found in the record
 500 ##********************************************************************
 501 sub get_editor {
 502     my ($editorfield) = @_;
 503
 504     if (!$editorfield) {
 505         return;
 506     }
 507     else {
 508         print "<marc>Editor(\$a): ", $editorfield->subfield('a'),"\r\n" if $marcprint;
 509         print "<marc>Editor(\$b): ", $editorfield->subfield('b'),"\r\n" if $marcprint;
 510         print "<marc>editor(\$c): ", $editorfield->subfield('c'),"\r\n" if $marcprint;
 511         return $editorfield->subfield('a');
 512     }
 513 }
 514
 515 ##********************************************************************
 516 ## print_title(): gets info from MARC field 245
 517 ## Arguments: field (245)
 518 ## Returns:
 519 ##********************************************************************
 520 sub print_title {
 521     my ($titlefield) = @_;
 522     if (!$titlefield) {
 523         print "<marc>empty title field (245)\r\n" if $marcprint;
 524         warn("empty title field (245)") if $marcprint;
 525     }
 526     else {
 527         print "<marc>Title(\$a): ",$titlefield->subfield('a'),"\r\n" if $marcprint;
 528         print "<marc>Title(\$b): ",$titlefield->subfield('b'),"\r\n" if $marcprint;
 529         print "<marc>Title(\$c): ",$titlefield->subfield('c'),"\r\n" if $marcprint;
 530
 531         ## The title is usually written in a very odd notation. The title
 532         ## proper ($a) often ends with a space followed by a separator like
 533         ## a slash or a colon. The subtitle ($b) doesn't start with a space
 534         ## so simple concatenation looks odd. We have to conditionally remove
 535         ## the separator and make sure there's a space between title and
 536         ## subtitle
 537
 538         my $clean_title = $titlefield->subfield('a');
 539
 540         my $clean_subtitle = $titlefield->subfield('b');
 541 $clean_subtitle ||= q{};
 542         $clean_title =~ s% *[/:;.]$%%;
 543         $clean_subtitle =~ s%^ *(.*) *[/:;.]$%$1%;
 544
 545     my $marcflavour = C4::Context->preference("marcflavour");
 546     my $intype = lc($marcflavour);
 547         if (length($clean_title) > 0
 548             || (length($clean_subtitle) > 0 && $intype ne "unimarc")) {
 549             print "TI  - ", $clean_title;
 550
 551             ## subfield $b is relevant only for marc21/ukmarc
 552             if (length($clean_subtitle) > 0 && $intype ne "unimarc") {
 553                 print ": ",$clean_subtitle;
 554             }
 555             print "\r\n";
 556         }
 557
 558         ## The statement of responsibility is just this: horrors. There is
 559         ## no formal definition how authors, editors and the like should
 560         ## be written and designated. The field is free-form and resistant
 561         ## to all parsing efforts, so this information is lost on me
 562     }
 563 }
 564
 565 ##********************************************************************
 566 ## print_stitle(): prints info from series title field
 567 ## Arguments: field
 568 ## Returns:
 569 ##********************************************************************
 570 sub print_stitle {
 571     my ($titlefield) = @_;
 572
 573     if (!$titlefield) {
 574         print "<marc>empty series title field\r\n" if $marcprint;
 575     }
 576     else {
 577         print "<marc>Series title(\$a): ",$titlefield->subfield('a'),"\r\n" if $marcprint;
 578         my $clean_title = $titlefield->subfield('a');
 579
 580         $clean_title =~ s% *[/:;.]$%%;
 581
 582         if (length($clean_title) > 0) {
 583             print "T2  - ", $clean_title,"\r\n";
 584         }
 585
 586     my $marcflavour = C4::Context->preference("marcflavour");
 587     my $intype = lc($marcflavour);
 588         if ($intype eq "unimarc") {
 589             print "<marc>Series vol(\$v): ",$titlefield->subfield('v'),"\r\n" if $marcprint;
 590             if (length($titlefield->subfield('v')) > 0) {
 591                 print "VL  - ", $titlefield->subfield('v'),"\r\n";
 592             }
 593         }
 594     }
 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;