File Coverage

blib/lib/Text/UPF.pm

Criterion	Covered	Total	%
statement	6	62	9.6
branch	0	32	0.0
condition	0	3	0.0
subroutine	2	5	40.0
pod	0	3	0.0
total	8	105	7.6

###################################################
## UPF.pm
## Andrew N. Hicox
##
## Provides auto-population facilities using
##  tags.
###################################################


## Global Stuff ###################################
  package Text::UPF;
  use 5.6.0;
  #use warnings;

  require Exporter;
  require Text::Wrapper;
  use AutoLoader qw(AUTOLOAD);

## Class Global Values ############################
  our @ISA = qw(Exporter);
  our $VERSION = '1.0.5';
  our $errstr = ();
  our @EXPORT_OK = ($VERSION, $errstr);

## new ############################################
 sub new {
     my %p = @_;
     my $obj = bless ({
       #the tagset
        'tagin'		=> "",
        'tagout'	=> "",
       #view to get forms from in GetFormDB
        "Form View"	=> "",
        "Form Name"	=> "",
        "Form Text"	=> "",
       #form name of standard disclaimer
        "Disclaimer"=> "",
       #options to pass to DBIx::YAWM::new
        "DBAccess"	=> {
           #default values for getting forms from db view
            "Server"			=> "",
            "DBType"			=> "",
            "User"				=> "",
            "Pass"				=> "",
            "SID"				=> "",
            "Port"				=> ""
        },
       #wrap lines larger than
        'Columns'	=> "",
       #quote the disclaimer with this
        'DiscQuote'	=> ""
     });
   #delete null parameters from the object
    foreach (keys %{$obj}){
        if (ref ($obj->{$_}) eq "HASH"){
           foreach my $par (keys %{$obj->{$_}}){ if ($obj->{$_}->{$par} =~/^$/){ delete($obj->{$_}->{$par}); } }
        }else{
            if ($obj->{$_} =~/^$/){ delete($obj->{$_}); }
        }
    }
   #overrides and extra directives go here
    if (exists($p{Port})){ $obj->{DBAccess}->{Port} = $p{Port}; delete($p{Port}); }
    foreach (keys %p){ $obj->{$_} = $p{$_}; }
    return ($obj);
 }

## Populate #######################################
 sub Populate {
    #local vars
     my ($self, %p) = @_;
    #local for easier regex syntax
     my ($tagin,$tagout) = ($self->{tagin},$self->{tagout});
    #if there's no Text, look for Form to get from DB, or as last resort
    #try to open File, if it exists
     unless (exists ($p{Text})){
         if (exists ($p{Form})){
             unless ($p{Text} = $self->GetFormDB(Form => $p{Form})){
                 $self->{errstr} = "failed to get form ($p{Form}) from database! $self->{errstr}";
                 return (undef);
             }
         }elsif (exists ($p{File})){
             unless ($p{Text} = $self->GetFormFile(File => $p{File})){
                 $self->{errstr} = "failed to open form file ($p{File}) $self->{errstr}";
                 return (undef);
             }
         }else{
             $self->{errstr} = "Text, Form, or File is a required option for Text::UPF::Populate";
             return (undef);
         }
     }
    #while there are 's left to read
     while ($p{Text} =~/($tagin)(.+?)($tagout)/i){
         my ($tag_in,$method,$tag_out) = ($1,$2,$3);
         my $whole_tag = quotemeta("$tag_in$method$tag_out");
         my ($directive,$replace) = ();
         if (exists ($p{Data}->{$method})){
            #if we have the data, just replace it
             $p{Text} =~s/$whole_tag/$p{Data}->{$method}/ig;
             next;
         }elsif ($method =~/(.+)\{(.+)\}/i){
            #look for directive in the method
             ($method,$directive) = ($1,$2);
             my $str = '$replace = $self->$method(directive => $directive, %p)';
             eval ($str);
             if ($@ =~/^can't locate object method/i){
                 $replace = "[Unsuported Population Method: $method]";
             }
             $p{Text} =~s/$whole_tag/$replace/ig;
         }else{
            #maybe we need to call a subroutine?
             my $str = '$replace = $self->$method(%p)';
             eval ($str);
             if ($@ =~/^can't locate object method/i){
                 $replace = "[Undefined Population Method: $method]";
             }
             $p{Text} =~s/$whole_tag/$replace/ig;
         }
     }
    #wrap the lines
     unless (exists($self->{wrapper})){
         $self->{wrapper} = Text::Wrapper->new(columns => $self->{'Columns'});
     }
     unless ($p{NoWrap}){ $p{Text} = $self->{wrapper}->wrap($p{Text}); }
    #duff man says ... oh yeaaaah!
     return ($p{Text});
 }

## Destroy ########################################
 #clean up db connection (if it belongs to us), destroy object
 sub Destroy {
     my ($self) = shift();
     if (($self->{myDB}) && ($self->{DBTool})){ $self->{DBTool}->Destroy(); }
     $self = undef;
 }

## True for perl include ##########################
 1;
__END__