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

package COBISS;

use warnings;
use strict;

use WWW::Mechanize;
use MARC::Record;
use File::Slurp;

binmode STDOUT, ':utf8';

my $cobiss_marc21 = {
        '010' => { a => [ '020', 'a' ] },
         200  => {
                        a => [  245 , 'a' ],
                        f => [  245 , 'f' ],
        },
         205  => { a => [  250 , 'a' ] },
         210  => {
                a => [  250 , '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)";

diag $mech->content;

        $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_marc {
        my ($self) = @_;

        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]";

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

                write_file "comarc/$id", $comarc;

                print $comarc;

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

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

                        if ( $line !~ s{^(\d\d\d)([01 ])([01 ])}{} ) {
                                diag "SKIP: $line";
                        } else {
                                $line .= "<eol>";

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

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

                diag $marc->as_formatted;

                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	4	use File::Slurp;
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			a => [ 250 , 'a' ],
21			c => [ 260 , 'b' ],
22			d => [ 260 , 'c' ],
23			},
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	4	diag "# get $url";
80	dpavlin	1
81			$mech->get( $url );
82
83	dpavlin	4	diag "# got session";
84	dpavlin	1
85			$mech->follow_link( text_regex => qr/union/ );
86
87	dpavlin	4	diag "# switch to advanced form (select)";
88	dpavlin	1
89	dpavlin	4	diag $mech->content;
90
91			$mech->follow_link( url_regex => qr/mode=3/ );
92
93			diag "# submit search $query";
94
95	dpavlin	1	$mech->submit_form(
96			fields => {
97	dpavlin	4	'SS1' => $query,
98	dpavlin	1	},
99			);
100
101	dpavlin	4	$hits = 0;
102	dpavlin	1	if ( $mech->content =~ m{hits:\s<b>\s(\d+)\s*</b>}s ) {
103			$hits = $1;
104			} else {
105	dpavlin	4	diag "get't find results in ", $mech->content;
106			return;
107	dpavlin	1	}
108
109	dpavlin	4	diag "# got $hits results, get first one";
110	dpavlin	1
111			$mech->follow_link( url_regex => qr/ukaz=DISP/ );
112
113	dpavlin	4	diag "# in COMARC format";
114	dpavlin	1
115			$mech->follow_link( url_regex => qr/fmt=13/ );
116	dpavlin	4	}
117	dpavlin	1
118	dpavlin	4
119			sub fetch_marc {
120			my ($self) = @_;
121
122	dpavlin	1	my $comarc;
123
124	dpavlin	4	if ( $mech->content =~ m{<pre>\s(.+?(\d+\.)\s+ID=(\d+).+?)\s</pre>}s ) {
125
126	dpavlin	1	my $comarc = $1;
127	dpavlin	4	my $nr = $2;
128			my $id = $3;
129
130			diag "# fetch_marc $nr [$id]";
131
132	dpavlin	1	$comarc =~ s{</?b>}{}gs;
133	dpavlin	2	$comarc =~ s{<font[^>]*>}{<s>}gs;
134			$comarc =~ s{</font>}{<e>}gs;
135	dpavlin	1
136	dpavlin	4	write_file "comarc/$id", $comarc;
137
138	dpavlin	1	print $comarc;
139
140	dpavlin	2	my $marc = MARC::Record->new;
141
142			foreach my $line ( split(/[\r\n]+/, $comarc) ) {
143			our @f;
144
145	dpavlin	4	if ( $line !~ s{^(\d\d\d)([01 ])([01 ])}{} ) {
146			diag "SKIP: $line";
147	dpavlin	2	} else {
148			$line .= "<eol>";
149
150			@f = ( $1, $2, $3 );
151	dpavlin	4	sub sf { push @f, @_; }
152	dpavlin	2	$line =~ s{<s>(\w)<e>([^<]+)\s*}{sf($1, $2)}ges;
153	dpavlin	4	diag "# f:", join('\|', @f), " left: \|$line\|";
154	dpavlin	2	$marc->add_fields( @f );
155			}
156			}
157
158	dpavlin	4	open(my $out, '>:utf8', "marc/$id");
159	dpavlin	2	print $out $marc->as_usmarc;
160			close($out);
161
162	dpavlin	4	diag $marc->as_formatted;
163	dpavlin	2
164	dpavlin	4	return $marc->as_usmarc;
165	dpavlin	1	} else {
166			die "can't fetch COMARC format from ", $mech->content;
167			}
168
169			}
170
171			1;