File Coverage

blib/lib/Device/TLSPrinter.pm

Criterion	Covered	Total	%
statement	45	176	25.5
branch	6	74	8.1
condition	0	17	0.0
subroutine	11	32	34.3
pod	11	15	73.3
total	73	314	23.2

package Device::TLSPrinter;
use strict;
use Carp;
use Class::Accessor;
use Exporter ();

{
    no strict "vars";
    $VERSION = '0.51';
    @ISA = qw< Exporter Class::Accessor >;

    %EXPORT_TAGS = (
        feedback => [qw<
            FC_OK  FC_SERIAL_TIMEOUT_ERROR  FC_COMMAND_ERROR
            FC_MEMORY_FULL_ERROR  FC_IMAGE_ALREADY_EXISTS
            FC_IMMEDIATE_COMMANDS_ENABLED  FC_OUT_OF_LABELS  FC_PRINTHEAD_OPEN
            FC_OUT_OF_RIBBON  FC_BATTERY_CELL_SHORTED  FC_LOW_BATTERY
            FC_PRINTING_COMPLETE  FC_PRINTING_COMPLETE  FC_NO_LABEL_FORMAT_ERROR
            FC_MEMORY_READ_ERROR  FC_MEDIA_CHANGED  FC_PRINTHEAD_TOO_HOT
            FC_LABEL_ERROR  FC_FIELD_ERROR  FC_FEED_TO_CUT_COMPLETE

            FC_UNDEF FC_IMMEDIATE_COMMANDS_DISABLED  FC_NOT_IN_LABEL_EDIT_MODE

            ROTATION_NONE  ROTATION_90  ROTATION_180  ROTATION_270

            TYPE_FONT  TYPE_BARCODE_39  TYPE_BARCODE_39_WITH_CHECK
            TYPE_BARCODE_128  TYPE_IMAGE
        >],
        ascii => [qw<
            SOH  STX  CR
        >],
    );

    $EXPORT_TAGS{all} = [ @{$EXPORT_TAGS{feedback}}, @{$EXPORT_TAGS{ascii}} ];
    @EXPORT = ( @{$EXPORT_TAGS{feedback}} );
    @EXPORT_OK = ( @{$EXPORT_TAGS{ascii}} );
}


# ASCII constants
use constant {
    SOH    => "\x01",
    STX    => "\x02",
    CR     => "\x0D",
    CRLF   => "\x0D\x0A",
    LF     => "\x0A",
};

use constant {
    # standard feedback chars
    FC_OK                           => "0",
    FC_SERIAL_TIMEOUT_ERROR         => "1",
    FC_COMMAND_ERROR                => "2",
    FC_MEMORY_FULL_ERROR            => "3",
    FC_IMAGE_ALREADY_EXISTS         => "4",
    FC_IMMEDIATE_COMMANDS_ENABLED   => "5",
    FC_OUT_OF_LABELS                => "6",
    FC_PRINTHEAD_OPEN               => "7",
    FC_OUT_OF_RIBBON                => "8",
    FC_BATTERY_CELL_SHORTED         => "A",
    FC_LOW_BATTERY                  => "B",
    FC_PRINTING_COMPLETE            => "C",
    FC_NO_LABEL_FORMAT_ERROR        => "D",
    FC_MEMORY_READ_ERROR            => "E",
    FC_MEDIA_CHANGED                => "F",
    FC_PRINTHEAD_TOO_HOT            => "G",
    FC_LABEL_ERROR                  => "H",
    FC_FIELD_ERROR                  => "I",
    FC_FEED_TO_CUT_COMPLETE         => "J",

    # custom feedback chars
    FC_UNDEF                        => "~",
    FC_IMMEDIATE_COMMANDS_DISABLED  => ";",
    FC_NOT_IN_LABEL_EDIT_MODE       => ":",

    # rotations
    ROTATION_NONE                   => 1,
    ROTATION_90                     => 2,
    ROTATION_180                    => 3,
    ROTATION_270                    => 4,

    # field types
    TYPE_FONT                       => "9",
    TYPE_BARCODE_39                 => "a",
    TYPE_BARCODE_39_WITH_CHECK      => "b",
    TYPE_BARCODE_128                => "c",
    TYPE_IMAGE                      => "Y",
};

