lib/WebPAC/Input.pm

package WebPAC::Input;

use warnings;
use strict;

use blib;

use WebPAC::Common;
use base qw/WebPAC::Common/;
use Data::Dumper;
use Encode qw/from_to/;

=head1 NAME

WebPAC::Input - read different file formats into WebPAC

=head1 VERSION

Version 0.11

=cut

our $VERSION = '0.11';

=head1 SYNOPSIS

This module implements input as database which have fixed and known
I<size> while indexing and single unique numeric identifier for database
position ranging from 1 to I<size>.

Simply, something that is indexed by unmber from 1 .. I<size>.

Examples of such databases are CDS/ISIS files, MARC files, lines in
text file, and so on.

Specific file formats are implemented using low-level interface modules,
located in C<WebPAC::Input::*> namespace which export C<open_db>,
C<fetch_rec> and optional C<init> functions.

Perhaps a little code snippet.

        use WebPAC::Input;

        my $db = WebPAC::Input->new(
                module => 'WebPAC::Input::ISIS',
                low_mem => 1,
        );

        $db->open( path => '/path/to/database' );
        print "database size: ",$db->size,"\n";
        while (my $rec = $db->fetch) {
                # do something with $rec
        }


=head1 FUNCTIONS

=head2 new

Create new input database object.

  my $db = new WebPAC::Input(
        module => 'WebPAC::Input::MARC',
        encoding => 'ISO-8859-2',
        low_mem => 1,
        recode => 'char pairs',
        no_progress_bar => 1,
  );

C<module> is low-level file format module. See L<WebPAC::Input::ISIS> and
L<WebPAC::Input::MARC>.

Optional parametar C<encoding> specify application code page (which will be
used internally). This should probably be your terminal encoding, and by
default, it C<ISO-8859-2>.

Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).

C<recode> is optional string constisting of character or words pairs that
should be replaced in input stream.

C<no_progress_bar> disables progress bar output on C<STDOUT>

This function will also call low-level C<init> if it exists with same
parametars.

=cut

sub new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        my $log = $self->_get_logger;

        $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
        $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});

        $log->logconfess("specify low-level file format module") unless ($self->{module});
        my $module = $self->{module};
        $module =~ s#::#/#g;
        $module .= '.pm';
        $log->debug("require low-level module $self->{module} from $module");

        require $module;
        #eval $self->{module} .'->import';

        # check if required subclasses are implemented
        foreach my $subclass (qw/open_db fetch_rec init/) {
                my $n = $self->{module} . '::' . $subclass;
                if (! defined &{ $n }) {
                        my $missing = "missing $subclass in $self->{module}";
                        $self->{$subclass} = sub { $log->logwarn($missing) };
                } else {
                        $self->{$subclass} = \&{ $n };
                }
        }

        if ($self->{init}) {
                $log->debug("calling init");
                $self->{init}->($self, @_);
        }

        $self->{'encoding'} ||= 'ISO-8859-2';

        # running with low_mem flag? well, use DBM::Deep then.
        if ($self->{'low_mem'}) {
                $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");

                my $db_file = "data.db";

                if (-e $db_file) {
                        unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
                        $log->debug("removed '$db_file' from last run");
                }

                require DBM::Deep;

                my $db = new DBM::Deep $db_file;

                $log->logdie("DBM::Deep error: $!") unless ($db);

                if ($db->error()) {
                        $log->logdie("can't open '$db_file' under low_mem: ",$db->error());
                } else {
                        $log->debug("using file '$db_file' for DBM::Deep");
                }

                $self->{'db'} = $db;
        }

        $self ? return $self : return undef;
}

=head2 open

This function will read whole database in memory and produce lookups.

 $input->open(
        path => '/path/to/database/file',
        code_page => 'cp852',
        limit => 500,
        offset => 6000,
        lookup => $lookup_obj,
        stats => 1,
        lookup_ref => sub {
                my ($k,$v) = @_;
                # store lookup $k => $v
        },
        modify_records => {
                900 => { '^a' => { ' : ' => '^b' } },
                901 => { '*' => { '^b' => ' ; ' } },
        },
 );

By default, C<code_page> is assumed to be C<cp852>.

C<offset> is optional parametar to position at some offset before reading from database.

C<limit> is optional parametar to read just C<limit> records from database

C<stats> create optional report about usage of fields and subfields

C<lookup_coderef> is closure to call when adding C<< key => 'value' >> combinations to
lookup.

