File Coverage

blib/lib/String/Formatter.pm

Criterion	Covered	Total	%
statement	138	147	93.8
branch	22	36	61.1
condition	15	24	62.5
subroutine	27	28	96.4
pod	11	13	84.6
total	213	248	85.8

use v5.8.0;
use strict;
use warnings;
package String::Formatter 1.234;
# ABSTRACT: build sprintf-like functions of your own

#pod =head1 SYNOPSIS
#pod
#pod   use String::Formatter stringf => {
#pod     -as   => 'str_rf',
#pod     codes => {
#pod       f => sub { $_ },
#pod       b => sub { scalar reverse $_ },
#pod       o => 'Okay?',
#pod     },
#pod   };
#pod
#pod   print str_rf('This is %10f and this is %-15b, %o', 'forward', 'backward');
#pod
#pod ...prints...
#pod
#pod   This is    forward and this is drawkcab       , okay?
#pod
#pod =head1 DESCRIPTION
#pod
#pod String::Formatter is a tool for building sprintf-like formatting routines.
#pod It supports named or positional formatting, custom conversions, fixed string
#pod interpolation, and simple width-matching out of the box.  It is easy to alter
#pod its behavior to write new kinds of format string expanders.  For most cases, it
#pod should be easy to build all sorts of formatters out of the options built into
#pod String::Formatter.
#pod
#pod Normally, String::Formatter will be used to import a sprintf-like routine
#pod referred to as "C", but which can be given any name you like.  This
#pod routine acts like sprintf in that it takes a string and some inputs and returns
#pod a new string:
#pod
#pod   my $output = stringf "Some %a format %s for you to %u.\n", { ... };
#pod
#pod This routine is actually a wrapper around a String::Formatter object created by
#pod importing stringf.  In the following code, the entire hashref after "stringf"
#pod is passed to String::Formatter's constructor (the C method), save for the
#pod C<-as> key and any other keys that start with a dash.
#pod
#pod   use String::Formatter
#pod     stringf => {
#pod       -as => 'fmt_time',
#pod       codes           => { ... },
#pod       format_hunker   => ...,
#pod       input_processor => ...,
#pod     },
#pod     stringf => {
#pod       -as => 'fmt_date',
#pod       codes           => { ... },
#pod       string_replacer => ...,
#pod       hunk_formatter  => ...,
#pod     },
#pod   ;
#pod
#pod As you can see, this will generate two stringf routines, with different
#pod behaviors, which are installed with different names.  Since the behavior of
#pod these routines is based on the C method of a String::Formatter object,
#pod the rest of the documentation will describe the way the object behaves.
#pod
#pod There's also a C export, which behaves just like the C
#pod export, but defaults to the C and C
#pod arguments.  There's a C export, which defaults
#pod C and C.  Finally, a C,
#pod which defaults to C and C.  For more
#pod on these, keep reading, and check out the cookbook.
#pod
#pod L provides a number of recipes for ways to put
#pod String::Formatter to use.
#pod
#pod =head1 FORMAT STRINGS
#pod
#pod Format strings are generally assumed to look like Perl's sprintf's format
#pod strings:
#pod
#pod   There's a bunch of normal strings and then %s format %1.4c with %% signs.
#pod
#pod The exact semantics of the format codes are not totally settled yet -- and they
#pod can be replaced on a per-formatter basis.  Right now, they're mostly a subset
#pod of Perl's astonishingly large and complex system.  That subset looks like this:
#pod
#pod   %    - a percent sign to begin the format
#pod   ...  - (optional) various modifiers to the format like "-5" or "#" or "2$"
#pod   {..} - (optional) a string inside braces
#pod   s    - a short string (usually one character) identifying the conversion
#pod
#pod Not all format modifiers found in Perl's C are yet supported.
#pod Currently the only format modifiers must match:
#pod
#pod     (-)?          # left-align, rather than right
#pod     (\d*)?        # (optional) minimum field width
#pod     (?:\.(\d*))?  # (optional) maximum field width
#pod
#pod Some additional format semantics may be added, but probably nothing exotic.
#pod Even things like C<2$> and C<*> are probably not going to appear in
#pod String::Formatter's default behavior.
#pod
#pod Another subtle difference, introduced intentionally, is in the handling of
#pod C<%%>.  With the default String::Formatter behavior, string C<%%> is not
#pod interpreted as a formatting code.  This is different from the behavior of
#pod Perl's C, which interprets it as a special formatting character that
#pod doesn't consume input and always acts like the fixed string C<%>.  The upshot
#pod of this is:
#pod
#pod   sprintf "%%";   # ==> returns "%"
#pod   stringf "%%";   # ==> returns "%%"
#pod
#pod   sprintf "%10%"; # ==> returns "         %"
#pod   stringf "%10%"; # ==> dies: unknown format code %
#pod
#pod =cut

