r53797 - in /branches/upstream/libstring-format-perl: ./ current/ current/t/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Sun Mar 7 01:39:07 UTC 2010
Author: jawnsy-guest
Date: Sun Mar 7 01:38:58 2010
New Revision: 53797
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=53797
Log:
[svn-inject] Installing original source of libstring-format-perl
Added:
branches/upstream/libstring-format-perl/
branches/upstream/libstring-format-perl/current/
branches/upstream/libstring-format-perl/current/Changes
branches/upstream/libstring-format-perl/current/Format.pm
branches/upstream/libstring-format-perl/current/MANIFEST
branches/upstream/libstring-format-perl/current/MANIFEST.SKIP
branches/upstream/libstring-format-perl/current/META.yml
branches/upstream/libstring-format-perl/current/Makefile.PL
branches/upstream/libstring-format-perl/current/README
branches/upstream/libstring-format-perl/current/t/
branches/upstream/libstring-format-perl/current/t/01load.t
branches/upstream/libstring-format-perl/current/t/02basic.t
branches/upstream/libstring-format-perl/current/t/03multiple.t
branches/upstream/libstring-format-perl/current/t/04subrefs.t
branches/upstream/libstring-format-perl/current/t/05stringfactory.t
Added: branches/upstream/libstring-format-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libstring-format-perl/current/Changes?rev=53797&op=file
==============================================================================
--- branches/upstream/libstring-format-perl/current/Changes (added)
+++ branches/upstream/libstring-format-perl/current/Changes Sun Mar 7 01:38:58 2010
@@ -1,0 +1,21 @@
+# ======================================================================
+# --- String::Format ---
+# ======================================================================
+
+# ----------------------------------------------------------------------
+# Version 1.14 December 22, 2005
+# ----------------------------------------------------------------------
+
+* Updated tests so that 04subrefs.t no longer fails if getpwuid is not
+ defined. RT#2083.
+
+# ----------------------------------------------------------------------
+# Version 1.13 February 11, 2002
+# ----------------------------------------------------------------------
+
+* Modified regex to use \S, rather than a regenerated one based on
+ stuff passed in. This is feasible because _replace now passes
+ through everything it does not recognize. Updated t/02basic.t to
+ refect this change.
+
+# vim: set tw=70 ts=2 sw=2 fo=trcqo2n:
Added: branches/upstream/libstring-format-perl/current/Format.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libstring-format-perl/current/Format.pm?rev=53797&op=file
==============================================================================
--- branches/upstream/libstring-format-perl/current/Format.pm (added)
+++ branches/upstream/libstring-format-perl/current/Format.pm Sun Mar 7 01:38:58 2010
@@ -1,0 +1,238 @@
+package String::Format;
+
+# ----------------------------------------------------------------------
+# $Id: Format.pm,v 1.4 2005/12/22 17:18:12 dlc Exp $
+# ----------------------------------------------------------------------
+# Copyright (C) 2002 darren chamberlain <darren at cpan.org>
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; version 2.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
+# USA
+# -------------------------------------------------------------------
+
+use strict;
+use vars qw($VERSION $REVSION @EXPORT);
+use Exporter;
+use base qw(Exporter);
+
+$VERSION = '1.14';
+$REVSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
+ at EXPORT = qw(stringf);
+
+sub _replace {
+ my ($args, $orig, $alignment, $min_width,
+ $max_width, $passme, $formchar) = @_;
+
+ # For unknown escapes, return the orignial
+ return $orig unless defined $args->{$formchar};
+
+ $alignment = '+' unless defined $alignment;
+
+ my $replacement = $args->{$formchar};
+ if (ref $replacement eq 'CODE') {
+ # $passme gets passed to subrefs.
+ $passme ||= "";
+ $passme =~ tr/{}//d;
+ $replacement = $replacement->($passme);
+ }
+
+ my $replength = length $replacement;
+ $min_width ||= $replength;
+ $max_width ||= $replength;
+
+ # length of replacement is between min and max
+ if (($replength > $min_width) && ($replength < $max_width)) {
+ return $replacement;
+ }
+
+ # length of replacement is longer than max; truncate
+ if ($replength > $max_width) {
+ return substr($replacement, 0, $max_width);
+ }
+
+ # length of replacement is less than min: pad
+ if ($alignment eq '-') {
+ # left align; pad in front
+ return $replacement . " " x ($min_width - $replength);
+ }
+
+ # right align, pad at end
+ return " " x ($min_width - $replength) . $replacement;
+}
+
+my $regex = qr/
+ (% # leading '%'
+ (-)? # left-align, rather than right
+ (\d*)? # (optional) minimum field width
+ (?:\.(\d*))? # (optional) maximum field width
+ ({.*?})? # (optional) stuff inside
+ (\S) # actual format character
+ )/x;
+sub stringf {
+ my $format = shift || return;
+ my $args = UNIVERSAL::isa($_[0], 'HASH') ? shift : { @_ };
+ $args->{'n'} = "\n" unless defined $args->{'n'};
+ $args->{'t'} = "\t" unless defined $args->{'t'};
+ $args->{'%'} = "%" unless defined $args->{'%'};
+
+ $format =~ s/$regex/_replace($args, $1, $2, $3, $4, $5, $6)/ge;
+
+ return $format;
+}
+
+sub stringfactory {
+ shift; # It's a class method, but we don't actually want the class
+ my $args = UNIVERSAL::isa($_[0], "HASH") ? shift : { @_ };
+ return sub { stringf($_[0], $args) };
+}
+
+1;
+__END__
+
+=head1 NAME
+
+String::Format - sprintf-like string formatting capabilities with
+arbitrary format definitions
+
+=head1 ABSTRACT
+
+String::Format allows for sprintf-style formatting capabilities with
+arbitrary format definitions
+
+=head1 SYNOPSIS
+
+ # In a script invoked as:
+ # script.pl -f "I like %a, %b, and %g, but not %m or %w."
+
+ use String::Format;
+ use Getopt::Std;
+
+ my %fruit = (
+ 'a' => "apples",
+ 'b' => "bannanas",
+ 'g' => "grapefruits",
+ 'm' => "melons",
+ 'w' => "watermelons",
+ );
+
+ use vars qw($opt_f);
+ getopt("f");
+
+ print stringf($opt_f, %fruit);
+
+ # prints:
+ # I like apples, bannanas, and grapefruits, but not melons or watermelons.
+
+=head1 DESCRIPTION
+
+String::Format lets you define arbitrary printf-like format sequences
+to be expanded. This module would be most useful in configuration
+files and reporting tools, where the results of a query need to be
+formatted in a particular way. It was inspired by mutt's index_format
+and related directives (see <URL:http://www.mutt.org/doc/manual/manual-6.html#index_format>).
+
+=head1 FUNCTIONS
+
+=head2 stringf
+
+String::Format exports a single function called stringf. stringf
+takes two arguments: a format string (see FORMAT STRINGS, below) and
+a reference to a hash of name => value pairs. These name => value
+pairs are what will be expanded in the format string.
+
+=head1 FORMAT STRINGS
+
+Format strings must match the following regular expression:
+
+ qr/
+ (% # leading '%'
+ (-)? # left-align, rather than right
+ (\d*)? # (optional) minimum field width
+ (?:\.(\d*))? # (optional) maximum field width
+ ({.*?})? # (optional) stuff inside
+ (\S) # actual format character
+ )/x;
+
+If the escape character specified does not exist in %args, then the
+original string is used. The alignment, minimum width, and maximum
+width options function identically to how they are defined in
+sprintf(3) (any variation is a bug, and should be reported).
+
+Note that Perl's sprintf definition is a little more liberal than the
+above regex; the deviations were intentional, and all deal with
+numeric formatting (the #, 0, and + leaders were specifically left
+out).
+
+The value attached to the key can be a scalar value or a subroutine
+reference; if it is a subroutine reference, then anything between the
+'{' and '}' ($5 in the above regex) will be passed as $_[0] to the
+subroutine reference. This allows for entries such as this:
+
+ %args = (
+ d => sub { POSIX::strftime($_[0], localtime) },
+ );
+
+Which can be invoked with this format string:
+
+ "It is %{%M:%S}d right now, on %{%A, %B %e}d."
+
+And result in (for example):
+
+ It is 17:45 right now, on Monday, February 4.
+
+Note that since the string is passed unmolested to the subroutine
+reference, and strftime would Do The Right Thing with this data, the
+above format string could be written as:
+
+ "It is %{%M:%S right now, on %A, %B %e}d."
+
+By default, the formats 'n', 't', and '%' are defined to be a newline,
+tab, and '%', respectively, if they are not already defined in the
+hashref of arguments that gets passed it. So we can add carriage
+returns simply:
+
+ "It is %{%M:%S right now, on %A, %B %e}d.%n"
+
+Because of how the string is parsed, the normal "\n" and "\t" are
+turned into two characters each, and are not treated as a newline and
+tab. This is a bug.
+
+=head1 FACTORY METHOD
+
+String::Format also supports a class method, named B<stringfactory>,
+which will return reference to a "primed" subroutine. stringfatory
+should be passed a reference to a hash of value; the returned
+subroutine will use these values as the %args hash.
+
+ my $self = Some::Groovy::Package->new($$, $<, $^T);
+ my %formats = (
+ 'i' => sub { $self->id },
+ 'd' => sub { $self->date },
+ 's' => sub { $self->subject },
+ 'b' => sub { $self->body },
+ );
+ my $index_format = String::Format->stringfactory(\%formats);
+
+ print $index_format->($format1);
+ print $index_format->($format2);
+
+This subroutine reference can be assigned to a local symbol table
+entry, and called normally, of course:
+
+ *reformat = String::Format->stringfactory(\%formats);
+
+ my $reformed = reformat($format_string);
+
+=head1 AUTHOR
+
+darren chamberlain <darren at cpan.org>
Added: branches/upstream/libstring-format-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libstring-format-perl/current/MANIFEST?rev=53797&op=file
==============================================================================
--- branches/upstream/libstring-format-perl/current/MANIFEST (added)
+++ branches/upstream/libstring-format-perl/current/MANIFEST Sun Mar 7 01:38:58 2010
@@ -1,0 +1,12 @@
+Changes
+Format.pm
+MANIFEST
+MANIFEST.SKIP
+Makefile.PL
+README
+t/01load.t
+t/02basic.t
+t/03multiple.t
+t/04subrefs.t
+t/05stringfactory.t
+META.yml Module meta-data (added by MakeMaker)
Added: branches/upstream/libstring-format-perl/current/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libstring-format-perl/current/MANIFEST.SKIP?rev=53797&op=file
==============================================================================
--- branches/upstream/libstring-format-perl/current/MANIFEST.SKIP (added)
+++ branches/upstream/libstring-format-perl/current/MANIFEST.SKIP Sun Mar 7 01:38:58 2010
@@ -1,0 +1,6 @@
+.*CVS.*
+^Build$
+^Makefile$
+^_build/
+^pm_to_blib$
+^blib/
Added: branches/upstream/libstring-format-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libstring-format-perl/current/META.yml?rev=53797&op=file
==============================================================================
--- branches/upstream/libstring-format-perl/current/META.yml (added)
+++ branches/upstream/libstring-format-perl/current/META.yml Sun Mar 7 01:38:58 2010
@@ -1,0 +1,11 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: String-Format
+version: 1.14
+version_from:
+installdirs: site
+requires:
+ Test::More: 0
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Added: branches/upstream/libstring-format-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libstring-format-perl/current/Makefile.PL?rev=53797&op=file
==============================================================================
--- branches/upstream/libstring-format-perl/current/Makefile.PL (added)
+++ branches/upstream/libstring-format-perl/current/Makefile.PL Sun Mar 7 01:38:58 2010
@@ -1,0 +1,15 @@
+use strict;
+use ExtUtils::MakeMaker;
+
+my %clean = (
+ 'FILES' => '$(DISTVNAME).tar$(SUFFIX)'
+);
+
+WriteMakefile(
+ 'NAME' => 'String::Format',
+ 'VERSION' => '1.14',
+ 'clean' => \%clean,
+ 'PREREQ_PM' => {
+ 'Test::More' => 0.00,
+ },
+);
Added: branches/upstream/libstring-format-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libstring-format-perl/current/README?rev=53797&op=file
==============================================================================
--- branches/upstream/libstring-format-perl/current/README (added)
+++ branches/upstream/libstring-format-perl/current/README Sun Mar 7 01:38:58 2010
@@ -1,0 +1,136 @@
+NAME
+ String::Format - sprintf-like string formatting capabilities
+ with arbitrary format definitions
+
+ABSTRACT
+ String::Format allows for sprintf-style formatting capabilities
+ with arbitrary format definitions
+
+SYNOPSIS
+ # In a script invoked as:
+ # script.pl -f "I like %a, %b, and %g, but not %m or %w."
+
+ use String::Format;
+ use Getopt::Std;
+
+ my %fruit = (
+ 'a' => "apples",
+ 'b' => "bannanas",
+ 'g' => "grapefruits",
+ 'm' => "melons",
+ 'w' => "watermelons",
+ );
+
+ use vars qw($opt_f);
+ getopt("f");
+
+ print stringf($opt_f, %fruit);
+
+ # prints:
+ # I like apples, bannanas, and grapefruits, but not melons or watermelons.
+
+DESCRIPTION
+ String::Format lets you define arbitrary printf-like format
+ sequences to be expanded. This module would be most useful in
+ configuration files and reporting tools, where the results of a
+ query need to be formatted in a particular way. It was inspired
+ by mutt's index_format and related directives (see
+ <URL:http://www.mutt.org/doc/manual/manual-
+ 6.html#index_format>).
+
+FUNCTIONS
+ stringf
+
+ String::Format exports a single function called stringf. stringf
+ takes two arguments: a format string (see FORMAT STRINGS, below)
+ and a hash (or reference to a hash) of name => value pairs.
+ These name => value pairs are what will be expanded in the
+ format string.
+
+FORMAT STRINGS
+ Format strings must match the following regular expression:
+
+ qr!
+ (% # leading '%'
+ (-)? # left-align, rather than right
+ (\d*)? # (optional) minimum field width
+ (?:\.(\d*))? # (optional) maximum field width
+ ({.*?})? # (optional) stuff inside
+ (\S) # actual format character
+ )!x;
+
+ If the escape character specified does not exist in %args, then
+ the original string is used. The alignment, minimum width, and
+ maximum width options function identically to how they are
+ defined in sprintf(3) (any variation is a bug, and should be
+ reported).
+
+ Note that Perl's sprintf definition is a little more liberal
+ than the above regex; the deviations were intentional, and all
+ deal with numeric formatting (the #, 0, and + leaders were
+ specifically left out).
+
+ The value attached to the key can be a scalar value or a
+ subroutine reference; if it is a subroutine reference, then
+ anything between the '{' and '}' ($5 in the above regex) will be
+ passed as $_[0] to the subroutine reference. This allows for
+ entries such as this:
+
+ %args = (
+ d => sub { POSIX::strftime($_[0], localtime) },
+ );
+
+ Which can be invoked with this format string:
+
+ "It is %{%M:%S}d right now, on %{%A, %B %e}d."
+
+ And result in (for example):
+
+ It is 17:45 right now, on Monday, February 4.
+
+ Note that since the string is passed unmolested to the
+ subroutine reference, and strftime would Do The Right Thing with
+ this data, the above format string could be written as:
+
+ "It is %{%M:%S right now, on %A, %B %e}d."
+
+ By default, the formats 'n', 't', and '%' are defined to be a
+ newline, tab, and '%', respectively, if they are not already
+ defined in the hash of arguments that gets passed it. So we can
+ add carriage returns simply:
+
+ "It is %{%M:%S right now, on %A, %B %e}d.%n"
+
+ Because of how the string is parsed, the normal "\n" and "\t"
+ are turned into two characters each, and are not treated as a
+ newline and tab. This is a bug.
+
+FACTORY METHOD
+ String::Format also supports a class method, named
+ stringfactory, which will return reference to a "primed"
+ subroutine. stringfatory should be passed a reference to a hash
+ of value; the returned subroutine will use these values as the
+ %args hash.
+
+ my $self = Some::Groovy::Package->new($$, $<, $^T);
+ my %formats = (
+ 'i' => sub { $self->id },
+ 'd' => sub { $self->date },
+ 's' => sub { $self->subject },
+ 'b' => sub { $self->body },
+ );
+ my $index_format = String::Format->stringfactory(\%formats);
+
+ print $index_format->($format1);
+ print $index_format->($format2);
+
+ This subroutine reference can be assigned to a local symbol
+ table entry, and called normally, of course:
+
+ *reformat = String::Format->stringfactory(\%formats);
+
+ my $reformed = reformat($format_string);
+
+AUTHOR
+ darren chamberlain <darren at cpan.org>
+
Added: branches/upstream/libstring-format-perl/current/t/01load.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libstring-format-perl/current/t/01load.t?rev=53797&op=file
==============================================================================
--- branches/upstream/libstring-format-perl/current/t/01load.t (added)
+++ branches/upstream/libstring-format-perl/current/t/01load.t Sun Mar 7 01:38:58 2010
@@ -1,0 +1,11 @@
+#!/usr/bin/env perl
+# vim: set ft=perl ts=4 sw=4:
+
+# ======================================================================
+# This is your basic "Do I compile?" test.
+# ======================================================================
+
+use strict;
+use Test::More tests => 1;
+
+use_ok('String::Format');
Added: branches/upstream/libstring-format-perl/current/t/02basic.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libstring-format-perl/current/t/02basic.t?rev=53797&op=file
==============================================================================
--- branches/upstream/libstring-format-perl/current/t/02basic.t (added)
+++ branches/upstream/libstring-format-perl/current/t/02basic.t Sun Mar 7 01:38:58 2010
@@ -1,0 +1,105 @@
+#!/usr/bin/env perl
+# vim: set ft=perl:
+
+# ======================================================================
+# 02basic.t
+#
+# Simple test, testing multiple format chars in a single string.
+# There are many variations on this theme; a few are covered here.
+# ======================================================================
+
+use strict;
+
+use Test::More tests => 8;
+use String::Format;
+
+# ======================================================================
+# Lexicals. $orig is the original format string.
+# ======================================================================
+my ($orig, $target, $result);
+my %fruit = (
+ 'a' => "apples",
+ 'b' => "bannanas",
+ 'g' => "grapefruits",
+ 'm' => "melons",
+ 'w' => "watermelons",
+);
+
+# ======================================================================
+# Test 1
+# Standard test, with all elements in place.
+# ======================================================================
+$orig = qq(I like %a, %b, and %g, but not %m or %w.);
+$target = "I like apples, bannanas, and grapefruits, ".
+ "but not melons or watermelons.";
+$result = stringf $orig, \%fruit;
+is $target => $result;
+
+# ======================================================================
+# Test 2
+# Test where some of the elements are missing.
+# ======================================================================
+delete $fruit{'b'};
+$target = "I like apples, %b, and grapefruits, ".
+ "but not melons or watermelons.";
+$result = stringf $orig, \%fruit;
+is $target => $result;
+
+# ======================================================================
+# Test 3
+# Upper and lower case of same char
+# ======================================================================
+$orig = '%A is not %a';
+$target = 'two is not one';
+$result = stringf $orig, { "a" => "one", "A" => "two" };
+is $target => $result;
+
+# ======================================================================
+# Test 4
+# Field width
+# ======================================================================
+$orig = "I am being %.5r.";
+$target = "I am being trunc.";
+$result = stringf $orig, { "r" => "truncated" };
+is $result => $target;
+
+# ======================================================================
+# Test 5
+# Alignment
+# ======================================================================
+$orig = "I am being %30e.";
+$target = "I am being elongated.";
+$result = stringf $orig, { "e" => "elongated" };
+is $target => $result;
+
+# ======================================================================
+# Test 6 - 8
+# Testing of non-alphabet characters
+# ======================================================================
+# Test 6 => '/'
+# ======================================================================
+$orig = "holy shit %/.";
+$target = "holy shit w00t.";
+$result = stringf $orig, { '/' => "w00t" };
+is $target => $result;
+
+# ======================================================================
+# Test 7 => numbers
+# ======================================================================
+$orig = '%1 %2 %3';
+$target = "1 2 3";
+$result = stringf $orig, { '1' => 1, '2' => 2, '3' => 3 };
+is $target => $result;
+
+# ======================================================================
+# Test 8 => perl sigils ($@&)
+# ======================================================================
+# Note: The %$ must be single quoted so it does not interpolate!
+# This was causing this test to unexpenctedly fail.
+# ======================================================================
+$orig = '%$ %@ %&';
+$target = "1 2 3";
+$result = stringf $orig, { '$' => 1, '@' => 2, '&' => 3 };
+is $target => $result;
+
+
Added: branches/upstream/libstring-format-perl/current/t/03multiple.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libstring-format-perl/current/t/03multiple.t?rev=53797&op=file
==============================================================================
--- branches/upstream/libstring-format-perl/current/t/03multiple.t (added)
+++ branches/upstream/libstring-format-perl/current/t/03multiple.t Sun Mar 7 01:38:58 2010
@@ -1,0 +1,40 @@
+#!/usr/bin/env perl
+# vim: set ft=perl ts=4 sw=4:
+
+# ======================================================================
+# 03multiple.t
+#
+# Attempting to pass a multi-character format string will not work.
+# This means that stringf will return the malformed format characters
+# as they were passed in.
+# ======================================================================
+
+use strict;
+
+use Test::More tests => 3;
+use String::Format;
+
+my ($orig, $target, $result);
+
+# ======================================================================
+# Test 1
+# ======================================================================
+$orig = q(My %foot hurts.);
+$target = q(My %foot hurts.);
+$result = stringf $orig, { 'foot' => 'pretzel' };
+is $target => $result;
+
+# ======================================================================
+# Test 2, same as Test 1, but with a one-char format string.
+# ======================================================================
+$target = "My pretzeloot hurts.";
+$result = stringf $orig, { 'f' => 'pretzel' };
+is $target => $result;
+
+# ======================================================================
+# Test 3
+# ======================================================================
+$orig = 'I am %undefined';
+$target = 'I am not ndefined';
+$result = stringf $orig, { u => "not " };
+is $target => $result;
Added: branches/upstream/libstring-format-perl/current/t/04subrefs.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libstring-format-perl/current/t/04subrefs.t?rev=53797&op=file
==============================================================================
--- branches/upstream/libstring-format-perl/current/t/04subrefs.t (added)
+++ branches/upstream/libstring-format-perl/current/t/04subrefs.t Sun Mar 7 01:38:58 2010
@@ -1,0 +1,54 @@
+#!/usr/bin/env perl
+# vim: set ft=perl ts=4 sw=4:
+
+# ======================================================================
+# 04subrefs.t
+#
+# The design of String::Format is such that you can pass a subroutine
+# reference as a hash value, and it will be called in place. Let's
+# test that.
+# ======================================================================
+
+use strict;
+
+use Test::More tests => 3;
+use String::Format;
+use POSIX qw(strftime); # for test 1
+use Socket; # for test 3
+
+my ($orig, $target, $result);
+
+# ======================================================================
+# Test 1
+# Using strftime in a subroutine reference.
+# ======================================================================
+$orig = q(It is now %{%Y/%m%d}d.);
+$target = sprintf q(It is now %s.), strftime("%Y/%m/%d", localtime);
+$result = stringf $orig, "d" => sub { strftime("%Y/%m/%d", localtime) };
+is $target => $result;
+
+# ======================================================================
+# Test 2
+# using getpwuid
+# ======================================================================
+SKIP: {
+ use Config;
+ skip "getpwuid not implmented on this platform", 1
+ unless $Config{'d_getpwuid_r'};
+
+ $orig = "I am %u.";
+ $target = "I am " . getpwuid($<) . ".";
+ $result = stringf $orig, "u" => sub { getpwuid($<) };
+ is $target => $result;
+}
+
+# ======================================================================
+# Test 3
+# hostname lookups
+# ======================================================================
+sub ip { inet_ntoa inet_aton $_[0] }
+$orig = q(The address for localhost is %{localhost}i.);
+$target = q(The address for localhost is 127.0.0.1.);
+$result = stringf $orig, "i" => \&ip;
+is $target => $result;
+
Added: branches/upstream/libstring-format-perl/current/t/05stringfactory.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libstring-format-perl/current/t/05stringfactory.t?rev=53797&op=file
==============================================================================
--- branches/upstream/libstring-format-perl/current/t/05stringfactory.t (added)
+++ branches/upstream/libstring-format-perl/current/t/05stringfactory.t Sun Mar 7 01:38:58 2010
@@ -1,0 +1,43 @@
+#!/usr/bin/env perl
+# vim: set ft=perl ts=4 sw=4:
+
+# ======================================================================
+# 05stringfactory.t
+#
+# Test the subroutine generating facilities, supported by the
+# stringfactory class method.
+# ======================================================================
+
+use strict;
+use Test::More tests => 1;
+use String::Format;
+use POSIX qw(strftime);
+
+my ($orig, $target, $result);
+
+# ======================================================================
+# Test 1
+# Using instance methods
+# ======================================================================
+my $tpkg = TestPkg->new;
+my %formats = (
+ 'i' => sub { $tpkg->id },
+ 'd' => sub { strftime($_[0], localtime($tpkg->date)) },
+ 'f' => sub { $tpkg->diff($_[0]) }
+);
+my $formatter = String::Format->stringfactory(\%formats);
+
+$orig = 'my lovely TestPkg instance has an id of %i.';
+$target = 'my lovely TestPkg instance has an id of ' . $tpkg->id . '.';
+$result = $formatter->($orig);
+
+is $target => $result;
+
+BEGIN {
+ # (silly) embedded package
+ package TestPkg;
+ sub new { bless \(my $o = int rand($$)) => $_[0] }
+ sub id { ${$_[0]} }
+ sub date { time }
+ sub diff { $_[0]->id - ($_[0] || 0) }
+}
More information about the Pkg-perl-cvs-commits
mailing list