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