/[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 14 by dpavlin, Sun Jul 17 00:04:25 2005 UTC revision 364 by dpavlin, Sun Jan 8 20:27:11 2006 UTC
# Line 2  package WebPAC::Normalize; Line 2  package WebPAC::Normalize;
2    
3  use warnings;  use warnings;
4  use strict;  use strict;
5    use base 'WebPAC::Common';
6  use Data::Dumper;  use Data::Dumper;
 use Storable;  
7    
8  =head1 NAME  =head1 NAME
9    
10  WebPAC::Normalize - normalisation of source file  WebPAC::Normalize - data mungling for normalisation
11    
12  =head1 VERSION  =head1 VERSION
13    
14  Version 0.01  Version 0.08
15    
16  =cut  =cut
17    
18  our $VERSION = '0.01';  our $VERSION = '0.08';
19    
20  =head1 SYNOPSIS  =head1 SYNOPSIS
21    
22  This package contains code that could be helpful in implementing different  This package contains code that mungle data to produce normalized format.
23  normalisation front-ends.  
24    It contains several assumptions:
25    
26    =over
27    
28    =item *
29    
30    format of fields is defined using C<v123^a> notation for repeatable fields
31    or C<s123^a> for single (or first) value, where C<123> is field number and
32    C<a> is subfield.
33    
34    =item *
35    
36    source data records (C<$rec>) have unique identifiers in field C<000>
37    
38    =item *
39    
40    optional C<eval{length('v123^a') == 3}> tag at B<beginning of format> will be
41    perl code that is evaluated before producing output (value of field will be
42    interpolated before that)
43    
44    =item *
45    
46    optional C<filter{filter_name}> at B<begining of format> will apply perl
47    code defined as code ref on format after field substitution to producing
48    output
49    
50    There is one built-in filter called C<regex> which can be use like this:
51    
52      filter{regex(s/foo/bar/)}
53    
54    =item *
55    
56    optional C<lookup{...}> will be then performed. See C<WebPAC::Lookups>.
57    
58    =item *
59    
60    at end, optional C<format>s rules are resolved. Format rules are similar to
61    C<sprintf> and can also contain C<lookup{...}> which is performed after
62    values are inserted in format.
63    
64    =back
65    
66    This also describes order in which transformations are applied (eval,
67    filter, lookup, format) which is important to undestand when deciding how to
68    solve your data mungling and normalisation process.
69    
70    
71    
72    
73  =head1 FUNCTIONS  =head1 FUNCTIONS
74    
# Line 29  normalisation front-ends. Line 77  normalisation front-ends.
77  Create new normalisation object  Create new normalisation object
78    
79    my $n = new WebPAC::Normalize::Something(    my $n = new WebPAC::Normalize::Something(
80          cache_data_structure => './cache/ds/',          filter => {
81                    'filter_name_1' => sub {
82                            # filter code
83                            return length($_);
84                    }, ...
85            },
86            db => $db_obj,
87          lookup_regex => $lookup->regex,          lookup_regex => $lookup->regex,
88            lookup => $lookup_obj,
89            prefix => 'foobar',
90    );    );
91    
92  Optional parameter C<cache_data_structure> defines path to directory  Parametar C<filter> defines user supplied snippets of perl code which can
93  in which cache file for C<data_structure> call will be created.  be use with C<filter{...}> notation.
94    
95    C<prefix> is used to form filename for database record (to support multiple
96    source files which are joined in one database).
97    
98  Recommended parametar C<lookup_regex> is used to enable parsing of lookups  Recommended parametar C<lookup_regex> is used to enable parsing of lookups
99  in structures.  in structures. If you pass this parametar, you must also pass C<lookup>
100    which is C<WebPAC::Lookup> object.
101    
102  =cut  =cut
103    
# Line 46  sub new { Line 106  sub new {
106          my $self = {@_};          my $self = {@_};
107          bless($self, $class);          bless($self, $class);
108    
109          $self->setup_cache_dir( $self->{'cache_data_structure'} );          my $r = $self->{'lookup_regex'} ? 1 : 0;
110            my $l = $self->{'lookup'} ? 1 : 0;
         $self ? return $self : return undef;  
 }  
   
 =head2 setup_cache_dir  