# object fields and default values
my %object_fields = (
    # internal parameters
    _device         => undef,   # device string
    _socket         => undef,   # IO::Socket::INET object
    _serial         => undef,   # {Device,Win32}::SerialPort object
    _timeout        => 10,      # timeout

    # public attributes
    feedback_chars  => 0,   # are feedback characters enabled?
    immediate_cmds  => 0,   # are immediate commands enabled?
    label_edition   => 0,   # currently in label editing mode?
);

# create accessors
__PACKAGE__->mk_accessors(keys %object_fields);

# private variables
my $HEX = "[0-9A-Fa-f]";
my $HEXNUM = $HEX x 2;


#
# new()
# ---
sub new {
    my ($class, %args)  = @_;

    # if missing, try to infer the type from the device param
    if (not $args{type}) {
        if (eval { $args{device}->isa("Device::SerialPort") } ) {
            $args{type} = "serial"
        }
        elsif (eval { $args{device}->isa("Win32::SerialPort") } ) {
            $args{type} = "serial"
        }
        elsif ($args{device} =~ m{^COM\d|^/dev/(?:term|tty)}) {
            $args{type} = "serial"
        }
        elsif ($args{device} =~ m{^[a-zA-Z0-9.-]+:[0-9]+$}) {
            $args{type} = "network"
        }
    }

    # enable debug mode?
    {   local $SIG{__WARN__} = sub {};
        *DEBUG = $args{debug} ? \&_DEBUG : sub {};
    }

    # check arguments
    carp "warning: You should specify the connection type" unless exists $args{type};
    croak "error: Missing required parameter: device" unless exists $args{device};

    # create the object and populate the attributes
    my %fields = (
        %object_fields,     # default values
        _type    => $args{type},
        _device  => $args{device},
        _timeout => $args{timeout},
    );
    my $self = __PACKAGE__->SUPER::new(\%fields);

    # initialize the backend driver
    my ($driver) = $args{type} =~ /^(\w+)$/;
    $class = __PACKAGE__."::".ucfirst($driver);
    eval "require $class"
        or croak "error: Could not load driver $class: no such module";
    bless $self, $class;    # rebless the object into the class of the driver
    $self->init();

    return $self
}


#
# _DEBUG()
# ------
sub _DEBUG {
    print STDERR @_, $/
}


#
# exec_command()
# ------------
sub exec_command {
    my ($self, %args) = @_;
    my ($rc, $answer, $n) = (FC_UNDEF, "", 0);

    carp "error: Missing required parameter: cmd" and return unless $args{cmd};

    # send the data
    $n = $self->write(data => $args{cmd});

    # read the answer if any is expected
    if ($args{expect}) {
        my ($left_to_read, $read, $chunk);
        $left_to_read = $args{expect};

        while ($left_to_read > 0) {
            ($read, $chunk) = $self->read(expect => $left_to_read);
            $answer .= $chunk;
            $left_to_read -= $read;
        }
    }

    # read the feedback character if enabled
    if ($args{feedback} and $self->feedback_chars) {
        ($n, $rc) = $self->read(expect => 1);
        DEBUG(" >>> exec_command(): feedback='$rc' (", ord($rc), ")");
    }

    return ($rc, $answer)
}


# ========================================================================
# Immediate commands
#

my %ic_cmds = (
    ic_printer_reset    => { string => "#",  expect => 25 },
    ic_printer_status   => {
        string => "A",  expect =>  9,  filter => \&ic_filter_printer_status
    },
    ic_toggle_pause     => { string => "B",  expect =>  0 },
    ic_cancel_job       => { string => "C",  expect =>  0 },
    ic_batch_quantity   => { string => "E",  expect =>  5 },
);

