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 qw/LoadFile DumpFile/;

=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'
        mapping_path => '/path/to/input/dbf/mapping.yml',
        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

=item mapping_path

path to mapping YAML which will be created on first run

=back

=cut

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

        my $arg = {@_};

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

        $log->logconfess("this module requires input_config") unless ( $arg->{input_config} );

        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_path = $arg->{input_config}->{mapping_path};
        my $mapping;

        if ( ! $mapping_path ) {
                $log->debug("didn't found any mapping_path 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 );

                DumpFile( $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 {
                $mapping = LoadFile( $mapping_path ) || $log->logdie("can't open $mapping_path: $!");
                $log->logdie("missing top-level mapping key in $mapping_path") unless ( $mapping->{mapping} );
                $mapping = $mapping->{mapping};
                $log->debug("using mapping from $mapping_path = ", 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 ],
                };

                # fixme -- this *will* break given wrong structure!
                foreach my $m ( @$mapping ) {
                        my $db_field = (keys %$m)[0];
                        my ( $f, $sf ) = %{ $m->{$db_field} };
                        push @{ $record->{$f} }, '^' . $sf . $row->{$db_field} if ( defined( $row->{$db_field} ) && $row->{$db_field} ne '' );
                }

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