@ISA
=
qw(Exporter)
;
@EXPORT
=
qw(fmt pfmt)
;
$VERSION
=
"0.01"
;
use
vars
qw($accum $argno @arglist $VERSION)
;
my
(
$config_zero_is_false
) = 0;
my
(
$config_align_middle
) =
'l'
;
my
(
$verbose_tok
) = 0;
my
(
$verbose_parse
) = 0;
my
(
$verbose_reduce
) = 0;
my
(
$verbose_run
) = 0;
my
(
$verbose_fmt
) = 0;
sub
tok {
my
(
$s
) =
@_
;
my
(
$fulls
) =
$s
;
my
(
@s
);
my
(
@t
);
my
(
$len
) =
length
(
$s
);
my
(
$soff
,
$eoff
);
while
(
$s
){
print
STDERR
"T: $s\n"
if
$verbose_tok
;
if
(
$s
=~ /^([^~]+)/ && $1 ){
print
STDERR
"T-> $1 <$'>\n"
if
$verbose_tok
> 1;
$soff
=
$len
-
length
(
$s
) - 1;
$s
= $';
$eoff
=
$len
-
length
(
$s
) - 1;
push
@t
, {
directive
=>
'literal'
,
text
=> $1,
fullfmt
=>
$fulls
,
fmtoffset
=>
$eoff
,
fmtstart
=>
$soff
,
};
}
elsif
(
$s
=~ /^~(<{2,}|>{2,}|\|{2,})/ && $1 ){
my
(
$p
) = $1;
print
STDERR
"T-> $1 {$'}\n"
if
$verbose_tok
> 1;
$soff
=
$len
-
length
(
$s
) - 1;
$s
= $';
$eoff
=
$len
-
length
(
$s
) - 1;
push
@t
, {
directive
=>
'A'
,
numbers
=> [
length
($1)+1 ],
gravity
=> (
$p
=~ /</ ) ?
'l'
: ((
$p
=~ />/ ) ?
'r'
:
'c'
),
fullfmt
=>
$fulls
,
fmtoffset
=>
$eoff
,
fmtstart
=>
$soff
,
};
}
elsif
(
$s
=~ /^~(((-?\d*|v|\
([\@:!]*)
([^=\@:!\'v\
&& $1 ){
my
(
$ns
,
$sp
,
$f
) = ($2, $6, $7);
print
STDERR
"T-> $f; <$ns>; $sp <$'>\n"
if
$verbose_tok
> 1;
$soff
=
$len
-
length
(
$s
) - 1;
$s
= $';
$eoff
=
$len
-
length
(
$s
) - 1;
my
(
@n
) =
split
','
,
$ns
;
foreach
(
@n
){
if
( /^\'(.*)$/ ){
$_
= $1;
}
}
push
@t
, {
numbers
=> [
@n
],
directive
=>
uc
(
$f
),
atsign
=> (
$sp
=~ /@|!/) ? 1 : 0,
colon
=> (
$sp
=~ /:/) ? 1 : 0,
fullfmt
=>
$fulls
,
fmtoffset
=>
$eoff
,
fmtstart
=>
$soff
,
};
}
}
@t
;
}
sub
parse {
my
(
@t
) =
@_
;
my
(
$t
);
my
(
$i
) = 0;
my
(
$tnext
);
$tnext
=
sub
{
return
undef
if
(
$i
>=
@t
);
return
$t
[
$i
++ ];
};
parser(
''
, 1,
$tnext
);
}
sub
parser {
my
(
$term
,
$n
,
$tnext
) =
@_
;
my
(
$t
,
@tt
);
while
( 1 ){
$t
=
&$tnext
();
if
(
$term
&& !
$t
){
$t
=
$tt
[0];
formaterror(
"I see no matching $term here"
,
$t
);
return
;
}
return
\
@tt
unless
$t
;
print
STDERR
"PP"
,
"<"
x
$n
,
": $t->{directive}\n"
if
$verbose_parse
;
return
\
@tt
if
(
$t
->{
'directive'
} eq
$term
);
if
(
$t
->{
'directive'
} eq
'['
){
print
STDERR
"PP->[\n"
if
$verbose_parse
> 1;
my
(
$l
) = parser(
']'
,
$n
+1,
$tnext
);
my
(
@l
) = @{
$l
};
my
(
@nn
,
@ll
);
my
(
$n
) = 0;
while
(
@l
){
$l
=
shift
@l
;
if
(
$l
->{
'directive'
} eq
";"
){
push
@nn
, [
@ll
];
$t
->{
'default_item'
} = (
$n
+1)
if
$l
->{
'colon'
};
@ll
= ();
$n
++;
}
else
{
push
@ll
,
$l
;
}
}
push
@nn
, [
@ll
];
$t
->{
'subparts'
} = \
@nn
;
print
STDERR
"PP->]\n"
if
$verbose_parse
> 1;
}
if
(
$t
->{
'directive'
} eq
'<'
){
print
STDERR
"PP-><\n"
if
$verbose_parse
> 1;
my
(
$l
) = parser(
'>'
,
$n
+1,
$tnext
);
my
(
@l
) = @{
$l
};
my
(
@nn
,
@ll
);
my
(
$n
) = 0;
while
(
@l
){
$l
=
shift
@l
;
if
(
$l
->{
'directive'
} eq
";"
){
push
@nn
, [
@ll
];
@ll
= ();
$n
++;
}
else
{
push
@ll
,
$l
;
}
}
push
@nn
, [
@ll
];
$t
->{
'subparts'
} = \
@nn
;
print
STDERR
"PP->>\n"
if
$verbose_parse
> 1;
}
if
(
$t
->{
'directive'
} eq
'{'
){
print
STDERR
"PP->{\n"
if
$verbose_parse
> 1;
my
(
$b
) = parser(
'}'
,
$n
+1,
$tnext
);
if
( @{
$b
} != 0 ){
$t
->{
'body'
} =
$b
;
}
print
STDERR
"PP->}\n"
if
$verbose_parse
> 1;
}
if
(
$t
->{
'directive'
} eq
'('
){
print
STDERR
"PP->(\n"
if
$verbose_parse
> 1;
$t
->{
'body'
} = parser(
')'
,
$n
+1,
$tnext
);
print
STDERR
"PP->)\n"
if
$verbose_parse
> 1;
}
if
(
$t
->{
'directive'
} eq
'/'
){
my
(
$tt
);
$tt
=
&$tnext
();
$tt
->{
'directive'
} eq
'literal'
||
return
formaterror(
"I was expecting a function name. Pity."
,
$tt
);
$t
->{
'funcname'
} =
$tt
->{
'text'
};
$tt
=
&$tnext
();
$tt
->{
'directive'
} eq
'/'
||
return
formaterror(
"I see no matching / here"
,
$tt
);
}
if
(
$t
->{
'directive'
} eq
'=('
){
print
STDERR
"PP->=(\n"
if
$verbose_parse
> 1;
$t
->{
'body'
} = parser(
'=)'
,
$n
+1,
$tnext
);
print
STDERR
"PP->=)\n"
if
$verbose_parse
> 1;
}
push
@tt
, reduce(
$t
);
}
}
sub
reduce {
my
(
$t
) =
@_
;
my
(
@n
);
my
(
$d
);
$d
=
$t
->{
'directive'
};
print
STDERR
"R: $d\n"
if
$verbose_reduce
;
if
(
$d
=~ /^[DOXBR]$/ ){
$t
->{
'directive'
} =
'number'
;
$t
->{
'radix'
} = 10
if
$d
eq
"D"
;
$t
->{
'radix'
} = 8
if
$d
eq
"O"
;
$t
->{
'radix'
} = 16
if
$d
eq
"X"
;
$t
->{
'radix'
} = 2
if
$d
eq
"B"
;
if
(
$d
eq
"R"
){
@n
= @{
$t
->{
'numbers'
}};
$t
->{
'radix'
} =
shift
@n
;
$t
->{
'numbers'
} = [
@n
];
if
( !
$t
->{
'radix'
} ){
if
(
$t
->{
'atsign'
} ){
$t
->{
'directive'
} =
'roman'
;
}
else
{
$t
->{
'directive'
} =
'english'
;
}
}
}
print
STDERR
"R-> number, $t->{'radix'}\n"
if
$verbose_reduce
> 1;
}
if
(
$d
=~ /^[ASW]$/ ){
$t
->{
'directive'
} =
'A'
;
$t
->{
'how'
} =
$d
eq
'A'
? 0 : 1;
}
if
(
$d
=~ /^[
%_
|~]$/ ){
my
(
$c
,
$n
);
@n
= @{
$t
->{
'numbers'
}};
$n
=
shift
@n
||
""
;
$n
= 1
if
$n
eq
""
;
$c
=
""
;
$c
=
" "
if
$d
eq
"_"
;
$c
=
"~"
if
$d
eq
"~"
;
$c
=
"\n"
if
$d
eq
"%"
;
$c
=
"\f"
if
$d
eq
"|"
;
if
(
$n
!~ /\d/ ){
$t
->{
'directive'
} =
"repeat"
;
$t
->{
'text'
} =
$c
;
}
else
{
$t
->{
'text'
} =
$c
x
$n
;
$t
->{
'directive'
} =
"literal"
;
}
print
STDERR
"R-> $d rewrite $t->{'directive'}\n"
if
$verbose_reduce
> 1;
}
if
(
$d
=~ /^\n/ ){
my
(
$sp
) =
$d
;
$sp
=~ s/\n//;
$t
->{
'text'
} = (
$t
->{
'atsign'
} ?
"\n"
:
""
) . (
$t
->{
'colon'
} ?
$sp
:
""
);
$t
->{
'directive'
} =
"literal"
;
print
STDERR
"R-> whitespace literal\n"
if
$verbose_reduce
> 1;
}
$t
;
}
sub
formaterror {
my
(
$msg
,
$t
) =
@_
;
my
(
$fmt
);
$fmt
=
$t
->{
'fullfmt'
};
$fmt
=~ s/\n/\$/g;
print
STDERR
"\n## FORMAT ERROR: $msg\n"
;
print
STDERR
"## \t\""
,
$fmt
,
"\"\n"
;
print
STDERR
"## \t "
,
" "
x
$t
->{
'fmtoffset'
},
"^\n"
;
"error"
;
}
my
(
$_fmtobja
,
$_fmtobjs
) = (
""
,
""
);
sub
objecttostring {
my
(
$how
,
$obj
) =
@_
;
if
(
ref
(
$obj
) ){
if
(
ref
(
$obj
) eq
"SCALAR"
){
if
(
$how
){
fmt(
"\\~s"
,
$$obj
);
}
else
{
fmt(
"\\~a"
,
$$obj
);
}
}
elsif
(
ref
(
$obj
) eq
"CODE"
){
"CODE"
;
}
elsif
(
ref
(
$obj
) eq
"GLOB"
){
"GLOB"
;
}
else
{
my
(
$fmta
,
$fmtb
);
if
(
$how
){
$_fmtobjs
= compile(
"~#[~;~s~:;~!{~#[~;~s~:;~s, ~]~}~]"
)
unless
$_fmtobjs
;
$fmtb
=
$_fmtobjs
;
}
else
{
$_fmtobja
= compile(
"~#[~;~a~:;~!{~#[~;~a~:;~a, ~]~}~]"
)
unless
$_fmtobja
;
$fmtb
=
$_fmtobja
;
}
$fmta
=
"<~?>"
;
$fmta
=
"[~?]"
if
ref
(
$obj
) eq
"ARRAY"
;
$fmta
=
"{~?}"
if
ref
(
$obj
) eq
"HASH"
;
fmt(
$fmta
,
$fmtb
,
$obj
);
}
}
elsif
(
$obj
=~ /^[+-]?\d+$/ ){
"$obj"
;
}
elsif
(
$obj
=~ /^[+-]\d*\.\d*$/ ){
"$obj"
;
}
else
{
if
(
$how
){
qq("$obj")
;
}
else
{
"$obj"
;
}
}
}
sub
formatstring {
my
(
$how
,
$mincol
,
$colinc
,
$minpad
,
$padchar
,
$ovchar
,
$gravity
,
$obj
) =
@_
;
my
(
$str
) = objecttostring(
$how
,
$obj
);
my
(
$l
,
$w
,
$padamt
,
$maxcolp
);
$padchar
=
chr
(
$padchar
)
if
(
$padchar
=~ /^\d+$/ );
$ovchar
=
chr
(
$ovchar
)
if
(
$ovchar
=~ /^\d+$/ );
print
STDERR
"F: $how, MC:$mincol, C:$colinc, MP:$minpad, P:$padchar, OV:$ovchar, G:$gravity, O:$obj\n"
if
$verbose_fmt
;
$l
=
length
(
$str
) +
$minpad
;
$w
=
abs
(
$mincol
?
$mincol
:0);
$padamt
=
$colinc
*
int
(((
$w
-
$l
) +
$colinc
- 1) /
$colinc
);
$maxcolp
= (
$mincol
ne
""
) && (
$mincol
< 0);
print
STDERR
"F: $l, $w, $padamt, $maxcolp, $str\n"
if
$verbose_fmt
;
if
(
$gravity
eq
"r"
){
$str
=
$padchar
x
$minpad
.
$str
;
}
elsif
(
$gravity
eq
"l"
){
$str
.=
$padchar
x
$minpad
;
}
if
(
$l
==
$w
){
}
elsif
(
$l
>
$w
){
if
(
$maxcolp
){
my
(
$fl
) =
$w
- 1;
if
(
$gravity
eq
"r"
){
$str
=~ s/^(.{
$fl
}).*$/$1
$ovchar
/;
}
else
{
$str
=~ s/^(.{
$fl
}).*$/
$ovchar
$1/;
}
}
}
else
{
if
(
$gravity
eq
"r"
){
$str
=
$padchar
x
$padamt
.
$str
;
}
elsif
(
$gravity
eq
"l"
){
$str
.=
$padchar
x
$padamt
;
}
else
{
my
(
$rp
,
$lp
);
$rp
=
int
( (
$w
-
$l
) / 2 );
$lp
=
$w
-
$l
-
$rp
;
$str
=
$padchar
x
$lp
.
$str
.
$padchar
x
$rp
;
}
}
$str
;
}
sub
formatnumber {
my
(
$radix
,
$mincol
,
$padchar
,
$commachar
,
$commawidth
,
$ovchar
,
$withsign
,
$withcommas
,
$val
) =
@_
;
my
(
$str
,
$sign
,
@cs
);
$str
=
""
;
$val
=
int
(
$val
);
if
(
$val
< 0 ){
$val
= -
$val
;
$sign
=
"-"
;
}
elsif
(
$withsign
){
$sign
=
"+"
;
}
else
{
$sign
=
""
;
}
if
(
$radix
== 1 ){
$str
=
"1"
x
$val
;
}
else
{
@cs
=
split
//,
"0123456789abcdefghijklmnopqrstuvwxyz"
;
while
(
$val
){
$str
=
$cs
[
$val
%
$radix
] .
$str
;
$val
=
int
(
$val
/
$radix
);
}
}
if
(
$withcommas
){
1
while
$str
=~ s/^(-?\d+)(\d{
$commawidth
})/$1
$commachar
$2/;
}
formatstring(0,
$mincol
, 1, 0,
$padchar
,
$ovchar
,
"r"
,
"$sign$str"
);
}
sub
roman {
my
(
$oldway
,
$val
) =
@_
;
my
(
$rc
,
$rv
,
$i
,
$str
);
my
(
@rc
,
@rv
);
@rc
=
qw(/M /D /C /L /X /V M D C L X V I)
;
@rv
=
qw(1000000 500000 100000 50000 10000 5000 1000 500 100 50 10 5 1 0 0)
;
$i
= 0;
$str
=
''
;
while
(
$val
){
if
(
$val
>=
$rv
[
$i
] ){
$str
.=
$rc
[
$i
];
$val
-=
$rv
[
$i
];
}
elsif
(
$val
<=
$rv
[
$i
+1] ){
$i
++;
}
elsif
( !
$oldway
&& (
$i
&1)==0 && (
$val
>= (
$rv
[
$i
] -
$rv
[
$i
+2])) ){
$str
.=
$rc
[
$i
+2];
$str
.=
$rc
[
$i
];
$val
-=
$rv
[
$i
] -
$rv
[
$i
+2];
}
elsif
( !
$oldway
&& (
$i
&1)!=0 && (
$val
>= (
$rv
[
$i
] -
$rv
[
$i
+1])) ){
$str
.=
$rc
[
$i
+1];
$str
.=
$rc
[
$i
];
$val
-=
$rv
[
$i
] -
$rv
[
$i
+1];
}
else
{
$i
++;
}
}
$str
;
}
sub
englishsmall {
my
(
$ordinal
,
$val
) =
@_
;
my
(
$n
,
$str
);
my
(
@units
,
@ounits
,
@tens
,
@otens
);
@units
=
qw(zero one two three four five six seven eight nine
ten eleven twelve thirteen fourteen fifteen sixteen
seventeen eighteen nineteen)
;
@ounits
=
qw(zeroth first second third fourth fifth sixth seventh
eighth ninth tenth eleventh twelfth)
;
@tens
=
qw(twenty thirty forty fifty sixty seventy eighty ninety)
;
@otens
=
qw(twentieth thirtieth fortieth fiftieth sixtieth seventieth eightieth ninetieth)
;
unshift
@tens
,
""
;
unshift
@tens
,
""
;
unshift
@otens
,
""
;
unshift
@otens
,
""
;
$str
=
""
;
if
(
$val
>= 100 ){
$str
.=
" "
.
$units
[
$val
/ 100 ] .
" hundred"
;
$val
%= 100;
$str
.=
"th"
if
$ordinal
&& !
$val
;
}
if
(
$val
>= 20 ){
$n
=
$val
% 10;
if
(
$ordinal
&& !
$n
){
$str
.=
" "
.
$otens
[
$val
/ 10 ];
}
else
{
$str
.=
" "
.
$tens
[
$val
/ 10 ];
}
$val
=
$n
;
}
if
(
$val
){
if
(
$ordinal
){
if
(
$val
<
@ounits
){
$str
.=
" "
.
$ounits
[
$val
];
}
else
{
$str
.=
" "
.
$units
[
$val
] .
"th"
;
}
}
else
{
$str
.=
" "
.
$units
[
$val
];
}
}
$str
=~ s/^ //;
$str
;
}
sub
english {
my
(
$ordinal
,
$val
) =
@_
;
my
(
@illions
);
my
(
$ordd
,
$f
);
@illions
=
qw(thousand million billion trillion quadrillion quintillion
sextillion septillion octillion nonillion decillion undecillion
duodecillion tredecillion quattuordecillion quindecillion
sexdecillion septdecillion octodecillion novemdecillion vigintillion)
;
unshift
@illions
,
""
;
$f
=
sub
{
my
(
$val
,
$k
) =
@_
;
my
(
$n
,
$r
,
$str
);
$str
=
""
;
$n
=
$val
% 1000;
$r
=
int
(
$val
/ 1000);
if
(
$r
){
$str
.=
&$f
(
$r
,
$k
+ 1);
if
(
$n
){
if
( !
$k
&& (
$n
< 100) ){
$str
.=
" and "
;
}
else
{
$str
.=
", "
;
}
}
}
if
(
$n
){
my
(
$o
);
$o
=
$ordinal
&& (
$k
==0);
$ordd
= 1
if
(
$o
);
$str
.= englishsmall(
$o
,
$n
);
}
if
(
$k
&&
$n
){
$str
.=
" "
;
if
(
$k
>
@illions
){
$str
.=
"times ten to the "
. english(1,
$k
* 3);
}
else
{
$str
.=
$illions
[
$k
];
}
}
$str
;
};
if
( !
$val
){
if
(
$ordinal
){
return
"zeroth"
;
}
else
{
return
"zero"
;
}
}
elsif
(
$val
< 0 ){
return
"minus "
. english(
$ordinal
, -
$val
);
}
else
{
&$f
(
$val
, 0) . ((
$ordinal
&& !
$ordd
) ?
"th"
:
""
);
}
}
sub
falsep {
my
(
$val
) =
@_
;
if
(
$config_zero_is_false
){
$val
? 0 : 1;
}
else
{
$val
eq
""
;
}
}
sub
mkarray {
my
(
$a
) =
@_
;
my
(
@a
);
if
(
$a
=~ /ARRAY/ ){
@a
= @{
$a
};
}
elsif
(
$a
=~ /HASH/ ){
@a
= %{
$a
};
}
else
{
@a
= (
$a
);
}
@a
;
}
sub
capitalize {
my
(
$s
) =
@_
;
$s
=
ucfirst
(
lc
(
$s
));
$s
=~ s/\b(\w)/\U$1/g;
$s
;
}
sub
nextarg {
return
""
if
(
$argno
>=
@arglist
);
return
$arglist
[
$argno
++ ];
}
sub
pound {
return
0
if
(
$argno
>=
@arglist
);
return
@arglist
-
$argno
;
}
sub
param {
my
(
$t
,
$nth
,
$dfl
) =
@_
;
my
(
$n
,
@n
);
@n
= @{
$t
->{
'numbers'
}};
return
$dfl
if
(
$nth
>=
@n
);
$n
=
$n
[
$nth
];
return
nextarg()
if
(
$n
eq
"v"
);
return
pound()
if
(
$n
eq
"#"
);
return
$dfl
if
$n
eq
""
;
$n
;
}
sub
run {
my
(
$t
) =
@_
;
my
(
$d
,
@t
);
@t
= @{
$t
};
while
(
@t
){
$t
=
shift
@t
;
$d
=
$t
->{
'directive'
};
print
STDERR
"U: $d\n"
if
$verbose_run
;
if
(
$d
eq
'literal'
){
$accum
.=
$t
->{
'text'
};
}
elsif
(
$d
eq
'repeat'
){
$accum
.=
$t
->{
'text'
} x param(
$t
, 0, 1);
}
elsif
(
$d
eq
"&"
){
my
(
$n
) = param(
$t
, 0, 1);
next
unless
$n
;
$accum
.=
"\n"
unless
(
$accum
=~ /\n$/ );
if
(
$n
> 1 ){
$accum
.=
"\n"
x (
$n
- 1);
}
}
elsif
(
$d
eq
"T"
){
my
(
$colnum
,
$colinc
,
$tabchar
);
my
(
$l
) =
$accum
;
my
(
$cp
,
$mp
);
$colnum
= param(
$t
,0,1);
$colinc
= param(
$t
,1,1);
$tabchar
= param(
$t
,2,
" "
);
$l
=~ s/.*\n$//;
$cp
=
length
$l
;
$mp
= 0;
if
(
$t
->{
'atsign'
} ){
if
(
$colinc
){
$mp
=
$colnum
+
$colinc
- ((
$cp
+
$colnum
) %
$colinc
);
}
}
else
{
$mp
=
$colnum
-
$cp
;
if
(
$mp
< 0 ){
if
(
$colinc
){
$mp
=
$colnum
+
$colinc
- (
$cp
%
$colinc
);
$mp
=
$mp
-
$colinc
if
$mp
>=
$colinc
;
}
}
}
$accum
.=
$tabchar
x
$mp
;
}
elsif
(
$d
eq
'A'
){
$accum
.=
formatstring(
$t
->{
'how'
}, param(
$t
,0,
""
), param(
$t
,1,1),
param(
$t
,2,0), param(
$t
,3,
" "
),
param(
$t
,4,
"*"
),
$t
->{
'gravity'
} || (
$t
->{
'atsign'
} ?
"r"
:
"l"
),
nextarg() );
}
elsif
(
$d
eq
'*'
){
my
(
$n
) = param(
$t
, 0,
$t
->{
'atsign'
} ? 0 : 1);
$n
= -
$n
if
(
$t
->{
'colon'
} );
if
(
$t
->{
'atsign'
} ){
$argno
=
$n
;
}
else
{
$argno
+=
$n
;
}
$argno
= 0
if
(
$argno
< 0 );
}
elsif
(
$d
eq
'?'
){
my
(
$fmt
) = nextarg();
my
(
$rv
);
if
(
$t
->{
'atsign'
} ){
$rv
= run(
ref
(
$fmt
) ?
$fmt
: compile(
$fmt
));
}
else
{
my
(
$a
) = nextarg();
local
(
$argno
) = 0;
local
(
@arglist
);
@arglist
= mkarray(
$a
);
$rv
= run(
ref
(
$fmt
) ?
$fmt
: compile(
$fmt
));
}
return
$rv
if
$rv
;
}
elsif
(
$d
eq
'P'
){
my
(
$n
);
if
(
$t
->{
'colon'
} ){
$n
=
$arglist
[
$argno
- 1 ];
}
else
{
$n
= nextarg();
}
if
(
$n
== 1 ){
$accum
.=
"y"
if
$t
->{
'atsign'
};
}
else
{
if
(
$t
->{
'atsign'
} ){
$accum
.=
"ies"
;
}
else
{
$accum
.=
"s"
;
}
}
}
elsif
(
$d
eq
'C'
){
my
(
@cv
) =
qw(NUL SOH STX ETX EOT ENQ ACK BEL BS HT NL
VT NP CR SO SI DLE DC1 DC2 DC3 DC4 NAK
SYN ETB CAN EM SUB ESC FS GS RS US SP)
;
my
(
$n
) = param(
$t
, 0,
""
);
my
(
$c
,
$str
);
$n
= nextarg()
if
$n
eq
""
;
$n
=
ord
(
$n
)
unless
$n
=~ /^\d+$/;
$c
=
chr
(
$n
);
if
(
$t
->{
'colon'
} ){
if
(
$t
->{
'atsign'
} &&
$n
&&
$n
< 27 ){
$str
=
"Control-"
.
chr
(
$n
+
ord
(
'A'
));
}
elsif
(
$n
<
@cv
){
$str
=
$cv
[
$n
];
}
elsif
(
$n
>= 127 ){
if
(
$t
->{
'atsign'
} ){
$str
=
"Meta-"
. fmt(
"~:!C"
,
$n
& 127);
}
else
{
$str
=
sprintf
"\\0%o"
,
$n
;
}
}
else
{
$str
=
$c
;
}
}
else
{
if
(
$t
->{
'atsign'
} ){
if
( (
$n
>= 127) || (
$n
<
@cv
) ){
$str
=
sprintf
"\"\\0%o\""
,
$n
;
}
else
{
$str
=
"\"$c\""
;
}
}
else
{
$str
=
$c
;
}
}
$accum
.=
$str
;
}
elsif
(
$d
eq
'('
){
my
(
$str
,
$rv
);
do
{
local
(
$accum
) = (
""
);
$rv
= run(
$t
->{
'body'
} );
$str
=
$accum
;
if
(
$t
->{
'colon'
} ){
if
(
$t
->{
'atsign'
} ){
$str
=
uc
(
$str
);
}
else
{
$str
= capitalize(
$str
);
}
}
else
{
if
(
$t
->{
'atsign'
} ){
$str
=
ucfirst
(
lc
(
$str
));
}
else
{
$str
=
lc
(
$str
);
}
}
};
$accum
.=
$str
;
return
$rv
if
$rv
;
}
elsif
(
$d
eq
'/'
){
my
(
$func
,
$str
,
$p
,
@p
);
$func
=
$t
->{
'funcname'
};
foreach
$p
( @{
$t
->{
'numbers'
}} ){
$p
= pound()
if
(
$p
eq
"#"
);
$p
= nextarg()
if
(
$p
eq
"v"
);
push
@p
,
$p
;
}
$str
= nextarg();
$str
=
"$func($str, $t->{'colon'}, t->{'atsign'}"
;
$str
.=
", "
.
join
(
", "
,
@p
)
if
(
@p
);
$str
.=
")"
;
$accum
.=
eval
(
$str
);
}
elsif
(
$d
eq
'<'
){
my
(
$str
,
$rv
,
$n
,
$s
);
my
(
@str
);
my
(
$mincol
,
$colinc
,
$minpad
,
$padchar
) =
(param(
$t
,0,
""
), param(
$t
,1,1),
param(
$t
,2,0), param(
$t
,3,
" "
));
do
{
local
(
$accum
);
foreach
$s
( @{
$t
->{
'subparts'
}} ){
$accum
=
""
;
$rv
= run(
$s
);
last
if
$rv
=~ /hat/;
push
@str
,
$accum
;
$n
++;
}
};
if
(
$n
== 1 ){
$str
= formatstring( 0,
$mincol
,
$colinc
,
$minpad
,
$padchar
,
"*"
,
$t
->{
'atsign'
} ? (
$t
->{
'colon'
} ?
'c'
:
'l'
) :
'r'
,
$str
[0] );
}
elsif
(
$n
>= 2 ){
my
(
$rspace
,
$lspace
,
$space
,
$m
);
$rspace
=
$mincol
;
$m
= 0;
$str
=
''
;
foreach
$s
(
@str
){
$space
=
$rspace
/ (
$n
-
$m
);
$rspace
-=
$space
;
$str
.= formatstring( 0,
$space
,
$colinc
,
$m
?
$minpad
:0,
$padchar
,
"*"
,
$m
==0 ? (
$t
->{
'colon'
} ?
'r'
:
'l'
) :
(
$m
==
$n
-1 ? (
$t
->{
'atsign'
} ?
'l'
:
'r'
) :
$config_align_middle
),
$str
[
$m
]);
$m
++;
}
}
$accum
.=
$str
;
}
elsif
(
$d
eq
'{'
){
my
(
$maxiter
) = param(
$t
, 0,
""
);
my
(
$maxiterp
) =
$maxiter
ne
""
? 1 : 0;
my
(
$retv
);
my
(
$body
) =
$t
->{
'body'
};
if
( !
$body
){
$body
= nextarg();
return
formaterror(
"An empty {} may be less filling, but it won't work"
,
$t
)
unless
$body
;
$body
= compile(
$body
);
}
if
(
$t
->{
'colon'
} &&
$t
->{
'atsign'
} ){
while
( !
$maxiterp
||
$maxiter
-- ){
my
(
$a
,
@a
);
last
if
$argno
>=
@arglist
;
$a
= nextarg();
@a
= mkarray(
$a
);
do
{
local
(
$argno
) = 0;
local
(
@arglist
) =
@a
;
$retv
= run(
$body
);
last
if
(
$retv
=~ /colon/ );
};
}
}
elsif
(
$t
->{
'colon'
} ){
my
(
$a
,
@a
);
$a
= nextarg();
@a
= @{
$a
};
while
( !
$maxiterp
||
$maxiter
-- ){
last
unless
@a
;
do
{
local
(
$argno
) = 0;
local
(
@arglist
) = @{
shift
@a
};
$retv
= run(
$body
);
last
if
(
$retv
=~ /colon/ );
};
}
}
elsif
(
$t
->{
'atsign'
} ){
while
( !
$maxiterp
||
$maxiter
-- ){
last
if
$argno
>=
@arglist
;
$retv
= run(
$body
);
last
if
(
$retv
=~ /hat/ );
}
}
else
{
my
(
$a
,
@a
);
$a
= nextarg();
@a
= mkarray(
$a
);
do
{
local
(
$argno
) = 0;
local
(
@arglist
) =
@a
;
while
( !
$maxiterp
||
$maxiter
-- ){
last
if
$argno
>=
@arglist
;
$retv
= run(
$body
);
last
if
(
$retv
=~ /hat/ );
}
};
}
}
elsif
(
$d
eq
'['
){
my
(
@ch
) = @{
$t
->{
'subparts'
}};
my
(
$ni
) =
scalar
@ch
;
my
(
$n
) = param(
$t
, 0,
""
);
my
(
$rv
);
$n
= nextarg()
if
$n
eq
""
;
if
(
$t
->{
'atsign'
} ){
$argno
--
if
( !falsep(
$n
) );
$n
= !falsep(
$n
) ? 0 : 1;
}
elsif
(
$t
->{
'colon'
} ){
$n
= falsep(
$n
) ? 0 : 1;
}
if
(
$n
>=
$ni
&& (
defined
$t
->{
'default_item'
} ) ){
$n
=
$t
->{
'default_item'
};
}
if
(
$n
<
$ni
){
my
(
$str
);
do
{
local
(
$accum
) = (
""
);
$rv
= run(
$t
->{
'subparts'
}[
$n
] );
$str
=
$accum
;
};
$accum
.=
$str
;
}
return
$rv
if
$rv
;
}
elsif
(
$d
eq
'^'
){
my
(
$np
,
$out
);
$np
= @{
$t
->{
'numbers'
}};
if
(
$np
== 1 ){
$out
= 1
if
param(
$t
, 0,
""
) == 0;
}
elsif
(
$np
== 2 ){
$out
= 1
if
param(
$t
, 0,
""
) == param(
$t
, 1,
""
);
}
elsif
(
$np
== 3 ){
$out
= 1
if
(param(
$t
, 0,
""
) <= param(
$t
, 1,
""
))
&& (param(
$t
, 1,
""
) <= param(
$t
, 2,
""
));
}
else
{
$out
= 1
if
$argno
>=
@arglist
;
}
if
(
$out
){
return
"hat/colon"
if
(
$t
->{
'colon'
} );
return
"hat"
;
}
}
elsif
(
$d
eq
'number'
){
my
(
$r
);
$r
=
$t
->{
'radix'
};
$r
= pound()
if
(
$r
eq
"#"
);
$r
= nextarg()
if
(
$r
eq
"v"
);
return
formaterror(
"In base $r? I'm game. Would you care to explain how?"
,
$t
)
if
(
$r
<1 ||
$r
>36 );
$accum
.=
formatnumber(
$r
, param(
$t
,0,
""
), param(
$t
,1,
" "
),
param(
$t
,2,
","
), param(
$t
,3,3), param(
$t
,4,
"*"
),
(
$t
->{
'atsign'
}?1:0), (
$t
->{
'colon'
}?1:0),
nextarg());
}
elsif
(
$d
eq
'roman'
){
$accum
.= formatstring(0, param(
$t
,0,
""
), 1, 0, param(
$t
,1,
" "
),
param(
$t
,4,
"*"
),
"r"
,
roman(
$t
->{
'colon'
}, nextarg()));
}
elsif
(
$d
eq
'english'
){
$accum
.= formatstring(0, param(
$t
,0,
""
), 1, 0, param(
$t
,1,
" "
),
param(
$t
,4,
"*"
),
"r"
,
english(
$t
->{
'colon'
}, nextarg()));
}
elsif
(
$d
eq
'=V'
){
$accum
.=
"Good morning Dr. Chandra, I am "
if
$t
->{
'atsign'
};
$accum
.=
"Fmt Version "
if
$t
->{
'colon'
};
$accum
.=
"$VERSION"
;
}
elsif
(
$d
eq
'=('
){
my
(
$str
,
$rv
,
$fmt
);
do
{
local
(
$accum
) = (
""
);
$rv
= run(
$t
->{
'body'
} );
$str
=
$accum
;
$accum
=
''
;
$fmt
= compile(
$str
);
$rv
= run(
$fmt
);
$str
=
$accum
;
};
$accum
.=
$str
;
return
$rv
if
$rv
;
}
elsif
(
$d
eq
'=F'
){
my
(
$null
,
$i
,
$n
,
$m
,
$f
);
$n
= param(
$t
,0,
''
);
$m
= param(
$t
,1,
''
);
$f
= nextarg();
$i
= 1;
open
(FMT_FILE,
$f
) ||
return
formaterror(
"'$f' is stubborn and refuses to open: $!"
,
$t
);
if
(
$n
ne
''
){
while
(
$n
!=
$i
&& !
eof
(FMT_FILE) ){
$null
= <FMT_FILE>;
$i
++;
}
if
(
$m
ne
''
){
while
(
$m
+ 1 !=
$i
++ && !
eof
(FMT_FILE) ){
$accum
.= <FMT_FILE>;
}
}
else
{
$accum
.= <FMT_FILE>;
}
}
else
{
$accum
.=
$_
while
( <FMT_FILE> );
}
close
(FMT_FILE);
}
elsif
(
$d
eq
')'
){
return
formaterror(
"I see no matching ( here"
,
$t
);
}
elsif
(
$d
eq
'}'
){
return
formaterror(
"I see no matching { here"
,
$t
);
}
elsif
(
$d
eq
']'
){
return
formaterror(
"I see no matching [ here"
,
$t
);
}
elsif
(
$d
eq
';'
){
return
formaterror(
"I see no enclosing [] or <> here"
,
$t
);
}
else
{
return
formaterror(
"I don't know how to apply that word ($d) here."
,
$t
);
}
}
""
;
}
sub
tree {
my
(
$n
,
$t
) =
@_
;
my
(
$nn
,
@t
,
@nn
);
@t
= @{
$t
};
while
(
@t
){
$t
=
shift
@t
;
print
" "
x
$n
,
"$t->{'directive'}\n"
;
tree(
$n
+1,
$t
->{
'body'
} )
if
(
$t
->{
'body'
} );
if
(
$t
->{
'subparts'
} ){
@nn
= @{
$t
->{
'subparts'
}};
while
(
@nn
){
$nn
=
shift
@nn
;
tree(
$n
+1,
$nn
);
print
" "
x
$n
,
" ;\n"
;
}
}
}
}
sub
compile {
my
(
$fmt
) =
@_
;
parse(tok(
$fmt
));
}
sub
fmt {
my
(
$fmt
) =
shift
;
local
(
@arglist
) =
@_
;
local
(
$argno
) = 0;
local
(
$accum
) =
""
;
run(
ref
(
$fmt
) ?
$fmt
: compile(
$fmt
));
$accum
;
}
sub
pfmt {
print
fmt(
@_
);
}
;
1;