/[webpac2]/trunk/lib/WebPAC/Input/XML.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/WebPAC/Input/XML.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 981 by dpavlin, Sat Nov 3 13:33:21 2007 UTC revision 998 by dpavlin, Sun Nov 4 16:47:03 2007 UTC
# Line 8  use base qw/WebPAC::Common/; Line 8  use base qw/WebPAC::Common/;
8    
9  use XML::Simple;  use XML::Simple;
10  use File::Find;  use File::Find;
11    use File::Slurp;
12    
13  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
14    
# Line 17  WebPAC::Input::XML - support for reading Line 18  WebPAC::Input::XML - support for reading
18    
19  =cut  =cut
20    
21  our $VERSION = '0.01';  our $VERSION = '0.02';
22    
23  =head1 FUNCTIONS  =head1 FUNCTIONS
24    
# Line 32  Returns new low-level input API object Line 33  Returns new low-level input API object
33                  # do something with $l which is line of input file                  # do something with $l which is line of input file
34                  return $l;                  return $l;
35          },          },
36            mungle => 'conf/mungle/xml-mungle.pl',
37    }    }
38    
39  Options:  Options:
# Line 42  Options: Line 44  Options:
44    
45  path to directory with xml files ending in C<.xml>  path to directory with xml files ending in C<.xml>
46    
47    =item mungle
48    
49    path to perl data_structure mungler which will be called to pre-normalize
50    hash produced by this module.
51    
52    It's ugly and souldn't be really here, but I didn't wanted to write separate
53    input module for each possible XML in the face of the earth, and having perl
54    power to transform hash is just... Best solution :-)
55    
56  =back  =back
57    
58  =cut  =cut
# Line 53  sub new { Line 64  sub new {
64    
65          my $arg = {@_};          my $arg = {@_};
66    
67    #warn "#### arg = ",dump( $arg );
68    
69          my $log = $self->_get_logger();          my $log = $self->_get_logger();
70    
71          $log->logdie("can't find path ", $arg->{path}, ": $!\n") unless -d $arg->{path};          $log->logdie("can't find path ", $arg->{path}, ": $!\n") unless -d $arg->{path};
# Line 72  sub new { Line 85  sub new {
85    
86          $log->info("found ", $#files + 1, " XML files in ", $arg->{path});          $log->info("found ", $#files + 1, " XML files in ", $arg->{path});
87    
88          $self->{_files} = \@files;          $self->{_files} = [ sort @files ];
89    
90            if ( my $path = $arg->{mungle} ) {
91                    $log->logdie("can't find $path: $!") unless -r $path;
92                    $log->info("using $path as mungle rules");
93    
94                    $self->{mungle_rules} = read_file( $path ) || $log->logdie("can't open $path: $!");
95            }
96    
97          $self ? return $self : return undef;          $self ? return $self : return undef;
98  }  }
# Line 94  sub fetch_rec { Line 114  sub fetch_rec {
114    
115          my $log = $self->_get_logger();          my $log = $self->_get_logger();
116    
117          my $xml = XMLin(          our $xml;
118                  $path,          eval {
119  #               ForceArray => 1,                  $xml = XMLin(
120  #               ForceContent => 1,                          $path,
121  #               KeepRoot => 1,  #                       ForceArray => 1,
122  #               SuppressEmpty => 1, # '' undef  #                       ForceContent => 1,
123                            KeepRoot => 1,
124          ) || $log->logdie("can't open $path: $!");  #                       SuppressEmpty => 1, # '' undef
125                    ) || die "can't open $path: $!";
126          warn "### fetch_rec( $mfn ) => $path => xml is ",dump($xml);          };
127    
128            if ( $@ ) {
129                    $log->error("$@");
130                    return;
131            }
132    
133            $log->debug("fetch_rec( $mfn ) => $path => xml is ",sub { dump($xml) });
134    
135            our $ds;
136    
137            if ( my $rules = $self->{mungle_rules} ) {
138    
139                    sub get_ds {
140    #                       warn "### get_ds xml = ",dump($xml);
141                            return $xml;
142                    }
143                    sub set_ds {
144                            my $hash = {@_};
145    #                       warn "### set_ds hash = ",dump($hash);
146                            foreach my $f ( keys %$hash ) {
147    #                               warn "+++ $f ", dump( $hash->{$f} ),"\n";
148                                    $ds->{$f} = $hash->{$f};
149                            }
150    #                       warn "### set_ds mungle_ds = ",dump($ds);
151                    }
152                    eval "$rules";
153                    $log->logdie("mungle rules $path error: $@") if $@;
154    
155    #               warn "### set_ds after mungle_rules ds = ",dump($ds);
156            } else {
157    
158                    $ds = $xml;
159            
160            }
161    
162          # add mfn          # add mfn
163          $xml->{'000'} = [ $mfn ];          $ds->{'000'} = [ $mfn ];
164    
165          return $xml;          return $ds;
166  }  }
167    
168    
Legend:
Removed from v.981  
changed lines
  Added in v.998
  ViewVC Help
Powered by ViewVC 1.1.26