[webpac2] / lib / WebPAC / Common.pm

package WebPAC::Common;

use warnings;
use strict;

use Log::Log4perl qw(get_logger :levels);

=head1 NAME

WebPAC::Common - internal methods called from other WebPAC modules

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

#my $LOOKUP_REGEX = '\[[^\[\]]+\]';
#my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';
my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';
my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';

=head1 SYNOPSYS

This module defines common functions, and is used as base for other, more
specific modules.

 my $webpac = new WebPAC::Common(
        filter => {
                'filter_name_1' => sub {
                        # filter code
                        return length($_);
                }, ...
        },
  }

=head1 FUNCTIONS

=head2 fill_in

Workhourse of all: takes record from in-memory structure of database and
strings with placeholders and returns string or array of with substituted
values from record.

 my $text = $webpac->fill_in($rec,'v250^a');

Optional argument is ordinal number for repeatable fields. By default,
it's assume to be first repeatable field (fields are perl array, so first
element is 0).
Following example will read second value from repeatable field.

 my $text = $webpac->fill_in($rec,'Title: v250^a',1);

This function B<does not> perform parsing of format to inteligenty skip
delimiters before fields which aren't used.

This method will automatically decode UTF-8 string to local code page
if needed.

=cut

sub fill_in {
        my $self = shift;

        my $log = $self->_get_logger();

        my $rec = shift || $log->logconfess("need data record");
        my $format = shift || $log->logconfess("need format to parse");
        # iteration (for repeatable fields)
        my $i = shift || 0;

        $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));

        # FIXME remove for speedup?
        $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);

        if (utf8::is_utf8($format)) {
                $format = $self->_x($format);
        }

        my $found = 0;

        my $eval_code;
        # remove eval{...} from beginning
        $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);

        my $filter_name;
        # remove filter{...} from beginning
        $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);

        # do actual replacement of placeholders
        # repeatable fields
        $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
        # non-repeatable fields
        $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;

        if ($found) {
                $log->debug("format: $format");
                if ($eval_code) {
                        my $eval = $self->fill_in($rec,$eval_code,$i);
                        return if (! $self->_eval($eval));
                }
                if ($filter_name && $self->{'filter'}->{$filter_name}) {
                        $log->debug("filter '$filter_name' for $format");
                        $format = $self->{'filter'}->{$filter_name}->($format);
                        return unless(defined($format));
                        $log->debug("filter result: $format");
                }
                # do we have lookups?
                if ($format =~ /$LOOKUP_REGEX/o) {
                        $log->debug("format '$format' has lookup");
                        return $self->lookup($format);
                } else {
                        return $format;
                }
        } else {
                return;
        }
}


=head2 get_data

Returns value from record.

 my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);

Arguments are:
record reference C<$rec>,
field C<$f>,
optional subfiled C<$sf>,
index for repeatable values C<$i>.

Optinal variable C<$found> will be incremeted if there
is field.

Returns value or empty string.

=cut

sub get_data {
        my $self = shift;

        my ($rec,$f,$sf,$i,$found) = @_;

        if ($$rec->{$f}) {
                return '' if (! $$rec->{$f}->[$i]);
                no strict 'refs';
                if ($sf && $$rec->{$f}->[$i]->{$sf}) {
                        $$found++ if (defined($$found));
                        return $$rec->{$f}->[$i]->{$sf};
                } elsif ($$rec->{$f}->[$i]) {
                        $$found++ if (defined($$found));
                        # it still might have subfield, just
                        # not specified, so we'll dump all
                        if ($$rec->{$f}->[$i] =~ /HASH/o) {
                                my $out;
                                foreach my $k (keys %{$$rec->{$f}->[$i]}) {
                                        $out .= $$rec->{$f}->[$i]->{$k}." ";
                                }
                                return $out;
                        } else {
                                return $$rec->{$f}->[$i];
                        }
                }
        } else {
                return '';
        }
}


=head1 INTERNAL METHODS

Here is a quick list of internal methods, mostly useful to turn debugging
on them (see L<LOGGING> below for explanation).

=cut

=head2 _eval

Internal function to eval code without C<strict 'subs'>.

=cut

sub _eval {
        my $self = shift;

        my $code = shift || return;

        my $log = $self->_get_logger();

        no strict 'subs';
        my $ret = eval $code;
        if ($@) {
                $log->error("problem with eval code [$code]: $@");
        }

        $log->debug("eval: ",$code," [",$ret,"]");

        return $ret || undef;
}

=head2 _sort_by_order

Sort xml tags data structure accoding to C<order=""> attribute.

=cut

sub _sort_by_order {
        my $self = shift;

        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;
}

=head2 _x

Convert string from UTF-8 to code page defined in C<import_xml>.

 my $text = $webpac->_x('utf8 text');

Default application code page is C<ISO-8859-2>. You will probably want to
change that when creating new instance of object based on this one.

=cut

sub _x {
        my $self = shift;
        my $utf8 = shift || return;

        # create UTF-8 convertor for import_xml files
        $self->{'utf2cp'} ||= Text::Iconv->new('UTF-8' ,$self->{'code_page'} || 'ISO-8859-2');

        return $self->{'utf2cp'}->convert($utf8) ||
                $self->_get_logger()->logwarn("can't convert '$utf8'");
}

=head2 _init_logger

This function will init C<Log::Log4perl> using provided configuration file.

  $webpac->_init_logger('/path/to/log.conf');

If no path to configuration file is given, dummy empty configuration
will be create.

=cut

sub _init_logger {
        my $self = shift;
        my $file = shift;
        if ($file) {
                Log::Log4perl->init($file);
        } else {
                my $conf = q( );
                Log::Log4perl->init( \$conf );
        }
}


=head2 _get_logger

Get C<Log::Log4perl> object with a twist: domains are defined for each
method

 my $log = $webpac->_get_logger();

=cut

sub _get_logger {
        my $self = shift;

        $self->{'_logger_ok'} ||= $self->_init_logger;

        my $name = (caller(1))[3] || caller;
        return get_logger($name);
}


=head1 LOGGING

Logging in WebPAC is performed by L<Log::Log4perl> with config file
C<log.conf>.

Methods defined above have different levels of logging, so
it's descriptions will be useful to turn (mostry B<debug> logging) on
or off to see why WabPAC isn't perforing as you expect it (it might even
be a bug!).

B<This is different from normal Log4perl behaviour>. To repeat, you can
also use method names, and not only classes (which are just few)
to filter logging.