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

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

Return to bug 12357