use Params::Util ();
use Sub::Exporter -setup => {
  exports => {
    stringf => sub {
      my ($class, $name, $arg, $col) = @_;
      my $formatter = $class->new($arg);
      return sub { $formatter->format(@_) };
    },
    method_stringf => sub {
      my ($class, $name, $arg, $col) = @_;
      my $formatter = $class->new({
        input_processor => 'require_single_input',
        string_replacer => 'method_replace',
        %$arg,
      });
      return sub { $formatter->format(@_) };
    },
    named_stringf => sub {
      my ($class, $name, $arg, $col) = @_;
      my $formatter = $class->new({
        input_processor => 'require_named_input',
        string_replacer => 'named_replace',
        %$arg,
      });
      return sub { $formatter->format(@_) };
    },
    indexed_stringf => sub {
      my ($class, $name, $arg, $col) = @_;
      my $formatter = $class->new({
        input_processor => 'require_arrayref_input',
        string_replacer => 'indexed_replace',
        %$arg,
      });
      return sub { $formatter->format(@_) };
    },
  },
};

my %METHODS;
BEGIN {
  %METHODS = (
    format_hunker   => 'hunk_simply',
    input_processor => 'return_input',
    string_replacer => 'positional_replace',
    hunk_formatter  => 'format_simply',
  );

  no strict 'refs';
  for my $method (keys %METHODS) {
    *$method = sub { $_[0]->{ $method } };

    my $default = "default_$method";
    *$default = sub { $METHODS{ $method } };
  }
}

#pod =method new
#pod
#pod   my $formatter = String::Formatter->new({
#pod     codes => { ... },
#pod     format_hunker   => ...,
#pod     input_processor => ...,
#pod     string_replacer => ...,
#pod     hunk_formatter  => ...,
#pod   });
#pod
#pod This returns a new formatter.  The C argument contains the formatting
#pod codes for the formatter in the form:
#pod
#pod   codes => {
#pod     s => 'fixed string',
#pod     S => 'different string',
#pod     c => sub { ... },
#pod   }
#pod
#pod Code values (or "conversions") should either be strings or coderefs.  This
#pod hashref can be accessed later with the C method.
#pod
#pod The other four arguments change how the formatting occurs.  Formatting happens
#pod in five phases:
#pod
#pod =for :list
#pod 1. format_hunker - format string is broken down into fixed and %-code hunks
#pod 2. input_processor - the other inputs are validated and processed
#pod 3. string_replacer - replacement strings are generated by using conversions
#pod 4. hunk_formatter - replacement strings in hunks are formatted
#pod 5. all hunks, now strings, are recombined; this phase is just C
#pod
#pod The defaults are found by calling C for each helper that
#pod isn't given.  Values must be either strings (which are interpreted as method
#pod names) or coderefs.  The semantics for each method are described in the
#pod methods' sections, below.
#pod
#pod =cut

sub default_codes {
  return {};
}

sub new {
  my ($class, $arg) = @_;

  my $_codes = {
    %{ $class->default_codes },
    %{ $arg->{codes} || {} },
  };

  my $self = bless { codes => $_codes } => $class;

  for (keys %METHODS) {
    $self->{ $_ } = $arg->{ $_ } || do {
      my $default_method = "default_$_";
      $class->$default_method;
    };

    $self->{$_} = $self->can($self->{$_}) unless ref $self->{$_};
  }

  my $codes = $self->codes;

  return $self;
}

sub codes { $_[0]->{codes} }

