WebPAC/Input/DBF.pm

package WebPAC::Input::DBF;

use warnings;
use strict;

use WebPAC::Input;
use base qw/WebPAC::Common/;
use XBase;
use Data::Dump qw/dump/;
use Encode qw/encode_utf8/;
use YAML;
use File::Slurp;

=head1 NAME

WebPAC::Input::DBF - support for reading DBF tables

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

=head1 SYNOPSIS

Read data from DBF tables (do you remember Clipper applications?) and create
pseudo-MARC records from them.

 my $ll_db = new WebPAC::Input::DBF(
        path => '/path/to/database.dbf',
 );

=head1 FUNCTIONS

=head2 new

Returns new low-level input API object

  my $ll_db = new WebPAC::Input::DBF(
        path => '/path/to/database.dbf'
        filter => sub {
                my ($l,$field_nr) = @_;
                # do something with $l which is line of input file
                return $l;
        },
  }

Options:

=over 4

=item path

path to DBF file

=back

=cut

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

        my $arg = {@_};

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

        my $db = XBase->new( $arg->{path} ) || $log->logdie("can't open ", $arg->{path}, ": $!");

        my $size = $db->last_record;

        $log->info("opening DBF database '$arg->{path}' with $size records");

        my $mapping = $arg->{input_config}->{mapping};

        if ( ! $mapping ) {
                $log->debug("didn't found any mapping file in configuration", sub { dump( $arg->{input_config} ) });

                foreach my $field ( $db->field_names ) {
                        push @$mapping, { $field => { '900' => 'x' } };
                }

                my $mapping_path = $arg->{path};
                $mapping_path =~ s!^.+/([^/]+)\.dbf!$1.yml!;

                $log->logdie("mapping file $mapping_path allready exists, aborting.") if ( -e $mapping_path );

                write_file( $mapping_path, Dump( { mapping => $mapping } ) ) ||
                        $log->logdie("can't write template file for mapping_path $mapping_path: $!");

                $log->logdie("template file for mapping_path created as $mapping_path");

        } else {
                $log->debug("using mapping ", sub { dump($mapping) });
        }

        foreach my $mfn ( 1 .. $size ) {

                my $row = $db->get_record_as_hash( $mfn );

                $log->debug("dbf row = ", sub { dump( $row ) });

                my $record = {
                        '001' => [ $mfn ],
                };

                $self->{_rows}->{ $mfn } = $record;
                $log->debug("created row $mfn ", dump( $record ));
        }

        $self->{size} = $size;

        $self ? return $self : return undef;
}

=head2 fetch_rec

Return record with ID C<$mfn> from database

  my $rec = $ll_db->fetch_rec( $mfn, $filter_coderef );

=cut

sub fetch_rec {
        my $self = shift;

        my ($mfn, $filter_coderef) = @_;

        my $rec = $self->_to_hash(
                mfn => $mfn,
                row => $self->{_rows}->{$mfn},
                hash_filter => $filter_coderef,
        );

        my $log = $self->_get_logger();
        $log->debug("fetch_rec($mfn) = ", dump($rec));

        return $rec;
}

=head2 size

Return number of records in database

  my $size = $ll_db->size;

=cut

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

=head2 _to_hash

Return hash from row. Taken from L<Biblio::Isis>

  my $rec = $ll_db->_to_hash(
        mfn => $mfn;
        $row
  );

=cut

