/[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 340 by dpavlin, Mon Jan 2 10:58:26 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  
   
 Check if specified cache directory exist, and if not, disable caching.  
111    
112   $setup_cache_dir('./cache/ds/');          my $log = $self->_get_logger();
113    
114  If you pass false or zero value to this function, it will disable          # those two must be in pair
115  cacheing.          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  =cut          $log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));
121    
122  sub setup_cache_dir {          $log->warn("no prefix defined. please check that!") unless ($self->{'prefix'});
         my $self = shift;  
123    
124          my $dir = shift;          $log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);
125    
126          my $log = $self->_get_logger();          if (! $self->{filter} || ! $self->{filter}->{regex}) {
127                    $log->debug("adding built-in filter regex");
128          if ($dir) {                  $self->{filter}->{regex} = sub {
129                  my $msg;                          my ($val, $regex) = @_;
130                  if (! -e $dir) {                          eval "\$val =~ $regex";
131                          $msg = "doesn't exist";                          return $val;
132                  } elsif (! -d $dir) {                  };
                         $msg = "is not directory";  
                 } 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->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');
195                            $format = $tag->{'value'} || $tag->{'content'};
196    
197                          $log->debug("format: $format");                          $log->debug("format: $format");
198    
# Line 193  sub data_structure { Line 213  sub data_structure {
213                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
214                          }                          }
215    
                         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!  
                         }  
   
