/[webpac2]/trunk/lib/WebPAC/Normalize.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/Normalize.pm

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

revision 13 by dpavlin, Sat Jul 16 23:56:14 2005 UTC revision 551 by dpavlin, Fri Jun 30 20:43:09 2006 UTC
# Line 1  Line 1 
1  package WebPAC::Normalize;  package WebPAC::Normalize;
2    use Exporter 'import';
3    @EXPORT = qw/
4            _set_rec _set_lookup
5            _get_ds _clean_ds
6    
7            tag search display
8            marc marc_indicators marc_repeatable_subfield
9    
10            rec1 rec2 rec
11            regex prefix suffix surround
12            first lookup join_with
13    /;
14    
15  use warnings;  use warnings;
16  use strict;  use strict;
17  use Data::Dumper;  
18    #use base qw/WebPAC::Common/;
19    use Data::Dump qw/dump/;
20    use Encode qw/from_to/;
21    
22    # debugging warn(s)
23    my $debug = 0;
24    
25    
26  =head1 NAME  =head1 NAME
27    
28  WebPAC::Normalize - normalisation of source file  WebPAC::Normalize - describe normalisaton rules using sets
29    
30  =head1 VERSION  =head1 VERSION
31    
32  Version 0.01  Version 0.06
33    
34  =cut  =cut
35    
36  our $VERSION = '0.01';  our $VERSION = '0.06';
37    
38  =head1 SYNOPSIS  =head1 SYNOPSIS
39    
40  This package contains code that could be helpful in implementing different  This module uses C<conf/normalize/*.pl> files to perform normalisation
41  normalisation front-ends.  from input records using perl functions which are specialized for set
42    processing.
43    
44    Sets are implemented as arrays, and normalisation file is valid perl, which
45    means that you check it's validity before running WebPAC using
46    C<perl -c normalize.pl>.
47    
48    Normalisation can generate multiple output normalized data. For now, supported output
49    types (on the left side of definition) are: C<tag>, C<display>, C<search> and
50    C<marc>.
51    
52  =head1 FUNCTIONS  =head1 FUNCTIONS
53    
54  =head2 new  Functions which start with C<_> are private and used by WebPAC internally.
55    All other functions are available for use within normalisation rules.
56    
57  Create new normalisation object  =head2 data_structure
58    
59    my $n = new WebPAC::Normalize::Something(  Return data structure
60          cache_data_structure => './cache/ds/',  
61          lookup_regex => $lookup->regex,    my $ds = WebPAC::Normalize::data_structure(
62            lookup => $lookup->lookup_hash,
63            row => $row,
64            rules => $normalize_pl_config,
65            marc_encoding => 'utf-8',
66    );    );
67    
68  Optional parameter C<cache_data_structure> defines path to directory  Options C<lookup>, C<row>, C<rules> and C<log> are mandatory while all
69  in which cache file for C<data_structure> call will be created.  other are optional.
70    
71    This function will B<die> if normalizastion can't be evaled.
72    
73  Recommended parametar C<lookup_regex> is used to enable parsing of lookups  Since this function isn't exported you have to call it with
74  in structures.  C<WebPAC::Normalize::data_structure>.
75    
76  =cut  =cut
77    
78  sub new {  sub data_structure {
79          my $class = shift;          my $arg = {@_};
         my $self = {@_};  
         bless($self, $class);  
80    
81          $self->setup_cache_dir( $self->{'cache_data_structure'} );          die "need row argument" unless ($arg->{row});
82            die "need normalisation argument" unless ($arg->{rules});
83    
84          $self ? return $self : return undef;          no strict 'subs';
85  }          _set_lookup( $arg->{lookup} );
86            _set_rec( $arg->{row} );
87            _clean_ds( %{ $arg } );
88            eval "$arg->{rules}";
89            die "error evaling $arg->{rules}: $@\n" if ($@);
90    
91  =head2 setup_cache_dir          return _get_ds();
92    }
93    
94  Check if specified cache directory exist, and if not, disable caching.  =head2 _set_rec
95    
96   $setup_cache_dir('./cache/ds/');  Set current record hash
97    
98  If you pass false or zero value to this function, it will disable    _set_rec( $rec );
 cacheing.  
99    
100  =cut  =cut
101    
102  sub setup_cache_dir {  my $rec;
         my $self = shift;  
103    
104          my $dir = shift;  sub _set_rec {
105            $rec = shift or die "no record hash";
106    }
107    
108          my $log = $self->_get_logger();  =head2 _get_ds
109    
110          if ($dir) {  Return hash formatted as data structure
                 my $msg;  
                 if (! -e $dir) {  
                         $msg = "doesn't exist";  
                 } elsif (! -d $dir) {  
                         $msg = "is not directory";  
                 } elsif (! -w $dir) {  
                         $msg = "not writable";  
                 }  
111    
112                  if ($msg) {    my $ds = _get_ds();
113                          undef $self->{'cache_data_structure'};  
114                          $log->warn("cache_data_structure $dir $msg, disabling...");  =cut
115                  } else {  
116                          $log->debug("using cache dir $dir");  my ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators);
117                  }  
118          } else {  sub _get_ds {
119                  $log->debug("disabling cache");          return $out;
                 undef $self->{'cache_data_structure'};  
         }  
120  }  }
121    
122    =head2 _clean_ds
123    
124  =head2 data_structure  Clean data structure hash for next record
125    
126      _clean_ds();
127    
128  Create in-memory data structure which represents normalized layout from  =cut
 C<conf/normalize/*.xml>.  
129    
130  This structures are used to produce output.  sub _clean_ds {
131            my $a = {@_};
132            ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = ();
133            $marc_encoding = $a->{marc_encoding};
134    }
135    
136   my @ds = $webpac->data_structure($rec);  =head2 _set_lookup
137    
138  B<Note: historical oddity follows>  Set current lookup hash
139    
140  This method will also set C<< $webpac->{'currnet_filename'} >> if there is    _set_lookup( $lookup );
 C<< <filename> >> tag and C<< $webpac->{'headline'} >> if there is  
 C<< <headline> >> tag.  
141    
142  =cut  =cut
143    
144  sub data_structure {  my $lookup;
145          my $self = shift;  
146    sub _set_lookup {
147            $lookup = shift;
148    }
149    
150          my $log = $self->_get_logger();  =head2 _get_marc_fields
151    
152          my $rec = shift;  Get all fields defined by calls to C<marc>
         $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  
153    
154          my $cache_file;          $marc->add_fields( WebPAC::Normalize:_get_marc_fields() );
155    
         if (my $cache_path = $self->{'cache_data_structure'}) {  
                 my $id = $rec->{'000'};  
                 $id = $rec->{'000'}->[0] if ($id =~ m/^ARRAY/o);  
                 unless (defined($id)) {  
                         $log->warn("Can't use cache_data_structure on records without unique identifier in field 000");  
                         undef $self->{'cache_data_structure'};  
                 } else {  
                         $cache_file = "$cache_path/$id";  
                         if (-r $cache_file) {  
                                 my $ds_ref = retrieve($cache_file);  
                                 if ($ds_ref) {  
                                         $log->debug("cache hit: $cache_file");  
                                         my $ok = 1;  
                                         foreach my $f (qw(current_filename headline)) {  
                                                 if ($ds_ref->{$f}) {  
                                                         $self->{$f} = $ds_ref->{$f};  
                                                 } else {  
                                                         $ok = 0;  
                                                 }  
                                         };  
                                         if ($ok && $ds_ref->{'ds'}) {  
                                                 return @{ $ds_ref->{'ds'} };  
                                         } else {  
                                                 $log->warn("cache_data_structure $cache_path corrupt. Use rm $cache_path/* to re-create it on next run!");  
                                                 undef $self->{'cache_data_structure'};  
                                         }  
                                 }  
                         }  
                 }  
         }  
156    
         undef $self->{'currnet_filename'};  
         undef $self->{'headline'};  
157    
158          my @sorted_tags;  We are using I<magic> which detect repeatable fields only from
159          if ($self->{tags_by_order}) {  sequence of field/subfield data generated by normalization.
                 @sorted_tags = @{$self->{tags_by_order}};  
         } else {  
                 @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};  
                 $self->{tags_by_order} = \@sorted_tags;  
         }  
160    
161          my @ds;  Repeatable field is created if there is second occurence of same subfield or
162    if any of indicators are different. This is sane for most cases except for
163    non-repeatable fields with repeatable subfields.
164    
165          $log->debug("tags: ",sub { join(", ",@sorted_tags) });  You can change behaviour of that using C<marc_repeatable_subfield>.
166    
167          foreach my $field (@sorted_tags) {  =cut
168    
169                  my $row;  sub _get_marc_fields {
170    
171  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});          return if (! $marc_record || ref($marc_record) ne 'ARRAY' || $#{ $marc_record } < 0);
172    
173                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {          # first, sort all existing fields
174                          my $format = $tag->{'value'} || $tag->{'content'};          # XXX might not be needed, but modern perl might randomize elements in hash
175            my @sorted_marc_record = sort {
176                    $a->[0] . $a->[3] cmp $b->[0] . $b->[3]
177            } @{ $marc_record };
178    
179                          $log->debug("format: $format");          # output marc fields
180            my @m;
181    
182                          my @v;          # count unique field-subfields (used for offset when walking to next subfield)
183                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {          my $u;
184                                  @v = $self->fill_in_to_arr($rec,$format);          map { $u->{ $_->[0] . $_->[3]  }++ } @sorted_marc_record;
                         } else {  
                                 @v = $self->parse_to_arr($rec,$format);  
                         }  
                         next if (! @v);  
185    
186                          if ($tag->{'sort'}) {          if ($debug) {
187                                  @v = $self->sort_arr(@v);                  warn "## marc_repeatable_subfield ", dump( $marc_repeatable_subfield ), $/;
188                          }                  warn "## marc_record ", dump( $marc_record ), $/;
189                    warn "## sorted_marc_record ", dump( \@sorted_marc_record ), $/;
190                    warn "## subfield count ", dump( $u ), $/;
191            }
192    
193                          # use format?          my $len = $#sorted_marc_record;
194                          if ($tag->{'format_name'}) {          my $visited;
195                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;          my $i = 0;
196                          }          my $field;
197    
198                          if ($field eq 'filename') {          foreach ( 0 .. $len ) {
                                 $self->{'current_filename'} = join('',@v);  
                                 $log->debug("filename: ",$self->{'current_filename'});  
                         } elsif ($field eq 'headline') {  
                                 $self->{'headline'} .= join('',@v);  
                                 $log->debug("headline: ",$self->{'headline'});  
                                 next; # don't return headline in data_structure!  
                         }  
199    
200                          # delimiter will join repeatable fields                  # find next element which isn't visited
201                          if ($tag->{'delimiter'}) {                  while ($visited->{$i}) {
202                                  @v = ( join($tag->{'delimiter'}, @v) );                          $i = ($i + 1) % ($len + 1);
203                          }                  }
204    
205                          # default types                  # mark it visited
206                          my @types = qw(display swish);                  $visited->{$i}++;
207                          # override by type attribute  
208                          @types = ( $tag->{'type'} ) if ($tag->{'type'});                  my $row = $sorted_marc_record[$i];
   
                         foreach my $type (@types) {  
                                 # append to previous line?  
                                 $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');  
                                 if ($tag->{'append'}) {  
   
                                         # I will delimit appended part with  
                                         # delimiter (or ,)  
                                         my $d = $tag->{'delimiter'};  
                                         # default delimiter  
                                         $d ||= " ";  
   
                                         my $last = pop @{$row->{$type}};  
                                         $d = "" if (! $last);  
                                         $last .= $d . join($d, @v);  
                                         push @{$row->{$type}}, $last;  
   
                                 } else {  
                                         push @{$row->{$type}}, @v;  
                                 }  
                         }  
209    
210                    # field and subfield which is key for
211                    # marc_repeatable_subfield and u
212                    my $fsf = $row->[0] . $row->[3];
213    
214                    if ($debug > 1) {
215    
216                            print "### field so far [", $#$field, "] : ", dump( $field ), " ", $field ? 'T' : 'F', $/;
217                            print "### this [$i]: ", dump( $row ),$/;
218                            print "### sf: ", $row->[3], " vs ", $field->[3],
219                                    $marc_repeatable_subfield->{ $row->[0] . $row->[3] } ? ' (repeatable)' : '', $/,
220                                    if ($#$field >= 0);
221    
222                  }                  }
223    
224                  if ($row) {                  # if field exists
225                          $row->{'tag'} = $field;                  if ( $#$field >= 0 ) {
226                            if (
227                                    $row->[0] ne $field->[0] ||             # field
228                                    $row->[1] ne $field->[1] ||             # i1
229                                    $row->[2] ne $field->[2]                # i2
230                            ) {
231                                    push @m, $field;
232                                    warn "## saved/1 ", dump( $field ),$/ if ($debug);
233                                    $field = $row;
234    
235                            } elsif (
236                                    ( $row->[3] lt $field->[-2] )           # subfield which is not next (e.g. a after c)
237                                    ||
238                                    ( $row->[3] eq $field->[-2] &&          # same subfield, but not repeatable
239                                            ! $marc_repeatable_subfield->{ $fsf }
240                                    )
241                            ) {
242                                    push @m, $field;
243                                    warn "## saved/2 ", dump( $field ),$/ if ($debug);
244                                    $field = $row;
245    
246                          # TODO: name_sigular, name_plural                          } else {
247                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                                  # append new subfields to existing field
248                          $row->{'name'} = $name ? $self->_x($name) : $field;                                  push @$field, ( $row->[3], $row->[4] );
   
                         # post-sort all values in field  
                         if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {  
                                 $log->warn("sort at field tag not implemented");  
249                          }                          }
250                    } else {
251                          push @ds, $row;                          # insert first field
252                            $field = $row;
                         $log->debug("row $field: ",sub { Dumper($row) });  
253                  }                  }
254    
255                    if (! $marc_repeatable_subfield->{ $fsf }) {
256                            # make step to next subfield
257                            $i = ($i + $u->{ $fsf } ) % ($len + 1);
258                    }
259          }          }
260    
261          if ($cache_file) {          if ($#$field >= 0) {
262                  store {                  push @m, $field;
263                          ds => \@ds,                  warn "## saved/3 ", dump( $field ),$/ if ($debug);
                         current_filename => $self->{'current_filename'},  
                         headline => $self->{'headline'},  
                 }, $cache_file;  
                 $log->debug("created storable cache file $cache_file");  
264          }          }
265    
266          return @ds;          return @m;
   
267  }  }
268    
269  =head2 apply_format  =head1 Functions to create C<data_structure>
270    
271    Those functions generally have to first in your normalization file.
272    
273  Apply format specified in tag with C<format_name="name"> and  =head2 tag
 C<format_delimiter=";;">.  
274    
275   my $text = $webpac->apply_format($format_name,$format_delimiter,$data);  Define new tag for I<search> and I<display>.
276    
277      tag('Title', rec('200','a') );
278    
 Formats can contain C<lookup{...}> if you need them.  
279    
280  =cut  =cut
281    
282  sub apply_format {  sub tag {
283          my $self = shift;          my $name = shift or die "tag needs name as first argument";
284            my @o = grep { defined($_) && $_ ne '' } @_;
285            return unless (@o);
286            $out->{$name}->{tag} = $name;
287            $out->{$name}->{search} = \@o;
288            $out->{$name}->{display} = \@o;
289    }
290    
291          my ($name,$delimiter,$data) = @_;  =head2 display
292    
293          my $log = $self->_get_logger();  Define tag just for I<display>
294    
295          if (! $self->{'import_xml'}->{'format'}->{$name}) {    @v = display('Title', rec('200','a') );
                 $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});  
                 return $data;  
         }  
296    
297          $log->warn("no delimiter for format $name") if (! $delimiter);  =cut
298    
299          my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");  sub display {
300            my $name = shift or die "display needs name as first argument";
301            my @o = grep { defined($_) && $_ ne '' } @_;
302            return unless (@o);
303            $out->{$name}->{tag} = $name;
304            $out->{$name}->{display} = \@o;
305    }
306    
307          my @data = split(/\Q$delimiter\E/, $data);  =head2 search
308    
309          my $out = sprintf($format, @data);  Prepare values just for I<search>
         $log->debug("using format $name [$format] on $data to produce: $out");  
310    
311          if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {    @v = search('Title', rec('200','a') );
                 return $self->lookup($out);  
         } else {  
                 return $out;  
         }  
312    
313    =cut
314    
315    sub search {
316            my $name = shift or die "search needs name as first argument";
317            my @o = grep { defined($_) && $_ ne '' } @_;
318            return unless (@o);
319            $out->{$name}->{tag} = $name;
320            $out->{$name}->{search} = \@o;
321  }  }
322    
323  =head2 parse  =head2 marc
324    
325  Perform smart parsing of string, skipping delimiters for fields which aren't  Save value for MARC field
 defined. It can also eval code in format starting with C<eval{...}> and  
 return output or nothing depending on eval code.  
326    
327   my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);    marc('900','a', rec('200','a') );
328    
329  =cut  =cut
330    
331  sub parse {  sub marc {
332          my $self = shift;          my $f = shift or die "marc needs field";
333            die "marc field must be numer" unless ($f =~ /^\d+$/);
334    
335          my ($rec, $format_utf8, $i) = @_;          my $sf = shift or die "marc needs subfield";
336    
337          return if (! $format_utf8);          foreach (@_) {
338                    my $v = $_;             # make var read-write for Encode
339                    next unless (defined($v) && $v !~ /^\s*$/);
340                    from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
341                    my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
342                    push @{ $marc_record }, [ $f, $i1, $i2, $sf => $v ];
343            }
344    }
345    
346          my $log = $self->_get_logger();  =head2 marc_repeatable_subfield
347    
348          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  Save values for MARC repetable subfield
349    
350          $i = 0 if (! $i);    marc_repeatable_subfield('910', 'z', rec('909') );
351    
352          my $format = $self->_x($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});  =cut
353    
354          my @out;  sub marc_repeatable_subfield {
355            my ($f,$sf) = @_;
356            die "marc_repeatable_subfield need field and subfield!\n" unless ($f && $sf);
357            $marc_repeatable_subfield->{ $f . $sf }++;
358            marc(@_);
359    }
360    
361          $log->debug("format: $format");  =head2 marc_indicators
362    
363          my $eval_code;  Set both indicators for MARC field
         # remove eval{...} from beginning  
         $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);  
364    
365          my $filter_name;    marc_indicators('900', ' ', 1);
         # remove filter{...} from beginning  
         $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);  
366    
367          my $prefix;  Any indicator value other than C<0-9> will be treated as undefined.
         my $all_found=0;  
368    
369          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {  =cut
370    
371                  my $del = $1 || '';  sub marc_indicators {
372                  $prefix ||= $del if ($all_found == 0);          my $f = shift || die "marc_indicators need field!\n";
373            my ($i1,$i2) = @_;
374            die "marc_indicators($f, ...) need i1!\n" unless(defined($i1));
375            die "marc_indicators($f, $i1, ...) need i2!\n" unless(defined($i2));
376    
377                  # repeatable index          $i1 = ' ' if ($i1 !~ /^\d$/);
378                  my $r = $i;          $i2 = ' ' if ($i2 !~ /^\d$/);
379                  $r = 0 if (lc("$2") eq 's');          @{ $marc_indicators->{$f} } = ($i1,$i2);
380    }
381    
                 my $found = 0;  
                 my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);  
382    
383                  if ($found) {  =head1 Functions to extract data from input
                         push @out, $del;  
                         push @out, $tmp;  
                         $all_found += $found;  
                 }  
         }  
384    
385          return if (! $all_found);  This function should be used inside functions to create C<data_structure> described
386    above.
387    
388          my $out = join('',@out);  =head2 rec1
389    
390          if ($out) {  Return all values in some field
                 # add rest of format (suffix)  
                 $out .= $format;  
391    
392                  # add prefix if not there    @v = rec1('200')
                 $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);  
393    
394                  $log->debug("result: $out");  TODO: order of values is probably same as in source data, need to investigate that
         }  
395    
396          if ($eval_code) {  =cut
                 my $eval = $self->fill_in($rec,$eval_code,$i) || return;  
                 $log->debug("about to eval{$eval} format: $out");  
                 return if (! $self->_eval($eval));  
         }  
           
         if ($filter_name && $self->{'filter'}->{$filter_name}) {  
                 $log->debug("about to filter{$filter_name} format: $out");  
                 $out = $self->{'filter'}->{$filter_name}->($out);  
                 return unless(defined($out));  
                 $log->debug("filter result: $out");  
         }  
397    
398          return $out;  sub rec1 {
399            my $f = shift;
400            return unless (defined($rec) && defined($rec->{$f}));
401            if (ref($rec->{$f}) eq 'ARRAY') {
402                    return map {
403                            if (ref($_) eq 'HASH') {
404                                    values %{$_};
405                            } else {
406                                    $_;
407                            }
408                    } @{ $rec->{$f} };
409            } elsif( defined($rec->{$f}) ) {
410                    return $rec->{$f};
411            }
412  }  }
413    
414  =head2 parse_to_arr  =head2 rec2
415    
416  Similar to C<parse>, but returns array of all repeatable fields  Return all values in specific field and subfield
417    
418   my @arr = $webpac->parse_to_arr($rec,'v250^a');    @v = rec2('200','a')
419    
420  =cut  =cut
421    
422  sub parse_to_arr {  sub rec2 {
423          my $self = shift;          my $f = shift;
424            return unless (defined($rec && $rec->{$f}));
425            my $sf = shift;
426            return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
427    }
428    
429          my ($rec, $format_utf8) = @_;  =head2 rec
430    
431          my $log = $self->_get_logger();  syntaxtic sugar for
432    
433          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);    @v = rec('200')
434          return if (! $format_utf8);    @v = rec('200','a')
435    
436          my $i = 0;  =cut
         my @arr;  
437    
438          while (my $v = $self->parse($rec,$format_utf8,$i++)) {  sub rec {
439                  push @arr, $v;          if ($#_ == 0) {
440                    return rec1(@_);
441            } elsif ($#_ == 1) {
442                    return rec2(@_);
443          }          }
   
         $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);  
   
         return @arr;  
444  }  }
445    
446  =head2 fill_in_to_arr  =head2 regex
447    
448  Similar to C<fill_in>, but returns array of all repeatable fields. Usable  Apply regex to some or all values
 for fields which have lookups, so they shouldn't be parsed but rather  
 C<fill_id>ed.  
449    
450   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');    @v = regex( 's/foo/bar/g', @v );
451    
452  =cut  =cut
453    
454  sub fill_in_to_arr {  sub regex {
455          my $self = shift;          my $r = shift;
456            my @out;
457          my ($rec, $format_utf8) = @_;          #warn "r: $r\n", dump(\@_);
458            foreach my $t (@_) {
459          my $log = $self->_get_logger();                  next unless ($t);
460                    eval "\$t =~ $r";
461                    push @out, $t if ($t && $t ne '');
462            }
463            return @out;
464    }
465    
466          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  =head2 prefix
         return if (! $format_utf8);  
467    
468          my $i = 0;  Prefix all values with a string
         my @arr;  
469    
470          while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {    @v = prefix( 'my_', @v );
                 push @arr, @v;  
         }  
471    
472          $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);  =cut
473    
474          return @arr;  sub prefix {
475            my $p = shift or die "prefix needs string as first argument";
476            return map { $p . $_ } grep { defined($_) } @_;
477  }  }
478    
479  =head2 sort_arr  =head2 suffix
480    
481  Sort array ignoring case and html in data  suffix all values with a string
482    
483   my @sorted = $webpac->sort_arr(@unsorted);    @v = suffix( '_my', @v );
484    
485  =cut  =cut
486    
487  sub sort_arr {  sub suffix {
488          my $self = shift;          my $s = shift or die "suffix needs string as first argument";
489            return map { $_ . $s } grep { defined($_) } @_;
490    }
491    
492    =head2 surround
493    
494          my $log = $self->_get_logger();  surround all values with a two strings
495    
496          # FIXME add Schwartzian Transformation?    @v = surround( 'prefix_', '_suffix', @v );
497    
498          my @sorted = sort {  =cut
                 $a =~ s#<[^>]+/*>##;  
                 $b =~ s#<[^>]+/*>##;  
                 lc($b) cmp lc($a)  
         } @_;  
         $log->debug("sorted values: ",sub { join(", ",@sorted) });  
499    
500          return @sorted;  sub surround {
501            my $p = shift or die "surround need prefix as first argument";
502            my $s = shift or die "surround needs suffix as second argument";
503            return map { $p . $_ . $s } grep { defined($_) } @_;
504  }  }
505    
506    =head2 first
507    
508  =head2 _sort_by_order  Return first element
509    
510  Sort xml tags data structure accoding to C<order=""> attribute.    $v = first( @v );
511    
512  =cut  =cut
513    
514  sub _sort_by_order {  sub first {
515          my $self = shift;          my $r = shift;
516            return $r;
         my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||  
                 $self->{'import_xml'}->{'indexer'}->{$a};  
         my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||  
                 $self->{'import_xml'}->{'indexer'}->{$b};  
   
         return $va <=> $vb;  
517  }  }
518    
519  =head2 _x  =head2 lookup
   
 Convert strings from C<conf/normalize> encoding into application specific  
 (optinally specified using C<code_page> to C<new> constructor.  
520    
521   my $text = $n->_x('normalize text string');  Consult lookup hashes for some value
522    
523  This is a stub so that other modules doesn't have to implement it.    @v = lookup( $v );
524      @v = lookup( @v );
525    
526  =cut  =cut
527    
528  sub _x {  sub lookup {
529          my $self = shift;          my $k = shift or return;
530          return shift;          return unless (defined($lookup->{$k}));
531            if (ref($lookup->{$k}) eq 'ARRAY') {
532                    return @{ $lookup->{$k} };
533            } else {
534                    return $lookup->{$k};
535            }
536  }  }
537    
538    =head2 join_with
539    
540  =head1 AUTHOR  Joins walues with some delimiter
   
 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  
   
 =head1 COPYRIGHT & LICENSE  
541    
542  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.    $v = join_with(", ", @v);
   
 This program is free software; you can redistribute it and/or modify it  
 under the same terms as Perl itself.  
543    
544  =cut  =cut
545    
546  1; # End of WebPAC::DB  sub join_with {
547            my $d = shift;
548            return join($d, grep { defined($_) && $_ ne '' } @_);
549    }
550    
551    # END
552    1;

Legend:
Removed from v.13  
changed lines
  Added in v.551

  ViewVC Help
Powered by ViewVC 1.1.26