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