View | Details | Raw Unified | Return to bug 2505
Collapse All | Expand All

(-)a/C4/Ris.pm (-51 / +71 lines)
Lines 59-66 package C4::Ris; Link Here
59
#
59
#
60
#
60
#
61
61
62
#use strict;
62
use strict;
63
#use warnings;
63
use warnings;
64
64
65
use vars qw($VERSION @ISA @EXPORT);
65
use vars qw($VERSION @ISA @EXPORT);
66
66
Lines 75-80 $VERSION = 3.07.00.049; Link Here
75
  &marc2ris
75
  &marc2ris
76
);
76
);
77
77
78
# Debug flag, set to 1 to obtain additional debugging
79
my $marcprint = 0;
80
81
# Switch to record whether UTF enabled
82
my $UTF = 0;
78
83
79
=head1 marc2bibtex - Convert from UNIMARC to RIS
84
=head1 marc2bibtex - Convert from UNIMARC to RIS
80
85
Lines 92-98 sub marc2ris { Link Here
92
97
93
    my $marcflavour = C4::Context->preference("marcflavour");
98
    my $marcflavour = C4::Context->preference("marcflavour");
94
    my $intype = lc($marcflavour);
99
    my $intype = lc($marcflavour);
95
    my $marcprint = 0; # Debug flag;
96
100
97
    # Let's redirect stdout
101
    # Let's redirect stdout
98
    open my $oldout, ">&STDOUT";
102
    open my $oldout, ">&STDOUT";
Lines 108-114 sub marc2ris { Link Here
108
	if ($intype eq "marc21") {
112
	if ($intype eq "marc21") {
109
	    if ($leader =~ /^.{9}a/) {
113
	    if ($leader =~ /^.{9}a/) {
110
		print "<marc>---\r\n<marc>UTF-8 data\r\n" if $marcprint;
114
		print "<marc>---\r\n<marc>UTF-8 data\r\n" if $marcprint;
111
		$utf = 1;
115
		$UTF = 1;
112
	    }
116
	    }
113
	    else {
117
	    else {
114
		print "<marc>---\r\n<marc>MARC-8 data\r\n" if $marcprint;
118
		print "<marc>---\r\n<marc>MARC-8 data\r\n" if $marcprint;
Lines 118-124 sub marc2ris { Link Here
118
	## we assume it's *not* UTF-8
122
	## we assume it's *not* UTF-8
119
123
120
	## start RIS dataset
124
	## start RIS dataset
121
	&print_typetag($leader);
125
	&print_typetag($intype, $leader);
122
126
123
	## retrieve all author fields and collect them in a list
127
	## retrieve all author fields and collect them in a list
124
	my @author_fields;
128
	my @author_fields;
Lines 136-142 sub marc2ris { Link Here
136
	## loop over all author fields
140
	## loop over all author fields
137
	foreach my $field (@author_fields) {
141
	foreach my $field (@author_fields) {
138
	    if (length($field)) {
142
	    if (length($field)) {
139
		my $author = &get_author($field);
143
		my $author = &get_author($intype, $field);
140
		print "AU  - ",&charconv($author),"\r\n";
144
		print "AU  - ",&charconv($author),"\r\n";
141
	    }
145
	    }
142
	}
146
	}
Lines 169-186 sub marc2ris { Link Here
169
173
170
	## get info from the title field
174
	## get info from the title field
171
	if ($intype eq "unimarc") {
175
	if ($intype eq "unimarc") {
172
	    &print_title($record->field('200'));
176
	    &print_title($intype, $record->field('200'));
173
	}
177
	}
174
	else { ## marc21, ukmarc
178
	else { ## marc21, ukmarc
175
	    &print_title($record->field('245'));
179
	    &print_title($intype, $record->field('245'));
176
	}
180
	}
177
181
178
	## series title
182
	## series title
179
	if ($intype eq "unimarc") {
183
	if ($intype eq "unimarc") {
180
	    &print_stitle($record->field('225'));
184
	    &print_stitle($intype, $record->field('225'));
181
	}
185
	}
182
	else { ## marc21, ukmarc
186
	else { ## marc21, ukmarc
183
	    &print_stitle($record->field('490'));
187
	    &print_stitle($intype, $record->field('490'));
184
	}
188
	}
185
189
186
	## ISBN/ISSN
190
	## ISBN/ISSN
Lines 206-219 sub marc2ris { Link Here
206
     
210
     
207
	## publication info
211
	## publication info
208
	if ($intype eq "unimarc") {
212
	if ($intype eq "unimarc") {
209
	    &print_pubinfo($record->field('210'));
213
	    &print_pubinfo($intype, $record->field('210'));
210
	}
214
	}
211
	else { ## marc21, ukmarc
215
	else { ## marc21, ukmarc
212
            if ($record->field('264')) {
216
            if ($record->field('264')) {
213
                 &print_pubinfo($record->field('264'));
217
                 &print_pubinfo($intype, $record->field('264'));
214
            }
218
            }
215
            else {
219
            else {
216
            &print_pubinfo($record->field('260'));
220
            &print_pubinfo($intype, $record->field('260'));
217
            }
221
            }
218
	}
222
	}
219
223
Lines 302-312 sub marc2ris { Link Here
302
##********************************************************************
306
##********************************************************************
303
## print_typetag(): prints the first line of a RIS dataset including
307
## print_typetag(): prints the first line of a RIS dataset including
304
## the preceeding newline
308
## the preceeding newline
305
## Argument: the leader of a MARC dataset
309
## Arguments: MARC flavour type, the leader of a MARC dataset
306
## Returns: the value at leader position 06 
310
## Returns: the value at leader position 06 
307
##********************************************************************
311
##********************************************************************
308
sub print_typetag {
312
sub print_typetag {
309
  my ($leader)= @_;
313
    my ($intype, $leader)= @_;
314
    return undef unless $leader;
315
310
    ## the keys of typehash are the allowed values at position 06
316
    ## the keys of typehash are the allowed values at position 06
311
    ## of the leader of a MARC record, the values are the RIS types
317
    ## of the leader of a MARC record, the values are the RIS types
312
    ## that might appropriately represent these types.
318
    ## that might appropriately represent these types.
Lines 389-395 sub print_typetag { Link Here
389
sub normalize_author {
395
sub normalize_author {
390
    my($rawauthora, $rawauthorb, $rawauthorc, $nametype) = @_;
396
    my($rawauthora, $rawauthorb, $rawauthorc, $nametype) = @_;
391
397
392
    if ($nametype == 0) {
398
    if (! defined($nametype) || $nametype == 0) {
393
	# ToDo: convert every input to Last[,(F.|First)[ (M.|Middle)[,Suffix]]]
399
	# ToDo: convert every input to Last[,(F.|First)[ (M.|Middle)[,Suffix]]]
394
	warn("name >>$rawauthora<< in direct order - leave as is") if $marcprint;
400
	warn("name >>$rawauthora<< in direct order - leave as is") if $marcprint;
395
	return $rawauthora;
401
	return $rawauthora;
Lines 407-412 sub normalize_author { Link Here
407
413
408
	## start munging subfield b (something like the suffix)
414
	## start munging subfield b (something like the suffix)
409
	## remove trailing separators after spaces
415
	## remove trailing separators after spaces
416
	$rawauthorb = "" unless defined($rawauthorb);
410
	$rawauthorb =~ s% *[,;:/]*$%%;
417
	$rawauthorb =~ s% *[,;:/]*$%%;
411
418
412
	## we currently ignore subfield c until someone complains
419
	## we currently ignore subfield c until someone complains
Lines 424-434 sub normalize_author { Link Here
424
431
425
##********************************************************************
432
##********************************************************************
426
## get_author(): gets authorname info from MARC fields 100, 700
433
## get_author(): gets authorname info from MARC fields 100, 700
427
## Argument: field (100 or 700)
434
## Argument: MARC flavour type, field (100 or 700)
428
## Returns: an author string in the format found in the record
435
## Returns: an author string in the format found in the record
429
##********************************************************************
436
##********************************************************************
430
sub get_author {
437
sub get_author {
431
    my ($authorfield) = @_;
438
    my ($intype, $authorfield) = @_;
432
    my ($indicator);
439
    my ($indicator);
433
440
434
    ## the sequence of the name parts is encoded either in indicator
441
    ## the sequence of the name parts is encoded either in indicator
Lines 440-457 sub get_author { Link Here
440
	$indicator = 1;
447
	$indicator = 1;
441
    }
448
    }
442
449
443
    print "<marc>:Author(Ind$indicator): ", $authorfield->indicator("$indicator"),"\r\n" if $marcprint;
450
    # Must call subfield in scalar context before passing into normalize_author()
444
    print "<marc>:Author(\$a): ", $authorfield->subfield('a'),"\r\n" if $marcprint;
451
    my $i = $authorfield->indicator("$indicator");
445
    print "<marc>:Author(\$b): ", $authorfield->subfield('b'),"\r\n" if $marcprint;
452
    my $a = $authorfield->subfield('a');
446
    print "<marc>:Author(\$c): ", $authorfield->subfield('c'),"\r\n" if $marcprint;
453
    my $b = $authorfield->subfield('b');
447
    print "<marc>:Author(\$h): ", $authorfield->subfield('h'),"\r\n" if $marcprint;
454
    my $c = $authorfield->subfield('c');
448
    if ($intype eq "ukmarc") {
455
    my $h = $authorfield->subfield('h');
449
	my $authorname = $authorfield->subfield('a') . "," . $authorfield->subfield('h');
456
450
	normalize_author($authorname, $authorfield->subfield('b'), $authorfield->subfield('c'), $authorfield->indicator("$indicator"));
457
    print "<marc>:Author(Ind$indicator): $i\r\n" if $marcprint;
451
    }
458
    print "<marc>:Author(\$a): ", $a, "\r\n" if $marcprint;
452
    else {
459
    print "<marc>:Author(\$b): ", $b, "\r\n" if $marcprint;
453
	normalize_author($authorfield->subfield('a'), $authorfield->subfield('b'), $authorfield->subfield('c'), $authorfield->indicator("$indicator"));
460
    print "<marc>:Author(\$c): ", $c, "\r\n" if $marcprint;
454
    }
461
    print "<marc>:Author(\$h): ", $h, "\r\n" if $marcprint;
462
463
    my $authorname = $intype eq "ukmarc" ? $a . "," . $h : $a;
464
    normalize_author($authorname, $b, $c, $i);
455
}
465
}
456
466
457
##********************************************************************
467
##********************************************************************
Lines 474-488 sub get_editor { Link Here
474
}
484
}
475
485
476
##********************************************************************
486
##********************************************************************
477
## print_title(): gets info from MARC field 245
487
## print_title(): gets info from MARC field 245 or 200
478
## Arguments: field (245)
488
## Arguments: MARC flavour type, field (245 or 200)
479
## Returns: 
489
## Returns: 
480
##********************************************************************
490
##********************************************************************
481
sub print_title {
491
sub print_title {
482
    my ($titlefield) = @_;
492
    my ($intype, $titlefield) = @_;
483
    if (!$titlefield) {
493
    if (!$titlefield) {
484
	print "<marc>empty title field (245)\r\n" if $marcprint;
494
	print "<marc>empty title field (245)\r\n" if $marcprint;
485
	warn("empty title field (245)") if $marcprint;
495
	warn("empty title field (245)") if $marcprint;
496
	return undef;
486
    }
497
    }
487
    else {
498
    else {
488
	print "<marc>Title(\$a): ",$titlefield->subfield('a'),"\r\n" if $marcprint;
499
	print "<marc>Title(\$a): ",$titlefield->subfield('a'),"\r\n" if $marcprint;
Lines 496-504 sub print_title { Link Here
496
	## the separator and make sure there's a space between title and
507
	## the separator and make sure there's a space between title and
497
	## subtitle
508
	## subtitle
498
509
499
	my $clean_title = $titlefield->subfield('a');
510
	my $clean_title = $titlefield->subfield('a') || "";
500
511
501
	my $clean_subtitle = $titlefield->subfield('b');
512
	my $clean_subtitle = $titlefield->subfield('b') || "";
502
	$clean_title =~ s% *[/:;.]$%%;
513
	$clean_title =~ s% *[/:;.]$%%;
503
	$clean_subtitle =~ s%^ *(.*) *[/:;.]$%$1%;
514
	$clean_subtitle =~ s%^ *(.*) *[/:;.]$%$1%;
504
515
Lines 522-539 sub print_title { Link Here
522
533
523
##********************************************************************
534
##********************************************************************
524
## print_stitle(): prints info from series title field
535
## print_stitle(): prints info from series title field
525
## Arguments: field 
536
## Arguments: MARC flavour type, field
526
## Returns: 
537
## Returns: 
527
##********************************************************************
538
##********************************************************************
528
sub print_stitle {
539
sub print_stitle {
529
    my ($titlefield) = @_;
540
    my ($intype, $titlefield) = @_;
530
541
531
    if (!$titlefield) {
542
    if (!$titlefield) {
532
	print "<marc>empty series title field\r\n" if $marcprint;
543
	print "<marc>empty series title field\r\n" if $marcprint;
544
	return undef;
533
    }
545
    }
534
    else {
546
    else {
535
	print "<marc>Series title(\$a): ",$titlefield->subfield('a'),"\r\n" if $marcprint;
547
	print "<marc>Series title(\$a): ",$titlefield->subfield('a'),"\r\n" if $marcprint;
536
	my $clean_title = $titlefield->subfield('a');
548
	my $clean_title = $titlefield->subfield('a') || "";
537
549
538
	$clean_title =~ s% *[/:;.]$%%;
550
	$clean_title =~ s% *[/:;.]$%%;
539
551
Lines 640-650 sub print_dewey { Link Here
640
}
652
}
641
653
642
##********************************************************************
654
##********************************************************************
643
## print_pubinfo(): gets info from MARC field 260
655
## print_pubinfo(): gets info from MARC field 210, 260 or 264
644
## Arguments: field (260)
656
## Arguments: MARC flavour type, field (210 or 260 or 264)
645
##********************************************************************
657
##********************************************************************
646
sub print_pubinfo {
658
sub print_pubinfo {
647
    my($pubinfofield) = @_;
659
    my($intype, $pubinfofield) = @_;
648
660
649
    if (!$pubinfofield) {
661
    if (!$pubinfofield) {
650
    print "<marc>no publication information found (260/264)\r\n" if $marcprint;
662
    print "<marc>no publication information found (260/264)\r\n" if $marcprint;
Lines 708-714 sub print_pubinfo { Link Here
708
		## the dates are free-form, so we want to extract
720
		## the dates are free-form, so we want to extract
709
		## a four-digit year and leave the rest as
721
		## a four-digit year and leave the rest as
710
		## "other info"
722
		## "other info"
711
		$protoyear = @$tuple[1];
723
		my $protoyear = @$tuple[1];
712
		print "<marc>Year (260\$c): $protoyear\r\n" if $marcprint;
724
		print "<marc>Year (260\$c): $protoyear\r\n" if $marcprint;
713
725
714
		## strip any separator chars at the end
726
		## strip any separator chars at the end
Lines 769-784 sub get_keywords { Link Here
769
781
770
    ## loop over all 6XX fields
782
    ## loop over all 6XX fields
771
    foreach my $kwfield (@keywords) {
783
    foreach my $kwfield (@keywords) {
772
	if ($kwfield != undef) {
784
	if ( defined($kwfield) ) {
773
	    ## authornames get special treatment
785
	    ## authornames get special treatment
774
	    if ($fieldname eq "600") {
786
	    if ($fieldname eq "600") {
775
		my $val = normalize_author($kwfield->subfield('a'), $kwfield->subfield('b'), $kwfield->subfield('c'), $kwfield->indicator('1'));
787
		# Must call subfield in scalar context before passing into normalize_author()
788
		my $a = $kwfield->subfield('a');
789
		my $b = $kwfield->subfield('b');
790
		my $c = $kwfield->subfield('c');
791
792
		my $val = normalize_author($a, $b, $c, $kwfield->indicator('1'));
776
		${$href}{$val} += 1;
793
		${$href}{$val} += 1;
777
		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;
794
		print "<marc>Field $kwfield subfield a:", $a, "\r\n<marc>Field $kwfield subfield b:", $b, "\r\n<marc>Field $kwfield subfield c:", $c, "\r\n" if $marcprint;
778
	    }
795
	    }
779
	    else {
796
	    else {
780
		## retrieve all available subfields
797
		## retrieve all available subfields
781
		@kwsubfields = $kwfield->subfields();
798
		my @kwsubfields = $kwfield->subfields();
782
		
799
		
783
		## loop over all available subfield tuples
800
		## loop over all available subfield tuples
784
        foreach my $kwtuple (@kwsubfields) {
801
        foreach my $kwtuple (@kwsubfields) {
Lines 892-900 sub pool_subx { Link Here
892
909
893
    ## loop over all notefields
910
    ## loop over all notefields
894
    foreach my $notefield (@notefields) {
911
    foreach my $notefield (@notefields) {
895
	if ($notefield != undef) {
912
	if ( defined($notefield) ) {
896
	    ## retrieve all available subfield tuples
913
	    ## retrieve all available subfield tuples
897
	    @notesubfields = $notefield->subfields();
914
	    my @notesubfields = $notefield->subfields();
898
915
899
	    ## loop over all subfield tuples
916
	    ## loop over all subfield tuples
900
        foreach my $notetuple (@notesubfields) {
917
        foreach my $notetuple (@notesubfields) {
Lines 935-941 sub print_abstract { Link Here
935
    foreach my $abfield (@abfields) {
952
    foreach my $abfield (@abfields) {
936
        foreach my $field (@subfields) {
953
        foreach my $field (@subfields) {
937
            if ( length( $abfield->subfield($field) ) > 0 ) {
954
            if ( length( $abfield->subfield($field) ) > 0 ) {
938
                my $ab = $abfield->subfield($field);
955
                my $ab = $abfield->subfield($field) || "";
939
956
940
                print "<marc>field 520 subfield $field: $ab\r\n" if $marcprint;
957
                print "<marc>field 520 subfield $field: $ab\r\n" if $marcprint;
941
958
Lines 959-970 sub print_abstract { Link Here
959
    
976
    
960
    
977
    
961
##********************************************************************
978
##********************************************************************
962
## charconv(): converts to a different charset based on a global var
979
## charconv(): converts to a different charset based on a global var, $UTF
963
## Arguments: string
980
## Arguments: string
964
## Returns: string
981
## Returns: string
965
##********************************************************************
982
##********************************************************************
966
sub charconv {
983
sub charconv {
967
    if ($utf) {
984
    # FIXME $uniout is not referred to anywhere else in koha source.
985
    # TODO Initialise it for now, check RIS output using a non-UTF database
986
    my $uniout = "";
987
    if ($UTF) {
968
	## return unaltered if already utf-8
988
	## return unaltered if already utf-8
969
	return @_;
989
	return @_;
970
    }
990
    }
(-)a/t/Ris.t (-6 / +33 lines)
Lines 1-22 Link Here
1
#!/usr/bin/perl
1
#!/usr/bin/perl
2
#
2
#
3
# This Koha test module is a stub!  
3
# This file is part of Koha.
4
# Add more tests here!!!
4
#
5
# Koha is free software; you can redistribute it and/or modify it
6
# under the terms of the GNU General Public License as published by
7
# the Free Software Foundation; either version 3 of the License, or
8
# (at your option) any later version.
9
#
10
# Koha is distributed in the hope that it will be useful, but
11
# WITHOUT ANY WARRANTY; without even the implied warranty of
12
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13
# GNU General Public License for more details.
14
#
15
# You should have received a copy of the GNU General Public License
16
# along with Koha; if not, see <http://www.gnu.org/licenses>.
5
17
6
use strict;
18
use Modern::Perl;
7
use warnings;
8
19
9
use Test::More tests => 6;
20
use Test::More tests => 11;
10
21
11
BEGIN {
22
BEGIN {
12
        use_ok('C4::Ris');
23
        use_ok('C4::Ris');
13
}
24
}
14
25
26
# print*() functions
15
is(C4::Ris::print_typetag(),undef,'test printing typetag');
27
is(C4::Ris::print_typetag(),undef,'test printing typetag');
16
28
17
is(C4::Ris::print_title(),undef, 'test printing title when print_title is nil');
29
is(C4::Ris::print_title(),undef, 'test printing title when print_title is nil');
18
30
19
is(C4::Ris::print_stitle(),undef, 'test printing info from series title field when its nil');
31
is(C4::Ris::print_stitle(),undef, 'test printing info from series title field when its nil');
20
32
33
# author functions
34
my $authora = "Writer, A. ";
35
my $authorb = "Second, B. ";
36
is(C4::Ris::normalize_author($authora), "Writer, A. ", 'normalize author using undefined type (unchanged) with subfield a');
37
38
is(C4::Ris::normalize_author($authora, undef, undef, 0), "Writer, A. ", 'normalize author using type 0 (unchanged) with subfield a');
39
40
is(C4::Ris::normalize_author($authora, undef, undef, 3), "Writer, A. ", 'normalize author using type 3 (unchanged) with subfield a');
41
42
is(C4::Ris::normalize_author($authora, undef, undef, 1), "Writer,A.", 'normalize author using type 1 (cleaned) with subfield a');
43
44
is(C4::Ris::normalize_author($authora, $authorb, undef, 1), "Writer,A.,Second, B.", 'normalize author using type 1 (cleaned) with subfield a and b');
45
46
# charconv() function
21
ok((C4::Ris::charconv('hello world'))[0] eq 'hello world', 'testing that it returns what you entered');
47
ok((C4::Ris::charconv('hello world'))[0] eq 'hello world', 'testing that it returns what you entered');
22
ok(C4::Ris::charconv() == 0, 'testing when charconv is nil');
48
ok(C4::Ris::charconv() == 0, 'testing when charconv is nil');
23
- 
49
50
1;

Return to bug 2505