File Coverage

blib/lib/Printer/Label/Template/Processor.pm

Criterion	Covered	Total	%
statement	57	78	73.0
branch	7	30	23.3
condition	1	3	33.3
subroutine	13	18	72.2
pod	2	2	100.0
total	80	131	61.0

package Printer::Label::Template::Processor;
use strict;
use warnings;

use Carp;
use File::Slurp;
use Net::FTP;
use Net::Printer;
use Template;
use Params::Validate qw/validate SCALAR UNDEF OBJECT HASHREF ARRAYREF CODEREF/;

our $VERSION = '1.01';

#-------------------------------------------------------------------------------
# Constants
#-------------------------------------------------------------------------------

# lookup table used to link file extensions and _build_output_from_* methods
my $H_TEMPLATES = {
    pl   => 'perl',
    perl => 'perl',
    tt   => 'tkit',
    tt2  => 'tkit',
};

#-------------------------------------------------------------------------------
# Public methods
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# new
# Creates a label object
#-------------------------------------------------------------------------------

sub new {
    my $class = shift;
    my %params = @_;
    my $print_mode = defined($params{print_mode}) ? uc($params{print_mode}) : 'CON';

    # params validation
    %params = validate(@_, {
        script_file => {
            type => SCALAR,
        },
        print_mode  => {
            type    => SCALAR,
            default => 'CON',
        },
        check_syntax => {
            type => CODEREF,
            default => sub { return (1==1) },
        },
        server => {
            type     => SCALAR,
            optional => (grep(/$print_mode/, qw/FTP LPR/) ? 0 : 1),
        },
        port => {
            type     => SCALAR,
            optional => 1,      # Net::FTP and Net::Printer define their own default values
            depends  => [ 'server' ],
        },
        user => {
            type     => SCALAR,
            optional => 1,      # Net::FTP defines its own default value
            depends  => [ 'server', 'password' ],
        },
        password => {
            type     => SCALAR,
            optional => 1,      # Net::FTP defines its own default value
            depends  => [ 'server', 'user' ],
        },
        output_file => {
            type     => SCALAR,
            optional => ($print_mode ne 'FILE'),
        },
    });

    my $self = bless {}, $class;
    $self->{$_} = $params{$_} foreach (keys %params);

    return $self;
}

#-------------------------------------------------------------------------------
# printout
# Builds the output data and sends it to a printing system
#-------------------------------------------------------------------------------

sub printout {
    my $self = shift;

    # params validation
    my %params = validate(@_, {
        vars => { type => HASHREF },
    });

    $self->{$_} = $params{$_} foreach (keys %params);

    # builds the output data
    $self->_set_output_data;

    # checks the syntax
    $self->{check_syntax}->($self->{output_data}) or croak "Invalid output syntax while processing $self->{script_file}";

    # builds the print method name and calls it
    my $method = '_print_to_' . lc($self->{print_mode});
    $self->can("$method") or croak "Unknown print method: $method";
    $self->$method;
}

#-------------------------------------------------------------------------------
# Private methods
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# _set_output_data
# Builds the output data of the label
#-------------------------------------------------------------------------------

sub _set_output_data {
    my $self = shift;

    # detects the script's language
    my $script_language = $self->{script_file};
    $script_language =~ s/^.*\.([^\.]*$)/lc($1)/e;
    $H_TEMPLATES->{$script_language} or croak "Unknown script language: $script_language";

    # invokes the corresponding method
    my $method = '_build_output_from_' . $H_TEMPLATES->{$script_language};
    $self->can("$method") or croak "Unknown print method: $method";
    $self->$method;
}

#-------------------------------------------------------------------------------
# _build_output_from_perl
# Builds output data by processing a Perl script
#-------------------------------------------------------------------------------

sub _build_output_from_perl {
    my $self = shift;

    # loads the script
    my $script = read_file($self->{script_file}) ;
    $script or croak "Error while loading the file: $self->{script_file}";

    # evaluates the script
    my $output_data = eval("$script");

    # links the output data to the label
    $self->{output_data} = $output_data;
}

#-------------------------------------------------------------------------------
# _build_output_from_tkit
# Builds output data by processing a Template Toolkit script
#-------------------------------------------------------------------------------

sub _build_output_from_tkit {
    my $self = shift;

    # extracts the script's filename
    my $script_file = (split(/[\\\/]/, $self->{script_file}))[-1];

    # extracts the path to the script file
    my $script_path = $self->{script_file};
    $script_path =~ s/\/$script_file//g;

    # creates a TT2 object
    my $tt = Template->new({
        INCLUDE_PATH => $script_path,
        INTERPOLATE  => 1,
    }) || croak "$Template::ERROR";

    # evaluates the script
    my $output_data;
    $tt->process($script_file, $self->{vars}, \$output_data) || croak $tt->error();

    # links the output data to the label
    $self->{output_data} = $output_data;
}

#-------------------------------------------------------------------------------
# _print_to_con
# Sends the content to the standard output
#-------------------------------------------------------------------------------

sub _print_to_con {
    my $self = shift;

    # prints the output data to standard output
    print "$self->{output_data}\n";
}

#-------------------------------------------------------------------------------
# _print_to_ftp
# Sends the content to a FTP server
#-------------------------------------------------------------------------------

sub _print_to_ftp {
    my $self = shift;

    # connects to the FTP server
    my $session = Net::FTP->new(
        $self->{server},
        Passive => 0,
        Debug => 0,
    ) or croak "Error while connecting to $self->{server}\n";
    $session->login(
        $self->{user},
        $self->{password},
    ) or croak "Invalid user/password\n";
    $session->ascii;

    # sends the in-memory file to the FTP server
    open my $output_file, "<", \$self->{output_data} or croak $!;
    $session->put($output_file, "OUTPUT.TXT") or croak "Error while sending the file\n";
    $session->quit;
    close $output_file;
}

#-------------------------------------------------------------------------------
# _print_to_lpr
# Sends the content to a print queue
#-------------------------------------------------------------------------------

sub _print_to_lpr {
    my $self = shift;

    # creates a print queue
    my $printer = new Net::Printer(
        server => $self->{server},
    );
    $printer->{port} = $self->{port} if defined($self->{port});

    # sends the output data to the print queue
    my $res = $printer->printstring($self->{output_data});
    $res or croak "Error while printing on $self->{server} port $self->{port} using LPR: " . $printer->printerror() . "\n";
}

#-------------------------------------------------------------------------------
# _print_to_file
# Writes the content to a file
#-------------------------------------------------------------------------------

sub _print_to_file {
    my $self = shift;

    # dumps the output data to a file
    write_file($self->{output_file}, \$self->{output_data}) or croak "Error while sending the file\n";
}


1;

__END__