#pod =method format
#pod
#pod   my $result = $formatter->format( $format_string, @input );
#pod
#pod   print $formatter->format("My %h is full of %e.\n", 'hovercraft', 'eels');
#pod
#pod This does the actual formatting, calling the methods described above, under
#pod C> and returning the result.
#pod
#pod =cut

sub format {
  my $self   = shift;
  my $format = shift;

  Carp::croak("not enough arguments for stringf-based format")
    unless defined $format;

  my $hunker = $self->format_hunker;
  my $hunks  = $self->$hunker($format);

  my $processor = $self->input_processor;
  my $input = $self->$processor([ @_ ]);

  my $replacer = $self->string_replacer;
  $self->$replacer($hunks, $input);

  my $formatter = $self->hunk_formatter;
  ref($_) and $_ = $self->$formatter($_) for @$hunks;

  my $string = join q{}, @$hunks;

  return $string;
}

#pod =method format_hunker
#pod
#pod Format hunkers are passed strings and return arrayrefs containing strings (for
#pod fixed content) and hashrefs (for formatting code sections).
#pod
#pod The hashref hunks should contain at least two entries:  C for the
#pod conversion code (the s, d, or u in %s, %d, or %u); and C for the
#pod complete original text of the hunk.  For example, a bare minimum hunker should
#pod turn the following:
#pod
#pod   I would like to buy %d %s today.
#pod
#pod ...into...
#pod
#pod   [
#pod     'I would like to buy ',
#pod     { conversion => 'd', literal => '%d' },
#pod     ' ',
#pod     { conversion => 's', literal => '%d' },
#pod     ' today.',
#pod   ]
#pod
#pod Another common entry is C.  In the format strings expected by
#pod C, for example, these are free strings inside of curly braces.
#pod These are used extensively other existing helpers for things liked accessing
#pod named arguments or providing method names.
#pod
#pod =method hunk_simply
#pod
#pod This is the default format hunker.  It implements the format string semantics
#pod L.
#pod
#pod This hunker will produce C and C and C.  Its
#pod other entries are not yet well-defined for public consumption.
#pod
#pod =cut

my $regex = qr/
 (%                # leading '%'
  (-)?             # left-align, rather than right
  ([0-9]+)?        # (optional) minimum field width
  (?:\.([0-9]*))?  # (optional) maximum field width
  (?:{(.*?)})?     # (optional) stuff inside
  (\S)             # actual format character
 )
/x;

sub hunk_simply {
  my ($self, $string) = @_;

  my @to_fmt;
  my $pos = 0;

  while ($string =~ m{\G(.*?)$regex}gs) {
    push @to_fmt, $1, {
      alignment => $3,
      min_width => $4,
      max_width => $5,

      literal     => $2,
      argument    => $6,
      conversion  => $7,
    };

    $to_fmt[-1] = '%' if $to_fmt[-1]{literal} eq '%%';

    $pos = pos $string;
  }

  push @to_fmt, substr $string, $pos if $pos < length $string;

  return \@to_fmt;
}

#pod =method input_processor
#pod
#pod The input processor is responsible for inspecting the post-format-string
#pod arguments, validating them, and returning them in a possibly-transformed form.
#pod The processor is passed an arrayref containing the arguments and should return
#pod a scalar value to be used as the input going forward.
#pod
#pod =method return_input
#pod
#pod This input processor, the default, simply returns the input it was given with
#pod no validation or transformation.
#pod
#pod =cut

sub return_input {
  return $_[1];
}

#pod =method require_named_input
#pod
#pod This input processor will raise an exception unless there is exactly one
#pod post-format-string argument to the format call, and unless that argument is a
#pod hashref.  It will also replace the arrayref with the given hashref so
#pod subsequent phases of the format can avoid lots of needless array dereferencing.
#pod
#pod =cut

sub require_named_input {
  my ($self, $args) = @_;

  Carp::croak("routine must be called with exactly one hashref arg")
    if @$args != 1 or ! Params::Util::_HASHLIKE($args->[0]);

  return $args->[0];
}