216                          # delimiter will join repeatable fields                          # delimiter will join repeatable fields
217                          if ($tag->{'delimiter'}) {                          if ($tag->{'delimiter'}) {
218                                  @v = ( join($tag->{'delimiter'}, @v) );                                  @v = ( join($tag->{'delimiter'}, @v) );
219                          }                          }
220    
221                          # default types                          # default types
222                          my @types = qw(display swish);                          my @types = qw(display search);
223                          # override by type attribute                          # override by type attribute
224                          @types = ( $tag->{'type'} ) if ($tag->{'type'});                          @types = ( $tag->{'type'} ) if ($tag->{'type'});
225    
226                          foreach my $type (@types) {                          foreach my $type (@types) {
227                                  # append to previous line?                                  # append to previous line?
228                                  $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');                                  $log->debug("type: $type ",sub { join(" ",@v) }, " ", $row->{'append'} || 'no append');
229                                  if ($tag->{'append'}) {                                  if ($tag->{'append'}) {
230    
231                                          # I will delimit appended part with                                          # I will delimit appended part with
# Line 241  sub data_structure { Line 252  sub data_structure {
252    
253                          # TODO: name_sigular, name_plural                          # TODO: name_sigular, name_plural
254                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
255                          $row->{'name'} = $name ? $self->_x($name) : $field;                          my $row_name = $name ? $self->_x($name) : $field;
256    
257                          # post-sort all values in field                          # post-sort all values in field
258                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
259                                  $log->warn("sort at field tag not implemented");                                  $log->warn("sort at field tag not implemented");
260                          }                          }
261    
262                          push @ds, $row;                          $ds->{$row_name} = $row;
263    
264                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
265                  }                  }
266    
267          }          }
268    
269          if ($cache_file) {          $self->{'db'}->save_ds(
270                  store {                  id => $id,
271                          ds => \@ds,                  ds => $ds,
272                          current_filename => $self->{'current_filename'},                  prefix => $self->{prefix},
273                          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;  
         }  
274    
275          $log->warn("no delimiter for format $name") if (! $delimiter);          $log->debug("ds: ", sub { Dumper($ds) });
276    
277          my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");          $log->logconfess("data structure returned is not array any more!") if wantarray;
278    
279          my @data = split(/\Q$delimiter\E/, $data);          return $ds;
   
         my $out = sprintf($format, @data);  
         $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;  
         }  
280    
281  }  }
282    
# Line 316  return output or nothing depending on ev Line 288  return output or nothing depending on ev
288    
289   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);
290    
291    Filters are implemented here. While simple form of filters looks like this:
292    
293      filter{name_of_filter}
294    
295    but, filters can also have variable number of parametars like this:
296    
297      filter{name_of_filter(param,param,param)}
298    
299  =cut  =cut
300    
301    my $warn_once;
302    
303  sub parse {  sub parse {
304          my $self = shift;          my $self = shift;
305    
# Line 335  sub parse { Line 317  sub parse {
317    
318          my @out;          my @out;
319    
320          $log->debug("format: $format");          $log->debug("format: $format [$i]");
321    
322          my $eval_code;          my $eval_code;
323          # remove eval{...} from beginning          # remove eval{...} from beginning
# Line 345  sub parse { Line 327  sub parse {
327          # remove filter{...} from beginning          # remove filter{...} from beginning
328          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
329    
330            # did we found any (att all) field from format in row?
331            my $found_any;
332            # prefix before first field which we preserve it $found_any
333          my $prefix;          my $prefix;
334          my $all_found=0;  
335            my $f_step = 1;
336    
337          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
338    
339                  my $del = $1 || '';                  my $del = $1 || '';
340                  $prefix ||= $del if ($all_found == 0);                  $prefix = $del if ($f_step == 1);
341    
342                    my $fld_type = lc($2);
343    
344                  # repeatable index                  # repeatable index
345                  my $r = $i;                  my $r = $i;
346                  $r = 0 if (lc("$2") eq 's');                  if ($fld_type eq 's') {
347                            if ($found_any->{'v'}) {
348                                    $r = 0;
349                            } else {
350                                    return;
351                            }
352                    }
353    
354                  my $found = 0;                  my $found = 0;
355                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
356    
357                  if ($found) {                  if ($found) {
358                          push @out, $del;                          $found_any->{$fld_type} += $found;
359    
360                            # we will skip delimiter before first occurence of field!
361                            push @out, $del unless($found_any == 1);
362                          push @out, $tmp;                          push @out, $tmp;
                         $all_found += $found;  
363                  }                  }
364                    $f_step++;
365          }          }
366    
367          return if (! $all_found);          # test if any fields found?
368            return if (! $found_any->{'v'} && ! $found_any->{'s'});
369    
370          my $out = join('',@out);          my $out = join('',@out);
371    
# Line 387  sub parse { Line 385  sub parse {
385                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
386          }          }
387                    
388          if ($filter_name && $self->{'filter'}->{$filter_name}) {          if ($filter_name) {
389                  $log->debug("about to filter{$filter_name} format: $out");                  my @filter_args;
390                  $out = $self->{'filter'}->{$filter_name}->($out);                  if ($filter_name =~ s/(\w+)\((.*)\)/$1/) {
391                  return unless(defined($out));                          @filter_args = split(/,/, $2);
392                  $log->debug("filter result: $out");                  }
393                    if ($self->{'filter'}->{$filter_name}) {
394                            $log->debug("about to filter{$filter_name} format: $out with arguments: ", join(",", @filter_args));
395                            unshift @filter_args, $out;
396                            $out = $self->{'filter'}->{$filter_name}->(@filter_args);
397                            return unless(defined($out));
398                            $log->debug("filter result: $out");
399                    } elsif (! $warn_once->{$filter_name}) {
400                            $log->warn("trying to use undefined filter $filter_name");
401                            $warn_once->{$filter_name}++;
402                    }
403          }          }
404    
405          return $out;          return $out;
# Line 427  sub parse_to_arr { Line 435  sub parse_to_arr {
435          return @arr;          return @arr;
436  }  }
437    
438    
439    =head2 fill_in
440    
441    Workhourse of all: takes record from in-memory structure of database and
442    strings with placeholders and returns string or array of with substituted
443    values from record.
444    
445     my $text = $webpac->fill_in($rec,'v250^a');
446    
447    Optional argument is ordinal number for repeatable fields. By default,
448    it's assume to be first repeatable field (fields are perl array, so first
449    element is 0).
450    Following example will read second value from repeatable field.
451    
452     my $text = $webpac->fill_in($rec,'Title: v250^a',1);
453    
454    This function B<does not> perform parsing of format to inteligenty skip
455    delimiters before fields which aren't used.
456    
457    This method will automatically decode UTF-8 string to local code page
458    if needed.
459    
460    =cut
461    
462    sub fill_in {
463            my $self = shift;
464    
465            my $log = $self->_get_logger();
466    
467            my $rec = shift || $log->logconfess("need data record");
468            my $format = shift || $log->logconfess("need format to parse");
469            # iteration (for repeatable fields)
470            my $i = shift || 0;
471    
472            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
473    
474            # FIXME remove for speedup?
475            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
476    
477            if (utf8::is_utf8($format)) {
478                    $format = $self->_x($format);
479            }
480    
481            my $found = 0;
482            my $just_single = 1;
483    
484            my $eval_code;
485            # remove eval{...} from beginning
486            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
487    
488            my $filter_name;
489            # remove filter{...} from beginning
490            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
491    
492            # do actual replacement of placeholders
493            # repeatable fields
494            if ($format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges) {
495                    $just_single = 0;
496            }
497            
498            # non-repeatable fields
499            if ($format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges) {
500                    return if ($i > 0 && $just_single);
501            }
502    
503            if ($found) {
504                    $log->debug("format: $format");
505                    if ($eval_code) {
506                            my $eval = $self->fill_in($rec,$eval_code,$i);
507                            return if (! $self->_eval($eval));
508                    }
509                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
510                            $log->debug("filter '$filter_name' for $format");
511                            $format = $self->{'filter'}->{$filter_name}->($format);
512                            return unless(defined($format));
513                            $log->debug("filter result: $format");
514                    }
515                    # do we have lookups?
516                    if ($self->{'lookup'}) {
517                            if ($self->{'lookup'}->can('lookup')) {
518                                    my @lookup = $self->{lookup}->lookup($format);
519                                    $log->debug("lookup $format", join(", ", @lookup));
520                                    return @lookup;
521                            } else {
522                                    $log->warn("Have lookup object but can't invoke lookup method");
523                            }
524                    } else {
525                            return $format;
526                    }
527            } else {
528                    return;
529            }
530    }
531    
532    
533  =head2 fill_in_to_arr  =head2 fill_in_to_arr
534    
535  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 459  sub fill_in_to_arr { Line 562  sub fill_in_to_arr {
562          return @arr;          return @arr;
563  }  }
564    
565    
566    =head2 get_data
567    
568    Returns value from record.
569    
570     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
571    
572    Arguments are:
573    record reference C<$rec>,
574    field C<$f>,
575    optional subfiled C<$sf>,
576    index for repeatable values C<$i>.
577    
578    Optinal variable C<$found> will be incremeted if there
579    is field.
580    
581    Returns value or empty string.
582    
583    =cut
584    
585    sub get_data {
586            my $self = shift;
587    
588            my ($rec,$f,$sf,$i,$found) = @_;
589    
590            if ($$rec->{$f}) {
591                    return '' if (! $$rec->{$f}->[$i]);
592                    no strict 'refs';
593                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
594                            $$found++ if (defined($$found));
595                            return $$rec->{$f}->[$i]->{$sf};
596                    } elsif (! $sf && $$rec->{$f}->[$i]) {
597                            $$found++ if (defined($$found));
598                            # it still might have subfield, just
599                            # not specified, so we'll dump all
600                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
601                                    my $out;
602                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
603                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
604                                    }
605                                    return $out;
606                            } else {
607                                    return $$rec->{$f}->[$i];
608                            }
609                    } else {
610                            return '';
611                    }
612            } else {
613                    return '';
614            }
615    }
616    
617    
618    =head2 apply_format
619    
620    Apply format specified in tag with C<format_name="name"> and
621    C<format_delimiter=";;">.
622    
623     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
624    
625    Formats can contain C<lookup{...}> if you need them.
626    
627    =cut
628    
629    sub apply_format {
630            my $self = shift;
631    
632            my ($name,$delimiter,$data) = @_;
633    
634            my $log = $self->_get_logger();
635    
636            if (! $self->{'import_xml'}->{'format'}->{$name}) {
637                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
638                    return $data;
639            }
640    
641            $log->warn("no delimiter for format $name") if (! $delimiter);
642    
643            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
644    
645            my @data = split(/\Q$delimiter\E/, $data);
646    
647            my $out = sprintf($format, @data);
648            $log->debug("using format $name [$format] on $data to produce: $out");
649    
650            if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {
651                    return $self->{'lookup'}->lookup($out);
652            } else {
653                    return $out;
654            }
655    
656    }
657    
658  =head2 sort_arr  =head2 sort_arr
659    
660  Sort array ignoring case and html in data  Sort array ignoring case and html in data
# Line 485  sub sort_arr { Line 681  sub sort_arr {
681  }  }
682    
683    
684    =head1 INTERNAL METHODS
685    
686  =head2 _sort_by_order  =head2 _sort_by_order
687    
688  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 702  sub _sort_by_order {
702    
703  =head2 _x  =head2 _x
704    
705  Convert strings from C<conf/normalize> encoding into application specific  Convert strings from C<conf/normalize/*.xml> encoding into application
706  (optinally specified using C<code_page> to C<new> constructor.  specific encoding (optinally specified using C<code_page> to C<new>
707    constructor).
708    
709   my $text = $n->_x('normalize text string');   my $text = $n->_x('normalize text string');
710    
# Line 532  under the same terms as Perl itself. Line 731  under the same terms as Perl itself.
731    
732  =cut  =cut
733    
734  1; # End of WebPAC::DB  1; # End of WebPAC::Normalize

Legend:
Removed from v.14  
changed lines
  Added in v.340

  ViewVC Help
Powered by ViewVC 1.1.26