File Coverage

blib/lib/Text/Printf.pm

Criterion	Covered	Total	%
statement	188	215	87.4
branch	86	100	86.0
condition	16	22	72.7
subroutine	24	27	88.8
pod	8	11	72.7
total	322	375	85.8

=for gpg
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1

=head1 NAME

Text::Printf - A simple, lightweight text fill-in class.

=head1 VERSION

This documentation describes version 1.03 of Text::Printf, June 9, 2008.

=cut

package Text::Printf;

use strict;
use warnings;
use Readonly;

$Text::Printf::VERSION = '1.03';
use vars '$DONTSET';
Readonly::Scalar $DONTSET => [];    # Unique identifier

# Always export the $DONTSET variable
# Always export the *printf subroutines
sub import
{
    my ($pkg) = caller;
    no strict 'refs';
    *{$pkg.'::DONTSET'}  = \$DONTSET;
    *{$pkg.'::tprintf'}  = \&tprintf;
    *{$pkg.'::tsprintf'} = \&tsprintf;
}

# Declare exception classes
use Exception::Class
(
    'Text::Printf::X' =>
        { description => 'Generic Text::Printf exception',
        },
    'Text::Printf::X::ParameterError' =>
        { isa         => 'Text::Printf::X',
          description => 'Error in parameters to Text::Printf method',
        },
    'Text::Printf::X::OptionError' =>
        { isa         => 'Text::Printf::X',
          fields      => 'name',
          description => 'A bad option was passed to a Text::Printf method',
        },
    'Text::Printf::X::KeyNotFound' =>
        { isa         => 'Text::Printf::X',
          fields      => 'symbols',
          description => 'Could not resolve one or more symbols in template text',
        },
    'Text::Printf::X::NoText' =>
        { isa         => 'Text::Printf::X',
          description => 'No text to expand',
        },
    'Text::Printf::X::InternalError' =>
        { isa         => 'Text::Printf::X',
          fields      => 'additional_info',
          description => 'Internal Text::Printf error.  Please contact the author.'
        },
);

# Early versions of Exception::Class didn't define this useful subroutine
if (!defined &Exception::Class::Base::caught)
{
    # Class method to help caller catch exceptions
    no warnings qw(once redefine);
    *Exception::Class::Base::caught = sub
    {
        my $class = shift;
        return Exception::Class->caught($class);
    }
}

# Croak-like location of error
sub Text::Printf::X::location
{
    my ($pkg,$file,$line);
    my $caller_level = 0;
    while (1)
    {
        ($pkg,$file,$line) = caller($caller_level++);
        last if $pkg !~ /\A Text::Printf/x  &&  $pkg !~ /\A Exception::Class/x
    }
    return "at $file line $line";
}

# Die-like location of error
sub Text::Printf::X::InternalError::location
{
    my $self = shift;
    return "at " . $self->file() . " line " . $self->line()
}

# Override full_message, to report location of error in caller's code.
sub Text::Printf::X::full_message
{
    my $self = shift;

    my $msg = $self->message;
    return $msg  if substr($msg,-1,1) eq "\n";

    $msg =~ s/[ \t]+\z//;   # remove any trailing spaces (is this necessary?)
    return $msg . q{ } . $self->location() . qq{\n};
}

# Comma formatting.  From the Perl Cookbook.
sub commify ($)
{
    my $rev_num = reverse shift;  # The number to be formatted, reversed.
    $rev_num =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
    return scalar reverse $rev_num;
}


## Constructor
# $object = Text::Printf->new($boilerplate, $options);
sub new
{
    my $class = shift;
    my $self  = \do { my $anonymous_scalar };
    bless $self, $class;
    $self->_initialize(@_);
    return $self;
}


