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 usemap {
        my $f = shift || die;
        $usemap->{$f};
}

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			sub usemap {
68			my $f = shift \|\| die;
69			$usemap->{$f};
70			}
71
72	dpavlin	1	sub search {
73	dpavlin	4	my ( $self, $query ) = @_;
74	dpavlin	1
75	dpavlin	4	die "need query" unless defined $query;
76
77	dpavlin	1	my $url = 'http://cobiss.izum.si/scripts/cobiss?ukaz=GETID&lani=en';
78
79	dpavlin	7	diag "get $url";
80	dpavlin	1
81			$mech->get( $url );
82
83	dpavlin	7	diag "got session";
84	dpavlin	1
85			$mech->follow_link( text_regex => qr/union/ );
86
87	dpavlin	7	diag "switch to advanced form (select)";
88	dpavlin	1
89	dpavlin	4	$mech->follow_link( url_regex => qr/mode=3/ );
90
91	dpavlin	7	diag "submit search $query";
92	dpavlin	4
93	dpavlin	1	$mech->submit_form(
94			fields => {
95	dpavlin	4	'SS1' => $query,
96	dpavlin	1	},
97			);
98
99	dpavlin	4	$hits = 0;
100	dpavlin	1	if ( $mech->content =~ m{hits:\s<b>\s(\d+)\s*</b>}s ) {
101			$hits = $1;
102			} else {
103	dpavlin	4	diag "get't find results in ", $mech->content;
104			return;
105	dpavlin	1	}
106
107	dpavlin	7	diag "got $hits results, get first one";
108	dpavlin	1
109			$mech->follow_link( url_regex => qr/ukaz=DISP/ );
110
111	dpavlin	7	diag "in COMARC format";
112	dpavlin	1
113			$mech->follow_link( url_regex => qr/fmt=13/ );
114	dpavlin	4	}
115	dpavlin	1
116	dpavlin	4
117	dpavlin	9	sub fetch_rec {
118			my ($self,$format) = @_;
119	dpavlin	4
120	dpavlin	9	$format \|\|= 'unimarc';
121
122			die "unknown format: $format" unless $format =~ m{(uni\|us)marc};
123
124	dpavlin	1	my $comarc;
125
126	dpavlin	8	if ( $mech->content =~ m{<pre>\s(.+?(\d+)\.\s+ID=(\d+).+?)\s</pre>}s ) {
127	dpavlin	4
128	dpavlin	1	my $comarc = $1;
129	dpavlin	4	my $nr = $2;
130			my $id = $3;
131
132	dpavlin	9	diag "fetch_marc $nr [$id] $format";
133	dpavlin	4
134	dpavlin	1	$comarc =~ s{</?b>}{}gs;
135	dpavlin	2	$comarc =~ s{<font[^>]*>}{<s>}gs;
136			$comarc =~ s{</font>}{<e>}gs;
137	dpavlin	1
138	dpavlin	8	open(my $out, '>:utf8', "comarc/$id");
139			print $out $comarc;
140			close($out);
141	dpavlin	4
142	dpavlin	1	print $comarc;
143
144	dpavlin	2	my $marc = MARC::Record->new;
145
146			foreach my $line ( split(/[\r\n]+/, $comarc) ) {
147
148	dpavlin	4	if ( $line !~ s{^(\d\d\d)([01 ])([01 ])}{} ) {
149			diag "SKIP: $line";
150	dpavlin	2	} else {
151	dpavlin	9	our @f = ( $1, $2, $3 );
152	dpavlin	2	$line .= "<eol>";
153
154	dpavlin	9	if ( $format eq 'unimarc' ) {
155
156			diag dump(@f), "line: $line";
157			sub sf_uni {
158			warn "sf ",dump(@_);
159			push @f, @_;
160			}
161			$line =~ s{<s>(\w)<e>([^<]+)\s*}{sf_uni($1, $2)}ges;
162			diag "f:", dump(@f), " left: \|$line\|";
163			$marc->add_fields( @f );
164
165			} elsif ( $format eq 'usmarc' ) {
166
167			my ( $f, $i1, $i2 ) = @f;
168
169			our $out = {};
170
171			sub sf_us {
172			my ($f,$sf,$v) = @_;
173			if ( my $m = $cobiss_marc21->{$f}->{$sf} ) {
174			push @{ $out->{ $m->[0] } }, ( $m->[1], $v );
175			}
176			return;
177			}
178			$line =~ s{<s>(\w)<e>([^<]+)\s*}{sf_us($f,$1, $2)}ges;
179
180			diag "converted marc21 ",dump( $out );
181
182			foreach my $f ( keys %$out ) {
183			$marc->add_fields( $f, $i1, $i2, @{ $out->{$f} } );
184			}
185			}
186	dpavlin	2	}
187			}
188
189	dpavlin	9	my $path = "marc/$id.$format";
190
191			open($out, '>:utf8', $path);
192	dpavlin	2	print $out $marc->as_usmarc;
193			close($out);
194
195	dpavlin	9	diag "created $path ", -s $path, " bytes";
196
197	dpavlin	4	diag $marc->as_formatted;
198	dpavlin	2
199	dpavlin	8	$nr++;
200			$mech->follow_link( url_regex => qr/rec=$nr/ );
201
202	dpavlin	4	return $marc->as_usmarc;
203	dpavlin	1	} else {
204			die "can't fetch COMARC format from ", $mech->content;
205			}
206
207			}
208
209			1;