0ca18aaf33019f24fdf2b582be4465b0075a7d68
[crolist2marc] / crolist2marc.pl
1 #!/usr/bin/perl
2 use warnings;
3 use strict;
4 use autodie;
5
6 use MARC::Record;
7 use Data::Dump qw(dump);
8 use utf8;
9
10 my $data;
11
12 sub vc_casefix { # partial reverse-engeenered implementation of case mapping
13         my ( $tag, $sfi, $vc, $k, $rest ) = @_;
14
15         $vc .= " " x (4 - length($vc));
16
17         $k =~ tr/^~]}\\|[{@`/ČčĆćĐ𩹮ž/; # CROASCII (YUS|HRN) B1.002:1982
18
19         my @m = map { ord($_) } split(//, $vc);
20
21         my $mask = ( $m[3] & 0b00001111 ) << 4 | ( $m[2] & 0b00001111 );
22
23         my $sel = 0b10000000;
24         my $fixed;
25         my @chars = split(//, $k);
26         foreach my $c ( @chars ) {
27                 die "key [$k]" unless defined $c;
28                 $fixed .= $mask & $sel ? uc($c) : lc($c);
29                 $sel >>= 1;
30         }
31
32         if ( substr($vc,0,1) eq 'x' || ( $vc eq 'am  ' && $tag =~ m/^(200|210|225)$/ ) ) { #&& $sfi eq '$a' )) {
33                 $fixed = ucfirst $fixed;
34         }
35
36         if ( $rest && length($fixed) < 8 ) {
37 #               warn "# padding $fixed|$rest";
38                 $fixed .= " " x ( 8 - length($fixed) );
39         }
40
41         return $fixed . $rest;
42 }
43
44 sub csv_file {
45         my ($file,$parse) = @_;
46
47         print STDERR "# reading $file ";
48         my $lines = 1;
49
50         open(my $fh, '<:encoding(UTF-8)', $file);
51         my $h = <$fh>; # header
52         while(<$fh>) {
53                 chomp;
54                 
55 #               tr/^~]}\\|[{@`/ČčĆćĐ𩹮ž/; # CROASCII (YUS|HRN) B1.002:1982
56
57                 my ( $idsl, $tag, $tagno, $id, $sfi, $sfino, $text ) = $parse->($_);
58                 $lines++;
59
60                 if ( ! $text ) {
61                         print STDERR "\nSKIP $file +$lines [$_] " if $idsl;
62                         next;
63                 }
64
65                 $tagno ||= 0;
66                 $sfino ||= 0;
67
68                 $id .= " " if length $id < 2;
69                 $id .= " " if length $id < 2;
70                 my ($i1, $i2) = split(//, $id, 2);
71
72                 $sfi =~ s/^\$// || die "can't fix subfield [$sfi]";
73
74                 $text =~ tr/^~]}\\|[{@`/ČčĆćĐ𩹮ž/; # CROASCII (YUS|HRN) B1.002:1982
75
76                 $data->{$idsl}->{$tag}->[ $tagno ]->[ 0 ] = $i1;
77                 $data->{$idsl}->{$tag}->[ $tagno ]->[ 1 ] = $i2;
78                 $data->{$idsl}->{$tag}->[ $tagno ]->[ ( $sfino * 2 ) + 2 ] = $sfi;
79                 $data->{$idsl}->{$tag}->[ $tagno ]->[ ( $sfino * 2 ) + 3 ] = $text;
80
81                 print STDERR "$lines " if $lines % 1000 == 0;
82         }
83         print STDERR "\n";
84 }
85
86 csv_file( 'tsv/TEKTAG.csv', sub {
87         my $line = shift;
88
89         my ( $idsl, $tag, $tagno, $id, $sfi, $sfino, $textkey, $textres, $vc ) = split(/\t/,$_);
90
91         my $text = vc_casefix( $tag, $sfi, $vc, $textkey, $textres );
92
93         return ( $idsl, $tag, $tagno, $id, $sfi, $sfino, $text );
94 });
95
96 csv_file( 'tsv/NUMTAG.csv', sub {
97         my $line = shift;
98
99         my ( $IDSL, $TAG, $TAGNO, $ID, $SFI, $SFINO, $LTAG, $LTAGNO, $LID, $LSFI, $TXKEY, $TXRES, $VC, $STOPW ) = split(/\t/,$_);
100
101         my $text = vc_casefix( $TAG, $SFI, $VC, $TXKEY, $TXRES );
102
103         return ( $IDSL, $TAG, $TAGNO, $ID, $SFI, $SFINO, $text );
104 });
105
106 csv_file( 'tsv/LONTAG.csv', sub {
107         my $line = shift;
108
109         my ( $idsl, $tag, $tagno, $id, $sfi, $sfino, $text ) = split(/\t/,$_, 7);
110
111         $text =~ s/\t+$//;
112         $text =~ s/\t/\n/g; # join OPIS[1-11]
113
114         return ( $idsl, $tag, $tagno, $id, $sfi, $sfino, $text );
115 });
116
117 csv_file( 'tsv/IDNTAG.csv', sub {
118         my $line = shift;
119
120         my ( $idsl, $tag, $STSL, $KZVS, $BIBRAZ, $HIRAZ, $KPS, $OKO ) = split(/\t/,$_);
121
122         my @leader;
123         $leader[5] = $STSL;
124         $leader[6] = $KZVS;
125         $leader[7] = $BIBRAZ;
126         $leader[8] = $HIRAZ;
127         $leader[17] = $KPS;
128         $leader[18] = $OKO;
129
130         $leader[23] = ' '; # last char;
131
132         my $full = join('', map { defined $_ ? $_ : ' ' } @leader);
133         $data->{$idsl}->{'leader'} = $full; 
134         return;
135 });
136
137 csv_file( 'tsv/OBRTAG.csv', sub {
138         my $line = shift;
139
140         my ( $IDSL, $TAG, $TAGNO, $ID, $SFI, $SFINO, $CODINF ) = split(/\t/,$_);
141         return ( $IDSL, $TAG, $TAGNO, $ID, $SFI, $SFINO, $CODINF );
142 });
143
144 print STDERR "\n# getting all ids ";
145 my @ids = sort keys %$data;
146 print STDERR scalar(@ids), " found\n";
147
148 my $marc_file = 'liberated.marc';
149 open(my $marc_fh, '>:encoding(UTF-8)', $marc_file);
150 my $number = 0;
151
152 foreach my $id ( @ids ) {
153         my $rec = MARC::Record->new;
154         $rec->encoding( 'UTF-8' );
155         $rec->add_fields( [ '001', $id ] );
156
157         foreach my $field ( sort keys %{ $data->{$id} } ) {
158                 if ( $field eq 'leader' ) {
159                         $rec->leader( $data->{$id}->{$field} );
160                         next;
161                 }
162                 foreach my $arr ( @{ $data->{$id}->{$field} } ) {
163                         if ( ! $arr ) {
164 #                               print STDERR "SKIPPED $id $field ",dump( $data->{$id}->{$field} ), "\n";
165                                 next;
166                         }
167                         $arr = [ $arr->[3] ] if ( $field < 010 ); # control fields don't have idicators or subfields
168                         $rec->add_fields( $field, @$arr );
169                 }
170         }
171
172         #print $rec->as_formatted;
173         #print "# $id ",dump($data->{$id});
174
175         print $marc_fh $rec->as_usmarc;
176         $number++;
177         print "$number " if $number % 1000 == 0;
178 }
179
180 close($marc_fh);
181 print "$marc_file ",-s $marc_file, " bytes\n";