{ # encapsulation enclosure

    # Attributes
    my %boilerplate_for;
    my %delimiters_for;
    my %regex_for;
    my %value_hashes_for;
    my %defaults_for;
    my %bad_keys_of;

    ## Initializer
    # $obj->_initialize($boilerplate, $options);
    sub _initialize
    {
        my $self = shift;

        # Check whether any attribute has a value from another, earlier object.
        # This should never happen, if DESTROY is working, and nobody calls
        # _initialize on an already-initialized object.
        {
            my   @occupied;
            push @occupied, '%boilerplate_for'   if exists $boilerplate_for {$self};
            push @occupied, '%delimiters_for'    if exists $delimiters_for  {$self};
            push @occupied, '%regex_for'         if exists $regex_for       {$self};
            push @occupied, '%value_hashes_for'  if exists $value_hashes_for{$self};
            push @occupied, '%defaults_for'      if exists $defaults_for    {$self};
            push @occupied, '%bad_keys_of'       if exists $bad_keys_of     {$self};

            Text::Printf::X::InternalError->throw(
                message         => 'Internal programing error: contact author.',
                additional_info => join(', ', @occupied))
                if @occupied;
        }

        # Check number and type of parameters
        # Legal possibilities:  (), ($scalar), ($hashref), ($scalar, $hashref);
        my $whoami = ref($self) . " constructor";

        my $boilerplate;
        my $options_ref;

        if (@_ == 1)
        {
            my $arg = shift;
            Text::Printf::X::ParameterError->throw('Text may not be set to an undefined value')
                if !defined $arg;

            my $ref = ref $arg;
            if ($ref eq '')
            {
                $boilerplate = $arg;
            }
            elsif ($ref eq 'HASH')
            {
                $options_ref = $arg;
            }
            else
            {
                $ref = _decode_ref($arg);
                Text::Printf::X::ParameterError->throw(
                    "Solo argument to $whoami should be scalar or hashref, not $ref");
            }
        }
        elsif (@_ == 2)
        {
            my $arg = shift;
            Text::Printf::X::ParameterError->throw('Text may not be set to an undefined value')
                if !defined $arg;

            my $ref = ref $arg;
            if ($ref eq '')
            {
                $boilerplate = $arg;
            }
            else
            {
                $ref = _decode_ref($arg);
                Text::Printf::X::ParameterError->throw(
                    "First argument to $whoami should be a scalar, not $ref");
            }

            $arg = shift;
            $ref = ref($arg);
            if ($ref ne 'HASH')
            {
                $ref = _decode_ref($arg);
                Text::Printf::X::ParameterError->throw(
                    "Second argument to $whoami must be hash ref, not $ref");
            }
            $options_ref = $arg;
        }
        elsif (@_ > 2)
        {
            Text::Printf::X::ParameterError->throw("Too many parameters to $whoami");
        }


        $boilerplate_for{$self} = $boilerplate;
        if (exists $options_ref->{delimiters})
        {
            my $delim = $options_ref->{delimiters};

            Text::Printf::X::OptionError->throw(
                message => "Bad option to $whoami\n"
                           . "delimiter value must be array reference",
                name => 'delimiter')
                unless ref($delim) eq 'ARRAY';

            Text::Printf::X::OptionError->throw(
                message => "Bad option to $whoami\n"
                           . "delimiter arrayref must have exactly two values",
                name => 'delimiter')
                unless @$delim == 2;

            my ($ref0, $ref1) = (ref ($delim->[0]), ref ($delim->[1]));
            Text::Printf::X::OptionError->throw(
                message => "Bad option to $whoami\n"
                           . "delimiter values must be strings or regexes",
                name => 'delimiter')
                unless ($ref0 eq q{}  ||  $ref0 eq 'Regexp')
                    && ($ref1 eq q{}  ||  $ref1 eq 'Regexp');

            $delimiters_for{$self} = [ $ref0? $delim->[0] : quotemeta($delim->[0]),
                                       $ref0? $delim->[1] : quotemeta($delim->[1]) ];
        }
        else
        {
            $delimiters_for{$self} = [ quotemeta('{{'), quotemeta('}}') ];
        }

        # $1 is the keyword plus its delimiters; $2 is the keyword by itself.
        # $3 is the printf format, if any; $4 is the extended format.
        $regex_for{$self} =
            qr/(                                         # $1: capture whole expression
                 $delimiters_for{$self}[0]               # Opening delimiter
                 (\w+)                                   # $2: keyword
                 (?:  :                                  # Maybe a colon and...
                      %? ( (?: \+ (?=[^+]{2}) )? [-<>]?  \+?
                                 [\d.]* [A-Za-z]{1,2} )  #   $3: ...a printf format
                      (?:   :                            #   and maybe another colon
                            ([,\$]+) )?                  #   $4: and extended format chars
                 )?
                 $delimiters_for{$self}[1]               # Closing delimiter
              )/xsm;

        return;
    }

    sub DESTROY
    {
        my $self = shift;

        # Free up the hash entries we're using.
        delete $boilerplate_for {$self};
        delete $delimiters_for  {$self};
        delete $regex_for       {$self};
        delete $value_hashes_for{$self};
        delete $defaults_for    {$self};
        delete $bad_keys_of     {$self};
    }

    # Stack up hash values for later substitution
    sub pre_fill
    {
        my $self = shift;

        # Validate the parameters
        foreach my $arg (@_)
        {
            Text::Printf::X::ParameterError->throw("Argument to pre_fill() is not a hashref")
                if ref $arg ne 'HASH';
        }
        push @{ $value_hashes_for{$self} }, @_;
        return;
    }

    # Stack up hash values for later substitution
    sub default
    {
        my $self = shift;

        # Validate the parameters
        foreach my $arg (@_)
        {
            Text::Printf::X::ParameterError->throw("Argument to default() is not a hashref")
                if ref $arg ne 'HASH';
        }
        push @{ $defaults_for{$self} }, @_;
        return;
    }

    # Clear any pre-stored hashes
    sub clear_values
    {
        my $self = shift;
        $value_hashes_for{$self} = [];
        $defaults_for    {$self} = [];
        return;
    }

    # Set or change the boilerplate (template) text
    sub text
    {
        my $self = shift;

        # No arguments?  Return the text.
        return $boilerplate_for{$self}
              unless @_;

        my $text = shift;
        Text::Printf::X::ParameterError->throw('Too many parameters to text()')
              if @_;
        Text::Printf::X::ParameterError->throw('Text may not be set to an undefined value')
              if !defined $text;

        $boilerplate_for{$self} = $text;
        return;
    }

    # Do the replacements.
    sub fill
    {
        my $self = shift;
        my @fill_hashes = @_;

        # Validate the parameters
        foreach my $arg (@fill_hashes)
        {
            Text::Printf::X::ParameterError->throw('Argument to fill() is not a hashref')
                if ref $arg ne 'HASH';
        }

        my @hashes;
        push @hashes, @{ $value_hashes_for{$self}}  if exists $value_hashes_for{$self};
        push @hashes, @fill_hashes;
        push @hashes, @{ $defaults_for    {$self}}  if exists $defaults_for    {$self};

        # Fetch other attributes
        my $str = $boilerplate_for{$self};
        defined $str or Text::Printf::X::NoText->throw('Template text was never set');
        my $rex = $regex_for{$self};

        # Do the subsitution
        $bad_keys_of{$self} = [];
        $str =~ s/$rex/$self->_substitution_of(\@hashes, $1, $2, $3, $4)/ge;

        # Any unfulfilled substitutions?
        my $bk = $bad_keys_of{$self};    # shortcut for the next few lines
        if (@$bk > 0)
        {
            my $s = @$bk == 1? q{} : 's';
            my $bad_str = join ', ', @$bk;
            $bad_keys_of{$self} = [];   # reset in case exception is caught.
            Text::Printf::X::KeyNotFound->throw(
                message => "Could not resolve the following symbol$s: $bad_str",
                symbols => $bk);
        }

        return $str;
    }

    # Helper function for regular expression in fill(), above.
    sub _substitution_of
    {
        my $self = shift;
        my ($values_aref, $whole_expr, $keyword, $format, $extend) = @_;

        Value_Hash: foreach my $hashref (@$values_aref)
        {
            next unless exists $hashref->{$keyword};

            my $value = $hashref->{$keyword};

            # Special DONTSET value: leave the whole expression intact
            return $whole_expr
                if ref($value) eq 'ARRAY'  &&  $value eq $DONTSET;

            $value = q{}  if !defined $value;
            return $value if !defined $format;

            $format =~ tr/<>/-/d;
            $value = sprintf "%$format", $value;

            # Special extended formatting
            if (defined $extend)
            {
                # Currently, ',' and '$' are defined
                my $v_len = length $value;
                $value = commify $value     if index ($extend, ',') >= 0;
                $value =~ s/([^ ])/\$$1/    if index ($extend, '$') >= 0;
                my $length_diff = length($value) - $v_len;
                $value =~ s/^ {0,$length_diff}//;
                $length_diff = length($value) - $v_len;
                $value =~ s/ {0,$length_diff}$//;
            }

            return $value;
        }

        # Never found a match?  Pity.
        # Store the bad keyword, and leave it intact in the string.
        push @{ $bad_keys_of{$self} }, $keyword;
        return $whole_expr;
    }

    # Debugging routine -- dumps a string representation of the object
    sub _dump
    {
        my $self = shift;
        my $out = q{};

        $out .= qq{Boilerplate: "$boilerplate_for{$self}"\n};
        $out .= qq{Delimiters: [ "$delimiters_for{$self}[0]", "$delimiters_for{$self}[1]" ]\n};
        $out .= qq{Regex: $regex_for{$self}\n};
        $out .= qq{Value hashes: [\n};
        my $i = 0;
        my $vals = $value_hashes_for{$self} || [];
        for my $h (@$vals)
        {
            $out .= "    $i {\n";
            foreach my $k (sort keys %$h)
            {
                $out .= "        qq{$k} => qq{$h->{$k}}\n";
            }
            $out .= "       },\n";
            ++$i;
        }
        $out .= "]\n";

        my $bad_keys = $bad_keys_of{$self} || [];
        $out .= qq{Bad keys: [} . join(", ", @$bad_keys) . "]\n";;
        return $out;
    }

} # end encapsulation enclosure



# printf-like convenience functions

sub tprintf
{
    # First arg a filehandle?
    my $fh;
    if (ref $_[0] eq 'GLOB'  ||  UNIVERSAL::can($_[0], 'print'))
    {
        $fh = shift;
        Text::Printf::X::ParameterError->throw
            ("tprintf() requires at least one non-handle argument")
            if @_ < 1;
    }

    my $string = t_printf_guts('tprintf', @_);

    if ($fh)
    {
        if (UNIVERSAL::can($fh, 'print'))
        {
            $fh->print($string);
        }
        else
        {
            print {$fh} $string;
        }
    }
    else
    {
        print $string;
    }
}

sub tsprintf
{
    return t_printf_guts('tsprintf', @_);
}

sub tfprintf
{
    Text::Printf::X::ParameterError->throw
        ("tfprintf() requires at least two arguments")
        if @_ < 2;

    my $fh = shift;
    print {$fh} t_printf_guts('tfprintf', @_);
}

sub t_printf_guts
{
    my $which = shift;
    Text::Printf::X::ParameterError->throw
        ("$which() requires at least one argument")
        if @_ == 0;

    my $format = shift;
    my @value_hashes = @_;

    # Validate the parameters
    foreach my $arg (@value_hashes)
    {
        Text::Printf::X::ParameterError->throw
            ("Argument to $which() is not a hashref")
            if ref $arg ne 'HASH';
    }

    my $template = Text::Printf->new ($format);
    return $template->fill(@value_hashes);
}

sub _decode_ref
{
    my $ref = ref $_[0];
    return $ref eq '' ? 'scalar'
         : $ref . ' ref';
}

1;
__END__