111    
112  Check if specified cache directory exist, and if not, disable caching.          my $log = $self->_get_logger();
   
  $setup_cache_dir('./cache/ds/');  
   
 If you pass false or zero value to this function, it will disable  
 cacheing.  
113    
114  =cut          # those two must be in pair
115            if ( ($r & $l) != ($r || $l) ) {
116                    my $log = $self->_get_logger();
117                    $log->logdie("lookup_regex and lookup must be in pair");
118            }
119    
120  sub setup_cache_dir {          $log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));
         my $self = shift;  
121    
122          my $dir = shift;          $log->warn("no prefix defined. please check that!") unless ($self->{'prefix'});
123    
124          my $log = $self->_get_logger();          $log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);
125    
126          if ($dir) {          if (! $self->{filter} || ! $self->{filter}->{regex}) {
127                  my $msg;                  $log->debug("adding built-in filter regex");
128                  if (! -e $dir) {                  $self->{filter}->{regex} = sub {
129                          $msg = "doesn't exist";                          my ($val, $regex) = @_;
130                  } elsif (! -d $dir) {                          eval "\$val =~ $regex";
131                          $msg = "is not directory";                          return $val;
132                  } elsif (! -w $dir) {                  };
                         $msg = "not writable";  
                 }  
   
                 if ($msg) {  
                         undef $self->{'cache_data_structure'};  
                         $log->warn("cache_data_structure $dir $msg, disabling...");  
                 } else {  
                         $log->debug("using cache dir $dir");  
                 }  
         } else {  
                 $log->debug("disabling cache");  
                 undef $self->{'cache_data_structure'};  
133          }          }
134    
135            $self ? return $self : return undef;
136  }  }
137    
138    
# Line 99  C<conf/normalize/*.xml>. Line 143  C<conf/normalize/*.xml>.
143    
144  This structures are used to produce output.  This structures are used to produce output.
145    
146   my @ds = $webpac->data_structure($rec);   my $ds = $webpac->data_structure($rec);
   
 B<Note: historical oddity follows>  
   
 This method will also set C<< $webpac->{'currnet_filename'} >> if there is  
 C<< <filename> >> tag and C<< $webpac->{'headline'} >> if there is  
 C<< <headline> >> tag.  
147    
148  =cut  =cut
149    
# Line 117  sub data_structure { Line 155  sub data_structure {
155          my $rec = shift;          my $rec = shift;
156          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
157    
158            $log->debug("data_structure rec = ", sub { Dumper($rec) });
159    
160            $log->logdie("need unique ID (mfn) in field 000 of record " . Dumper($rec) ) unless (defined($rec->{'000'}));
161    
162            my $id = $rec->{'000'}->[0] || $log->logdie("field 000 isn't array!");
163    
164          my $cache_file;          my $cache_file;
165    
166          if (my $cache_path = $self->{'cache_data_structure'}) {          if ($self->{'db'}) {
167                  my $id = $rec->{'000'};                  my $ds = $self->{'db'}->load_ds( id => $id, prefix => $self->{prefix} );
168                  $id = $rec->{'000'}->[0] if ($id =~ m/^ARRAY/o);                  $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper($ds) });
169                  unless (defined($id)) {                  return $ds if ($ds);
170                          $log->warn("Can't use cache_data_structure on records without unique identifier in field 000");                  $log->debug("cache miss, creating");
                         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'};  
                                         }  
                                 }  
                         }  
                 }  
171          }          }
172    
         undef $self->{'currnet_filename'};  
         undef $self->{'headline'};  
   
