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

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

Return to bug 12357