git.rot13.org Git - webpac2/blob - lib/WebPAC/Input/DBF.pm

   1 package WebPAC::Input::DBF;
   2
   3 use warnings;
   4 use strict;
   5
   6 use WebPAC::Input;
   7 use WebPAC::Input::Helper;
   8 use base qw/WebPAC::Common WebPAC::Input::Helper/;
   9 use XBase;
  10 use Data::Dump qw/dump/;
  11 use Encode qw/encode_utf8/;
  12 use YAML qw/LoadFile DumpFile/;
  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         mapping_path => '/path/to/input/dbf/mapping.yml',
  44         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 =item mapping_path
  60
  61 path to mapping YAML which will be created on first run
  62
  63 =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         $log->logconfess("this module requires input_config") unless ( $arg->{input_config} );
  77
  78         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         my $mapping_path = $arg->{input_config}->{mapping_path} || $self->{input_config}->{mapping_path};
  85         my $mapping;
  86
  87         if ( ! $mapping_path || ! -e $mapping_path ) {
  88                 $log->debug("didn't found any mapping_path in configuration", sub { dump( $arg->{input_config} ) });
  89
  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                 DumpFile( $mapping_path, { mapping => $mapping } ) ||
 100                         $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                 $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         }
 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                 # 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                 $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