=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.01 of Text::Printf, March 28, 2008. =cut package Text::Printf; use strict; use warnings; use Readonly; $Text::Printf::VERSION = '1.01'; 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::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 my $whoami = ref($self) . " constructor"; Text::Printf::X::ParameterError->throw("Second argument to $whoami must be hash reference") if @_ == 2 && ref($_[1]) ne 'HASH'; Text::Printf::X::ParameterError->throw("Too many parameters to $whoami") if @_ > 2; Text::Printf::X::ParameterError->throw("Missing boilerplate text parameter to $whoami") if @_ == 0; my $boilerplate = shift; my $options_ref = shift || {}; $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; } # 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}; 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); } 1; __END__ =head1 SYNOPSIS C-like usage: # Print (to default filehandle, or explicit filehandle). tprintf ($format, \%values); tprintf ($filehandle, $format, \%values) # Render to string. $result = tsprintf ($format, \%values); Prepared-template usage: # Create a template: $template = Text::Printf->new($format, \%options); # Set default values: $template->default(\%values); # Set some override values: $template->pre_fill(\%values); # Fill it in, rendering the result string: $result = $template->fill(\%values); =head1 OPTIONS delimiters => [ '{{', '}}' ]; # may be strings delimiters => [ qr/\{\{/, qr/\}\}/ ]; # and/or regexps =head1 DESCRIPTION There are many templating modules on CPAN. They're all far, far more powerful than Text::Printf. When you need that power, they're wonderful. But when you don't, they're overkill. This module provides a very simple, lightweight, quick and easy templating mechanism for when you don't need those other powerful-but-cumbersome modules. There are two ways to use this module: an immediate (printf-like) way, and a delayed (prepared) way. For the immediate way, you simply call L or L with a boilerplate string and the values to be inserted/formatted. See the following section for information on how to format the boilerplate string. This is somewhat easier than using plain C or C, since the name of the value to be inserted is at the same place as its format. For the prepared way, you create a template object that contains the boilerplate text. Again, see the next section for information on how to format it properly. Then, when it is necessary to render the final text (with placeholders filled in), you use the L method, passing it one or more references of hashes of values to be substituted into the original boilerplate text. The special value C<$DONTSET> indicates that the keyword (and its delimiters) are to remain in the boilerplate text, unsubstituted. That's it. No control flow, no executable content, no filesystem access. Never had it, never will. =head1 TEMPLATE FORMAT When you create a template object, or when you use one of the printf-like functions, you must supply a I