home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl5 / String / Errf.pm next >
Encoding:
Text File  |  2010-10-28  |  12.4 KB  |  432 lines
  1. use strict;
  2. use warnings;
  3. package String::Errf;
  4. BEGIN {
  5.   $String::Errf::VERSION = '0.006';
  6. } # I really wanted to call it String::Fister.
  7. use String::Formatter 0.102081 ();
  8. use base 'String::Formatter';
  9. # ABSTRACT: a simple sprintf-like dialect
  10.  
  11. use Scalar::Util ();
  12.  
  13.  
  14. use Carp ();
  15. use Time::Piece ();
  16. use Params::Util ();
  17.  
  18. use Sub::Exporter -setup => {
  19.   exports => {
  20.     errf => sub {
  21.       my ($class) = @_;
  22.       my $fmt = $class->new;
  23.       return sub { $fmt->format(@_) };
  24.     },
  25.   }
  26. };
  27.  
  28. sub default_codes {
  29.   return {
  30.     i => '_format_int',
  31.     f => '_format_float',
  32.     t => '_format_timestamp',
  33.     s => '_format_string',
  34.     n => '_format_numbered',
  35.     N => '_format_numbered',
  36.   };
  37. }
  38.  
  39. sub default_input_processor { 'require_named_input' }
  40. sub default_format_hunker   { '__hunk_errf' }
  41. sub default_string_replacer { '__replace_errf' }
  42. sub default_hunk_formatter  { '__format_errf' }
  43.  
  44. my $regex = qr/
  45.  (%                   # leading '%'
  46.   (?:{                # {
  47.     (.*?)             #   mandatory argument name
  48.     (?: ; (.*?) )?    #   optional extras after semicolon
  49.   })                  # }
  50.   ([a-z])             # actual conversion character
  51.  )
  52. /xi;
  53.  
  54. sub __hunk_errf {
  55.   my ($self, $string) = @_;
  56.  
  57.   my @to_fmt;
  58.   my $pos = 0;
  59.  
  60.   while ($string =~ m{\G(.*?)$regex}gs) {
  61.     push @to_fmt, $1, {
  62.       literal     => $2,
  63.       argument    => $3,
  64.       extra       => $4,
  65.       conversion  => $5,
  66.     };
  67.  
  68.     $pos = pos $string;
  69.   }
  70.  
  71.   push @to_fmt, substr $string, $pos if $pos < length $string;
  72.  
  73.   return \@to_fmt;
  74. }
  75.  
  76. sub __replace_errf {
  77.   my ($self, $hunks, $input) = @_;
  78.  
  79.   my $heap = {};
  80.   my $code = $self->codes;
  81.  
  82.   for my $i (grep { ref $hunks->[$_] } 0 .. $#$hunks) {
  83.     my $hunk = $hunks->[ $i ];
  84.     my $conv = $code->{ $hunk->{conversion} };
  85.  
  86.     Carp::croak("Unknown conversion in stringf: $hunk->{conversion}")
  87.       unless defined $conv;
  88.  
  89.     $hunk->{replacement} = $input->{ $hunk->{argument} };
  90.     $hunk->{args}        = [ $hunk->{extra} ? split /;/, $hunk->{extra} : () ];
  91.   }
  92. }
  93.  
  94. sub __format_errf {
  95.   my ($self, $hunk) = @_;
  96.  
  97.   my $conv = $self->codes->{ $hunk->{conversion} };
  98.  
  99.   Carp::croak("Unknown conversion in stringf: $hunk->{conversion}")
  100.     unless defined $conv;
  101.  
  102.   return $self->$conv($hunk->{replacement}, $hunk->{args}, $hunk);
  103. }
  104.  
  105. sub _proc_args {
  106.   my ($self, $input, $parse_compact) = @_;
  107.  
  108.   return $input if ref $input eq 'HASH';
  109.  
  110.   $parse_compact ||= sub {
  111.     Carp::croak("no compact format allowed, but compact format found");
  112.   };
  113.  
  114.   my @args = @$input;
  115.  
  116.   my $first = (defined $args[0] and length $args[0] and $args[0] !~ /=/)
  117.             ? shift @args
  118.             : undef;
  119.  
  120.   my %param = (
  121.     ($first ? %{ $parse_compact->($first) } : ()),
  122.     (map {; split /=/, $_, 2 } @args),
  123.   );
  124.  
  125.   return \%param;
  126. }
  127.  
  128. # Likely integer formatting options are:
  129. #   prefix (+ for positive numbers)
  130. #
  131. # Other options like (minwidth, precision, fillchar) are not out of the
  132. # question, but if this system is to be used for formatting simple
  133. # user-oriented error messages, they seem really unlikely to be used.  Put off
  134. # supplying them! -- rjbs, 2010-07-30
  135. sub _format_int {
  136.   my ($self, $value, $rest) = @_;
  137.  
  138.   my $arg = $self->_proc_args($rest, sub {
  139.     return { prefix => $_[0] eq '+' ? '+' : '', }
  140.   });
  141.  
  142.   my $int_value = int $value;
  143.   $value = sprintf '%.0f', $value unless $int_value == $value;
  144.  
  145.   return $value if $value < 0;
  146.  
  147.   $arg->{prefix} = '' unless defined $arg->{prefix};
  148.  
  149.   return "$arg->{prefix}$value";
  150. }
  151.  
  152.  
  153. # Likely float formatting options are:
  154. #   prefix (+ for positive numbers)
  155. #   precision
  156. #
  157. # My remarks above for "int" go for floats, too. -- rjbs, 2010-07-30
  158. sub _format_float {
  159.   my ($self, $value, $rest) = @_;
  160.  
  161.   my $arg = $self->_proc_args($rest, sub {
  162.     my ($prefix_str, $prec) = $_[0] =~ /\A(\+?)(?:\.(\d+))?\z/;
  163.     return { prefix => $prefix_str, precision => $prec };
  164.   });
  165.  
  166.   undef $arg->{precision}
  167.     unless defined $arg->{precision} and length $arg->{precision};
  168.  
  169.   $arg->{prefix} = '' unless defined $arg->{prefix};
  170.  
  171.   $value = defined $arg->{precision}
  172.          ? sprintf("%0.$arg->{precision}f", $value)
  173.          : $value;
  174.  
  175.   return $value < 0 ? $value : "$arg->{prefix}$value";
  176. }
  177.  
  178. sub _format_timestamp {
  179.   my ($self, $value, $rest) = @_;
  180.  
  181.   my $arg = $self->_proc_args($rest, sub {
  182.     return { type => $_[0] };
  183.   });
  184.  
  185.   my $type = $arg->{type} || 'datetime';
  186.   my $zone = $arg->{tz}   || 'local';
  187.  
  188.   my $format = $type eq 'datetime' ? '%Y-%m-%d %H:%M:%S'
  189.              : $type eq 'date'     ? '%Y-%m-%d'
  190.              : $type eq 'time'     ? '%H:%M:%S'
  191.              : Carp::croak("unknown format type for %t: $type");
  192.  
  193.   # Supplying a time zone is *strictly informational*. -- rjbs, 2010-10-15
  194.   Carp::croak("illegal time zone for %t: $zone")
  195.     unless $zone eq 'local' or $zone eq 'UTC';
  196.  
  197.   my $method = $zone eq 'UTC' ? 'gmtime' : 'localtime';
  198.   my $piece  = Time::Piece->$method($value);
  199.  
  200.   my $str = $piece->strftime($format);
  201.  
  202.   return $zone eq 'UTC' ? "$str UTC" : $str;
  203. }
  204.  
  205. sub _format_string {
  206.   my ($self, $value, $rest) = @_;
  207.   return $value;
  208. }
  209.  
  210. sub _pluralize {
  211.   my ($singular) = @_;
  212.  
  213.   return $singular  =~ /(?:[xzs]|sh|ch)\z/ ? "${singular}es"
  214.        : $singular  =~ s/y\z/ies/          ? $singular
  215.        :                                     "${singular}s";
  216. }
  217.  
  218. sub _format_numbered {
  219.   my ($self, $value, $rest, $hunk) = @_;
  220.  
  221.   my $arg = $self->_proc_args($rest, sub {
  222.     my ($word) = @_;
  223.  
  224.     my ($singular, $divider, $extra) = $word =~ m{\A(.+?)(?: ([/+]) (.+) )?\z}x;
  225.  
  226.     $divider = '' unless defined $divider; # just to avoid warnings
  227.  
  228.     my $plural = $divider   eq '/'                 ? $extra
  229.                : $divider   eq '+'                 ? "$singular$extra"
  230.                :                                     _pluralize($singular);
  231.  
  232.     return { singular => $singular, plural => $plural };
  233.   });
  234.  
  235.   $value = $self->_format_float($value, {
  236.     prefix    => $arg->{prefix},
  237.     precision => $arg->{precision},
  238.   });
  239.  
  240.   Carp::croak("no word given to number-based formatter")
  241.     unless defined $arg->{singular};
  242.  
  243.   $arg->{plural} = _pluralize($arg->{singular}) unless defined $arg->{plural};
  244.  
  245.   my $formed = abs($value) == 1 ? $arg->{singular} : $arg->{plural};
  246.  
  247.   return $formed if $hunk->{conversion} eq 'N';
  248.   return "$value $formed";
  249. }
  250.  
  251. 1;
  252.  
  253. __END__
  254. =pod
  255.  
  256. =head1 NAME
  257.  
  258. String::Errf - a simple sprintf-like dialect
  259.  
  260. =head1 VERSION
  261.  
  262. version 0.006
  263.  
  264. =head1 SYNOPSIS
  265.  
  266.   use String::Errf qw(errf);
  267.  
  268.   print errf "This process was started at %{start}t with %{args;argument}n.\n",
  269.     { start => $^T, args => 0 + @ARGV };
  270.  
  271. ...might print something like:
  272.  
  273.   This process was started at 2010-10-17 14:05:29 with 0 arguments.
  274.  
  275. =head1 DESCRIPTION
  276.  
  277. String::Errf provides C<errf>, a simple string formatter that works something
  278. like C<L<sprintf|perlfunc/sprintf>>.  It is implemented using
  279. L<String::Formatter> and L<Sub::Exporter>.  Their documentation may be useful
  280. in understanding or extending String::Errf.
  281.  
  282. =head1 DIFFERENCES FROM SPRINTF
  283.  
  284. The data passed to C<errf> should be organized in a single hashref, not a list.
  285.  
  286. Formatting codes require named parameters, and the available codes are
  287. different.  See L</FORMATTING CODES> below.
  288.  
  289. As with most String::Formatter formatters, C<%> is not a format code.  If you
  290. want a literal C<%>, do not put anything between the two percent signs, just
  291. write C<%%>.
  292.  
  293. =head2 FORMATTING CODES
  294.  
  295. C<errf> formatting codes I<require> a set of arguments between the C<%> and the
  296. formatting code letter.  These arguments are placed in curly braces and
  297. separated by semicolons.  The first argument is the name of the data to look
  298. for in the format data.  For example, this is a valid use of C<errf>:
  299.  
  300.   errf "The current time in %{tz}s is %{now;local}t.", {
  301.     tz  => $ENV{TZ},
  302.     now => time,
  303.   };
  304.  
  305. The second argument, if present, may be a compact form for multiple named
  306. arguments.  The rest of the arguments will be named values in the form
  307. C<name=value>.  The examples below should help clarify how arguments are
  308. passed.  When an argument appears in both a compact and named form, the named
  309. form trumps the compact form.
  310.  
  311. The specific codes and their arguments are:
  312.  
  313. =head3 s for string
  314.  
  315. The C<s> format code is for any string, and takes no arguments.  It just
  316. includes the named item from the input data.
  317.  
  318.   errf "%{name}s", { name => 'John Smith' }; # returns "John Smith"
  319.  
  320. Remember, C<errf> does I<not> have any of the left- or right-padding formatting
  321. that C<sprintf> provides.  It is not meant for building tables, only strings.
  322.  
  323. =head3 i for integer
  324.  
  325. The C<i> format code is used for integers.  It takes one optional argument,
  326. C<prefix>, which defaults to the empty string.  C<prefix> may be given as the
  327. compact argument, standing alone.  C<prefix> is used to prefix non-negative
  328. integers.  It may only be a plus sign.
  329.  
  330.   errf "%{x}i",    { x => 10 }; # returns "10"
  331.   errf "%{x;+}i",  { x => 10 }; # returns "+10"
  332.  
  333.   errf "%{x;prefix=+}i",  { x => 10 }; # returns "+10"
  334.  
  335. The rounding behavior for non-integer values I<is not currently specified>.
  336.  
  337. =head3 f for float (or fractional)
  338.  
  339. The C<f> format code is for numbers with sub-integer precision.  It works just
  340. like C<i>, but adds a C<precision> argument which specifies how many decimal
  341. places of precision to display.  The compact argument may be just the prefix or
  342. the prefix followed by a period followed by the precision.
  343.  
  344.   errf "%{x}f",     { x => 10.1234 }; # returns "10";
  345.   errf "%{x;+}f",   { x => 10.1234 }; # returns "+10";
  346.  
  347.   errf "%{x;.2}f",  { x => 10.1234 }; # returns  "10.12";
  348.   errf "%{x;+.2}f", { x => 10.1234 }; # returns "+10.12";
  349.  
  350.   errf "%{x;precision=.2}f",          { x => 10.1234 }; # returns  "10.12";
  351.   errf "%{x;prefix=+;precision=.2}f", { x => 10.1234 }; # returns "+10.12";
  352.  
  353. =head3 t for time
  354.  
  355. The C<t> format code is used to format timestamps provided in epoch seconds.
  356. It can be given two arguments: C<type> and C<tz>.
  357.  
  358. C<type> can be either date, time, or datetime, and indicates what part of the
  359. timestamp should be displayed.  The default is datetime.  C<tz> requests that
  360. the timestamp be displayed in either UTC or the local time zone.  The default
  361. is local.
  362.  
  363. The compact form is just C<type> alone.
  364.  
  365.   # Assuming our local time zone is America/New_York...
  366.  
  367.   errf "%{x}t",               { x => 1280530906 }; # "2010-07-30 19:01:46"
  368.   errf "%{x;type=date}t",     { x => 1280530906 }; # "2010-07-30"
  369.   errf "%{x;type=time}t",     { x => 1280530906 }; # "19:01:46"
  370.   errf "%{x;type=datetime}t", { x => 1280530906 }; # "2010-07-30 19:01:46"
  371.  
  372.   errf "%{x;tz=UTC}t",               { x => 1280530906 }; # "2010-07-30 23:01:46 UTC"
  373.   errf "%{x;tz=UTC;type=date}t",     { x => 1280530906 }; # "2010-07-30 UTC"
  374.   errf "%{x;tz=UTC;type=time}t",     { x => 1280530906 }; # "23:01:46 UTC"
  375.   errf "%{x;tz=UTC;type=datetime}t", { x => 1280530906 }; # "2010-07-30 23:01:46 UTC"
  376.  
  377. =head3 n and N for numbered
  378.  
  379. The C<n> and C<N> format codes are for picking words based on number.  It takes
  380. two of its own arguments, C<singular> and C<plural>, as well as C<prefix> and
  381. C<precision> which may be used for formatting the number itself.
  382.  
  383. If the value being formatted is 1, the singular word is used.  Otherwise, the
  384. plural form is used.
  385.  
  386.   errf "%{x;singular=dog;plural=dogs}n", { x => 0 }; # 0 dogs
  387.   errf "%{x;singular=dog;plural=dogs}n", { x => 1 }; # 1 dog
  388.   errf "%{x;singular=dog;plural=dogs}n", { x => 2 }; # 2 dogs
  389.  
  390.   errf "%{x;singular=dog;plural=dogs}n", { x => 1.4 }; # 1.4 dogs
  391.   errf "%{x;singular=dog;plural=dogs;precision=1}n", { x => 1.4 }; # 1.4 dogs
  392.   errf "%{x;singular=dog;plural=dogs;precision=0}n", { x => 1.4 }; # 1 dog
  393.  
  394. If C<N> is used instead of C<n>, the number will not be included, only the
  395. chosen word.
  396.  
  397.   errf "%{x;singular=is;plural=are}N", { x => 0 }; # are
  398.   errf "%{x;singular=is;plural=are}N", { x => 1 }; # is
  399.   errf "%{x;singular=is;plural=are}N", { x => 2 }; # are
  400.  
  401.   errf "%{x;singular=is;plural=are}N", { x => 1.4 }; # 1.4 are
  402.   errf "%{x;singular=is;plural=are;precision=1}N", { x => 1.4 }; # 1.4 are
  403.   errf "%{x;singular=is;plural=are;precision=0}N", { x => 1.4 }; # 1 is
  404.  
  405. The compact form may take any of the following forms:
  406.  
  407.   word          - equivalent to singular=word
  408.  
  409.   word+suffix   - equivalent to singular=word;plural=wordsuffix
  410.  
  411.   word1/word2   - equivalent to singular=word;plural=word2
  412.  
  413. If no singular form is given, an exception is thrown.  If no plural form is
  414. given, one will be generated according to some basic rules of English
  415. noun orthography.
  416.  
  417. =head3
  418.  
  419. =head1 AUTHOR
  420.  
  421. Ricardo Signes <rjbs@cpan.org>
  422.  
  423. =head1 COPYRIGHT AND LICENSE
  424.  
  425. This software is copyright (c) 2010 by Ricardo Signes.
  426.  
  427. This is free software; you can redistribute it and/or modify it under
  428. the same terms as the Perl 5 programming language system itself.
  429.  
  430. =cut
  431.  
  432.