COBISS.pm

   1 package COBISS;
   2
   3 use warnings;
   4 use strict;
   5
   6 use WWW::Mechanize;
   7 use MARC::Record;
   8
   9 binmode STDOUT, ':utf8';
  10
  11 my $cobiss_marc21 = {
  12         '010' => { a => [ '020', 'a' ] },
  13          200  => {
  14                         a => [  245 , 'a' ],
  15                         f => [  245 , 'f' ],
  16         },
  17          205  => { a => [  250 , 'a' ] },
  18          210  => {
  19                 a => [  250 , 'a' ],
  20                 c => [  260 , 'b' ],
  21                 d => [  260 , 'c' ],
  22         },
  23         215 => {
  24                 a => [  300 , 'a' ],
  25                 c => [  300 , 'b' ],
  26                 d => [  300 , 'c' ],
  27         },
  28         700 => {
  29                 a => [  100 , 'a' ],
  30         },
  31 };
  32
  33 our $mech = WWW::Mechanize->new();
  34 our $hits;
  35
  36 sub diag {
  37         print "# ", @_, $/;
  38 }
  39
  40 # Koha Z39.50 query:
  41 #
  42 # Bib-1 @and @and @and @and @and @and @and @or
  43 # @attr 1=8 isbn-issn
  44 # @attr 1=7 isbn-issn
  45 # @attr 1=4 title
  46 # @attr 1=1003 author
  47 # @attr 1=16 dewey
  48 # @attr 1=21 subject-holding
  49 # @attr 1=12 control-no
  50 # @attr 1=1007 standard-id
  51 # @attr 1=1016 any
  52
  53 our $usemap = {
  54         8               => 'BN',        # FIXME check
  55         7               => 'SN',        # FIXME check
  56         4               => 'TI',
  57         1003    => 'TI',
  58         16              => 'CU',
  59         21              => 'SU',
  60 #       12              => '',
  61 #       1007    => '',
  62 #       1016    => '',
  63
  64 };
  65
  66 sub usemap {
  67         my $f = shift || die;
  68         $usemap->{$f};
  69 }
  70
  71 sub search {
  72         my ( $self, $query ) = @_;
  73
  74         die "need query" unless defined $query;
  75
  76         my $url = 'http://cobiss.izum.si/scripts/cobiss?ukaz=GETID&lani=en';
  77
  78 diag "get $url";
  79
  80         $mech->get( $url );
  81
  82 diag "got session";
  83
  84         $mech->follow_link( text_regex => qr/union/ );
  85
  86 diag "switch to advanced form (select)";
  87
  88         $mech->follow_link( url_regex => qr/mode=3/ );
  89
  90 diag "submit search $query";
  91
  92         $mech->submit_form(
  93                 fields => {
  94                         'SS1' => $query,
  95                 },
  96         );
  97
  98         $hits = 0;
  99         if ( $mech->content =~ m{hits:\s*<b>\s*(\d+)\s*</b>}s ) {
 100                 $hits = $1;
 101         } else {
 102                 diag "get't find results in ", $mech->content;
 103                 return;
 104         }
 105
 106 diag "got $hits results, get first one";
 107
 108         $mech->follow_link( url_regex => qr/ukaz=DISP/ );
 109
 110 diag "in COMARC format";
 111
 112         $mech->follow_link( url_regex => qr/fmt=13/ );
 113 }
 114
 115
 116 sub fetch_marc {
 117         my ($self) = @_;
 118
 119         my $comarc;
 120
 121         if ( $mech->content =~ m{<pre>\s*(.+?(\d+)\.\s+ID=(\d+).+?)\s*</pre>}s ) {
 122
 123                 my $comarc = $1;
 124                 my $nr = $2;
 125                 my $id = $3;
 126
 127 diag "fetch_marc $nr [$id]";
 128
 129                 $comarc =~ s{</?b>}{}gs;
 130                 $comarc =~ s{<font[^>]*>}{<s>}gs;
 131                 $comarc =~ s{</font>}{<e>}gs;
 132
 133                 open(my $out, '>:utf8', "comarc/$id");
 134                 print $out $comarc;
 135                 close($out);
 136
 137                 print $comarc;
 138
 139                 my $marc = MARC::Record->new;
 140
 141                 foreach my $line ( split(/[\r\n]+/, $comarc) ) {
 142
 143                         if ( $line !~ s{^(\d\d\d)([01 ])([01 ])}{} ) {
 144                                 diag "SKIP: $line";
 145                         } else {
 146                                 $line .= "<eol>";
 147
 148                                 our @f = ( $1, $2, $3 );
 149                                 sub sf { push @f, @_; }
 150                                 $line =~ s{<s>(\w)<e>([^<]+)\s*}{sf($1, $2)}ges;
 151                                 diag "f:", join('|', @f), " left: |$line|";
 152                                 $marc->add_fields( @f );
 153                         }
 154                 }
 155
 156                 open(my $out, '>:utf8', "marc/$id");
 157                 print $out $marc->as_usmarc;
 158                 close($out);
 159
 160                 diag $marc->as_formatted;
 161
 162                 $nr++;
 163                 $mech->follow_link( url_regex => qr/rec=$nr/ );
 164
 165                 return $marc->as_usmarc;
 166         } else {
 167                 die "can't fetch COMARC format from ", $mech->content;
 168         }
 169
 170 }
 171
 172 1;