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