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