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