C<modify_records> specify mapping from subfields to delimiters or from
delimiters to subfields, as well as oprations on fields (if subfield is
defined as C<*>.

Returns size of database, regardless of C<offset> and C<limit>
parametars, see also C<size>.

=cut

sub open {
        my $self = shift;
        my $arg = {@_};

        my $log = $self->_get_logger();

        $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
        $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
                if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');

        $log->logcroak("need path") if (! $arg->{'path'});
        my $code_page = $arg->{'code_page'} || 'cp852';

        # store data in object
        $self->{'input_code_page'} = $code_page;
        foreach my $v (qw/path offset limit/) {
                $self->{$v} = $arg->{$v} if ($arg->{$v});
        }

        my $filter_ref;
        my $recode_regex;
        my $recode_map;

        if ($self->{recode}) {
                my @r = split(/\s/, $self->{recode});
                if ($#r % 2 != 1) {
                        $log->logwarn("recode needs even number of elements (some number of valid pairs)");
                } else {
                        while (@r) {
                                my $from = shift @r;
                                my $to = shift @r;
                                $recode_map->{$from} = $to;
                        }

                        $recode_regex = join '|' => keys %{ $recode_map };

                        $log->debug("using recode regex: $recode_regex");
                }

        }

        my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });
        $log->debug("rec_regex: ", Dumper($rec_regex));

        my ($db, $size) = $self->{open_db}->( $self, 
                path => $arg->{path},
#               filter => sub {
#                       my ($l,$f_nr) = @_;
#                       return unless defined($l);
#                       from_to($l, $code_page, $self->{'encoding'});
#                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
#                       return $l;
#               },
                %{ $arg },
        );

        unless (defined($db)) {
                $log->logwarn("can't open database $arg->{path}, skipping...");
                return;
        }

        unless ($size) {
                $log->logwarn("no records in database $arg->{path}, skipping...");
                return;
        }

        my $from_rec = 1;
        my $to_rec = $size;

        if (my $s = $self->{offset}) {
                $log->debug("skipping to MFN $s");
                $from_rec = $s;
        } else {
                $self->{offset} = $from_rec;
        }

        if ($self->{limit}) {
                $log->debug("limiting to ",$self->{limit}," records");
                $to_rec = $from_rec + $self->{limit} - 1;
                $to_rec = $size if ($to_rec > $size);
        }

        # store size for later
        $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;

        $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');

        # read database
        for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {

                $log->debug("position: $pos\n");

                my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {
                                my ($l,$f_nr) = @_;
#                               return unless defined($l);
#                               return $l unless ($rec_regex && $f_nr);

                                $log->debug("-=> $f_nr ## $l");

                                # codepage conversion and recode_regex
                                from_to($l, $code_page, $self->{'encoding'});
                                $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);

                                # apply regexps
                                if ($rec_regex && defined($rec_regex->{$f_nr})) {
                                        $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
                                        my $c = 0;
                                        foreach my $r (@{ $rec_regex->{$f_nr} }) {
                                                my $old_l = $l;
                                                eval '$l =~ ' . $r;
                                                if ($old_l ne $l) {
                                                        $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
                                                }
                                                $log->error("error applying regex: $r") if ($@);
                                        }
                                }

                                $log->debug("<=- $f_nr ## $l");
                                return $l;
                });

                $log->debug(sub { Dumper($rec) });

                if (! $rec) {
                        $log->warn("record $pos empty? skipping...");
                        next;
                }

                # store
                if ($self->{low_mem}) {
                        $self->{db}->put($pos, $rec);
                } else {
                        $self->{data}->{$pos} = $rec;
                }

                # create lookup
                $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});

                # update counters for statistics
                if ($self->{stats}) {

                        # fetch clean record with regexpes applied for statistics
                        my $rec = $self->{fetch_rec}->($self, $db, $pos);

                        foreach my $fld (keys %{ $rec }) {
                                $self->{_stats}->{fld}->{ $fld }++;

                                $log->logdie("invalid record fild $fld, not ARRAY")
                                        unless (ref($rec->{ $fld }) eq 'ARRAY');
        
                                foreach my $row (@{ $rec->{$fld} }) {

                                        if (ref($row) eq 'HASH') {

                                                foreach my $sf (keys %{ $row }) {
                                                        next if ($sf eq 'subfields');
                                                        $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
                                                        $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
                                                                        if (ref($row->{$sf}) eq 'ARRAY');
                                                }

                                        } else {
                                                $self->{_stats}->{repeatable}->{ $fld }++;
                                        }
                                }
                        }
                }

                $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});

        }

        $self->{pos} = -1;
        $self->{last_pcnt} = 0;

        # store max mfn and return it.
        $self->{max_pos} = $to_rec;
        $log->debug("max_pos: $to_rec");

        return $size;
}

