WebPAC/Input/DBF.pm

package WebPAC::Input::DBF;

use warnings;
use strict;

use WebPAC::Input;
use WebPAC::Input::Helper;
use base qw/WebPAC::Common WebPAC::Input::Helper/;
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};
}

=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	dpavlin	871	use WebPAC::Input::Helper;
8			use base qw/WebPAC::Common WebPAC::Input::Helper/;
9	dpavlin	869	use XBase;
10			use Data::Dump qw/dump/;
11			use Encode qw/encode_utf8/;
12	dpavlin	870	use YAML qw/LoadFile DumpFile/;
13	dpavlin	869
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	dpavlin	870	mapping_path => '/path/to/input/dbf/mapping.yml',
44	dpavlin	869	filter => sub {
45			my ($l,$field_nr) = @_;
46			# do something with $l which is line of input file
47			return $l;
48			},
49			}
50
51			Options:
52
53			=over 4
54
55			=item path
56
57			path to DBF file
58
59	dpavlin	870	=item mapping_path
60
61			path to mapping YAML which will be created on first run
62
63	dpavlin	869	=back
64
65			=cut
66
67			sub new {
68			my $class = shift;
69			my $self = {@_};
70			bless($self, $class);
71
72			my $arg = {@_};
73
74			my $log = $self->_get_logger();
75
76	dpavlin	870	$log->logconfess("this module requires input_config") unless ( $arg->{input_config} );
77
78	dpavlin	869	my $db = XBase->new( $arg->{path} ) \|\| $log->logdie("can't open ", $arg->{path}, ": $!");
79
80			my $size = $db->last_record;
81
82			$log->info("opening DBF database '$arg->{path}' with $size records");
83
84	dpavlin	870	my $mapping_path = $arg->{input_config}->{mapping_path};
85			my $mapping;
86	dpavlin	869
87	dpavlin	870	if ( ! $mapping_path ) {
88			$log->debug("didn't found any mapping_path in configuration", sub { dump( $arg->{input_config} ) });
89	dpavlin	869
90			foreach my $field ( $db->field_names ) {
91			push @$mapping, { $field => { '900' => 'x' } };
92			}
93
94			my $mapping_path = $arg->{path};
95			$mapping_path =~ s!^.+/([^/]+)\.dbf!$1.yml!;
96
97			$log->logdie("mapping file $mapping_path allready exists, aborting.") if ( -e $mapping_path );
98
99	dpavlin	870	DumpFile( $mapping_path, Dump( { mapping => $mapping } ) ) \|\|
100	dpavlin	869	$log->logdie("can't write template file for mapping_path $mapping_path: $!");
101
102			$log->logdie("template file for mapping_path created as $mapping_path");
103
104			} else {
105	dpavlin	870	$mapping = LoadFile( $mapping_path ) \|\| $log->logdie("can't open $mapping_path: $!");
106			$log->logdie("missing top-level mapping key in $mapping_path") unless ( $mapping->{mapping} );
107			$mapping = $mapping->{mapping};
108			$log->debug("using mapping from $mapping_path = ", sub { dump($mapping) });
109	dpavlin	869	}
110
111			foreach my $mfn ( 1 .. $size ) {
112
113			my $row = $db->get_record_as_hash( $mfn );
114
115			$log->debug("dbf row = ", sub { dump( $row ) });
116
117			my $record = {
118			'001' => [ $mfn ],
119			};
120
121	dpavlin	870	# fixme -- this will break given wrong structure!
122			foreach my $m ( @$mapping ) {
123			my $db_field = (keys %$m)[0];
124			my ( $f, $sf ) = %{ $m->{$db_field} };
125			push @{ $record->{$f} }, '^' . $sf . $row->{$db_field} if ( defined( $row->{$db_field} ) && $row->{$db_field} ne '' );
126			}
127
128	dpavlin	869	$self->{_rows}->{ $mfn } = $record;
129			$log->debug("created row $mfn ", dump( $record ));
130			}
131
132			$self->{size} = $size;
133
134			$self ? return $self : return undef;
135			}
136
137			=head2 fetch_rec
138
139			Return record with ID C<$mfn> from database
140
141			my $rec = $ll_db->fetch_rec( $mfn, $filter_coderef );
142
143			=cut
144
145			sub fetch_rec {
146			my $self = shift;
147
148			my ($mfn, $filter_coderef) = @_;
149
150			my $rec = $self->_to_hash(
151			mfn => $mfn,
152			row => $self->{_rows}->{$mfn},
153			hash_filter => $filter_coderef,
154			);
155
156			my $log = $self->_get_logger();
157			$log->debug("fetch_rec($mfn) = ", dump($rec));
158
159			return $rec;
160			}
161
162			=head2 size
163
164			Return number of records in database
165
166			my $size = $ll_db->size;
167
168			=cut
169
170			sub size {
171			my $self = shift;
172			return $self->{size};
173			}
174
175			=head1 AUTHOR
176
177			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
178
179			=head1 COPYRIGHT & LICENSE
180
181			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
182
183			This program is free software; you can redistribute it and/or modify it
184			under the same terms as Perl itself.
185
186			=cut
187
188			1; # End of WebPAC::Input::DBF