sub _to_hash {
        my $self = shift;

        my $arg = {@_};

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

        my $hash_filter = $arg->{hash_filter};
        my $mfn = $arg->{mfn} || $log->logconfess("need mfn in arguments");
        my $row = $arg->{row} || $log->logconfess("need row in arguments");

        # init record to include MFN as field 000
        my $rec = { '000' => [ $mfn ] };

        foreach my $f_nr (keys %{$row}) {
                foreach my $l (@{$row->{$f_nr}}) {

                        # filter output
                        $l = $hash_filter->($l, $f_nr) if ($hash_filter);
                        next unless defined($l);

                        my $val;
                        my $r_sf;       # repeatable subfields in this record

                        # has subfields?
                        if ($l =~ m/\^/) {
                                foreach my $t (split(/\^/,$l)) {
                                        next if (! $t);
                                        my ($sf,$v) = (substr($t,0,1), substr($t,1));
                                        next unless (defined($v) && $v ne '');

                                        if (ref( $val->{$sf} ) eq 'ARRAY') {

                                                push @{ $val->{$sf} }, $v;

                                                # record repeatable subfield it it's offset
                                                push @{ $val->{subfields} }, ( $sf, $#{ $val->{$sf} } );
                                                $r_sf->{$sf}++;

                                        } elsif (defined( $val->{$sf} )) {

                                                # convert scalar field to array
                                                $val->{$sf} = [ $val->{$sf}, $v ];

                                                push @{ $val->{subfields} }, ( $sf, 1 );
                                                $r_sf->{$sf}++;

                                        } else {
                                                $val->{$sf} = $v;
                                                push @{ $val->{subfields} }, ( $sf, 0 );
                                        }
                                }
                        } else {
                                $val = $l;
                        }

                        push @{$rec->{$f_nr}}, $val;
                }
        }

        return $rec;
}

=head1 AUTHOR

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

=head1 COPYRIGHT & LICENSE

Copyright 2007 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::DBF
1	dpavlin	869	package WebPAC::Input::DBF;
2
3			use warnings;
4			use strict;
5
6			use WebPAC::Input;
7			use base qw/WebPAC::Common/;
8			use XBase;
9			use Data::Dump qw/dump/;
10			use Encode qw/encode_utf8/;
11			use YAML;
12			use File::Slurp;
13
14			=head1 NAME
15
16			WebPAC::Input::DBF - support for reading DBF tables
17
18			=head1 VERSION
19
20			Version 0.01
21
22			=cut
23
24			our $VERSION = '0.01';
25
26			=head1 SYNOPSIS
27
28			Read data from DBF tables (do you remember Clipper applications?) and create
29			pseudo-MARC records from them.
30
31			my $ll_db = new WebPAC::Input::DBF(
32			path => '/path/to/database.dbf',
33			);
34
35			=head1 FUNCTIONS
36
37			=head2 new
38
39			Returns new low-level input API object
40
41			my $ll_db = new WebPAC::Input::DBF(
42			path => '/path/to/database.dbf'
43			filter => sub {
44			my ($l,$field_nr) = @_;
45			# do something with $l which is line of input file
46			return $l;
47			},
48			}
49
50			Options:
51
52			=over 4
53
54			=item path
55
56			path to DBF file
57
58			=back
59
60			=cut
61
62			sub new {
63			my $class = shift;
64			my $self = {@_};
65			bless($self, $class);
66
67			my $arg = {@_};
68
69			my $log = $self->_get_logger();
70
71			my $db = XBase->new( $arg->{path} ) \|\| $log->logdie("can't open ", $arg->{path}, ": $!");
72
73			my $size = $db->last_record;
74
75			$log->info("opening DBF database '$arg->{path}' with $size records");
76
77			my $mapping = $arg->{input_config}->{mapping};
78
79			if ( ! $mapping ) {
80			$log->debug("didn't found any mapping file in configuration", sub { dump( $arg->{input_config} ) });
81
82			foreach my $field ( $db->field_names ) {
83			push @$mapping, { $field => { '900' => 'x' } };
84			}
85
86			my $mapping_path = $arg->{path};
87			$mapping_path =~ s!^.+/([^/]+)\.dbf!$1.yml!;
88
89			$log->logdie("mapping file $mapping_path allready exists, aborting.") if ( -e $mapping_path );
90
91			write_file( $mapping_path, Dump( { mapping => $mapping } ) ) \|\|
92			$log->logdie("can't write template file for mapping_path $mapping_path: $!");
93
94			$log->logdie("template file for mapping_path created as $mapping_path");
95
96			} else {
97			$log->debug("using mapping ", sub { dump($mapping) });
98			}
99
100			foreach my $mfn ( 1 .. $size ) {
101
102			my $row = $db->get_record_as_hash( $mfn );
103
104			$log->debug("dbf row = ", sub { dump( $row ) });
105
106			my $record = {
107			'001' => [ $mfn ],
108			};
109
110			$self->{_rows}->{ $mfn } = $record;
111			$log->debug("created row $mfn ", dump( $record ));
112			}
113
114			$self->{size} = $size;
115
116			$self ? return $self : return undef;
117			}
118
119			=head2 fetch_rec
120
121			Return record with ID C<$mfn> from database
122
123			my $rec = $ll_db->fetch_rec( $mfn, $filter_coderef );
124
125			=cut
126
127			sub fetch_rec {
128			my $self = shift;
129
130			my ($mfn, $filter_coderef) = @_;
131
132			my $rec = $self->_to_hash(
133			mfn => $mfn,
134			row => $self->{_rows}->{$mfn},
135			hash_filter => $filter_coderef,
136			);
137
138			my $log = $self->_get_logger();
139			$log->debug("fetch_rec($mfn) = ", dump($rec));
140
141			return $rec;
142			}
143
144			=head2 size
145
146			Return number of records in database
147
148			my $size = $ll_db->size;
149
150			=cut
151
152			sub size {
153			my $self = shift;
154			return $self->{size};
155			}
156
157			=head2 _to_hash
158
159			Return hash from row. Taken from L<Biblio::Isis>
160
161			my $rec = $ll_db->_to_hash(
162			mfn => $mfn;
163			$row
164			);
165
166			=cut
167
168			sub _to_hash {
169			my $self = shift;
170
171			my $arg = {@_};
172
173			my $log = $self->_get_logger();
174
175			my $hash_filter = $arg->{hash_filter};
176			my $mfn = $arg->{mfn} \|\| $log->logconfess("need mfn in arguments");
177			my $row = $arg->{row} \|\| $log->logconfess("need row in arguments");
178
179			# init record to include MFN as field 000
180			my $rec = { '000' => [ $mfn ] };
181
182			foreach my $f_nr (keys %{$row}) {
183			foreach my $l (@{$row->{$f_nr}}) {
184
185			# filter output
186			$l = $hash_filter->($l, $f_nr) if ($hash_filter);
187			next unless defined($l);
188
189			my $val;
190			my $r_sf; # repeatable subfields in this record
191
192			# has subfields?
193			if ($l =~ m/\^/) {
194			foreach my $t (split(/\^/,$l)) {
195			next if (! $t);
196			my ($sf,$v) = (substr($t,0,1), substr($t,1));
197			next unless (defined($v) && $v ne '');
198
199			if (ref( $val->{$sf} ) eq 'ARRAY') {
200
201			push @{ $val->{$sf} }, $v;
202
203			# record repeatable subfield it it's offset
204			push @{ $val->{subfields} }, ( $sf, $#{ $val->{$sf} } );
205			$r_sf->{$sf}++;
206
207			} elsif (defined( $val->{$sf} )) {
208
209			# convert scalar field to array
210			$val->{$sf} = [ $val->{$sf}, $v ];
211
212			push @{ $val->{subfields} }, ( $sf, 1 );
213			$r_sf->{$sf}++;
214
215			} else {
216			$val->{$sf} = $v;
217			push @{ $val->{subfields} }, ( $sf, 0 );
218			}
219			}
220			} else {
221			$val = $l;
222			}
223
224			push @{$rec->{$f_nr}}, $val;
225			}
226			}
227
228			return $rec;
229			}
230
231			=head1 AUTHOR
232
233			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
234
235			=head1 COPYRIGHT & LICENSE
236
237			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
238
239			This program is free software; you can redistribute it and/or modify it
240			under the same terms as Perl itself.
241
242			=cut
243
244			1; # End of WebPAC::Input::DBF