173          my @sorted_tags;          my @sorted_tags;
174          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
175                  @sorted_tags = @{$self->{tags_by_order}};                  @sorted_tags = @{$self->{tags_by_order}};
# Line 161  sub data_structure { Line 178  sub data_structure {
178                  $self->{tags_by_order} = \@sorted_tags;                  $self->{tags_by_order} = \@sorted_tags;
179          }          }
180    
181          my @ds;          my $ds;
182    
183          $log->debug("tags: ",sub { join(", ",@sorted_tags) });          $log->debug("tags: ",sub { join(", ",@sorted_tags) });
184    
# Line 172  sub data_structure { Line 189  sub data_structure {
189  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
190    
191                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
192                          my $format = $tag->{'value'} || $tag->{'content'};                          my $format;
193    
194                          $log->debug("format: $format");                          $log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');
195                            $format = $tag->{'value'} || $tag->{'content'};
196    
197                          my @v;                          my @v;
198                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {
# Line 182  sub data_structure { Line 200  sub data_structure {
200                          } else {                          } else {
201                                  @v = $self->parse_to_arr($rec,$format);                                  @v = $self->parse_to_arr($rec,$format);
202                          }                          }
203                          next if (! @v);                          if (! @v) {
204                                    $log->debug("$field <",$self->{tag},"> format: $format no values");
205    #                               next;
206                            } else {
207                                    $log->debug("$field <",$self->{tag},"> format: $format values: ", join(",", @v));
208                            }
209    
210                          if ($tag->{'sort'}) {                          if ($tag->{'sort'}) {
211                                  @v = $self->sort_arr(@v);                                  @v = $self->sort_arr(@v);
# Line 193  sub data_structure { Line 216  sub data_structure {
216                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
217                          }                          }
218    
                         if ($field eq 'filename') {  
                                 $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!  
                         }  
   
219                          # delimiter will join repeatable fields                          # delimiter will join repeatable fields
220                          if ($tag->{'delimiter'}) {                          if ($tag->{'delimiter'}) {
221                                  @v = ( join($tag->{'delimiter'}, @v) );                                  @v = ( join($tag->{'delimiter'}, @v) );
222                          }                          }
223    
224                          # default types                          # default types
225                          my @types = qw(display swish);                          my @types = qw(display search);
226                          # override by type attribute                          # override by type attribute
227                          @types = ( $tag->{'type'} ) if ($tag->{'type'});                          @types = ( $tag->{'type'} ) if ($tag->{'type'});
228    
229                          foreach my $type (@types) {                          foreach my $type (@types) {
230                                  # append to previous line?                                  # append to previous line?
231                                  $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');                                  $log->debug("tag $field / $type [",sub { join(",",@v) }, "] ", $row->{'append'} || 'no append');
232                                  if ($tag->{'append'}) {                                  if ($tag->{'append'}) {
233    
234                                          # I will delimit appended part with                                          # I will delimit appended part with
# Line 241  sub data_structure { Line 255  sub data_structure {
255    
256                          # TODO: name_sigular, name_plural                          # TODO: name_sigular, name_plural
257                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
258                          $row->{'name'} = $name ? $self->_x($name) : $field;                          my $row_name = $name ? $self->_x($name) : $field;
259    
260                          # post-sort all values in field                          # post-sort all values in field
261                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
262                                  $log->warn("sort at field tag not implemented");                                  $log->warn("sort at field tag not implemented");
263                          }                          }
264    
265                          push @ds, $row;                          $ds->{$row_name} = $row;
266    
267                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
268                  }                  }
269    
270          }          }
271    
272          if ($cache_file) {          $self->{'db'}->save_ds(
273                  store {                  id => $id,
274                          ds => \@ds,                  ds => $ds,
275                          current_filename => $self->{'current_filename'},                  prefix => $self->{prefix},
276                          headline => $self->{'headline'},          ) if ($self->{'db'});
                 }, $cache_file;  
                 $log->debug("created storable cache file $cache_file");  
         }  
   
         return @ds;  
   
 }  
   
 =head2 apply_format  
   
 Apply format specified in tag with C<format_name="name"> and  
 C<format_delimiter=";;">.  
   
  my $text = $webpac->apply_format($format_name,$format_delimiter,$data);  
   
 Formats can contain C<lookup{...}> if you need them.  
   
 =cut  
   
 sub apply_format {  
         my $self = shift;  
   
         my ($name,$delimiter,$data) = @_;  
   
         my $log = $self->_get_logger();  
   
         if (! $self->{'import_xml'}->{'format'}->{$name}) {  
                 $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});  
                 return $data;  
         }  
   
         $log->warn("no delimiter for format $name") if (! $delimiter);  
