Attachment #34442 for bug #2505

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

Lines 59-66 package C4::Ris; Link Here

(-)a/C4/Ris.pm (-51 / +71 lines)
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	}




#!/usr/bin/perl
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# Koha is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.

use Modern::Perl;
use warnings;

use Test::More tests => 11;

BEGIN {
        use_ok('C4::Ris');
}

# print*() functions
is(C4::Ris::print_typetag(),undef,'test printing typetag');

is(C4::Ris::print_title(),undef, 'test printing title when print_title is nil');

is(C4::Ris::print_stitle(),undef, 'test printing info from series title field when its nil');

# author functions
my $authora = "Writer, A. ";
my $authorb = "Second, B. ";
is(C4::Ris::normalize_author($authora), "Writer, A. ", 'normalize author using undefined type (unchanged) with subfield a');

is(C4::Ris::normalize_author($authora, undef, undef, 0), "Writer, A. ", 'normalize author using type 0 (unchanged) with subfield a');

is(C4::Ris::normalize_author($authora, undef, undef, 3), "Writer, A. ", 'normalize author using type 3 (unchanged) with subfield a');

is(C4::Ris::normalize_author($authora, undef, undef, 1), "Writer,A.", 'normalize author using type 1 (cleaned) with subfield a');

is(C4::Ris::normalize_author($authora, $authorb, undef, 1), "Writer,A.,Second, B.", 'normalize author using type 1 (cleaned) with subfield a and b');

# charconv() function
ok((C4::Ris::charconv('hello world'))[0] eq 'hello world', 'testing that it returns what you entered');
ok(C4::Ris::charconv() == 0, 'testing when charconv is nil');

1;

Return to bug 2505

Lines 1-22 Link Here

(-)a/t/Ris.t (-6 / +33 lines)
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;