viewvc.cgi/Z3950-HTML-Scraper/COBISS.pm

package COBISS;

use warnings;
use strict;

use WWW::Mechanize;
use MARC::Record;
use Data::Dump qw/dump/;

binmode STDOUT, ':utf8';

my $cobiss_marc21 = {
        '010' => { a => [ '020', 'a' ] },
         200  => {
                        a => [  245 , 'a' ],
                        f => [  245 , 'f' ],
        },
         205  => { a => [  250 , 'a' ] },
         210  => {
                a => [  260 , 'a' ],
                c => [  260 , 'b' ],
                d => [  260 , 'c' ],
        },
        215 => {
                a => [  300 , 'a' ],
                c => [  300 , 'b' ],
                d => [  300 , 'c' ],
        },
        700 => {
                a => [  100 , 'a' ],
        },
};

our $mech = WWW::Mechanize->new();
our $hits;

sub diag {
        print "# ", @_, $/;
}

# Koha Z39.50 query:
#
# Bib-1 @and @and @and @and @and @and @and @or
# @attr 1=8 isbn-issn 
# @attr 1=7 isbn-issn 
# @attr 1=4 title 
# @attr 1=1003 author 
# @attr 1=16 dewey 
# @attr 1=21 subject-holding 
# @attr 1=12 control-no 
# @attr 1=1007 standard-id 
# @attr 1=1016 any

our $usemap = {
        8               => 'BN',        # FIXME check
        7               => 'SN',        # FIXME check
        4               => 'TI',
        1003    => 'TI',
        16              => 'CU',
        21              => 'SU',
#       12              => '',
#       1007    => '',
#       1016    => '',

};

sub search {
        my ( $self, $query ) = @_;

        die "need query" unless defined $query;

        my $url = 'http://cobiss.izum.si/scripts/cobiss?ukaz=GETID&lani=en';

diag "get $url";

        $mech->get( $url );

diag "got session";

        $mech->follow_link( text_regex => qr/union/ );

diag "switch to advanced form (select)";

        $mech->follow_link( url_regex => qr/mode=3/ );

diag "submit search $query";

        $mech->submit_form(
                fields => {
                        'SS1' => $query,
                },
        );

        $hits = 0;
        if ( $mech->content =~ m{hits:\s*<b>\s*(\d+)\s*</b>}s ) {
                $hits = $1;
        } else {
                diag "get't find results in ", $mech->content;
                return;
        }

diag "got $hits results, get first one";

        $mech->follow_link( url_regex => qr/ukaz=DISP/ );

diag "in COMARC format";

        $mech->follow_link( url_regex => qr/fmt=13/ );
}


sub fetch_rec {
        my ($self,$format) = @_;

        $format ||= 'unimarc';

        die "unknown format: $format" unless $format =~ m{(uni|us)marc};

        my $comarc;

        if ( $mech->content =~ m{<pre>\s*(.+?(\d+)\.\s+ID=(\d+).+?)\s*</pre>}s ) {

                my $comarc = $1;
                my $nr = $2;
                my $id = $3;

diag "fetch_marc $nr [$id] $format";

                $comarc =~ s{</?b>}{}gs;
                $comarc =~ s{<font[^>]*>}{<s>}gs;
                $comarc =~ s{</font>}{<e>}gs;

                open(my $out, '>:utf8', "comarc/$id");
                print $out $comarc;
                close($out);

                print $comarc;

                my $marc = MARC::Record->new;

                foreach my $line ( split(/[\r\n]+/, $comarc) ) {

                        if ( $line !~ s{^(\d\d\d)([01 ])([01 ])}{} ) {
                                diag "SKIP: $line";
                        } else {
                                our @f = ( $1, $2, $3 );
                                $line .= "<eol>";

                                if ( $format eq 'unimarc' ) {

                                        diag dump(@f), "line: $line";
                                        sub sf_uni {
                                                warn "sf ",dump(@_);
                                                push @f, @_;
                                        }
                                        $line =~ s{<s>(\w)<e>([^<]+)\s*}{sf_uni($1, $2)}ges;
                                        diag "f:", dump(@f), " left: |$line|";
                                        $marc->add_fields( @f );

                                } elsif ( $format eq 'usmarc' ) {

                                        my ( $f, $i1, $i2 ) = @f;

                                        our $out = {};

                                        sub sf_us {
                                                my ($f,$sf,$v) = @_;
                                                if ( my $m = $cobiss_marc21->{$f}->{$sf} ) {
                                                        push @{ $out->{ $m->[0] } }, ( $m->[1], $v );
                                                }
                                                return;
                                        }
                                        $line =~ s{<s>(\w)<e>([^<]+)\s*}{sf_us($f,$1, $2)}ges;

                                        diag "converted marc21 ",dump( $out );

                                        foreach my $f ( keys %$out ) {
                                                $marc->add_fields( $f, $i1, $i2, @{ $out->{$f} } );
                                        }
                                }
                        }
                }

                my $path = "marc/$id.$format";

                open($out, '>:utf8', $path);
                print $out $marc->as_usmarc;
                close($out);

                diag "created $path ", -s $path, " bytes";

                diag $marc->as_formatted;

                $nr++;
                $mech->follow_link( url_regex => qr/rec=$nr/ );

                return $marc->as_usmarc;
        } else {
                die "can't fetch COMARC format from ", $mech->content;
        }

}

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