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

package COBISS;

use warnings;
use strict;

use WWW::Mechanize;
use MARC::Record;

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

        $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;

                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 {
                                $line .= "<eol>";

                                our @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;

                $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	1
9	dpavlin	2	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	dpavlin	4	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	dpavlin	1	sub search {
72	dpavlin	4	my ( $self, $query ) = @_;
73	dpavlin	1
74	dpavlin	4	die "need query" unless defined $query;
75
76	dpavlin	1	my $url = 'http://cobiss.izum.si/scripts/cobiss?ukaz=GETID&lani=en';
77
78	dpavlin	7	diag "get $url";
79	dpavlin	1
80			$mech->get( $url );
81
82	dpavlin	7	diag "got session";
83	dpavlin	1
84			$mech->follow_link( text_regex => qr/union/ );
85
86	dpavlin	7	diag "switch to advanced form (select)";
87	dpavlin	1
88	dpavlin	4	$mech->follow_link( url_regex => qr/mode=3/ );
89
90	dpavlin	7	diag "submit search $query";
91	dpavlin	4
92	dpavlin	1	$mech->submit_form(
93			fields => {
94	dpavlin	4	'SS1' => $query,
95	dpavlin	1	},
96			);
97
98	dpavlin	4	$hits = 0;
99	dpavlin	1	if ( $mech->content =~ m{hits:\s<b>\s(\d+)\s*</b>}s ) {
100			$hits = $1;
101			} else {
102	dpavlin	4	diag "get't find results in ", $mech->content;
103			return;
104	dpavlin	1	}
105
106	dpavlin	7	diag "got $hits results, get first one";
107	dpavlin	1
108			$mech->follow_link( url_regex => qr/ukaz=DISP/ );
109
110	dpavlin	7	diag "in COMARC format";
111	dpavlin	1
112			$mech->follow_link( url_regex => qr/fmt=13/ );
113	dpavlin	4	}
114	dpavlin	1
115	dpavlin	4
116			sub fetch_marc {
117			my ($self) = @_;
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	7	diag "fetch_marc $nr [$id]";
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			$line .= "<eol>";
147
148	dpavlin	7	our @f = ( $1, $2, $3 );
149	dpavlin	4	sub sf { push @f, @_; }
150	dpavlin	2	$line =~ s{<s>(\w)<e>([^<]+)\s*}{sf($1, $2)}ges;
151	dpavlin	7	diag "f:", join('\|', @f), " left: \|$line\|";
152	dpavlin	2	$marc->add_fields( @f );
153			}
154			}
155
156	dpavlin	4	open(my $out, '>:utf8', "marc/$id");
157	dpavlin	2	print $out $marc->as_usmarc;
158			close($out);
159
160	dpavlin	4	diag $marc->as_formatted;
161	dpavlin	2
162	dpavlin	8	$nr++;
163			$mech->follow_link( url_regex => qr/rec=$nr/ );
164
165	dpavlin	4	return $marc->as_usmarc;
166	dpavlin	1	} else {
167			die "can't fetch COMARC format from ", $mech->content;
168			}
169
170			}
171
172			1;