for my $cmd (keys %ic_cmds) {
    no strict 'refs';
    *$cmd = sub {
        my ($self) = @_;
        my ($rc, $raw, @data) = (FC_UNDEF);
        DEBUG(" >>> $cmd()");

        if ($self->immediate_cmds) {
            ($rc, $raw) = $self->exec_command(
                cmd      => SOH.$ic_cmds{$cmd}{string},
                expect   => $ic_cmds{$cmd}{expect},
                feedback => 0,
            );
            $rc = FC_OK;

            # pass the raw result to the filter if it's defined
            if (defined $raw and ref $ic_cmds{$cmd}{filter} eq "CODE") {
                @data = $ic_cmds{$cmd}{filter}->($raw)
            }
        }
        else {
            $rc = FC_IMMEDIATE_COMMANDS_DISABLED
        }

        return wantarray ? ($rc, $raw, @data) : $rc
    }
}


#
# ic_disable_immediate_cmds()
# -------------------------
sub ic_disable_immediate_cmds {
    my ($self) = @_;
    $self->exec_command(cmd => SOH."D");
    $self->immediate_cmds(0);
}


#
# ic_filter_printer_status()
# ------------------------
sub ic_filter_printer_status {
    my ($raw) = @_;

    # decode the status
    my @chars = split //, $raw;
    my %status = (
        printhead_open   => $chars[0] eq "Y" ? 1 : 0,
        out_of_labels    => $chars[1] eq "Y" ? 1 : 0,
        out_of_ribbon    => $chars[2] eq "Y" ? 1 : 0,
        printing_batch   => $chars[3] eq "Y" ? 1 : 0,
        busy_printing    => $chars[4] eq "Y" ? 1 : 0,
        printer_paused   => $chars[5] eq "Y" ? 1 : 0,
        touch_cell_error => $chars[6] eq "Y" ? 1 : 0,
        low_battery      => $chars[7] eq "Y" ? 1 : 0,
    );

    return %status
}


# ========================================================================
# System commands
#

my %sc_cmds = (
    sc_heat_setting_offset          => { string => "b%+02.2d" },
    sc_disable_feed_to_cut_position => { string => "C" },
    sc_enable_feed_to_cut_position  => { string => "c" },
    sc_quantity_for_stored_labels   => { string => "E%04d" },
    sc_form_feed                    => { string => "F" },
    sc_set_form_stop_position       => { string => "f%+02.2d" },
    sc_print_last_label_format      => { string => "G" },
    sc_set_printer_to_metric        => { string => "m" },
    sc_set_printer_to_inches        => { string => "n" },
    sc_set_start_of_print_offset    => { string => "O+02.2d" },
    sc_set_horizontal_align_offset  => { string => "o+02.2d" },
    sc_set_continuous_label_length  => { string => "P%04d" },
    sc_clear_all_memory             => { string => "Q" },
    sc_set_continuous_label_spacing => { string => "S%04d" },
    sc_print_test_label             => { string => "T" },
    sc_get_touch_cell_data_binary   => {
        string => "t",  expect => 32
    },
    sc_replace_label_format_field   => { string => "U%02d%s".CR },
    sc_get_touch_cell_data_ascii    => {
        string => "V",    expect => 32*2,  filter => \&sc_filter_touch_cell_data_ascii
    },
    sc_firmware_version             => {
        string => "v",    expect => 25,    filter => \&sc_filter_chomp
    },
    sc_memory_information           => {
        string => "W%s",  expect => 255,   filter => \&sc_filter_memory_info
    },
    sc_delete_file                  => { string => "x%s%s" },
    sc_pack_memory                  => { string => "z" },
);

for my $cmd (keys %sc_cmds) {
    no strict 'refs';
    *$cmd = sub {
        my ($self, @args) = @_;
        my @data;
        DEBUG(" >>> $cmd(@args)");

        # execute the command
        my ($rc, $raw) = $self->exec_command(
            cmd      => sprintf(STX.$sc_cmds{$cmd}{string}, @args),
            expect   => $sc_cmds{$cmd}{expect},
            feedback => 1,
        );

        # pass the raw result to the filter if it's defined
        if (defined $raw and ref $sc_cmds{$cmd}{filter} eq "CODE") {
            @data = $sc_cmds{$cmd}{filter}->($raw)
        }

        return wantarray ? ($rc, $raw, @data) : $rc
    }
}


