git.rot13.org Git - crolist2marc/blob - 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' || ( $tag =~ m/^(200|210|225|700|701|702|710|711|712)$/ ) ) { #&& $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";