277    
278          my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");          $log->debug("ds: ", sub { Dumper($ds) });
279    
280          my @data = split(/\Q$delimiter\E/, $data);          $log->logconfess("data structure returned is not array any more!") if wantarray;
281    
282          my $out = sprintf($format, @data);          return $ds;
         $log->debug("using format $name [$format] on $data to produce: $out");  
   
         if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {  
                 return $self->lookup($out);  
         } else {  
                 return $out;  
         }  
283    
284  }  }
285    
# Line 316  return output or nothing depending on ev Line 291  return output or nothing depending on ev
291    
292   my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);   my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
293    
294    Filters are implemented here. While simple form of filters looks like this:
295    
296      filter{name_of_filter}
297    
298    but, filters can also have variable number of parametars like this:
299    
300      filter{name_of_filter(param,param,param)}
301    
302  =cut  =cut
303    
304    my $warn_once;
305    
306  sub parse {  sub parse {
307          my $self = shift;          my $self = shift;
308    
# Line 335  sub parse { Line 320  sub parse {
320    
321          my @out;          my @out;
322    
323          $log->debug("format: $format");          $log->debug("format: $format [$i]");
324    
325          my $eval_code;          my $eval_code;
326          # remove eval{...} from beginning          # remove eval{...} from beginning
# Line 345  sub parse { Line 330  sub parse {
330          # remove filter{...} from beginning          # remove filter{...} from beginning
331          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
332    
333            # did we found any (att all) field from format in row?
334            my $found_any;
335            # prefix before first field which we preserve it $found_any
336          my $prefix;          my $prefix;
337          my $all_found=0;  
338            my $f_step = 1;
339    
340          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
341    
342                  my $del = $1 || '';                  my $del = $1 || '';
343                  $prefix ||= $del if ($all_found == 0);                  $prefix = $del if ($f_step == 1);
344    
345                    my $fld_type = lc($2);
346    
347                  # repeatable index                  # repeatable index
348                  my $r = $i;                  my $r = $i;
349                  $r = 0 if (lc("$2") eq 's');                  if ($fld_type eq 's') {
350                            if ($found_any->{'v'}) {
351                                    $r = 0;
352                            } else {
353                                    return;
354                            }
355                    }
356    
357                  my $found = 0;                  my $found = 0;
358                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
359    
360                  if ($found) {                  if ($found) {
361                          push @out, $del;                          $found_any->{$fld_type} += $found;
362    
363                            # we will skip delimiter before first occurence of field!
364                            push @out, $del unless($found_any->{$fld_type} == 1);
365                          push @out, $tmp;                          push @out, $tmp;
                         $all_found += $found;  
366                  }                  }
367                    $f_step++;
368          }          }
369    
370          return if (! $all_found);          # test if any fields found?
371            return if (! $found_any->{'v'} && ! $found_any->{'s'});
372    
373          my $out = join('',@out);          my $out = join('',@out);
374    
# Line 387  sub parse { Line 388  sub parse {
388                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
389          }          }
390                    
391          if ($filter_name && $self->{'filter'}->{$filter_name}) {          if ($filter_name) {
392                  $log->debug("about to filter{$filter_name} format: $out");                  my @filter_args;
393                  $out = $self->{'filter'}->{$filter_name}->($out);                  if ($filter_name =~ s/(\w+)\((.*)\)/$1/) {
394                  return unless(defined($out));                          @filter_args = split(/,/, $2);
395                  $log->debug("filter result: $out");                  }
396                    if ($self->{'filter'}->{$filter_name}) {
397                            $log->debug("about to filter{$filter_name} format: $out with arguments: ", join(",", @filter_args));
398                            unshift @filter_args, $out;
399                            $out = $self->{'filter'}->{$filter_name}->(@filter_args);
400                            return unless(defined($out));
401                            $log->debug("filter result: $out");
402                    } elsif (! $warn_once->{$filter_name}) {
403                            $log->warn("trying to use undefined filter $filter_name");
404                            $warn_once->{$filter_name}++;
405                    }
406          }          }
407    
408          return $out;          return $out;
# Line 427  sub parse_to_arr { Line 438  sub parse_to_arr {
438          return @arr;          return @arr;
439  }  }
440    
441    
442    =head2 fill_in
443    
444    Workhourse of all: takes record from in-memory structure of database and
445    strings with placeholders and returns string or array of with substituted
446    values from record.
447    
448     my $text = $webpac->fill_in($rec,'v250^a');
449    
450    Optional argument is ordinal number for repeatable fields. By default,
451    it's assume to be first repeatable field (fields are perl array, so first
452    element is 0).
453    Following example will read second value from repeatable field.
454    
455     my $text = $webpac->fill_in($rec,'Title: v250^a',1);
456    
457    This function B<does not> perform parsing of format to inteligenty skip
458    delimiters before fields which aren't used.
459    
460    This method will automatically decode UTF-8 string to local code page
461    if needed.
462    
463    =cut
464    
465    sub fill_in {
466            my $self = shift;
467    
468            my $log = $self->_get_logger();
469    
470            my $rec = shift || $log->logconfess("need data record");
471            my $format = shift || $log->logconfess("need format to parse");
472            # iteration (for repeatable fields)
473            my $i = shift || 0;
474    
475            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
476    
477            # FIXME remove for speedup?
478            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
479    
480            if (utf8::is_utf8($format)) {
481                    $format = $self->_x($format);
482            }
483    
484            my $found = 0;
485            my $just_single = 1;
486    
487            my $eval_code;
488            # remove eval{...} from beginning
489            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
490    
491            my $filter_name;
492            # remove filter{...} from beginning
493            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
494    
495            # do actual replacement of placeholders
496            # repeatable fields
497            if ($format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges) {
498                    $just_single = 0;
499            }
500    
501            # non-repeatable fields
502            if ($format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges) {
503                    return if ($i > 0 && $just_single);
504            }
505    
506            if ($found) {
507                    $log->debug("format: $format");
508                    if ($eval_code) {
509                            my $eval = $self->fill_in($rec,$eval_code,$i);
510                            return if (! $self->_eval($eval));
511                    }
512                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
513                            $log->debug("filter '$filter_name' for $format");
514                            $format = $self->{'filter'}->{$filter_name}->($format);
515                            return unless(defined($format));
516                            $log->debug("filter result: $format");
517                    }
518                    # do we have lookups?
519                    if ($self->{'lookup'}) {
520                            if ($self->{'lookup'}->can('lookup')) {
521                                    my @lookup = $self->{lookup}->lookup($format);
522                                    $log->debug("lookup $format", join(", ", @lookup));
523                                    return @lookup;
524                            } else {
525                                    $log->warn("Have lookup object but can't invoke lookup method");
526                            }
527                    } else {
528                            return $format;
529                    }
530            } else {
531                    return;
532            }
533    }
534    
535    
536  =head2 fill_in_to_arr  =head2 fill_in_to_arr
537    
538  Similar to C<fill_in>, but returns array of all repeatable fields. Usable  Similar to C<fill_in>, but returns array of all repeatable fields. Usable
# Line 450  sub fill_in_to_arr { Line 556  sub fill_in_to_arr {
556          my $i = 0;          my $i = 0;
557          my @arr;          my @arr;
558    
559          while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {          while (my $v = $self->fill_in($rec,$format_utf8,$i++)) {
560                  push @arr, @v;                  push @arr, $v;
561          }          }
562    
563          $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);          $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
# Line 459  sub fill_in_to_arr { Line 565  sub fill_in_to_arr {
565          return @arr;          return @arr;
566  }  }
567    
568    
569    =head2 get_data
570    
571    Returns value from record.
572    
573     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
574    
575    Arguments are:
576    record reference C<$rec>,
577    field C<$f>,
578    optional subfiled C<$sf>,
579    index for repeatable values C<$i>.
580    
581    Optinal variable C<$found> will be incremeted if there
582    is field.
583    
584    Returns value or empty string.
585    
586    =cut
587    
588    sub get_data {
589            my $self = shift;
590    
591            my ($rec,$f,$sf,$i,$found) = @_;
592    
593            if ($$rec->{$f}) {
594                    return '' if (! $$rec->{$f}->[$i]);
595                    no strict 'refs';
596                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
597                            $$found++ if (defined($$found));
598                            return $$rec->{$f}->[$i]->{$sf};
599                    } elsif (! $sf && $$rec->{$f}->[$i]) {
600                            $$found++ if (defined($$found));
601                            # it still might have subfield, just
602                            # not specified, so we'll dump all
603                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
604                                    my $out;
605                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
606                                            my $v = $$rec->{$f}->[$i]->{$k};
607                                            $out .= "$v " if ($v);
608                                    }
609                                    return $out;
610                            } else {
611                                    return $$rec->{$f}->[$i];
612                            }
613                    } else {
614                            return '';
615                    }
616            } else {
617                    return '';
618            }
619    }
620    
621    
622    =head2 apply_format
623    
624    Apply format specified in tag with C<format_name="name"> and
625    C<format_delimiter=";;">.
626    
627     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
628    
629    Formats can contain C<lookup{...}> if you need them.
630    
631    =cut
632    
633    sub apply_format {
634            my $self = shift;
635    
636            my ($name,$delimiter,$data) = @_;
637    
638            my $log = $self->_get_logger();
639    
640            if (! $self->{'import_xml'}->{'format'}->{$name}) {
641                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
642                    return $data;
643            }
644    
645            $log->warn("no delimiter for format $name") if (! $delimiter);
646    
647            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
648    
649            my @data = split(/\Q$delimiter\E/, $data);
650    
651            my $out = sprintf($format, @data);
652            $log->debug("using format $name [$format] on $data to produce: $out");
653    
654            if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {
655                    return $self->{'lookup'}->lookup($out);
656            } else {
657                    return $out;
658            }
659    
660    }
661    
662  =head2 sort_arr  =head2 sort_arr
663    
664  Sort array ignoring case and html in data  Sort array ignoring case and html in data
# Line 485  sub sort_arr { Line 685  sub sort_arr {
685  }  }
686    
687    
688    =head1 INTERNAL METHODS
689    
690  =head2 _sort_by_order  =head2 _sort_by_order
691    
692  Sort xml tags data structure accoding to C<order=""> attribute.  Sort xml tags data structure accoding to C<order=""> attribute.
# Line 504  sub _sort_by_order { Line 706  sub _sort_by_order {
706    
707  =head2 _x  =head2 _x
708    
709  Convert strings from C<conf/normalize> encoding into application specific  Convert strings from C<conf/normalize/*.xml> encoding into application
710  (optinally specified using C<code_page> to C<new> constructor.  specific encoding (optinally specified using C<code_page> to C<new>
711    constructor).
712    
713   my $text = $n->_x('normalize text string');   my $text = $n->_x('normalize text string');
714    
# Line 532  under the same terms as Perl itself. Line 735  under the same terms as Perl itself.
735    
736  =cut  =cut
737    
738  1; # End of WebPAC::DB  1; # End of WebPAC::Normalize
Legend:
Removed from v.14  
changed lines
  Added in v.364
  ViewVC Help
Powered by ViewVC 1.1.26