#
# sc_filter_chomp()
# ---------------
sub sc_filter_chomp {
    my ($raw) = @_;
    $raw =~ s/[\012\015]$//g;
    return $raw
}


#
# sc_filter_memory_info()
# ---------------------
sub sc_filter_memory_info {
    my ($raw) = @_;
    $raw =~ s/\b($HEX+)\s$/hex($1)/e;
    return split CR, $raw
}


#
# sc_filter_touch_cell_data_ascii()
# -------------------------------
sub sc_filter_touch_cell_data_ascii {
    my ($raw) = @_;

    my @values = map {hex} $raw =~ m{
        ^ $HEXNUM ($HEXNUM $HEXNUM) $HEXNUM $HEXNUM     # label quantity
        ($HEXNUM) ($HEXNUM $HEXNUM) ($HEXNUM $HEXNUM)   # bits field, offset X and Y
        ($HEXNUM $HEXNUM) ($HEXNUM $HEXNUM)             # width, length
    }x;

    my %fields = (
        remaining_labels => $values[0],
        notched_material => $values[1] & 1,
        offset_x         => $values[2],
        offset_y         => $values[3],
        label_width      => $values[4],
        label_length     => $values[5],
    );

    return %fields
}


#
# sc_disable_feedback_chars()
# -------------------------
## @method string sc_disable_feedback_chars($self)
# @return feedback code
#
sub sc_disable_feedback_chars {
    my ($self) = @_;
    DEBUG(" >>> sc_disable_feedback_chars()");
    $self->exec_command(cmd => STX."A", feedback => 0);
    $self->feedback_chars(0);
}


#
# sc_enable_feedback_chars()
# ------------------------
## @method string sc_enable_feedback_chars($self)
# @return feedback code
#
sub sc_enable_feedback_chars {
    my ($self) = @_;
    DEBUG(" >>> sc_enable_feedback_chars()");
    $self->exec_command(cmd => STX."a", feedback => 0);
    $self->feedback_chars(1);
}


#
# sc_enable_immediate_cmds()
# ------------------------
## @method string sc_enable_immediate_cmds($self)
# @return feedback code
#
*ic_enable_immediate_cmds = \&sc_enable_immediate_cmds;
sub sc_enable_immediate_cmds {
    my ($self) = @_;
    DEBUG(" >>> sc_enable_immediate_cmds()");
    my ($rc) = $self->exec_command(cmd => STX."H", feedback => 1);
    $self->immediate_cmds(1) if $rc eq FC_IMMEDIATE_COMMANDS_ENABLED;
    return $rc
}


#
# sc_input_image_data()
# -------------------
## @method string sc_input_image_data($self, $data_type, $format, $image_name, @image_data)
# @param data_type string
# @param format string, image format designation
# @param image_name string, image name, up to 8 characters long
# @param image_data array or image data
# @return feedback code
#
sub sc_input_image_data {
    my ($self, $data_type, $format, $image_name, @image_data) = @_;
    DEBUG(" >>> sc_input_image_data($data_type, $format, $image_name)");

    # check arguments
    carp "error: Invalid value for data type: '$data_type'"
        and return if $data_type !~ /^[AB]$/;
    carp "error: Invalid value for format designation: '$format'"
        and return if $format !~ /^[BbPpU]$/;

    # first disable immediate commands if they were enabled
    my $ic_enabled = $self->immediate_cmds;
    $self->ic_disable_immediate_cmds if $ic_enabled;

    # then send the actual image command
    my $cmd  = sprintf STX."I%s%s%s".CR, $data_type, $format, $image_name;
    my $data = join '', @image_data;
    my ($rc) = $self->exec_command(cmd => $cmd.$data, feedback => 1);

    # finaly restore immediate commands
    $self->sc_enable_immediate_cmds if $ic_enabled;

    return $rc
}