=head2 fetch

Fetch next record from database. It will also displays progress bar.

 my $rec = $isis->fetch;

Record from this function should probably go to C<data_structure> for
normalisation.

=cut

sub fetch {
        my $self = shift;

        my $log = $self->_get_logger();

        $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});

        if ($self->{pos} == -1) {
                $self->{pos} = $self->{offset};
        } else {
                $self->{pos}++;
        }

        my $mfn = $self->{pos};

        if ($mfn > $self->{max_pos}) {
                $self->{pos} = $self->{max_pos};
                $log->debug("at EOF");
                return;
        }

        $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});

        my $rec;

        if ($self->{low_mem}) {
                $rec = $self->{db}->get($mfn);
        } else {
                $rec = $self->{data}->{$mfn};
        }

        $rec ||= 0E0;
}

=head2 pos

Returns current record number (MFN).

 print $isis->pos;

First record in database has position 1.

=cut

sub pos {
        my $self = shift;
        return $self->{pos};
}


=head2 size

Returns number of records in database

 print $isis->size;

Result from this function can be used to loop through all records

 foreach my $mfn ( 1 ... $isis->size ) { ... }

because it takes into account C<offset> and C<limit>.

=cut

sub size {
        my $self = shift;
        return $self->{size};
}

=head2 seek

Seek to specified MFN in file.

 $isis->seek(42);

First record in database has position 1.

=cut

sub seek {
        my $self = shift;
        my $pos = shift || return;

        my $log = $self->_get_logger();

        if ($pos < 1) {
                $log->warn("seek before first record");
                $pos = 1;
        } elsif ($pos > $self->{max_pos}) {
                $log->warn("seek beyond last record");
                $pos = $self->{max_pos};
        }

        return $self->{pos} = (($pos - 1) || -1);
}

=head2 stats

Dump statistics about field and subfield usage

  print $input->stats;

=cut

sub stats {
        my $self = shift;

        my $log = $self->_get_logger();

        my $s = $self->{_stats};
        if (! $s) {
                $log->warn("called stats, but there is no statistics collected");
                return;
        }

        my $max_fld = 0;

        my $out = join("\n",
                map {
                        my $f = $_ || die "no field";
                        my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
                        $max_fld = $v if ($v > $max_fld);

                        my $o = sprintf("%4s %d ~", $f, $v);

                        if (defined($s->{sf}->{$f})) {
                                map {
                                        $o .= sprintf(" %s:%d%s", $_, 
                                                $s->{sf}->{$f}->{$_}->{count},
                                                $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
                                        );
                                } sort keys %{ $s->{sf}->{$f} };
                        }

                        if (my $v_r = $s->{repeatable}->{$f}) {
                                $o .= " ($v_r)" if ($v_r != $v);
                        }

                        $o;
                } sort { $a cmp $b } keys %{ $s->{fld} }
        );

        $log->debug( sub { Dumper($s) } );

        return $out;
}

=head2 modify_record_regexps

Generate hash with regexpes to be applied using L<filter>.

  my $regexpes = $input->modify_record_regexps(
                900 => { '^a' => { ' : ' => '^b' } },
                901 => { '*' => { '^b' => ' ; ' } },
  );

=cut

sub modify_record_regexps {
        my $self = shift;
        my $modify_record = {@_};

        my $regexpes;

        foreach my $f (keys %$modify_record) {
warn "--- f: $f\n";
                foreach my $sf (keys %{ $modify_record->{$f} }) {
warn "---- sf: $sf\n";
                        foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
                                my $to = $modify_record->{$f}->{$sf}->{$from};
                                #die "no field?" unless defined($to);
warn "----- transform: |$from| -> |$to|\n";

                                if ($sf =~ /^\^/) {
                                        my $regex = 
                                                's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
                                        push @{ $regexpes->{$f} }, $regex;
warn ">>>>> $regex [sf]\n";
                                } else {
                                        my $regex =
                                                's/\Q'. $from .'\E/'. $to .'/g';
                                        push @{ $regexpes->{$f} }, $regex;
warn ">>>>> $regex [global]\n";
                                }

                        }
                }
        }

        return $regexpes;
}

=head1 MEMORY USAGE

C<low_mem> options is double-edged sword. If enabled, WebPAC
will run on memory constraint machines (which doesn't have enough
physical RAM to create memory structure for whole source database).