#pod =method require_arrayref_input
#pod
#pod This input processor will raise an exception unless there is exactly one
#pod post-format-string argument to the format call, and unless that argument is a
#pod arrayref.  It will also replace the input with that single arrayref it found so
#pod subsequent phases of the format can avoid lots of needless array dereferencing.
#pod
#pod =cut

sub require_arrayref_input {
  my ($self, $args) = @_;

  Carp::croak("routine must be called with exactly one arrayref arg")
    if @$args != 1 or ! Params::Util::_ARRAYLIKE($args->[0]);

  return $args->[0];
}

#pod =method require_single_input
#pod
#pod This input processor will raise an exception if more than one input is given.
#pod After input processing, the single element in the input will be used as the
#pod input itself.
#pod
#pod =cut

sub require_single_input {
  my ($self, $args) = @_;

  Carp::croak("routine must be called with exactly one argument after string")
    if @$args != 1;

  return $args->[0];
}

#pod =method forbid_input
#pod
#pod This input processor will raise an exception if any input is given.  In other
#pod words, formatters with this input processor accept format strings and nothing
#pod else.
#pod
#pod =cut

sub forbid_input {
  my ($self, $args) = @_;

  Carp::croak("routine must be called with no arguments after format string")
    if @$args;

  return $args;
}

#pod =method string_replacer
#pod
#pod The string_replacer phase is responsible for adding a C entry to
#pod format code hunks.  This should be a string-value entry that will be formatted
#pod and concatenated into the output string.  String replacers can also replace the
#pod whole hunk with a string to avoid any subsequent formatting.
#pod
#pod =method positional_replace
#pod
#pod This replacer matches inputs to the hunk's position in the format string.  This
#pod is the default replacer, used in the L, which should
#pod make its behavior clear.  At present, fixed-string conversions B affect
#pod the position of arg matched, meaning that given the following:
#pod
#pod   my $formatter = String::Formatter->new({
#pod     codes => {
#pod       f => 'fixed string',
#pod       s => sub { ... },
#pod     }
#pod   });
#pod
#pod   $formatter->format("%s %f %s", 1, 2);
#pod
#pod The subroutine is called twice, once for the input C<1> and once for the input
#pod C<2>.  B after some more experimental use.
#pod
#pod =method named_replace
#pod
#pod This replacer should be used with the C input processor.
#pod It expects the input to be a hashref and it finds values to be interpolated by
#pod looking in the hashref for the brace-enclosed name on each format code.  Here's
#pod an example use:
#pod
#pod   $formatter->format("This was the %{adj}s day in %{num}d weeks.", {
#pod     adj => 'best',
#pod     num => 6,
#pod   });
#pod
#pod =method indexed_replace
#pod
#pod This replacer should be used with the C input
#pod processor.  It expects the input to be an arrayref and it finds values to be
#pod interpolated by looking in the arrayref for the brace-enclosed index on each
#pod format code.  Here's an example use:
#pod
#pod   $formatter->format("This was the %{1}s day in %{0}d weeks.", [ 6, 'best' ]);
#pod
#pod =cut

sub __closure_replace {
  my ($closure) = @_;

  return sub {
    my ($self, $hunks, $input) = @_;

    my $heap = {};
    my $code = $self->codes;

    for my $i (grep { ref $hunks->[$_] } 0 .. $#$hunks) {
      my $hunk = $hunks->[ $i ];
      my $conv = $code->{ $hunk->{conversion} };

      Carp::croak("Unknown conversion in stringf: $hunk->{conversion}")
        unless defined $conv;

      if (ref $conv) {
        $hunks->[ $i ]->{replacement} = $self->$closure({
          conv => $conv,
          hunk => $hunk,
          heap => $heap,
          input => $input,
        });
      } else {
        $hunks->[ $i ]->{replacement} = $conv;
      }
    }
  };
}

# $self->$string_replacer($hunks, $input);
BEGIN {
  *positional_replace = __closure_replace(sub {
    my ($self, $arg) = @_;
    local $_ = $arg->{input}->[ $arg->{heap}{nth}++ ];
    return $arg->{conv}->($self, $_, $arg->{hunk}{argument});
  });

  *named_replace = __closure_replace(sub {
    my ($self, $arg) = @_;
    local $_ = $arg->{input}->{ $arg->{hunk}{argument} };
    return $arg->{conv}->($self, $_, $arg->{hunk}{argument});
  });

  *indexed_replace = __closure_replace(sub {
    my ($self, $arg) = @_;
    local $_ = $arg->{input}->[ $arg->{hunk}{argument} ];
    return $arg->{conv}->($self, $_, $arg->{hunk}{argument});
  });
}

