Bug 15200 - t/Creators.t fails when using build-git-snapshot
[koha.git] / C4 / Ris.pm
blob0932cbfdbcdb0ddf8b38ab777738b69ed06bae17
1 package C4::Ris;
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
13 ## markus@mhoenicka.de 2002-11-16
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.
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
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
41 # Modified 2008 by BibLibre for Koha
42 # Modified 2011 by Catalyst
43 # Modified 2011 by Equinox Software, Inc.
45 # This file is part of Koha.
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.
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.
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>.
62 use Modern::Perl;
64 use List::MoreUtils qw/uniq/;
65 use vars qw(@ISA @EXPORT);
67 use C4::Biblio qw(GetMarcSubfieldStructureFromKohaField);
68 use Koha::SimpleMARC qw(read_field);
71 @ISA = qw(Exporter);
73 # only export API methods
75 @EXPORT = qw(
76 &marc2ris
79 our $marcprint = 0; # Debug flag;
81 =head1 marc2bibtex - Convert from UNIMARC to RIS
83 my ($ris) = marc2ris($record);
85 Returns a RIS scalar
87 C<$record> - a MARC::Record object
89 =cut
91 sub marc2ris {
92 my ($record) = @_;
93 my $output;
95 my $marcflavour = C4::Context->preference("marcflavour");
96 my $intype = lc($marcflavour);
98 # Let's redirect stdout
99 open my $oldout, ">&STDOUT";
100 my $outvar;
101 close STDOUT;
102 open STDOUT,'>:encoding(utf8)', \$outvar;
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;
112 else {
113 print "<marc>---\r\n<marc>MARC-8 data\r\n" if $marcprint;
116 ## else: other MARC formats do not specify the character encoding
117 ## we assume it's *not* UTF-8
119 my $RisExportAdditionalFields = C4::Context->preference('RisExportAdditionalFields');
120 my $ris_additional_fields;
121 if ($RisExportAdditionalFields) {
122 $RisExportAdditionalFields = "$RisExportAdditionalFields\n\n";
123 $ris_additional_fields = eval { YAML::Load($RisExportAdditionalFields); };
124 if ($@) {
125 warn "Unable to parse RisExportAdditionalFields : $@";
126 $ris_additional_fields = undef;
130 ## start RIS dataset
131 if ( $ris_additional_fields && $ris_additional_fields->{TY} ) {
132 my ( $f, $sf ) = split( /\$/, $ris_additional_fields->{TY} );
133 my ( $type ) = read_field( { record => $record, field => $f, subfield => $sf, field_numbers => [1] } );
134 if ($type) {
135 print "TY - $type\r\n";
137 else {
138 &print_typetag($leader);
141 else {
142 &print_typetag($leader);
145 ## retrieve all author fields and collect them in a list
146 my @author_fields;
148 if ($intype eq "unimarc") {
149 ## Fields 700, 701, and 702 can contain author names
150 @author_fields = ($record->field('700'), $record->field('701'), $record->field('702'));
152 else { ## marc21, ukmarc
153 ## Field 100 sometimes carries main author
154 ## Field(s) 700 carry added entries - personal names
155 @author_fields = ($record->field('100'), $record->field('700'));
158 ## loop over all author fields
159 foreach my $field (@author_fields) {
160 if (length($field)) {
161 my $author = &get_author($field);
162 print "AU - ",$author,"\r\n";
166 # ToDo: should we specify anonymous as author if we didn't find
167 # one? or use one of the corporate/meeting names below?
169 ## add corporate names or meeting names as editors ??
170 my @editor_fields;
172 if ($intype eq "unimarc") {
173 ## Fields 710, 711, and 712 can carry corporate names
174 ## Field(s) 720, 721, 722, 730 have additional candidates
175 @editor_fields = ($record->field('710'), $record->field('711'), $record->field('712'), $record->field('720'), $record->field('721'), $record->field('722'), $record->field('730'));
177 else { ## marc21, ukmarc
178 ## Fields 110 and 111 carry the main entries - corporate name and
179 ## meeting name, respectively
180 ## Field(s) 710, 711 carry added entries - personal names
181 @editor_fields = ($record->field('110'), $record->field('111'), $record->field('710'), $record->field('711'));
184 ## loop over all editor fields
185 foreach my $field (@editor_fields) {
186 if (length($field)) {
187 my $editor = &get_editor($field);
188 print "ED - ",$editor,"\r\n";
192 ## get info from the title field
193 if ($intype eq "unimarc") {
194 &print_title($record->field('200'));
196 else { ## marc21, ukmarc
197 &print_title($record->field('245'));
200 ## series title
201 if ($intype eq "unimarc") {
202 &print_stitle($record->field('225'));
204 else { ## marc21, ukmarc
205 &print_stitle($record->field('490'));
208 ## ISBN/ISSN
209 if ($intype eq "unimarc") {
210 &print_isbn($record->field('010'));
211 &print_issn($record->field('011'));
213 elsif ($intype eq "ukmarc") {
214 &print_isbn($record->field('021'));
215 ## this is just an assumption
216 &print_issn($record->field('022'));
218 else { ## assume marc21
219 &print_isbn($record->field('020'));
220 &print_issn($record->field('022'));
223 if ($intype eq "marc21") {
224 &print_loc_callno($record->field('050'));
225 &print_dewey($record->field('082'));
227 ## else: unimarc, ukmarc do not seem to store call numbers?
229 ## publication info
230 if ($intype eq "unimarc") {
231 &print_pubinfo($record->field('210'));
233 else { ## marc21, ukmarc
234 if ($record->field('264')) {
235 &print_pubinfo($record->field('264'));
237 else {
238 &print_pubinfo($record->field('260'));
242 ## 6XX fields contain KW candidates. We add all of them to a
244 my @field_list;
245 if ($intype eq "unimarc") {
246 @field_list = ('600', '601', '602', '604', '605', '606','607', '608', '610', '615', '620', '660', '661', '670', '675', '676', '680', '686');
247 } elsif ($intype eq "ukmarc") {
248 @field_list = ('600', '610', '611', '630', '650', '651','653', '655', '660', '661', '668', '690', '691', '692', '695');
249 } else { ## assume marc21
250 @field_list = ('600', '610', '611', '630', '650', '651','653', '654', '655', '656', '657', '658');
253 my @kwpool;
254 for my $f ( @field_list ) {
255 my @fields = $record->field($f);
256 push @kwpool, ( get_keywords("$f",$record->field($f)) );
259 # Remove duplicate
260 @kwpool = uniq @kwpool;
262 for my $kw ( @kwpool ) {
263 print "KW - ", $kw, "\r\n";
266 ## 5XX have various candidates for notes and abstracts. We pool
267 ## all notes-like stuff in one list.
268 my @notepool;
270 ## these fields have notes candidates
271 if ($intype eq "unimarc") {
272 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') {
273 &pool_subx(\@notepool, $_, $record->field($_));
276 elsif ($intype eq "ukmarc") {
277 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') {
278 &pool_subx(\@notepool, $_, $record->field($_));
281 else { ## assume marc21
282 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') {
283 &pool_subx(\@notepool, $_, $record->field($_));
287 my $allnotes = join "; ", @notepool;
289 if (length($allnotes) > 0) {
290 print "N1 - ", $allnotes, "\r\n";
293 ## 320/520 have the abstract
294 if ($intype eq "unimarc") {
295 &print_abstract($record->field('320'));
297 elsif ($intype eq "ukmarc") {
298 &print_abstract($record->field('512'), $record->field('513'));
300 else { ## assume marc21
301 &print_abstract($record->field('520'));
304 # 856u has the URI
305 if ($record->field('856')) {
306 print_uri($record->field('856'));
309 if ($ris_additional_fields) {
310 foreach my $ris_tag ( keys %$ris_additional_fields ) {
311 next if $ris_tag eq 'TY';
313 my @fields =
314 ref( $ris_additional_fields->{$ris_tag} ) eq 'ARRAY'
315 ? @{ $ris_additional_fields->{$ris_tag} }
316 : $ris_additional_fields->{$ris_tag};
318 for my $tag (@fields) {
319 my ( $f, $sf ) = split( /\$/, $tag );
320 my @values = read_field( { record => $record, field => $f, subfield => $sf } );
321 foreach my $v (@values) {
322 print "$ris_tag - $v\r\n";
328 ## end RIS dataset
329 print "ER - \r\n";
331 # Let's re-redirect stdout
332 close STDOUT;
333 open STDOUT, ">&", $oldout;
335 return $outvar;
340 ##********************************************************************
341 ## print_typetag(): prints the first line of a RIS dataset including
342 ## the preceding newline
343 ## Argument: the leader of a MARC dataset
344 ## Returns: the value at leader position 06
345 ##********************************************************************
346 sub print_typetag {
347 my ($leader)= @_;
348 ## the keys of typehash are the allowed values at position 06
349 ## of the leader of a MARC record, the values are the RIS types
350 ## that might appropriately represent these types.
351 my %ustypehash = (
352 "a" => "BOOK",
353 "c" => "MUSIC",
354 "d" => "MUSIC",
355 "e" => "MAP",
356 "f" => "MAP",
357 "g" => "ADVS",
358 "i" => "SOUND",
359 "j" => "SOUND",
360 "k" => "ART",
361 "m" => "DATA",
362 "o" => "GEN",
363 "p" => "GEN",
364 "r" => "ART",
365 "t" => "GEN",
368 my %unitypehash = (
369 "a" => "BOOK",
370 "b" => "BOOK",
371 "c" => "MUSIC",
372 "d" => "MUSIC",
373 "e" => "MAP",
374 "f" => "MAP",
375 "g" => "ADVS",
376 "i" => "SOUND",
377 "j" => "SOUND",
378 "k" => "ART",
379 "l" => "ELEC",
380 "m" => "ADVS",
381 "r" => "ART",
384 ## The type of a MARC record is found at position 06 of the leader
385 my $typeofrecord = defined($leader) && length $leader >=6 ?
386 substr($leader, 6, 1): undef;
388 ## ToDo: for books, field 008 positions 24-27 might have a few more
389 ## hints
391 my %typehash;
392 my $marcflavour = C4::Context->preference("marcflavour");
393 my $intype = lc($marcflavour);
394 if ($intype eq "unimarc") {
395 %typehash = %unitypehash;
397 else {
398 %typehash = %ustypehash;
401 if (!defined $typeofrecord || !exists $typehash{$typeofrecord}) {
402 print "TY - BOOK\r\n"; ## most reasonable default
403 warn ("no type found - assume BOOK") if $marcprint;
405 else {
406 print "TY - $typehash{$typeofrecord}\r\n";
409 ## use $typeofrecord as the return value, just in case
410 $typeofrecord;
413 ##********************************************************************
414 ## normalize_author(): normalizes an authorname
415 ## Arguments: authorname subfield a
416 ## authorname subfield b
417 ## authorname subfield c
418 ## name type if known: 0=direct order
419 ## 1=only surname or full name in
420 ## inverted order
421 ## 3=family, clan, dynasty name
422 ## Returns: the normalized authorname
423 ##********************************************************************
424 sub normalize_author {
425 my($rawauthora, $rawauthorb, $rawauthorc, $nametype) = @_;
427 if ($nametype == 0) {
428 # ToDo: convert every input to Last[,(F.|First)[ (M.|Middle)[,Suffix]]]
429 warn("name >>$rawauthora<< in direct order - leave as is") if $marcprint;
430 return $rawauthora;
432 elsif ($nametype == 1) {
433 ## start munging subfield a (the real name part)
434 ## remove spaces after separators
435 $rawauthora =~ s%([,.]+) *%$1%g;
437 ## remove trailing separators after spaces
438 $rawauthora =~ s% *[,;:/]*$%%;
440 ## remove periods after a non-abbreviated name
441 $rawauthora =~ s%(\w{2,})\.%$1%g;
443 ## start munging subfield b (something like the suffix)
444 ## remove trailing separators after spaces
445 $rawauthorb =~ s% *[,;:/]*$%%;
447 ## we currently ignore subfield c until someone complains
448 if (length($rawauthorb) > 0) {
449 return join ", ", ($rawauthora, $rawauthorb);
451 else {
452 return $rawauthora;
455 elsif ($nametype == 3) {
456 return $rawauthora;
460 ##********************************************************************
461 ## get_author(): gets authorname info from MARC fields 100, 700
462 ## Argument: field (100 or 700)
463 ## Returns: an author string in the format found in the record
464 ##********************************************************************
465 sub get_author {
466 my ($authorfield) = @_;
467 my ($indicator);
469 ## the sequence of the name parts is encoded either in indicator
470 ## 1 (marc21) or 2 (unimarc)
471 my $marcflavour = C4::Context->preference("marcflavour");
472 my $intype = lc($marcflavour);
473 if ($intype eq "unimarc") {
474 $indicator = 2;
476 else { ## assume marc21
477 $indicator = 1;
480 print "<marc>:Author(Ind$indicator): ", $authorfield->indicator("$indicator"),"\r\n" if $marcprint;
481 print "<marc>:Author(\$a): ", $authorfield->subfield('a'),"\r\n" if $marcprint;
482 print "<marc>:Author(\$b): ", $authorfield->subfield('b'),"\r\n" if $marcprint;
483 print "<marc>:Author(\$c): ", $authorfield->subfield('c'),"\r\n" if $marcprint;
484 print "<marc>:Author(\$h): ", $authorfield->subfield('h'),"\r\n" if $marcprint;
485 if ($intype eq "ukmarc") {
486 my $authorname = $authorfield->subfield('a') . "," . $authorfield->subfield('h');
487 normalize_author($authorname, $authorfield->subfield('b'), $authorfield->subfield('c'), $authorfield->indicator("$indicator"));
489 else {
490 normalize_author($authorfield->subfield('a') // '', $authorfield->subfield('b') // '', $authorfield->subfield('c') // '', $authorfield->indicator("$indicator"));
494 ##********************************************************************
495 ## get_editor(): gets editor info from MARC fields 110, 111, 710, 711
496 ## Argument: field (110, 111, 710, or 711)
497 ## Returns: an author string in the format found in the record
498 ##********************************************************************
499 sub get_editor {
500 my ($editorfield) = @_;
502 if (!$editorfield) {
503 return;
505 else {
506 print "<marc>Editor(\$a): ", $editorfield->subfield('a'),"\r\n" if $marcprint;
507 print "<marc>Editor(\$b): ", $editorfield->subfield('b'),"\r\n" if $marcprint;
508 print "<marc>editor(\$c): ", $editorfield->subfield('c'),"\r\n" if $marcprint;
509 return $editorfield->subfield('a');
513 ##********************************************************************
514 ## print_title(): gets info from MARC field 245
515 ## Arguments: field (245)
516 ## Returns:
517 ##********************************************************************
518 sub print_title {
519 my ($titlefield) = @_;
520 if (!$titlefield) {
521 print "<marc>empty title field (245)\r\n" if $marcprint;
522 warn("empty title field (245)") if $marcprint;
524 else {
525 print "<marc>Title(\$a): ",$titlefield->subfield('a'),"\r\n" if $marcprint;
526 print "<marc>Title(\$b): ",$titlefield->subfield('b'),"\r\n" if $marcprint;
527 print "<marc>Title(\$c): ",$titlefield->subfield('c'),"\r\n" if $marcprint;
529 ## The title is usually written in a very odd notation. The title
530 ## proper ($a) often ends with a space followed by a separator like
531 ## a slash or a colon. The subtitle ($b) doesn't start with a space
532 ## so simple concatenation looks odd. We have to conditionally remove
533 ## the separator and make sure there's a space between title and
534 ## subtitle
536 my $clean_title = $titlefield->subfield('a');
538 my $clean_subtitle = $titlefield->subfield('b');
539 $clean_subtitle ||= q{};
540 $clean_title =~ s% *[/:;.]$%%;
541 $clean_subtitle =~ s%^ *(.*) *[/:;.]$%$1%;
543 my $marcflavour = C4::Context->preference("marcflavour");
544 my $intype = lc($marcflavour);
545 if (length($clean_title) > 0
546 || (length($clean_subtitle) > 0 && $intype ne "unimarc")) {
547 print "TI - ", $clean_title;
549 ## subfield $b is relevant only for marc21/ukmarc
550 if (length($clean_subtitle) > 0 && $intype ne "unimarc") {
551 print ": ",$clean_subtitle;
553 print "\r\n";
556 ## The statement of responsibility is just this: horrors. There is
557 ## no formal definition how authors, editors and the like should
558 ## be written and designated. The field is free-form and resistant
559 ## to all parsing efforts, so this information is lost on me
561 return;
564 ##********************************************************************
565 ## print_stitle(): prints info from series title field
566 ## Arguments: field
567 ## Returns:
568 ##********************************************************************
569 sub print_stitle {
570 my ($titlefield) = @_;
572 if (!$titlefield) {
573 print "<marc>empty series title field\r\n" if $marcprint;
575 else {
576 print "<marc>Series title(\$a): ",$titlefield->subfield('a'),"\r\n" if $marcprint;
577 my $clean_title = $titlefield->subfield('a');
579 $clean_title =~ s% *[/:;.]$%%;
581 if (length($clean_title) > 0) {
582 print "T2 - ", $clean_title,"\r\n";
585 my $marcflavour = C4::Context->preference("marcflavour");
586 my $intype = lc($marcflavour);
587 if ($intype eq "unimarc") {
588 print "<marc>Series vol(\$v): ",$titlefield->subfield('v'),"\r\n" if $marcprint;
589 if (length($titlefield->subfield('v')) > 0) {
590 print "VL - ", $titlefield->subfield('v'),"\r\n";
594 return;
597 ##********************************************************************
598 ## print_isbn(): gets info from MARC field 020
599 ## Arguments: field (020)
600 ##********************************************************************
601 sub print_isbn {
602 my($isbnfield) = @_;
604 if (!$isbnfield || length ($isbnfield->subfield('a')) == 0) {
605 print "<marc>no isbn found (020\$a)\r\n" if $marcprint;
606 warn("no isbn found") if $marcprint;
608 else {
609 if (length ($isbnfield->subfield('a')) < 10) {
610 print "<marc>truncated isbn (020\$a)\r\n" if $marcprint;
611 warn("truncated isbn") if $marcprint;
614 my $isbn = $isbnfield->subfield('a');
615 print "SN - ", $isbn, "\r\n";
619 ##********************************************************************
620 ## print_issn(): gets info from MARC field 022
621 ## Arguments: field (022)
622 ##********************************************************************
623 sub print_issn {
624 my($issnfield) = @_;
626 if (!$issnfield || length ($issnfield->subfield('a')) == 0) {
627 print "<marc>no issn found (022\$a)\r\n" if $marcprint;
628 warn("no issn found") if $marcprint;
630 else {
631 if (length ($issnfield->subfield('a')) < 9) {
632 print "<marc>truncated issn (022\$a)\r\n" if $marcprint;
633 warn("truncated issn") if $marcprint;
636 my $issn = substr($issnfield->subfield('a'), 0, 9);
637 print "SN - ", $issn, "\r\n";
642 # print_uri() prints info from 856 u
644 sub print_uri {
645 my @f856s = @_;
647 foreach my $f856 (@f856s) {
648 if (my $uri = $f856->subfield('u')) {
649 print "UR - ", $uri, "\r\n";
654 ##********************************************************************
655 ## print_loc_callno(): gets info from MARC field 050
656 ## Arguments: field (050)
657 ##********************************************************************
658 sub print_loc_callno {
659 my($callnofield) = @_;
661 if (!$callnofield || length ($callnofield->subfield('a')) == 0) {
662 print "<marc>no LOC call number found (050\$a)\r\n" if $marcprint;
663 warn("no LOC call number found") if $marcprint;
665 else {
666 print "AV - ", $callnofield->subfield('a'), " ", $callnofield->subfield('b'), "\r\n";
670 ##********************************************************************
671 ## print_dewey(): gets info from MARC field 082
672 ## Arguments: field (082)
673 ##********************************************************************
674 sub print_dewey {
675 my($deweyfield) = @_;
677 if (!$deweyfield || length ($deweyfield->subfield('a')) == 0) {
678 print "<marc>no Dewey number found (082\$a)\r\n" if $marcprint;
679 warn("no Dewey number found") if $marcprint;
681 else {
682 print "U1 - ", $deweyfield->subfield('a'), " ", $deweyfield->subfield('2'), "\r\n";
686 ##********************************************************************
687 ## print_pubinfo(): gets info from MARC field 260
688 ## Arguments: field (260)
689 ##********************************************************************
690 sub print_pubinfo {
691 my($pubinfofield) = @_;
693 if (!$pubinfofield) {
694 print "<marc>no publication information found (260/264)\r\n" if $marcprint;
695 warn("no publication information found") if $marcprint;
697 else {
698 ## the following information is available in MARC21:
699 ## $a place -> CY
700 ## $b publisher -> PB
701 ## $c date -> PY
702 ## the corresponding subfields for UNIMARC:
703 ## $a place -> CY
704 ## $c publisher -> PB
705 ## $d date -> PY
707 ## all of them are repeatable. We pool all places into a
708 ## comma-separated list in CY. We also pool all publishers
709 ## into a comma-separated list in PB. We break the rule with
710 ## the date field because this wouldn't make much sense. In
711 ## this case, we use the first occurrence for PY, the second
712 ## for Y2, and ignore the rest
714 my @pubsubfields = $pubinfofield->subfields();
715 my @cities;
716 my @publishers;
717 my $pycounter = 0;
719 my $pubsub_place;
720 my $pubsub_publisher;
721 my $pubsub_date;
723 my $marcflavour = C4::Context->preference("marcflavour");
724 my $intype = lc($marcflavour);
725 if ($intype eq "unimarc") {
726 $pubsub_place = "a";
727 $pubsub_publisher = "c";
728 $pubsub_date = "d";
730 else { ## assume marc21
731 $pubsub_place = "a";
732 $pubsub_publisher = "b";
733 $pubsub_date = "c";
736 ## loop over all subfield list entries
737 for my $tuple (@pubsubfields) {
738 ## each tuple consists of the subfield code and the value
739 if (@$tuple[0] eq $pubsub_place) {
740 ## strip any trailing crap
741 $_ = @$tuple[1];
742 s% *[,;:/]$%%;
743 ## pool all occurrences in a list
744 push (@cities, $_);
746 elsif (@$tuple[0] eq $pubsub_publisher) {
747 ## strip any trailing crap
748 $_ = @$tuple[1];
749 s% *[,;:/]$%%;
750 ## pool all occurrences in a list
751 push (@publishers, $_);
753 elsif (@$tuple[0] eq $pubsub_date) {
754 ## the dates are free-form, so we want to extract
755 ## a four-digit year and leave the rest as
756 ## "other info"
757 my $protoyear = @$tuple[1];
758 print "<marc>Year (260\$c): $protoyear\r\n" if $marcprint;
760 ## strip any separator chars at the end
761 $protoyear =~ s% *[\.;:/]*$%%;
763 ## isolate a four-digit year. We discard anything
764 ## preceding the year, but keep everything after
765 ## the year as other info.
766 $protoyear =~ s%\D*([0-9\-]{4})(.*)%$1///$2%;
768 ## check what we've got. If there is no four-digit
769 ## year, make it up. If digits are replaced by '-',
770 ## replace those with 0s
772 if (index($protoyear, "/") == 4) {
773 ## have year info
774 ## replace all '-' in the four-digit year
775 ## by '0'
776 substr($protoyear,0,4) =~ s!-!0!g;
778 else {
779 ## have no year info
780 print "<marc>no four-digit year found, use 0000\r\n" if $marcprint;
781 $protoyear = "0000///$protoyear";
782 warn("no four-digit year found, use 0000") if $marcprint;
785 if ($pycounter == 0 && length($protoyear)) {
786 print "PY - $protoyear\r\n";
788 elsif ($pycounter == 1 && length($_)) {
789 print "Y2 - $protoyear\r\n";
791 ## else: discard
793 ## else: discard
796 ## now dump the collected CY and PB lists
797 if (@cities > 0) {
798 print "CY - ", join(", ", @cities), "\r\n";
800 if (@publishers > 0) {
801 print "PB - ", join(", ", @publishers), "\r\n";
806 ##********************************************************************
807 ## get_keywords(): prints info from MARC fields 6XX
808 ## Arguments: list of fields (6XX)
809 ##********************************************************************
810 sub get_keywords {
811 my($fieldname, @keywords) = @_;
813 my @kw;
814 ## a list of all possible subfields
815 my @subfields = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'x', 'y', 'z', '2', '3', '4');
817 ## loop over all 6XX fields
818 foreach my $kwfield (@keywords) {
819 if ($kwfield != undef) {
820 ## authornames get special treatment
821 if ($fieldname eq "600") {
822 my $val = normalize_author($kwfield->subfield('a'), $kwfield->subfield('b'), $kwfield->subfield('c'), $kwfield->indicator('1'));
823 push @kw, $val;
824 print "<marc>Field $kwfield subfield a:", $kwfield->subfield('a'), "\r\n<marc>Field $kwfield subfield b:", $kwfield->subfield('b'), "\r\n<marc>Field $kwfield subfield c:", $kwfield->subfield('c'), "\r\n" if $marcprint;
826 else {
827 ## retrieve all available subfields
828 my @kwsubfields = $kwfield->subfields();
830 ## loop over all available subfield tuples
831 foreach my $kwtuple (@kwsubfields) {
832 ## loop over all subfields to check
833 foreach my $subfield (@subfields) {
834 ## [0] contains subfield code
835 if (@$kwtuple[0] eq $subfield) {
836 ## [1] contains value, remove trailing separators
837 @$kwtuple[1] =~ s% *[,;.:/]*$%%;
838 if (length(@$kwtuple[1]) > 0) {
839 push @kw, @$kwtuple[1];
840 print "<marc>Field $fieldname subfield $subfield:", @$kwtuple[1], "\r\n" if $marcprint;
842 ## we can leave the subfields loop here
843 last;
850 return @kw;
853 ##********************************************************************
854 ## pool_subx(): adds contents of several subfields to a list
855 ## Arguments: reference to a list
856 ## field name
857 ## list of fields (5XX)
858 ##********************************************************************
859 sub pool_subx {
860 my($aref, $fieldname, @notefields) = @_;
862 ## we use a list that contains the interesting subfields
863 ## for each field
864 # ToDo: this is apparently correct only for marc21
865 my @subfields;
867 if ($fieldname eq "500") {
868 @subfields = ('a');
870 elsif ($fieldname eq "501") {
871 @subfields = ('a');
873 elsif ($fieldname eq "502") {
874 @subfields = ('a');
876 elsif ($fieldname eq "504") {
877 @subfields = ('a', 'b');
879 elsif ($fieldname eq "505") {
880 @subfields = ('a', 'g', 'r', 't', 'u');
882 elsif ($fieldname eq "506") {
883 @subfields = ('a', 'b', 'c', 'd', 'e');
885 elsif ($fieldname eq "507") {
886 @subfields = ('a', 'b');
888 elsif ($fieldname eq "508") {
889 @subfields = ('a');
891 elsif ($fieldname eq "510") {
892 @subfields = ('a', 'b', 'c', 'x', '3');
894 elsif ($fieldname eq "511") {
895 @subfields = ('a');
897 elsif ($fieldname eq "513") {
898 @subfields = ('a', 'b');
900 elsif ($fieldname eq "514") {
901 @subfields = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'm', 'u', 'z');
903 elsif ($fieldname eq "515") {
904 @subfields = ('a');
906 elsif ($fieldname eq "516") {
907 @subfields = ('a');
909 elsif ($fieldname eq "518") {
910 @subfields = ('a', '3');
912 elsif ($fieldname eq "521") {
913 @subfields = ('a', 'b', '3');
915 elsif ($fieldname eq "522") {
916 @subfields = ('a');
918 elsif ($fieldname eq "524") {
919 @subfields = ('a', '2', '3');
921 elsif ($fieldname eq "525") {
922 @subfields = ('a');
924 elsif ($fieldname eq "526") {
925 @subfields = ('a', 'b', 'c', 'd', 'i', 'x', 'z', '5');
927 elsif ($fieldname eq "530") {
928 @subfields = ('a', 'b', 'c', 'd', 'u', '3');
930 elsif ($fieldname eq "533") {
931 @subfields = ('a', 'b', 'c', 'd', 'e', 'f', 'm', 'n', '3');
933 elsif ($fieldname eq "534") {
934 @subfields = ('a', 'b', 'c', 'e', 'f', 'k', 'l', 'm', 'n', 'p', 't', 'x', 'z');
936 elsif ($fieldname eq "535") {
937 @subfields = ('a', 'b', 'c', 'd', 'g', '3');
940 ## loop over all notefields
941 foreach my $notefield (@notefields) {
942 if (defined $notefield) {
943 ## retrieve all available subfield tuples
944 my @notesubfields = $notefield->subfields();
946 ## loop over all subfield tuples
947 foreach my $notetuple (@notesubfields) {
948 ## loop over all subfields to check
949 foreach my $subfield (@subfields) {
950 ## [0] contains subfield code
951 if (@$notetuple[0] eq $subfield) {
952 ## [1] contains value, remove trailing separators
953 print "<marc>field $fieldname subfield $subfield: ", @$notetuple[1], "\r\n" if $marcprint;
954 @$notetuple[1] =~ s% *[,;.:/]*$%%;
955 if (length(@$notetuple[1]) > 0) {
956 ## add to list
957 push @{$aref}, @$notetuple[1];
959 last;
967 ##********************************************************************
968 ## print_abstract(): prints abstract fields
969 ## Arguments: list of fields (520)
970 ##********************************************************************
971 sub print_abstract {
972 # ToDo: take care of repeatable subfields
973 my(@abfields) = @_;
975 ## we check the following subfields
976 my @subfields = ('a', 'b');
978 ## we generate a list for all useful strings
979 my @abstrings;
981 ## loop over all abfields
982 foreach my $abfield (@abfields) {
983 foreach my $field (@subfields) {
984 if ( length( $abfield->subfield($field) ) > 0 ) {
985 my $ab = $abfield->subfield($field);
987 print "<marc>field 520 subfield $field: $ab\r\n" if $marcprint;
989 ## strip trailing separators
990 $ab =~ s% *[;,:./]*$%%;
992 ## add string to the list
993 push( @abstrings, $ab );
998 my $allabs = join "; ", @abstrings;
1000 if (length($allabs) > 0) {
1001 print "N2 - ", $allabs, "\r\n";