If your machine has 512Mb or more of RAM and database is around 10000 records,
memory shouldn't be an issue. If you don't have enough physical RAM, you
might consider using virtual memory (if your operating system is handling it
well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle
parsed structure of ISIS database (this is what C<low_mem> option does).

Hitting swap at end of reading source database is probably o.k. However,
hitting swap before 90% will dramatically decrease performance and you will
be better off with C<low_mem> and using rest of availble memory for
operating system disk cache (Linux is particuallary good about this).
However, every access to database record will require disk access, so
generation phase will be slower 10-100 times.

Parsed structures are essential - you just have option to trade RAM memory
(which is fast) for disk space (which is slow). Be sure to have planty of
disk space if you are using C<low_mem> and thus L<DBM::Deep>.

However, when WebPAC is running on desktop machines (or laptops :-), it's
highly undesireable for system to start swapping. Using C<low_mem> option can
reduce WecPAC memory usage to around 64Mb for same database with lookup
fields and sorted indexes which stay in RAM. Performance will suffer, but
memory usage will really be minimal. It might be also more confortable to
run WebPAC reniced on those machines.


=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of WebPAC::Input
1	dpavlin	1	package WebPAC::Input;
2
3			use warnings;
4			use strict;
5
6	dpavlin	507	use blib;
7
8	dpavlin	487	use WebPAC::Common;
9	dpavlin	285	use base qw/WebPAC::Common/;
10	dpavlin	308	use Data::Dumper;
11	dpavlin	624	use Encode qw/from_to/;
12	dpavlin	285
13	dpavlin	1	=head1 NAME
14
15	dpavlin	286	WebPAC::Input - read different file formats into WebPAC
16	dpavlin	1
17			=head1 VERSION
18
19	dpavlin	619	Version 0.11
20	dpavlin	1
21			=cut
22
23	dpavlin	619	our $VERSION = '0.11';
24	dpavlin	1
25			=head1 SYNOPSIS
26
27	dpavlin	286	This module implements input as database which have fixed and known
28			I<size> while indexing and single unique numeric identifier for database
29			position ranging from 1 to I<size>.
30	dpavlin	1
31	dpavlin	286	Simply, something that is indexed by unmber from 1 .. I<size>.
32
33			Examples of such databases are CDS/ISIS files, MARC files, lines in
34			text file, and so on.
35
36			Specific file formats are implemented using low-level interface modules,
37			located in C<WebPAC::Input::*> namespace which export C<open_db>,
38			C<fetch_rec> and optional C<init> functions.
39
40	dpavlin	1	Perhaps a little code snippet.
41
42	dpavlin	597	use WebPAC::Input;
43	dpavlin	1
44	dpavlin	597	my $db = WebPAC::Input->new(
45			module => 'WebPAC::Input::ISIS',
46	dpavlin	286	low_mem => 1,
47	dpavlin	597	);
48	dpavlin	1
49	dpavlin	597	$db->open( path => '/path/to/database' );
50	dpavlin	416	print "database size: ",$db->size,"\n";
51			while (my $rec = $db->fetch) {
52			# do something with $rec
53			}
54	dpavlin	1
55	dpavlin	286
56
57	dpavlin	1	=head1 FUNCTIONS
58
59	dpavlin	3	=head2 new
60	dpavlin	1
61	dpavlin	3	Create new input database object.
62
63	dpavlin	9	my $db = new WebPAC::Input(
64	dpavlin	286	module => 'WebPAC::Input::MARC',
65	dpavlin	585	encoding => 'ISO-8859-2',
66	dpavlin	10	low_mem => 1,
67	dpavlin	416	recode => 'char pairs',
68	dpavlin	483	no_progress_bar => 1,
69	dpavlin	9	);
70	dpavlin	3
71	dpavlin	597	C<module> is low-level file format module. See L<WebPAC::Input::ISIS> and
72	dpavlin	286	L<WebPAC::Input::MARC>.
73
74	dpavlin	585	Optional parametar C<encoding> specify application code page (which will be
75	dpavlin	9	used internally). This should probably be your terminal encoding, and by
76			default, it C<ISO-8859-2>.
77
78	dpavlin	10	Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).
79
80	dpavlin	483	C<recode> is optional string constisting of character or words pairs that
81			should be replaced in input stream.
82
83			C<no_progress_bar> disables progress bar output on C<STDOUT>
84
85	dpavlin	285	This function will also call low-level C<init> if it exists with same
86			parametars.
87
88	dpavlin	1	=cut
89
90	dpavlin	3	sub new {
91	dpavlin	285	my $class = shift;
92			my $self = {@_};
93	dpavlin	3	bless($self, $class);
94
95	dpavlin	285	my $log = $self->_get_logger;
96
97	dpavlin	585	$log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
98			$log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
99
100	dpavlin	286	$log->logconfess("specify low-level file format module") unless ($self->{module});
101			my $module = $self->{module};
102			$module =~ s#::#/#g;
103			$module .= '.pm';
104			$log->debug("require low-level module $self->{module} from $module");
105	dpavlin	289
106	dpavlin	286	require $module;
107	dpavlin	289	#eval $self->{module} .'->import';
108	dpavlin	286
109	dpavlin	285	# check if required subclasses are implemented
110	dpavlin	289	foreach my $subclass (qw/open_db fetch_rec init/) {
111			my $n = $self->{module} . '::' . $subclass;
112			if (! defined &{ $n }) {
113	dpavlin	290	my $missing = "missing $subclass in $self->{module}";
114	dpavlin	301	$self->{$subclass} = sub { $log->logwarn($missing) };
115	dpavlin	286	} else {
116	dpavlin	289	$self->{$subclass} = \&{ $n };
117	dpavlin	286	}
118	dpavlin	285	}
119
120	dpavlin	289	if ($self->{init}) {
121	dpavlin	285	$log->debug("calling init");
122	dpavlin	289	$self->{init}->($self, @_);
123	dpavlin	285	}
124
125	dpavlin	585	$self->{'encoding'} \|\|= 'ISO-8859-2';
126	dpavlin	9
127	dpavlin	10	# running with low_mem flag? well, use DBM::Deep then.
128			if ($self->{'low_mem'}) {
129			$log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
130
131			my $db_file = "data.db";
132
133			if (-e $db_file) {
134			unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
135			$log->debug("removed '$db_file' from last run");
136			}
137
138			require DBM::Deep;
139
140			my $db = new DBM::Deep $db_file;
141
142			$log->logdie("DBM::Deep error: $!") unless ($db);
143
144			if ($db->error()) {
145			$log->logdie("can't open '$db_file' under low_mem: ",$db->error());
146			} else {
147			$log->debug("using file '$db_file' for DBM::Deep");
148			}
149
150			$self->{'db'} = $db;
151			}
152
153	dpavlin	3	$self ? return $self : return undef;
154	dpavlin	1	}
155
156	dpavlin	285	=head2 open
157
158			This function will read whole database in memory and produce lookups.
159
160	dpavlin	286	$input->open(
161	dpavlin	285	path => '/path/to/database/file',
162	dpavlin	624	code_page => 'cp852',
163	dpavlin	286	limit => 500,
164			offset => 6000,
165	dpavlin	285	lookup => $lookup_obj,
166	dpavlin	506	stats => 1,
167	dpavlin	585	lookup_ref => sub {
168			my ($k,$v) = @_;
169			# store lookup $k => $v
170			},
171	dpavlin	597	modify_records => {
172			900 => { '^a' => { ' : ' => '^b' } },
173			901 => { '*' => { '^b' => ' ; ' } },
174			},
175	dpavlin	285	);
176
177	dpavlin	624	By default, C<code_page> is assumed to be C<cp852>.
178	dpavlin	285
179	dpavlin	286	C<offset> is optional parametar to position at some offset before reading from database.
180	dpavlin	285
181	dpavlin	286	C<limit> is optional parametar to read just C<limit> records from database
182	dpavlin	285
183	dpavlin	506	C<stats> create optional report about usage of fields and subfields
184
185	dpavlin	597	C<lookup_coderef> is closure to call when adding C<< key => 'value' >> combinations to
186	dpavlin	585	lookup.
187
188	dpavlin	597	C<modify_records> specify mapping from subfields to delimiters or from
189			delimiters to subfields, as well as oprations on fields (if subfield is
190			defined as C<*>.
191
192	dpavlin	286	Returns size of database, regardless of C<offset> and C<limit>
193			parametars, see also C<size>.
194	dpavlin	285
195			=cut
196
197			sub open {
198			my $self = shift;
199			my $arg = {@_};
200
201			my $log = $self->_get_logger();
202
203	dpavlin	585	$log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
204			$log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
205			if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
206
207	dpavlin	285	$log->logcroak("need path") if (! $arg->{'path'});
208	dpavlin	624	my $code_page = $arg->{'code_page'} \|\| 'cp852';
209	dpavlin	285
210			# store data in object
211	dpavlin	292	$self->{'input_code_page'} = $code_page;
212	dpavlin	286	foreach my $v (qw/path offset limit/) {
213	dpavlin	285	$self->{$v} = $arg->{$v} if ($arg->{$v});
214			}
215
216	dpavlin	416	my $filter_ref;
217	dpavlin	597	my $recode_regex;
218			my $recode_map;
219	dpavlin	416
220			if ($self->{recode}) {
221			my @r = split(/\s/, $self->{recode});
222			if ($#r % 2 != 1) {
223			$log->logwarn("recode needs even number of elements (some number of valid pairs)");
224			} else {
225			while (@r) {
226			my $from = shift @r;
227			my $to = shift @r;
228	dpavlin	597	$recode_map->{$from} = $to;
229	dpavlin	416	}
230
231	dpavlin	597	$recode_regex = join '\|' => keys %{ $recode_map };
232	dpavlin	416
233	dpavlin	597	$log->debug("using recode regex: $recode_regex");
234	dpavlin	416	}
235
236			}
237
238	dpavlin	597	my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });
239			$log->debug("rec_regex: ", Dumper($rec_regex));
240
241	dpavlin	289	my ($db, $size) = $self->{open_db}->( $self,
242	dpavlin	285	path => $arg->{path},
243	dpavlin	624	# filter => sub {
244			# my ($l,$f_nr) = @_;
245			# return unless defined($l);
246			# from_to($l, $code_page, $self->{'encoding'});
247			# $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
248			# return $l;
249			# },
250	dpavlin	523	%{ $arg },
251	dpavlin	285	);
252
253	dpavlin	496	unless (defined($db)) {
254	dpavlin	285	$log->logwarn("can't open database $arg->{path}, skipping...");
255			return;
256			}
257
258			unless ($size) {
259			$log->logwarn("no records in database $arg->{path}, skipping...");
260			return;
261			}
262
263	dpavlin	339	my $from_rec = 1;
264			my $to_rec = $size;
265	dpavlin	285
266	dpavlin	286	if (my $s = $self->{offset}) {
267	dpavlin	513	$log->debug("skipping to MFN $s");
268	dpavlin	339	$from_rec = $s;
269	dpavlin	285	} else {
270	dpavlin	339	$self->{offset} = $from_rec;
271	dpavlin	285	}
272
273	dpavlin	286	if ($self->{limit}) {
274	dpavlin	301	$log->debug("limiting to ",$self->{limit}," records");
275	dpavlin	339	$to_rec = $from_rec + $self->{limit} - 1;
276			$to_rec = $size if ($to_rec > $size);
277	dpavlin	285	}
278
279			# store size for later
280	dpavlin	339	$self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
281	dpavlin	285
282	dpavlin	585	$log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
283	dpavlin	285
284			# read database
285	dpavlin	339	for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
286	dpavlin	285
287	dpavlin	286	$log->debug("position: $pos\n");
288	dpavlin	285
289	dpavlin	619	my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {
290			my ($l,$f_nr) = @_;
291	dpavlin	624	# return unless defined($l);
292			# return $l unless ($rec_regex && $f_nr);
293	dpavlin	285
294	dpavlin	625	$log->debug("-=> $f_nr ## $l");
295
296	dpavlin	624	# codepage conversion and recode_regex
297	dpavlin	626	from_to($l, $code_page, $self->{'encoding'});
298	dpavlin	624	$l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
299
300	dpavlin	619	# apply regexps
301			if ($rec_regex && defined($rec_regex->{$f_nr})) {
302			$log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
303			my $c = 0;
304			foreach my $r (@{ $rec_regex->{$f_nr} }) {
305	dpavlin	626	my $old_l = $l;
306	dpavlin	619	eval '$l =~ ' . $r;
307	dpavlin	626	if ($old_l ne $l) {
308			$log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
309			}
310	dpavlin	619	$log->error("error applying regex: $r") if ($@);
311			}
312			}
313
314	dpavlin	625	$log->debug("<=- $f_nr ## $l");
315	dpavlin	619	return $l;
316			});
317
318	dpavlin	308	$log->debug(sub { Dumper($rec) });
319
320	dpavlin	285	if (! $rec) {
321	dpavlin	286	$log->warn("record $pos empty? skipping...");
322	dpavlin	285	next;
323			}
324
325			# store
326	dpavlin	286	if ($self->{low_mem}) {
327			$self->{db}->put($pos, $rec);
328	dpavlin	285	} else {
329	dpavlin	286	$self->{data}->{$pos} = $rec;
330	dpavlin	285	}
331
332			# create lookup
333	dpavlin	585	$arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
334	dpavlin	285
335	dpavlin	506	# update counters for statistics
336			if ($self->{stats}) {
337	dpavlin	593
338	dpavlin	619	# fetch clean record with regexpes applied for statistics
339			my $rec = $self->{fetch_rec}->($self, $db, $pos);
340
341	dpavlin	593	foreach my $fld (keys %{ $rec }) {
342	dpavlin	506	$self->{_stats}->{fld}->{ $fld }++;
343	dpavlin	593
344			$log->logdie("invalid record fild $fld, not ARRAY")
345			unless (ref($rec->{ $fld }) eq 'ARRAY');
346
347			foreach my $row (@{ $rec->{$fld} }) {
348
349			if (ref($row) eq 'HASH') {
350
351			foreach my $sf (keys %{ $row }) {
352	dpavlin	619	next if ($sf eq 'subfields');
353	dpavlin	593	$self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
354			$self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
355			if (ref($row->{$sf}) eq 'ARRAY');
356	dpavlin	506	}
357	dpavlin	593
358			} else {
359			$self->{_stats}->{repeatable}->{ $fld }++;
360			}
361	dpavlin	506	}
362	dpavlin	593	}
363	dpavlin	506	}
364
365	dpavlin	483	$self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
366	dpavlin	285
367			}
368
369	dpavlin	286	$self->{pos} = -1;
370			$self->{last_pcnt} = 0;
371	dpavlin	285
372			# store max mfn and return it.
373	dpavlin	339	$self->{max_pos} = $to_rec;
374			$log->debug("max_pos: $to_rec");
375	dpavlin	285
376			return $size;
377			}
378
379			=head2 fetch
380
381			Fetch next record from database. It will also displays progress bar.
382
383			my $rec = $isis->fetch;
384
385			Record from this function should probably go to C<data_structure> for
386			normalisation.
387
388			=cut
389
390			sub fetch {
391			my $self = shift;
392
393			my $log = $self->_get_logger();
394
395	dpavlin	286	$log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
396	dpavlin	285
397	dpavlin	286	if ($self->{pos} == -1) {
398			$self->{pos} = $self->{offset};
399	dpavlin	285	} else {
400	dpavlin	286	$self->{pos}++;
401	dpavlin	285	}
402
403	dpavlin	286	my $mfn = $self->{pos};
404	dpavlin	285
405	dpavlin	286	if ($mfn > $self->{max_pos}) {
406			$self->{pos} = $self->{max_pos};
407	dpavlin	285	$log->debug("at EOF");
408			return;
409			}
410
411	dpavlin	483	$self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
412	dpavlin	285
413			my $rec;
414
415	dpavlin	286	if ($self->{low_mem}) {
416			$rec = $self->{db}->get($mfn);
417	dpavlin	285	} else {
418	dpavlin	286	$rec = $self->{data}->{$mfn};
419	dpavlin	285	}
420
421			$rec \|\|= 0E0;
422			}
423
424			=head2 pos
425
426			Returns current record number (MFN).
427
428			print $isis->pos;
429
430			First record in database has position 1.
431
432			=cut
433
434			sub pos {
435			my $self = shift;
436	dpavlin	286	return $self->{pos};
437	dpavlin	285	}
438
439
440			=head2 size
441
442			Returns number of records in database
443
444			print $isis->size;
445
446			Result from this function can be used to loop through all records
447
448			foreach my $mfn ( 1 ... $isis->size ) { ... }
449
450	dpavlin	286	because it takes into account C<offset> and C<limit>.
451	dpavlin	285
452			=cut
453
454			sub size {
455			my $self = shift;
456	dpavlin	286	return $self->{size};
457	dpavlin	285	}
458
459			=head2 seek
460
461			Seek to specified MFN in file.
462
463			$isis->seek(42);
464
465			First record in database has position 1.
466
467			=cut
468
469			sub seek {
470			my $self = shift;
471			my $pos = shift \|\| return;
472
473			my $log = $self->_get_logger();
474
475			if ($pos < 1) {
476			$log->warn("seek before first record");
477			$pos = 1;
478	dpavlin	286	} elsif ($pos > $self->{max_pos}) {
479	dpavlin	285	$log->warn("seek beyond last record");
480	dpavlin	286	$pos = $self->{max_pos};
481	dpavlin	285	}
482
483	dpavlin	286	return $self->{pos} = (($pos - 1) \|\| -1);
484	dpavlin	285	}
485
486	dpavlin	506	=head2 stats
487	dpavlin	285
488	dpavlin	506	Dump statistics about field and subfield usage
489
490	dpavlin	507	print $input->stats;
491	dpavlin	506
492			=cut
493
494			sub stats {
495			my $self = shift;
496	dpavlin	507
497			my $log = $self->_get_logger();
498
499			my $s = $self->{_stats};
500			if (! $s) {
501			$log->warn("called stats, but there is no statistics collected");
502			return;
503			}
504
505			my $max_fld = 0;
506
507			my $out = join("\n",
508			map {
509			my $f = $_ \|\| die "no field";
510			my $v = $s->{fld}->{$f} \|\| die "no s->{fld}->{$f}";
511			$max_fld = $v if ($v > $max_fld);
512
513	dpavlin	519	my $o = sprintf("%4s %d ~", $f, $v);
514	dpavlin	507
515			if (defined($s->{sf}->{$f})) {
516			map {
517	dpavlin	593	$o .= sprintf(" %s:%d%s", $_,
518			$s->{sf}->{$f}->{$_}->{count},
519			$s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
520			);
521	dpavlin	507	} sort keys %{ $s->{sf}->{$f} };
522			}
523
524			if (my $v_r = $s->{repeatable}->{$f}) {
525			$o .= " ($v_r)" if ($v_r != $v);
526			}
527
528			$o;
529	dpavlin	519	} sort { $a cmp $b } keys %{ $s->{fld} }
530	dpavlin	507	);
531
532			$log->debug( sub { Dumper($s) } );
533
534			return $out;
535	dpavlin	506	}
536
537	dpavlin	598	=head2 modify_record_regexps
538	dpavlin	597
539			Generate hash with regexpes to be applied using L<filter>.
540
541			my $regexpes = $input->modify_record_regexps(
542			900 => { '^a' => { ' : ' => '^b' } },
543			901 => { '*' => { '^b' => ' ; ' } },
544			);
545
546			=cut
547
548			sub modify_record_regexps {
549			my $self = shift;
550			my $modify_record = {@_};
551
552			my $regexpes;
553
554			foreach my $f (keys %$modify_record) {
555			warn "--- f: $f\n";
556			foreach my $sf (keys %{ $modify_record->{$f} }) {
557			warn "---- sf: $sf\n";
558			foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
559			my $to = $modify_record->{$f}->{$sf}->{$from};
560			#die "no field?" unless defined($to);
561			warn "----- transform: \|$from\| -> \|$to\|\n";
562
563			if ($sf =~ /^\^/) {
564			my $regex =
565			's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
566			push @{ $regexpes->{$f} }, $regex;
567			warn ">>>>> $regex [sf]\n";
568			} else {
569			my $regex =
570			's/\Q'. $from .'\E/'. $to .'/g';
571			push @{ $regexpes->{$f} }, $regex;
572			warn ">>>>> $regex [global]\n";
573			}
574
575			}
576			}
577			}
578
579			return $regexpes;
580			}
581
582	dpavlin	3	=head1 MEMORY USAGE
583	dpavlin	1
584	dpavlin	3	C<low_mem> options is double-edged sword. If enabled, WebPAC
585			will run on memory constraint machines (which doesn't have enough
586			physical RAM to create memory structure for whole source database).
587	dpavlin	1
588	dpavlin	3	If your machine has 512Mb or more of RAM and database is around 10000 records,
589			memory shouldn't be an issue. If you don't have enough physical RAM, you
590			might consider using virtual memory (if your operating system is handling it
591			well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle
592			parsed structure of ISIS database (this is what C<low_mem> option does).
593	dpavlin	1
594	dpavlin	3	Hitting swap at end of reading source database is probably o.k. However,
595			hitting swap before 90% will dramatically decrease performance and you will
596			be better off with C<low_mem> and using rest of availble memory for
597			operating system disk cache (Linux is particuallary good about this).
598			However, every access to database record will require disk access, so
599			generation phase will be slower 10-100 times.
600
601			Parsed structures are essential - you just have option to trade RAM memory
602			(which is fast) for disk space (which is slow). Be sure to have planty of
603			disk space if you are using C<low_mem> and thus L<DBM::Deep>.
604
605			However, when WebPAC is running on desktop machines (or laptops :-), it's
606			highly undesireable for system to start swapping. Using C<low_mem> option can
607			reduce WecPAC memory usage to around 64Mb for same database with lookup
608			fields and sorted indexes which stay in RAM. Performance will suffer, but
609			memory usage will really be minimal. It might be also more confortable to
610			run WebPAC reniced on those machines.
611
612
613			=head1 AUTHOR
614
615			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
616
617	dpavlin	1	=head1 COPYRIGHT & LICENSE
618
619	dpavlin	599	Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
620	dpavlin	1
621			This program is free software; you can redistribute it and/or modify it
622			under the same terms as Perl itself.
623
624			=cut
625
626			1; # End of WebPAC::Input