File Coverage

blib/lib/String/Formatter.pm

Criterion	Covered	Total	%
statement	136	145	93.7
branch	22	36	61.1
condition	15	24	62.5
subroutine	26	27	96.3
pod	11	13	84.6
total	210	245	85.7

use strict;
use warnings;
package String::Formatter;
{
  $String::Formatter::VERSION = '0.102084';
}
# ABSTRACT: build sprintf-like functions of your own


require 5.006;

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 } };
  }
}


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} }


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;
}


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;
}


sub return_input {
  return $_[1];
}


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];
}


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];
}


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];
}


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

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

  return $args;
}


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});
  });
}


# 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} : ()
      );
    }
  }
}


# 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};
    }
  }
}


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;

__END__