#
# sc_extended_system_cmds()
# -----------------------
## @method string sc_extended_system_cmds($self)
# @return feedback code
#
sub sc_extended_system_cmds {
    my ($self) = @_;
    DEBUG(" >>> sc_extended_system_cmds()");
    $self->exec_command(cmd => STX."K", feedback => 0);
}


#
# sc_enter_label_formatting_cmd()
# -----------------------------
## @method string sc_enter_label_formatting_cmd($self)
# @return feedback code
#
sub sc_enter_label_formatting_cmd {
    my ($self) = @_;
    DEBUG(" >>> sc_enter_label_formatting_cmd()");

    my ($rc) = $self->exec_command(cmd => STX."L", feedback => 1);
    $self->label_edition(1);

    return $rc
}


# ========================================================================
# Label formatting commands
#

my %lc_cmds = (
    lc_set_format_attribute             => { string => "A%d".CR },
    lc_set_column_offset                => { string => "C%04d".CR },
    lc_end_label_formatting_and_print   => { string => "E".CR,  end_mode => 1 },
    lc_set_row_offset                   => { string => "C%04d".CR },
    lc_end_label_formatting             => { string => "X".CR,  end_mode => 1 },
    lc_increment_prev_numeric_field     => { string => "+%s%02d".CR },
    lc_decrement_prev_numeric_field     => { string => "-%s%02d".CR },
    lc_increment_prev_alphanum_field    => { string => ">%s%02d".CR },
    lc_decrement_prev_alphanum_field    => { string => "<%s%02d".CR },
    lc_set_count_by_amount              => { string => "^%02d".CR },
    lc_add_field                        => { string => "%d%s00%03d%04d%04d".CR },
);

for my $cmd (keys %lc_cmds) {
    no strict 'refs';
    *$cmd = sub {
        my ($self, @args) = @_;
        DEBUG(" >>> $cmd(@args)");

        # check that we're in label formatting mode
        return FC_NOT_IN_LABEL_EDIT_MODE
            unless $self->label_edition;

        # execute the command
        my ($rc) = $self->exec_command(
            cmd      => sprintf($lc_cmds{$cmd}{string}, @args),
            expect   => $lc_cmds{$cmd}{expect},
            feedback => 1,
        );

        # end edition mode if needed
        if ($lc_cmds{$cmd}{end_mode}) {
            $self->label_edition(0)
        }

        return $rc
    }
}


# ========================================================================
# High-level commands
#


#
# hc_flush_input()
# --------------
## @method string hc_flush_input($self)
# @return feedback code
#
sub hc_flush_input {
    my ($self) = @_;
    my ($n, $data) = (1, "");

    # read everything in the input buffer
    while ($n) {
        local $SIG{ALRM} = sub { $n = 0; die "read timeout\n" };
        alarm 2;
        ($n, $data) = eval { $self->read(expect => 20) };
        alarm 0;
        $n ||= 0;
    }

    return FC_OK
}


#
# hc_upload_label()
# ---------------
## @method string hc_upload_label($self, %params)
# @param lines arrayref of lines describing the label
# @param print_now boolean
# @return feedback code
#
sub hc_upload_label {
    my ($self, %args) = @_;
    DEBUG(" >>> hc_upload_label()");
    my $rc;
    croak "error: Missing required parameter: lines" unless exists $args{lines};
    croak "error: Invalid value for parameter 'lines'" unless ref $args{lines} eq "ARRAY";

    # prepare the data to be sent
    my @lines = @{ $args{lines} };
    chomp @lines;

    # send the label data
    $self->sc_enter_label_formatting_cmd;

    for my $line (@lines) {
        ($rc) = $self->exec_command(cmd => $line.CR, feedback => 1);
        last if $rc ne FC_OK;
    }

    # in case of error, stop and return the last feedback char
    if ($rc ne FC_OK) {
        $self->lc_end_label_formatting;
        return $rc
    }

    # end the label edition mode
    if ($args{print_now}) {
        ($rc) = $self->lc_end_label_formatting_and_print
    }
    else {
        ($rc) = $self->lc_end_label_formatting
    }

    return $rc
}


1;

__END__