#pod =method method_replace
#pod
#pod This string replacer method expects the input to be a single value on which
#pod methods can be called.  If a value was given in braces to the format code, it
#pod is passed as an argument.
#pod
#pod =cut

# should totally be rewritten with commonality with keyed_replace factored out
sub method_replace {
  my ($self, $hunks, $input) = @_;

  my $heap = {};
  my $code = $self->codes;

  for my $i (grep { ref $hunks->[$_] } 0 .. $#$hunks) {
    my $hunk = $hunks->[ $i ];
    my $conv = $code->{ $hunk->{conversion} };

    Carp::croak("Unknown conversion in stringf: $hunk->{conversion}")
      unless defined $conv;

    if (ref $conv) {
      local $_ = $input;
      $hunks->[ $i ]->{replacement} = $input->$conv($hunk->{argument});
    } else {
      local $_ = $input;
      $hunks->[ $i ]->{replacement} = $input->$conv(
        defined $hunk->{argument} ? $hunk->{argument} : ()
      );
    }
  }
}

#pod =method keyed_replace
#pod
#pod This string replacer method expects the input to be a single hashref.  Coderef
#pod code values are used as callbacks, but strings are used as hash keys.  If a
#pod value was given in braces to the format code, it is ignored.
#pod
#pod For example if the codes contain C<< i => 'ident' >> then C<%i> in the format
#pod string will be replaced with C<< $input->{ident} >> in the output.
#pod
#pod =cut

# should totally be rewritten with commonality with method_replace factored out
sub keyed_replace {
  my ($self, $hunks, $input) = @_;

  my $heap = {};
  my $code = $self->codes;

  for my $i (grep { ref $hunks->[$_] } 0 .. $#$hunks) {
    my $hunk = $hunks->[ $i ];
    my $conv = $code->{ $hunk->{conversion} };

    Carp::croak("Unknown conversion in stringf: $hunk->{conversion}")
      unless defined $conv;

    if (ref $conv) {
      local $_ = $input;
      $hunks->[ $i ]->{replacement} = $input->$conv($hunk->{argument});
    } else {
      local $_ = $input;
      $hunks->[ $i ]->{replacement} = $input->{$conv};
    }
  }
}

#pod =method hunk_formatter
#pod
#pod The hunk_formatter processes each the hashref hunks left after string
#pod replacement and returns a string.  When it is called, it is passed a hunk
#pod hashref and must return a string.
#pod
#pod =method format_simply
#pod
#pod This is the default hunk formatter.  It deals with minimum and maximum width
#pod cues as well as left and right alignment.  Beyond that, it does no formatting
#pod of the replacement string.
#pod
#pod =cut

sub format_simply {
  my ($self, $hunk) = @_;

  my $replacement = $hunk->{replacement};
  my $replength   = length $replacement;

  my $alignment   = $hunk->{alignment} || '';
  my $min_width   = $hunk->{min_width} || 0;
  my $max_width   = $hunk->{max_width} || $replength;

  $min_width ||= $replength > $min_width ? $min_width : $replength;
  $max_width ||= $max_width > $replength ? $max_width : $replength;

  return sprintf "%$alignment${min_width}.${max_width}s", $replacement;
}

1;

#pod =begin :postlude
#pod
#pod =head1 HISTORY
#pod
#pod String::Formatter is based on L, written by
#pod Darren Chamberlain.  For a history of the code, check the project's source code
#pod repository.  All bugs should be reported to Ricardo Signes and
#pod String::Formatter.  Very little of the original code remains.
#pod
#pod =end :postlude
#pod
#pod =for Pod::Coverage
#pod   codes
#pod   default_format_hunker
#pod   default_input_processor
#pod   default_string_replacer
#pod   default_hunk_formatter
#pod

__END__