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' ],
        },
};

sub search {

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

warn "# get $url\n";

        my $mech = WWW::Mechanize->new();
        $mech->get( $url );

warn "# got session\n";

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

warn "# submit search\n";

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

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

warn "# got $hits results, get first one\n";

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

warn "# in COMARC format\n";

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

        my $comarc;

        if ( $mech->content =~ m{<pre>\s*(.+1\..+?)\s*</pre>}s ) {
                my $comarc = $1;
                $comarc =~ s{</?b>}{}gs;
                $comarc =~ s{<font[^>]*>}{<s>}gs;
                $comarc =~ s{</font>}{<e>}gs;

                print $comarc;

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

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

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

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

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

                warn $marc->as_formatted;

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

}

1;
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	sub search {
34
35	my $url = 'http://cobiss.izum.si/scripts/cobiss?ukaz=GETID&lani=en';
36
37	warn "# get $url\n";
38
39	my $mech = WWW::Mechanize->new();
40	$mech->get( $url );
41
42	warn "# got session\n";
43
44	$mech->follow_link( text_regex => qr/union/ );
45
46	warn "# submit search\n";
47
48	$mech->submit_form(
49	fields => {
50	'SS1' => 'Krleza',
51	},
52	);
53
54	my $hits = 1;
55	if ( $mech->content =~ m{hits:\s<b>\s(\d+)\s*</b>}s ) {
56	$hits = $1;
57	} else {
58	warn "get't find results in ", $mech->content;
59	}
60
61	warn "# got $hits results, get first one\n";
62
63	$mech->follow_link( url_regex => qr/ukaz=DISP/ );
64
65	warn "# in COMARC format\n";
66
67	$mech->follow_link( url_regex => qr/fmt=13/ );
68
69	my $comarc;
70
71	if ( $mech->content =~ m{<pre>\s(.+1\..+?)\s</pre>}s ) {
72	my $comarc = $1;
73	$comarc =~ s{</?b>}{}gs;
74	$comarc =~ s{<font[^>]*>}{<s>}gs;
75	$comarc =~ s{</font>}{<e>}gs;
76
77	print $comarc;
78
79	my $marc = MARC::Record->new;
80
81	foreach my $line ( split(/[\r\n]+/, $comarc) ) {
82	our @f;
83
84	if ( $line !~ s{(\d\d\d)([01 ])([01 ])}{} ) {
85	warn "SKIP: $line\n";
86	} else {
87	$line .= "<eol>";
88
89	@f = ( $1, $2, $3 );
90	sub sf { warn "sf",@_,"\|",@f; push @f, @_; }
91	$line =~ s{<s>(\w)<e>([^<]+)\s*}{sf($1, $2)}ges;
92	warn "# f:", join(' ', @f), " left:\|$line\|\n";
93	$marc->add_fields( @f );
94	}
95	}
96
97	open(my $out, '>:utf8', 'out.marc');
98	print $out $marc->as_usmarc;
99	close($out);
100
101	warn $marc->as_formatted;
102
103	return $comarc;
104	} else {
105	die "can't fetch COMARC format from ", $mech->content;
106	}
107
108	}
109
110	1;