# -*- mode: cperl; cperl-indent-level: 2 -*-
#
# This module is copyright 1998 Mark-Jason Dominus.
# (mjd-perl-interpolation@plover.com)
#
# Version 0.53 alpha $Revision: 1.2 $ $Date: 1998年04月09日 18:59:07 $
package Interpolation;
$VERSION = '0.53';
use Carp;
# use Symbol;
%builtin = (null => sub { $_[0] },
'eval' => sub { $_[0] },
identity => sub { $_[0] },
ucwords =>
sub {
my $s = lc shift;
$s =~ s/\b(\w)/\u1ドル/g;
$s
},
commify =>
sub {
local $_ = sprintf("%.2f", shift());
1 while s/^(-?\d+)(\d{3})/1,ドル2ドル/;
$_;
},
'reverse' =>
sub { reverse $_[0] },
# Idea for funky sprintf trick thanks to Ken Fox
'sprintf' =>
sub {
my %fakehash;
my $format = shift;
tie %fakehash, Interpolation,
sub { sprintf($format, split /$;/o,$_[0])};
\%fakehash;
},
'sprintf1' =>
sub {
my ($fmt, @args) = split(/$;/o, shift());
sprintf($fmt, @args);
},
# Idea for hash interpolator thanks to me
'hash' =>
sub {
my $h = shift;
unless (ref $h) {
require Carp;
Carp::croak("Argument of '%' formatter is not a reference");
}
my $o = '{ ';
my $k;
foreach $k (sort keys %$h) {
$o .= "$k => $h->{$k}, ";
}
chop $o; chop $o;
$o .= ' }';
},
# And why not make it even more impressive?
# (There is probably a more intelligent way to do this.)
'dumper' =>
sub { require Data::Dumper; goto &Data::Dumper::Dumper}
);
sub import {
my $caller_pack = caller;
# print STDERR "exporter args: (@_); caller pack: $caller_pack\n";
my $my_pack = shift;
if (@_ % 2) {
croak "Argument list in `use $my_pack' must be list of pairs; aborting";
}
while (@_) {
my $hashname = shift;
my $function = shift;
# Probably should use ISA or something here, because
# $function might be blessed
unless (ref $function eq CODE || exists $builtin{$function}) {
croak "Values in argument list in `use $my_pack' must be code refs; aborting\n";
}
my %fakehash;
tie %fakehash, $my_pack, $function;
*{$caller_pack . '::' . $hashname} = \%fakehash;
}
}
sub unimport {
# warn "Interpolation::unimport @_\n";
my $caller_pack = caller;
my $my_pack = shift;
while (@_) {
my $hashname = shift;
my %fakehash;
my $oldhash = *{$caller_pack . '::' . $hashname}{HASH};
*{$caller_pack . '::' . $hashname} = \%fakehash;
untie %$oldhash;
}
}
sub TIEHASH {
my $pack = shift;
my $cref = shift;
unless (ref $cref) { # Convert symbolic name to function ref
croak "Unknown builtin function `$cref'; aborting"
unless exists $builtin{$cref};
$cref = $builtin{$cref};
}
bless $cref => $pack; # That's it? Yup!
}
# Deprecated unless someone has a good idea of what it is good for.
{
# To suppress the warning, set this variable to 1.
$TIEARRAY_WARNED = 0;
sub TIEARRAY {
my $pack = shift;
unless ($TIEARRAY_WARNED++) {
carp "Tied $pack arrays are deprecated.\n Send email to mjd-perl-interpolation\@plover.com\n to prevent them from being removed in a future version.\n";
}
bless $builtin{identity} => $pack;
}
}
# This is where the magic is.
sub FETCH {
&{$_[0]}($_[1]); # For pre-5.004_04 compatibility
#$_[0]->($_[1]); # Line of the day?
}
sub cut_it_out {
my $object = shift;
my $caller = (caller(1))[3];
croak "Not allowed to use $caller on an Interpolation variable; aborting";
}
*STORE = \&cut_it_out;
*DELETE = \&cut_it_out;
*CLEAR = \&cut_it_out;
*EXISTS = \&cut_it_out;
*FIRSTKEY = \&cut_it_out;
*NEXTKEY = \&cut_it_out;
1;
=head1 NAME
Interpolation - Arbitrary string interpolation semantics
=head1 SYNOPSIS
use Interpolation name => \&function, ...;
print "la la la la $name{blah blah blah}";
# This is like doing:
$VAR = &function(blah blah blah);
print "la la la la $VAR";
=head1 DESCRIPTION
Beginners always want to write this:
print "The sum of three and four is: 3+4";
And they want the C<3+4> part to be evaluated, so that it prints
this:
The sum of three and four is: 7
Of course, it's a double-quoted string, so it's not evaluated. The
only things that are evaluated in double-quoted strings are variable
references.
There are solutions to this, but most of them are ugly. This module
is less ugly. It lets you define arbitrary interpolation semantics.
For example, you can say
use Interpolation money => \&commify_with_dollar_sign,
E => 'eval',
placename => 'ucwords',
;
And then you can write these:
print "3 + 4 = $E{3+4}";
# Prints ``3 + 4 = 7''
$SALARY = 57500;
print "The salary is $money{$SALARY}";
# Prints ``The salary is 57,500ドル.00''
$PLACE1 = 'SAN BERNADINO HIGH SCHOOL';
$PLACE2 = 'n.y. state';
print "$placename{$PLACE1} is not near $placename{$PLACE2}";
# Prints ``San Bernadino High School is not near N.Y. State";
=head1 DETAILS
The arguments to the C