?????????? ????????? - ??????????????? - /home/agenciai/public_html/cd38d8/perl5.tar
???????
5.32/version/Internals.pod 0000444 00000055703 15125513451 0011275 0 ustar 00 =head1 NAME version::Internals - Perl extension for Version Objects =head1 DESCRIPTION Overloaded version objects for all modern versions of Perl. This documents the internal data representation and underlying code for version.pm. See F<version.pod> for daily usage. This document is only useful for users interested in the gory details. =head1 WHAT IS A VERSION? For the purposes of this module, a version "number" is a sequence of positive integer values separated by one or more decimal points and optionally a single underscore. This corresponds to what Perl itself uses for a version, as well as extending the "version as number" that is discussed in the various editions of the Camel book. There are actually two distinct kinds of version objects: =over 4 =item Decimal versions Any version which "looks like a number", see L<Decimal Versions>. This also includes versions with a single decimal point and a single embedded underscore, see L<Alpha Versions>, even though these must be quoted to preserve the underscore formatting. =item Dotted-Decimal versions Also referred to as "Dotted-Integer", these contains more than one decimal point and may have an optional embedded underscore, see L<Dotted-Decimal Versions>. This is what is commonly used in most open source software as the "external" version (the one used as part of the tag or tarfile name). A leading 'v' character is now required and will warn if it missing. =back Both of these methods will produce similar version objects, in that the default stringification will yield the version L<Normal Form> only if required: $v = version->new(1.002); # 1.002, but compares like 1.2.0 $v = version->new(1.002003); # 1.002003 $v2 = version->new("v1.2.3"); # v1.2.3 In specific, version numbers initialized as L<Decimal Versions> will stringify as they were originally created (i.e. the same string that was passed to C<new()>. Version numbers initialized as L<Dotted-Decimal Versions> will be stringified as L<Normal Form>. =head2 Decimal Versions These correspond to historical versions of Perl itself prior to 5.6.0, as well as all other modules which follow the Camel rules for the $VERSION scalar. A Decimal version is initialized with what looks like a floating point number. Leading zeros B<are> significant and trailing zeros are implied so that a minimum of three places is maintained between subversions. What this means is that any subversion (digits to the right of the decimal place) that contains less than three digits will have trailing zeros added to make up the difference, but only for purposes of comparison with other version objects. For example: # Prints Equivalent to $v = version->new( 1.2); # 1.2 v1.200.0 $v = version->new( 1.02); # 1.02 v1.20.0 $v = version->new( 1.002); # 1.002 v1.2.0 $v = version->new( 1.0023); # 1.0023 v1.2.300 $v = version->new( 1.00203); # 1.00203 v1.2.30 $v = version->new( 1.002003); # 1.002003 v1.2.3 All of the preceding examples are true whether or not the input value is quoted. The important feature is that the input value contains only a single decimal. See also L<Alpha Versions>. IMPORTANT NOTE: As shown above, if your Decimal version contains more than 3 significant digits after the decimal place, it will be split on each multiple of 3, so 1.0003 is equivalent to v1.0.300, due to the need to remain compatible with Perl's own 5.005_03 == 5.5.30 interpretation. Any trailing zeros are ignored for mathematical comparison purposes. =head2 Dotted-Decimal Versions These are the newest form of versions, and correspond to Perl's own version style beginning with 5.6.0. Starting with Perl 5.10.0, and most likely Perl 6, this is likely to be the preferred form. This method normally requires that the input parameter be quoted, although Perl's after 5.8.1 can use v-strings as a special form of quoting, but this is highly discouraged. Unlike L<Decimal Versions>, Dotted-Decimal Versions have more than a single decimal point, e.g.: # Prints $v = version->new( "v1.200"); # v1.200.0 $v = version->new("v1.20.0"); # v1.20.0 $v = qv("v1.2.3"); # v1.2.3 $v = qv("1.2.3"); # v1.2.3 $v = qv("1.20"); # v1.20.0 In general, Dotted-Decimal Versions permit the greatest amount of freedom to specify a version, whereas Decimal Versions enforce a certain uniformity. Just like L</Decimal Versions>, Dotted-Decimal Versions can be used as L</Alpha Versions>. =head2 Alpha Versions For module authors using CPAN, the convention has been to note unstable releases with an underscore in the version string. (See L<CPAN>.) version.pm follows this convention and alpha releases will test as being newer than the more recent stable release, and less than the next stable release. Only the last element may be separated by an underscore: # Declaring use version 0.77; our $VERSION = version->declare("v1.2_3"); # Parsing $v1 = version->parse("v1.2_3"); $v1 = version->parse("1.002_003"); Note that you B<must> quote the version when writing an alpha Decimal version. The stringified form of Decimal versions will always be the same string that was used to initialize the version object. =head2 Regular Expressions for Version Parsing A formalized definition of the legal forms for version strings is included in the C<version::regex> class. Primitives are included for common elements, although they are scoped to the file so they are useful for reference purposes only. There are two publicly accessible scalars that can be used in other code (not exported): =over 4 =item C<$version::LAX> This regexp covers all of the legal forms allowed under the current version string parser. This is not to say that all of these forms are recommended, and some of them can only be used when quoted. For dotted decimals: v1.2 1.2345.6 v1.23_4 The leading 'v' is optional if two or more decimals appear. If only a single decimal is included, then the leading 'v' is required to trigger the dotted-decimal parsing. A leading zero is permitted, though not recommended except when quoted, because of the risk that Perl will treat the number as octal. A trailing underscore plus one or more digits denotes an alpha or development release (and must be quoted to be parsed properly). For decimal versions: 1 1.2345 1.2345_01 an integer portion, an optional decimal point, and optionally one or more digits to the right of the decimal are all required. A trailing underscore is permitted and a leading zero is permitted. Just like the lax dotted-decimal version, quoting the values is required for alpha/development forms to be parsed correctly. =item C<$version::STRICT> This regexp covers a much more limited set of formats and constitutes the best practices for initializing version objects. Whether you choose to employ decimal or dotted-decimal for is a personal preference however. =over 4 =item v1.234.5 For dotted-decimal versions, a leading 'v' is required, with three or more sub-versions of no more than three digits. A leading 0 (zero) before the first sub-version (in the above example, '1') is also prohibited. =item 2.3456 For decimal versions, an integer portion (no leading 0), a decimal point, and one or more digits to the right of the decimal are all required. =back =back Both of the provided scalars are already compiled as regular expressions and do not contain either anchors or implicit groupings, so they can be included in your own regular expressions freely. For example, consider the following code: ($pkg, $ver) =~ / ^[ \t]* use [ \t]+($PKGNAME) (?:[ \t]+($version::STRICT))? [ \t]*; /x; This would match a line of the form: use Foo::Bar::Baz v1.2.3; # legal only in Perl 5.8.1+ where C<$PKGNAME> is another regular expression that defines the legal forms for package names. =head1 IMPLEMENTATION DETAILS =head2 Equivalence between Decimal and Dotted-Decimal Versions When Perl 5.6.0 was released, the decision was made to provide a transformation between the old-style decimal versions and new-style dotted-decimal versions: 5.6.0 == 5.006000 5.005_04 == 5.5.40 The floating point number is taken and split first on the single decimal place, then each group of three digits to the right of the decimal makes up the next digit, and so on until the number of significant digits is exhausted, B<plus> enough trailing zeros to reach the next multiple of three. This was the method that version.pm adopted as well. Some examples may be helpful: equivalent decimal zero-padded dotted-decimal ------- ----------- -------------- 1.2 1.200 v1.200.0 1.02 1.020 v1.20.0 1.002 1.002 v1.2.0 1.0023 1.002300 v1.2.300 1.00203 1.002030 v1.2.30 1.002003 1.002003 v1.2.3 =head2 Quoting Rules Because of the nature of the Perl parsing and tokenizing routines, certain initialization values B<must> be quoted in order to correctly parse as the intended version, especially when using the C<declare> or L</qv()> methods. While you do not have to quote decimal numbers when creating version objects, it is always safe to quote B<all> initial values when using version.pm methods, as this will ensure that what you type is what is used. Additionally, if you quote your initializer, then the quoted value that goes B<in> will be exactly what comes B<out> when your $VERSION is printed (stringified). If you do not quote your value, Perl's normal numeric handling comes into play and you may not get back what you were expecting. If you use a mathematic formula that resolves to a floating point number, you are dependent on Perl's conversion routines to yield the version you expect. You are pretty safe by dividing by a power of 10, for example, but other operations are not likely to be what you intend. For example: $VERSION = version->new((qw$Revision: 1.4)[1]/10); print $VERSION; # yields 0.14 $V2 = version->new(100/9); # Integer overflow in decimal number print $V2; # yields something like 11.111.111.100 Perl 5.8.1 and beyond are able to automatically quote v-strings but that is not possible in earlier versions of Perl. In other words: $version = version->new("v2.5.4"); # legal in all versions of Perl $newvers = version->new(v2.5.4); # legal only in Perl >= 5.8.1 =head2 What about v-strings? There are two ways to enter v-strings: a bare number with two or more decimal points, or a bare number with one or more decimal points and a leading 'v' character (also bare). For example: $vs1 = 1.2.3; # encoded as \1\2\3 $vs2 = v1.2; # encoded as \1\2 However, the use of bare v-strings to initialize version objects is B<strongly> discouraged in all circumstances. Also, bare v-strings are not completely supported in any version of Perl prior to 5.8.1. If you insist on using bare v-strings with Perl > 5.6.0, be aware of the following limitations: 1) For Perl releases 5.6.0 through 5.8.0, the v-string code merely guesses, based on some characteristics of v-strings. You B<must> use a three part version, e.g. 1.2.3 or v1.2.3 in order for this heuristic to be successful. 2) For Perl releases 5.8.1 and later, v-strings have changed in the Perl core to be magical, which means that the version.pm code can automatically determine whether the v-string encoding was used. 3) In all cases, a version created using v-strings will have a stringified form that has a leading 'v' character, for the simple reason that sometimes it is impossible to tell whether one was present initially. =head2 Replacement UNIVERSAL::VERSION In addition to the version objects, this modules also replaces the core UNIVERSAL::VERSION function with one that uses version objects for its comparisons. The return from this operator is always the stringified form as a simple scalar (i.e. not an object), but the warning message generated includes either the stringified form or the normal form, depending on how it was called. For example: package Foo; $VERSION = 1.2; package Bar; $VERSION = "v1.3.5"; # works with all Perl's (since it is quoted) package main; use version; print $Foo::VERSION; # prints 1.2 print $Bar::VERSION; # prints 1.003005 eval "use foo 10"; print $@; # prints "foo version 10 required..." eval "use foo 1.3.5; # work in Perl 5.6.1 or better print $@; # prints "foo version 1.3.5 required..." eval "use bar 1.3.6"; print $@; # prints "bar version 1.3.6 required..." eval "use bar 1.004"; # note Decimal version print $@; # prints "bar version 1.004 required..." IMPORTANT NOTE: This may mean that code which searches for a specific string (to determine whether a given module is available) may need to be changed. It is always better to use the built-in comparison implicit in C<use> or C<require>, rather than manually poking at C<< class->VERSION >> and then doing a comparison yourself. The replacement UNIVERSAL::VERSION, when used as a function, like this: print $module->VERSION; will also exclusively return the stringified form. See L</Stringification> for more details. =head1 USAGE DETAILS =head2 Using modules that use version.pm As much as possible, the version.pm module remains compatible with all current code. However, if your module is using a module that has defined C<$VERSION> using the version class, there are a couple of things to be aware of. For purposes of discussion, we will assume that we have the following module installed: package Example; use version; $VERSION = qv('1.2.2'); ...module code here... 1; =over 4 =item Decimal versions always work Code of the form: use Example 1.002003; will always work correctly. The C<use> will perform an automatic C<$VERSION> comparison using the floating point number given as the first term after the module name (e.g. above 1.002.003). In this case, the installed module is too old for the requested line, so you would see an error like: Example version 1.002003 (v1.2.3) required--this is only version 1.002002 (v1.2.2)... =item Dotted-Decimal version work sometimes With Perl >= 5.6.2, you can also use a line like this: use Example 1.2.3; and it will again work (i.e. give the error message as above), even with releases of Perl which do not normally support v-strings (see L<What about v-strings?> above). This has to do with that fact that C<use> only checks to see if the second term I<looks like a number> and passes that to the replacement L<UNIVERSAL::VERSION|UNIVERSAL/VERSION>. This is not true in Perl 5.005_04, however, so you are B<strongly encouraged> to always use a Decimal version in your code, even for those versions of Perl which support the Dotted-Decimal version. =back =head2 Object Methods =over 4 =item new() Like many OO interfaces, the new() method is used to initialize version objects. If two arguments are passed to C<new()>, the B<second> one will be used as if it were prefixed with "v". This is to support historical use of the C<qw> operator with the CVS variable $Revision, which is automatically incremented by CVS every time the file is committed to the repository. In order to facilitate this feature, the following code can be employed: $VERSION = version->new(qw$Revision: 2.7 $); and the version object will be created as if the following code were used: $VERSION = version->new("v2.7"); In other words, the version will be automatically parsed out of the string, and it will be quoted to preserve the meaning CVS normally carries for versions. The CVS $Revision$ increments differently from Decimal versions (i.e. 1.10 follows 1.9), so it must be handled as if it were a Dotted-Decimal Version. A new version object can be created as a copy of an existing version object, either as a class method: $v1 = version->new(12.3); $v2 = version->new($v1); or as an object method: $v1 = version->new(12.3); $v2 = $v1->new(12.3); and in each case, $v1 and $v2 will be identical. NOTE: if you create a new object using an existing object like this: $v2 = $v1->new(); the new object B<will not> be a clone of the existing object. In the example case, $v2 will be an empty object of the same type as $v1. =back =over 4 =item qv() An alternate way to create a new version object is through the exported qv() sub. This is not strictly like other q? operators (like qq, qw), in that the only delimiters supported are parentheses (or spaces). It is the best way to initialize a short version without triggering the floating point interpretation. For example: $v1 = qv(1.2); # v1.2.0 $v2 = qv("1.2"); # also v1.2.0 As you can see, either a bare number or a quoted string can usually be used interchangeably, except in the case of a trailing zero, which must be quoted to be converted properly. For this reason, it is strongly recommended that all initializers to qv() be quoted strings instead of bare numbers. To prevent the C<qv()> function from being exported to the caller's namespace, either use version with a null parameter: use version (); or just require version, like this: require version; Both methods will prevent the import() method from firing and exporting the C<qv()> sub. =back For the subsequent examples, the following three objects will be used: $ver = version->new("1.2.3.4"); # see "Quoting Rules" $alpha = version->new("1.2.3_4"); # see "Alpha Versions" $nver = version->new(1.002); # see "Decimal Versions" =over 4 =item Normal Form For any version object which is initialized with multiple decimal places (either quoted or if possible v-string), or initialized using the L<qv()|version/qv()> operator, the stringified representation is returned in a normalized or reduced form (no extraneous zeros), and with a leading 'v': print $ver->normal; # prints as v1.2.3.4 print $ver->stringify; # ditto print $ver; # ditto print $nver->normal; # prints as v1.2.0 print $nver->stringify; # prints as 1.002, # see "Stringification" In order to preserve the meaning of the processed version, the normalized representation will always contain at least three sub terms. In other words, the following is guaranteed to always be true: my $newver = version->new($ver->stringify); if ($newver eq $ver ) # always true {...} =back =over 4 =item Numification Although all mathematical operations on version objects are forbidden by default, it is possible to retrieve a number which corresponds to the version object through the use of the $obj->numify method. For formatting purposes, when displaying a number which corresponds a version object, all sub versions are assumed to have three decimal places. So for example: print $ver->numify; # prints 1.002003004 print $nver->numify; # prints 1.002 Unlike the stringification operator, there is never any need to append trailing zeros to preserve the correct version value. =back =over 4 =item Stringification The default stringification for version objects returns exactly the same string as was used to create it, whether you used C<new()> or C<qv()>, with one exception. The sole exception is if the object was created using C<qv()> and the initializer did not have two decimal places or a leading 'v' (both optional), then the stringified form will have a leading 'v' prepended, in order to support round-trip processing. For example: Initialized as Stringifies to ============== ============== version->new("1.2") 1.2 version->new("v1.2") v1.2 qv("1.2.3") 1.2.3 qv("v1.3.5") v1.3.5 qv("1.2") v1.2 ### exceptional case See also L<UNIVERSAL::VERSION|UNIVERSAL/VERSION>, as this also returns the stringified form when used as a class method. IMPORTANT NOTE: There is one exceptional cases shown in the above table where the "initializer" is not stringwise equivalent to the stringified representation. If you use the C<qv>() operator on a version without a leading 'v' B<and> with only a single decimal place, the stringified output will have a leading 'v', to preserve the sense. See the L</qv()> operator for more details. IMPORTANT NOTE 2: Attempting to bypass the normal stringification rules by manually applying L<numify()|version/numify()> and L<normal()|version/normal()> will sometimes yield surprising results: print version->new(version->new("v1.0")->numify)->normal; # v1.0.0 The reason for this is that the L<numify()|version/numify()> operator will turn "v1.0" into the equivalent string "1.000000". Forcing the outer version object to L<normal()|version/normal()> form will display the mathematically equivalent "v1.0.0". As the example in L</new()> shows, you can always create a copy of an existing version object with the same value by the very compact: $v2 = $v1->new($v1); and be assured that both C<$v1> and C<$v2> will be completely equivalent, down to the same internal representation as well as stringification. =back =over 4 =item Comparison operators Both C<cmp> and C<E<lt>=E<gt>> operators perform the same comparison between terms (upgrading to a version object automatically). Perl automatically generates all of the other comparison operators based on those two. In addition to the obvious equalities listed below, appending a single trailing 0 term does not change the value of a version for comparison purposes. In other words "v1.2" and "1.2.0" will compare as identical. For example, the following relations hold: As Number As String Truth Value ------------- ---------------- ----------- $ver > 1.0 $ver gt "1.0" true $ver < 2.5 $ver lt true $ver != 1.3 $ver ne "1.3" true $ver == 1.2 $ver eq "1.2" false $ver == 1.2.3.4 $ver eq "1.2.3.4" see discussion below It is probably best to chose either the Decimal notation or the string notation and stick with it, to reduce confusion. Perl6 version objects B<may> only support Decimal comparisons. See also L<Quoting Rules>. WARNING: Comparing version with unequal numbers of decimal points (whether explicitly or implicitly initialized), may yield unexpected results at first glance. For example, the following inequalities hold: version->new(0.96) > version->new(0.95); # 0.960.0 > 0.950.0 version->new("0.96.1") < version->new(0.95); # 0.096.1 < 0.950.0 For this reason, it is best to use either exclusively L<Decimal Versions> or L<Dotted-Decimal Versions> with multiple decimal points. =back =over 4 =item Logical Operators If you need to test whether a version object has been initialized, you can simply test it directly: $vobj = version->new($something); if ( $vobj ) # true only if $something was non-blank You can also test whether a version object is an alpha version, for example to prevent the use of some feature not present in the main release: $vobj = version->new("1.2_3"); # MUST QUOTE ...later... if ( $vobj->is_alpha ) # True =back =head1 AUTHOR John Peacock E<lt>jpeacock@cpan.orgE<gt> =head1 SEE ALSO L<perl>. =cut 5.32/version/vpp.pm 0000444 00000053613 15125513451 0007773 0 ustar 00 package charstar; # a little helper class to emulate C char* semantics in Perl # so that prescan_version can use the same code as in C use overload ( '""' => \&thischar, '0+' => \&thischar, '++' => \&increment, '--' => \&decrement, '+' => \&plus, '-' => \&minus, '*' => \&multiply, 'cmp' => \&cmp, '<=>' => \&spaceship, 'bool' => \&thischar, '=' => \&clone, ); sub new { my ($self, $string) = @_; my $class = ref($self) || $self; my $obj = { string => [split(//,$string)], current => 0, }; return bless $obj, $class; } sub thischar { my ($self) = @_; my $last = $#{$self->{string}}; my $curr = $self->{current}; if ($curr >= 0 && $curr <= $last) { return $self->{string}->[$curr]; } else { return ''; } } sub increment { my ($self) = @_; $self->{current}++; } sub decrement { my ($self) = @_; $self->{current}--; } sub plus { my ($self, $offset) = @_; my $rself = $self->clone; $rself->{current} += $offset; return $rself; } sub minus { my ($self, $offset) = @_; my $rself = $self->clone; $rself->{current} -= $offset; return $rself; } sub multiply { my ($left, $right, $swapped) = @_; my $char = $left->thischar(); return $char * $right; } sub spaceship { my ($left, $right, $swapped) = @_; unless (ref($right)) { # not an object already $right = $left->new($right); } return $left->{current} <=> $right->{current}; } sub cmp { my ($left, $right, $swapped) = @_; unless (ref($right)) { # not an object already if (length($right) == 1) { # comparing single character only return $left->thischar cmp $right; } $right = $left->new($right); } return $left->currstr cmp $right->currstr; } sub bool { my ($self) = @_; my $char = $self->thischar; return ($char ne ''); } sub clone { my ($left, $right, $swapped) = @_; $right = { string => [@{$left->{string}}], current => $left->{current}, }; return bless $right, ref($left); } sub currstr { my ($self, $s) = @_; my $curr = $self->{current}; my $last = $#{$self->{string}}; if (defined($s) && $s->{current} < $last) { $last = $s->{current}; } my $string = join('', @{$self->{string}}[$curr..$last]); return $string; } package version::vpp; use 5.006002; use strict; use warnings::register; use Config; our $VERSION = '0.9933'; our $CLASS = 'version::vpp'; our ($LAX, $STRICT, $WARN_CATEGORY); if ($] > 5.015) { warnings::register_categories(qw/version/); $WARN_CATEGORY = 'version'; } else { $WARN_CATEGORY = 'numeric'; } require version::regex; *version::vpp::is_strict = \&version::regex::is_strict; *version::vpp::is_lax = \&version::regex::is_lax; *LAX = \$version::regex::LAX; *STRICT = \$version::regex::STRICT; use overload ( '""' => \&stringify, '0+' => \&numify, 'cmp' => \&vcmp, '<=>' => \&vcmp, 'bool' => \&vbool, '+' => \&vnoop, '-' => \&vnoop, '*' => \&vnoop, '/' => \&vnoop, '+=' => \&vnoop, '-=' => \&vnoop, '*=' => \&vnoop, '/=' => \&vnoop, 'abs' => \&vnoop, ); sub import { no strict 'refs'; my ($class) = shift; # Set up any derived class unless ($class eq $CLASS) { local $^W; *{$class.'::declare'} = \&{$CLASS.'::declare'}; *{$class.'::qv'} = \&{$CLASS.'::qv'}; } my %args; if (@_) { # any remaining terms are arguments map { $args{$_} = 1 } @_ } else { # no parameters at all on use line %args = ( qv => 1, 'UNIVERSAL::VERSION' => 1, ); } my $callpkg = caller(); if (exists($args{declare})) { *{$callpkg.'::declare'} = sub {return $class->declare(shift) } unless defined(&{$callpkg.'::declare'}); } if (exists($args{qv})) { *{$callpkg.'::qv'} = sub {return $class->qv(shift) } unless defined(&{$callpkg.'::qv'}); } if (exists($args{'UNIVERSAL::VERSION'})) { no warnings qw/redefine/; *UNIVERSAL::VERSION = \&{$CLASS.'::_VERSION'}; } if (exists($args{'VERSION'})) { *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; } if (exists($args{'is_strict'})) { *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} unless defined(&{$callpkg.'::is_strict'}); } if (exists($args{'is_lax'})) { *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} unless defined(&{$callpkg.'::is_lax'}); } } my $VERSION_MAX = 0x7FFFFFFF; # implement prescan_version as closely to the C version as possible use constant TRUE => 1; use constant FALSE => 0; sub isDIGIT { my ($char) = shift->thischar(); return ($char =~ /\d/); } sub isALPHA { my ($char) = shift->thischar(); return ($char =~ /[a-zA-Z]/); } sub isSPACE { my ($char) = shift->thischar(); return ($char =~ /\s/); } sub BADVERSION { my ($s, $errstr, $error) = @_; if ($errstr) { $$errstr = $error; } return $s; } sub prescan_version { my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_; my $qv = defined $sqv ? $$sqv : FALSE; my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0; my $width = defined $swidth ? $$swidth : 3; my $alpha = defined $salpha ? $$salpha : FALSE; my $d = $s; if ($qv && isDIGIT($d)) { goto dotted_decimal_version; } if ($d eq 'v') { # explicit v-string $d++; if (isDIGIT($d)) { $qv = TRUE; } else { # degenerate v-string # requires v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } dotted_decimal_version: if ($strict && $d eq '0' && isDIGIT($d+1)) { # no leading zeros allowed return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); } while (isDIGIT($d)) { # integer part $d++; } if ($d eq '.') { $saw_decimal++; $d++; # decimal point } else { if ($strict) { # require v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } else { goto version_prescan_finish; } } { my $i = 0; my $j = 0; while (isDIGIT($d)) { # just keep reading $i++; while (isDIGIT($d)) { $d++; $j++; # maximum 3 digits between decimal if ($strict && $j > 3) { return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)"); } } if ($d eq '_') { if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } if ( $alpha ) { return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); } $d++; $alpha = TRUE; } elsif ($d eq '.') { if ($alpha) { return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); } $saw_decimal++; $d++; } elsif (!isDIGIT($d)) { last; } $j = 0; } if ($strict && $i < 2) { # requires v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } } } # end if dotted-decimal else { # decimal versions my $j = 0; # special $strict case for leading '.' or '0' if ($strict) { if ($d eq '.') { return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)"); } if ($d eq '0' && isDIGIT($d+1)) { return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); } } # and we never support negative version numbers if ($d eq '-') { return BADVERSION($s,$errstr,"Invalid version format (negative version number)"); } # consume all of the integer part while (isDIGIT($d)) { $d++; } # look for a fractional part if ($d eq '.') { # we found it, so consume it $saw_decimal++; $d++; } elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') { if ( $d == $s ) { # found nothing return BADVERSION($s,$errstr,"Invalid version format (version required)"); } # found just an integer goto version_prescan_finish; } elsif ( $d == $s ) { # didn't find either integer or period return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } elsif ($d eq '_') { # underscore can't come after integer part if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } elsif (isDIGIT($d+1)) { return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)"); } else { return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); } } elsif ($d) { # anything else after integer part is just invalid data return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } # scan the fractional part after the decimal point if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) { # $strict or lax-but-not-the-end return BADVERSION($s,$errstr,"Invalid version format (fractional part required)"); } while (isDIGIT($d)) { $d++; $j++; if ($d eq '.' && isDIGIT($d-1)) { if ($alpha) { return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); } if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); } $d = $s; # start all over again $qv = TRUE; goto dotted_decimal_version; } if ($d eq '_') { if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } if ( $alpha ) { return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); } if ( ! isDIGIT($d+1) ) { return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); } $width = $j; $d++; $alpha = TRUE; } } } version_prescan_finish: while (isSPACE($d)) { $d++; } if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) { # trailing non-numeric data return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } if ($saw_decimal > 1 && ($d-1) eq '.') { # no trailing period allowed return BADVERSION($s,$errstr,"Invalid version format (trailing decimal)"); } if (defined $sqv) { $$sqv = $qv; } if (defined $swidth) { $$swidth = $width; } if (defined $ssaw_decimal) { $$ssaw_decimal = $saw_decimal; } if (defined $salpha) { $$salpha = $alpha; } return $d; } sub scan_version { my ($s, $rv, $qv) = @_; my $start; my $pos; my $last; my $errstr; my $saw_decimal = 0; my $width = 3; my $alpha = FALSE; my $vinf = FALSE; my @av; $s = new charstar $s; while (isSPACE($s)) { # leading whitespace is OK $s++; } $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal, \$width, \$alpha); if ($errstr) { # 'undef' is a special case and not an error if ( $s ne 'undef') { require Carp; Carp::croak($errstr); } } $start = $s; if ($s eq 'v') { $s++; } $pos = $s; if ( $qv ) { $$rv->{qv} = $qv; } if ( $alpha ) { $$rv->{alpha} = $alpha; } if ( !$qv && $width < 3 ) { $$rv->{width} = $width; } while (isDIGIT($pos) || $pos eq '_') { $pos++; } if (!isALPHA($pos)) { my $rev; for (;;) { $rev = 0; { # this is atoi() that delimits on underscores my $end = $pos; my $mult = 1; my $orev; # the following if() will only be true after the decimal # point of a version originally created with a bare # floating point number, i.e. not quoted in any way # if ( !$qv && $s > $start && $saw_decimal == 1 ) { $mult *= 100; while ( $s < $end ) { next if $s eq '_'; $orev = $rev; $rev += $s * $mult; $mult /= 10; if ( (abs($orev) > abs($rev)) || (abs($rev) > $VERSION_MAX )) { warn("Integer overflow in version %d", $VERSION_MAX); $s = $end - 1; $rev = $VERSION_MAX; $vinf = 1; } $s++; if ( $s eq '_' ) { $s++; } } } else { while (--$end >= $s) { next if $end eq '_'; $orev = $rev; $rev += $end * $mult; $mult *= 10; if ( (abs($orev) > abs($rev)) || (abs($rev) > $VERSION_MAX )) { warn("Integer overflow in version"); $end = $s - 1; $rev = $VERSION_MAX; $vinf = 1; } } } } # Append revision push @av, $rev; if ( $vinf ) { $s = $last; last; } elsif ( $pos eq '.' ) { $s = ++$pos; } elsif ( $pos eq '_' && isDIGIT($pos+1) ) { $s = ++$pos; } elsif ( $pos eq ',' && isDIGIT($pos+1) ) { $s = ++$pos; } elsif ( isDIGIT($pos) ) { $s = $pos; } else { $s = $pos; last; } if ( $qv ) { while ( isDIGIT($pos) || $pos eq '_') { $pos++; } } else { my $digits = 0; while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) { if ( $pos ne '_' ) { $digits++; } $pos++; } } } } if ( $qv ) { # quoted versions always get at least three terms my $len = $#av; # This for loop appears to trigger a compiler bug on OS X, as it # loops infinitely. Yes, len is negative. No, it makes no sense. # Compiler in question is: # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) # for ( len = 2 - len; len > 0; len-- ) # av_push(MUTABLE_AV(sv), newSViv(0)); # $len = 2 - $len; while ($len-- > 0) { push @av, 0; } } # need to save off the current version string for later if ( $vinf ) { $$rv->{original} = "v.Inf"; $$rv->{vinf} = 1; } elsif ( $s > $start ) { $$rv->{original} = $start->currstr($s); if ( $qv && $saw_decimal == 1 && $start ne 'v' ) { # need to insert a v to be consistent $$rv->{original} = 'v' . $$rv->{original}; } } else { $$rv->{original} = '0'; push(@av, 0); } # And finally, store the AV in the hash $$rv->{version} = \@av; # fix RT#19517 - special case 'undef' as string if ($s eq 'undef') { $s += 5; } return $s; } sub new { my $class = shift; unless (defined $class or $#_ > 1) { require Carp; Carp::croak('Usage: version::new(class, version)'); } my $self = bless ({}, ref ($class) || $class); my $qv = FALSE; if ( $#_ == 1 ) { # must be CVS-style $qv = TRUE; } my $value = pop; # always going to be the last element if ( ref($value) && eval('$value->isa("version")') ) { # Can copy the elements directly $self->{version} = [ @{$value->{version} } ]; $self->{qv} = 1 if $value->{qv}; $self->{alpha} = 1 if $value->{alpha}; $self->{original} = ''.$value->{original}; return $self; } if ( not defined $value or $value =~ /^undef$/ ) { # RT #19517 - special case for undef comparison # or someone forgot to pass a value push @{$self->{version}}, 0; $self->{original} = "0"; return ($self); } if (ref($value) =~ m/ARRAY|HASH/) { require Carp; Carp::croak("Invalid version format (non-numeric data)"); } $value = _un_vstring($value); if ($Config{d_setlocale}) { use POSIX qw/locale_h/; use if $Config{d_setlocale}, 'locale'; my $currlocale = setlocale(LC_ALL); # if the current locale uses commas for decimal points, we # just replace commas with decimal places, rather than changing # locales if ( localeconv()->{decimal_point} eq ',' ) { $value =~ tr/,/./; } } # exponential notation if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) { $value = sprintf("%.9f",$value); $value =~ s/(0+)$//; # trim trailing zeros } my $s = scan_version($value, \$self, $qv); if ($s) { # must be something left over warn(sprintf "Version string '%s' contains invalid data; " ."ignoring: '%s'", $value, $s); } return ($self); } *parse = \&new; sub numify { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } my $alpha = $self->{alpha} || ""; my $len = $#{$self->{version}}; my $digit = $self->{version}[0]; my $string = sprintf("%d.", $digit ); if ($alpha and warnings::enabled()) { warnings::warn($WARN_CATEGORY, 'alpha->numify() is lossy'); } for ( my $i = 1 ; $i <= $len ; $i++ ) { $digit = $self->{version}[$i]; $string .= sprintf("%03d", $digit); } if ( $len == 0 ) { $string .= sprintf("000"); } return $string; } sub normal { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } my $len = $#{$self->{version}}; my $digit = $self->{version}[0]; my $string = sprintf("v%d", $digit ); for ( my $i = 1 ; $i <= $len ; $i++ ) { $digit = $self->{version}[$i]; $string .= sprintf(".%d", $digit); } if ( $len <= 2 ) { for ( $len = 2 - $len; $len != 0; $len-- ) { $string .= sprintf(".%0d", 0); } } return $string; } sub stringify { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } return exists $self->{original} ? $self->{original} : exists $self->{qv} ? $self->normal : $self->numify; } sub to_decimal { my ($self) = @_; return ref($self)->new($self->numify); } sub to_dotted_decimal { my ($self) = @_; return ref($self)->new($self->normal); } sub vcmp { my ($left,$right,$swap) = @_; die "Usage: version::vcmp(lobj, robj, ...)" if @_ < 2; my $class = ref($left); unless ( UNIVERSAL::isa($right, $class) ) { $right = $class->new($right); } if ( $swap ) { ($left, $right) = ($right, $left); } unless (_verify($left)) { require Carp; Carp::croak("Invalid version object"); } unless (_verify($right)) { require Carp; Carp::croak("Invalid version format"); } my $l = $#{$left->{version}}; my $r = $#{$right->{version}}; my $m = $l < $r ? $l : $r; my $lalpha = $left->is_alpha; my $ralpha = $right->is_alpha; my $retval = 0; my $i = 0; while ( $i <= $m && $retval == 0 ) { $retval = $left->{version}[$i] <=> $right->{version}[$i]; $i++; } # possible match except for trailing 0's if ( $retval == 0 && $l != $r ) { if ( $l < $r ) { while ( $i <= $r && $retval == 0 ) { if ( $right->{version}[$i] != 0 ) { $retval = -1; # not a match after all } $i++; } } else { while ( $i <= $l && $retval == 0 ) { if ( $left->{version}[$i] != 0 ) { $retval = +1; # not a match after all } $i++; } } } return $retval; } sub vbool { my ($self) = @_; return vcmp($self,$self->new("0"),1); } sub vnoop { require Carp; Carp::croak("operation not supported with version object"); } sub is_alpha { my ($self) = @_; return (exists $self->{alpha}); } sub qv { my $value = shift; my $class = $CLASS; if (@_) { $class = ref($value) || $value; $value = shift; } $value = _un_vstring($value); $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/; my $obj = $CLASS->new($value); return bless $obj, $class; } *declare = \&qv; sub is_qv { my ($self) = @_; return (exists $self->{qv}); } sub tuple { my ($self) = @_; return @{ $self->{version} }; } sub from_tuple { my ($proto, @args) = @_; my $class = ref($proto) || $proto; my @version = map 0+$_, @args; die if @args < 1; return bless { version => \@version, qv => !!1, 'v' . join('.', @version), }, $class; } sub _verify { my ($self) = @_; if ( ref($self) && eval { exists $self->{version} } && ref($self->{version}) eq 'ARRAY' ) { return 1; } else { return 0; } } sub _is_non_alphanumeric { my $s = shift; $s = new charstar $s; while ($s) { return 0 if isSPACE($s); # early out return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/); $s++; } return 0; } sub _un_vstring { my $value = shift; # may be a v-string if ( length($value) >= 1 && $value !~ /[,._]/ && _is_non_alphanumeric($value)) { my $tvalue; if ( $] >= 5.008_001 ) { $tvalue = _find_magic_vstring($value); $value = $tvalue if length $tvalue; } elsif ( $] >= 5.006_000 ) { $tvalue = sprintf("v%vd",$value); if ( $tvalue =~ /^v\d+(\.\d+)*$/ ) { # must be a v-string $value = $tvalue; } } } return $value; } sub _find_magic_vstring { my $value = shift; my $tvalue = ''; require B; my $sv = B::svref_2object(\$value); my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; while ( $magic ) { if ( $magic->TYPE eq 'V' ) { $tvalue = $magic->PTR; $tvalue =~ s/^v?(.+)$/v$1/; last; } else { $magic = $magic->MOREMAGIC; } } $tvalue =~ tr/_//d; return $tvalue; } sub _VERSION { my ($obj, $req) = @_; my $class = ref($obj) || $obj; no strict 'refs'; if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) { # file but no package require Carp; Carp::croak( "$class defines neither package nor VERSION" ."--version check failed"); } my $version = eval "\$$class\::VERSION"; if ( defined $version ) { local $^W if $] <= 5.008; $version = version::vpp->new($version); } if ( defined $req ) { unless ( defined $version ) { require Carp; my $msg = $] < 5.006 ? "$class version $req required--this is only version " : "$class does not define \$$class\::VERSION" ."--version check failed"; if ( $ENV{VERSION_DEBUG} ) { Carp::confess($msg); } else { Carp::croak($msg); } } $req = version::vpp->new($req); if ( $req > $version ) { require Carp; if ( $req->is_qv ) { Carp::croak( sprintf ("%s version %s required--". "this is only version %s", $class, $req->normal, $version->normal) ); } else { Carp::croak( sprintf ("%s version %s required--". "this is only version %s", $class, $req->stringify, $version->stringify) ); } } } return defined $version ? $version->stringify : undef; } 1; #this line is important and will help the module return a true value 5.32/version/regex.pm 0000444 00000007752 15125513451 0010303 0 ustar 00 package version::regex; use strict; our $VERSION = '0.9933'; #--------------------------------------------------------------------------# # Version regexp components #--------------------------------------------------------------------------# # Fraction part of a decimal version number. This is a common part of # both strict and lax decimal versions my $FRACTION_PART = qr/\.[0-9]+/; # First part of either decimal or dotted-decimal strict version number. # Unsigned integer with no leading zeroes (except for zero itself) to # avoid confusion with octal. my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/; # First part of either decimal or dotted-decimal lax version number. # Unsigned integer, but allowing leading zeros. Always interpreted # as decimal. However, some forms of the resulting syntax give odd # results if used as ordinary Perl expressions, due to how perl treats # octals. E.g. # version->new("010" ) == 10 # version->new( 010 ) == 8 # version->new( 010.2) == 82 # "8" . "2" my $LAX_INTEGER_PART = qr/[0-9]+/; # Second and subsequent part of a strict dotted-decimal version number. # Leading zeroes are permitted, and the number is always decimal. # Limited to three digits to avoid overflow when converting to decimal # form and also avoid problematic style with excessive leading zeroes. my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/; # Second and subsequent part of a lax dotted-decimal version number. # Leading zeroes are permitted, and the number is always decimal. No # limit on the numerical value or number of digits, so there is the # possibility of overflow when converting to decimal form. my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/; # Alpha suffix part of lax version number syntax. Acts like a # dotted-decimal part. my $LAX_ALPHA_PART = qr/_[0-9]+/; #--------------------------------------------------------------------------# # Strict version regexp definitions #--------------------------------------------------------------------------# # Strict decimal version number. our $STRICT_DECIMAL_VERSION = qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x; # Strict dotted-decimal version number. Must have both leading "v" and # at least three parts, to avoid confusion with decimal syntax. our $STRICT_DOTTED_DECIMAL_VERSION = qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x; # Complete strict version number syntax -- should generally be used # anchored: qr/ \A $STRICT \z /x our $STRICT = qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x; #--------------------------------------------------------------------------# # Lax version regexp definitions #--------------------------------------------------------------------------# # Lax decimal version number. Just like the strict one except for # allowing an alpha suffix or allowing a leading or trailing # decimal-point our $LAX_DECIMAL_VERSION = qr/ $LAX_INTEGER_PART (?: $FRACTION_PART | \. )? $LAX_ALPHA_PART? | $FRACTION_PART $LAX_ALPHA_PART? /x; # Lax dotted-decimal version number. Distinguished by having either # leading "v" or at least three non-alpha parts. Alpha part is only # permitted if there are at least two non-alpha parts. Strangely # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2, # so when there is no "v", the leading part is optional our $LAX_DOTTED_DECIMAL_VERSION = qr/ v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )? | $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART? /x; # Complete lax version number syntax -- should generally be used # anchored: qr/ \A $LAX \z /x # # The string 'undef' is a special case to make for easier handling # of return values from ExtUtils::MM->parse_version our $LAX = qr/ undef | $LAX_DOTTED_DECIMAL_VERSION | $LAX_DECIMAL_VERSION /x; #--------------------------------------------------------------------------# # Preloaded methods go here. sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x } sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x } 1; 5.32/version/vxs.pm 0000444 00000000746 15125513451 0010005 0 ustar 00 #!perl -w package version::vxs; use v5.10; use strict; our $VERSION = '0.9933'; our $CLASS = 'version::vxs'; our @ISA; eval { require XSLoader; local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION XSLoader::load('version::vxs', $VERSION); 1; } or do { require DynaLoader; push @ISA, 'DynaLoader'; local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION bootstrap version::vxs $VERSION; }; # Preloaded methods go here. 1; 5.32/IO/Tty/Constant.pm 0000444 00000016070 15125513451 0010355 0 ustar 00 package IO::Tty::Constant; our $VERSION = '1.20'; use vars qw(@ISA @EXPORT_OK); require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(B0 B110 B115200 B1200 B134 B150 B153600 B1800 B19200 B200 B230400 B2400 B300 B307200 B38400 B460800 B4800 B50 B57600 B600 B75 B76800 B9600 BRKINT BS0 BS1 BSDLY CBAUD CBAUDEXT CBRK CCTS_OFLOW CDEL CDSUSP CEOF CEOL CEOL2 CEOT CERASE CESC CFLUSH CIBAUD CIBAUDEXT CINTR CKILL CLNEXT CLOCAL CNSWTCH CNUL CQUIT CR0 CR1 CR2 CR3 CRDLY CREAD CRPRNT CRTSCTS CRTSXOFF CRTS_IFLOW CS5 CS6 CS7 CS8 CSIZE CSTART CSTOP CSTOPB CSUSP CSWTCH CWERASE DEFECHO DIOC DIOCGETP DIOCSETP DOSMODE ECHO ECHOCTL ECHOE ECHOK ECHOKE ECHONL ECHOPRT EXTA EXTB FF0 FF1 FFDLY FIORDCHK FLUSHO HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR IMAXBEL INLCR INPCK ISIG ISTRIP IUCLC IXANY IXOFF IXON KBENABLED LDCHG LDCLOSE LDDMAP LDEMAP LDGETT LDGMAP LDIOC LDNMAP LDOPEN LDSETT LDSMAP LOBLK NCCS NL0 NL1 NLDLY NOFLSH OCRNL OFDEL OFILL OLCUC ONLCR ONLRET ONOCR OPOST PAGEOUT PARENB PAREXT PARMRK PARODD PENDIN RCV1EN RTS_TOG TAB0 TAB1 TAB2 TAB3 TABDLY TCDSET TCFLSH TCGETA TCGETS TCIFLUSH TCIOFF TCIOFLUSH TCION TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW TCSBRK TCSETA TCSETAF TCSETAW TCSETCTTY TCSETS TCSETSF TCSETSW TCXONC TERM_D40 TERM_D42 TERM_H45 TERM_NONE TERM_TEC TERM_TEX TERM_V10 TERM_V61 TIOCCBRK TIOCCDTR TIOCCONS TIOCEXCL TIOCFLUSH TIOCGETD TIOCGETC TIOCGETP TIOCGLTC TIOCSETC TIOCSETN TIOCSETP TIOCSLTC TIOCGPGRP TIOCGSID TIOCGSOFTCAR TIOCGWINSZ TIOCHPCL TIOCKBOF TIOCKBON TIOCLBIC TIOCLBIS TIOCLGET TIOCLSET TIOCMBIC TIOCMBIS TIOCMGET TIOCMSET TIOCM_CAR TIOCM_CD TIOCM_CTS TIOCM_DSR TIOCM_DTR TIOCM_LE TIOCM_RI TIOCM_RNG TIOCM_RTS TIOCM_SR TIOCM_ST TIOCNOTTY TIOCNXCL TIOCOUTQ TIOCREMOTE TIOCSBRK TIOCSCTTY TIOCSDTR TIOCSETD TIOCSIGNAL TIOCSPGRP TIOCSSID TIOCSSOFTCAR TIOCSTART TIOCSTI TIOCSTOP TIOCSWINSZ TM_ANL TM_CECHO TM_CINVIS TM_LCF TM_NONE TM_SET TM_SNL TOSTOP VCEOF VCEOL VDISCARD VDSUSP VEOF VEOL VEOL2 VERASE VINTR VKILL VLNEXT VMIN VQUIT VREPRINT VSTART VSTOP VSUSP VSWTCH VT0 VT1 VTDLY VTIME VWERASE WRAP XCASE XCLUDE XMT1EN XTABS); __END__ =head1 NAME IO::Tty::Constant - Terminal Constants (autogenerated) =head1 SYNOPSIS use IO::Tty::Constant qw(TIOCNOTTY); ... =head1 DESCRIPTION This package defines constants usually found in <termio.h> or <termios.h> (and their #include hierarchy). Find below an autogenerated alphabetic list of all known constants and whether they are defined on your system (prefixed with '+') and have compilation problems ('o'). Undefined or problematic constants are set to 'undef'. =head1 DEFINED CONSTANTS =over 4 =item + B0 =item + B110 =item + B115200 =item + B1200 =item + B134 =item + B150 =item - B153600 =item + B1800 =item + B19200 =item + B200 =item + B230400 =item + B2400 =item + B300 =item - B307200 =item + B38400 =item + B460800 =item + B4800 =item + B50 =item + B57600 =item + B600 =item + B75 =item - B76800 =item + B9600 =item + BRKINT =item + BS0 =item + BS1 =item + BSDLY =item + CBAUD =item - CBAUDEXT =item + CBRK =item - CCTS_OFLOW =item - CDEL =item + CDSUSP =item + CEOF =item + CEOL =item - CEOL2 =item + CEOT =item + CERASE =item - CESC =item + CFLUSH =item + CIBAUD =item - CIBAUDEXT =item + CINTR =item + CKILL =item + CLNEXT =item + CLOCAL =item - CNSWTCH =item - CNUL =item + CQUIT =item + CR0 =item + CR1 =item + CR2 =item + CR3 =item + CRDLY =item + CREAD =item + CRPRNT =item + CRTSCTS =item - CRTSXOFF =item - CRTS_IFLOW =item + CS5 =item + CS6 =item + CS7 =item + CS8 =item + CSIZE =item + CSTART =item + CSTOP =item + CSTOPB =item + CSUSP =item - CSWTCH =item + CWERASE =item - DEFECHO =item - DIOC =item - DIOCGETP =item - DIOCSETP =item - DOSMODE =item + ECHO =item + ECHOCTL =item + ECHOE =item + ECHOK =item + ECHOKE =item + ECHONL =item + ECHOPRT =item + EXTA =item + EXTB =item + FF0 =item + FF1 =item + FFDLY =item - FIORDCHK =item + FLUSHO =item + HUPCL =item + ICANON =item + ICRNL =item + IEXTEN =item + IGNBRK =item + IGNCR =item + IGNPAR =item + IMAXBEL =item + INLCR =item + INPCK =item + ISIG =item + ISTRIP =item + IUCLC =item + IXANY =item + IXOFF =item + IXON =item - KBENABLED =item - LDCHG =item - LDCLOSE =item - LDDMAP =item - LDEMAP =item - LDGETT =item - LDGMAP =item - LDIOC =item - LDNMAP =item - LDOPEN =item - LDSETT =item - LDSMAP =item - LOBLK =item + NCCS =item + NL0 =item + NL1 =item + NLDLY =item + NOFLSH =item + OCRNL =item + OFDEL =item + OFILL =item + OLCUC =item + ONLCR =item + ONLRET =item + ONOCR =item + OPOST =item - PAGEOUT =item + PARENB =item - PAREXT =item + PARMRK =item + PARODD =item + PENDIN =item - RCV1EN =item - RTS_TOG =item + TAB0 =item + TAB1 =item + TAB2 =item + TAB3 =item + TABDLY =item - TCDSET =item + TCFLSH =item + TCGETA =item + TCGETS =item + TCIFLUSH =item + TCIOFF =item + TCIOFLUSH =item + TCION =item + TCOFLUSH =item + TCOOFF =item + TCOON =item + TCSADRAIN =item + TCSAFLUSH =item + TCSANOW =item + TCSBRK =item + TCSETA =item + TCSETAF =item + TCSETAW =item - TCSETCTTY =item + TCSETS =item + TCSETSF =item + TCSETSW =item + TCXONC =item - TERM_D40 =item - TERM_D42 =item - TERM_H45 =item - TERM_NONE =item - TERM_TEC =item - TERM_TEX =item - TERM_V10 =item - TERM_V61 =item + TIOCCBRK =item - TIOCCDTR =item + TIOCCONS =item + TIOCEXCL =item - TIOCFLUSH =item + TIOCGETD =item - TIOCGETC =item - TIOCGETP =item - TIOCGLTC =item - TIOCSETC =item - TIOCSETN =item - TIOCSETP =item - TIOCSLTC =item + TIOCGPGRP =item + TIOCGSID =item + TIOCGSOFTCAR =item + TIOCGWINSZ =item - TIOCHPCL =item - TIOCKBOF =item - TIOCKBON =item - TIOCLBIC =item - TIOCLBIS =item - TIOCLGET =item - TIOCLSET =item + TIOCMBIC =item + TIOCMBIS =item + TIOCMGET =item + TIOCMSET =item + TIOCM_CAR =item + TIOCM_CD =item + TIOCM_CTS =item + TIOCM_DSR =item + TIOCM_DTR =item + TIOCM_LE =item + TIOCM_RI =item + TIOCM_RNG =item + TIOCM_RTS =item + TIOCM_SR =item + TIOCM_ST =item + TIOCNOTTY =item + TIOCNXCL =item + TIOCOUTQ =item - TIOCREMOTE =item + TIOCSBRK =item + TIOCSCTTY =item - TIOCSDTR =item + TIOCSETD =item - TIOCSIGNAL =item + TIOCSPGRP =item - TIOCSSID =item + TIOCSSOFTCAR =item - TIOCSTART =item + TIOCSTI =item - TIOCSTOP =item + TIOCSWINSZ =item - TM_ANL =item - TM_CECHO =item - TM_CINVIS =item - TM_LCF =item - TM_NONE =item - TM_SET =item - TM_SNL =item + TOSTOP =item - VCEOF =item - VCEOL =item + VDISCARD =item - VDSUSP =item + VEOF =item + VEOL =item + VEOL2 =item + VERASE =item + VINTR =item + VKILL =item + VLNEXT =item + VMIN =item + VQUIT =item + VREPRINT =item + VSTART =item + VSTOP =item + VSUSP =item - VSWTCH =item + VT0 =item + VT1 =item + VTDLY =item + VTIME =item + VWERASE =item - WRAP =item + XCASE =item - XCLUDE =item - XMT1EN =item + XTABS =back =head1 FOR MORE INFO SEE L<IO::Tty> =cut 5.32/IO/Tty.pm 0000555 00000020434 15125513451 0006566 0 ustar 00 # Documentation at the __END__ # -*-cperl-*- package IO::Tty; use strict; use warnings; use IO::Handle; use IO::File; use IO::Tty::Constant; use Carp; require POSIX; require DynaLoader; use vars qw(@ISA $VERSION $XS_VERSION $CONFIG $DEBUG); $VERSION = '1.20'; $XS_VERSION = "1.20"; @ISA = qw(IO::Handle); eval { local $^W = 0; undef local $SIG{__DIE__}; require IO::Stty }; push @ISA, "IO::Stty" if ( not $@ ); # if IO::Stty is installed BOOT_XS: { # If I inherit DynaLoader then I inherit AutoLoader and I DON'T WANT TO require DynaLoader; # DynaLoader calls dl_load_flags as a static method. *dl_load_flags = DynaLoader->can('dl_load_flags'); do { defined(&bootstrap) ? \&bootstrap : \&DynaLoader::bootstrap; } ->(__PACKAGE__); } sub import { IO::Tty::Constant->export_to_level( 1, @_ ); } sub open { my ( $tty, $dev, $mode ) = @_; IO::File::open( $tty, $dev, $mode ) or return undef; $tty->autoflush; 1; } sub clone_winsize_from { my ( $self, $fh ) = @_; croak "Given filehandle is not a tty in clone_winsize_from, called" if not POSIX::isatty($fh); return 1 if not POSIX::isatty($self); # ignored for master ptys my $winsize = " " x 1024; # preallocate memory for older perl versions $winsize = ''; # But leave the SV as empty ioctl( $fh, &IO::Tty::Constant::TIOCGWINSZ, $winsize ) and ioctl( $self, &IO::Tty::Constant::TIOCSWINSZ, $winsize ) and return 1; warn "clone_winsize_from: error: $!" if $^W; return undef; } # ioctl() doesn't tell us how long the structure is, so we'll have to trim it # after TIOCGWINSZ my $SIZEOF_WINSIZE = length IO::Tty::pack_winsize( 0, 0, 0, 0 ); sub get_winsize { my $self = shift; my $winsize = " " x 1024; # preallocate memory ioctl( $self, IO::Tty::Constant::TIOCGWINSZ(), $winsize ) or croak "Cannot TIOCGWINSZ - $!"; substr( $winsize, $SIZEOF_WINSIZE ) = ""; return IO::Tty::unpack_winsize($winsize); } sub set_winsize { my $self = shift; my $winsize = IO::Tty::pack_winsize(@_); ioctl( $self, IO::Tty::Constant::TIOCSWINSZ(), $winsize ) or croak "Cannot TIOCSWINSZ - $!"; } sub set_raw($) { require POSIX; my $self = shift; return 1 if not POSIX::isatty($self); my $ttyno = fileno($self); my $termios = new POSIX::Termios; unless ($termios) { warn "set_raw: new POSIX::Termios failed: $!"; return undef; } unless ( $termios->getattr($ttyno) ) { warn "set_raw: getattr($ttyno) failed: $!"; return undef; } $termios->setiflag(0); $termios->setoflag(0); $termios->setlflag(0); $termios->setcc( &POSIX::VMIN, 1 ); $termios->setcc( &POSIX::VTIME, 0 ); unless ( $termios->setattr( $ttyno, &POSIX::TCSANOW ) ) { warn "set_raw: setattr($ttyno) failed: $!"; return undef; } return 1; } 1; __END__ =head1 NAME IO::Tty - Low-level allocate a pseudo-Tty, import constants. =head1 VERSION 1.20 =head1 SYNOPSIS use IO::Tty qw(TIOCNOTTY); ... # use only to import constants, see IO::Pty to create ptys. =head1 DESCRIPTION C<IO::Tty> is used internally by C<IO::Pty> to create a pseudo-tty. You wouldn't want to use it directly except to import constants, use C<IO::Pty>. For a list of importable constants, see L<IO::Tty::Constant>. Windows is now supported, but ONLY under the Cygwin environment, see L<http://sources.redhat.com/cygwin/>. Please note that pty creation is very system-dependend. From my experience, any modern POSIX system should be fine. Find below a list of systems that C<IO::Tty> should work on. A more detailed table (which is slowly getting out-of-date) is available from the project pages document manager at SourceForge L<http://sourceforge.net/projects/expectperl/>. If you have problems on your system and your system is listed in the "verified" list, you probably have some non-standard setup, e.g. you compiled your Linux-kernel yourself and disabled ptys (bummer!). Please ask your friendly sysadmin for help. If your system is not listed, unpack the latest version of C<IO::Tty>, do a C<'perl Makefile.PL; make; make test; uname -a'> and send me (F<RGiersig@cpan.org>) the results and I'll see what I can deduce from that. There are chances that it will work right out-of-the-box... If it's working on your system, please send me a short note with details (version number, distribution, etc. 'uname -a' and 'perl -V' is a good start; also, the output from "perl Makefile.PL" contains a lot of interesting info, so please include that as well) so I can get an overview. Thanks! =head1 VERIFIED SYSTEMS, KNOWN ISSUES This is a list of systems that C<IO::Tty> seems to work on ('make test' passes) with comments about "features": =over 4 =item * AIX 4.3 Returns EIO instead of EOF when the slave is closed. Benign. =item * AIX 5.x =item * FreeBSD 4.4 EOF on the slave tty is not reported back to the master. =item * OpenBSD 2.8 The ioctl TIOCSCTTY sometimes fails. This is also known in Tcl/Expect, see http://expect.nist.gov/FAQ.html EOF on the slave tty is not reported back to the master. =item * Darwin 7.9.0 =item * HPUX 10.20 & 11.00 EOF on the slave tty is not reported back to the master. =item * IRIX 6.5 =item * Linux 2.2.x & 2.4.x Returns EIO instead of EOF when the slave is closed. Benign. =item * OSF 4.0 EOF on the slave tty is not reported back to the master. =item * Solaris 8, 2.7, 2.6 Has the "feature" of returning EOF just once?! EOF on the slave tty is not reported back to the master. =item * Windows NT/2k/XP (under Cygwin) When you send (print) a too long line (>160 chars) to a non-raw pty, the call just hangs forever and even alarm() cannot get you out. Don't complain to me... EOF on the slave tty is not reported back to the master. =item * z/OS =back The following systems have not been verified yet for this version, but a previous version worked on them: =over 4 =item * SCO Unix =item * NetBSD probably the same as the other *BSDs... =back If you have additions to these lists, please mail them to E<lt>F<RGiersig@cpan.org>E<gt>. =head1 SEE ALSO L<IO::Pty>, L<IO::Tty::Constant> =head1 MAILING LISTS As this module is mainly used by Expect, support for it is available via the two Expect mailing lists, expectperl-announce and expectperl-discuss, at http://lists.sourceforge.net/lists/listinfo/expectperl-announce and http://lists.sourceforge.net/lists/listinfo/expectperl-discuss =head1 AUTHORS Originally by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>, based on the Ptty module by Nick Ing-Simmons E<lt>F<nik@tiuk.ti.com>E<gt>. Now maintained and heavily rewritten by Roland Giersig E<lt>F<RGiersig@cpan.org>E<gt>. Contains copyrighted stuff from openssh v3.0p1, authored by Tatu Ylonen <ylo@cs.hut.fi>, Markus Friedl and Todd C. Miller <Todd.Miller@courtesan.com>. I also got a lot of inspiration from the pty code in Xemacs. =head1 COPYRIGHT Now all code is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Nevertheless the above AUTHORS retain their copyrights to the various parts and want to receive credit if their source code is used. See the source for details. =head1 DISCLAIMER THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. In other words: Use at your own risk. Provided as is. Your mileage may vary. Read the source, Luke! And finally, just to be sure: Any Use of This Product, in Any Manner Whatsoever, Will Increase the Amount of Disorder in the Universe. Although No Liability Is Implied Herein, the Consumer Is Warned That This Process Will Ultimately Lead to the Heat Death of the Universe. =cut 5.32/IO/Pty.pm 0000444 00000022377 15125513451 0006567 0 ustar 00 # Documentation at the __END__ package IO::Pty; use strict; use Carp; use IO::Tty qw(TIOCSCTTY TCSETCTTY TIOCNOTTY); use IO::File; require POSIX; use vars qw(@ISA $VERSION); $VERSION = '1.20'; # keep same as in Tty.pm @ISA = qw(IO::Handle); eval { local $^W = 0; undef local $SIG{__DIE__}; require IO::Stty }; push @ISA, "IO::Stty" if ( not $@ ); # if IO::Stty is installed sub new { my ($class) = $_[0] || "IO::Pty"; $class = ref($class) if ref($class); @_ <= 1 or croak 'usage: new $class'; my ( $ptyfd, $ttyfd, $ttyname ) = pty_allocate(); croak "Cannot open a pty" if not defined $ptyfd; my $pty = $class->SUPER::new_from_fd( $ptyfd, "r+" ); croak "Cannot create a new $class from fd $ptyfd: $!" if not $pty; $pty->autoflush(1); bless $pty => $class; my $slave = IO::Tty->new_from_fd( $ttyfd, "r+" ); croak "Cannot create a new IO::Tty from fd $ttyfd: $!" if not $slave; $slave->autoflush(1); ${*$pty}{'io_pty_slave'} = $slave; ${*$pty}{'io_pty_ttyname'} = $ttyname; ${*$slave}{'io_tty_ttyname'} = $ttyname; return $pty; } sub ttyname { @_ == 1 or croak 'usage: $pty->ttyname();'; my $pty = shift; ${*$pty}{'io_pty_ttyname'}; } sub close_slave { @_ == 1 or croak 'usage: $pty->close_slave();'; my $master = shift; if ( exists ${*$master}{'io_pty_slave'} ) { close ${*$master}{'io_pty_slave'}; delete ${*$master}{'io_pty_slave'}; } } sub slave { @_ == 1 or croak 'usage: $pty->slave();'; my $master = shift; if ( exists ${*$master}{'io_pty_slave'} ) { return ${*$master}{'io_pty_slave'}; } my $tty = ${*$master}{'io_pty_ttyname'}; my $slave = new IO::Tty; $slave->open( $tty, O_RDWR | O_NOCTTY ) || croak "Cannot open slave $tty: $!"; return $slave; } sub make_slave_controlling_terminal { @_ == 1 or croak 'usage: $pty->make_slave_controlling_terminal();'; my $self = shift; local (*DEVTTY); # loose controlling terminal explicitly if ( defined TIOCNOTTY ) { if ( open( \*DEVTTY, "/dev/tty" ) ) { ioctl( \*DEVTTY, TIOCNOTTY, 0 ); close \*DEVTTY; } } # Create a new 'session', lose controlling terminal. if ( POSIX::setsid() == -1 ) { warn "setsid() failed, strange behavior may result: $!\r\n" if $^W; } if ( open( \*DEVTTY, "/dev/tty" ) ) { warn "Could not disconnect from controlling terminal?!\n" if $^W; close \*DEVTTY; } # now open slave, this should set it as controlling tty on some systems my $ttyname = ${*$self}{'io_pty_ttyname'}; my $slv = new IO::Tty; $slv->open( $ttyname, O_RDWR ) or croak "Cannot open slave $ttyname: $!"; if ( not exists ${*$self}{'io_pty_slave'} ) { ${*$self}{'io_pty_slave'} = $slv; } else { $slv->close; } # Acquire a controlling terminal if this doesn't happen automatically if ( not open( \*DEVTTY, "/dev/tty" ) ) { if ( defined TIOCSCTTY ) { if ( not defined ioctl( ${*$self}{'io_pty_slave'}, TIOCSCTTY, 0 ) ) { warn "warning: TIOCSCTTY failed, slave might not be set as controlling terminal: $!" if $^W; } } elsif ( defined TCSETCTTY ) { if ( not defined ioctl( ${*$self}{'io_pty_slave'}, TCSETCTTY, 0 ) ) { warn "warning: TCSETCTTY failed, slave might not be set as controlling terminal: $!" if $^W; } } else { warn "warning: You have neither TIOCSCTTY nor TCSETCTTY on your system\n" if $^W; return 0; } } if ( not open( \*DEVTTY, "/dev/tty" ) ) { warn "Error: could not connect pty as controlling terminal!\n"; return undef; } else { close \*DEVTTY; } return 1; } *clone_winsize_from = \&IO::Tty::clone_winsize_from; *get_winsize = \&IO::Tty::get_winsize; *set_winsize = \&IO::Tty::set_winsize; *set_raw = \&IO::Tty::set_raw; 1; __END__ =head1 NAME IO::Pty - Pseudo TTY object class =head1 VERSION 1.20 =head1 SYNOPSIS use IO::Pty; $pty = new IO::Pty; $slave = $pty->slave; foreach $val (1..10) { print $pty "$val\n"; $_ = <$slave>; print "$_"; } close($slave); =head1 DESCRIPTION C<IO::Pty> provides an interface to allow the creation of a pseudo tty. C<IO::Pty> inherits from C<IO::Handle> and so provide all the methods defined by the C<IO::Handle> package. Please note that pty creation is very system-dependent. If you have problems, see L<IO::Tty> for help. =head1 CONSTRUCTOR =over 3 =item new The C<new> constructor takes no arguments and returns a new file object which is the master side of the pseudo tty. =back =head1 METHODS =over 4 =item ttyname() Returns the name of the slave pseudo tty. On UNIX machines this will be the pathname of the device. Use this name for informational purpose only, to get a slave filehandle, use slave(). =item slave() The C<slave> method will return the slave filehandle of the given master pty, opening it anew if necessary. If IO::Stty is installed, you can then call C<$slave-E<gt>stty()> to modify the terminal settings. =item close_slave() The slave filehandle will be closed and destroyed. This is necessary in the parent after forking to get rid of the open filehandle, otherwise the parent will not notice if the child exits. Subsequent calls of C<slave()> will return a newly opened slave filehandle. =item make_slave_controlling_terminal() This will set the slave filehandle as the controlling terminal of the current process, which will become a session leader, so this should only be called by a child process after a fork(), e.g. in the callback to C<sync_exec()> (see L<Proc::SyncExec>). See the C<try> script (also C<test.pl>) for an example how to correctly spawn a subprocess. =item set_raw() Will set the pty to raw. Note that this is a one-way operation, you need IO::Stty to set the terminal settings to anything else. On some systems, the master pty is not a tty. This method checks for that and returns success anyway on such systems. Note that this method must be called on the slave, and probably should be called on the master, just to be sure, i.e. $pty->slave->set_raw(); $pty->set_raw(); =item clone_winsize_from(\*FH) Gets the terminal size from filehandle FH (which must be a terminal) and transfers it to the pty. Returns true on success and undef on failure. Note that this must be called upon the I<slave>, i.e. $pty->slave->clone_winsize_from(\*STDIN); On some systems, the master pty also isatty. I actually have no idea if setting terminal sizes there is passed through to the slave, so if this method is called for a master that is not a tty, it silently returns OK. See the C<try> script for example code how to propagate SIGWINCH. =item get_winsize() Returns the terminal size, in a 4-element list. ($row, $col, $xpixel, $ypixel) = $tty->get_winsize() =item set_winsize($row, $col, $xpixel, $ypixel) Sets the terminal size. If not specified, C<$xpixel> and C<$ypixel> are set to 0. As with C<clone_winsize_from>, this must be called upon the I<slave>. =back =head1 SEE ALSO L<IO::Tty>, L<IO::Tty::Constant>, L<IO::Handle>, L<Expect>, L<Proc::SyncExec> =head1 MAILING LISTS As this module is mainly used by Expect, support for it is available via the two Expect mailing lists, expectperl-announce and expectperl-discuss, at http://lists.sourceforge.net/lists/listinfo/expectperl-announce and http://lists.sourceforge.net/lists/listinfo/expectperl-discuss =head1 AUTHORS Originally by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>, based on the Ptty module by Nick Ing-Simmons E<lt>F<nik@tiuk.ti.com>E<gt>. Now maintained and heavily rewritten by Roland Giersig E<lt>F<RGiersig@cpan.org>E<gt>. Contains copyrighted stuff from openssh v3.0p1, authored by Tatu Ylonen <ylo@cs.hut.fi>, Markus Friedl and Todd C. Miller <Todd.Miller@courtesan.com>. =head1 COPYRIGHT Now all code is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Nevertheless the above AUTHORS retain their copyrights to the various parts and want to receive credit if their source code is used. See the source for details. =head1 DISCLAIMER THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. In other words: Use at your own risk. Provided as is. Your mileage may vary. Read the source, Luke! And finally, just to be sure: Any Use of This Product, in Any Manner Whatsoever, Will Increase the Amount of Disorder in the Universe. Although No Liability Is Implied Herein, the Consumer Is Warned That This Process Will Ultimately Lead to the Heat Death of the Universe. =cut 5.32/YAML/XS.pm 0000444 00000007146 15125513451 0006575 0 ustar 00 use strict; use warnings; package YAML::XS; our $VERSION = 'v0.902.0'; # VERSION use base 'Exporter'; @YAML::XS::EXPORT = qw(Load Dump); @YAML::XS::EXPORT_OK = qw(LoadFile DumpFile); %YAML::XS::EXPORT_TAGS = ( all => [qw(Dump Load LoadFile DumpFile)], ); our ( $Boolean, $DumpCode, $ForbidDuplicateKeys, $Indent, $LoadBlessed, $LoadCode, $UseCode, ); $ForbidDuplicateKeys = 0; # $YAML::XS::UseCode = 0; # $YAML::XS::DumpCode = 0; # $YAML::XS::LoadCode = 0; $YAML::XS::QuoteNumericStrings = 1; use YAML::XS::LibYAML qw(Load Dump); use Scalar::Util qw/ openhandle /; sub DumpFile { my $OUT; my $filename = shift; if (openhandle $filename) { $OUT = $filename; } else { my $mode = '>'; if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) { ($mode, $filename) = ($1, $2); } open $OUT, $mode, $filename or die "Can't open '$filename' for output:\n$!"; } local $/ = "\n"; # reset special to "sane" print $OUT YAML::XS::LibYAML::Dump(@_); } sub LoadFile { my $IN; my $filename = shift; if (openhandle $filename) { $IN = $filename; } else { open $IN, $filename or die "Can't open '$filename' for input:\n$!"; } return YAML::XS::LibYAML::Load(do { local $/; local $_ = <$IN> }); } # XXX The following code should be moved from Perl to C. $YAML::XS::coderef2text = sub { my $coderef = shift; require B::Deparse; my $deparse = B::Deparse->new(); my $text; eval { local $^W = 0; $text = $deparse->coderef2text($coderef); }; if ($@) { warn "YAML::XS failed to dump code ref:\n$@"; return; } $text =~ s[BEGIN \{\$\{\^WARNING_BITS\} = "UUUUUUUUUUUU\\001"\}] [use warnings;]g; return $text; }; $YAML::XS::glob2hash = sub { my $hash = {}; for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) { my $value = *{$_[0]}{$type}; $value = $$value if $type eq 'SCALAR'; if (defined $value) { if ($type eq 'IO') { my @stats = qw(device inode mode links uid gid rdev size atime mtime ctime blksize blocks); undef $value; $value->{stat} = {}; map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]}); $value->{fileno} = fileno(*{$_[0]}); { local $^W; $value->{tell} = tell(*{$_[0]}); } } $hash->{$type} = $value; } } return $hash; }; use constant _QR_MAP => { '' => sub { qr{$_[0]} }, x => sub { qr{$_[0]}x }, i => sub { qr{$_[0]}i }, s => sub { qr{$_[0]}s }, m => sub { qr{$_[0]}m }, ix => sub { qr{$_[0]}ix }, sx => sub { qr{$_[0]}sx }, mx => sub { qr{$_[0]}mx }, si => sub { qr{$_[0]}si }, mi => sub { qr{$_[0]}mi }, ms => sub { qr{$_[0]}sm }, six => sub { qr{$_[0]}six }, mix => sub { qr{$_[0]}mix }, msx => sub { qr{$_[0]}msx }, msi => sub { qr{$_[0]}msi }, msix => sub { qr{$_[0]}msix }, }; sub __qr_loader { if ($_[0] =~ /\A \(\? ([\^uixsm]*) (?:- (?:[ixsm]*))? : (.*) \) \z/x) { my ($flags, $re) = ($1, $2); $flags =~ s/^\^//; $flags =~ tr/u//d; my $sub = _QR_MAP->{$flags} || _QR_MAP->{''}; my $qr = &$sub($re); return $qr; } return qr/$_[0]/; } sub __code_loader { my ($string) = @_; my $sub = eval "sub $string"; if ($@) { warn "YAML::XS failed to load sub: $@"; return sub {}; } return $sub; } 1; 5.32/YAML/Loader/Syck.pm 0000444 00000000155 15125513451 0010353 0 ustar 00 package YAML::Loader::Syck; use strict; sub new { $_[0] } sub load { shift; YAML::Syck::Load( $_[0] ) } 1; 5.32/YAML/Dumper/Syck.pm 0000444 00000000155 15125513451 0010401 0 ustar 00 package YAML::Dumper::Syck; use strict; sub new { $_[0] } sub dump { shift; YAML::Syck::Dump( $_[0] ) } 1; 5.32/YAML/LibYAML.pm 0000444 00000000276 15125513451 0007431 0 ustar 00 use strict; use warnings; package YAML::LibYAML; our $VERSION = 'v0.902.0'; # VERSION sub import { die "YAML::LibYAML has been renamed to YAML::XS. Please use YAML::XS instead."; } 1; 5.32/YAML/Syck.pm 0000444 00000023157 15125513451 0007154 0 ustar 00 package YAML::Syck; # See documentation after the __END__ mark. use strict; our ( $Headless, $SingleQuote, $ImplicitBinary, $ImplicitTyping, $ImplicitUnicode, $UseCode, $LoadCode, $DumpCode, $DeparseObject ); use 5.006; use Exporter; use XSLoader (); our $VERSION = '1.34'; our @EXPORT = qw( Dump Load DumpFile LoadFile ); our @EXPORT_OK = qw( DumpInto ); our @ISA = qw( Exporter ); our $SortKeys = 1; our $LoadBlessed = 0; XSLoader::load( 'YAML::Syck', $VERSION ); use constant QR_MAP => { '' => sub { qr{$_[0]} }, x => sub { qr{$_[0]}x }, i => sub { qr{$_[0]}i }, s => sub { qr{$_[0]}s }, m => sub { qr{$_[0]}m }, ix => sub { qr{$_[0]}ix }, sx => sub { qr{$_[0]}sx }, mx => sub { qr{$_[0]}mx }, si => sub { qr{$_[0]}si }, mi => sub { qr{$_[0]}mi }, ms => sub { qr{$_[0]}sm }, six => sub { qr{$_[0]}six }, mix => sub { qr{$_[0]}mix }, msx => sub { qr{$_[0]}msx }, msi => sub { qr{$_[0]}msi }, msix => sub { qr{$_[0]}msix }, }; sub __qr_helper { if ( $_[0] =~ /\A \(\? ([ixsm]*) (?:- (?:[ixsm]*))? : (.*) \) \z/x ) { my $sub = QR_MAP()->{$1} || QR_MAP()->{''}; &$sub($2); } else { qr/$_[0]/; } } sub Dump { $#_ ? join( '', map { YAML::Syck::DumpYAML($_) } @_ ) : YAML::Syck::DumpYAML( $_[0] ); } sub Load { if (wantarray) { my ($rv) = YAML::Syck::LoadYAML( $_[0] ); @{$rv}; } else { @_ = $_[0]; goto &YAML::Syck::LoadYAML; } } sub _is_glob { my $h = shift; return 1 if ( ref($h) eq 'GLOB' ); return 1 if ( ref( \$h ) eq 'GLOB' ); return 1 if ( ref($h) =~ m/^IO::/ ); return; } sub DumpFile { my $file = shift; if ( _is_glob($file) ) { for (@_) { my $err = YAML::Syck::DumpYAMLFile( $_, $file ); if ($err) { $! = 0 + $err; die "Error writing to filehandle $file: $!\n"; } } } else { open( my $fh, '>', $file ) or die "Cannot write to $file: $!"; for (@_) { my $err = YAML::Syck::DumpYAMLFile( $_, $fh ); if ($err) { $! = 0 + $err; die "Error writing to file $file: $!\n"; } } close $fh or die "Error writing to file $file: $!\n"; } return 1; } sub LoadFile { my $file = shift; if ( _is_glob($file) ) { Load( do { local $/; <$file> } ); } else { if ( !-e $file || -z $file ) { die("'$file' is empty or non-existent"); } open( my $fh, '<', $file ) or die "Cannot read from $file: $!"; Load( do { local $/; <$fh> } ); } } sub DumpInto { my $bufref = shift; ( ref $bufref ) or die "DumpInto not given reference to output buffer\n"; YAML::Syck::DumpYAMLInto( $_, $bufref ) for @_; 1; } 1; __END__ =pod =head1 NAME YAML::Syck - Fast, lightweight YAML loader and dumper =head1 SYNOPSIS use YAML::Syck; # Set this for interoperability with other YAML/Syck bindings: # e.g. Load('Yes') becomes 1 and Load('No') becomes ''. $YAML::Syck::ImplicitTyping = 1; $data = Load($yaml); $yaml = Dump($data); # $file can be an IO object, or a filename $data = LoadFile($file); DumpFile($file, $data); # A string with multiple YAML streams in it $yaml = Dump(@data); @data = Load($yaml); # Dumping into a pre-existing output buffer my $yaml; DumpInto(\$yaml, @data); =head1 DESCRIPTION This module provides a Perl interface to the B<libsyck> data serialization library. It exports the C<Dump> and C<Load> functions for converting Perl data structures to YAML strings, and the other way around. B<NOTE>: If you are working with other language's YAML/Syck bindings (such as Ruby), please set C<$YAML::Syck::ImplicitTyping> to C<1> before calling the C<Load>/C<Dump> functions. The default setting is for preserving backward-compatibility with C<YAML.pm>. =head1 Differences Between YAML::Syck and YAML =head2 Error handling Some calls are designed to die rather than returning YAML. You should wrap your calls in eval to assure you do not get unexpected results. =head1 FLAGS =head2 $YAML::Syck::Headless Defaults to false. Setting this to a true value will make C<Dump> omit the leading C<---\n> marker. =head2 $YAML::Syck::SortKeys Defaults to false. Setting this to a true value will make C<Dump> sort hash keys. =head2 $YAML::Syck::SingleQuote Defaults to false. Setting this to a true value will make C<Dump> always emit single quotes instead of bare strings. =head2 $YAML::Syck::ImplicitTyping Defaults to false. Setting this to a true value will make C<Load> recognize various implicit types in YAML, such as unquoted C<true>, C<false>, as well as integers and floating-point numbers. Otherwise, only C<~> is recognized to be C<undef>. =head2 $YAML::Syck::ImplicitUnicode Defaults to false. For Perl 5.8.0 or later, setting this to a true value will make C<Load> set Unicode flag on for every string that contains valid UTF8 sequences, and make C<Dump> return a unicode string. Regardless of this flag, Unicode strings are dumped verbatim without escaping; byte strings with high-bit set will be dumped with backslash escaping. However, because YAML does not distinguish between these two kinds of strings, so this flag will affect loading of both variants of strings. If you want to use LoadFile or DumpFile with unicode, you are required to open your own file in order to assure it's UTF8 encoded: open(my $fh, ">:encoding(UTF-8)", "out.yml"); DumpFile($fh, $hashref); =head2 $YAML::Syck::ImplicitBinary Defaults to false. For Perl 5.8.0 or later, setting this to a true value will make C<Dump> generate Base64-encoded C<!!binary> data for all non-Unicode scalars containing high-bit bytes. =head2 $YAML::Syck::UseCode / $YAML::Syck::LoadCode / $YAML::Syck::DumpCode These flags control whether or not to try and eval/deparse perl source code; each of them defaults to false. Setting C<$YAML::Syck::UseCode> to a true value is equivalent to setting both C<$YAML::Syck::LoadCode> and C<$YAML::Syck::DumpCode> to true. =head2 $YAML::Syck::LoadBlessed Defaults to false. Setting to true will allow YAML::Syck to bless objects as it imports objects. This default changed in 1.32. You can create any kind of object with YAML. The creation itself is not the critical part. If the class has a DESTROY method, it will be called once the object is deleted. An example with File::Temp removing files can be found at L<https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=862373|https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=862373> =head1 BUGS Dumping Glob/IO values do not work yet. Dumping of Tied variables is unsupported. Dumping into tied (or other magic variables) with C<DumpInto> might not work properly in all cases. =head1 CAVEATS This module implements the YAML 1.0 spec. To deal with data in YAML 1.1, please use the C<YAML::XS> module instead. The current implementation bundles libsyck source code; if your system has a site-wide shared libsyck, it will I<not> be used. Tag names such as C<!!perl/hash:Foo> is blessed into the package C<Foo>, but the C<!hs/foo> and C<!!hs/Foo> tags are blessed into C<hs::Foo>. Note that this holds true even if the tag contains non-word characters; for example, C<!haskell.org/Foo> is blessed into C<haskell.org::Foo>. Please use L<Class::Rebless> to cast it into other user-defined packages. You can also set the LoadBlessed flag false to disable all blessing. This module has L<a lot of known issues|https://rt.cpan.org/Public/Dist/Display.html?Name=YAML-Syck> and has only been semi-actively maintained since 2007. If you encounter an issue with it probably won't be fixed unless you L<offer up a patch|http://github.com/toddr/YAML-Syck> in Git that's ready for release. There are still good reasons to use this module, such as better interoperability with other syck wrappers (like Ruby's), or some edge case of YAML's syntax that it handles better. It'll probably work perfectly for you, but if it doesn't you may want to look at L<YAML::XS>, or perhaps at looking another serialization format like L<JSON>. =head1 SEE ALSO L<YAML>, L<JSON::Syck> L<http://www.yaml.org/> =head1 AUTHORS Audrey Tang E<lt>cpan@audreyt.orgE<gt> =head1 COPYRIGHT Copyright 2005-2009 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>. This software is released under the MIT license cited below. The F<libsyck> code bundled with this library is released by "why the lucky stiff", under a BSD-style license. See the F<COPYING> file for details. =head2 The "MIT" License Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =cut 5.32/YAML/XS.pod 0000444 00000012740 15125513451 0006737 0 ustar 00 =pod =encoding utf8 =head1 NAME YAML::XS - Perl YAML Serialization using XS and libyaml =for html <a href="https://github.com/ingydotnet/yaml-libyaml-pm/actions/workflows/linux.yml"><img src="https://github.com/ingydotnet/yaml-libyaml-pm/actions/workflows/linux.yml/badge.svg" alt="linux"></a> =head1 SYNOPSIS use YAML::XS; my $yaml = Dump [ 1..4 ]; my $array = Load $yaml; =head1 DESCRIPTION Kirill Simonov's C<libyaml> is arguably the best YAML implementation. The C library is written precisely to the YAML 1.1 specification. It was originally bound to Python and was later bound to Ruby. This module is a Perl XS binding to libyaml which offers Perl the best YAML support to date. This module exports the functions C<Dump>, C<Load>, C<DumpFile> and C<LoadFile>. These functions are intended to work exactly like C<YAML.pm>'s corresponding functions. Only C<Load> and C<Dump> are exported by default. =head1 CONFIGURATION =over =item * C<$YAML::XS::LoadBlessed> (since v0.69) Default: false. The default was changed in version 0.81. When set to false, it will not bless data into objects, which can be a security problem, when loading YAML from an untrusted source. It will silently ignore the tag and just load the data unblessed. In PyYAML, this is called SafeLoad. If set to true, it will load the following YAML as objects: --- local: !Foo::Bar [a] perl: !!perl/hash:Foo::Bar { a: 1 } regex: !!perl/regexp:Foo::Bar pattern You can create any kind of object with YAML. The creation itself is not the critical part. If the class has a C<DESTROY> method, it will be called once the object is deleted. An example with File::Temp removing files can be found at L<https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=862373|https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=862373>. =item * C<$YAML::XS::ForbidDuplicateKeys> (since 0.84) Default: false When set to true, C<Load> will die when encountering a duplicate key in a hash, e.g. key: value key: another value This can be useful for bigger YAML documents where it is not that obvious, and it is recommended to set it to true. That's also what a YAML loader should do by default according to the YAML specification. =item * C<$YAML::XS::UseCode> =item * C<$YAML::XS::DumpCode> =item * C<$YAML::XS::LoadCode> If enabled supports deparsing and evaling of code blocks. Note that support for loading code was added in version 0.75, although C<$LoadCode> was documented already in earlier versions. =item * C<$YAML::XS::QuoteNumericStrings> When true (the default) strings that look like numbers but have not been numified will be quoted when dumping. This ensures leading that things like leading zeros and other formatting are preserved. =item * C<$YAML::XS::Boolean> (since v0.67) Default: undef Since YAML::XS 0.89: When used with perl 5.36 or later, builtin booleans will work out of the box. They will be created by C<Load> and recognized by C<Dump> automatically (since YAML::XS 0.89). say Dump({ truth => builtin::true }); # truth: true Since YAML::XS v0.902: loaded booleans are not set to readonly anymore. For older perl versions you can use the following configuration to serialize data as YAML booleans: When set to C<"JSON::PP"> or C<"boolean">, the plain (unquoted) strings C<true> and C<false> will be loaded as C<JSON::PP::Boolean> or C<boolean.pm> objects. Those objects will be dumped again as plain "true" or "false". It will try to load [JSON::PP] or [boolean] and die if it can't be loaded. With that it's possible to add new "real" booleans to a data structure: local $YAML::XS::Boolean = "JSON::PP"; # or "boolean" my $data = Load("booltrue: true"); $data->{boolfalse} = JSON::PP::false; my $yaml = Dump($data); # boolfalse: false # booltrue: true It also lets booleans survive when loading YAML via YAML::XS and encode it in JSON via one of the various JSON encoders, which mostly support JSON::PP booleans. Please note that JSON::PP::Boolean and boolean.pm behave a bit differently. Ideally you should only use them in boolean context. If not set, booleans are loaded as special perl variables C<PL_sv_yes> and C<PL_sv_no>, which have the disadvantage that they are readonly, and you can't add those to an existing data structure with pure perl. If you simply need to load "perl booleans" that are true or false in boolean context, you will be fine with the default setting. =item * C<$YAML::XS::Indent> (since v0.76) Default is 2. Sets the number of spaces for indentation for C<Dump>. =back =head1 USING YAML::XS WITH UNICODE Handling unicode properly in Perl can be a pain. YAML::XS only deals with streams of utf8 octets. Just remember this: $perl = Load($utf8_octets); $utf8_octets = Dump($perl); There are many, many places where things can go wrong with unicode. If you are having problems, use Devel::Peek on all the possible data points. =head1 LIBYAML You can find out (since v.079) which libyaml version this module was built with: my $libyaml_version = YAML::XS::LibYAML::libyaml_version(); =head1 SEE ALSO =over =item * YAML.pm =item * YAML::Syck =item * YAML::Tiny =item * YAML::PP =item * YAML::PP::LibYAML =back =head1 AUTHOR Ingy döt Net L<ingy@ingy.net|mailto:ingy@ingy.net> =head1 COPYRIGHT AND LICENSE Copyright 2007-2024 - Ingy döt Net This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<http://www.perl.com/perl/misc/Artistic.html|http://www.perl.com/perl/misc/Artistic.html> =cut 5.32/YAML/XS/LibYAML.pm 0000444 00000000370 15125513451 0007756 0 ustar 00 package YAML::XS::LibYAML; use 5.008001; use strict; use warnings; use XSLoader; XSLoader::load 'YAML::XS::LibYAML'; use base 'Exporter'; our @EXPORT_OK = qw(Load Dump); 1; =head1 NAME YAML::XS::LibYAML - An XS Wrapper Module of libyaml =cut 5.32/YAML/LibYAML.pod 0000444 00000001077 15125513451 0007577 0 ustar 00 =pod =encoding utf8 =head1 NAME YAML::LibYAML - Perl YAML Serialization using XS and libyaml =head1 NOTE C<YAML-LibYAML> is the CPAN I<distribution> name for the C<YAML::XS> module. See the YAML::XS documentation instead. =head1 AUTHOR Ingy döt Net L<ingy@cpan.org|mailto:ingy@cpan.org> =head1 COPYRIGHT AND LICENSE Copyright 2007-2022 - Ingy döt Net This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<http://www.perl.com/perl/misc/Artistic.html|http://www.perl.com/perl/misc/Artistic.html> =cut 5.32/Storable.pm 0000444 00000141403 15125513451 0007247 0 ustar 00 # # Copyright (c) 1995-2001, Raphael Manfredi # Copyright (c) 2002-2014 by the Perl 5 Porters # Copyright (c) 2015-2016 cPanel Inc # Copyright (c) 2017 Reini Urban # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # BEGIN { require XSLoader } require Exporter; package Storable; our @ISA = qw(Exporter); our @EXPORT = qw(store retrieve); our @EXPORT_OK = qw( nstore store_fd nstore_fd fd_retrieve freeze nfreeze thaw dclone retrieve_fd lock_store lock_nstore lock_retrieve file_magic read_magic BLESS_OK TIE_OK FLAGS_COMPAT stack_depth stack_depth_hash ); our ($canonical, $forgive_me); BEGIN { our $VERSION = '3.25'; } our $recursion_limit; our $recursion_limit_hash; $recursion_limit = 512 unless defined $recursion_limit; $recursion_limit_hash = 256 unless defined $recursion_limit_hash; use Carp; BEGIN { if (eval { local $SIG{__DIE__}; local @INC = @INC; pop @INC if $INC[-1] eq '.'; require Log::Agent; 1; }) { Log::Agent->import; } # # Use of Log::Agent is optional. If it hasn't imported these subs then # provide a fallback implementation. # unless ($Storable::{logcroak} && *{$Storable::{logcroak}}{CODE}) { *logcroak = \&Carp::croak; } else { # Log::Agent's logcroak always adds a newline to the error it is # given. This breaks refs getting thrown. We can just discard what # it throws (but keep whatever logging it does) and throw the original # args. no warnings 'redefine'; my $logcroak = \&logcroak; *logcroak = sub { my @args = @_; eval { &$logcroak }; Carp::croak(@args); }; } unless ($Storable::{logcarp} && *{$Storable::{logcarp}}{CODE}) { *logcarp = \&Carp::carp; } } # # They might miss :flock in Fcntl # BEGIN { if (eval { require Fcntl; 1 } && exists $Fcntl::EXPORT_TAGS{'flock'}) { Fcntl->import(':flock'); } else { eval q{ sub LOCK_SH () { 1 } sub LOCK_EX () { 2 } }; } } sub CLONE { # clone context under threads Storable::init_perinterp(); } sub BLESS_OK () { 2 } sub TIE_OK () { 4 } sub FLAGS_COMPAT () { BLESS_OK | TIE_OK } # By default restricted hashes are downgraded on earlier perls. $Storable::flags = FLAGS_COMPAT; $Storable::downgrade_restricted = 1; $Storable::accept_future_minor = 1; BEGIN { XSLoader::load('Storable') }; # # Determine whether locking is possible, but only when needed. # sub show_file_magic { print <<EOM; # # To recognize the data files of the Perl module Storable, # the following lines need to be added to the local magic(5) file, # usually either /usr/share/misc/magic or /etc/magic. # 0 string perl-store perl Storable(v0.6) data >4 byte >0 (net-order %d) >>4 byte &01 (network-ordered) >>4 byte =3 (major 1) >>4 byte =2 (major 1) 0 string pst0 perl Storable(v0.7) data >4 byte >0 >>4 byte &01 (network-ordered) >>4 byte =5 (major 2) >>4 byte =4 (major 2) >>5 byte >0 (minor %d) EOM } sub file_magic { require IO::File; my $file = shift; my $fh = IO::File->new; open($fh, "<", $file) || die "Can't open '$file': $!"; binmode($fh); defined(sysread($fh, my $buf, 32)) || die "Can't read from '$file': $!"; close($fh); $file = "./$file" unless $file; # ensure TRUE value return read_magic($buf, $file); } sub read_magic { my($buf, $file) = @_; my %info; my $buflen = length($buf); my $magic; if ($buf =~ s/^(pst0|perl-store)//) { $magic = $1; $info{file} = $file || 1; } else { return undef if $file; $magic = ""; } return undef unless length($buf); my $net_order; if ($magic eq "perl-store" && ord(substr($buf, 0, 1)) > 1) { $info{version} = -1; $net_order = 0; } else { $buf =~ s/(.)//s; my $major = (ord $1) >> 1; return undef if $major > 4; # sanity (assuming we never go that high) $info{major} = $major; $net_order = (ord $1) & 0x01; if ($major > 1) { return undef unless $buf =~ s/(.)//s; my $minor = ord $1; $info{minor} = $minor; $info{version} = "$major.$minor"; $info{version_nv} = sprintf "%d.%03d", $major, $minor; } else { $info{version} = $major; } } $info{version_nv} ||= $info{version}; $info{netorder} = $net_order; unless ($net_order) { return undef unless $buf =~ s/(.)//s; my $len = ord $1; return undef unless length($buf) >= $len; return undef unless $len == 4 || $len == 8; # sanity @info{qw(byteorder intsize longsize ptrsize)} = unpack "a${len}CCC", $buf; (substr $buf, 0, $len + 3) = ''; if ($info{version_nv} >= 2.002) { return undef unless $buf =~ s/(.)//s; $info{nvsize} = ord $1; } } $info{hdrsize} = $buflen - length($buf); return \%info; } sub BIN_VERSION_NV { sprintf "%d.%03d", BIN_MAJOR(), BIN_MINOR(); } sub BIN_WRITE_VERSION_NV { sprintf "%d.%03d", BIN_MAJOR(), BIN_WRITE_MINOR(); } # # store # # Store target object hierarchy, identified by a reference to its root. # The stored object tree may later be retrieved to memory via retrieve. # Returns undef if an I/O error occurred, in which case the file is # removed. # sub store { return _store(\&pstore, @_, 0); } # # nstore # # Same as store, but in network order. # sub nstore { return _store(\&net_pstore, @_, 0); } # # lock_store # # Same as store, but flock the file first (advisory locking). # sub lock_store { return _store(\&pstore, @_, 1); } # # lock_nstore # # Same as nstore, but flock the file first (advisory locking). # sub lock_nstore { return _store(\&net_pstore, @_, 1); } # Internal store to file routine sub _store { my $xsptr = shift; my $self = shift; my ($file, $use_locking) = @_; logcroak "not a reference" unless ref($self); logcroak "wrong argument number" unless @_ == 2; # No @foo in arglist local *FILE; if ($use_locking) { open(FILE, ">>", $file) || logcroak "can't write into $file: $!"; unless (CAN_FLOCK) { logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O"; return undef; } flock(FILE, LOCK_EX) || logcroak "can't get exclusive lock on $file: $!"; truncate FILE, 0; # Unlocking will happen when FILE is closed } else { open(FILE, ">", $file) || logcroak "can't create $file: $!"; } binmode FILE; # Archaic systems... my $da = $@; # Don't mess if called from exception handler my $ret; # Call C routine nstore or pstore, depending on network order eval { $ret = &$xsptr(*FILE, $self) }; # close will return true on success, so the or short-circuits, the () # expression is true, and for that case the block will only be entered # if $@ is true (ie eval failed) # if close fails, it returns false, $ret is altered, *that* is (also) # false, so the () expression is false, !() is true, and the block is # entered. if (!(close(FILE) or undef $ret) || $@) { unlink($file) or warn "Can't unlink $file: $!\n"; } if ($@) { $@ =~ s/\.?\n$/,/ unless ref $@; logcroak $@; } $@ = $da; return $ret; } # # store_fd # # Same as store, but perform on an already opened file descriptor instead. # Returns undef if an I/O error occurred. # sub store_fd { return _store_fd(\&pstore, @_); } # # nstore_fd # # Same as store_fd, but in network order. # sub nstore_fd { my ($self, $file) = @_; return _store_fd(\&net_pstore, @_); } # Internal store routine on opened file descriptor sub _store_fd { my $xsptr = shift; my $self = shift; my ($file) = @_; logcroak "not a reference" unless ref($self); logcroak "too many arguments" unless @_ == 1; # No @foo in arglist my $fd = fileno($file); logcroak "not a valid file descriptor" unless defined $fd; my $da = $@; # Don't mess if called from exception handler my $ret; # Call C routine nstore or pstore, depending on network order eval { $ret = &$xsptr($file, $self) }; logcroak $@ if $@ =~ s/\.?\n$/,/; local $\; print $file ''; # Autoflush the file if wanted $@ = $da; return $ret; } # # freeze # # Store object and its hierarchy in memory and return a scalar # containing the result. # sub freeze { _freeze(\&mstore, @_); } # # nfreeze # # Same as freeze but in network order. # sub nfreeze { _freeze(\&net_mstore, @_); } # Internal freeze routine sub _freeze { my $xsptr = shift; my $self = shift; logcroak "not a reference" unless ref($self); logcroak "too many arguments" unless @_ == 0; # No @foo in arglist my $da = $@; # Don't mess if called from exception handler my $ret; # Call C routine mstore or net_mstore, depending on network order eval { $ret = &$xsptr($self) }; if ($@) { $@ =~ s/\.?\n$/,/ unless ref $@; logcroak $@; } $@ = $da; return $ret ? $ret : undef; } # # retrieve # # Retrieve object hierarchy from disk, returning a reference to the root # object of that tree. # # retrieve(file, flags) # flags include by default BLESS_OK=2 | TIE_OK=4 # with flags=0 or the global $Storable::flags set to 0, no resulting object # will be blessed nor tied. # sub retrieve { _retrieve(shift, 0, @_); } # # lock_retrieve # # Same as retrieve, but with advisory locking. # sub lock_retrieve { _retrieve(shift, 1, @_); } # Internal retrieve routine sub _retrieve { my ($file, $use_locking, $flags) = @_; $flags = $Storable::flags unless defined $flags; my $FILE; open($FILE, "<", $file) || logcroak "can't open $file: $!"; binmode $FILE; # Archaic systems... my $self; my $da = $@; # Could be from exception handler if ($use_locking) { unless (CAN_FLOCK) { logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O"; return undef; } flock($FILE, LOCK_SH) || logcroak "can't get shared lock on $file: $!"; # Unlocking will happen when FILE is closed } eval { $self = pretrieve($FILE, $flags) }; # Call C routine close($FILE); if ($@) { $@ =~ s/\.?\n$/,/ unless ref $@; logcroak $@; } $@ = $da; return $self; } # # fd_retrieve # # Same as retrieve, but perform from an already opened file descriptor instead. # sub fd_retrieve { my ($file, $flags) = @_; $flags = $Storable::flags unless defined $flags; my $fd = fileno($file); logcroak "not a valid file descriptor" unless defined $fd; my $self; my $da = $@; # Could be from exception handler eval { $self = pretrieve($file, $flags) }; # Call C routine if ($@) { $@ =~ s/\.?\n$/,/ unless ref $@; logcroak $@; } $@ = $da; return $self; } sub retrieve_fd { &fd_retrieve } # Backward compatibility # # thaw # # Recreate objects in memory from an existing frozen image created # by freeze. If the frozen image passed is undef, return undef. # # thaw(frozen_obj, flags) # flags include by default BLESS_OK=2 | TIE_OK=4 # with flags=0 or the global $Storable::flags set to 0, no resulting object # will be blessed nor tied. # sub thaw { my ($frozen, $flags) = @_; $flags = $Storable::flags unless defined $flags; return undef unless defined $frozen; my $self; my $da = $@; # Could be from exception handler eval { $self = mretrieve($frozen, $flags) };# Call C routine if ($@) { $@ =~ s/\.?\n$/,/ unless ref $@; logcroak $@; } $@ = $da; return $self; } # # _make_re($re, $flags) # # Internal function used to thaw a regular expression. # my $re_flags; BEGIN { if ($] < 5.010) { $re_flags = qr/\A[imsx]*\z/; } elsif ($] < 5.014) { $re_flags = qr/\A[msixp]*\z/; } elsif ($] < 5.022) { $re_flags = qr/\A[msixpdual]*\z/; } else { $re_flags = qr/\A[msixpdualn]*\z/; } } sub _make_re { my ($re, $flags) = @_; $flags =~ $re_flags or die "regexp flags invalid"; my $qr = eval "qr/\$re/$flags"; die $@ if $@; $qr; } if ($] < 5.012) { eval <<'EOS' sub _regexp_pattern { my $re = "" . shift; $re =~ /\A\(\?([xism]*)(?:-[xism]*)?:(.*)\)\z/s or die "Cannot parse regexp /$re/"; return ($2, $1); } 1 EOS or die "Cannot define _regexp_pattern: $@"; } 1; __END__ =head1 NAME Storable - persistence for Perl data structures =head1 SYNOPSIS use Storable; store \%table, 'file'; $hashref = retrieve('file'); use Storable qw(nstore store_fd nstore_fd freeze thaw dclone); # Network order nstore \%table, 'file'; $hashref = retrieve('file'); # There is NO nretrieve() # Storing to and retrieving from an already opened file store_fd \@array, \*STDOUT; nstore_fd \%table, \*STDOUT; $aryref = fd_retrieve(\*SOCKET); $hashref = fd_retrieve(\*SOCKET); # Serializing to memory $serialized = freeze \%table; %table_clone = %{ thaw($serialized) }; # Deep (recursive) cloning $cloneref = dclone($ref); # Advisory locking use Storable qw(lock_store lock_nstore lock_retrieve) lock_store \%table, 'file'; lock_nstore \%table, 'file'; $hashref = lock_retrieve('file'); =head1 DESCRIPTION The Storable package brings persistence to your Perl data structures containing SCALAR, ARRAY, HASH or REF objects, i.e. anything that can be conveniently stored to disk and retrieved at a later time. It can be used in the regular procedural way by calling C<store> with a reference to the object to be stored, along with the file name where the image should be written. The routine returns C<undef> for I/O problems or other internal error, a true value otherwise. Serious errors are propagated as a C<die> exception. To retrieve data stored to disk, use C<retrieve> with a file name. The objects stored into that file are recreated into memory for you, and a I<reference> to the root object is returned. In case an I/O error occurs while reading, C<undef> is returned instead. Other serious errors are propagated via C<die>. Since storage is performed recursively, you might want to stuff references to objects that share a lot of common data into a single array or hash table, and then store that object. That way, when you retrieve back the whole thing, the objects will continue to share what they originally shared. At the cost of a slight header overhead, you may store to an already opened file descriptor using the C<store_fd> routine, and retrieve from a file via C<fd_retrieve>. Those names aren't imported by default, so you will have to do that explicitly if you need those routines. The file descriptor you supply must be already opened, for read if you're going to retrieve and for write if you wish to store. store_fd(\%table, *STDOUT) || die "can't store to stdout\n"; $hashref = fd_retrieve(*STDIN); You can also store data in network order to allow easy sharing across multiple platforms, or when storing on a socket known to be remotely connected. The routines to call have an initial C<n> prefix for I<network>, as in C<nstore> and C<nstore_fd>. At retrieval time, your data will be correctly restored so you don't have to know whether you're restoring from native or network ordered data. Double values are stored stringified to ensure portability as well, at the slight risk of loosing some precision in the last decimals. When using C<fd_retrieve>, objects are retrieved in sequence, one object (i.e. one recursive tree) per associated C<store_fd>. If you're more from the object-oriented camp, you can inherit from Storable and directly store your objects by invoking C<store> as a method. The fact that the root of the to-be-stored tree is a blessed reference (i.e. an object) is special-cased so that the retrieve does not provide a reference to that object but rather the blessed object reference itself. (Otherwise, you'd get a reference to that blessed object). =head1 MEMORY STORE The Storable engine can also store data into a Perl scalar instead, to later retrieve them. This is mainly used to freeze a complex structure in some safe compact memory place (where it can possibly be sent to another process via some IPC, since freezing the structure also serializes it in effect). Later on, and maybe somewhere else, you can thaw the Perl scalar out and recreate the original complex structure in memory. Surprisingly, the routines to be called are named C<freeze> and C<thaw>. If you wish to send out the frozen scalar to another machine, use C<nfreeze> instead to get a portable image. Note that freezing an object structure and immediately thawing it actually achieves a deep cloning of that structure: dclone(.) = thaw(freeze(.)) Storable provides you with a C<dclone> interface which does not create that intermediary scalar but instead freezes the structure in some internal memory space and then immediately thaws it out. =head1 ADVISORY LOCKING The C<lock_store> and C<lock_nstore> routine are equivalent to C<store> and C<nstore>, except that they get an exclusive lock on the file before writing. Likewise, C<lock_retrieve> does the same as C<retrieve>, but also gets a shared lock on the file before reading. As with any advisory locking scheme, the protection only works if you systematically use C<lock_store> and C<lock_retrieve>. If one side of your application uses C<store> whilst the other uses C<lock_retrieve>, you will get no protection at all. The internal advisory locking is implemented using Perl's flock() routine. If your system does not support any form of flock(), or if you share your files across NFS, you might wish to use other forms of locking by using modules such as LockFile::Simple which lock a file using a filesystem entry, instead of locking the file descriptor. =head1 SPEED The heart of Storable is written in C for decent speed. Extra low-level optimizations have been made when manipulating perl internals, to sacrifice encapsulation for the benefit of greater speed. =head1 CANONICAL REPRESENTATION Normally, Storable stores elements of hashes in the order they are stored internally by Perl, i.e. pseudo-randomly. If you set C<$Storable::canonical> to some C<TRUE> value, Storable will store hashes with the elements sorted by their key. This allows you to compare data structures by comparing their frozen representations (or even the compressed frozen representations), which can be useful for creating lookup tables for complicated queries. Canonical order does not imply network order; those are two orthogonal settings. =head1 CODE REFERENCES Since Storable version 2.05, CODE references may be serialized with the help of L<B::Deparse>. To enable this feature, set C<$Storable::Deparse> to a true value. To enable deserialization, C<$Storable::Eval> should be set to a true value. Be aware that deserialization is done through C<eval>, which is dangerous if the Storable file contains malicious data. You can set C<$Storable::Eval> to a subroutine reference which would be used instead of C<eval>. See below for an example using a L<Safe> compartment for deserialization of CODE references. If C<$Storable::Deparse> and/or C<$Storable::Eval> are set to false values, then the value of C<$Storable::forgive_me> (see below) is respected while serializing and deserializing. =head1 FORWARD COMPATIBILITY This release of Storable can be used on a newer version of Perl to serialize data which is not supported by earlier Perls. By default, Storable will attempt to do the right thing, by C<croak()>ing if it encounters data that it cannot deserialize. However, the defaults can be changed as follows: =over 4 =item utf8 data Perl 5.6 added support for Unicode characters with code points > 255, and Perl 5.8 has full support for Unicode characters in hash keys. Perl internally encodes strings with these characters using utf8, and Storable serializes them as utf8. By default, if an older version of Perl encounters a utf8 value it cannot represent, it will C<croak()>. To change this behaviour so that Storable deserializes utf8 encoded values as the string of bytes (effectively dropping the I<is_utf8> flag) set C<$Storable::drop_utf8> to some C<TRUE> value. This is a form of data loss, because with C<$drop_utf8> true, it becomes impossible to tell whether the original data was the Unicode string, or a series of bytes that happen to be valid utf8. =item restricted hashes Perl 5.8 adds support for restricted hashes, which have keys restricted to a given set, and can have values locked to be read only. By default, when Storable encounters a restricted hash on a perl that doesn't support them, it will deserialize it as a normal hash, silently discarding any placeholder keys and leaving the keys and all values unlocked. To make Storable C<croak()> instead, set C<$Storable::downgrade_restricted> to a C<FALSE> value. To restore the default set it back to some C<TRUE> value. The cperl PERL_PERTURB_KEYS_TOP hash strategy has a known problem with restricted hashes. =item huge objects On 64bit systems some data structures may exceed the 2G (i.e. I32_MAX) limit. On 32bit systems also strings between I32 and U32 (2G-4G). Since Storable 3.00 (not in perl5 core) we are able to store and retrieve these objects, even if perl5 itself is not able to handle them. These are strings longer then 4G, arrays with more then 2G elements and hashes with more then 2G elements. cperl forbids hashes with more than 2G elements, but this fail in cperl then. perl5 itself at least until 5.26 allows it, but cannot iterate over them. Note that creating those objects might cause out of memory exceptions by the operating system before perl has a chance to abort. =item files from future versions of Storable Earlier versions of Storable would immediately croak if they encountered a file with a higher internal version number than the reading Storable knew about. Internal version numbers are increased each time new data types (such as restricted hashes) are added to the vocabulary of the file format. This meant that a newer Storable module had no way of writing a file readable by an older Storable, even if the writer didn't store newer data types. This version of Storable will defer croaking until it encounters a data type in the file that it does not recognize. This means that it will continue to read files generated by newer Storable modules which are careful in what they write out, making it easier to upgrade Storable modules in a mixed environment. The old behaviour of immediate croaking can be re-instated by setting C<$Storable::accept_future_minor> to some C<FALSE> value. =back All these variables have no effect on a newer Perl which supports the relevant feature. =head1 ERROR REPORTING Storable uses the "exception" paradigm, in that it does not try to workaround failures: if something bad happens, an exception is generated from the caller's perspective (see L<Carp> and C<croak()>). Use eval {} to trap those exceptions. When Storable croaks, it tries to report the error via the C<logcroak()> routine from the C<Log::Agent> package, if it is available. Normal errors are reported by having store() or retrieve() return C<undef>. Such errors are usually I/O errors (or truncated stream errors at retrieval). When Storable throws the "Max. recursion depth with nested structures exceeded" error we are already out of stack space. Unfortunately on some earlier perl versions cleaning up a recursive data structure recurses into the free calls, which will lead to stack overflows in the cleanup. This data structure is not properly cleaned up then, it will only be destroyed during global destruction. =head1 WIZARDS ONLY =head2 Hooks Any class may define hooks that will be called during the serialization and deserialization process on objects that are instances of that class. Those hooks can redefine the way serialization is performed (and therefore, how the symmetrical deserialization should be conducted). Since we said earlier: dclone(.) = thaw(freeze(.)) everything we say about hooks should also hold for deep cloning. However, hooks get to know whether the operation is a mere serialization, or a cloning. Therefore, when serializing hooks are involved, dclone(.) <> thaw(freeze(.)) Well, you could keep them in sync, but there's no guarantee it will always hold on classes somebody else wrote. Besides, there is little to gain in doing so: a serializing hook could keep only one attribute of an object, which is probably not what should happen during a deep cloning of that same object. Here is the hooking interface: =over 4 =item C<STORABLE_freeze> I<obj>, I<cloning> The serializing hook, called on the object during serialization. It can be inherited, or defined in the class itself, like any other method. Arguments: I<obj> is the object to serialize, I<cloning> is a flag indicating whether we're in a dclone() or a regular serialization via store() or freeze(). Returned value: A LIST C<($serialized, $ref1, $ref2, ...)> where $serialized is the serialized form to be used, and the optional $ref1, $ref2, etc... are extra references that you wish to let the Storable engine serialize. At deserialization time, you will be given back the same LIST, but all the extra references will be pointing into the deserialized structure. The B<first time> the hook is hit in a serialization flow, you may have it return an empty list. That will signal the Storable engine to further discard that hook for this class and to therefore revert to the default serialization of the underlying Perl data. The hook will again be normally processed in the next serialization. Unless you know better, serializing hook should always say: sub STORABLE_freeze { my ($self, $cloning) = @_; return if $cloning; # Regular default serialization .... } in order to keep reasonable dclone() semantics. =item C<STORABLE_thaw> I<obj>, I<cloning>, I<serialized>, ... The deserializing hook called on the object during deserialization. But wait: if we're deserializing, there's no object yet... right? Wrong: the Storable engine creates an empty one for you. If you know Eiffel, you can view C<STORABLE_thaw> as an alternate creation routine. This means the hook can be inherited like any other method, and that I<obj> is your blessed reference for this particular instance. The other arguments should look familiar if you know C<STORABLE_freeze>: I<cloning> is true when we're part of a deep clone operation, I<serialized> is the serialized string you returned to the engine in C<STORABLE_freeze>, and there may be an optional list of references, in the same order you gave them at serialization time, pointing to the deserialized objects (which have been processed courtesy of the Storable engine). When the Storable engine does not find any C<STORABLE_thaw> hook routine, it tries to load the class by requiring the package dynamically (using the blessed package name), and then re-attempts the lookup. If at that time the hook cannot be located, the engine croaks. Note that this mechanism will fail if you define several classes in the same file, but L<perlmod> warned you. It is up to you to use this information to populate I<obj> the way you want. Returned value: none. =item C<STORABLE_attach> I<class>, I<cloning>, I<serialized> While C<STORABLE_freeze> and C<STORABLE_thaw> are useful for classes where each instance is independent, this mechanism has difficulty (or is incompatible) with objects that exist as common process-level or system-level resources, such as singleton objects, database pools, caches or memoized objects. The alternative C<STORABLE_attach> method provides a solution for these shared objects. Instead of C<STORABLE_freeze> --E<gt> C<STORABLE_thaw>, you implement C<STORABLE_freeze> --E<gt> C<STORABLE_attach> instead. Arguments: I<class> is the class we are attaching to, I<cloning> is a flag indicating whether we're in a dclone() or a regular de-serialization via thaw(), and I<serialized> is the stored string for the resource object. Because these resource objects are considered to be owned by the entire process/system, and not the "property" of whatever is being serialized, no references underneath the object should be included in the serialized string. Thus, in any class that implements C<STORABLE_attach>, the C<STORABLE_freeze> method cannot return any references, and C<Storable> will throw an error if C<STORABLE_freeze> tries to return references. All information required to "attach" back to the shared resource object B<must> be contained B<only> in the C<STORABLE_freeze> return string. Otherwise, C<STORABLE_freeze> behaves as normal for C<STORABLE_attach> classes. Because C<STORABLE_attach> is passed the class (rather than an object), it also returns the object directly, rather than modifying the passed object. Returned value: object of type C<class> =back =head2 Predicates Predicates are not exportable. They must be called by explicitly prefixing them with the Storable package name. =over 4 =item C<Storable::last_op_in_netorder> The C<Storable::last_op_in_netorder()> predicate will tell you whether network order was used in the last store or retrieve operation. If you don't know how to use this, just forget about it. =item C<Storable::is_storing> Returns true if within a store operation (via STORABLE_freeze hook). =item C<Storable::is_retrieving> Returns true if within a retrieve operation (via STORABLE_thaw hook). =back =head2 Recursion With hooks comes the ability to recurse back to the Storable engine. Indeed, hooks are regular Perl code, and Storable is convenient when it comes to serializing and deserializing things, so why not use it to handle the serialization string? There are a few things you need to know, however: =over 4 =item * From Storable 3.05 to 3.13 we probed for the stack recursion limit for references, arrays and hashes to a maximal depth of ~1200-35000, otherwise we might fall into a stack-overflow. On JSON::XS this limit is 512 btw. With references not immediately referencing each other there's no such limit yet, so you might fall into such a stack-overflow segfault. This probing and the checks we performed have some limitations: =over =item * the stack size at build time might be different at run time, eg. the stack size may have been modified with ulimit(1). If it's larger at run time Storable may fail the freeze() or thaw() unnecessarily. If it's larger at build time Storable may segmentation fault when processing a deep structure at run time. =item * the stack size might be different in a thread. =item * array and hash recursion limits are checked separately against the same recursion depth, a frozen structure with a large sequence of nested arrays within many nested hashes may exhaust the processor stack without triggering Storable's recursion protection. =back So these now have simple defaults rather than probing at build-time. You can control the maximum array and hash recursion depths by modifying C<$Storable::recursion_limit> and C<$Storable::recursion_limit_hash> respectively. Either can be set to C<-1> to prevent any depth checks, though this isn't recommended. If you want to test what the limits are, the F<stacksize> tool is included in the C<Storable> distribution. =item * You can create endless loops if the things you serialize via freeze() (for instance) point back to the object we're trying to serialize in the hook. =item * Shared references among objects will not stay shared: if we're serializing the list of object [A, C] where both object A and C refer to the SAME object B, and if there is a serializing hook in A that says freeze(B), then when deserializing, we'll get [A', C'] where A' refers to B', but C' refers to D, a deep clone of B'. The topology was not preserved. =item * The maximal stack recursion limit for your system is returned by C<stack_depth()> and C<stack_depth_hash()>. The hash limit is usually half the size of the array and ref limit, as the Perl hash API is not optimal. =back That's why C<STORABLE_freeze> lets you provide a list of references to serialize. The engine guarantees that those will be serialized in the same context as the other objects, and therefore that shared objects will stay shared. In the above [A, C] example, the C<STORABLE_freeze> hook could return: ("something", $self->{B}) and the B part would be serialized by the engine. In C<STORABLE_thaw>, you would get back the reference to the B' object, deserialized for you. Therefore, recursion should normally be avoided, but is nonetheless supported. =head2 Deep Cloning There is a Clone module available on CPAN which implements deep cloning natively, i.e. without freezing to memory and thawing the result. It is aimed to replace Storable's dclone() some day. However, it does not currently support Storable hooks to redefine the way deep cloning is performed. =head1 Storable magic Yes, there's a lot of that :-) But more precisely, in UNIX systems there's a utility called C<file>, which recognizes data files based on their contents (usually their first few bytes). For this to work, a certain file called F<magic> needs to taught about the I<signature> of the data. Where that configuration file lives depends on the UNIX flavour; often it's something like F</usr/share/misc/magic> or F</etc/magic>. Your system administrator needs to do the updating of the F<magic> file. The necessary signature information is output to STDOUT by invoking Storable::show_file_magic(). Note that the GNU implementation of the C<file> utility, version 3.38 or later, is expected to contain support for recognising Storable files out-of-the-box, in addition to other kinds of Perl files. You can also use the following functions to extract the file header information from Storable images: =over =item $info = Storable::file_magic( $filename ) If the given file is a Storable image return a hash describing it. If the file is readable, but not a Storable image return C<undef>. If the file does not exist or is unreadable then croak. The hash returned has the following elements: =over =item C<version> This returns the file format version. It is a string like "2.7". Note that this version number is not the same as the version number of the Storable module itself. For instance Storable v0.7 create files in format v2.0 and Storable v2.15 create files in format v2.7. The file format version number only increment when additional features that would confuse older versions of the module are added. Files older than v2.0 will have the one of the version numbers "-1", "0" or "1". No minor number was used at that time. =item C<version_nv> This returns the file format version as number. It is a string like "2.007". This value is suitable for numeric comparisons. The constant function C<Storable::BIN_VERSION_NV> returns a comparable number that represents the highest file version number that this version of Storable fully supports (but see discussion of C<$Storable::accept_future_minor> above). The constant C<Storable::BIN_WRITE_VERSION_NV> function returns what file version is written and might be less than C<Storable::BIN_VERSION_NV> in some configurations. =item C<major>, C<minor> This also returns the file format version. If the version is "2.7" then major would be 2 and minor would be 7. The minor element is missing for when major is less than 2. =item C<hdrsize> The is the number of bytes that the Storable header occupies. =item C<netorder> This is TRUE if the image store data in network order. This means that it was created with nstore() or similar. =item C<byteorder> This is only present when C<netorder> is FALSE. It is the $Config{byteorder} string of the perl that created this image. It is a string like "1234" (32 bit little endian) or "87654321" (64 bit big endian). This must match the current perl for the image to be readable by Storable. =item C<intsize>, C<longsize>, C<ptrsize>, C<nvsize> These are only present when C<netorder> is FALSE. These are the sizes of various C datatypes of the perl that created this image. These must match the current perl for the image to be readable by Storable. The C<nvsize> element is only present for file format v2.2 and higher. =item C<file> The name of the file. =back =item $info = Storable::read_magic( $buffer ) =item $info = Storable::read_magic( $buffer, $must_be_file ) The $buffer should be a Storable image or the first few bytes of it. If $buffer starts with a Storable header, then a hash describing the image is returned, otherwise C<undef> is returned. The hash has the same structure as the one returned by Storable::file_magic(). The C<file> element is true if the image is a file image. If the $must_be_file argument is provided and is TRUE, then return C<undef> unless the image looks like it belongs to a file dump. The maximum size of a Storable header is currently 21 bytes. If the provided $buffer is only the first part of a Storable image it should at least be this long to ensure that read_magic() will recognize it as such. =back =head1 EXAMPLES Here are some code samples showing a possible usage of Storable: use Storable qw(store retrieve freeze thaw dclone); %color = ('Blue' => 0.1, 'Red' => 0.8, 'Black' => 0, 'White' => 1); store(\%color, 'mycolors') or die "Can't store %a in mycolors!\n"; $colref = retrieve('mycolors'); die "Unable to retrieve from mycolors!\n" unless defined $colref; printf "Blue is still %lf\n", $colref->{'Blue'}; $colref2 = dclone(\%color); $str = freeze(\%color); printf "Serialization of %%color is %d bytes long.\n", length($str); $colref3 = thaw($str); which prints (on my machine): Blue is still 0.100000 Serialization of %color is 102 bytes long. Serialization of CODE references and deserialization in a safe compartment: =for example begin use Storable qw(freeze thaw); use Safe; use strict; my $safe = new Safe; # because of opcodes used in "use strict": $safe->permit(qw(:default require)); local $Storable::Deparse = 1; local $Storable::Eval = sub { $safe->reval($_[0]) }; my $serialized = freeze(sub { 42 }); my $code = thaw($serialized); $code->() == 42; =for example end =for example_testing is( $code->(), 42 ); =head1 SECURITY WARNING B<Do not accept Storable documents from untrusted sources!> Some features of Storable can lead to security vulnerabilities if you accept Storable documents from untrusted sources with the default flags. Most obviously, the optional (off by default) CODE reference serialization feature allows transfer of code to the deserializing process. Furthermore, any serialized object will cause Storable to helpfully load the module corresponding to the class of the object in the deserializing module. For manipulated module names, this can load almost arbitrary code. Finally, the deserialized object's destructors will be invoked when the objects get destroyed in the deserializing process. Maliciously crafted Storable documents may put such objects in the value of a hash key that is overridden by another key/value pair in the same hash, thus causing immediate destructor execution. To disable blessing objects while thawing/retrieving remove the flag C<BLESS_OK> = 2 from C<$Storable::flags> or set the 2nd argument for thaw/retrieve to 0. To disable tieing data while thawing/retrieving remove the flag C<TIE_OK> = 4 from C<$Storable::flags> or set the 2nd argument for thaw/retrieve to 0. With the default setting of C<$Storable::flags> = 6, creating or destroying random objects, even renamed objects can be controlled by an attacker. See CVE-2015-1592 and its metasploit module. If your application requires accepting data from untrusted sources, you are best off with a less powerful and more-likely safe serialization format and implementation. If your data is sufficiently simple, L<Cpanel::JSON::XS>, L<Data::MessagePack> or L<Sereal> are the best choices and offer maximum interoperability, but note that Sereal is L<unsafe by default|Sereal::Decoder/ROBUSTNESS>. =head1 WARNING If you're using references as keys within your hash tables, you're bound to be disappointed when retrieving your data. Indeed, Perl stringifies references used as hash table keys. If you later wish to access the items via another reference stringification (i.e. using the same reference that was used for the key originally to record the value into the hash table), it will work because both references stringify to the same string. It won't work across a sequence of C<store> and C<retrieve> operations, however, because the addresses in the retrieved objects, which are part of the stringified references, will probably differ from the original addresses. The topology of your structure is preserved, but not hidden semantics like those. On platforms where it matters, be sure to call C<binmode()> on the descriptors that you pass to Storable functions. Storing data canonically that contains large hashes can be significantly slower than storing the same data normally, as temporary arrays to hold the keys for each hash have to be allocated, populated, sorted and freed. Some tests have shown a halving of the speed of storing -- the exact penalty will depend on the complexity of your data. There is no slowdown on retrieval. =head1 REGULAR EXPRESSIONS Storable now has experimental support for storing regular expressions, but there are significant limitations: =over =item * perl 5.8 or later is required. =item * regular expressions with code blocks, ie C</(?{ ... })/> or C</(??{ ... })/> will throw an exception when thawed. =item * regular expression syntax and flags have changed over the history of perl, so a regular expression that you freeze in one version of perl may fail to thaw or behave differently in another version of perl. =item * depending on the version of perl, regular expressions can change in behaviour depending on the context, but later perls will bake that behaviour into the regexp. =back Storable will throw an exception if a frozen regular expression cannot be thawed. =head1 BUGS You can't store GLOB, FORMLINE, etc.... If you can define semantics for those operations, feel free to enhance Storable so that it can deal with them. The store functions will C<croak> if they run into such references unless you set C<$Storable::forgive_me> to some C<TRUE> value. In that case, the fatal message is converted to a warning and some meaningless string is stored instead. Setting C<$Storable::canonical> may not yield frozen strings that compare equal due to possible stringification of numbers. When the string version of a scalar exists, it is the form stored; therefore, if you happen to use your numbers as strings between two freezing operations on the same data structures, you will get different results. When storing doubles in network order, their value is stored as text. However, you should also not expect non-numeric floating-point values such as infinity and "not a number" to pass successfully through a nstore()/retrieve() pair. As Storable neither knows nor cares about character sets (although it does know that characters may be more than eight bits wide), any difference in the interpretation of character codes between a host and a target system is your problem. In particular, if host and target use different code points to represent the characters used in the text representation of floating-point numbers, you will not be able be able to exchange floating-point data, even with nstore(). C<Storable::drop_utf8> is a blunt tool. There is no facility either to return B<all> strings as utf8 sequences, or to attempt to convert utf8 data back to 8 bit and C<croak()> if the conversion fails. Prior to Storable 2.01, no distinction was made between signed and unsigned integers on storing. By default Storable prefers to store a scalars string representation (if it has one) so this would only cause problems when storing large unsigned integers that had never been converted to string or floating point. In other words values that had been generated by integer operations such as logic ops and then not used in any string or arithmetic context before storing. =head2 64 bit data in perl 5.6.0 and 5.6.1 This section only applies to you if you have existing data written out by Storable 2.02 or earlier on perl 5.6.0 or 5.6.1 on Unix or Linux which has been configured with 64 bit integer support (not the default) If you got a precompiled perl, rather than running Configure to build your own perl from source, then it almost certainly does not affect you, and you can stop reading now (unless you're curious). If you're using perl on Windows it does not affect you. Storable writes a file header which contains the sizes of various C language types for the C compiler that built Storable (when not writing in network order), and will refuse to load files written by a Storable not on the same (or compatible) architecture. This check and a check on machine byteorder is needed because the size of various fields in the file are given by the sizes of the C language types, and so files written on different architectures are incompatible. This is done for increased speed. (When writing in network order, all fields are written out as standard lengths, which allows full interworking, but takes longer to read and write) Perl 5.6.x introduced the ability to optional configure the perl interpreter to use C's C<long long> type to allow scalars to store 64 bit integers on 32 bit systems. However, due to the way the Perl configuration system generated the C configuration files on non-Windows platforms, and the way Storable generates its header, nothing in the Storable file header reflected whether the perl writing was using 32 or 64 bit integers, despite the fact that Storable was storing some data differently in the file. Hence Storable running on perl with 64 bit integers will read the header from a file written by a 32 bit perl, not realise that the data is actually in a subtly incompatible format, and then go horribly wrong (possibly crashing) if it encountered a stored integer. This is a design failure. Storable has now been changed to write out and read in a file header with information about the size of integers. It's impossible to detect whether an old file being read in was written with 32 or 64 bit integers (they have the same header) so it's impossible to automatically switch to a correct backwards compatibility mode. Hence this Storable defaults to the new, correct behaviour. What this means is that if you have data written by Storable 1.x running on perl 5.6.0 or 5.6.1 configured with 64 bit integers on Unix or Linux then by default this Storable will refuse to read it, giving the error I<Byte order is not compatible>. If you have such data then you should set C<$Storable::interwork_56_64bit> to a true value to make this Storable read and write files with the old header. You should also migrate your data, or any older perl you are communicating with, to this current version of Storable. If you don't have data written with specific configuration of perl described above, then you do not and should not do anything. Don't set the flag - not only will Storable on an identically configured perl refuse to load them, but Storable a differently configured perl will load them believing them to be correct for it, and then may well fail or crash part way through reading them. =head1 CREDITS Thank you to (in chronological order): Jarkko Hietaniemi <jhi@iki.fi> Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de> Benjamin A. Holzman <bholzman@earthlink.net> Andrew Ford <A.Ford@ford-mason.co.uk> Gisle Aas <gisle@aas.no> Jeff Gresham <gresham_jeffrey@jpmorgan.com> Murray Nesbitt <murray@activestate.com> Marc Lehmann <pcg@opengroup.org> Justin Banks <justinb@wamnet.com> Jarkko Hietaniemi <jhi@iki.fi> (AGAIN, as perl 5.7.0 Pumpkin!) Salvador Ortiz Garcia <sog@msg.com.mx> Dominic Dunlop <domo@computer.org> Erik Haugan <erik@solbors.no> Benjamin A. Holzman <ben.holzman@grantstreet.com> Reini Urban <rurban@cpan.org> Todd Rinaldo <toddr@cpanel.net> Aaron Crane <arc@cpan.org> for their bug reports, suggestions and contributions. Benjamin Holzman contributed the tied variable support, Andrew Ford contributed the canonical order for hashes, and Gisle Aas fixed a few misunderstandings of mine regarding the perl internals, and optimized the emission of "tags" in the output streams by simply counting the objects instead of tagging them (leading to a binary incompatibility for the Storable image starting at version 0.6--older images are, of course, still properly understood). Murray Nesbitt made Storable thread-safe. Marc Lehmann added overloading and references to tied items support. Benjamin Holzman added a performance improvement for overloaded classes; thanks to Grant Street Group for footing the bill. Reini Urban took over maintenance from p5p, and added security fixes and huge object support. =head1 AUTHOR Storable was written by Raphael Manfredi F<E<lt>Raphael_Manfredi@pobox.comE<gt>> Maintenance is now done by cperl L<http://perl11.org/cperl> Please e-mail us with problems, bug fixes, comments and complaints, although if you have compliments you should send them to Raphael. Please don't e-mail Raphael with problems, as he no longer works on Storable, and your message will be delayed while he forwards it to us. =head1 SEE ALSO L<Clone>. =cut 5.32/version.pm 0000444 00000007607 15125513451 0007170 0 ustar 00 #!perl -w package version; use 5.006002; use strict; use warnings::register; if ($] >= 5.015) { warnings::register_categories(qw/version/); } our $VERSION = '0.9933'; our $CLASS = 'version'; our (@ISA, $STRICT, $LAX); # !!!!Delete this next block completely when adding to Perl core!!!! { local $SIG{'__DIE__'}; eval "use version::vxs $VERSION"; if ( $@ ) { # don't have the XS version installed eval "use version::vpp $VERSION"; # don't tempt fate die "$@" if ( $@ ); push @ISA, "version::vpp"; local $^W; *version::qv = \&version::vpp::qv; *version::declare = \&version::vpp::declare; *version::_VERSION = \&version::vpp::_VERSION; *version::vcmp = \&version::vpp::vcmp; *version::new = \&version::vpp::new; *version::numify = \&version::vpp::numify; *version::normal = \&version::vpp::normal; *version::to_decimal = \&version::vpp::to_decimal; *version::to_dotted_decimal = \&version::vpp::to_dotted_decimal; *version::tuple = \&version::vpp::tuple; *version::from_tuple = \&version::vpp::from_tuple; if ($] >= 5.009000) { no strict 'refs'; *version::stringify = \&version::vpp::stringify; *{'version::(""'} = \&version::vpp::stringify; *{'version::(<=>'} = \&version::vpp::vcmp; *{'version::(cmp'} = \&version::vpp::vcmp; *version::parse = \&version::vpp::parse; } } else { # use XS module push @ISA, "version::vxs"; local $^W; *version::declare = \&version::vxs::declare; *version::qv = \&version::vxs::qv; *version::_VERSION = \&version::vxs::_VERSION; *version::vcmp = \&version::vxs::VCMP; *version::new = \&version::vxs::new; *version::numify = \&version::vxs::numify; *version::normal = \&version::vxs::normal; *version::to_decimal = \&version::vxs::to_decimal; *version::to_dotted_decimal = \&version::vxs::to_dotted_decimal; *version::tuple = \&version::vxs::tuple; *version::from_tuple = \&version::vxs::from_tuple; if ($] >= 5.009000) { no strict 'refs'; *version::stringify = \&version::vxs::stringify; *{'version::(""'} = \&version::vxs::stringify; *{'version::(<=>'} = \&version::vxs::VCMP; *{'version::(cmp'} = \&version::vxs::VCMP; *version::parse = \&version::vxs::parse; } } } # avoid using Exporter require version::regex; *version::is_lax = \&version::regex::is_lax; *version::is_strict = \&version::regex::is_strict; *LAX = \$version::regex::LAX; *LAX_DECIMAL_VERSION = \$version::regex::LAX_DECIMAL_VERSION; *LAX_DOTTED_DECIMAL_VERSION = \$version::regex::LAX_DOTTED_DECIMAL_VERSION; *STRICT = \$version::regex::STRICT; *STRICT_DECIMAL_VERSION = \$version::regex::STRICT_DECIMAL_VERSION; *STRICT_DOTTED_DECIMAL_VERSION = \$version::regex::STRICT_DOTTED_DECIMAL_VERSION; sub import { no strict 'refs'; my ($class) = shift; # Set up any derived class unless ($class eq $CLASS) { local $^W; *{$class.'::declare'} = \&{$CLASS.'::declare'}; *{$class.'::qv'} = \&{$CLASS.'::qv'}; } my %args; if (@_) { # any remaining terms are arguments map { $args{$_} = 1 } @_ } else { # no parameters at all on use line %args = ( qv => 1, 'UNIVERSAL::VERSION' => 1, ); } my $callpkg = caller(); if (exists($args{declare})) { *{$callpkg.'::declare'} = sub {return $class->declare(shift) } unless defined(&{$callpkg.'::declare'}); } if (exists($args{qv})) { *{$callpkg.'::qv'} = sub {return $class->qv(shift) } unless defined(&{$callpkg.'::qv'}); } if (exists($args{'UNIVERSAL::VERSION'})) { local $^W; *UNIVERSAL::VERSION = \&{$CLASS.'::_VERSION'}; } if (exists($args{'VERSION'})) { *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; } if (exists($args{'is_strict'})) { *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} unless defined(&{$callpkg.'::is_strict'}); } if (exists($args{'is_lax'})) { *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} unless defined(&{$callpkg.'::is_lax'}); } } 1; 5.32/JSON/XS.pm 0000444 00000210056 15125513451 0006600 0 ustar 00 =head1 NAME JSON::XS - JSON serialising/deserialising, done correctly and fast =encoding utf-8 JSON::XS - 正しくて高速な JSON シリアライザ/デシリアライザ (http://fleur.hio.jp/perldoc/mix/lib/JSON/XS.html) =head1 SYNOPSIS use JSON::XS; # exported functions, they croak on error # and expect/generate UTF-8 $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; # OO-interface $coder = JSON::XS->new->ascii->pretty->allow_nonref; $pretty_printed_unencoded = $coder->encode ($perl_scalar); $perl_scalar = $coder->decode ($unicode_json_text); # Note that JSON version 2.0 and above will automatically use JSON::XS # if available, at virtually no speed overhead either, so you should # be able to just: use JSON; # and do the same things, except that you have a pure-perl fallback now. =head1 DESCRIPTION This module converts Perl data structures to JSON and vice versa. Its primary goal is to be I<correct> and its secondary goal is to be I<fast>. To reach the latter goal it was written in C. See MAPPING, below, on how JSON::XS maps perl values to JSON values and vice versa. =head2 FEATURES =over =item * correct Unicode handling This module knows how to handle Unicode, documents how and when it does so, and even documents what "correct" means. =item * round-trip integrity When you serialise a perl data structure using only data types supported by JSON and Perl, the deserialised data structure is identical on the Perl level. (e.g. the string "2.0" doesn't suddenly become "2" just because it looks like a number). There I<are> minor exceptions to this, read the MAPPING section below to learn about those. =item * strict checking of JSON correctness There is no guessing, no generating of illegal JSON texts by default, and only JSON is accepted as input by default (the latter is a security feature). =item * fast Compared to other JSON modules and other serialisers such as Storable, this module usually compares favourably in terms of speed, too. =item * simple to use This module has both a simple functional interface as well as an object oriented interface. =item * reasonably versatile output formats You can choose between the most compact guaranteed-single-line format possible (nice for simple line-based protocols), a pure-ASCII format (for when your transport is not 8-bit clean, still supports the whole Unicode range), or a pretty-printed format (for when you want to read that stuff). Or you can combine those features in whatever way you like. =back =cut package JSON::XS; use common::sense; our $VERSION = '4.03'; our @ISA = qw(Exporter); our @EXPORT = qw(encode_json decode_json); use Exporter; use XSLoader; use Types::Serialiser (); =head1 FUNCTIONAL INTERFACE The following convenience methods are provided by this module. They are exported by default: =over =item $json_text = encode_json $perl_scalar Converts the given Perl data structure to a UTF-8 encoded, binary string (that is, the string contains octets only). Croaks on error. This function call is functionally identical to: $json_text = JSON::XS->new->utf8->encode ($perl_scalar) Except being faster. =item $perl_scalar = decode_json $json_text The opposite of C<encode_json>: expects a UTF-8 (binary) string and tries to parse that as a UTF-8 encoded JSON text, returning the resulting reference. Croaks on error. This function call is functionally identical to: $perl_scalar = JSON::XS->new->utf8->decode ($json_text) Except being faster. =back =head1 A FEW NOTES ON UNICODE AND PERL Since this often leads to confusion, here are a few very clear words on how Unicode works in Perl, modulo bugs. =over =item 1. Perl strings can store characters with ordinal values > 255. This enables you to store Unicode characters as single characters in a Perl string - very natural. =item 2. Perl does I<not> associate an encoding with your strings. ... until you force it to, e.g. when matching it against a regex, or printing the scalar to a file, in which case Perl either interprets your string as locale-encoded text, octets/binary, or as Unicode, depending on various settings. In no case is an encoding stored together with your data, it is I<use> that decides encoding, not any magical meta data. =item 3. The internal utf-8 flag has no meaning with regards to the encoding of your string. Just ignore that flag unless you debug a Perl bug, a module written in XS or want to dive into the internals of perl. Otherwise it will only confuse you, as, despite the name, it says nothing about how your string is encoded. You can have Unicode strings with that flag set, with that flag clear, and you can have binary data with that flag set and that flag clear. Other possibilities exist, too. If you didn't know about that flag, just the better, pretend it doesn't exist. =item 4. A "Unicode String" is simply a string where each character can be validly interpreted as a Unicode code point. If you have UTF-8 encoded data, it is no longer a Unicode string, but a Unicode string encoded in UTF-8, giving you a binary string. =item 5. A string containing "high" (> 255) character values is I<not> a UTF-8 string. It's a fact. Learn to live with it. =back I hope this helps :) =head1 OBJECT-ORIENTED INTERFACE The object oriented interface lets you configure your own encoding or decoding style, within the limits of supported formats. =over =item $json = new JSON::XS Creates a new JSON::XS object that can be used to de/encode JSON strings. All boolean flags described below are by default I<disabled> (with the exception of C<allow_nonref>, which defaults to I<enabled> since version C<4.0>). The mutators for flags all return the JSON object again and thus calls can be chained: my $json = JSON::XS->new->utf8->space_after->encode ({a => [1,2]}) => {"a": [1, 2]} =item $json = $json->ascii ([$enable]) =item $enabled = $json->get_ascii If C<$enable> is true (or missing), then the C<encode> method will not generate characters outside the code range C<0..127> (which is ASCII). Any Unicode characters outside that range will be escaped using either a single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. The resulting encoded JSON text can be treated as a native Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string, or any other superset of ASCII. If C<$enable> is false, then the C<encode> method will not escape Unicode characters unless required by the JSON syntax or other flags. This results in a faster and more compact format. See also the section I<ENCODING/CODESET FLAG NOTES> later in this document. The main use for this flag is to produce JSON texts that can be transmitted over a 7-bit channel, as the encoded JSON texts will not contain any 8 bit characters. JSON::XS->new->ascii (1)->encode ([chr 0x10401]) => ["\ud801\udc01"] =item $json = $json->latin1 ([$enable]) =item $enabled = $json->get_latin1 If C<$enable> is true (or missing), then the C<encode> method will encode the resulting JSON text as latin1 (or iso-8859-1), escaping any characters outside the code range C<0..255>. The resulting string can be treated as a latin1-encoded JSON text or a native Unicode string. The C<decode> method will not be affected in any way by this flag, as C<decode> by default expects Unicode, which is a strict superset of latin1. If C<$enable> is false, then the C<encode> method will not escape Unicode characters unless required by the JSON syntax or other flags. See also the section I<ENCODING/CODESET FLAG NOTES> later in this document. The main use for this flag is efficiently encoding binary data as JSON text, as most octets will not be escaped, resulting in a smaller encoded size. The disadvantage is that the resulting JSON text is encoded in latin1 (and must correctly be treated as such when storing and transferring), a rare encoding for JSON. It is therefore most useful when you want to store data structures known to contain binary data efficiently in files or databases, not when talking to other JSON encoders/decoders. JSON::XS->new->latin1->encode (["\x{89}\x{abc}"] => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) =item $json = $json->utf8 ([$enable]) =item $enabled = $json->get_utf8 If C<$enable> is true (or missing), then the C<encode> method will encode the JSON result into UTF-8, as required by many protocols, while the C<decode> method expects to be handed a UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any characters outside the range C<0..255>, they are thus useful for bytewise/binary I/O. In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 encoding families, as described in RFC4627. If C<$enable> is false, then the C<encode> method will return the JSON string as a (non-encoded) Unicode string, while C<decode> expects thus a Unicode string. Any decoding or encoding (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. See also the section I<ENCODING/CODESET FLAG NOTES> later in this document. Example, output UTF-16BE-encoded JSON: use Encode; $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object); Example, decode UTF-32LE-encoded JSON: use Encode; $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext); =item $json = $json->pretty ([$enable]) This enables (or disables) all of the C<indent>, C<space_before> and C<space_after> (and in the future possibly more) flags in one call to generate the most readable (or most compact) form possible. Example, pretty-print some simple structure: my $json = JSON::XS->new->pretty(1)->encode ({a => [1,2]}) => { "a" : [ 1, 2 ] } =item $json = $json->indent ([$enable]) =item $enabled = $json->get_indent If C<$enable> is true (or missing), then the C<encode> method will use a multiline format as output, putting every array member or object/hash key-value pair into its own line, indenting them properly. If C<$enable> is false, no newlines or indenting will be produced, and the resulting JSON text is guaranteed not to contain any C<newlines>. This setting has no effect when decoding JSON texts. =item $json = $json->space_before ([$enable]) =item $enabled = $json->get_space_before If C<$enable> is true (or missing), then the C<encode> method will add an extra optional space before the C<:> separating keys from values in JSON objects. If C<$enable> is false, then the C<encode> method will not add any extra space at those places. This setting has no effect when decoding JSON texts. You will also most likely combine this setting with C<space_after>. Example, space_before enabled, space_after and indent disabled: {"key" :"value"} =item $json = $json->space_after ([$enable]) =item $enabled = $json->get_space_after If C<$enable> is true (or missing), then the C<encode> method will add an extra optional space after the C<:> separating keys from values in JSON objects and extra whitespace after the C<,> separating key-value pairs and array members. If C<$enable> is false, then the C<encode> method will not add any extra space at those places. This setting has no effect when decoding JSON texts. Example, space_before and indent disabled, space_after enabled: {"key": "value"} =item $json = $json->relaxed ([$enable]) =item $enabled = $json->get_relaxed If C<$enable> is true (or missing), then C<decode> will accept some extensions to normal JSON syntax (see below). C<encode> will not be affected in any way. I<Be aware that this option makes you accept invalid JSON texts as if they were valid!>. I suggest only to use this option to parse application-specific files written by humans (configuration files, resource files etc.) If C<$enable> is false (the default), then C<decode> will only accept valid JSON texts. Currently accepted extensions are: =over =item * list items can have an end-comma JSON I<separates> array elements and key-value pairs with commas. This can be annoying if you write JSON texts manually and want to be able to quickly append elements, so this extension accepts comma at the end of such items not just between them: [ 1, 2, <- this comma not normally allowed ] { "k1": "v1", "k2": "v2", <- this comma not normally allowed } =item * shell-style '#'-comments Whenever JSON allows whitespace, shell-style comments are additionally allowed. They are terminated by the first carriage-return or line-feed character, after which more white-space and comments are allowed. [ 1, # this comment not allowed in JSON # neither this one... ] =item * literal ASCII TAB characters in strings Literal ASCII TAB characters are now allowed in strings (and treated as C<\t>). [ "Hello\tWorld", "Hello<TAB>World", # literal <TAB> would not normally be allowed ] =back =item $json = $json->canonical ([$enable]) =item $enabled = $json->get_canonical If C<$enable> is true (or missing), then the C<encode> method will output JSON objects by sorting their keys. This is adding a comparatively high overhead. If C<$enable> is false, then the C<encode> method will output key-value pairs in the order Perl stores them (which will likely change between runs of the same script, and can change even within the same run from 5.18 onwards). This option is useful if you want the same data structure to be encoded as the same JSON text (given the same overall settings). If it is disabled, the same hash might be encoded differently even if contains the same data, as key-value pairs have no inherent ordering in Perl. This setting has no effect when decoding JSON texts. This setting has currently no effect on tied hashes. =item $json = $json->allow_nonref ([$enable]) =item $enabled = $json->get_allow_nonref Unlike other boolean options, this opotion is enabled by default beginning with version C<4.0>. See L<SECURITY CONSIDERATIONS> for the gory details. If C<$enable> is true (or missing), then the C<encode> method can convert a non-reference into its corresponding string, number or null JSON value, which is an extension to RFC4627. Likewise, C<decode> will accept those JSON values instead of croaking. If C<$enable> is false, then the C<encode> method will croak if it isn't passed an arrayref or hashref, as JSON texts must either be an object or array. Likewise, C<decode> will croak if given something that is not a JSON object or array. Example, encode a Perl scalar as JSON value without enabled C<allow_nonref>, resulting in an error: JSON::XS->new->allow_nonref (0)->encode ("Hello, World!") => hash- or arrayref expected... =item $json = $json->allow_unknown ([$enable]) =item $enabled = $json->get_allow_unknown If C<$enable> is true (or missing), then C<encode> will I<not> throw an exception when it encounters values it cannot represent in JSON (for example, filehandles) but instead will encode a JSON C<null> value. Note that blessed objects are not included here and are handled separately by c<allow_nonref>. If C<$enable> is false (the default), then C<encode> will throw an exception when it encounters anything it cannot encode as JSON. This option does not affect C<decode> in any way, and it is recommended to leave it off unless you know your communications partner. =item $json = $json->allow_blessed ([$enable]) =item $enabled = $json->get_allow_blessed See L<OBJECT SERIALISATION> for details. If C<$enable> is true (or missing), then the C<encode> method will not barf when it encounters a blessed reference that it cannot convert otherwise. Instead, a JSON C<null> value is encoded instead of the object. If C<$enable> is false (the default), then C<encode> will throw an exception when it encounters a blessed object that it cannot convert otherwise. This setting has no effect on C<decode>. =item $json = $json->convert_blessed ([$enable]) =item $enabled = $json->get_convert_blessed See L<OBJECT SERIALISATION> for details. If C<$enable> is true (or missing), then C<encode>, upon encountering a blessed object, will check for the availability of the C<TO_JSON> method on the object's class. If found, it will be called in scalar context and the resulting scalar will be encoded instead of the object. The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON> returns other blessed objects, those will be handled in the same way. C<TO_JSON> must take care of not causing an endless recursion cycle (== crash) in this case. The name of C<TO_JSON> was chosen because other methods called by the Perl core (== not by the user of the object) are usually in upper case letters and to avoid collisions with any C<to_json> function or method. If C<$enable> is false (the default), then C<encode> will not consider this type of conversion. This setting has no effect on C<decode>. =item $json = $json->allow_tags ([$enable]) =item $enabled = $json->get_allow_tags See L<OBJECT SERIALISATION> for details. If C<$enable> is true (or missing), then C<encode>, upon encountering a blessed object, will check for the availability of the C<FREEZE> method on the object's class. If found, it will be used to serialise the object into a nonstandard tagged JSON value (that JSON decoders cannot decode). It also causes C<decode> to parse such tagged JSON values and deserialise them via a call to the C<THAW> method. If C<$enable> is false (the default), then C<encode> will not consider this type of conversion, and tagged JSON values will cause a parse error in C<decode>, as if tags were not part of the grammar. =item $json->boolean_values ([$false, $true]) =item ($false, $true) = $json->get_boolean_values By default, JSON booleans will be decoded as overloaded C<$Types::Serialiser::false> and C<$Types::Serialiser::true> objects. With this method you can specify your own boolean values for decoding - on decode, JSON C<false> will be decoded as a copy of C<$false>, and JSON C<true> will be decoded as C<$true> ("copy" here is the same thing as assigning a value to another variable, i.e. C<$copy = $false>). Calling this method without any arguments will reset the booleans to their default values. C<get_boolean_values> will return both C<$false> and C<$true> values, or the empty list when they are set to the default. =item $json = $json->filter_json_object ([$coderef->($hashref)]) When C<$coderef> is specified, it will be called from C<decode> each time it decodes a JSON object. The only argument is a reference to the newly-created hash. If the code reference returns a single scalar (which need not be a reference), this value (or rather a copy of it) is inserted into the deserialised data structure. If it returns an empty list (NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised hash will be inserted. This setting can slow down decoding considerably. When C<$coderef> is omitted or undefined, any existing callback will be removed and C<decode> will not change the deserialised hash in any way. Example, convert all JSON objects into the integer 5: my $js = JSON::XS->new->filter_json_object (sub { 5 }); # returns [5] $js->decode ('[{}]') # throw an exception because allow_nonref is not enabled # so a lone 5 is not allowed. $js->decode ('{"a":1, "b":2}'); =item $json = $json->filter_json_single_key_object ($key [=> $coderef->($value)]) Works remotely similar to C<filter_json_object>, but is only called for JSON objects having a single key named C<$key>. This C<$coderef> is called before the one specified via C<filter_json_object>, if any. It gets passed the single value in the JSON object. If it returns a single value, it will be inserted into the data structure. If it returns nothing (not even C<undef> but the empty list), the callback from C<filter_json_object> will be called next, as if no single-key callback were specified. If C<$coderef> is omitted or undefined, the corresponding callback will be disabled. There can only ever be one callback for a given key. As this callback gets called less often then the C<filter_json_object> one, decoding speed will not usually suffer as much. Therefore, single-key objects make excellent targets to serialise Perl objects into, especially as single-key JSON objects are as close to the type-tagged value concept as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not support this in any way, so you need to make sure your data never looks like a serialised Perl hash. Typical names for the single object key are C<__class_whatever__>, or C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even things like C<__class_md5sum(classname)__>, to reduce the risk of clashing with real hashes. Example, decode JSON objects of the form C<< { "__widget__" => <id> } >> into the corresponding C<< $WIDGET{<id>} >> object: # return whatever is in $WIDGET{5}: JSON::XS ->new ->filter_json_single_key_object (__widget__ => sub { $WIDGET{ $_[0] } }) ->decode ('{"__widget__": 5') # this can be used with a TO_JSON method in some "widget" class # for serialisation to json: sub WidgetBase::TO_JSON { my ($self) = @_; unless ($self->{id}) { $self->{id} = ..get..some..id..; $WIDGET{$self->{id}} = $self; } { __widget__ => $self->{id} } } =item $json = $json->shrink ([$enable]) =item $enabled = $json->get_shrink Perl usually over-allocates memory a bit when allocating space for strings. This flag optionally resizes strings generated by either C<encode> or C<decode> to their minimum size possible. This can save memory when your JSON texts are either very very long or you have many short strings. It will also try to downgrade any strings to octet-form if possible: perl stores strings internally either in an encoding called UTF-X or in octet-form. The latter cannot store everything but uses less space in general (and some buggy Perl or C code might even rely on that internal representation being used). The actual definition of what shrink does might change in future versions, but it will always try to save space at the expense of time. If C<$enable> is true (or missing), the string returned by C<encode> will be shrunk-to-fit, while all strings generated by C<decode> will also be shrunk-to-fit. If C<$enable> is false, then the normal perl allocation algorithms are used. If you work with your data, then this is likely to be faster. In the future, this setting might control other things, such as converting strings that look like integers or floats into integers or floats internally (there is no difference on the Perl level), saving space. =item $json = $json->max_depth ([$maximum_nesting_depth]) =item $max_depth = $json->get_max_depth Sets the maximum nesting level (default C<512>) accepted while encoding or decoding. If a higher nesting level is detected in JSON text or a Perl data structure, then the encoder and decoder will stop and croak at that point. Nesting level is defined by number of hash- or arrayrefs that the encoder needs to traverse to reach a given point or the number of C<{> or C<[> characters without their matching closing parenthesis crossed to reach a given character in a string. Setting the maximum depth to one disallows any nesting, so that ensures that the object is only a single hash/object or array. If no argument is given, the highest possible setting will be used, which is rarely useful. Note that nesting is implemented by recursion in C. The default value has been chosen to be as large as typical operating systems allow without crashing. See SECURITY CONSIDERATIONS, below, for more info on why this is useful. =item $json = $json->max_size ([$maximum_string_size]) =item $max_size = $json->get_max_size Set the maximum length a JSON text may have (in bytes) where decoding is being attempted. The default is C<0>, meaning no limit. When C<decode> is called on a string that is longer then this many bytes, it will not attempt to decode the string but throw an exception. This setting has no effect on C<encode> (yet). If no argument is given, the limit check will be deactivated (same as when C<0> is specified). See SECURITY CONSIDERATIONS, below, for more info on why this is useful. =item $json_text = $json->encode ($perl_scalar) Converts the given Perl value or data structure to its JSON representation. Croaks on error. =item $perl_scalar = $json->decode ($json_text) The opposite of C<encode>: expects a JSON text and tries to parse it, returning the resulting simple scalar or reference. Croaks on error. =item ($perl_scalar, $characters) = $json->decode_prefix ($json_text) This works like the C<decode> method, but instead of raising an exception when there is trailing garbage after the first JSON object, it will silently stop parsing there and return the number of characters consumed so far. This is useful if your JSON texts are not delimited by an outer protocol and you need to know where the JSON text ends. JSON::XS->new->decode_prefix ("[1] the tail") => ([1], 3) =back =head1 INCREMENTAL PARSING In some cases, there is the need for incremental parsing of JSON texts. While this module always has to keep both JSON text and resulting Perl data structure in memory at one time, it does allow you to parse a JSON stream incrementally. It does so by accumulating text until it has a full JSON object, which it then can decode. This process is similar to using C<decode_prefix> to see if a full JSON object is available, but is much more efficient (and can be implemented with a minimum of method calls). JSON::XS will only attempt to parse the JSON text once it is sure it has enough text to get a decisive result, using a very simple but truly incremental parser. This means that it sometimes won't stop as early as the full parser, for example, it doesn't detect mismatched parentheses. The only thing it guarantees is that it starts decoding as soon as a syntactically valid JSON text has been seen. This means you need to set resource limits (e.g. C<max_size>) to ensure the parser will stop parsing in the presence if syntax errors. The following methods implement this incremental parser. =over =item [void, scalar or list context] = $json->incr_parse ([$string]) This is the central parsing function. It can both append new text and extract objects from the stream accumulated so far (both of these functions are optional). If C<$string> is given, then this string is appended to the already existing JSON fragment stored in the C<$json> object. After that, if the function is called in void context, it will simply return without doing anything further. This can be used to add more text in as many chunks as you want. If the method is called in scalar context, then it will try to extract exactly I<one> JSON object. If that is successful, it will return this object, otherwise it will return C<undef>. If there is a parse error, this method will croak just as C<decode> would do (one can then use C<incr_skip> to skip the erroneous part). This is the most common way of using the method. And finally, in list context, it will try to extract as many objects from the stream as it can find and return them, or the empty list otherwise. For this to work, there must be no separators (other than whitespace) between the JSON objects or arrays, instead they must be concatenated back-to-back. If an error occurs, an exception will be raised as in the scalar context case. Note that in this case, any previously-parsed JSON texts will be lost. Example: Parse some JSON arrays/objects in a given string and return them. my @objs = JSON::XS->new->incr_parse ("[5][7][1,2]"); =item $lvalue_string = $json->incr_text This method returns the currently stored JSON fragment as an lvalue, that is, you can manipulate it. This I<only> works when a preceding call to C<incr_parse> in I<scalar context> successfully returned an object. Under all other circumstances you must not call this function (I mean it. although in simple tests it might actually work, it I<will> fail under real world conditions). As a special exception, you can also call this method before having parsed anything. That means you can only use this function to look at or manipulate text before or after complete JSON objects, not while the parser is in the middle of parsing a JSON object. This function is useful in two cases: a) finding the trailing text after a JSON object or b) parsing multiple JSON objects separated by non-JSON text (such as commas). =item $json->incr_skip This will reset the state of the incremental parser and will remove the parsed text from the input buffer so far. This is useful after C<incr_parse> died, in which case the input buffer and incremental parser state is left unchanged, to skip the text parsed so far and to reset the parse state. The difference to C<incr_reset> is that only text until the parse error occurred is removed. =item $json->incr_reset This completely resets the incremental parser, that is, after this call, it will be as if the parser had never parsed anything. This is useful if you want to repeatedly parse JSON objects and want to ignore any trailing data, which means you have to reset the parser after each successful decode. =back =head2 LIMITATIONS The incremental parser is a non-exact parser: it works by gathering as much text as possible that I<could> be a valid JSON text, followed by trying to decode it. That means it sometimes needs to read more data than strictly necessary to diagnose an invalid JSON text. For example, after parsing the following fragment, the parser I<could> stop with an error, as this fragment I<cannot> be the beginning of a valid JSON text: [, In reality, hopwever, the parser might continue to read data until a length limit is exceeded or it finds a closing bracket. =head2 EXAMPLES Some examples will make all this clearer. First, a simple example that works similarly to C<decode_prefix>: We want to decode the JSON object at the start of a string and identify the portion after the JSON object: my $text = "[1,2,3] hello"; my $json = new JSON::XS; my $obj = $json->incr_parse ($text) or die "expected JSON object or array at beginning of string"; my $tail = $json->incr_text; # $tail now contains " hello" Easy, isn't it? Now for a more complicated example: Imagine a hypothetical protocol where you read some requests from a TCP stream, and each request is a JSON array, without any separation between them (in fact, it is often useful to use newlines as "separators", as these get interpreted as whitespace at the start of the JSON text, which makes it possible to test said protocol with C<telnet>...). Here is how you'd do it (it is trivial to write this in an event-based manner): my $json = new JSON::XS; # read some data from the socket while (sysread $socket, my $buf, 4096) { # split and decode as many requests as possible for my $request ($json->incr_parse ($buf)) { # act on the $request } } Another complicated example: Assume you have a string with JSON objects or arrays, all separated by (optional) comma characters (e.g. C<[1],[2], [3]>). To parse them, we have to skip the commas between the JSON texts, and here is where the lvalue-ness of C<incr_text> comes in useful: my $text = "[1],[2], [3]"; my $json = new JSON::XS; # void context, so no parsing done $json->incr_parse ($text); # now extract as many objects as possible. note the # use of scalar context so incr_text can be called. while (my $obj = $json->incr_parse) { # do something with $obj # now skip the optional comma $json->incr_text =~ s/^ \s* , //x; } Now lets go for a very complex example: Assume that you have a gigantic JSON array-of-objects, many gigabytes in size, and you want to parse it, but you cannot load it into memory fully (this has actually happened in the real world :). Well, you lost, you have to implement your own JSON parser. But JSON::XS can still help you: You implement a (very simple) array parser and let JSON decode the array elements, which are all full JSON objects on their own (this wouldn't work if the array elements could be JSON numbers, for example): my $json = new JSON::XS; # open the monster open my $fh, "<bigfile.json" or die "bigfile: $!"; # first parse the initial "[" for (;;) { sysread $fh, my $buf, 65536 or die "read error: $!"; $json->incr_parse ($buf); # void context, so no parsing # Exit the loop once we found and removed(!) the initial "[". # In essence, we are (ab-)using the $json object as a simple scalar # we append data to. last if $json->incr_text =~ s/^ \s* \[ //x; } # now we have the skipped the initial "[", so continue # parsing all the elements. for (;;) { # in this loop we read data until we got a single JSON object for (;;) { if (my $obj = $json->incr_parse) { # do something with $obj last; } # add more data sysread $fh, my $buf, 65536 or die "read error: $!"; $json->incr_parse ($buf); # void context, so no parsing } # in this loop we read data until we either found and parsed the # separating "," between elements, or the final "]" for (;;) { # first skip whitespace $json->incr_text =~ s/^\s*//; # if we find "]", we are done if ($json->incr_text =~ s/^\]//) { print "finished.\n"; exit; } # if we find ",", we can continue with the next element if ($json->incr_text =~ s/^,//) { last; } # if we find anything else, we have a parse error! if (length $json->incr_text) { die "parse error near ", $json->incr_text; } # else add more data sysread $fh, my $buf, 65536 or die "read error: $!"; $json->incr_parse ($buf); # void context, so no parsing } This is a complex example, but most of the complexity comes from the fact that we are trying to be correct (bear with me if I am wrong, I never ran the above example :). =head1 MAPPING This section describes how JSON::XS maps Perl values to JSON values and vice versa. These mappings are designed to "do the right thing" in most circumstances automatically, preserving round-tripping characteristics (what you put in comes out as something equivalent). For the more enlightened: note that in the following descriptions, lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl> refers to the abstract Perl language itself. =head2 JSON -> PERL =over =item object A JSON object becomes a reference to a hash in Perl. No ordering of object keys is preserved (JSON does not preserve object key ordering itself). =item array A JSON array becomes a reference to an array in Perl. =item string A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON are represented by the same codepoints in the Perl string, so no manual decoding is necessary. =item number A JSON number becomes either an integer, numeric (floating point) or string scalar in perl, depending on its range and any fractional parts. On the Perl level, there is no difference between those as Perl handles all the conversion details, but an integer may take slightly less memory and might represent more values exactly than floating point numbers. If the number consists of digits only, JSON::XS will try to represent it as an integer value. If that fails, it will try to represent it as a numeric (floating point) value if that is possible without loss of precision. Otherwise it will preserve the number as a string value (in which case you lose roundtripping ability, as the JSON number will be re-encoded to a JSON string). Numbers containing a fractional or exponential part will always be represented as numeric (floating point) values, possibly at a loss of precision (in which case you might lose perfect roundtripping ability, but the JSON number will still be re-encoded as a JSON number). Note that precision is not accuracy - binary floating point values cannot represent most decimal fractions exactly, and when converting from and to floating point, JSON::XS only guarantees precision up to but not including the least significant bit. =item true, false These JSON atoms become C<Types::Serialiser::true> and C<Types::Serialiser::false>, respectively. They are overloaded to act almost exactly like the numbers C<1> and C<0>. You can check whether a scalar is a JSON boolean by using the C<Types::Serialiser::is_bool> function (after C<use Types::Serialier>, of course). =item null A JSON null atom becomes C<undef> in Perl. =item shell-style comments (C<< # I<text> >>) As a nonstandard extension to the JSON syntax that is enabled by the C<relaxed> setting, shell-style comments are allowed. They can start anywhere outside strings and go till the end of the line. =item tagged values (C<< (I<tag>)I<value> >>). Another nonstandard extension to the JSON syntax, enabled with the C<allow_tags> setting, are tagged values. In this implementation, the I<tag> must be a perl package/class name encoded as a JSON string, and the I<value> must be a JSON array encoding optional constructor arguments. See L<OBJECT SERIALISATION>, below, for details. =back =head2 PERL -> JSON The mapping from Perl to JSON is slightly more difficult, as Perl is a truly typeless language, so we can only guess which JSON type is meant by a Perl value. =over =item hash references Perl hash references become JSON objects. As there is no inherent ordering in hash keys (or JSON objects), they will usually be encoded in a pseudo-random order. JSON::XS can optionally sort the hash keys (determined by the I<canonical> flag), so the same datastructure will serialise to the same JSON text (given same settings and version of JSON::XS), but this incurs a runtime overhead and is only rarely useful, e.g. when you want to compare some JSON text against another for equality. =item array references Perl array references become JSON arrays. =item other references Other unblessed references are generally not allowed and will cause an exception to be thrown, except for references to the integers C<0> and C<1>, which get turned into C<false> and C<true> atoms in JSON. Since C<JSON::XS> uses the boolean model from L<Types::Serialiser>, you can also C<use Types::Serialiser> and then use C<Types::Serialiser::false> and C<Types::Serialiser::true> to improve readability. use Types::Serialiser; encode_json [\0, Types::Serialiser::true] # yields [false,true] =item Types::Serialiser::true, Types::Serialiser::false These special values from the L<Types::Serialiser> module become JSON true and JSON false values, respectively. You can also use C<\1> and C<\0> directly if you want. =item blessed objects Blessed objects are not directly representable in JSON, but C<JSON::XS> allows various ways of handling objects. See L<OBJECT SERIALISATION>, below, for details. =item simple scalars Simple Perl scalars (any scalar that is not a reference) are the most difficult objects to encode: JSON::XS will encode undefined scalars as JSON C<null> values, scalars that have last been used in a string context before encoding as JSON strings, and anything else as number value: # dump as number encode_json [2] # yields [2] encode_json [-3.0e17] # yields [-3e+17] my $value = 5; encode_json [$value] # yields [5] # used as string, so dump as string print $value; encode_json [$value] # yields ["5"] # undef becomes null encode_json [undef] # yields [null] You can force the type to be a JSON string by stringifying it: my $x = 3.1; # some variable containing a number "$x"; # stringified $x .= ""; # another, more awkward way to stringify print $x; # perl does it for you, too, quite often You can force the type to be a JSON number by numifying it: my $x = "3"; # some variable containing a string $x += 0; # numify it, ensuring it will be dumped as a number $x *= 1; # same thing, the choice is yours. You can not currently force the type in other, less obscure, ways. Tell me if you need this capability (but don't forget to explain why it's needed :). Note that numerical precision has the same meaning as under Perl (so binary to decimal conversion follows the same rules as in Perl, which can differ to other languages). Also, your perl interpreter might expose extensions to the floating point numbers of your platform, such as infinities or NaN's - these cannot be represented in JSON, and it is an error to pass those in. =back =head2 OBJECT SERIALISATION As JSON cannot directly represent Perl objects, you have to choose between a pure JSON representation (without the ability to deserialise the object automatically again), and a nonstandard extension to the JSON syntax, tagged values. =head3 SERIALISATION What happens when C<JSON::XS> encounters a Perl object depends on the C<allow_blessed>, C<convert_blessed> and C<allow_tags> settings, which are used in this order: =over =item 1. C<allow_tags> is enabled and the object has a C<FREEZE> method. In this case, C<JSON::XS> uses the L<Types::Serialiser> object serialisation protocol to create a tagged JSON value, using a nonstandard extension to the JSON syntax. This works by invoking the C<FREEZE> method on the object, with the first argument being the object to serialise, and the second argument being the constant string C<JSON> to distinguish it from other serialisers. The C<FREEZE> method can return any number of values (i.e. zero or more). These values and the paclkage/classname of the object will then be encoded as a tagged JSON value in the following format: ("classname")[FREEZE return values...] e.g.: ("URI")["http://www.google.com/"] ("MyDate")[2013,10,29] ("ImageData::JPEG")["Z3...VlCg=="] For example, the hypothetical C<My::Object> C<FREEZE> method might use the objects C<type> and C<id> members to encode the object: sub My::Object::FREEZE { my ($self, $serialiser) = @_; ($self->{type}, $self->{id}) } =item 2. C<convert_blessed> is enabled and the object has a C<TO_JSON> method. In this case, the C<TO_JSON> method of the object is invoked in scalar context. It must return a single scalar that can be directly encoded into JSON. This scalar replaces the object in the JSON text. For example, the following C<TO_JSON> method will convert all L<URI> objects to JSON strings when serialised. The fatc that these values originally were L<URI> objects is lost. sub URI::TO_JSON { my ($uri) = @_; $uri->as_string } =item 3. C<allow_blessed> is enabled. The object will be serialised as a JSON null value. =item 4. none of the above If none of the settings are enabled or the respective methods are missing, C<JSON::XS> throws an exception. =back =head3 DESERIALISATION For deserialisation there are only two cases to consider: either nonstandard tagging was used, in which case C<allow_tags> decides, or objects cannot be automatically be deserialised, in which case you can use postprocessing or the C<filter_json_object> or C<filter_json_single_key_object> callbacks to get some real objects our of your JSON. This section only considers the tagged value case: I a tagged JSON object is encountered during decoding and C<allow_tags> is disabled, a parse error will result (as if tagged values were not part of the grammar). If C<allow_tags> is enabled, C<JSON::XS> will look up the C<THAW> method of the package/classname used during serialisation (it will not attempt to load the package as a Perl module). If there is no such method, the decoding will fail with an error. Otherwise, the C<THAW> method is invoked with the classname as first argument, the constant string C<JSON> as second argument, and all the values from the JSON array (the values originally returned by the C<FREEZE> method) as remaining arguments. The method must then return the object. While technically you can return any Perl scalar, you might have to enable the C<enable_nonref> setting to make that work in all cases, so better return an actual blessed reference. As an example, let's implement a C<THAW> function that regenerates the C<My::Object> from the C<FREEZE> example earlier: sub My::Object::THAW { my ($class, $serialiser, $type, $id) = @_; $class->new (type => $type, id => $id) } =head1 ENCODING/CODESET FLAG NOTES The interested reader might have seen a number of flags that signify encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be some confusion on what these do, so here is a short comparison: C<utf8> controls whether the JSON text created by C<encode> (and expected by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only control whether C<encode> escapes character values outside their respective codeset range. Neither of these flags conflict with each other, although some combinations make less sense than others. Care has been taken to make all flags symmetrical with respect to C<encode> and C<decode>, that is, texts encoded with any combination of these flag values will be correctly decoded when the same flags are used - in general, if you use different flag settings while encoding vs. when decoding you likely have a bug somewhere. Below comes a verbose discussion of these flags. Note that a "codeset" is simply an abstract set of character-codepoint pairs, while an encoding takes those codepoint numbers and I<encodes> them, in our case into octets. Unicode is (among other things) a codeset, UTF-8 is an encoding, and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at the same time, which can be confusing. =over =item C<utf8> flag disabled When C<utf8> is disabled (the default), then C<encode>/C<decode> generate and expect Unicode strings, that is, characters with high ordinal Unicode values (> 255) will be encoded as such characters, and likewise such characters are decoded as-is, no changes to them will be done, except "(re-)interpreting" them as Unicode codepoints or Unicode characters, respectively (to Perl, these are the same thing in strings unless you do funny/weird/dumb stuff). This is useful when you want to do the encoding yourself (e.g. when you want to have UTF-16 encoded JSON texts) or when some other layer does the encoding for you (for example, when printing to a terminal using a filehandle that transparently encodes to UTF-8 you certainly do NOT want to UTF-8 encode your data first and have Perl encode it another time). =item C<utf8> flag enabled If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all characters using the corresponding UTF-8 multi-byte sequence, and will expect your input strings to be encoded as UTF-8, that is, no "character" of the input string must have any value > 255, as UTF-8 does not allow that. The C<utf8> flag therefore switches between two modes: disabled means you will get a Unicode string in Perl, enabled means you get a UTF-8 encoded octet/binary string in Perl. =item C<latin1> or C<ascii> flags enabled With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining characters as specified by the C<utf8> flag. If C<utf8> is disabled, then the result is also correctly encoded in those character sets (as both are proper subsets of Unicode, meaning that a Unicode string with all character values < 256 is the same thing as a ISO-8859-1 string, and a Unicode string with all character values < 128 is the same thing as an ASCII string in Perl). If C<utf8> is enabled, you still get a correct UTF-8-encoded string, regardless of these flags, just some more characters will be escaped using C<\uXXXX> then before. Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8 encoding, while ASCII-encoded strings are. That is because the ISO-8859-1 encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being a subset of Unicode), while ASCII is. Surprisingly, C<decode> will ignore these flags and so treat all input values as governed by the C<utf8> flag. If it is disabled, this allows you to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings. So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag - they only govern when the JSON output engine escapes a character or not. The main use for C<latin1> is to relatively efficiently store binary data as JSON, at the expense of breaking compatibility with most JSON decoders. The main use for C<ascii> is to force the output to not contain characters with values > 127, which means you can interpret the resulting string as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and 8-bit-encoding, and still get the same data structure back. This is useful when your channel for JSON transfer is not 8-bit clean or the encoding might be mangled in between (e.g. in mail), and works because ASCII is a proper subset of most 8-bit and multibyte encodings in use in the world. =back =head2 JSON and ECMAscript JSON syntax is based on how literals are represented in javascript (the not-standardised predecessor of ECMAscript) which is presumably why it is called "JavaScript Object Notation". However, JSON is not a subset (and also not a superset of course) of ECMAscript (the standard) or javascript (whatever browsers actually implement). If you want to use javascript's C<eval> function to "parse" JSON, you might run into parse errors for valid JSON texts, or the resulting data structure might not be queryable: One of the problems is that U+2028 and U+2029 are valid characters inside JSON strings, but are not allowed in ECMAscript string literals, so the following Perl fragment will not output something that can be guaranteed to be parsable by javascript's C<eval>: use JSON::XS; print encode_json [chr 0x2028]; The right fix for this is to use a proper JSON parser in your javascript programs, and not rely on C<eval> (see for example Douglas Crockford's F<json2.js> parser). If this is not an option, you can, as a stop-gap measure, simply encode to ASCII-only JSON: use JSON::XS; print JSON::XS->new->ascii->encode ([chr 0x2028]); Note that this will enlarge the resulting JSON text quite a bit if you have many non-ASCII characters. You might be tempted to run some regexes to only escape U+2028 and U+2029, e.g.: # DO NOT USE THIS! my $json = JSON::XS->new->utf8->encode ([chr 0x2028]); $json =~ s/\xe2\x80\xa8/\\u2028/g; # escape U+2028 $json =~ s/\xe2\x80\xa9/\\u2029/g; # escape U+2029 print $json; Note that I<this is a bad idea>: the above only works for U+2028 and U+2029 and thus only for fully ECMAscript-compliant parsers. Many existing javascript implementations, however, have issues with other characters as well - using C<eval> naively simply I<will> cause problems. Another problem is that some javascript implementations reserve some property names for their own purposes (which probably makes them non-ECMAscript-compliant). For example, Iceweasel reserves the C<__proto__> property name for its own purposes. If that is a problem, you could parse try to filter the resulting JSON output for these property strings, e.g.: $json =~ s/"__proto__"\s*:/"__proto__renamed":/g; This works because C<__proto__> is not valid outside of strings, so every occurrence of C<"__proto__"\s*:> must be a string used as property name. If you know of other incompatibilities, please let me know. =head2 JSON and YAML You often hear that JSON is a subset of YAML. This is, however, a mass hysteria(*) and very far from the truth (as of the time of this writing), so let me state it clearly: I<in general, there is no way to configure JSON::XS to output a data structure as valid YAML> that works in all cases. If you really must use JSON::XS to generate YAML, you should use this algorithm (subject to change in future versions): my $to_yaml = JSON::XS->new->utf8->space_after (1); my $yaml = $to_yaml->encode ($ref) . "\n"; This will I<usually> generate JSON texts that also parse as valid YAML. Please note that YAML has hardcoded limits on (simple) object key lengths that JSON doesn't have and also has different and incompatible unicode character escape syntax, so you should make sure that your hash keys are noticeably shorter than the 1024 "stream characters" YAML allows and that you do not have characters with codepoint values outside the Unicode BMP (basic multilingual page). YAML also does not allow C<\/> sequences in strings (which JSON::XS does not I<currently> generate, but other JSON generators might). There might be other incompatibilities that I am not aware of (or the YAML specification has been changed yet again - it does so quite often). In general you should not try to generate YAML with a JSON generator or vice versa, or try to parse JSON with a YAML parser or vice versa: chances are high that you will run into severe interoperability problems when you least expect it. =over =item (*) I have been pressured multiple times by Brian Ingerson (one of the authors of the YAML specification) to remove this paragraph, despite him acknowledging that the actual incompatibilities exist. As I was personally bitten by this "JSON is YAML" lie, I refused and said I will continue to educate people about these issues, so others do not run into the same problem again and again. After this, Brian called me a (quote)I<complete and worthless idiot>(unquote). In my opinion, instead of pressuring and insulting people who actually clarify issues with YAML and the wrong statements of some of its proponents, I would kindly suggest reading the JSON spec (which is not that difficult or long) and finally make YAML compatible to it, and educating users about the changes, instead of spreading lies about the real compatibility for many I<years> and trying to silence people who point out that it isn't true. Addendum/2009: the YAML 1.2 spec is still incompatible with JSON, even though the incompatibilities have been documented (and are known to Brian) for many years and the spec makes explicit claims that YAML is a superset of JSON. It would be so easy to fix, but apparently, bullying people and corrupting userdata is so much easier. =back =head2 SPEED It seems that JSON::XS is surprisingly fast, as shown in the following tables. They have been generated with the help of the C<eg/bench> program in the JSON::XS distribution, to make it easy to compare on your own system. First comes a comparison between various modules using a very short single-line JSON string (also available at L<http://dist.schmorp.de/misc/json/short.json>). {"method": "handleMessage", "params": ["user1", "we were just talking"], "id": null, "array":[1,11,234,-5,1e5,1e7, 1, 0]} It shows the number of encodes/decodes per second (JSON::XS uses the functional interface, while JSON::XS/2 uses the OO interface with pretty-printing and hashkey sorting enabled, JSON::XS/3 enables shrink. JSON::DWIW/DS uses the deserialise function, while JSON::DWIW::FJ uses the from_json method). Higher is better: module | encode | decode | --------------|------------|------------| JSON::DWIW/DS | 86302.551 | 102300.098 | JSON::DWIW/FJ | 86302.551 | 75983.768 | JSON::PP | 15827.562 | 6638.658 | JSON::Syck | 63358.066 | 47662.545 | JSON::XS | 511500.488 | 511500.488 | JSON::XS/2 | 291271.111 | 388361.481 | JSON::XS/3 | 361577.931 | 361577.931 | Storable | 66788.280 | 265462.278 | --------------+------------+------------+ That is, JSON::XS is almost six times faster than JSON::DWIW on encoding, about five times faster on decoding, and over thirty to seventy times faster than JSON's pure perl implementation. It also compares favourably to Storable for small amounts of data. Using a longer test string (roughly 18KB, generated from Yahoo! Locals search API (L<http://dist.schmorp.de/misc/json/long.json>). module | encode | decode | --------------|------------|------------| JSON::DWIW/DS | 1647.927 | 2673.916 | JSON::DWIW/FJ | 1630.249 | 2596.128 | JSON::PP | 400.640 | 62.311 | JSON::Syck | 1481.040 | 1524.869 | JSON::XS | 20661.596 | 9541.183 | JSON::XS/2 | 10683.403 | 9416.938 | JSON::XS/3 | 20661.596 | 9400.054 | Storable | 19765.806 | 10000.725 | --------------+------------+------------+ Again, JSON::XS leads by far (except for Storable which non-surprisingly decodes a bit faster). On large strings containing lots of high Unicode characters, some modules (such as JSON::PC) seem to decode faster than JSON::XS, but the result will be broken due to missing (or wrong) Unicode handling. Others refuse to decode or encode properly, so it was impossible to prepare a fair comparison table for that case. =head1 SECURITY CONSIDERATIONS When you are using JSON in a protocol, talking to untrusted potentially hostile creatures requires relatively few measures. First of all, your JSON decoder should be secure, that is, should not have any buffer overflows. Obviously, this module should ensure that and I am trying hard on making that true, but you never know. Second, you need to avoid resource-starving attacks. That means you should limit the size of JSON texts you accept, or make sure then when your resources run out, that's just fine (e.g. by using a separate process that can crash safely). The size of a JSON text in octets or characters is usually a good indication of the size of the resources required to decode it into a Perl structure. While JSON::XS can check the size of the JSON text, it might be too late when you already have it in memory, so you might want to check the size before you accept the string. Third, JSON::XS recurses using the C stack when decoding objects and arrays. The C stack is a limited resource: for instance, on my amd64 machine with 8MB of stack size I can decode around 180k nested arrays but only 14k nested JSON objects (due to perl itself recursing deeply on croak to free the temporary). If that is exceeded, the program crashes. To be conservative, the default nesting limit is set to 512. If your process has a smaller stack, you should adjust this setting accordingly with the C<max_depth> method. Something else could bomb you, too, that I forgot to think of. In that case, you get to keep the pieces. I am always open for hints, though... Also keep in mind that JSON::XS might leak contents of your Perl data structures in its error messages, so when you serialise sensitive information you might want to make sure that exceptions thrown by JSON::XS will not end up in front of untrusted eyes. If you are using JSON::XS to return packets to consumption by JavaScript scripts in a browser you should have a look at L<http://blog.archive.jpsykes.com/47/practical-csrf-and-json-security/> to see whether you are vulnerable to some common attack vectors (which really are browser design bugs, but it is still you who will have to deal with it, as major browser developers care only for features, not about getting security right). =head2 "OLD" VS. "NEW" JSON (RFC4627 VS. RFC7159) JSON originally required JSON texts to represent an array or object - scalar values were explicitly not allowed. This has changed, and versions of JSON::XS beginning with C<4.0> reflect this by allowing scalar values by default. One reason why one might not want this is that this removes a fundamental property of JSON texts, namely that they are self-delimited and self-contained, or in other words, you could take any number of "old" JSON texts and paste them together, and the result would be unambiguously parseable: [1,3]{"k":5}[][null] # four JSON texts, without doubt By allowing scalars, this property is lost: in the following example, is this one JSON text (the number 12) or two JSON texts (the numbers 1 and 2): 12 # could be 12, or 1 and 2 Another lost property of "old" JSON is that no lookahead is required to know the end of a JSON text, i.e. the JSON text definitely ended at the last C<]> or C<}> character, there was no need to read extra characters. For example, a viable network protocol with "old" JSON was to simply exchange JSON texts without delimiter. For "new" JSON, you have to use a suitable delimiter (such as a newline) after every JSON text or ensure you never encode/decode scalar values. Most protocols do work by only transferring arrays or objects, and the easiest way to avoid problems with the "new" JSON definition is to explicitly disallow scalar values in your encoder and decoder: $json_coder = JSON::XS->new->allow_nonref (0) This is a somewhat unhappy situation, and the blame can fully be put on JSON's inmventor, Douglas Crockford, who unilaterally changed the format in 2006 without consulting the IETF, forcing the IETF to either fork the format or go with it (as I was told, the IETF wasn't amused). =head1 RELATIONSHIP WITH I-JSON JSON is a somewhat sloppily-defined format - it carries around obvious Javascript baggage, such as not really defining number range, probably because Javascript only has one type of numbers: IEEE 64 bit floats ("binary64"). For this reaosn, RFC7493 defines "Internet JSON", which is a restricted subset of JSON that is supposedly more interoperable on the internet. While C<JSON::XS> does not offer specific support for I-JSON, it of course accepts valid I-JSON and by default implements some of the limitations of I-JSON, such as parsing numbers as perl numbers, which are usually a superset of binary64 numbers. To generate I-JSON, follow these rules: =over =item * always generate UTF-8 I-JSON must be encoded in UTF-8, the default for C<encode_json>. =item * numbers should be within IEEE 754 binary64 range Basically all existing perl installations use binary64 to represent floating point numbers, so all you need to do is to avoid large integers. =item * objects must not have duplicate keys This is trivially done, as C<JSON::XS> does not allow duplicate keys. =item * do not generate scalar JSON texts, use C<< ->allow_nonref (0) >> I-JSON strongly requests you to only encode arrays and objects into JSON. =item * times should be strings in ISO 8601 format There are a myriad of modules on CPAN dealing with ISO 8601 - search for C<ISO8601> on CPAN and use one. =item * encode binary data as base64 While it's tempting to just dump binary data as a string (and let C<JSON::XS> do the escaping), for I-JSON, it's I<recommended> to encode binary data as base64. =back There are some other considerations - read RFC7493 for the details if interested. =head1 INTEROPERABILITY WITH OTHER MODULES C<JSON::XS> uses the L<Types::Serialiser> module to provide boolean constants. That means that the JSON true and false values will be comaptible to true and false values of other modules that do the same, such as L<JSON::PP> and L<CBOR::XS>. =head1 INTEROPERABILITY WITH OTHER JSON DECODERS As long as you only serialise data that can be directly expressed in JSON, C<JSON::XS> is incapable of generating invalid JSON output (modulo bugs, but C<JSON::XS> has found more bugs in the official JSON testsuite (1) than the official JSON testsuite has found in C<JSON::XS> (0)). When you have trouble decoding JSON generated by this module using other decoders, then it is very likely that you have an encoding mismatch or the other decoder is broken. When decoding, C<JSON::XS> is strict by default and will likely catch all errors. There are currently two settings that change this: C<relaxed> makes C<JSON::XS> accept (but not generate) some non-standard extensions, and C<allow_tags> will allow you to encode and decode Perl objects, at the cost of not outputting valid JSON anymore. =head2 TAGGED VALUE SYNTAX AND STANDARD JSON EN/DECODERS When you use C<allow_tags> to use the extended (and also nonstandard and invalid) JSON syntax for serialised objects, and you still want to decode the generated When you want to serialise objects, you can run a regex to replace the tagged syntax by standard JSON arrays (it only works for "normal" package names without comma, newlines or single colons). First, the readable Perl version: # if your FREEZE methods return no values, you need this replace first: $json =~ s/\( \s* (" (?: [^\\":,]+|\\.|::)* ") \s* \) \s* \[\s*\]/[$1]/gx; # this works for non-empty constructor arg lists: $json =~ s/\( \s* (" (?: [^\\":,]+|\\.|::)* ") \s* \) \s* \[/[$1,/gx; And here is a less readable version that is easy to adapt to other languages: $json =~ s/\(\s*("([^\\":,]+|\\.|::)*")\s*\)\s*\[/[$1,/g; Here is an ECMAScript version (same regex): json = json.replace (/\(\s*("([^\\":,]+|\\.|::)*")\s*\)\s*\[/g, "[$1,"); Since this syntax converts to standard JSON arrays, it might be hard to distinguish serialised objects from normal arrays. You can prepend a "magic number" as first array element to reduce chances of a collision: $json =~ s/\(\s*("([^\\":,]+|\\.|::)*")\s*\)\s*\[/["XU1peReLzT4ggEllLanBYq4G9VzliwKF",$1,/g; And after decoding the JSON text, you could walk the data structure looking for arrays with a first element of C<XU1peReLzT4ggEllLanBYq4G9VzliwKF>. The same approach can be used to create the tagged format with another encoder. First, you create an array with the magic string as first member, the classname as second, and constructor arguments last, encode it as part of your JSON structure, and then: $json =~ s/\[\s*"XU1peReLzT4ggEllLanBYq4G9VzliwKF"\s*,\s*("([^\\":,]+|\\.|::)*")\s*,/($1)[/g; Again, this has some limitations - the magic string must not be encoded with character escapes, and the constructor arguments must be non-empty. =head1 (I-)THREADS This module is I<not> guaranteed to be ithread (or MULTIPLICITY-) safe and there are no plans to change this. Note that perl's builtin so-called threads/ithreads are officially deprecated and should not be used. =head1 THE PERILS OF SETLOCALE Sometimes people avoid the Perl locale support and directly call the system's setlocale function with C<LC_ALL>. This breaks both perl and modules such as JSON::XS, as stringification of numbers no longer works correctly (e.g. C<$x = 0.1; print "$x"+1> might print C<1>, and JSON::XS might output illegal JSON as JSON::XS relies on perl to stringify numbers). The solution is simple: don't call C<setlocale>, or use it for only those categories you need, such as C<LC_MESSAGES> or C<LC_CTYPE>. If you need C<LC_NUMERIC>, you should enable it only around the code that actually needs it (avoiding stringification of numbers), and restore it afterwards. =head1 SOME HISTORY At the time this module was created there already were a number of JSON modules available on CPAN, so what was the reason to write yet another JSON module? While it seems there are many JSON modules, none of them correctly handled all corner cases, and in most cases their maintainers are unresponsive, gone missing, or not listening to bug reports for other reasons. Beginning with version 2.0 of the JSON module, when both JSON and JSON::XS are installed, then JSON will fall back on JSON::XS (this can be overridden) with no overhead due to emulation (by inheriting constructor and methods). If JSON::XS is not available, it will fall back to the compatible JSON::PP module as backend, so using JSON instead of JSON::XS gives you a portable JSON API that can be fast when you need it and doesn't require a C compiler when that is a problem. Somewhere around version 3, this module was forked into C<Cpanel::JSON::XS>, because its maintainer had serious trouble understanding JSON and insisted on a fork with many bugs "fixed" that weren't actually bugs, while spreading FUD about this module without actually giving any details on his accusations. You be the judge, but in my personal opinion, if you want quality, you will stay away from dangerous forks like that. =head1 BUGS While the goal of this module is to be correct, that unfortunately does not mean it's bug-free, only that I think its design is bug-free. If you keep reporting bugs they will be fixed swiftly, though. Please refrain from using rt.cpan.org or any other bug reporting service. I put the contact address into my modules for a reason. =cut BEGIN { *true = \$Types::Serialiser::true; *true = \&Types::Serialiser::true; *false = \$Types::Serialiser::false; *false = \&Types::Serialiser::false; *is_bool = \&Types::Serialiser::is_bool; *JSON::XS::Boolean:: = *Types::Serialiser::Boolean::; } XSLoader::load "JSON::XS", $VERSION; =head1 SEE ALSO The F<json_xs> command line utility for quick experiments. =head1 AUTHOR Marc Lehmann <schmorp@schmorp.de> http://home.schmorp.de/ =cut 1 5.32/JSON/Syck.pm 0000444 00000015100 15125513451 0007150 0 ustar 00 package JSON::Syck; use strict; use Exporter; use YAML::Syck (); our $VERSION = '1.34'; our @EXPORT_OK = qw( Load Dump LoadFile DumpFile DumpInto ); our @ISA = qw/Exporter/; *Load = \&YAML::Syck::LoadJSON; *Dump = \&YAML::Syck::DumpJSON; sub DumpFile { my $file = shift; if ( YAML::Syck::_is_glob($file) ) { my $err = YAML::Syck::DumpJSONFile( $_[0], $file ); if ($err) { $! = 0 + $err; die "Error writing to filehandle $file: $!\n"; } } else { open( my $fh, '>', $file ) or die "Cannot write to $file: $!"; my $err = YAML::Syck::DumpJSONFile( $_[0], $fh ); if ($err) { $! = 0 + $err; die "Error writing to file $file: $!\n"; } close $fh or die "Error writing to file $file: $!\n"; } return 1; } sub LoadFile { my $file = shift; if ( YAML::Syck::_is_glob($file) ) { YAML::Syck::LoadJSON( do { local $/; <$file> } ); } else { if ( !-e $file || -z $file ) { die("'$file' is non-existent or empty"); } open( my $fh, '<', $file ) or die "Cannot read from $file: $!"; YAML::Syck::LoadJSON( do { local $/; <$fh> } ); } } sub DumpInto { my $bufref = shift; ( ref $bufref ) or die "DumpInto not given reference to output buffer\n"; YAML::Syck::DumpJSONInto( $_[0], $bufref ); 1; } $JSON::Syck::ImplicitTyping = 1; $JSON::Syck::MaxDepth = 512; $JSON::Syck::Headless = 1; $JSON::Syck::ImplicitUnicode = 0; $JSON::Syck::SingleQuote = 0; 1; __END__ =head1 NAME JSON::Syck - JSON is YAML (but consider using L<JSON::XS> instead!) =head1 SYNOPSIS use JSON::Syck; # no exports by default my $data = JSON::Syck::Load($json); my $json = JSON::Syck::Dump($data); # $file can be an IO object, or a filename my $data = JSON::Syck::LoadFile($file); JSON::Syck::DumpFile($file, $data); # Dump into a pre-existing buffer my $json; JSON::Syck::DumpInto(\$json, $data); =head1 DESCRIPTION JSON::Syck is a syck implementation of JSON parsing and generation. Because JSON is YAML (L<http://redhanded.hobix.com/inspect/yamlIsJson.html>), using syck gives you a fast and memory-efficient parser and dumper for JSON data representation. However, a newer module L<JSON::XS>, has since emerged. It is more flexible, efficient and robust, so please consider using it instead of this module. =head1 DIFFERENCE WITH JSON You might want to know the difference between the I<JSON> module and this one. Since JSON is a pure-perl module and JSON::Syck is based on libsyck, JSON::Syck is supposed to be very fast and memory efficient. See chansen's benchmark table at L<http://idisk.mac.com/christian.hansen/Public/perl/serialize.pl> JSON.pm comes with dozens of ways to do the same thing and lots of options, while JSON::Syck doesn't. There's only C<Load> and C<Dump>. Oh, and JSON::Syck doesn't use camelCase method names :-) =head1 REFERENCES =head2 SCALAR REFERENCE For now, when you pass a scalar reference to JSON::Syck, it dereferences to get the actual scalar value. JSON::Syck raises an exception when you pass in circular references. If you want to serialize self referencing stuff, you should use YAML which supports it. =head2 SUBROUTINE REFERENCE When you pass subroutine reference, JSON::Syck dumps it as null. =head1 UTF-8 FLAGS By default this module doesn't touch any of utf-8 flags set in strings, and assumes UTF-8 bytes to be passed and emit. However, when you set C<$JSON::Syck::ImplicitUnicode> to 1, this module properly decodes UTF-8 binaries and sets UTF-8 flag everywhere, as in: JSON (UTF-8 bytes) => Perl (UTF-8 flagged) JSON (UTF-8 flagged) => Perl (UTF-8 flagged) Perl (UTF-8 bytes) => JSON (UTF-8 flagged) Perl (UTF-8 flagged) => JSON (UTF-8 flagged) By default, JSON::Syck::Dump will only transverse up to 512 levels of a datastructure in order to avoid an infinite loop when it is presented with an circular reference. However, you set C<$JSON::Syck::MaxLevels> to a larger value if you have very complex structures. Unfortunately, there's no implicit way to dump Perl UTF-8 flagged data structure to utf-8 encoded JSON. To do this, simply use Encode module, e.g.: use Encode; use JSON::Syck qw(Dump); my $json = encode_utf8( Dump($data) ); Alternatively you can use Encode::JavaScript::UCS to encode Unicode strings as in I<%uXXXX> form. use Encode; use Encode::JavaScript::UCS; use JSON::Syck qw(Dump); my $json_unicode_escaped = encode( 'JavaScript-UCS', Dump($data) ); =head1 QUOTING According to the JSON specification, all JSON strings are to be double-quoted. However, when embedding JavaScript in HTML attributes, it may be more convenient to use single quotes. Set C<$JSON::Syck::SingleQuote> to 1 will make both C<Dump> and C<Load> expect single-quoted string literals. =head1 BUGS Dumping into tied (or other magic variables) with C<DumpInto> might not work properly in all cases. When dumping with C<DumpFile>, some spacing might be wrong and C<$JSON::Syck::SingleQuote> might be handled incorrectly. =head1 SEE ALSO L<JSON::XS>, L<YAML::Syck> =head1 AUTHORS Audrey Tang E<lt>cpan@audreyt.orgE<gt> Tatsuhiko Miyagawa E<lt>miyagawa@gmail.comE<gt> =head1 COPYRIGHT Copyright 2005-2009 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>. This software is released under the MIT license cited below. The F<libsyck> code bundled with this library is released by "why the lucky stiff", under a BSD-style license. See the F<COPYING> file for details. =head2 The "MIT" License Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =cut 5.32/JSON/XS/Boolean.pm 0000444 00000001122 15125513451 0010147 0 ustar 00 =head1 NAME JSON::XS::Boolean - dummy module providing JSON::XS::Boolean =head1 SYNOPSIS # do not "use" yourself =head1 DESCRIPTION This module exists only to provide overload resolution for Storable and similar modules. It's only needed for compatibility with data serialised (by other modules such as Storable) that was decoded by JSON::XS versions before 3.0. Since 3.0, JSON::PP::Boolean has replaced it. Support for JSON::XS::Boolean will be removed in a future release. =cut use JSON::XS (); 1; =head1 AUTHOR Marc Lehmann <schmorp@schmorp.de> http://home.schmorp.de/ =cut 5.32/Digest/MD5.pm 0000444 00000025454 15125513451 0007307 0 ustar 00 package Digest::MD5; use strict; use warnings; our $VERSION = '2.59'; require Exporter; *import = \&Exporter::import; our @EXPORT_OK = qw(md5 md5_hex md5_base64); our @ISA; eval { require Digest::base; @ISA = qw/Digest::base/; }; if ($@) { my $err = $@; *add_bits = sub { die $err }; } eval { require XSLoader; XSLoader::load('Digest::MD5', $VERSION); }; if ($@) { my $olderr = $@; eval { # Try to load the pure perl version require Digest::Perl::MD5; Digest::Perl::MD5->import(qw(md5 md5_hex md5_base64)); unshift(@ISA, "Digest::Perl::MD5"); # make OO interface work }; if ($@) { # restore the original error die $olderr; } } else { *reset = \&new; } 1; __END__ =head1 NAME Digest::MD5 - Perl interface to the MD5 Algorithm =head1 SYNOPSIS # Functional style use Digest::MD5 qw(md5 md5_hex md5_base64); my $digest = md5($data); my $digest = md5_hex($data); my $digest = md5_base64($data); # OO style use Digest::MD5; my $ctx = Digest::MD5->new; $ctx->add($data); $ctx->addfile($file_handle); $digest = $ctx->digest; $digest = $ctx->hexdigest; $digest = $ctx->b64digest; =head1 DESCRIPTION The C<Digest::MD5> module allows you to use the RSA Data Security Inc. MD5 Message Digest algorithm from within Perl programs. The algorithm takes as input a message of arbitrary length and produces as output a 128-bit "fingerprint" or "message digest" of the input. Note that the MD5 algorithm is not as strong as it used to be. It has since 2005 been easy to generate different messages that produce the same MD5 digest. It still seems hard to generate messages that produce a given digest, but it is probably wise to move to stronger algorithms for applications that depend on the digest to uniquely identify a message. The C<Digest::MD5> module provide a procedural interface for simple use, as well as an object oriented interface that can handle messages of arbitrary length and which can read files directly. =head1 FUNCTIONS The following functions are provided by the C<Digest::MD5> module. None of these functions are exported by default. =over 4 =item md5($data,...) This function will concatenate all arguments, calculate the MD5 digest of this "message", and return it in binary form. The returned string will be 16 bytes long. The result of md5("a", "b", "c") will be exactly the same as the result of md5("abc"). =item md5_hex($data,...) Same as md5(), but will return the digest in hexadecimal form. The length of the returned string will be 32 and it will only contain characters from this set: '0'..'9' and 'a'..'f'. =item md5_base64($data,...) Same as md5(), but will return the digest as a base64 encoded string. The length of the returned string will be 22 and it will only contain characters from this set: 'A'..'Z', 'a'..'z', '0'..'9', '+' and '/'. Note that the base64 encoded string returned is not padded to be a multiple of 4 bytes long. If you want interoperability with other base64 encoded md5 digests you might want to append the redundant string "==" to the result. =back =head1 METHODS The object oriented interface to C<Digest::MD5> is described in this section. After a C<Digest::MD5> object has been created, you will add data to it and finally ask for the digest in a suitable format. A single object can be used to calculate multiple digests. The following methods are provided: =over 4 =item $md5 = Digest::MD5->new The constructor returns a new C<Digest::MD5> object which encapsulate the state of the MD5 message-digest algorithm. If called as an instance method (i.e. $md5->new) it will just reset the state the object to the state of a newly created object. No new object is created in this case. =item $md5->reset This is just an alias for $md5->new. =item $md5->clone This a copy of the $md5 object. It is useful when you do not want to destroy the digests state, but need an intermediate value of the digest, e.g. when calculating digests iteratively on a continuous data stream. Example: my $md5 = Digest::MD5->new; while (<>) { $md5->add($_); print "Line $.: ", $md5->clone->hexdigest, "\n"; } =item $md5->add($data,...) The $data provided as argument are appended to the message we calculate the digest for. The return value is the $md5 object itself. All these lines will have the same effect on the state of the $md5 object: $md5->add("a"); $md5->add("b"); $md5->add("c"); $md5->add("a")->add("b")->add("c"); $md5->add("a", "b", "c"); $md5->add("abc"); =item $md5->addfile($io_handle) The $io_handle will be read until EOF and its content appended to the message we calculate the digest for. The return value is the $md5 object itself. The addfile() method will croak() if it fails reading data for some reason. If it croaks it is unpredictable what the state of the $md5 object will be in. The addfile() method might have been able to read the file partially before it failed. It is probably wise to discard or reset the $md5 object if this occurs. In most cases you want to make sure that the $io_handle is in C<binmode> before you pass it as argument to the addfile() method. =item $md5->add_bits($data, $nbits) =item $md5->add_bits($bitstring) Since the MD5 algorithm is byte oriented you might only add bits as multiples of 8, so you probably want to just use add() instead. The add_bits() method is provided for compatibility with other digest implementations. See L<Digest> for description of the arguments that add_bits() take. =item $md5->digest Return the binary digest for the message. The returned string will be 16 bytes long. Note that the C<digest> operation is effectively a destructive, read-once operation. Once it has been performed, the C<Digest::MD5> object is automatically C<reset> and can be used to calculate another digest value. Call $md5->clone->digest if you want to calculate the digest without resetting the digest state. =item $md5->hexdigest Same as $md5->digest, but will return the digest in hexadecimal form. The length of the returned string will be 32 and it will only contain characters from this set: '0'..'9' and 'a'..'f'. =item $md5->b64digest Same as $md5->digest, but will return the digest as a base64 encoded string. The length of the returned string will be 22 and it will only contain characters from this set: 'A'..'Z', 'a'..'z', '0'..'9', '+' and '/'. The base64 encoded string returned is not padded to be a multiple of 4 bytes long. If you want interoperability with other base64 encoded md5 digests you might want to append the string "==" to the result. =item @ctx = $md5->context =item $md5->context(@ctx) Saves or restores the internal state. When called with no arguments, returns a list: number of blocks processed, a 16-byte internal state buffer, then optionally up to 63 bytes of unprocessed data if there are any. When passed those same arguments, restores the state. This is only useful for specialised operations. =back =head1 EXAMPLES The simplest way to use this library is to import the md5_hex() function (or one of its cousins): use Digest::MD5 qw(md5_hex); print "Digest is ", md5_hex("foobarbaz"), "\n"; The above example would print out the message: Digest is 6df23dc03f9b54cc38a0fc1483df6e21 The same checksum can also be calculated in OO style: use Digest::MD5; my $md5 = Digest::MD5->new; $md5->add('foo', 'bar'); $md5->add('baz'); my $digest = $md5->hexdigest; print "Digest is $digest\n"; With OO style, you can break the message arbitrarily. This means that we are no longer limited to have space for the whole message in memory, i.e. we can handle messages of any size. This is useful when calculating checksum for files: use Digest::MD5; my $filename = shift || "/etc/passwd"; open (my $fh, '<', $filename) or die "Can't open '$filename': $!"; binmode($fh); my $md5 = Digest::MD5->new; while (<$fh>) { $md5->add($_); } close($fh); print $md5->b64digest, " $filename\n"; Or we can use the addfile method for more efficient reading of the file: use Digest::MD5; my $filename = shift || "/etc/passwd"; open (my $fh, '<', $filename) or die "Can't open '$filename': $!"; binmode ($fh); print Digest::MD5->new->addfile($fh)->hexdigest, " $filename\n"; Since the MD5 algorithm is only defined for strings of bytes, it can not be used on strings that contains chars with ordinal number above 255 (Unicode strings). The MD5 functions and methods will croak if you try to feed them such input data: use Digest::MD5 qw(md5_hex); my $str = "abc\x{300}"; print md5_hex($str), "\n"; # croaks # Wide character in subroutine entry What you can do is calculate the MD5 checksum of the UTF-8 representation of such strings. This is achieved by filtering the string through encode_utf8() function: use Digest::MD5 qw(md5_hex); use Encode qw(encode_utf8); my $str = "abc\x{300}"; print md5_hex(encode_utf8($str)), "\n"; # 8c2d46911f3f5a326455f0ed7a8ed3b3 =head1 SEE ALSO L<Digest>, L<Digest::MD2>, L<Digest::SHA>, L<Digest::HMAC> L<md5sum(1)> RFC 1321 http://en.wikipedia.org/wiki/MD5 The paper "How to Break MD5 and Other Hash Functions" by Xiaoyun Wang and Hongbo Yu. =head1 COPYRIGHT This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright 1998-2003 Gisle Aas. Copyright 1995-1996 Neil Winton. Copyright 1991-1992 RSA Data Security, Inc. The MD5 algorithm is defined in RFC 1321. This implementation is derived from the reference C code in RFC 1321 which is covered by the following copyright statement: =over 4 =item Copyright (C) 1991-2, RSA Data Security, Inc. Created 1991. All rights reserved. License to copy and use this software is granted provided that it is identified as the "RSA Data Security, Inc. MD5 Message-Digest Algorithm" in all material mentioning or referencing this software or this function. License is also granted to make and use derivative works provided that such works are identified as "derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm" in all material mentioning or referencing the derived work. RSA Data Security, Inc. makes no representations concerning either the merchantability of this software or the suitability of this software for any particular purpose. It is provided "as is" without express or implied warranty of any kind. These notices must be retained in any copies of any part of this documentation and/or software. =back This copyright does not prohibit distribution of any version of Perl containing this extension under the terms of the GNU or Artistic licenses. =head1 AUTHORS The original C<MD5> interface was written by Neil Winton (C<N.Winton@axion.bt.co.uk>). The C<Digest::MD5> module is written by Gisle Aas <gisle@ActiveState.com>. =cut 5.32/version.pod 0000444 00000024551 15125513451 0007333 0 ustar 00 =head1 NAME version - Perl extension for Version Objects =head1 SYNOPSIS # Parsing version strings (decimal or dotted-decimal) use version 0.77; # get latest bug-fixes and API $ver = version->parse($string) # Declaring a dotted-decimal $VERSION (keep on one line!) use version; our $VERSION = version->declare("v1.2.3"); # formal use version; our $VERSION = qv("v1.2.3"); # deprecated use version; our $VERSION = qv("v1.2_3"); # deprecated # Declaring an old-style decimal $VERSION (use quotes!) our $VERSION = "1.0203"; # recommended use version; our $VERSION = version->parse("1.0203"); # formal use version; our $VERSION = version->parse("1.02_03"); # alpha # Comparing mixed version styles (decimals, dotted-decimals, objects) if ( version->parse($v1) == version->parse($v2) ) { # do stuff } # Sorting mixed version styles @ordered = sort { version->parse($a) <=> version->parse($b) } @list; =head1 DESCRIPTION Version objects were added to Perl in 5.10. This module implements version objects for older version of Perl and provides the version object API for all versions of Perl. All previous releases before 0.74 are deprecated and should not be used due to incompatible API changes. Version 0.77 introduces the new 'parse' and 'declare' methods to standardize usage. You are strongly urged to set 0.77 as a minimum in your code, e.g. use version 0.77; # even for Perl v.5.10.0 =head1 TYPES OF VERSION OBJECTS There are two different types of version objects, corresponding to the two different styles of versions in use: =over 2 =item Decimal Versions The classic floating-point number $VERSION. The advantage to this style is that you don't need to do anything special, just type a number into your source file. Quoting is recommended, as it ensures that trailing zeroes ("1.50") are preserved in any warnings or other output. =item Dotted Decimal Versions The more modern form of version assignment, with 3 (or potentially more) integers separated by decimal points (e.g. v1.2.3). This is the form that Perl itself has used since 5.6.0 was released. The leading 'v' is now strongly recommended for clarity, and will throw a warning in a future release if omitted. A leading 'v' character is required to pass the L</is_strict()> test. =back =head1 DECLARING VERSIONS If you have a module that uses a decimal $VERSION (floating point), and you do not intend to ever change that, this module is not for you. There is nothing that version.pm gains you over a simple $VERSION assignment: our $VERSION = "1.02"; Since Perl v5.10.0 includes the version.pm comparison logic anyways, you don't need to do anything at all. =head2 How to convert a module from decimal to dotted-decimal If you have used a decimal $VERSION in the past and wish to switch to a dotted-decimal $VERSION, then you need to make a one-time conversion to the new format. B<Important Note>: you must ensure that your new $VERSION is numerically greater than your current decimal $VERSION; this is not always obvious. First, convert your old decimal version (e.g. 1.02) to a normalized dotted-decimal form: $ perl -Mversion -e 'print version->parse("1.02")->normal' v1.20.0 Then increment any of the dotted-decimal components (v1.20.1 or v1.21.0). =head2 How to C<declare()> a dotted-decimal version use version; our $VERSION = version->declare("v1.2.3"); The C<declare()> method always creates dotted-decimal version objects. When used in a module, you B<must> put it on the same line as "use version" to ensure that $VERSION is read correctly by PAUSE and installer tools. You should also add 'version' to the 'configure_requires' section of your module metadata file. See instructions in L<ExtUtils::MakeMaker> or L<Module::Build> for details. B<Important Note>: Even if you pass in what looks like a decimal number ("1.2"), a dotted-decimal will be created ("v1.200.0"). To avoid confusion or unintentional errors on older Perls, follow these guidelines: =over 2 =item * Always use a dotted-decimal with (at least) three components =item * Always use a leading-v =item * Always quote the version =back If you really insist on using version.pm with an ordinary decimal version, use C<parse()> instead of declare. See the L<PARSING AND COMPARING VERSIONS> for details. See also L<version::Internals> for more on version number conversion, quoting, calculated version numbers and declaring developer or "alpha" version numbers. =head1 PARSING AND COMPARING VERSIONS If you need to compare version numbers, but can't be sure whether they are expressed as numbers, strings, v-strings or version objects, then you should use version.pm to parse them all into objects for comparison. =head2 How to C<parse()> a version The C<parse()> method takes in anything that might be a version and returns a corresponding version object, doing any necessary conversion along the way. =over 2 =item * Dotted-decimal: bare v-strings (v1.2.3) and strings with more than one decimal point and a leading 'v' ("v1.2.3"); NOTE you can technically use a v-string or strings with a leading-v and only one decimal point (v1.2 or "v1.2"), but you will confuse both yourself and others. =item * Decimal: regular decimal numbers (literal or in a string) =back Some examples: $variable version->parse($variable) --------- ------------------------- 1.23 v1.230.0 "1.23" v1.230.0 v1.23 v1.23.0 "v1.23" v1.23.0 "1.2.3" v1.2.3 "v1.2.3" v1.2.3 See L<version::Internals> for more on version number conversion. =head2 How to check for a legal version string If you do not want to actually create a full blown version object, but would still like to verify that a given string meets the criteria to be parsed as a version, there are two helper functions that can be employed directly: =over 4 =item C<is_lax()> The lax criteria corresponds to what is currently allowed by the version parser. All of the following formats are acceptable for dotted-decimal formats strings: v1.2 1.2345.6 v1.23_4 1.2345 1.2345_01 =item C<is_strict()> If you want to limit yourself to a much more narrow definition of what a version string constitutes, C<is_strict()> is limited to version strings like the following list: v1.234.5 2.3456 =back See L<version::Internals> for details of the regular expressions that define the legal version string forms, as well as how to use those regular expressions in your own code if C<is_lax()> and C<is_strict()> are not sufficient for your needs. =head2 How to compare version objects Version objects overload the C<cmp> and C<< <=> >> operators. Perl automatically generates all of the other comparison operators based on those two so all the normal logical comparisons will work. if ( version->parse($v1) == version->parse($v2) ) { # do stuff } If a version object is compared against a non-version object, the non-object term will be converted to a version object using C<parse()>. This may give surprising results: $v1 = version->parse("v0.95.0"); $bool = $v1 < 0.94; # TRUE since 0.94 is v0.940.0 Always comparing to a version object will help avoid surprises: $bool = $v1 < version->parse("v0.94.0"); # FALSE Note that "alpha" version objects (where the version string contains a trailing underscore segment) compare as less than the equivalent version without an underscore: $bool = version->parse("1.23_45") < version->parse("1.2345"); # TRUE See L<version::Internals> for more details on "alpha" versions. =head1 OBJECT METHODS =head2 is_alpha() True if and only if the version object was created with a underscore, e.g. version->parse('1.002_03')->is_alpha; # TRUE version->declare('1.2.3_4')->is_alpha; # TRUE =head2 is_qv() True only if the version object is a dotted-decimal version, e.g. version->parse('v1.2.0')->is_qv; # TRUE version->declare('v1.2')->is_qv; # TRUE qv('1.2')->is_qv; # TRUE version->parse('1.2')->is_qv; # FALSE =head2 normal() Returns a string with a standard 'normalized' dotted-decimal form with a leading-v and at least 3 components. version->declare('v1.2')->normal; # v1.2.0 version->parse('1.2')->normal; # v1.200.0 =head2 numify() Returns a value representing the object in a pure decimal. version->declare('v1.2')->numify; # 1.002000 version->parse('1.2')->numify; # 1.200 =head2 to_decimal This returns a new version object for the numified version, much like C<< version->parse($v->numify) >> would. version->parse('v1.2')->to_decimal; # 1.002000 =head2 to_dotted_decimal This returns a new version object for the normalized version, much like C<< version->parse($v->normal) >> would. version->parse('1.002')->to_dotted_decimal; # v1.2.0 =head2 tuple() This turns the components of the version into a list. E.g. version->parse('1.2.3')->tuple; # (1, 2, 3) =head2 from_tuple(...) This takes a list of components and creates a dotted decimal version out of it. E.g. version->from_tuple(1, 2, 3) # v1.2.3 =head2 stringify() Returns a string that is as close to the original representation as possible. If the original representation was a numeric literal, it will be returned the way perl would normally represent it in a string. This method is used whenever a version object is interpolated into a string. version->declare('v1.2')->stringify; # v1.2 version->parse('1.200')->stringify; # 1.2 version->parse(1.02_30)->stringify; # 1.023 =head2 tuple Returns an array of non-negative integers that is used for comparison purposes with other version objects. =head1 EXPORTED FUNCTIONS =head2 qv() This function is no longer recommended for use, but is maintained for compatibility with existing code. If you do not want to have it exported to your namespace, use this form: use version 0.77 (); =head2 is_lax() (Not exported by default) This function takes a scalar argument and returns a boolean value indicating whether the argument meets the "lax" rules for a version number. Leading and trailing spaces are not allowed. =head2 is_strict() (Not exported by default) This function takes a scalar argument and returns a boolean value indicating whether the argument meets the "strict" rules for a version number. Leading and trailing spaces are not allowed. =head1 AUTHOR John Peacock E<lt>jpeacock@cpan.orgE<gt> =head1 SEE ALSO L<version::Internals>. L<perl>. =cut 5.32/DBD/mysql.pm 0000444 00000176203 15125513451 0007240 0 ustar 00 use strict; use warnings; require 5.008_001; # just as DBI package DBD::mysql; use DBI; use DynaLoader(); use Carp; our @ISA = qw(DynaLoader); # please make sure the sub-version does not increase above '099' # SQL_DRIVER_VER is formatted as dd.dd.dddd # for version 5.x please switch to 5.00(_00) version numbering # keep $VERSION in Bundle/DBD/mysql.pm in sync our $VERSION = '5.011'; bootstrap DBD::mysql $VERSION; our $err = 0; # holds error code for DBI::err our $errstr = ""; # holds error string for DBI::errstr our $drh = undef; # holds driver handle once initialised my $methods_are_installed = 0; sub driver{ return $drh if $drh; my($class, $attr) = @_; $class .= "::dr"; # not a 'my' since we use it above to prevent multiple drivers $drh = DBI::_new_drh($class, { 'Name' => 'mysql', 'Version' => $VERSION, 'Err' => \$DBD::mysql::err, 'Errstr' => \$DBD::mysql::errstr, 'Attribution' => 'DBD::mysql by Patrick Galbraith' }); if (!$methods_are_installed) { DBD::mysql::db->install_method('mysql_fd'); DBD::mysql::db->install_method('mysql_async_result'); DBD::mysql::db->install_method('mysql_async_ready'); DBD::mysql::st->install_method('mysql_async_result'); DBD::mysql::st->install_method('mysql_async_ready'); $methods_are_installed++; } $drh; } sub CLONE { undef $drh; } sub _OdbcParse($$$) { my($class, $dsn, $hash, $args) = @_; my($var, $val); if (!defined($dsn)) { return; } while (length($dsn)) { if ($dsn =~ /([^:;]*\[.*]|[^:;]*)[:;](.*)/) { $val = $1; $dsn = $2; $val =~ s/\[|]//g; # Remove [] if present, the rest of the code prefers plain IPv6 addresses } else { $val = $dsn; $dsn = ''; } if ($val =~ /([^=]*)=(.*)/) { $var = $1; $val = $2; if ($var eq 'hostname' || $var eq 'host') { $hash->{'host'} = $val; } elsif ($var eq 'db' || $var eq 'dbname') { $hash->{'database'} = $val; } else { $hash->{$var} = $val; } } else { foreach $var (@$args) { if (!defined($hash->{$var})) { $hash->{$var} = $val; last; } } } } } sub _OdbcParseHost ($$) { my($class, $dsn) = @_; my($hash) = {}; $class->_OdbcParse($dsn, $hash, ['host', 'port']); ($hash->{'host'}, $hash->{'port'}); } sub AUTOLOAD { my ($meth) = $DBD::mysql::AUTOLOAD; my ($smeth) = $meth; $smeth =~ s/(.*)\:\://; my $val = constant($smeth, @_ ? $_[0] : 0); if ($! == 0) { eval "sub $meth { $val }"; return $val; } Carp::croak "$meth: Not defined"; } 1; package DBD::mysql::dr; # ====== DRIVER ====== use strict; use DBI qw(:sql_types); use DBI::Const::GetInfoType; sub connect { my($drh, $dsn, $username, $password, $attrhash) = @_; my($port); my($cWarn); my $connect_ref= { 'Name' => $dsn }; my $dbi_imp_data; # Avoid warnings for undefined values $username ||= ''; $password ||= ''; $attrhash ||= {}; $attrhash->{mysql_conn_attrs} ||= {}; $attrhash->{mysql_conn_attrs}->{'program_name'} ||= $0; # create a 'blank' dbh my($this, $privateAttrHash) = (undef, $attrhash); $privateAttrHash = { %$privateAttrHash, 'Name' => $dsn, 'user' => $username, 'password' => $password }; DBD::mysql->_OdbcParse($dsn, $privateAttrHash, ['database', 'host', 'port']); $dbi_imp_data = delete $attrhash->{dbi_imp_data}; $connect_ref->{'dbi_imp_data'} = $dbi_imp_data; if (!defined($this = DBI::_new_dbh($drh, $connect_ref, $privateAttrHash))) { return undef; } DBD::mysql::db::_login($this, $dsn, $username, $password) or $this = undef; if ($this && ($ENV{MOD_PERL} || $ENV{GATEWAY_INTERFACE})) { $this->{mysql_auto_reconnect} = 1; } $this; } sub data_sources { my($self) = shift; my($attributes) = shift; my($host, $port, $user, $password) = ('', '', '', ''); if ($attributes) { $host = $attributes->{host} || ''; $port = $attributes->{port} || ''; $user = $attributes->{user} || ''; $password = $attributes->{password} || ''; } my(@dsn) = $self->func($host, $port, $user, $password, '_ListDBs'); my($i); for ($i = 0; $i < @dsn; $i++) { $dsn[$i] = "DBI:mysql:$dsn[$i]"; } @dsn; } package DBD::mysql::db; # ====== DATABASE ====== use strict; use DBI qw(:sql_types); %DBD::mysql::db::db2ANSI = ( "INT" => "INTEGER", "CHAR" => "CHAR", "REAL" => "REAL", "IDENT" => "DECIMAL" ); ### ANSI datatype mapping to MySQL datatypes %DBD::mysql::db::ANSI2db = ( "CHAR" => "CHAR", "VARCHAR" => "CHAR", "LONGVARCHAR" => "CHAR", "NUMERIC" => "INTEGER", "DECIMAL" => "INTEGER", "BIT" => "INTEGER", "TINYINT" => "INTEGER", "SMALLINT" => "INTEGER", "INTEGER" => "INTEGER", "BIGINT" => "INTEGER", "REAL" => "REAL", "FLOAT" => "REAL", "DOUBLE" => "REAL", "BINARY" => "CHAR", "VARBINARY" => "CHAR", "LONGVARBINARY" => "CHAR", "DATE" => "CHAR", "TIME" => "CHAR", "TIMESTAMP" => "CHAR" ); sub prepare { my($dbh, $statement, $attribs)= @_; return unless $dbh->func('_async_check'); # create a 'blank' dbh my $sth = DBI::_new_sth($dbh, {'Statement' => $statement}); # Populate internal handle data. if (!DBD::mysql::st::_prepare($sth, $statement, $attribs)) { $sth = undef; } $sth; } sub db2ANSI { my $self = shift; my $type = shift; return $DBD::mysql::db::db2ANSI{"$type"}; } sub ANSI2db { my $self = shift; my $type = shift; return $DBD::mysql::db::ANSI2db{"$type"}; } sub table_info ($) { my ($dbh, $catalog, $schema, $table, $type, $attr) = @_; $dbh->{mysql_server_prepare}||= 0; my $mysql_server_prepare_save= $dbh->{mysql_server_prepare}; $dbh->{mysql_server_prepare}= 0; my @names = qw(TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS); my @rows; my $sponge = DBI->connect("DBI:Sponge:", '','') or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); # Return the list of catalogs if (defined $catalog && $catalog eq "%" && (!defined($schema) || $schema eq "") && (!defined($table) || $table eq "")) { @rows = (); # Empty, because MySQL doesn't support catalogs (yet) } # Return the list of schemas elsif (defined $schema && $schema eq "%" && (!defined($catalog) || $catalog eq "") && (!defined($table) || $table eq "")) { my $sth = $dbh->prepare("SHOW DATABASES") or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && return undef); $sth->execute() or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && return DBI::set_err($dbh, $sth->err(), $sth->errstr())); while (my $ref = $sth->fetchrow_arrayref()) { push(@rows, [ undef, $ref->[0], undef, undef, undef ]); } } # Return the list of table types elsif (defined $type && $type eq "%" && (!defined($catalog) || $catalog eq "") && (!defined($schema) || $schema eq "") && (!defined($table) || $table eq "")) { @rows = ( [ undef, undef, undef, "TABLE", undef ], [ undef, undef, undef, "VIEW", undef ], ); } # Special case: a catalog other than undef, "", or "%" elsif (defined $catalog && $catalog ne "" && $catalog ne "%") { @rows = (); # Nothing, because MySQL doesn't support catalogs yet. } # Uh oh, we actually have a meaty table_info call. Work is required! else { my @schemas; # If no table was specified, we want them all $table ||= "%"; # If something was given for the schema, we need to expand it to # a list of schemas, since it may be a wildcard. if (defined $schema && $schema ne "") { my $sth = $dbh->prepare("SHOW DATABASES LIKE " . $dbh->quote($schema)) or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && return undef); $sth->execute() or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && return DBI::set_err($dbh, $sth->err(), $sth->errstr())); while (my $ref = $sth->fetchrow_arrayref()) { push @schemas, $ref->[0]; } } # Otherwise we want the current database else { push @schemas, $dbh->selectrow_array("SELECT DATABASE()"); } # Figure out which table types are desired my ($want_tables, $want_views); if (defined $type && $type ne "") { $want_tables = ($type =~ m/table/i); $want_views = ($type =~ m/view/i); } else { $want_tables = $want_views = 1; } for my $database (@schemas) { my $sth = $dbh->prepare("SHOW /*!50002 FULL*/ TABLES FROM " . $dbh->quote_identifier($database) . " LIKE " . $dbh->quote($table)) or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && return undef); $sth->execute() or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && return DBI::set_err($dbh, $sth->err(), $sth->errstr())); while (my $ref = $sth->fetchrow_arrayref()) { my $type = (defined $ref->[1] && $ref->[1] =~ /view/i) ? 'VIEW' : 'TABLE'; next if $type eq 'TABLE' && not $want_tables; next if $type eq 'VIEW' && not $want_views; push @rows, [ undef, $database, $ref->[0], $type, undef ]; } } } my $sth = $sponge->prepare("table_info", { rows => \@rows, NUM_OF_FIELDS => scalar @names, NAME => \@names, }) or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && return $dbh->DBI::set_err($sponge->err(), $sponge->errstr())); $dbh->{mysql_server_prepare}= $mysql_server_prepare_save; return $sth; } sub column_info { my ($dbh, $catalog, $schema, $table, $column) = @_; return unless $dbh->func('_async_check'); $dbh->{mysql_server_prepare}||= 0; my $mysql_server_prepare_save= $dbh->{mysql_server_prepare}; $dbh->{mysql_server_prepare}= 0; # ODBC allows a NULL to mean all columns, so we'll accept undef $column = '%' unless defined $column; my $ER_NO_SUCH_TABLE= 1146; my $table_id = $dbh->quote_identifier($catalog, $schema, $table); my @names = qw( TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH DECIMAL_DIGITS NUM_PREC_RADIX NULLABLE REMARKS COLUMN_DEF SQL_DATA_TYPE SQL_DATETIME_SUB CHAR_OCTET_LENGTH ORDINAL_POSITION IS_NULLABLE CHAR_SET_CAT CHAR_SET_SCHEM CHAR_SET_NAME COLLATION_CAT COLLATION_SCHEM COLLATION_NAME UDT_CAT UDT_SCHEM UDT_NAME DOMAIN_CAT DOMAIN_SCHEM DOMAIN_NAME SCOPE_CAT SCOPE_SCHEM SCOPE_NAME MAX_CARDINALITY DTD_IDENTIFIER IS_SELF_REF mysql_is_pri_key mysql_type_name mysql_values mysql_is_auto_increment ); my %col_info; local $dbh->{FetchHashKeyName} = 'NAME_lc'; # only ignore ER_NO_SUCH_TABLE in internal_execute if issued from here my $desc_sth = $dbh->prepare("SHOW COLUMNS FROM $table_id LIKE " . $dbh->quote($column)); my $desc = $dbh->selectall_arrayref($desc_sth, { Columns=>{} }); #return $desc_sth if $desc_sth->err(); if (my $err = $desc_sth->err()) { # return the error, unless it is due to the table not # existing per DBI spec if ($err != $ER_NO_SUCH_TABLE) { $dbh->{mysql_server_prepare}= $mysql_server_prepare_save; return undef; } $dbh->set_err(undef,undef); $desc = []; } my $ordinal_pos = 0; my @fields; for my $row (@$desc) { my $type = $row->{type}; $type =~ m/^(\w+)(\((.+)\))?\s?(.*)?$/; my $basetype = lc($1); my $typemod = $3; my $attr = $4; push @fields, $row->{field}; my $info = $col_info{ $row->{field} }= { TABLE_CAT => $catalog, TABLE_SCHEM => $schema, TABLE_NAME => $table, COLUMN_NAME => $row->{field}, NULLABLE => ($row->{null} eq 'YES') ? 1 : 0, IS_NULLABLE => ($row->{null} eq 'YES') ? "YES" : "NO", TYPE_NAME => uc($basetype), COLUMN_DEF => $row->{default}, ORDINAL_POSITION => ++$ordinal_pos, mysql_is_pri_key => ($row->{key} eq 'PRI'), mysql_type_name => $row->{type}, mysql_is_auto_increment => ($row->{extra} =~ /auto_increment/i ? 1 : 0), }; # # This code won't deal with a pathological case where a value # contains a single quote followed by a comma, and doesn't unescape # any escaped values. But who would use those in an enum or set? # my @type_params= ($typemod && index($typemod,"'")>=0) ? ("$typemod," =~ /'(.*?)',/g) # assume all are quoted : split /,/, $typemod||''; # no quotes, plain list s/''/'/g for @type_params; # undo doubling of quotes my @type_attr= split / /, $attr||''; $info->{DATA_TYPE}= SQL_VARCHAR(); if ($basetype =~ /^(char|varchar|\w*text|\w*blob)/) { $info->{DATA_TYPE}= SQL_CHAR() if $basetype eq 'char'; if ($type_params[0]) { $info->{COLUMN_SIZE} = $type_params[0]; } else { $info->{COLUMN_SIZE} = 65535; $info->{COLUMN_SIZE} = 255 if $basetype =~ /^tiny/; $info->{COLUMN_SIZE} = 16777215 if $basetype =~ /^medium/; $info->{COLUMN_SIZE} = 4294967295 if $basetype =~ /^long/; } } elsif ($basetype =~ /^(binary|varbinary)/) { $info->{COLUMN_SIZE} = $type_params[0]; # SQL_BINARY & SQL_VARBINARY are tempting here but don't match the # semantics for mysql (not hex). SQL_CHAR & SQL_VARCHAR are correct here. $info->{DATA_TYPE} = ($basetype eq 'binary') ? SQL_CHAR() : SQL_VARCHAR(); } elsif ($basetype =~ /^(enum|set)/) { if ($basetype eq 'set') { $info->{COLUMN_SIZE} = length(join ",", @type_params); } else { my $max_len = 0; length($_) > $max_len and $max_len = length($_) for @type_params; $info->{COLUMN_SIZE} = $max_len; } $info->{"mysql_values"} = \@type_params; } elsif ($basetype =~ /int/ || $basetype eq 'bit' ) { # big/medium/small/tiny etc + unsigned? $info->{DATA_TYPE} = SQL_INTEGER(); $info->{NUM_PREC_RADIX} = 10; $info->{COLUMN_SIZE} = $type_params[0]; } elsif ($basetype =~ /^decimal/) { $info->{DATA_TYPE} = SQL_DECIMAL(); $info->{NUM_PREC_RADIX} = 10; $info->{COLUMN_SIZE} = $type_params[0]; $info->{DECIMAL_DIGITS} = $type_params[1]; } elsif ($basetype =~ /^(float|double)/) { $info->{DATA_TYPE} = ($basetype eq 'float') ? SQL_FLOAT() : SQL_DOUBLE(); $info->{NUM_PREC_RADIX} = 2; $info->{COLUMN_SIZE} = ($basetype eq 'float') ? 32 : 64; } elsif ($basetype =~ /date|time/) { # date/datetime/time/timestamp if ($basetype eq 'time' or $basetype eq 'date') { #$info->{DATA_TYPE} = ($basetype eq 'time') ? SQL_TYPE_TIME() : SQL_TYPE_DATE(); $info->{DATA_TYPE} = ($basetype eq 'time') ? SQL_TIME() : SQL_DATE(); $info->{COLUMN_SIZE} = ($basetype eq 'time') ? 8 : 10; } else { # datetime/timestamp #$info->{DATA_TYPE} = SQL_TYPE_TIMESTAMP(); $info->{DATA_TYPE} = SQL_TIMESTAMP(); $info->{SQL_DATA_TYPE} = SQL_DATETIME(); $info->{SQL_DATETIME_SUB} = $info->{DATA_TYPE} - ($info->{SQL_DATA_TYPE} * 10); $info->{COLUMN_SIZE} = ($basetype eq 'datetime') ? 19 : $type_params[0] || 14; } $info->{DECIMAL_DIGITS}= 0; # no fractional seconds } elsif ($basetype eq 'year') { # no close standard so treat as int $info->{DATA_TYPE} = SQL_INTEGER(); $info->{NUM_PREC_RADIX} = 10; $info->{COLUMN_SIZE} = 4; } else { Carp::carp("column_info: unrecognized column type '$basetype' of $table_id.$row->{field} treated as varchar"); } $info->{SQL_DATA_TYPE} ||= $info->{DATA_TYPE}; #warn Dumper($info); } my $sponge = DBI->connect("DBI:Sponge:", '','') or ( $dbh->{mysql_server_prepare}= $mysql_server_prepare_save && return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr")); my $sth = $sponge->prepare("column_info $table", { rows => [ map { [ @{$_}{@names} ] } map { $col_info{$_} } @fields ], NUM_OF_FIELDS => scalar @names, NAME => \@names, }) or return ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && $dbh->DBI::set_err($sponge->err(), $sponge->errstr())); $dbh->{mysql_server_prepare}= $mysql_server_prepare_save; return $sth; } sub primary_key_info { my ($dbh, $catalog, $schema, $table) = @_; return unless $dbh->func('_async_check'); $dbh->{mysql_server_prepare}||= 0; my $mysql_server_prepare_save= $dbh->{mysql_server_prepare}; my $table_id = $dbh->quote_identifier($catalog, $schema, $table); my @names = qw( TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME ); my %col_info; local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $desc_sth = $dbh->prepare("SHOW KEYS FROM $table_id"); my $desc= $dbh->selectall_arrayref($desc_sth, { Columns=>{} }); my $ordinal_pos = 0; for my $row (grep { $_->{key_name} eq 'PRIMARY'} @$desc) { $col_info{ $row->{column_name} }= { TABLE_CAT => $catalog, TABLE_SCHEM => $schema, TABLE_NAME => $table, COLUMN_NAME => $row->{column_name}, KEY_SEQ => $row->{seq_in_index}, PK_NAME => $row->{key_name}, }; } my $sponge = DBI->connect("DBI:Sponge:", '','') or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr")); my $sth= $sponge->prepare("primary_key_info $table", { rows => [ map { [ @{$_}{@names} ] } sort { $a->{KEY_SEQ} <=> $b->{KEY_SEQ} } values %col_info ], NUM_OF_FIELDS => scalar @names, NAME => \@names, }) or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && return $dbh->DBI::set_err($sponge->err(), $sponge->errstr())); $dbh->{mysql_server_prepare}= $mysql_server_prepare_save; return $sth; } sub foreign_key_info { my ($dbh, $pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table, ) = @_; return unless $dbh->func('_async_check'); # INFORMATION_SCHEMA.KEY_COLUMN_USAGE was added in 5.0.6 # no one is going to be running 5.0.6, taking out the check for $point > .6 my ($maj, $min, $point) = _version($dbh); return if $maj < 5 ; my $sql = <<'EOF'; SELECT NULL AS PKTABLE_CAT, A.REFERENCED_TABLE_SCHEMA AS PKTABLE_SCHEM, A.REFERENCED_TABLE_NAME AS PKTABLE_NAME, A.REFERENCED_COLUMN_NAME AS PKCOLUMN_NAME, A.TABLE_CATALOG AS FKTABLE_CAT, A.TABLE_SCHEMA AS FKTABLE_SCHEM, A.TABLE_NAME AS FKTABLE_NAME, A.COLUMN_NAME AS FKCOLUMN_NAME, A.ORDINAL_POSITION AS KEY_SEQ, NULL AS UPDATE_RULE, NULL AS DELETE_RULE, A.CONSTRAINT_NAME AS FK_NAME, NULL AS PK_NAME, NULL AS DEFERABILITY, NULL AS UNIQUE_OR_PRIMARY FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE A, INFORMATION_SCHEMA.TABLE_CONSTRAINTS B WHERE A.TABLE_SCHEMA = B.TABLE_SCHEMA AND A.TABLE_NAME = B.TABLE_NAME AND A.CONSTRAINT_NAME = B.CONSTRAINT_NAME AND B.CONSTRAINT_TYPE IS NOT NULL EOF my @where; my @bind; # catalogs are not yet supported by MySQL # if (defined $pk_catalog) { # push @where, 'A.REFERENCED_TABLE_CATALOG = ?'; # push @bind, $pk_catalog; # } if (defined $pk_schema) { push @where, 'A.REFERENCED_TABLE_SCHEMA = ?'; push @bind, $pk_schema; } if (defined $pk_table) { push @where, 'A.REFERENCED_TABLE_NAME = ?'; push @bind, $pk_table; } # if (defined $fk_catalog) { # push @where, 'A.TABLE_CATALOG = ?'; # push @bind, $fk_schema; # } if (defined $fk_schema) { push @where, 'A.TABLE_SCHEMA = ?'; push @bind, $fk_schema; } if (defined $fk_table) { push @where, 'A.TABLE_NAME = ?'; push @bind, $fk_table; } if (@where) { $sql .= ' AND '; $sql .= join ' AND ', @where; } $sql .= " ORDER BY A.TABLE_SCHEMA, A.TABLE_NAME, A.ORDINAL_POSITION"; local $dbh->{FetchHashKeyName} = 'NAME_uc'; my $sth = $dbh->prepare($sql); $sth->execute(@bind); return $sth; } # #86030: PATCH: adding statistics_info support # Thank you to David Dick http://search.cpan.org/~ddick/ sub statistics_info { my ($dbh, $catalog, $schema, $table, $unique_only, $quick, ) = @_; return unless $dbh->func('_async_check'); # INFORMATION_SCHEMA.KEY_COLUMN_USAGE was added in 5.0.6 # no one is going to be running 5.0.6, taking out the check for $point > .6 my ($maj, $min, $point) = _version($dbh); return if $maj < 5 ; my $sql = <<'EOF'; SELECT TABLE_CATALOG AS TABLE_CAT, TABLE_SCHEMA AS TABLE_SCHEM, TABLE_NAME AS TABLE_NAME, NON_UNIQUE AS NON_UNIQUE, NULL AS INDEX_QUALIFIER, INDEX_NAME AS INDEX_NAME, LCASE(INDEX_TYPE) AS TYPE, SEQ_IN_INDEX AS ORDINAL_POSITION, COLUMN_NAME AS COLUMN_NAME, COLLATION AS ASC_OR_DESC, CARDINALITY AS CARDINALITY, NULL AS PAGES, NULL AS FILTER_CONDITION FROM INFORMATION_SCHEMA.STATISTICS EOF my @where; my @bind; if (defined $catalog) { push @where, 'TABLE_CATALOG = ?'; push @bind, $catalog; } if (defined $schema) { push @where, 'TABLE_SCHEMA = ?'; push @bind, $schema; } if (defined $table) { push @where, 'TABLE_NAME = ?'; push @bind, $table; } if ($unique_only) { push @where, 'NON_UNIQUE = ?'; push @bind, 0; } if (@where) { $sql .= ' WHERE '; $sql .= join ' AND ', @where; } $sql .= " ORDER BY TABLE_SCHEMA, TABLE_NAME, ORDINAL_POSITION"; local $dbh->{FetchHashKeyName} = 'NAME_uc'; my $sth = $dbh->prepare($sql); $sth->execute(@bind); return $sth; } sub _version { my $dbh = shift; return $dbh->get_info($DBI::Const::GetInfoType::GetInfoType{SQL_DBMS_VER}) =~ /(\d+)\.(\d+)\.(\d+)/; } #################### # get_info() # Generated by DBI::DBD::Metadata sub get_info { my($dbh, $info_type) = @_; return unless $dbh->func('_async_check'); require DBD::mysql::GetInfo; my $v = $DBD::mysql::GetInfo::info{int($info_type)}; $v = $v->($dbh) if ref $v eq 'CODE'; return $v; } BEGIN { my @needs_async_check = qw/data_sources quote_identifier begin_work/; foreach my $method (@needs_async_check) { no strict 'refs'; my $super = "SUPER::$method"; *$method = sub { my $h = shift; return unless $h->func('_async_check'); return $h->$super(@_); }; } } package DBD::mysql::st; # ====== STATEMENT ====== use strict; BEGIN { my @needs_async_result = qw/fetchrow_hashref fetchall_hashref/; my @needs_async_check = qw/bind_param_array bind_col bind_columns execute_for_fetch/; foreach my $method (@needs_async_result) { no strict 'refs'; my $super = "SUPER::$method"; *$method = sub { my $sth = shift; if(defined $sth->mysql_async_ready) { return unless $sth->mysql_async_result; } return $sth->$super(@_); }; } foreach my $method (@needs_async_check) { no strict 'refs'; my $super = "SUPER::$method"; *$method = sub { my $h = shift; return unless $h->func('_async_check'); return $h->$super(@_); }; } } 1; __END__ =pod =encoding utf8 =head1 NAME DBD::mysql - MySQL driver for the Perl5 Database Interface (DBI) =head1 SYNOPSIS use DBI; my $dsn = "DBI:mysql:database=$database;host=$hostname;port=$port"; my $dbh = DBI->connect($dsn, $user, $password); my $sth = $dbh->prepare( 'SELECT id, first_name, last_name FROM authors WHERE last_name = ?') or die "prepare statement failed: $dbh->errstr()"; $sth->execute('Eggers') or die "execution failed: $dbh->errstr()"; print $sth->rows . " rows found.\n"; while (my $ref = $sth->fetchrow_hashref()) { print "Found a row: id = $ref->{'id'}, fn = $ref->{'first_name'}\n"; } $sth->finish; =head1 EXAMPLE #!/usr/bin/perl use strict; use warnings; use DBI; # Connect to the database. my $dbh = DBI->connect("DBI:mysql:database=test;host=localhost", "joe", "joe's password", {'RaiseError' => 1}); # Drop table 'foo'. This may fail, if 'foo' doesn't exist # Thus we put an eval around it. eval { $dbh->do("DROP TABLE foo") }; print "Dropping foo failed: $@\n" if $@; # Create a new table 'foo'. This must not fail, thus we don't # catch errors. $dbh->do("CREATE TABLE foo (id INTEGER, name VARCHAR(20))"); # INSERT some data into 'foo'. We are using $dbh->quote() for # quoting the name. $dbh->do("INSERT INTO foo VALUES (1, " . $dbh->quote("Tim") . ")"); # same thing, but using placeholders (recommended!) $dbh->do("INSERT INTO foo VALUES (?, ?)", undef, 2, "Jochen"); # now retrieve data from the table. my $sth = $dbh->prepare("SELECT * FROM foo"); $sth->execute(); while (my $ref = $sth->fetchrow_hashref()) { print "Found a row: id = $ref->{'id'}, name = $ref->{'name'}\n"; } $sth->finish(); # Disconnect from the database. $dbh->disconnect(); =head1 DESCRIPTION B<DBD::mysql> is the Perl5 Database Interface driver for the MySQL database. In other words: DBD::mysql is an interface between the Perl programming language and the MySQL programming API that comes with the MySQL relational database management system. Most functions provided by this programming API are supported. Some rarely used functions are missing, mainly because no-one ever requested them. :-) In what follows we first discuss the use of DBD::mysql, because this is what you will need the most. For installation, see the separate document L<DBD::mysql::INSTALL>. See L</"EXAMPLE"> for a simple example above. From perl you activate the interface with the statement use DBI; After that you can connect to multiple MySQL database servers and send multiple queries to any of them via a simple object oriented interface. Two types of objects are available: database handles and statement handles. Perl returns a database handle to the connect method like so: $dbh = DBI->connect("DBI:mysql:database=$db;host=$host", $user, $password, {RaiseError => 1}); Once you have connected to a database, you can execute SQL statements with: my $query = sprintf("INSERT INTO foo VALUES (%d, %s)", $number, $dbh->quote("name")); $dbh->do($query); See L<DBI> for details on the quote and do methods. An alternative approach is $dbh->do("INSERT INTO foo VALUES (?, ?)", undef, $number, $name); in which case the quote method is executed automatically. See also the bind_param method in L<DBI>. See L</"DATABASE HANDLES"> below for more details on database handles. If you want to retrieve results, you need to create a so-called statement handle with: $sth = $dbh->prepare("SELECT * FROM $table"); $sth->execute(); This statement handle can be used for multiple things. First of all you can retrieve a row of data: my $row = $sth->fetchrow_hashref(); If your table has columns ID and NAME, then $row will be hash ref with keys ID and NAME. See L</"STATEMENT HANDLES"> below for more details on statement handles. But now for a more formal approach: =head2 Class Methods =over =item B<connect> use DBI; $dsn = "DBI:mysql:$database"; $dsn = "DBI:mysql:database=$database;host=$hostname"; $dsn = "DBI:mysql:database=$database;host=$hostname;port=$port"; $dbh = DBI->connect($dsn, $user, $password); The C<database> is not a required attribute, but please note that MySQL has no such thing as a default database. If you don't specify the database at connection time your active database will be null and you'd need to prefix your tables with the database name; i.e. 'SELECT * FROM mydb.mytable'. This is similar to the behavior of the mysql command line client. Also, 'SELECT DATABASE()' will return the current database active for the handle. =over =item host =item port The hostname, if not specified or specified as '' or 'localhost', will default to a MySQL server running on the local machine using the default for the UNIX socket. To connect to a MySQL server on the local machine via TCP, you must specify the loopback IP address (127.0.0.1) as the host. Should the MySQL server be running on a non-standard port number, you may explicitly state the port number to connect to in the C<hostname> argument, by concatenating the I<hostname> and I<port number> together separated by a colon ( C<:> ) character or by using the C<port> argument. To connect to a MySQL server on localhost using TCP/IP, you must specify the hostname as 127.0.0.1 (with the optional port). When connecting to a MySQL Server with IPv6, a bracketed IPv6 address should be used. Example DSN: my $dsn = "DBI:mysql:;host=[1a12:2800:6f2:85::f20:8cf];port=3306"; =item mysql_client_found_rows If TRUE (Default), sets the CLIENT_FOUND_ROWS flag when connecting to MySQL. This causes UPDATE statements to return the number of rows *matched*, not the number of rows actually changed. If you want the number of rows changed in response to an UPDATE statement, specify "mysql_client_found_rows=0" in the DSN. =item mysql_compression If your DSN contains the option "mysql_compression", then this will be used to set the compression algorithms for the connection. If your DSN contains the option "mysql_compression=1", then the compression algorithms will be set to "zlib". This is for backwards compatibility with older versions of DBD::mysql. =item mysql_connect_timeout If your DSN contains the option "mysql_connect_timeout=##", the connect request to the server will timeout if it has not been successful after the given number of seconds. =item mysql_write_timeout If your DSN contains the option "mysql_write_timeout=##", the write operation to the server will timeout if it has not been successful after the given number of seconds. =item mysql_read_timeout If your DSN contains the option "mysql_read_timeout=##", the read operation to the server will timeout if it has not been successful after the given number of seconds. =item mysql_init_command If your DSN contains the option "mysql_init_command=##", then this SQL statement is executed when connecting to the MySQL server. It is automatically re-executed if reconnection occurs. =item mysql_skip_secure_auth This option is for older mysql databases that don't have secure auth set. =item mysql_read_default_file =item mysql_read_default_group These options can be used to read a config file like /etc/my.cnf or ~/.my.cnf. By default MySQL's C client library doesn't use any config files unlike the client programs (mysql, mysqladmin, ...) that do, but outside of the C client library. Thus you need to explicitly request reading a config file, as in $dsn = "DBI:mysql:test;mysql_read_default_file=/home/joe/my.cnf"; $dbh = DBI->connect($dsn, $user, $password) The option mysql_read_default_group can be used to specify the default group in the config file: Usually this is the I<client> group, but see the following example: [client] host=localhost [perl] host=perlhost (Note the order of the entries! The example won't work, if you reverse the [client] and [perl] sections!) If you read this config file, then you'll be typically connected to I<localhost>. However, by using $dsn = "DBI:mysql:test;mysql_read_default_group=perl;" . "mysql_read_default_file=/home/joe/my.cnf"; $dbh = DBI->connect($dsn, $user, $password); you'll be connected to I<perlhost>. Note that if you specify a default group and do not specify a file, then the default config files will all be read. See the documentation of the C function mysql_options() for details. =item mysql_socket It is possible to choose the Unix socket that is used for connecting to the server. This is done, for example, with mysql_socket=/dev/mysql Usually there's no need for this option, unless you are using another location for the socket than that built into the client. =item mysql_ssl A true value turns on the CLIENT_SSL flag when connecting to the MySQL server and enforce SSL encryption. A false value (which is default) disable SSL encryption with the MySQL server. When enabling SSL encryption you should set also other SSL options, at least mysql_ssl_ca_file or mysql_ssl_ca_path. mysql_ssl=1 mysql_ssl_verify_server_cert=1 mysql_ssl_ca_file=/path/to/ca_cert.pem This means that your communication with the server will be encrypted. Please note that this can only work if you enabled SSL when compiling DBD::mysql; this is the default starting version 4.034. See L<DBD::mysql::INSTALL> for more details. =item mysql_ssl_ca_file The path to a file in PEM format that contains a list of trusted SSL certificate authorities. When set MySQL server certificate is checked that it is signed by some CA certificate in the list. Common Name value is not verified unless C<mysql_ssl_verify_server_cert> is enabled. =item mysql_ssl_ca_path The path to a directory that contains trusted SSL certificate authority certificates in PEM format. When set MySQL server certificate is checked that it is signed by some CA certificate in the list. Common Name value is not verified unless C<mysql_ssl_verify_server_cert> is enabled. Please note that this option is supported only if your MySQL client was compiled with OpenSSL library, and not with default yaSSL library. =item mysql_ssl_verify_server_cert Checks the server's Common Name value in the certificate that the server sends to the client. The client verifies that name against the host name the client uses for connecting to the server, and the connection fails if there is a mismatch. For encrypted connections, this option helps prevent man-in-the-middle attacks. Verification of the host name is disabled by default. =item mysql_ssl_client_key The name of the SSL key file in PEM format to use for establishing a secure connection. =item mysql_ssl_client_cert The name of the SSL certificate file in PEM format to use for establishing a secure connection. =item mysql_ssl_cipher A list of permissible ciphers to use for connection encryption. If no cipher in the list is supported, encrypted connections will not work. mysql_ssl_cipher=AES128-SHA mysql_ssl_cipher=DHE-RSA-AES256-SHA:AES128-SHA =item mysql_ssl_optional Setting C<mysql_ssl_optional> to true disables strict SSL enforcement and makes SSL connection optional. This option opens security hole for man-in-the-middle attacks. Default value is false which means that C<mysql_ssl> set to true enforce SSL encryption. This option was introduced in 4.043 version of DBD::mysql. Due to L<The BACKRONYM|http://backronym.fail/> and L<The Riddle|http://riddle.link/> vulnerabilities in libmysqlclient library, enforcement of SSL encryption was not possbile and therefore C<mysql_ssl_optional=1> was effectively set for all DBD::mysql versions prior to 4.043. Starting with 4.043, DBD::mysql with C<mysql_ssl=1> could refuse connection to MySQL server if underlaying libmysqlclient library is vulnerable. Option C<mysql_ssl_optional> can be used to make SSL connection vulnerable. =item mysql_server_pubkey Path to the RSA public key of the server. This is used for the sha256_password and caching_sha2_password authentication plugins. =item mysql_get_server_pubkey Setting C<mysql_get_server_pubkey> to true requests the public RSA key of the server. =item mysql_local_infile The LOCAL capability for LOAD DATA may be disabled in the MySQL client library by default. If your DSN contains the option "mysql_local_infile=1", LOAD DATA LOCAL will be enabled. (However, this option is *ineffective* if the server has also been configured to disallow LOCAL.) =item mysql_multi_statements Support for multiple statements separated by a semicolon (;) may be enabled by using this option. Enabling this option may cause problems if server-side prepared statements are also enabled. =item mysql_server_prepare This option is used to enable server side prepared statements. To use server side prepared statements, all you need to do is set the variable mysql_server_prepare in the connect: $dbh = DBI->connect( "DBI:mysql:database=test;host=localhost;mysql_server_prepare=1", "", "", { RaiseError => 1, AutoCommit => 1 } ); or: $dbh = DBI->connect( "DBI:mysql:database=test;host=localhost", "", "", { RaiseError => 1, AutoCommit => 1, mysql_server_prepare => 1 } ); There are many benefits to using server side prepare statements, mostly if you are performing many inserts because of that fact that a single statement is prepared to accept multiple insert values. To make sure that the 'make test' step tests whether server prepare works, you just need to export the env variable MYSQL_SERVER_PREPARE: export MYSQL_SERVER_PREPARE=1 Please note that mysql server cannot prepare or execute some prepared statements. In this case DBD::mysql fallbacks to normal non-prepared statement and tries again. =item mysql_server_prepare_disable_fallback This option disable fallback to normal non-prepared statement when mysql server does not support execution of current statement as prepared. Useful when you want to be sure that statement is going to be executed as server side prepared. Error message and code in case of failure is propagated back to DBI. =item mysql_conn_attrs The option <mysql_conn_attrs> is a hash of attribute names and values which can be used to send custom connection attributes to the server. Some attributes like '_os', '_platform', '_client_name' and '_client_version' are added by libmysqlclient and 'program_name' is added by DBD::mysql. You can then later read these attributes from the performance schema tables which can be quite helpful for profiling your database or creating statistics. my $dbh= DBI->connect($dsn, $user, $password, { AutoCommit => 0, mysql_conn_attrs => { foo => 'bar', wiz => 'bang' }, }); Now you can select the results from the performance schema tables. You can do this in the same session, but also afterwards. It can be very useful to answer questions like 'which script sent this query?'. my $results = $dbh->selectall_hashref( 'SELECT * FROM performance_schema.session_connect_attrs', 'ATTR_NAME' ); This returns: $result = { 'foo' => { 'ATTR_VALUE' => 'bar', 'PROCESSLIST_ID' => '3', 'ATTR_NAME' => 'foo', 'ORDINAL_POSITION' => '6' }, 'wiz' => { 'ATTR_VALUE' => 'bang', 'PROCESSLIST_ID' => '3', 'ATTR_NAME' => 'wiz', 'ORDINAL_POSITION' => '3' }, 'program_name' => { 'ATTR_VALUE' => './foo.pl', 'PROCESSLIST_ID' => '3', 'ATTR_NAME' => 'program_name', 'ORDINAL_POSITION' => '5' }, '_client_name' => { 'ATTR_VALUE' => 'libmysql', 'PROCESSLIST_ID' => '3', 'ATTR_NAME' => '_client_name', 'ORDINAL_POSITION' => '1' }, '_client_version' => { 'ATTR_VALUE' => '5.6.24', 'PROCESSLIST_ID' => '3', 'ATTR_NAME' => '_client_version', 'ORDINAL_POSITION' => '7' }, '_os' => { 'ATTR_VALUE' => 'osx10.8', 'PROCESSLIST_ID' => '3', 'ATTR_NAME' => '_os', 'ORDINAL_POSITION' => '0' }, '_pid' => { 'ATTR_VALUE' => '59860', 'PROCESSLIST_ID' => '3', 'ATTR_NAME' => '_pid', 'ORDINAL_POSITION' => '2' }, '_platform' => { 'ATTR_VALUE' => 'x86_64', 'PROCESSLIST_ID' => '3', 'ATTR_NAME' => '_platform', 'ORDINAL_POSITION' => '4' } }; =back =back =head1 DATABASE HANDLES The DBD::mysql driver supports the following attributes of database handles (read only): $errno = $dbh->{'mysql_errno'}; $error = $dbh->{'mysql_error'}; $info = $dbh->{'mysql_hostinfo'}; $info = $dbh->{'mysql_info'}; $insertid = $dbh->{'mysql_insertid'}; $info = $dbh->{'mysql_protoinfo'}; $info = $dbh->{'mysql_serverinfo'}; $info = $dbh->{'mysql_stat'}; $threadId = $dbh->{'mysql_thread_id'}; These correspond to mysql_errno(), mysql_error(), mysql_get_host_info(), mysql_info(), mysql_insert_id(), mysql_get_proto_info(), mysql_get_server_info(), mysql_stat() and mysql_thread_id(), respectively. =over 2 =item mysql_clientinfo List information of the MySQL client library that DBD::mysql was built against: print "$dbh->{mysql_clientinfo}\n"; 8.3.0 =item mysql_clientversion print "$dbh->{mysql_clientversion}\n"; 80300 =item mysql_serverversion print "$dbh->{mysql_serverversion}\n"; 80300 =item mysql_dbd_stats $info_hashref = $dbh->{mysql_dbd_stats}; DBD::mysql keeps track of some statistics in the mysql_dbd_stats attribute. The following stats are being maintained: =over 8 =item auto_reconnects_ok The number of times that DBD::mysql successfully reconnected to the mysql server. =item auto_reconnects_failed The number of times that DBD::mysql tried to reconnect to mysql but failed. =back =back The DBD::mysql driver also supports the following attributes of database handles (read/write): =over =item mysql_auto_reconnect This attribute determines whether DBD::mysql will automatically reconnect to mysql if the connection be lost. This feature defaults to off; however, if either the GATEWAY_INTERFACE or MOD_PERL environment variable is set, DBD::mysql will turn mysql_auto_reconnect on. Setting mysql_auto_reconnect to on is not advised if 'lock tables' is used because if DBD::mysql reconnect to mysql all table locks will be lost. This attribute is ignored when AutoCommit is turned off, and when AutoCommit is turned off, DBD::mysql will not automatically reconnect to the server. It is also possible to set the default value of the C<mysql_auto_reconnect> attribute for the $dbh by passing it in the C<\%attr> hash for C<DBI->connect>. $dbh->{mysql_auto_reconnect} = 1; or my $dbh = DBI->connect($dsn, $user, $password, { mysql_auto_reconnect => 1, }); Note that if you are using a module or framework that performs reconnections for you (for example L<DBIx::Connector> in fixup mode), this value must be set to 0. =item mysql_use_result This attribute forces the driver to use mysql_use_result rather than mysql_store_result. The former is faster and less memory consuming, but tends to block other processes. mysql_store_result is the default due to that fact storing the result is expected behavior with most applications. It is possible to set the default value of the C<mysql_use_result> attribute for the $dbh via the DSN: $dbh = DBI->connect("DBI:mysql:test;mysql_use_result=1", "root", ""); You can also set it after creation of the database handle: $dbh->{mysql_use_result} = 0; # disable $dbh->{mysql_use_result} = 1; # enable You can also set or unset the C<mysql_use_result> setting on your statement handle, when creating the statement handle or after it has been created. See L</"STATEMENT HANDLES">. =item mysql_enable_utf8 This attribute determines whether DBD::mysql should assume strings stored in the database are utf8. This feature defaults to off. When set, a data retrieved from a textual column type (char, varchar, etc) will have the UTF-8 flag turned on if necessary. This enables character semantics on that string. You will also need to ensure that your database / table / column is configured to use UTF8. See for more information the chapter on character set support in the MySQL manual: L<http://dev.mysql.com/doc/refman/8.0/en/charset.html> Additionally, turning on this flag tells MySQL that incoming data should be treated as UTF-8. This will only take effect if used as part of the call to connect(). If you turn the flag on after connecting, you will need to issue the command C<SET NAMES utf8> to get the same effect. This flag's implementation suffers the "Unicode Bug" on passed statements and input bind parameters, and cannot be fixed for historical reasons. In order to pass strings with Unicode characters consistently through DBD::mysql, you can use a "hack" workaround of calling the C<utf8::upgrade()> function on scalars immediately before passing them to DBD::mysql. Calling the C<utf8::upgrade()> function has absolutely no effect on (correctly written) Perl code, but forces DBD::mysql to interpret it correctly as text data to be encoded. In the same way, binary (byte) data can be passed through DBD::mysql without being encoded as text data by calling the C<utf8::downgrade()> function (it dies on wide Unicode strings with codepoints above U+FF). See the following example: # check that last name contains LATIN CAPITAL LETTER O WITH STROKE (U+D8) my $statement = "SELECT * FROM users WHERE last_name LIKE '%\x{D8}%' AND first_name = ? AND data = ?"; my $wide_string_param = "Andr\x{E9}"; # Andre with LATIN SMALL LETTER E WITH ACUTE (U+E9) my $byte_param = "\x{D8}\x{A0}\x{39}\x{F8}"; # some bytes (binary data) my $dbh = DBI->connect('DBI:mysql:database', 'username', 'pass', { mysql_enable_utf8mb4 => 1 }); utf8::upgrade($statement); # UTF-8 fix for DBD::mysql my $sth = $dbh->prepare($statement); utf8::upgrade($wide_string_param); # UTF-8 fix for DBD::mysql $sth->bind_param(1, $wide_string_param); utf8::downgrade($byte_param); # byte fix for DBD::mysql $sth->bind_param(2, $byte_param, DBI::SQL_BINARY); # set correct binary type $sth->execute(); my $output = $sth->fetchall_arrayref(); # returned data in $output reference should be already UTF-8 decoded as appropriate =item mysql_enable_utf8mb4 This is similar to mysql_enable_utf8, but is capable of handling 4-byte UTF-8 characters. =item mysql_bind_type_guessing This attribute causes the driver (emulated prepare statements) to attempt to guess if a value being bound is a numeric value, and if so, doesn't quote the value. This was created by Dragonchild and is one way to deal with the performance issue of using quotes in a statement that is inserting or updating a large numeric value. This was previously called C<unsafe_bind_type_guessing> because it is experimental. I have successfully run the full test suite with this option turned on, the name can now be simply C<mysql_bind_type_guessing>. CAVEAT: Even though you can insert an integer value into a character column, if this column is indexed, if you query that column with the integer value not being quoted, it will not use the index: mysql> explain select * from test where value0 = '3' \G *************************** 1. row *************************** id: 1 select_type: SIMPLE table: test type: ref possible_keys: value0 key: value0 key_len: 13 ref: const rows: 1 Extra: Using index condition 1 row in set (0.00 sec) mysql> explain select * from test where value0 = 3 -> \G *************************** 1. row *************************** id: 1 select_type: SIMPLE table: test type: ALL possible_keys: value0 key: NULL key_len: NULL ref: NULL rows: 6 Extra: Using where 1 row in set (0.00 sec) See bug: https://rt.cpan.org/Ticket/Display.html?id=43822 C<mysql_bind_type_guessing> can be turned on via - through DSN my $dbh= DBI->connect('DBI:mysql:test', 'username', 'pass', { mysql_bind_type_guessing => 1}) - OR after handle creation $dbh->{mysql_bind_type_guessing} = 1; =item mysql_bind_comment_placeholders This attribute causes the driver (emulated prepare statements) will cause any placeholders in comments to be bound. This is not correct prepared statement behavior, but some developers have come to depend on this behavior, so I have made it available in 4.015 =item mysql_no_autocommit_cmd This attribute causes the driver to not issue 'set autocommit' either through explicit or using mysql_autocommit(). This is particularly useful in the case of using MySQL Proxy. See the bug report: https://rt.cpan.org/Public/Bug/Display.html?id=46308 C<mysql_no_autocommit_cmd> can be turned on when creating the database handle: my $dbh = DBI->connect('DBI:mysql:test', 'username', 'pass', { mysql_no_autocommit_cmd => 1}); or using an existing database handle: $dbh->{mysql_no_autocommit_cmd} = 1; =item ping This can be used to send a ping to the server. $rc = $dbh->ping(); =back =head1 STATEMENT HANDLES The statement handles of DBD::mysql support a number of attributes. You access these by using, for example, my $numFields = $sth->{NUM_OF_FIELDS}; Note, that most attributes are valid only after a successful I<execute>. An C<undef> value will returned otherwise. The most important exception is the C<mysql_use_result> attribute, which forces the driver to use mysql_use_result rather than mysql_store_result. The former is faster and less memory consuming, but tends to block other processes. (That's why mysql_store_result is the default.) To set the C<mysql_use_result> attribute, use either of the following: my $sth = $dbh->prepare("QUERY", { mysql_use_result => 1}); or my $sth = $dbh->prepare($sql); $sth->{mysql_use_result} = 1; Column dependent attributes, for example I<NAME>, the column names, are returned as a reference to an array. The array indices are corresponding to the indices of the arrays returned by I<fetchrow> and similar methods. For example the following code will print a header of table names together with all rows: my $sth = $dbh->prepare("SELECT * FROM $table") || die "Error:" . $dbh->errstr . "\n"; $sth->execute || die "Error:" . $sth->errstr . "\n"; my $names = $sth->{NAME}; my $numFields = $sth->{'NUM_OF_FIELDS'} - 1; for my $i ( 0..$numFields ) { printf("%s%s", $i ? "," : "", $$names[$i]); } print "\n"; while (my $ref = $sth->fetchrow_arrayref) { for my $i ( 0..$numFields ) { printf("%s%s", $i ? "," : "", $$ref[$i]); } print "\n"; } For portable applications you should restrict yourself to attributes with capitalized or mixed case names. Uppercase attribute names are in the statement handle interface described by L<DBI>, while lower case attribute names are private to DBD::mysql. The attribute list includes: =over =item NAME A reference to an array of column names, as per DBI docs. =item NULLABLE A reference to an array of boolean values; TRUE indicates that this column may contain NULL's. =item NUM_OF_FIELDS Number of fields returned by a I<SELECT> or I<LISTFIELDS> statement. You may use this for checking whether a statement returned a result: A zero value indicates a non-SELECT statement like I<INSERT>, I<DELETE> or I<UPDATE>. =item TYPE A reference to an array of column types. The engine's native column types are mapped to portable types like DBI::SQL_INTEGER() or DBI::SQL_VARCHAR(), as good as possible. Not all native types have a meaningful equivalent, for example DBD::mysql::FIELD_TYPE_INTERVAL is mapped to DBI::SQL_VARCHAR(). If you need the native column types, use I<mysql_type>. See below. =item ChopBlanks this attribute determines whether a I<fetchrow> will chop preceding and trailing blanks off the column values. Chopping blanks does not have impact on the I<max_length> attribute. =item ParamValues This attribute is supported as described in the DBI documentation. It returns a hashref, the keys of which are the 'names' of the placeholders: integers starting at 1. It returns an empty hashref if the statement has no placeholders. The values for these keys are initially undef; they are populated with C<bind_param>, or when C<execute> method is called with parameters. (Supplying the parameter values in the arguments to C<execute> will override any previously bound values.) After execution, it is possible to use C<bind_param> to change a single parameter value and C<execute> the statement again, with other values unchanged. The attribute remains properly populated after the C<finish> method is called, with the values from the last execution. =item mysql_gtids Returns GTID(s) if GTID session tracking is ensabled in the server via session_track_gtids. =item mysql_insertid If the statement you executed performs an INSERT, and there is an AUTO_INCREMENT column in the table you inserted in, this attribute holds the value stored into the AUTO_INCREMENT column, if that value is automatically generated, by storing NULL or 0 or was specified as an explicit value. Typically, you'd access the value via $sth->{mysql_insertid}. The value can also be accessed via $dbh->{mysql_insertid} but this can easily produce incorrect results in case one database handle is shared. =item mysql_is_blob Reference to an array of boolean values; TRUE indicates, that the respective column is a blob. This attribute is valid for MySQL only. =item mysql_is_key Reference to an array of boolean values; TRUE indicates, that the respective column is a key. This is valid for MySQL only. =item mysql_is_num Reference to an array of boolean values; TRUE indicates, that the respective column contains numeric values. =item mysql_is_pri_key Reference to an array of boolean values; TRUE indicates, that the respective column is a primary key. =item mysql_is_auto_increment Reference to an array of boolean values; TRUE indicates that the respective column is an AUTO_INCREMENT column. This is only valid for MySQL. =item mysql_length =item mysql_max_length A reference to an array of maximum column sizes. The I<max_length> is the maximum physically present in the result table, I<length> gives the theoretically possible maximum. I<max_length> is valid for MySQL only. =item mysql_table A reference to an array of table names, useful in a I<JOIN> result. =item mysql_type A reference to an array of MySQL's native column types, for example DBD::mysql::FIELD_TYPE_SHORT() or DBD::mysql::FIELD_TYPE_STRING(). Use the I<TYPE> attribute, if you want portable types like DBI::SQL_SMALLINT() or DBI::SQL_VARCHAR(). =item mysql_type_name Similar to mysql, but type names and not numbers are returned. Whenever possible, the ANSI SQL name is preferred. =item mysql_warning_count The number of warnings generated during execution of the SQL statement. This attribute is available on both statement handles and database handles. =back =head1 TRANSACTION SUPPORT The transaction support works as follows: =over =item * By default AutoCommit mode is on, following the DBI specifications. =item * If you execute $dbh->{AutoCommit} = 0; or $dbh->{AutoCommit} = 1; then the driver will set the MySQL server variable autocommit to 0 or 1, respectively. Switching from 0 to 1 will also issue a COMMIT, following the DBI specifications. =item * The methods $dbh->rollback(); $dbh->commit(); will issue the commands ROLLBACK and COMMIT, respectively. A ROLLBACK will also be issued if AutoCommit mode is off and the database handles DESTROY method is called. Again, this is following the DBI specifications. =back Given the above, you should note the following: =over =item * You should never change the server variable autocommit manually, unless you are ignoring DBI's transaction support. =item * Switching AutoCommit mode from on to off or vice versa may fail. You should always check for errors when changing AutoCommit mode. The suggested way of doing so is using the DBI flag RaiseError. If you don't like RaiseError, you have to use code like the following: $dbh->{AutoCommit} = 0; if ($dbh->{AutoCommit}) { # An error occurred! } =item * If you detect an error while changing the AutoCommit mode, you should no longer use the database handle. In other words, you should disconnect and reconnect again, because the transaction mode is unpredictable. Alternatively you may verify the transaction mode by checking the value of the server variable autocommit. However, such behaviour isn't portable. =item * DBD::mysql has a "reconnect" feature that handles the so-called MySQL "morning bug": If the server has disconnected, most probably due to a timeout, then by default the driver will reconnect and attempt to execute the same SQL statement again. However, this behaviour is disabled when AutoCommit is off: Otherwise the transaction state would be completely unpredictable after a reconnect. =item * The "reconnect" feature of DBD::mysql can be toggled by using the L<mysql_auto_reconnect> attribute. This behaviour should be turned off in code that uses LOCK TABLE because if the database server time out and DBD::mysql reconnect, table locks will be lost without any indication of such loss. =back =head1 MULTIPLE RESULT SETS DBD::mysql supports multiple result sets, thanks to Guy Harrison! The basic usage of multiple result sets is do { while (@row = $sth->fetchrow_array()) { do stuff; } } while ($sth->more_results) An example would be: $dbh->do("drop procedure if exists someproc") or print $DBI::errstr; $dbh->do("create procedure someproc() deterministic begin declare a,b,c,d int; set a=1; set b=2; set c=3; set d=4; select a, b, c, d; select d, c, b, a; select b, a, c, d; select c, b, d, a; end") or print $DBI::errstr; $sth=$dbh->prepare('call someproc()') || die $DBI::err.": ".$DBI::errstr; $sth->execute || die DBI::err.": ".$DBI::errstr; $rowset=0; do { print "\nRowset ".++$i."\n---------------------------------------\n\n"; foreach $colno (0..$sth->{NUM_OF_FIELDS}-1) { print $sth->{NAME}->[$colno]."\t"; } print "\n"; while (@row= $sth->fetchrow_array()) { foreach $field (0..$#row) { print $row[$field]."\t"; } print "\n"; } } until (!$sth->more_results) =head2 Issues with multiple result sets Please be aware there could be issues if your result sets are "jagged", meaning the number of columns of your results vary. Varying numbers of columns could result in your script crashing. =head1 MULTITHREADING The multithreading capabilities of DBD::mysql depend completely on the underlying C libraries. The modules are working with handle data only, no global variables are accessed or (to the best of my knowledge) thread unsafe functions are called. Thus DBD::mysql is believed to be completely thread safe, if the C libraries are thread safe and you don't share handles among threads. The obvious question is: Are the C libraries thread safe? In the case of MySQL the answer is yes, since MySQL 5.5 it is. =head1 ASYNCHRONOUS QUERIES You can make a single asynchronous query per MySQL connection; this allows you to submit a long-running query to the server and have an event loop inform you when it's ready. An asynchronous query is started by either setting the 'async' attribute to a true value in the L<DBI/do> method, or in the L<DBI/prepare> method. Statements created with 'async' set to true in prepare always run their queries asynchronously when L<DBI/execute> is called. The driver also offers three additional methods: C<mysql_async_result>, C<mysql_async_ready>, and C<mysql_fd>. C<mysql_async_result> returns what do or execute would have; that is, the number of rows affected. C<mysql_async_ready> returns true if C<mysql_async_result> will not block, and zero otherwise. They both return C<undef> if that handle was not created with 'async' set to true or if an asynchronous query was not started yet. C<mysql_fd> returns the file descriptor number for the MySQL connection; you can use this in an event loop. Here's an example of how to use the asynchronous query interface: use feature 'say'; $dbh->do('SELECT SLEEP(10)', { async => 1 }); until($dbh->mysql_async_ready) { say 'not ready yet!'; sleep 1; } my $rows = $dbh->mysql_async_result; =head1 INSTALLATION See L<DBD::mysql::INSTALL>. =head1 AUTHORS Originally, there was a non-DBI driver, Mysql, which was much like PHP drivers such as mysql and mysqli. The B<Mysql> module was originally written by Andreas König <koenig@kulturbox.de> who still, to this day, contributes patches to DBD::mysql. An emulated version of Mysql was provided to DBD::mysql from Jochen Wiedmann, but eventually deprecated as it was another bundle of code to maintain. The first incarnation of DBD::mysql was developed by Alligator Descartes, who was also aided and abetted by Gary Shea, Andreas König and Tim Bunce. The current incarnation of B<DBD::mysql> was written by Jochen Wiedmann, then numerous changes and bug-fixes were added by Rudy Lippan. Next, prepared statement support was added by Patrick Galbraith and Alexy Stroganov (who also solely added embedded server support). For the past nine years DBD::mysql has been maintained by Patrick Galbraith (I<patg@patg.net>), and recently with the great help of Michiel Beijen (I<michiel.beijen@gmail.com>), along with the entire community of Perl developers who keep sending patches to help continue improving DBD::mysql =head1 CONTRIBUTIONS Anyone who desires to contribute to this project is encouraged to do so. Currently, the source code for this project can be found at Github: L<https://github.com/perl5-dbi/DBD-mysql/> Either fork this repository and produce a branch with your changeset that the maintainer can merge to his tree, or create a diff with git. The maintainer is more than glad to take contributions from the community as many features and fixes from DBD::mysql have come from the community. =head1 COPYRIGHT This module is =over =item * Large Portions Copyright (c) 2004-2013 Patrick Galbraith =item * Large Portions Copyright (c) 2004-2006 Alexey Stroganov =item * Large Portions Copyright (c) 2003-2005 Rudolf Lippan =item * Large Portions Copyright (c) 1997-2003 Jochen Wiedmann, with code portions =item * Copyright (c)1994-1997 their original authors =back =head1 LICENSE This module is released under the same license as Perl itself. See L<http://www.perl.com/perl/misc/Artistic.html> for details. =head1 MAILING LIST SUPPORT This module is maintained and supported on a mailing list, dbi-users. To subscribe to this list, send an email to dbi-users-subscribe@perl.org Mailing list archives are at L<http://groups.google.com/group/perl.dbi.users?hl=en&lr=> =head1 ADDITIONAL DBI INFORMATION Additional information on the DBI project can be found on the World Wide Web at the following URL: L<http://dbi.perl.org> where documentation, pointers to the mailing lists and mailing list archives and pointers to the most current versions of the modules can be used. Information on the DBI interface itself can be gained by typing: perldoc DBI Information on DBD::mysql specifically can be gained by typing: perldoc DBD::mysql (this will display the document you're currently reading) =head1 BUG REPORTING, ENHANCEMENT/FEATURE REQUESTS Please report bugs, including all the information needed such as DBD::mysql version, MySQL version, OS type/version, etc to this link: L<https://github.com/perl5-dbi/DBD-mysql/issues/new/choose> Note: until recently, MySQL/Sun/Oracle responded to bugs and assisted in fixing bugs which many thanks should be given for their help! This driver is outside the realm of the numerous components they support, and the maintainer and community solely support DBD::mysql =cut 5.32/DBD/mysql/INSTALL.pod 0000444 00000055567 15125513451 0010525 0 ustar 00 =encoding utf8 =head1 NAME DBD::mysql::INSTALL - How to install and configure DBD::mysql =head1 SYNOPSIS perl Makefile.PL [options] make make test make install =head1 DESCRIPTION This document describes the installation and configuration of DBD::mysql, the Perl DBI driver for the MySQL database. Before reading on, make sure that you have the prerequisites available: Perl, MySQL and DBI. For details see the separate section L</PREREQUISITES>. Depending on your version of Perl, it might be possible to use a binary distribution of DBD::mysql. If possible, this is recommended. Otherwise you need to install from the sources. If so, you will definitely need a C compiler. Installation from binaries and sources are both described in separate sections. L</BINARY INSTALLATION>. L</SOURCE INSTALLATION>. Finally, if you encounter any problems, do not forget to read the section on known problems L</KNOWN PROBLEMS>. If that doesn't help, you should check the section on L</SUPPORT>. =head1 PREREQUISITES =over =item Perl Preferably a version of Perl, that comes preconfigured with your system. For example, all Linux and FreeBSD distributions come with Perl. For Windows, use L<ActivePerl|https://www.activestate.com/activeperl> or L<Strawberry Perl|http://www.strawberryperl.com>. =item MySQL You need not install the actual MySQL database server, the client files and the development files are sufficient. For example, Fedora Linux distribution comes with RPM files (using DNF) B<mysql> and B<mysql-server> (use "dnf search" to find exact package names). These are sufficient, if the MySQL server is located on a foreign machine. You may also create client files by compiling from the MySQL source distribution and using cmake -DWITHOUT_SERVER=ON If you are using Windows and need to compile from sources (which is only the case if you are not using ActivePerl or Strawberry Perl), then you must ensure that the header and library files are installed. This may require choosing a "Custom installation" and selecting the appropriate option when running the MySQL setup program. =item DBI DBD::mysql is a DBI driver, hence you need DBI. It is available from the same source where you got the DBD::mysql distribution from. =item C compiler A C compiler is only required if you install from source. In most cases there are binary distributions of DBD::mysql available. However, if you need a C compiler, make sure, that it is the same C compiler that was used for compiling Perl and MySQL! Otherwise you will almost definitely encounter problems because of differences in the underlying C runtime libraries. In the worst case, this might mean to compile Perl and MySQL yourself. But believe me, experience shows that a lot of problems are fixed this way. =item Gzip libraries Late versions of MySQL come with support for compression. Thus it B<may> be required that you have install an RPM package like libz-devel, libgz-devel or something similar. =back =head1 BINARY INSTALLATION Binary installation is possible in the most cases, depending on your system. =head2 Windows =head3 Strawberry Perl Strawberry Perl comes bundled with DBD::mysql and the needed client libraries. =head3 ActiveState Perl ActivePerl offers a PPM archive of DBD::mysql. All you need to do is typing in a cmd.exe window: ppm install DBD-mysql This will fetch the module via HTTP and install them. If you need to use a WWW proxy server, the environment variable HTTP_proxy must be set: set HTTP_proxy=http://myproxy.example.com:8080/ ppm install DBD-mysql Of course you need to replace the host name C<myproxy.example.com> and the port number C<8080> with your local values. If the above procedure doesn't work, please upgrade to the latest version of ActivePerl. ActiveState has a policy where it only provides access free-of-charge for the PPM mirrors of the last few stable Perl releases. If you have an older perl, you'd either need to upgrade your perl or contact ActiveState about a subscription. =head2 Red Hat Enterprise Linux (RHEL), CentOS and Fedora Red Hat Enterprise Linux, its community derivatives such as CentOS, and Fedora come with MySQL and DBD::mysql. Use the following command to install DBD::mysql: dnf install "perl(DBD::mysql)" Previous name of installation command was C<yum>. =head2 Debian and Ubuntu On Debian, Ubuntu and derivatives you can install DBD::mysql from the repositories with the following command: sudo apt-get install libdbd-mysql-perl =head2 SLES and openSUSE On SUSE Linux Enterprise and the community version openSUSE, you can install DBD::mysql from the repositories with the following command: zypper install perl-DBD-mysql =head2 Other systems In the case of other Linux or FreeBSD distributions it is very likely that all you need comes with your distribution. I just cannot give you names, as I am not using these systems. Please let me know if you find the files in your favorite Linux or FreeBSD distribution so that I can extend the above list. =head1 SOURCE INSTALLATION So you need to install from sources. If you are lucky, the Perl module C<CPAN> will do all for you, thanks to the excellent work of Andreas König. Otherwise you will need to do a manual installation. All of these installation types have their own section: L</CPAN installation>, L</Manual installation> and L</Configuration>. The DBD::mysql Makefile.PL needs to know where to find your MySQL installation. This may be achieved using command line switches (see L</Configuration>) or automatically using the mysql_config binary which comes with most MySQL distributions. If your MySQL distribution contains mysql_config the easiest method is to ensure this binary is on your path. Typically, this is the case if you've installed the mysql library from your systems' package manager. e.g. PATH=$PATH:/usr/local/mysql/bin export PATH As stated, to compile DBD::mysql you'll need a C compiler. This should be the same compiler as the one used to build perl AND the mysql client libraries. If you're on linux, this is most typically the case and you need not worry. If you're on UNIX systems, you might want to pay attention. Also you'll need to get the MySQL client and development headers on your system. The easiest is to get these from your package manager. To run the tests that ship with the module, you'll need access to a running MySQL server. This can be running on localhost, but it can also be on a remote machine. On Fedora the process is as follows. In this example we install and start a local server for running the tests against. dnf -y install make gcc mysql-devel mysql-libs mysql-server mysql dnf -y install "perl(Test::Deep)" "perl(Test::More)" "perl(Test::Pod)" \ "perl(bigint)" "perl(DBI)" "perl(ExtUtils::MakeMaker)" \ "perl(Devel::CheckLib)" systemctl start mysqld.service =head2 Environment Variables For ease of use, you can set environment variables for DBD::mysql installation. You can set any or all of the options, and export them by putting them in your .bashrc or the like: export DBD_MYSQL_CFLAGS=-I/usr/local/mysql/include/mysql export DBD_MYSQL_LIBS="-L/usr/local/mysql/lib/mysql -lmysqlclient" export DBD_MYSQL_CONFIG=mysql_config export DBD_MYSQL_NOCATCHSTDERR=0 export DBD_MYSQL_NOFOUNDROWS=0 export DBD_MYSQL_TESTDB=test export DBD_MYSQL_TESTHOST=localhost export DBD_MYSQL_TESTPASSWORD=s3kr1+ export DBD_MYSQL_TESTPORT=3306 export DBD_MYSQL_TESTUSER=me The most useful may be the host, database, port, socket, user, and password. Installation will first look to your mysql_config, and then your environment variables, and then it will guess with intelligent defaults. =head2 CPAN installation Installation of DBD::mysql can be incredibly easy: cpan DBD::mysql Please note that this will only work if the prerequisites are fulfilled, which means you have a C-compiler installed, and you have the development headers and mysql client libraries available on your system. If you are using the CPAN module for the first time, just answer the questions by accepting the defaults which are fine in most cases. If you cannot get the CPAN module working, you might try manual installation. If installation with CPAN fails because the your local settings have been guessed wrong, you need to ensure MySQL's mysql_config is on your path (see L</SOURCE INSTALLATION>) or alternatively create a script called C<mysql_config>. This is described in more details later. L</Configuration>. =head2 Manual installation For a manual installation you need to fetch the DBD::mysql source distribution. The latest version is always available from https://metacpan.org/module/DBD::mysql The name is typically something like DBD-mysql-4.025.tar.gz The archive needs to be extracted. On Windows you may use a tool like 7-zip, on *nix you type tar xf DBD-mysql-4.025.tar.gz This will create a subdirectory DBD-mysql-4.025. Enter this subdirectory and type perl Makefile.PL make make test (On Windows you may need to replace "make" with "dmake" or "nmake".) If the tests seem to look fine, you may continue with make install If the compilation (make) or tests fail, you might need to configure some settings. For example you might choose a different database, the C compiler or the linker might need some flags. L</Configuration>. L</Compiler flags>. L</Linker flags>. For Cygwin there is a special section below. L</Cygwin>. =head2 Configuration The install script "Makefile.PL" can be configured via a lot of switches. All switches can be used on the command line. For example, the test database: perl Makefile.PL --testdb=<db> If you do not like configuring these switches on the command line, you may alternatively create a script called C<mysql_config>. This is described later on. Available switches are: =over =item testdb Name of the test database, defaults to B<test>. =item testuser Name of the test user, defaults to empty. If the name is empty, then the currently logged in users name will be used. =item testpassword Password of the test user, defaults to empty. =item testhost Host name or IP number of the test database; defaults to localhost. =item testport Port number of the test database =item testsocket Socket for connecting to the test database =item ps-protcol=1 or 0 Whether to run the test suite using server prepared statements or driver emulated prepared statements. ps-protocol=1 means use server prepare, ps-protocol=0 means driver emulated. =item cflags This is a list of flags that you want to give to the C compiler. The most important flag is the location of the MySQL header files. For example, on Red Hat Linux the header files are in /usr/include/mysql and you might try -I/usr/include/mysql On Windows the header files may be in C:\mysql\include and you might try -IC:\mysql\include The default flags are determined by running mysql_config --cflags More details on the C compiler flags can be found in the following section. L</Compiler flags>. =item libs This is a list of flags that you want to give to the linker or loader. The most important flags are the locations and names of additional libraries. For example, on Red Hat Linux your MySQL client libraries are in /usr/lib/mysql and you might try -L/usr/lib/mysql -lmysqlclient -lz On Windows the libraries may be in C:\mysql\lib and -LC:\mysql\lib -lmysqlclient might be a good choice. The default flags are determined by running mysql_config --libs More details on the linker flags can be found in a separate section. L<Linker flags>. =back If a switch is not present on the command line, then the script C<mysql_config> will be executed. This script comes as part of the MySQL distribution. For example, to determine the C compiler flags, we are executing mysql_config --cflags mysql_config --libs If you want to configure your own settings for database name, database user and so on, then you have to create a script with the same name, that replies =head2 Compiler flags Note: the following info about compiler and linker flags, you shouldn't have to use these options because Makefile.PL is pretty good at utilizing mysql_config to get the flags that you need for a successful compile. It is typically not so difficult to determine the appropriate flags for the C compiler. The linker flags, which you find in the next section, are another story. The determination of the C compiler flags is usually left to a configuration script called F<mysql_config>, which can be invoked with mysql_config --cflags When doing so, it will emit a line with suggested C compiler flags, for example like this: -L/usr/include/mysql The C compiler must find some header files. Header files have the extension C<.h>. MySQL header files are, for example, F<mysql.h> and F<mysql_version.h>. In most cases the header files are not installed by default. For example, on Windows it is an installation option of the MySQL setup program (Custom installation), whether the header files are installed or not. On Red Hat Linux, you need to install an RPM archive F<mysql-devel> or F<MySQL-devel>. If you know the location of the header files, then you will need to add an option -L<header directory> to the C compiler flags, for example C<-L/usr/include/mysql>. =head2 Linker flags Appropriate linker flags are the most common source of problems while installing DBD::mysql. I will only give a rough overview, you'll find more details in the troubleshooting section. L</KNOWN PROBLEMS> The determination of the C compiler flags is usually left to a configuration script called F<mysql_config>, which can be invoked with mysql_config --libs When doing so, it will emit a line with suggested C compiler flags, for example like this: -L'/usr/lib/mysql' -lmysqlclient -lnsl -lm -lz -lcrypt The following items typically need to be configured for the linker: =over =item The mysqlclient library The MySQL client library comes as part of the MySQL distribution. Depending on your system it may be a file called F<libmysqlclient.a> statically linked library, Unix F<libmysqlclient.so> dynamically linked library, Unix F<mysqlclient.lib> statically linked library, Windows F<mysqlclient.dll> dynamically linked library, Windows or something similar. As in the case of the header files, the client library is typically not installed by default. On Windows you will need to select them while running the MySQL setup program (Custom installation). On Red Hat Linux an RPM archive F<mysql-devel> or F<MySQL-devel> must be installed. The linker needs to know the location and name of the mysqlclient library. This can be done by adding the flags -L<lib directory> -lmysqlclient or by adding the complete path name. Examples: -L/usr/lib/mysql -lmysqlclient -LC:\mysql\lib -lmysqlclient If you would like to use the static libraries (and there are excellent reasons to do so), you need to create a separate directory, copy the static libraries to that place and use the -L switch above to point to your new directory. For example: mkdir /tmp/mysql-static cp /usr/lib/mysql/*.a /tmp/mysql-static perl Makefile.PL --libs="-L/tmp/mysql-static -lmysqlclient" make make test make install rm -rf /tmp/mysql-static =item The gzip library The MySQL client can use compression when talking to the MySQL server, a nice feature when sending or receiving large texts over a slow network. On Unix you typically find the appropriate file name by running ldconfig -p | grep libz ldconfig -p | grep libgz Once you know the name (libz.a or libgz.a is best), just add it to the list of linker flags. If this seems to be causing problem you may also try to link without gzip libraries. =back =head1 ENCRYPTED CONNECTIONS via SSL Connecting to your servers over an encrypted connection (SSL) is only possible if you enabled this setting at build time. Since version 4.034, this is the default. Attempting to connect to a server that requires an encrypted connection without first having L<DBD::mysql> compiled with the C<--ssl> option will result in an error that makes things appear as if your password is incorrect. =head1 SPECIAL SYSTEMS Below you find information on particular systems: =head2 macOS For installing DBD::mysql you need to have the libssl header files and the mysql client libs. The easiest way to install these is using Homebrew (L<https://brew.sh/>). It is recommended to use a Perl version that is installed with brew as well as the system version might not come with header files in the expected locations. Once you have Homebrew set up, you can simply install the dependencies using brew install perl openssl@3 mysql-client After installing components with brew you might have to logout and login for your shell to pick up the newly installed software. Then make sure to add the path for L<mysql_config> to your path: export PATH=/usr/local/Cellar/mysql-client/8.1.0/bin:$PATH Make sure to use the correct path for your installation. Check the output of L<brew list mysql-client> to see the correct path. You can use L<~/.zshrc> to set the path for future sessions as well. Then you can install DBD::mysql using your cpan client. =head2 Cygwin If you are a user of Cygwin you already know, it contains a nicely running perl 5.6.1, installation of additional modules usually works like a charm via the standard procedure of perl makefile.PL make make test make install The Windows binary distribution of MySQL runs smoothly under Cygwin. You can start/stop the server and use all Windows clients without problem. But to install DBD::mysql you have to take a little special action. Don't attempt to build DBD::mysql against either the MySQL Windows or Linux/Unix BINARY distributions: neither will work! You MUST compile the MySQL clients yourself under Cygwin, to get a 'libmysqlclient.a' compiled under Cygwin. Really! You'll only need that library and the header files, you don't need any other client parts. Continue to use the Windows binaries. And don't attempt (currently) to build the MySQL Server part, it is unnecessary, as MySQL AB does an excellent job to deliver optimized binaries for the mainstream operating systems, and it is told, that the server compiled under Cygwin is unstable. Install a MySQL server for testing against. You can install the regular Windows MySQL server package on your Windows machine, or you can also test against a MySQL server on a remote host. =head3 Build MySQL clients under Cygwin: download the MySQL LINUX source from L<https://dev.mysql.com/downloads>, unpack mysql-<version>.tar.gz into some tmp location and from this directory run configure: cmake -DWITHOUT_SERVER=ON -DCMAKE_INSTALL_PREFIX=/usr/local/mysql This prepares the Makefile with the installed Cygwin features. It takes some time, but should finish without error. The 'prefix', as given, installs the whole Cygwin/MySQL thingy into a location not normally in your PATH, so that you continue to use already installed Windows binaries. The --without-server parameter tells configure to only build the clients. make This builds all MySQL client parts ... be patient. It should finish finally without any error. make install This installs the compiled client files under /usr/local/mysql/. Remember, you don't need anything except the library under /usr/local/mysql/lib and the headers under /usr/local/mysql/include! Essentially you are now done with this part. If you want, you may try your compiled binaries shortly; for that, do: cd /usr/local/mysql/bin ./mysql -h 127.0.0.1 The host (-h) parameter 127.0.0.1 targets the local host, but forces the mysql client to use a TCP/IP connection. The default would be a pipe/socket connection (even if you say '-h localhost') and this doesn't work between Cygwin and Windows (as far as I know). If you have your MySQL server running on some other box, then please substitute '127.0.0.1' with the name or IP-number of that box. Please note, in my environment the 'mysql' client did not accept a simple RETURN, I had to use CTRL-RETURN to send commands ... strange, but I didn't attempt to fix that, as we are only interested in the built lib and headers. At the 'mysql>' prompt do a quick check: mysql> use mysql mysql> show tables; mysql> select * from db; mysql> exit You are now ready to build DBD::mysql! =head3 compile DBD::mysql download and extract DBD-mysql-<version>.tar.gz from CPAN cd into unpacked dir DBD-mysql-<version> you probably did that already, if you are reading this! cp /usr/local/mysql/bin/mysql_config . This copies the executable script mentioned in the DBD::mysql docs from your just built Cywin/MySQL client directory; it knows about your Cygwin installation, especially about the right libraries to link with. perl Makefile.PL --testhost=127.0.0.1 The --testhost=127.0.0.1 parameter again forces a TCP/IP connection to the MySQL server on the local host instead of a pipe/socket connection for the 'make test' phase. make This should run without error make test make install This installs DBD::mysql into the Perl hierarchy. =head1 KNOWN PROBLEMS =head2 no gzip on your system Some Linux distributions don't come with a gzip library by default. Running "make" terminates with an error message like LD_RUN_PATH="/usr/lib/mysql:/lib:/usr/lib" gcc -o blib/arch/auto/DBD/mysql/mysql.so -shared -L/usr/local/lib dbdimp.o mysql.o -L/usr/lib/mysql -lmysqlclient -lm -L/usr/lib/gcc-lib/i386-redhat-linux/2.96 -lgcc -lz /usr/bin/ld: cannot find -lz collect2: ld returned 1 exit status make: *** [blib/arch/auto/DBD/mysql/mysql.so] Error 1 If this is the case for you, install an RPM archive like libz-devel, libgz-devel, zlib-devel or gzlib-devel or something similar. =head2 different compiler for mysql and perl If Perl was compiled with gcc or egcs, but MySQL was compiled with another compiler or on another system, an error message like this is very likely when running "Make test": t/00base............install_driver(mysql) failed: Can't load '../blib/arch/auto/DBD/mysql/mysql.so' for module DBD::mysql: ../blib/arch/auto/DBD/mysql/mysql.so: undefined symbol: _umoddi3 at /usr/local/perl-5.005/lib/5.005/i586-linux-thread/DynaLoader.pm line 168. This means, that your linker doesn't include libgcc.a. You have the following options: The solution is telling the linker to use libgcc. Run gcc --print-libgcc-file to determine the exact location of libgcc.a or for older versions of gcc gcc -v to determine the directory. If you know the directory, add a -L<directory> -lgcc to the list of C compiler flags. L</Configuration>. L</Linker flags>. =head1 SUPPORT Finally, if everything else fails, you are not alone. First of all, for an immediate answer, you should look into the archives of the dbi-users mailing list, which is available at L<http://groups.google.com/group/perl.dbi.users?hl=en&lr=> To subscribe to this list, send and email to dbi-users-subscribe@perl.org If you don't find an appropriate posting and reply in the mailing list, please post a question. Typically a reply will be seen within one or two days. 5.32/DBD/mysql/GetInfo.pm 0000444 00000037361 15125513451 0010574 0 ustar 00 package DBD::mysql::GetInfo; ######################################## # DBD::mysql::GetInfo # # # Generated by DBI::DBD::Metadata # $Author$ <-- the person to blame # $Revision$ # $Date$ use strict; use warnings; use DBD::mysql; # Beware: not officially documented interfaces... # use DBI::Const::GetInfoType qw(%GetInfoType); # use DBI::Const::GetInfoReturn qw(%GetInfoReturnTypes %GetInfoReturnValues); my $sql_driver = 'mysql'; # SQL_DRIVER_VER should be formatted as dd.dd.dddd my $dbdversion = $DBD::mysql::VERSION; $dbdversion .= '_00' if $dbdversion =~ /^\d+\.\d+$/; my $sql_driver_ver = sprintf("%02d.%02d.%04d", split(/[\._]/,$dbdversion)); my @Keywords = qw( BIGINT BLOB DEFAULT KEYS LIMIT LONGBLOB MEDIUMBLOB MEDIUMINT MEDIUMTEXT PROCEDURE REGEXP RLIKE SHOW TABLES TINYBLOB TINYTEXT UNIQUE UNSIGNED ZEROFILL ); sub sql_keywords { return join ',', @Keywords; } sub sql_data_source_name { my $dbh = shift; return "dbi:$sql_driver:" . $dbh->{Name}; } sub sql_user_name { my $dbh = shift; # Non-standard attribute return $dbh->{CURRENT_USER}; } #################### # makefunc() # returns a ref to a sub that calls into XS to get # values for info types that must needs be coded in C sub makefunk ($) { my $type = shift; return sub {dbd_mysql_get_info(shift, $type)} } our %info = ( 20 => 'N', # SQL_ACCESSIBLE_PROCEDURES 19 => 'Y', # SQL_ACCESSIBLE_TABLES 0 => 0, # SQL_ACTIVE_CONNECTIONS 116 => 0, # SQL_ACTIVE_ENVIRONMENTS 1 => 0, # SQL_ACTIVE_STATEMENTS 169 => 127, # SQL_AGGREGATE_FUNCTIONS 117 => 0, # SQL_ALTER_DOMAIN 86 => 3, # SQL_ALTER_TABLE 10021 => makefunk 10021, # SQL_ASYNC_MODE 120 => 2, # SQL_BATCH_ROW_COUNT 121 => 2, # SQL_BATCH_SUPPORT 82 => 0, # SQL_BOOKMARK_PERSISTENCE 114 => 1, # SQL_CATALOG_LOCATION 10003 => 'Y', # SQL_CATALOG_NAME 41 => makefunk 41, # SQL_CATALOG_NAME_SEPARATOR 42 => makefunk 42, # SQL_CATALOG_TERM 92 => 29, # SQL_CATALOG_USAGE 10004 => '', # SQL_COLLATING_SEQUENCE 10004 => '', # SQL_COLLATION_SEQ 87 => 'Y', # SQL_COLUMN_ALIAS 22 => 0, # SQL_CONCAT_NULL_BEHAVIOR 53 => 259071, # SQL_CONVERT_BIGINT 54 => 0, # SQL_CONVERT_BINARY 55 => 259071, # SQL_CONVERT_BIT 56 => 259071, # SQL_CONVERT_CHAR 57 => 259071, # SQL_CONVERT_DATE 58 => 259071, # SQL_CONVERT_DECIMAL 59 => 259071, # SQL_CONVERT_DOUBLE 60 => 259071, # SQL_CONVERT_FLOAT 48 => 0, # SQL_CONVERT_FUNCTIONS # 173 => undef, # SQL_CONVERT_GUID 61 => 259071, # SQL_CONVERT_INTEGER 123 => 0, # SQL_CONVERT_INTERVAL_DAY_TIME 124 => 0, # SQL_CONVERT_INTERVAL_YEAR_MONTH 71 => 0, # SQL_CONVERT_LONGVARBINARY 62 => 259071, # SQL_CONVERT_LONGVARCHAR 63 => 259071, # SQL_CONVERT_NUMERIC 64 => 259071, # SQL_CONVERT_REAL 65 => 259071, # SQL_CONVERT_SMALLINT 66 => 259071, # SQL_CONVERT_TIME 67 => 259071, # SQL_CONVERT_TIMESTAMP 68 => 259071, # SQL_CONVERT_TINYINT 69 => 0, # SQL_CONVERT_VARBINARY 70 => 259071, # SQL_CONVERT_VARCHAR 122 => 0, # SQL_CONVERT_WCHAR 125 => 0, # SQL_CONVERT_WLONGVARCHAR 126 => 0, # SQL_CONVERT_WVARCHAR 74 => 1, # SQL_CORRELATION_NAME 127 => 0, # SQL_CREATE_ASSERTION 128 => 0, # SQL_CREATE_CHARACTER_SET 129 => 0, # SQL_CREATE_COLLATION 130 => 0, # SQL_CREATE_DOMAIN 131 => 0, # SQL_CREATE_SCHEMA 132 => 1045, # SQL_CREATE_TABLE 133 => 0, # SQL_CREATE_TRANSLATION 134 => 0, # SQL_CREATE_VIEW 23 => 2, # SQL_CURSOR_COMMIT_BEHAVIOR 24 => 2, # SQL_CURSOR_ROLLBACK_BEHAVIOR 10001 => 0, # SQL_CURSOR_SENSITIVITY 2 => \&sql_data_source_name, # SQL_DATA_SOURCE_NAME 25 => 'N', # SQL_DATA_SOURCE_READ_ONLY 119 => 7, # SQL_DATETIME_LITERALS 17 => 'MySQL', # SQL_DBMS_NAME 18 => makefunk 18, # SQL_DBMS_VER 170 => 3, # SQL_DDL_INDEX 26 => 2, # SQL_DEFAULT_TRANSACTION_ISOLATION 26 => 2, # SQL_DEFAULT_TXN_ISOLATION 10002 => 'N', # SQL_DESCRIBE_PARAMETER # 171 => undef, # SQL_DM_VER 3 => 137076632, # SQL_DRIVER_HDBC # 135 => undef, # SQL_DRIVER_HDESC 4 => 137076088, # SQL_DRIVER_HENV # 76 => undef, # SQL_DRIVER_HLIB # 5 => undef, # SQL_DRIVER_HSTMT 6 => 'libmyodbc3.so', # SQL_DRIVER_NAME 77 => '03.51', # SQL_DRIVER_ODBC_VER 7 => $sql_driver_ver, # SQL_DRIVER_VER 136 => 0, # SQL_DROP_ASSERTION 137 => 0, # SQL_DROP_CHARACTER_SET 138 => 0, # SQL_DROP_COLLATION 139 => 0, # SQL_DROP_DOMAIN 140 => 0, # SQL_DROP_SCHEMA 141 => 7, # SQL_DROP_TABLE 142 => 0, # SQL_DROP_TRANSLATION 143 => 0, # SQL_DROP_VIEW 144 => 0, # SQL_DYNAMIC_CURSOR_ATTRIBUTES1 145 => 0, # SQL_DYNAMIC_CURSOR_ATTRIBUTES2 27 => 'Y', # SQL_EXPRESSIONS_IN_ORDERBY 8 => 63, # SQL_FETCH_DIRECTION 84 => 0, # SQL_FILE_USAGE 146 => 97863, # SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 147 => 6016, # SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 81 => 11, # SQL_GETDATA_EXTENSIONS 88 => 3, # SQL_GROUP_BY 28 => 4, # SQL_IDENTIFIER_CASE #29 => sub {dbd_mysql_get_info(shift,$GetInfoType {SQL_IDENTIFIER_QUOTE_CHAR})}, 29 => makefunk 29, # SQL_IDENTIFIER_QUOTE_CHAR 148 => 0, # SQL_INDEX_KEYWORDS 149 => 0, # SQL_INFO_SCHEMA_VIEWS 172 => 7, # SQL_INSERT_STATEMENT 73 => 'N', # SQL_INTEGRITY 150 => 0, # SQL_KEYSET_CURSOR_ATTRIBUTES1 151 => 0, # SQL_KEYSET_CURSOR_ATTRIBUTES2 89 => \&sql_keywords, # SQL_KEYWORDS 113 => 'Y', # SQL_LIKE_ESCAPE_CLAUSE 78 => 0, # SQL_LOCK_TYPES 34 => 64, # SQL_MAXIMUM_CATALOG_NAME_LENGTH 97 => 0, # SQL_MAXIMUM_COLUMNS_IN_GROUP_BY 98 => 32, # SQL_MAXIMUM_COLUMNS_IN_INDEX 99 => 0, # SQL_MAXIMUM_COLUMNS_IN_ORDER_BY 100 => 0, # SQL_MAXIMUM_COLUMNS_IN_SELECT 101 => 0, # SQL_MAXIMUM_COLUMNS_IN_TABLE 30 => 64, # SQL_MAXIMUM_COLUMN_NAME_LENGTH 1 => 0, # SQL_MAXIMUM_CONCURRENT_ACTIVITIES 31 => 18, # SQL_MAXIMUM_CURSOR_NAME_LENGTH 0 => 0, # SQL_MAXIMUM_DRIVER_CONNECTIONS 10005 => 64, # SQL_MAXIMUM_IDENTIFIER_LENGTH 102 => 500, # SQL_MAXIMUM_INDEX_SIZE 104 => 0, # SQL_MAXIMUM_ROW_SIZE 32 => 0, # SQL_MAXIMUM_SCHEMA_NAME_LENGTH 105 => makefunk 105, # SQL_MAXIMUM_STATEMENT_LENGTH # 20000 => undef, # SQL_MAXIMUM_STMT_OCTETS # 20001 => undef, # SQL_MAXIMUM_STMT_OCTETS_DATA # 20002 => undef, # SQL_MAXIMUM_STMT_OCTETS_SCHEMA 106 => makefunk 106, # SQL_MAXIMUM_TABLES_IN_SELECT 35 => 64, # SQL_MAXIMUM_TABLE_NAME_LENGTH 107 => 16, # SQL_MAXIMUM_USER_NAME_LENGTH 10022 => makefunk 10022, # SQL_MAX_ASYNC_CONCURRENT_STATEMENTS 112 => 0, # SQL_MAX_BINARY_LITERAL_LEN 34 => 64, # SQL_MAX_CATALOG_NAME_LEN 108 => 0, # SQL_MAX_CHAR_LITERAL_LEN 97 => 0, # SQL_MAX_COLUMNS_IN_GROUP_BY 98 => 32, # SQL_MAX_COLUMNS_IN_INDEX 99 => 0, # SQL_MAX_COLUMNS_IN_ORDER_BY 100 => 0, # SQL_MAX_COLUMNS_IN_SELECT 101 => 0, # SQL_MAX_COLUMNS_IN_TABLE 30 => 64, # SQL_MAX_COLUMN_NAME_LEN 1 => 0, # SQL_MAX_CONCURRENT_ACTIVITIES 31 => 18, # SQL_MAX_CURSOR_NAME_LEN 0 => 0, # SQL_MAX_DRIVER_CONNECTIONS 10005 => 64, # SQL_MAX_IDENTIFIER_LEN 102 => 500, # SQL_MAX_INDEX_SIZE 32 => 0, # SQL_MAX_OWNER_NAME_LEN 33 => 0, # SQL_MAX_PROCEDURE_NAME_LEN 34 => 64, # SQL_MAX_QUALIFIER_NAME_LEN 104 => 0, # SQL_MAX_ROW_SIZE 103 => 'Y', # SQL_MAX_ROW_SIZE_INCLUDES_LONG 32 => 0, # SQL_MAX_SCHEMA_NAME_LEN 105 => 8192, # SQL_MAX_STATEMENT_LEN 106 => 31, # SQL_MAX_TABLES_IN_SELECT 35 => makefunk 35, # SQL_MAX_TABLE_NAME_LEN 107 => 16, # SQL_MAX_USER_NAME_LEN 37 => 'Y', # SQL_MULTIPLE_ACTIVE_TXN 36 => 'Y', # SQL_MULT_RESULT_SETS 111 => 'N', # SQL_NEED_LONG_DATA_LEN 75 => 1, # SQL_NON_NULLABLE_COLUMNS 85 => 2, # SQL_NULL_COLLATION 49 => 16777215, # SQL_NUMERIC_FUNCTIONS 9 => 1, # SQL_ODBC_API_CONFORMANCE 152 => 2, # SQL_ODBC_INTERFACE_CONFORMANCE 12 => 1, # SQL_ODBC_SAG_CLI_CONFORMANCE 15 => 1, # SQL_ODBC_SQL_CONFORMANCE 73 => 'N', # SQL_ODBC_SQL_OPT_IEF 10 => '03.80', # SQL_ODBC_VER 115 => 123, # SQL_OJ_CAPABILITIES 90 => 'Y', # SQL_ORDER_BY_COLUMNS_IN_SELECT 38 => 'Y', # SQL_OUTER_JOINS 115 => 123, # SQL_OUTER_JOIN_CAPABILITIES 39 => '', # SQL_OWNER_TERM 91 => 0, # SQL_OWNER_USAGE 153 => 2, # SQL_PARAM_ARRAY_ROW_COUNTS 154 => 3, # SQL_PARAM_ARRAY_SELECTS 80 => 3, # SQL_POSITIONED_STATEMENTS 79 => 31, # SQL_POS_OPERATIONS 21 => 'N', # SQL_PROCEDURES 40 => '', # SQL_PROCEDURE_TERM 114 => 1, # SQL_QUALIFIER_LOCATION 41 => '.', # SQL_QUALIFIER_NAME_SEPARATOR 42 => 'database', # SQL_QUALIFIER_TERM 92 => 29, # SQL_QUALIFIER_USAGE 93 => 3, # SQL_QUOTED_IDENTIFIER_CASE 11 => 'N', # SQL_ROW_UPDATES 39 => '', # SQL_SCHEMA_TERM 91 => 0, # SQL_SCHEMA_USAGE 43 => 7, # SQL_SCROLL_CONCURRENCY 44 => 17, # SQL_SCROLL_OPTIONS 14 => '\\', # SQL_SEARCH_PATTERN_ESCAPE 13 => makefunk 13, # SQL_SERVER_NAME 94 => 'ÇüéâäàåçêëèïîìÄÅÉæÆôöòûùÿÖÜáíóúñÑ', # SQL_SPECIAL_CHARACTERS 155 => 7, # SQL_SQL92_DATETIME_FUNCTIONS 156 => 0, # SQL_SQL92_FOREIGN_KEY_DELETE_RULE 157 => 0, # SQL_SQL92_FOREIGN_KEY_UPDATE_RULE 158 => 8160, # SQL_SQL92_GRANT 159 => 0, # SQL_SQL92_NUMERIC_VALUE_FUNCTIONS 160 => 0, # SQL_SQL92_PREDICATES 161 => 466, # SQL_SQL92_RELATIONAL_JOIN_OPERATORS 162 => 32640, # SQL_SQL92_REVOKE 163 => 7, # SQL_SQL92_ROW_VALUE_CONSTRUCTOR 164 => 255, # SQL_SQL92_STRING_FUNCTIONS 165 => 0, # SQL_SQL92_VALUE_EXPRESSIONS 118 => 4, # SQL_SQL_CONFORMANCE 166 => 2, # SQL_STANDARD_CLI_CONFORMANCE 167 => 97863, # SQL_STATIC_CURSOR_ATTRIBUTES1 168 => 6016, # SQL_STATIC_CURSOR_ATTRIBUTES2 83 => 7, # SQL_STATIC_SENSITIVITY 50 => 491519, # SQL_STRING_FUNCTIONS 95 => 0, # SQL_SUBQUERIES 51 => 7, # SQL_SYSTEM_FUNCTIONS 45 => 'table', # SQL_TABLE_TERM 109 => 0, # SQL_TIMEDATE_ADD_INTERVALS 110 => 0, # SQL_TIMEDATE_DIFF_INTERVALS 52 => 106495, # SQL_TIMEDATE_FUNCTIONS 46 => 3, # SQL_TRANSACTION_CAPABLE 72 => 15, # SQL_TRANSACTION_ISOLATION_OPTION 46 => 3, # SQL_TXN_CAPABLE 72 => 15, # SQL_TXN_ISOLATION_OPTION 96 => 0, # SQL_UNION 96 => 0, # SQL_UNION_STATEMENT 47 => \&sql_user_name, # SQL_USER_NAME 10000 => 1992, # SQL_XOPEN_CLI_YEAR ); 1; __END__ 5.32/Template.pm 0000444 00000062551 15125513451 0007255 0 ustar 00 #============================================================= -*-perl-*- # # Template # # DESCRIPTION # Module implementing a simple, user-oriented front-end to the Template # Toolkit. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== package Template; use strict; use warnings; use 5.006; use base 'Template::Base'; use Template::Config; use Template::Constants; use Template::Provider; use Template::Service; use File::Basename; use File::Path; use Scalar::Util qw(blessed); our $VERSION = '3.102'; our $ERROR = ''; our $DEBUG = 0; our $BINMODE = 0 unless defined $BINMODE; our $AUTOLOAD; # preload all modules if we're running under mod_perl Template::Config->preload() if $ENV{ MOD_PERL }; #------------------------------------------------------------------------ # process($input, \%replace, $output) # # Main entry point for the Template Toolkit. The Template module # delegates most of the processing effort to the underlying SERVICE # object, an instance of the Template::Service class. #------------------------------------------------------------------------ sub process { my ($self, $template, $vars, $outstream, @opts) = @_; my ($output, $error); my $options = (@opts == 1) && ref($opts[0]) eq 'HASH' ? shift(@opts) : { @opts }; $options->{ binmode } = $BINMODE unless defined $options->{ binmode }; # we're using this for testing in t/output.t and t/filter.t so # don't remove it if you don't want tests to fail... $self->DEBUG("set binmode\n") if $DEBUG && $options->{ binmode }; $output = $self->{ SERVICE }->process($template, $vars); if (defined $output) { $outstream ||= $self->{ OUTPUT }; unless (ref $outstream) { my $outpath = $self->{ OUTPUT_PATH }; $outstream = "$outpath/$outstream" if $outpath; } # send processed template to output stream, checking for error return ($self->error($error)) if ($error = &_output($outstream, \$output, $options)); return 1; } else { return $self->error($self->{ SERVICE }->error); } } #------------------------------------------------------------------------ # service() # # Returns a reference to the internal SERVICE object which handles # all requests for this Template object #------------------------------------------------------------------------ sub service { my $self = shift; return $self->{ SERVICE }; } #------------------------------------------------------------------------ # context() # # Returns a reference to the CONTEXT object within the SERVICE # object. #------------------------------------------------------------------------ sub context { my $self = shift; return $self->{ SERVICE }->{ CONTEXT }; } sub template { shift->context->template(@_); } #======================================================================== # -- PRIVATE METHODS -- #======================================================================== #------------------------------------------------------------------------ # _init(\%config) #------------------------------------------------------------------------ sub _init { my ($self, $config) = @_; # convert any textual DEBUG args to numerical form my $debug = $config->{ DEBUG }; $config->{ DEBUG } = Template::Constants::debug_flags($self, $debug) || return if defined $debug && $debug !~ /^\d+$/; # prepare a namespace handler for any CONSTANTS definition if (my $constants = $config->{ CONSTANTS }) { my $ns = $config->{ NAMESPACE } ||= { }; my $cns = $config->{ CONSTANTS_NAMESPACE } || 'constants'; $constants = Template::Config->constants($constants) || return $self->error(Template::Config->error); $ns->{ $cns } = $constants; } $self->{ SERVICE } = $config->{ SERVICE } || Template::Config->service($config) || return $self->error(Template::Config->error); $self->{ OUTPUT } = $config->{ OUTPUT } || \*STDOUT; $self->{ OUTPUT_PATH } = $config->{ OUTPUT_PATH }; return $self; } #------------------------------------------------------------------------ # _output($where, $text) #------------------------------------------------------------------------ sub _output { my ($where, $textref, $options) = @_; my $reftype; my $error = 0; # call a CODE reference if (($reftype = ref($where)) eq 'CODE') { &$where($$textref); } # print to a glob (such as \*STDOUT) elsif ($reftype eq 'GLOB') { print $where $$textref; } # append output to a SCALAR ref elsif ($reftype eq 'SCALAR') { $$where .= $$textref; } # push onto ARRAY ref elsif ($reftype eq 'ARRAY') { push @$where, $$textref; } # call the print() method on an object that implements the method # (e.g. IO::Handle, Apache::Request, etc) elsif (blessed($where) && $where->can('print')) { $where->print($$textref); } # a simple string is taken as a filename elsif (! $reftype) { local *FP; # make destination directory if it doesn't exist my $dir = dirname($where); eval { mkpath($dir) unless -d $dir; }; if ($@) { # strip file name and line number from error raised by die() ($error = $@) =~ s/ at \S+ line \d+\n?$//; } elsif (open(FP, '>', $where)) { # binmode option can be 1 or a specific layer, e.g. :utf8 my $bm = $options->{ binmode }; if (not(defined $bm)) { $bm = $BINMODE; } if ($bm && $bm eq 1) { binmode FP; } elsif ($bm){ binmode FP, $bm; } print FP $$textref; close FP; } else { $error = "$where: $!"; } } # give up, we've done our best else { $error = "output_handler() cannot determine target type ($where)\n"; } return $error; } 1; __END__ =head1 NAME Template - Front-end module to the Template Toolkit =head1 SYNOPSIS use Template; # some useful options (see below for full list) my $config = { INCLUDE_PATH => '/search/path', # or list ref INTERPOLATE => 1, # expand "$var" in plain text POST_CHOMP => 1, # cleanup whitespace PRE_PROCESS => 'header', # prefix each template EVAL_PERL => 1, # evaluate Perl code blocks }; # create Template object my $template = Template->new($config); # define template variables for replacement my $vars = { var1 => $value, var2 => \%hash, var3 => \@list, var4 => \&code, var5 => $object, }; # specify input filename, or file handle, text reference, etc. my $input = 'myfile.html'; # process input template, substituting variables $template->process($input, $vars) || die $template->error(); =head1 DESCRIPTION This documentation describes the Template module which is the direct Perl interface into the Template Toolkit. It covers the use of the module and gives a brief summary of configuration options and template directives. Please see L<Template::Manual> for the complete reference manual which goes into much greater depth about the features and use of the Template Toolkit. The L<Template::Tutorial> is also available as an introductory guide to using the Template Toolkit. =head1 METHODS =head2 new(\%config) The C<new()> constructor method (implemented by the L<Template::Base|Template::Base#new()> base class) instantiates a new C<Template> object. A reference to a hash array of configuration items may be passed as a parameter. my $tt = Template->new({ INCLUDE_PATH => '/usr/local/templates', EVAL_PERL => 1, }) || die $Template::ERROR, "\n"; A reference to a new C<Template> object is returned, or undef on error. In the latter case, the error message can be retrieved by calling L<error()> as a class method or by examining the C<$Template::ERROR> package variable directly. my $tt = Template->new(\%config) || die Template->error(), "\n"; my $tt = Template->new(\%config) || die $Template::ERROR, "\n"; For convenience, configuration items may also be specified as a list of items instead of a hash array reference. These are automatically folded into a hash array by the constructor. my $tt = Template->new(INCLUDE_PATH => '/tmp', POST_CHOMP => 1) || die $Template::ERROR, "\n"; =head2 process($template, \%vars, $output, %options) The C<process()> method is called to process a template. The first parameter indicates the input template as one of: =over 4 =item * a filename relative to C<INCLUDE_PATH>, if defined =item * a reference to a text string containing the template text =item * a file handle reference (e.g. C<IO::Handle> or sub-class) or C<GLOB> (e.g. C<\*STDIN>), from which the template can be read. =back A reference to a hash array may be passed as the second parameter, containing definitions of template variables. # filename $tt->process('welcome.tt2') || die $tt->error(), "\n"; # text reference $text = "[% INCLUDE header %]\nHello world!\n[% INCLUDE footer %]"; $tt->process(\$text) || die $tt->error(), "\n"; # file handle (GLOB) $tt->process(\*DATA) || die $tt->error(), "\n"; __END__ [% INCLUDE header %] This is a template defined in the __END__ section which is accessible via the DATA "file handle". [% INCLUDE footer %] By default, the processed template output is printed to C<STDOUT>. The C<process()> method then returns C<1> to indicate success. A third parameter may be passed to the C<process()> method to specify a different output location. This value may be one of: =over 4 =item * a plain string indicating a filename which will be opened (relative to C<OUTPUT_PATH>, if defined) and the output written to =item * a file GLOB opened ready for output =item * a reference to a scalar (e.g. a text string) to which output/error is appended =item * a reference to a subroutine which is called, passing the output as a parameter =item * any object reference which implements a C<print()> method (e.g. C<IO::Handle>, C<Apache::Request>, etc.) which will be called, passing the generated output as a parameter. =back Examples: # output filename $tt->process('welcome.tt2', $vars, 'welcome.html') || die $tt->error(), "\n"; # reference to output subroutine sub myout { my $output = shift; ... } $tt->process('welcome.tt2', $vars, \&myout) || die $tt->error(), "\n"; # reference to output text string my $output = ''; $tt->process('welcome.tt2', $vars, \$output) || die $tt->error(), "\n"; print "output: $output\n"; In an Apache/mod_perl handler: sub handler { my $req = shift; # ...your code here... # direct output to Apache::Request via $req->print($output) $tt->process($file, $vars, $req) || do { $req->log_reason($tt->error()); return SERVER_ERROR; }; return OK; } After the optional third output argument can come an optional reference to a hash or a list of C<(name, value)> pairs providing further options for the output. The only option currently supported is C<binmode> which, when set to any true value will ensure that files created (but not any existing file handles passed) will be set to binary mode. # either: hash reference of options $tt->process($infile, $vars, $outfile, { binmode => 1 }) || die $tt->error(), "\n"; # or: list of name, value pairs $tt->process($infile, $vars, $outfile, binmode => 1) || die $tt->error(), "\n"; Alternately, the C<binmode> argument can specify a particular IO layer such as C<:utf8>. $tt->process($infile, $vars, $outfile, binmode => ':utf8') || die $tt->error(), "\n"; The C<OUTPUT> configuration item can be used to specify a default output location other than C<\*STDOUT>. The C<OUTPUT_PATH> specifies a directory which should be prefixed to all output locations specified as filenames. my $tt = Template->new({ OUTPUT => sub { ... }, # default OUTPUT_PATH => '/tmp', ... }) || die Template->error(), "\n"; # use default OUTPUT (sub is called) $tt->process('welcome.tt2', $vars) || die $tt->error(), "\n"; # write file to '/tmp/welcome.html' $tt->process('welcome.tt2', $vars, 'welcome.html') || die $tt->error(), "\n"; The C<process()> method returns C<1> on success or C<undef> on error. The error message generated in the latter case can be retrieved by calling the L<error()> method. See also L<CONFIGURATION SUMMARY> which describes how error handling may be further customised. =head2 error() When called as a class method, it returns the value of the C<$ERROR> package variable. Thus, the following are equivalent. my $tt = Template->new() || die Template->error(), "\n"; my $tt = Template->new() || die $Template::ERROR, "\n"; When called as an object method, it returns the value of the internal C<_ERROR> variable, as set by an error condition in a previous call to process(). $tt->process('welcome.tt2') || die $tt->error(), "\n"; Errors are represented in the Template Toolkit by objects of the L<Template::Exception> class. If the L<process()> method returns a false value then the C<error()> method can be called to return an object of this class. The L<type()|Template::Exception#type()> and L<info()|Template::Exception#info()> methods can called on the object to retrieve the error type and information string, respectively. The L<as_string()|Template::Exception#as_string()> method can be called to return a string of the form C<$type - $info>. This method is also overloaded onto the stringification operator allowing the object reference itself to be printed to return the formatted error string. $tt->process('somefile') || do { my $error = $tt->error(); print "error type: ", $error->type(), "\n"; print "error info: ", $error->info(), "\n"; print $error, "\n"; }; =head2 service() The C<Template> module delegates most of the effort of processing templates to an underlying L<Template::Service> object. This method returns a reference to that object. =head2 context() The L<Template::Service> module uses a core L<Template::Context> object for runtime processing of templates. This method returns a reference to that object and is equivalent to C<< $template-E<gt>service-E<gt>context() >>. =head2 template($name) This method is a simple wrapper around the L<Template::Context> method of the same name. It returns a compiled template for the source provided as an argument. =head1 CONFIGURATION SUMMARY The following list gives a short summary of each Template Toolkit configuration option. See L<Template::Manual::Config> for full details. =head2 Template Style and Parsing Options =head3 ENCODING Specifies the character encoding. =head3 START_TAG, END_TAG Define tokens that indicate start and end of directives (default: 'C<[%>' and 'C<%]>'). =head3 TAG_STYLE Set C<START_TAG> and C<END_TAG> according to a pre-defined style (default: 'C<template>', as above). =head3 PRE_CHOMP, POST_CHOMP Removes whitespace before/after directives (default: 0/0). =head3 TRIM Remove leading and trailing whitespace from template output (default: 0). =head3 INTERPOLATE Interpolate variables embedded like C<$this> or C<${this}> (default: 0). =head3 ANYCASE Allow directive keywords in lower case (default: 0 - UPPER only). =head2 Template Files and Blocks =head3 INCLUDE_PATH One or more directories to search for templates. =head3 DELIMITER Delimiter for separating paths in C<INCLUDE_PATH> (default: 'C<:>'). =head3 ABSOLUTE Allow absolute file names, e.g. C</foo/bar.html> (default: 0). =head3 RELATIVE Allow relative filenames, e.g. C<../foo/bar.html> (default: 0). =head3 DEFAULT Default template to use when another not found. =head3 BLOCKS Hash array pre-defining template blocks. =head3 AUTO_RESET Enabled by default causing C<BLOCK> definitions to be reset each time a template is processed. Disable to allow C<BLOCK> definitions to persist. =head3 RECURSION Flag to permit recursion into templates (default: 0). =head2 Template Variables =head3 VARIABLES Hash array of variables and values to pre-define in the stash. =head2 Runtime Processing Options =head3 EVAL_PERL Flag to indicate if C<PERL>/C<RAWPERL> blocks should be processed (default: 0). =head3 PRE_PROCESS, POST_PROCESS Name of template(s) to process before/after main template. =head3 PROCESS Name of template(s) to process instead of main template. =head3 ERROR Name of error template or reference to hash array mapping error types to templates. =head3 OUTPUT Default output location or handler. =head3 OUTPUT_PATH Directory into which output files can be written. =head3 DEBUG Enable debugging messages. =head2 Caching and Compiling Options =head3 CACHE_SIZE Maximum number of compiled templates to cache in memory (default: undef - cache all) =head3 COMPILE_EXT Filename extension for compiled template files (default: undef - don't compile). =head3 COMPILE_DIR Root of directory in which compiled template files should be written (default: undef - don't compile). =head2 Plugins and Filters =head3 PLUGINS Reference to a hash array mapping plugin names to Perl packages. =head3 PLUGIN_BASE One or more base classes under which plugins may be found. =head3 LOAD_PERL Flag to indicate regular Perl modules should be loaded if a named plugin can't be found (default: 0). =head3 FILTERS Hash array mapping filter names to filter subroutines or factories. =head2 Customisation and Extension =head3 LOAD_TEMPLATES List of template providers. =head3 LOAD_PLUGINS List of plugin providers. =head3 LOAD_FILTERS List of filter providers. =head3 TOLERANT Set providers to tolerate errors as declinations (default: 0). =head3 SERVICE Reference to a custom service object (default: L<Template::Service>). =head3 CONTEXT Reference to a custom context object (default: L<Template::Context>). =head3 STASH Reference to a custom stash object (default: L<Template::Stash>). =head3 PARSER Reference to a custom parser object (default: L<Template::Parser>). =head3 GRAMMAR Reference to a custom grammar object (default: L<Template::Grammar>). =head1 DIRECTIVE SUMMARY The following list gives a short summary of each Template Toolkit directive. See L<Template::Manual::Directives> for full details. =head2 GET Evaluate and print a variable or value. [% GET variable %] # 'GET' keyword is optional [% variable %] [% hash.key %] [% list.n %] [% code(args) %] [% obj.meth(args) %] [% "value: $var" %] =head2 CALL As per L<GET> but without printing result (e.g. call code) [% CALL variable %] =head2 SET Assign a values to variables. [% SET variable = value %] # 'SET' also optional [% variable = other_variable variable = 'literal text @ $100' variable = "interpolated text: $var" list = [ val, val, val, val, ... ] list = [ val..val ] hash = { var => val, var => val, ... } %] =head2 DEFAULT Like L<SET>, but variables are only set if currently unset (i.e. have no true value). [% DEFAULT variable = value %] =head2 INSERT Insert a file without any processing performed on the contents. [% INSERT legalese.txt %] =head2 PROCESS Process another template file or block and insert the generated output. Any template L<BLOCK>s or variables defined or updated in the C<PROCESS>ed template will thereafter be defined in the calling template. [% PROCESS template %] [% PROCESS template var = val, ... %] =head2 INCLUDE Similar to C<PROCESS>, but using a local copy of the current variables. Any template C<BLOCK>s or variables defined in the C<INCLUDE>d template remain local to it. [% INCLUDE template %] [% INCLUDE template var = val, ... %] =head2 WRAPPER The content between the C<WRAPPER> and corresponding C<END> directives is first evaluated, with the output generated being stored in the C<content> variable. The named template is then process as per C<INCLUDE>. [% WRAPPER layout %] Some template markup [% blah %]... [% END %] A simple F<layout> template might look something like this: Your header here... [% content %] Your footer here... =head2 BLOCK Define a named template block for L<INCLUDE>, L<PROCESS> and L<WRAPPER> to use. [% BLOCK hello %] Hello World [% END %] [% INCLUDE hello %] =head2 FOREACH Repeat the enclosed C<FOREACH> ... C<END> block for each value in the list. [% FOREACH variable IN [ val, val, val ] %] # either [% FOREACH variable IN list %] # or The variable is set to [% variable %] [% END %] =head2 WHILE The block enclosed between C<WHILE> and C<END> block is processed while the specified condition is true. [% WHILE condition %] content [% END %] =head2 IF / UNLESS / ELSIF / ELSE The enclosed block is processed if the condition is true / false. [% IF condition %] content [% ELSIF condition %] content [% ELSE %] content [% END %] [% UNLESS condition %] content [% # ELSIF/ELSE as per IF, above %] content [% END %] =head2 SWITCH / CASE Multi-way switch/case statement. [% SWITCH variable %] [% CASE val1 %] content [% CASE [ val2, val3 ] %] content [% CASE %] # or [% CASE DEFAULT %] content [% END %] =head2 MACRO Define a named macro. [% MACRO name <directive> %] [% MACRO name(arg1, arg2) <directive> %] ... [% name %] [% name(val1, val2) %] =head2 FILTER Process enclosed C<FILTER> ... C<END> block then pipe through a filter. [% FILTER name %] # either [% FILTER name( params ) %] # or [% FILTER alias = name( params ) %] # or content [% END %] =head2 USE Load a plugin module (see C<Template::<Manual::Plugins>), or any regular Perl module when the C<LOAD_PERL> option is set. [% USE name %] # either [% USE name( params ) %] # or [% USE var = name( params ) %] # or ... [% name.method %] [% var.method %] =head2 PERL / RAWPERL Evaluate enclosed blocks as Perl code (requires the C<EVAL_PERL> option to be set). [% PERL %] # perl code goes here $stash->set('foo', 10); print "set 'foo' to ", $stash->get('foo'), "\n"; print $context->include('footer', { var => $val }); [% END %] [% RAWPERL %] # raw perl code goes here, no magic but fast. $output .= 'some output'; [% END %] =head2 TRY / THROW / CATCH / FINAL Exception handling. [% TRY %] content [% THROW type info %] [% CATCH type %] catch content [% error.type %] [% error.info %] [% CATCH %] # or [% CATCH DEFAULT %] content [% FINAL %] this block is always processed [% END %] =head2 NEXT Jump straight to the next item in a C<FOREACH> or C<WHILE> loop. [% NEXT %] =head2 LAST Break out of C<FOREACH> or C<WHILE> loop. [% LAST %] =head2 RETURN Stop processing current template and return to including templates. [% RETURN %] =head2 STOP Stop processing all templates and return to caller. [% STOP %] =head2 TAGS Define new tag style or characters (default: C<[%> C<%]>). [% TAGS html %] [% TAGS <!-- --> %] =head2 COMMENTS Ignored and deleted. [% # this is a comment to the end of line foo = 'bar' %] [%# placing the '#' immediately inside the directive tag comments out the entire directive %] =head1 SOURCE CODE REPOSITORY The source code for the Template Toolkit is held in a public git repository on Github: L<https://github.com/abw/Template2> =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 VERSION Template Toolkit version 3.100, released on July 13 2020. =head1 SUPPORT The Template Toolkit mailing list provides a forum for discussing issues relating to the use and abuse of the Template Toolkit. There are a number of knowledgeable and helpful individuals who frequent the list (including the author) who can often offer help or suggestions. Please respect their time and patience by checking the documentation and/or mailing list archives before asking questions that may already have been answered. To subscribe to the mailing list, send an email to: template-toolkit+subscribe@groups.io You can also use the web interface: https://groups.io/g/template-toolkit For information about commercial support and consultancy for the Template Toolkit, please contact the author. =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Manual/Credits.pod 0000444 00000012116 15125513451 0012225 0 ustar 00 #============================================================= -*-perl-*- # # Template::Manual::Credits # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =encoding utf8 =head1 NAME Template::Manual::Credits - Author and contributor credits =head1 HISTORY The Template Toolkit began its life as the C<Text::MetaText> module, originally released to CPAN around 1996. This itself was the public manifestation of an earlier template processing system I developed while working at Peritas (now Knowledge Pool - http://www.knowledgepool.com/) C<Text::MetaText> was the prototype - the one we always planned to throw away. It did the job well, showing us what worked and what didn't, what was good and what was bad, and gave us some ideas about what could be done better, given the chance to start again from scratch. Some time late in 1998 I threw away the prototype and started work on the Template Toolkit. By then I was working at Canon Research Centre Europe Ltd. (CRE), involved in a general research programme related to web publishing and dynamic content generation. The first alpha release was in June 1999, followed by numerous more alpha and beta releases culminating in 1.00 being released on 2nd December 1999. A month or so later, work had begun on version 2.00. The plan was to get the template language relatively stable in version 1.00 and not worry too much about performance or other internal matters. Then, version 2.00 would follow to improve performance, clean up the architecture and fix anything that, with the benefit of hindsight, we thought could be improved. As it happens, me starting work on version 2.00 coincided with Doug Steinwand sending me his parser variant which compiled templates to Perl code, giving a major performance boost. As well as the speedups, there are a whole host of significant new features in version 2.00, and a greatly improved internal architecture. Apart from a few minor "fixups" the template directives and language have remained the same as in version 1.00 Version 2.00 was available in beta release form in July 2000, just in time for the 4th Perl Conference where version 1.00 was awarded "Best New Perl Module". After another extended beta release period, version 2.00 was released on 1st December 2000. Version 3 has been in development ever since. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2020 Andy Wardley. All Rights Reserved. The Template Toolkit is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 CONTRIBUTORS Many people have contributed ideas, inspiration, fixes and features to the Template Toolkit. Their efforts continue to be very much appreciated. Please let me know if you think anyone is missing from this list. If you submit a patch/pull request then please make sure you add your own name to this list and include it in the changes. Adam Kennedy, ahollandECS, Alexey A. Kiritchun, Amiri Barksdale, Andreas Koenig, Andy Wardley, Autrijus Tang, Axel Gerstmair, Barrie Slaymaker, Ben Tilly, Breno G. de Oliveira, Briac PilprE<eacute>, Brian Fraser, Brian Wightman, Bryce Harrington, Chris Dean, Chris Winters, Christian, chromatic, Colin Johnson, Colin Keith, Craig Barratt, Darren Chamberlain, Dave Cash, Dave Cross, Dave Hodgkinson, Dave Howorth, Dave Jacoby, David Steinbrunner, Denis F. Latypoff, Dennis Clark, Doug, Drew Taylor, Dylan, E. Choroba, eadjei, Eric Cholet, Francois Desarmenien, François Andriot, fREW Schmidt, gordon-fish, Guido Flohr, Hans von Lengerke, Harald Joerg, Horst Dumcke, Ivan Krylov, Ivan Kurmanov, Jacques Germishuys, Jason Lewis, Jay Hannah, Jens Rehsack, Jess Robinson, Jim Vaughan, John Lightsey, John Napiorkowski, Jon Jensen, Jonas Liljegren, Jonathon Padfield, José Joaquín Atria, Jose Luis Martinez, Josh Rosenbaum, Kenny Gatdula, Kent Fredric, Kevin M. Goess, Koenig, Leon Brocard, Leslie Michael Orchard, Lubomir, Lyle Brooks, Marc Remy, Mark Fowler, Martin, Matthew Somerville, Michael Fowler, Michael Stevens, Mike Schilli, Mikhail Klyuchnikov from Positive Technologies, nataraj, Neil Bowers, Nick Hibma, Nicolas R, Nik Clayton, Norbert Buchmüller, Paul Orrock, Paul Seamons, Paul Sharpe, Perrin Harkins, Philippe Bruhat (BooK), Piers Cawley, Portman, Rafael Kitover, Randal L. Schwartz, Ricardo Signes, Richard Tietjen, Robin Berjon, Rod Taylor, Schaffner, sdeseille, Sean McAfee, Sean Zellmer, Simon, Simon Dawson, Simon Matthews, Simon Napiorkowski, Slaven Rezic, Smylers, Stas Bekman, Stathy G. Touloumis, stefano-b, Steinwand, Steve Peters, Swen, Thierry-Michel Barral, Thuemmler, Timmy Chan, Todd Rinaldo, Tom Delmas, Tony Bowden, Tosh Cooey, Ville SkyttE<auml>, Vivek Khera, Wilcox, William Hardison, Yanick Champoux, Yuri Pimenov. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Manual/Intro.pod 0000444 00000022621 15125513451 0011725 0 ustar 00 #============================================================= -*-perl-*- # # Template::Manual::Intro # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Manual::Intro - Introduction to the Template Toolkit =head1 Introduction The Template Toolkit is a collection of Perl modules which implement a fast, flexible, powerful and extensible template processing system. It is most often used for generating dynamic web content, although it can be used equally well for processing any kind of text documents. At the simplest level it provides an easy way to process template files, filling in embedded variable references with their equivalent values. Here's an example of a template. Dear [% name %], It has come to our attention that your account is in arrears to the sum of [% debt %]. Please settle your account before [% deadline %] or we will be forced to revoke your Licence to Thrill. The Management. By default, template directives are embedded within the character sequences C<[%> ... C<%]> but you can change these and various other options to configure how the Template Toolkit looks, feels and works. You can set the C<INTERPOLATE> option, for example, if you prefer to embed your variables in Perl style: Dear $name, It has come to our attention that your account is in arrears to the sum of $debt. ...etc... =head1 The Template Perl Module The L<Template> Perl module is the front end to the Template Toolkit for Perl programmers, providing access to the full range of functionality through a single module with a simple interface. It loads the other modules as required and instantiates a default set of objects to handle subsequent template processing requests. Configuration parameters may be passed to the L<Template> constructor method, L<new()|Template#new()>, which are then used to configure the generate object. use Template; my $tt = Template->new({ INCLUDE_PATH => '/usr/local/templates', INTERPOLATE => 1, }) || die "$Template::ERROR\n"; The L<Template> object implements a L<process()|Template#process()> method for processing template files or text. The name of the input template (or various other sources) is passed as the first argument, followed by a reference to a hash array of variable definitions for substitution in the template. my $vars = { name => 'Count Edward van Halen', debt => '3 riffs and a solo', deadline => 'the next chorus', }; $tt->process('letters/overdrawn', $vars) || die $tt->error(), "\n"; The L<process()|Template#process()> method returns a true value (C<1>) on success and prints the template output to C<STDOUT>, by default. On error, the L<process()|Template#process()> method returns a false value (C<undef>). The L<error()|Template#error()> method can then be called to retrieve details of the error. =head1 Component Based Content Construction A number of special directives are provided, such as C<INSERT>, C<INCLUDE> and C<PROCESS>, which allow content to be built up from smaller template components. This permits a modular approach to building a web site or other content repository, promoting reusability, cross-site consistency, ease of construction and subsequent maintenance. Common elements such as headers, footers, menu bars, tables, and so on, can be created as separate template files which can then be processed into other documents as required. All defined variables are inherited by these templates along with any additional "local" values specified. [% PROCESS header title = "The Cat Sat on the Mat" %] [% PROCESS menu %] The location of the missing feline has now been established. Thank you for your assistance. [% INSERT legal/disclaimer %] [% PROCESS footer %] You can also define a template as a BLOCK within the same file and PROCESS it just like any other template file. This can be invaluable for building up repetitive elements such as tables, menus, etc. [% BLOCK tabrow %] <tr><td>[% name %]</td><td>[% email %]</td></tr> [% END %] <table> [% PROCESS tabrow name="tom" email="tom@here.org" %] [% PROCESS tabrow name="dick" email="disk@there.org" %] [% PROCESS tabrow name="larry" email="larry@where.org" %] </table> =head1 Data and Code Binding One of the key features that sets the Template Toolkit apart from other template processors is the ability to bind template variables to any kind of Perl data: scalars, lists, hash arrays, sub-routines and objects. my $vars = { root => 'http://here.com/there', menu => [ 'modules', 'authors', 'scripts' ], client => { name => 'Doctor Joseph von Satriani', id => 'JVSAT', }, checkout => sub { my $total = shift; ...; return $something }, shopcart => My::Cool::Shopping::Cart->new(), }; The Template Toolkit will automatically Do The Right Thing to access the data in an appropriate manner to return some value which can then be output. The dot operator 'C<.>' is used to access into lists and hashes or to call object methods. The C<FOREACH> directive is provided for iterating through lists, and various logical tests are available using directives such as C<IF>, C<UNLESS>, C<ELSIF>, C<ELSE>, C<SWITCH>, C<CASE>, etc. [% FOREACH section = menu %] <a href="[% root %]/[% section %]/index.html">[% section %]</a> [% END %] <b>Client</b>: [% client.name %] (id: [% client.id %]) [% IF shopcart.nitems %] Your shopping cart contains the following items: <ul> [% FOREACH item = shopcart.contents %] <li>[% item.name %] : [% item.qty %] @ [% item.price %] [% END %] </ul> [% checkout(shopcart.total) %] [% ELSE %] No items currently in shopping cart. [% END %] =head1 Advanced Features: Filters, Macros, Exceptions, Plugins The Template Toolkit also provides a number of additional directives for advanced processing and programmatical functionality. It supports output filters (FILTER), allows custom macros to be defined (MACRO), has a fully-featured exception handling system (TRY, THROW, CATCH, FINAL) and supports a plugin architecture (USE) which allows special plugin modules and even regular Perl modules to be loaded and used with the minimum of fuss. The Template Toolkit is "just" a template processor but you can trivially extend it to incorporate the functionality of any Perl module you can get your hands on. Thus, it is also a scalable and extensible template framework, ideally suited for managing the presentation layer for application servers, content management systems and other web applications. =head1 Separating Presentation and Application Logic Rather than embedding Perl code or some other scripting language directly into template documents, it encourages you to keep functional components (i.e. Perl code) separate from presentation components (e.g. HTML templates). The template variables provide the interface between the two layers, allowing data to be generated in code and then passed to a template component for displaying (pipeline model) or for sub-routine or object references to be bound to variables which can then be called from the template as and when required (callback model). The directives that the Template Toolkit provide implement their own mini programming language, but they're not really designed for serious, general purpose programming. Perl is a far more appropriate language for that. If you embed application logic (e.g. Perl or other scripting language fragments) in HTML templates then you risk losing the clear separation of concerns between functionality and presentation. It becomes harder to maintain the two elements in isolation and more difficult, if not impossible, to reuse code or presentation elements by themselves. It is far better to write your application code in separate Perl modules, libraries or scripts and then use templates to control how the resulting data is presented as output. Thus you should think of the Template Toolkit language as a set of layout directives for displaying data, not calculating it. Having said that, the Template Toolkit doesn't force you into one approach or the other. It attempts to be pragmatic rather than dogmatic in allowing you to do whatever best gets the job done. Thus, if you enable the EVAL_PERL option then you can happily embed real Perl code in your templates within PERL ... END directives. =head1 Performance The Template Toolkit uses a fast YACC-like parser which compiles templates into Perl code for maximum runtime efficiency. It also has an advanced caching mechanism which manages in-memory and on-disk (i.e. persistent) versions of compiled templates. The modules that comprise the toolkit are highly configurable and the architecture around which they're built is designed to be extensible. The Template Toolkit provides a powerful framework around which content creation and delivery systems can be built while also providing a simple interface through the Template front-end module for general use. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Manual/Internals.pod 0000444 00000043534 15125513451 0012577 0 ustar 00 #============================================================= -*-perl-*- # # Template::Manual::Internals # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Manual::Internals - Template Toolkit internals =head1 Introduction This section of the documentation is aimed at developers wishing to know more about how the Template Toolkit works on the inside in order to extend or adapt it to their own needs. If that doesn't sound like you then you probably don't need to read this. There is no test afterwards. =head1 Outside Looking In The L<Template> module is simply a front end module which creates and uses a L<Template::Service> and pipes the output wherever you want it to go (C<STDOUT> by default, or maybe a file, scalar, etc). The C<Apache::Template> module (available separately from CPAN) is another front end. That creates a C<Template::Service::Apache> object, calls on it as required and sends the output back to the relevant C<Apache::Request> object. These front-end modules are really only there to handle any specifics of the environment in which they're being used. The C<Apache::Template> front end, for example, handles C<Apache::Request> specifics and configuration via the F<httpd.conf>. The regular L<Template> front-end deals with C<STDOUT>, variable refs, etc. Otherwise it is L<Template::Service> (or subclass) which does all the work. The L<Template::Service> module provides a high-quality template delivery service, with bells, whistles, signed up service level agreement and a 30-day no quibble money back guarantee. "Have a good time, all the time", that's our motto. Within the lower levels of the Template Toolkit, there are lots of messy details that we generally don't want to have to worry about most of the time. Things like templates not being found, or failing to parse correctly, uncaught exceptions being thrown, missing plugin modules or dependencies, and so on. L<Template::Service> hides that all away and makes everything look simple to the outsider. It provides extra features, like C<PRE_PROCESS>, C<PROCESS> and C<POST_PROCESS>, and also provides the error recovery mechanism via C<ERROR>. You ask it to process a template and it takes care of everything for you. The C<Template::Service::Apache> module goes a little bit further, adding some extra headers to the L<Apache::Request>, setting a few extra template variables, and so on. For the most part, the job of a service is really just one of scheduling and dispatching. It receives a request in the form of a call to its L<process()|Template::Service#process()> method and schedules the named template specified as an argument, and possibly several other templates (C<PRE_PROCESS>, etc) to be processed in order. It doesn't actually process the templates itself, but instead makes a L<process()|Template::Context#process()> call against a L<Template::Context> object. L<Template::Context> is the runtime engine for the Template Toolkit - the module that hangs everything together in the lower levels of the Template Toolkit and that one that does most of the real work, albeit by crafty delegation to various other friendly helper modules. Given a template name (or perhaps a reference to a scalar or file handle) the context process() method must load and compile, or fetch a cached copy of a previously compiled template, corresponding to that name. It does this by calling on a list of one or more L<Template::Provider> objects (the C<LOAD_TEMPLATES> posse) who themselves might get involved with a L<Template::Parser> to help turn source templates into executable Perl code (but more on that later). Thankfully, all of this complexity is hidden away behind a simple L<template()|Template::Context#template()> method. You call it passing a template name as an argument, and it returns a compiled template in the form of a L<Template::Document> object, or otherwise raises an exception. A L<Template::Document> is a thin object wrapper around a compiled template subroutine. The object implements a L<process()|Template::Document#process()> method which performs a little bit of housekeeping and then calls the template subroutine. The object also defines template metadata (defined in C<[% META ... %]> directives) and has a L<block()|Template::Document#block()> method which returns a hash of any additional C<[% BLOCK xxxx %]> definitions found in the template source. So the context fetches a compiled document via its own L<template()|Template::Context#template()> method and then gets ready to process it. It first updates the stash (the place where template variables get defined - more on that shortly) to set any template variable definitions specified as the second argument by reference to hash array. Then, it calls the document L<process()|Template::Document#process()> method, passing a reference to itself, the context object, as an argument. In doing this, it provides itself as an object against which template code can make callbacks to access runtime resources and Template Toolkit functionality. What we're trying to say here is this: not only does the L<Template::Context> object receive calls from the I<outside>, i.e. those originating in user code calling the process() method on a Template object, but it also receives calls from the I<inside>, i.e. those originating in template directives of the form C<[% PROCESS template %]>. Before we move on to that, here's a simple structure diagram showing the outer layers of the Template Toolkit heading inwards, with pseudo code annotations showing a typical invocation sequence. ,--------. | Caller | use Template; `--------' my $tt = Template->new( ... ); | $tt->process($template, \%vars); | Outside - - - | - - - - - - - - - - - - - - - - - - - - - - - - - - - - T T | package Template; Inside V +----------+ sub process($template, \%vars) { | Template | $out = $self->SERVICE->process($template, $vars); +----------+ print $out or send it to $self->OUTPUT; | } | | package Template::Service; | | sub process($template, \%vars) { | try { +----------+ foreach $p in @self->PRE_PROCESS | Service | $self->CONTEXT->process($p, $vars); +----------+ | $self->CONTEXT->process($template, $vars); | | foreach $p @self->POST_PROCESS | $self->CONTEXT->process($p, $vars); | } | catch { | $self->CONTEXT->process($self->ERROR); | } | } | V package Template::Context; +----------+ | Context | sub process($template, \%vars) { +----------+ # fetch compiled template | $template = $self->template($template) | # update stash | $self->STASH->update($vars); | # process template | $template->process($self) | } V +----------+ package Template::Document; | Document | +----------+ sub process($context) { $output = &{ $self->BLOCK }($context); } =head1 Inside Looking Out To understand more about what's going on in these lower levels, we need to look at what a compiled template looks like. In fact, a compiled template is just a regular Perl sub-routine. Here's a very simple one. sub my_compiled_template { return "This is a compiled template.\n"; } You're unlikely to see a compiled template this simple unless you wrote it yourself but it is entirely valid. All a template subroutine is obliged to do is return some output (which may be an empty of course). If it can't for some reason, then it should raise an error via C<die()>. sub my_todo_template { die "This template not yet implemented\n"; } If it wants to get fancy, it can raise an error as a L<Template::Exception> object. An exception object is really just a convenient wrapper for the 'C<type>' and 'C<info>' fields. sub my_solilique_template { die (Template::Exception->new('yorrick', 'Fellow of infinite jest')); } Templates generally need to do a lot more than just generate static output or raise errors. They may want to inspect variable values, process another template, load a plugin, run a filter, and so on. Whenever a template subroutine is called, it gets passed a reference to a L<Template::Context> object. It is through this context object that template code can access the features of the Template Toolkit. We described earlier how the L<Template::Service> object calls on L<Template::Context> to handle a L<process()|Template::Context#process()> request from the I<outside>. We can make a similar request on a context to process a template, but from within the code of another template. This is a call from the I<inside>. sub my_process_template { my $context = shift; my $output = $context->process('header', { title => 'Hello World' }) . "\nsome content\n" . $context->process('footer'); } This is then roughly equivalent to a source template something like this: [% PROCESS header title = 'Hello World' %] some content [% PROCESS footer %] Template variables are stored in, and managed by a L<Template::Stash> object. This is a blessed hash array in which template variables are defined. The object wrapper provides L<get()|Template::Stash#get()> and L<set()|Template::Stash#set()> method which implement all the I<magical.variable.features> of the Template Toolkit. Each context object has its own stash, a reference to which can be returned by the appropriately named L<stash()|Template::Context#stash()> method. So to print the value of some template variable, or for example, to represent the following source template: <title>[% title %]</title> we might have a subroutine definition something like this: sub { my $context = shift; my $stash = $context->stash(); return '<title>' . $stash->get('title') . '</title>'; } The stash L<get()|Template::Stash#get()> method hides the details of the underlying variable types, automatically calling code references, checking return values, and performing other such tricks. If 'C<title>' happens to be bound to a subroutine then we can specify additional parameters as a list reference passed as the second argument to get(). [% title('The Cat Sat on the Mat') %] This translates to the stash call: $stash->get([ 'title', ['The Cat Sat on the Mat'] ]); Dotted compound variables can be requested by passing a single list reference to the C<get()> method in place of the variable name. Each pair of elements in the list should correspond to the variable name and reference to a list of arguments for each dot-delimited element of the variable. [% foo(1, 2).bar(3, 4).baz(5) %] is thus equivalent to $stash->get([ foo => [1,2], bar => [3,4], baz => [5] ]); If there aren't any arguments for an element, you can specify an empty, zero or null argument list. [% foo.bar %] $stash->get([ 'foo', 0, 'bar', 0 ]); The L<set()|Template::Stash#set()> method works in a similar way. It takes a variable name and a variable value which should be assigned to it. [% x = 10 %] $stash->set('x', 10); [% x.y = 10 %] $stash->set([ 'x', 0, 'y', 0 ], 10); So the stash gives us access to template variables and the context provides the higher level functionality. Alongside the L<process()|Template::Context#process()> method lies the L<include()|Template::Context#include()> method. Just as with the C<PROCESS> / C<INCLUDE> directives, the key difference is in variable localisation. Before processing a template, the C<process()> method simply updates the stash to set any new variable definitions, overwriting any existing values. In contrast, the C<include()> method creates a copy of the existing stash, in a process known as I<cloning> the stash, and then uses that as a temporary variable store. Any previously existing variables are still defined, but any changes made to variables, including setting the new variable values passed aas arguments will affect only the local copy of the stash (although note that it's only a shallow copy, so it's not foolproof). When the template has been processed, the C<include()> method restores the previous variable state by I<decloning> the stash. The context also provides an L<insert()|Template::Context#insert()> method to implement the C<INSERT> directive, but no C<wrapper()> method. This functionality can be implemented by rewriting the Perl code and calling C<include()>. [% WRAPPER foo -%] blah blah [% x %] [%- END %] $context->include('foo', { content => 'blah blah ' . $stash->get('x'), }); Other than the template processing methods C<process()>, C<include()> and C<insert()>, the context defines methods for fetching plugin objects, L<plugin()|Template::Context#plugin()>, and filters, L<filter()|Template::Context#filter()>. # TT USE directive [% USE foo = Bar(10) %] # equivalent Perl $stash->set('foo', $context->plugin('Bar', [10])); # TT FILTER block [% FILTER bar(20) %] blah blah blah [% END %] # equivalent Perl my $filter = $context->filter('bar', [20]); &$filter('blah blah blah'); Pretty much everything else you might want to do in a template can be done in Perl code. Things like C<IF>, C<UNLESS>, C<FOREACH> and so on all have direct counterparts in Perl. # TT IF directive [% IF msg %] Message: [% msg %] [% END %]; # equivalent Perl if ($stash->get('msg')) { $output .= 'Message: '; $output .= $stash->get('msg'); } The best way to get a better understanding of what's going on underneath the hood is to set the C<$Template::Parser::DEBUG> flag to a true value and start processing templates. This will cause the parser to print the generated Perl code for each template it compiles to C<STDERR>. You'll probably also want to set the C<$Template::Directive::PRETTY> option to have the Perl pretty-printed for human consumption. use Template; use Template::Parser; use Template::Directive; $Template::Parser::DEBUG = 1; $Template::Directive::PRETTY = 1; my $template = Template->new(); $template->process(\*DATA, { cat => 'dog', mat => 'log' }); __DATA__ The [% cat %] sat on the [% mat %] The output sent to C<STDOUT> remains as you would expect: The dog sat on the log The output sent to C<STDERR> would look something like this: compiled main template document block: sub { my $context = shift || die "template sub called without context\n"; my $stash = $context->stash; my $output = ''; my $error; eval { BLOCK: { $output .= "The "; $output .= $stash->get('cat'); $output .= " sat on the "; $output .= $stash->get('mat'); $output .= "\n"; } }; if ($@) { $error = $context->catch($@, \$output); die $error unless $error->type eq 'return'; } return $output; } =head1 Hacking on the Template Toolkit Please feel free to hack on the Template Toolkit. If you find a bug that needs fixing, if you have an idea for something that's missing, or you feel inclined to tackle something on the TODO list, then by all means go ahead and do it! If you're contemplating something non-trivial then you'll probably want to bring it up on the mailing list first to get an idea about the current state of play, find out if anyone's already working on it, and so on. The source code repository for the Template Toolkit is hosted at Github. https://github.com/abw/Template2 Clone the repository, make your changes, commit them, then send a pull request. Once you've made your changes, please remember to update the test suite by adding extra tests to one of the existing test scripts in the C<t> sub-directory, or by adding a new test script of your own. And of course, run C<make test> to ensure that all the tests pass with your new code. Don't forget that any files you do add will need to be added to the MANIFEST. Running C<make manifest> will do this for you, but you need to make sure you haven't got any other temporary files lying around that might also get added to it. Documentation is often something that gets overlooked but it's just as important as the code. If you're adding a new module, a plugin module, for example, then it's OK to include the POD documentation in with the module, but I<please> write it all in one piece at the end of the file, I<after> the code (just look at any other C<Template::*> module for an example). It's a religious issue, I know, but I have a strong distaste for POD documentation interspersed throughout the code. In my not-so-humble opinion, it makes both the code and the documentation harder to read (same kinda problem as embedding Perl in HTML). Then add a line to the Changes file giving a very brief description of what you've done. There's no need to go into detail here (save that for the commit message, comments in code or docuemtation where appropriate). Please also make sure you add your name to the lib/Template/Manual/Credits.pod file (if it isn't already there). Then commit your changes and send a pull request. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Manual/Plugins.pod 0000444 00000021525 15125513451 0012255 0 ustar 00 #============================================================= -*-perl-*- # # Template::Manual::Plugins # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Manual::Plugins - Standard plugins =head1 TEMPLATE TOOLKIT PLUGINS The following plugin modules are distributed with the Template Toolkit. Some of the plugins interface to external modules (detailed below) which should be downloaded from any CPAN site and installed before using the plugin. =head2 Assert New in 2.20! The L<Assert|Template::Plugin::Assert> plugin adds an C<assert> virtual method that you can use to catch undefined values. For example, consider this dotop: [% user.name %] If C<user.name> is an undefined value then TT will silently ignore the fact and print nothing. If you C<USE> the C<assert> plugin then you can add the C<assert> vmethod between the C<user> and C<name> elements, like so: [% user.assert.name %] Now, if C<user.name> is an undefined value, an exception will be thrown: assert error - undefined value for name =head2 CGI The L<CGI|Template::Plugin::CGI> plugin is a wrapper around Lincoln Stein's CGI.pm module. The plugin is distributed with the Template Toolkit (see L<Template::Plugin::CGI>) and the L<CGI> module itself is distributed with recent versions Perl, or is available from CPAN. [% USE CGI %] [% CGI.param('param_name') %] [% CGI.start_form %] [% CGI.popup_menu( Name => 'color', Values => [ 'Green', 'Brown' ] ) %] [% CGI.end_form %] =head2 Datafile Provides an interface to data stored in a plain text file in a simple delimited format. The first line in the file specifies field names which should be delimiter by any non-word character sequence. Subsequent lines define data using the same delimiter as in the first line. Blank lines and comments (lines starting '#') are ignored. See L<Template::Plugin::Datafile> for further details. /tmp/mydata: # define names for each field id : email : name : tel # here's the data fred : fred@here.com : Fred Smith : 555-1234 bill : bill@here.com : Bill White : 555-5678 example: [% USE userlist = datafile('/tmp/mydata') %] [% FOREACH user = userlist %] [% user.name %] ([% user.id %]) [% END %] =head2 Date The L<Date|Template::Plugin::Date> plugin provides an easy way to generate formatted time and date strings by delegating to the L<POSIX> C<strftime()> routine. See L<Template::Plugin::Date> and L<POSIX> for further details. [% USE date %] [% date.format %] # current time/date File last modified: [% date.format(template.modtime) %] =head2 Directory The L<Directory|Template::Plugin::Directory> plugin provides a simple interface to a directory and the files within it. See L<Template::Plugin::Directory> for further details. [% USE dir = Directory('/tmp') %] [% FOREACH file = dir.files %] # all the plain files in the directory [% END %] [% FOREACH file = dir.dirs %] # all the sub-directories [% END %] =head2 DBI The C<DBI> plugin is no longer distributed as part of the Template Toolkit (as of version 2.15). It is now available as a separate L<Template::DBI> distribution from CPAN. =head2 Dumper The L<Dumper|Template::Plugin::Dumper> plugin provides an interface to the Data::Dumper module. See L<Template::Plugin::Dumper> and L<Data::Dumper> for further details. [% USE dumper(indent=0, pad="<br>") %] [% dumper.dump(myvar, yourvar) %] =head2 File The L<File|Template::Plugin::File> plugin provides a general abstraction for files and can be used to fetch information about specific files within a filesystem. See L<Template::Plugin::File> for further details. [% USE File('/tmp/foo.html') %] [% File.name %] # foo.html [% File.dir %] # /tmp [% File.mtime %] # modification time =head2 Filter This module implements a base class plugin which can be subclassed to easily create your own modules that define and install new filters. package MyOrg::Template::Plugin::MyFilter; use Template::Plugin::Filter; use base qw( Template::Plugin::Filter ); sub filter { my ($self, $text) = @_; # ...mungify $text... return $text; } Example of use: # now load it... [% USE MyFilter %] # ...and use the returned object as a filter [% FILTER $MyFilter %] ... [% END %] See L<Template::Plugin::Filter> for further details. =head2 Format The L<Format|Template::Plugin::Format> plugin provides a simple way to format text according to a C<printf()>-like format. See L<Template::Plugin::Format> for further details. [% USE bold = format('<b>%s</b>') %] [% bold('Hello') %] =head2 GD The C<GD> plugins are no longer part of the core Template Toolkit distribution. They are now available from CPAN in a separate L<Template::GD> distribution. =head2 HTML The L<HTML|Template::Plugin::HTML> plugin is very basic, implementing a few useful methods for generating HTML. It is likely to be extended in the future or integrated with a larger project to generate HTML elements in a generic way. [% USE HTML %] [% HTML.escape("if (a < b && c > d) ..." %] [% HTML.attributes(border => 1, cellpadding => 2) %] [% HTML.element(table => { border => 1, cellpadding => 2 }) %] See L<Template::Plugin::HTML> for further details. =head2 Iterator The L<Iterator|Template::Plugin::Iterator> plugin provides a way to create a L<Template::Iterator> object to iterate over a data set. An iterator is created automatically by the C<FOREACH> directive and is aliased to the C<loop> variable. This plugin allows an iterator to be explicitly created with a given name, or the default plugin name, C<iterator>. See L<Template::Plugin::Iterator> for further details. [% USE iterator(list, args) %] [% FOREACH item = iterator %] [% '<ul>' IF iterator.first %] <li>[% item %] [% '</ul>' IF iterator.last %] [% END %] =head2 Pod This plugin provides an interface to the L<Pod::POM|Pod::POM> module which parses POD documents into an internal object model which can then be traversed and presented through the Template Toolkit. [% USE Pod(podfile) %] [% FOREACH head1 = Pod.head1; FOREACH head2 = head1/head2; ... END; END %] =head2 Scalar The Template Toolkit calls user-defined subroutines and object methods using Perl's array context by default. # TT2 calls object methods in array context by default [% object.method %] This plugin module provides a way for you to call subroutines and methods in scalar context. [% USE scalar %] # force it to use scalar context [% object.scalar.method %] # also works with subroutine references [% scalar.my_sub_ref %] =head2 String The L<String|Template::Plugin::String> plugin implements an object-oriented interface for manipulating strings. See L<Template::Plugin::String> for further details. [% USE String 'Hello' %] [% String.append(' World') %] [% msg = String.new('Another string') %] [% msg.replace('string', 'text') %] The string "[% msg %]" is [% msg.length %] characters long. =head2 Table The L<Table|Template::Plugin::Table> plugin allows you to format a list of data items into a virtual table by specifying a fixed number of rows or columns, with an optional overlap. See L<Template::Plugin::Table> for further details. [% USE table(list, rows=10, overlap=1) %] [% FOREACH item = table.col(3) %] [% item %] [% END %] =head2 URL The L<URL|Template::Plugin::URL> plugin provides a simple way of constructing URLs from a base part and a variable set of parameters. See L<Template::Plugin::URL> for further details. [% USE mycgi = url('/cgi-bin/bar.pl', debug=1) %] [% mycgi %] # ==> /cgi/bin/bar.pl?debug=1 [% mycgi(mode='submit') %] # ==> /cgi/bin/bar.pl?mode=submit&debug=1 =head2 Wrap The L<Wrap|Template::Plugin::Wrap> plugin uses the L<Text::Wrap> module to provide simple paragraph formatting. See L<Template::Plugin::Wrap> and L<Text::Wrap> for further details. [% USE wrap %] [% wrap(mytext, 40, '* ', ' ') %] # use wrap sub [% mytext FILTER wrap(40) -%] # or wrap FILTER The C<Text::Wrap> module is available from CPAN: http://www.cpan.org/modules/by-module/Text/ =head2 XML The C<XML::DOM>, C<XML::RSS>, C<XML::Simple> and C<XML::XPath> plugins are no longer distributed with the Template Toolkit as of version 2.15 They are now available in a separate L<Template::XML> distribution. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Manual/Filters.pod 0000444 00000033357 15125513451 0012252 0 ustar 00 #============================================================= -*-perl-*- # # Template::Manual::Filters # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =encoding latin1 =head1 NAME Template::Manual::Filters - Standard filters =head1 format(format) The C<format> filter takes a format string as a parameter (as per C<printf()>) and formats each line of text accordingly. [% FILTER format('<!-- %-40s -->') %] This is a block of text filtered through the above format. [% END %] Output: <!-- This is a block of text filtered --> <!-- through the above format. --> =head1 upper Folds the input to UPPER CASE. [% "hello world" FILTER upper %] Output: HELLO WORLD =head1 lower Folds the input to lower case. [% "Hello World" FILTER lower %] Output: hello world =head1 ucfirst Folds the first character of the input to UPPER CASE. [% "hello" FILTER ucfirst %] Output: Hello =head1 lcfirst Folds the first character of the input to lower case. [% "HELLO" FILTER lcfirst %] Output: hELLO =head1 trim Trims any leading or trailing whitespace from the input text. Particularly useful in conjunction with C<INCLUDE>, C<PROCESS>, etc., having the same effect as the C<TRIM> configuration option. [% INCLUDE myfile | trim %] =head1 collapse Collapse any whitespace sequences in the input text into a single space. Leading and trailing whitespace (which would be reduced to a single space) is removed, as per trim. [% FILTER collapse %] The cat sat on the mat [% END %] Output: The cat sat on the mat =head1 html Converts the characters C<E<lt>>, C<E<gt>>, C<&> and C<"> to C<<>, C<>>, C<&>, and C<"> respectively, protecting them from being interpreted as representing HTML tags or entities. [% FILTER html %] Binary "<=>" returns -1, 0, or 1 depending on... [% END %] Output: Binary "<=>" returns -1, 0, or 1 depending on... =head1 html_entity The C<html> filter is fast and simple but it doesn't encode the full range of HTML entities that your text may contain. The C<html_entity> filter uses either the C<Apache::Util> module (which is written in C and is therefore faster) or the C<HTML::Entities> module (written in Perl but equally as comprehensive) to perform the encoding. If one or other of these modules are installed on your system then the text will be encoded (via the C<escape_html()> or C<encode_entities()> subroutines respectively) to convert all extended characters into their appropriate HTML entities (e.g. converting 'C<?>' to 'C<é>'). If neither module is available on your system then an 'C<html_entity>' exception will be thrown reporting an appropriate message. If you want to force TT to use one of the above modules in preference to the other, then call either of the L<Template::Filters> class methods: L<use_html_entities()|Template::Filters/use_html_entities()> or L<use_apache_util()|Template::Filters/use_apache_util()>. use Template::Filters; Template::Filters->use_html_entities; For further information on HTML entity encoding, see L<http://www.w3.org/TR/REC-html40/sgml/entities.html>. =head1 xml Same as the C<html> filter, but adds C<'> which is the fifth XML built-in entity. =head1 html_para This filter formats a block of text into HTML paragraphs. A sequence of two or more newlines is used as the delimiter for paragraphs which are then wrapped in HTML C<E<lt>pE<gt>>...C<E<lt>/pE<gt>> tags. [% FILTER html_para %] The cat sat on the mat. Mary had a little lamb. [% END %] Output: <p> The cat sat on the mat. </p> <p> Mary had a little lamb. </p> =head1 html_break / html_para_break Similar to the html_para filter described above, but uses the HTML tag sequence C<E<lt>brE<gt>E<lt>brE<gt>> to join paragraphs. [% FILTER html_break %] The cat sat on the mat. Mary had a little lamb. [% END %] Output: The cat sat on the mat. <br> <br> Mary had a little lamb. =head1 html_line_break This filter replaces any newlines with C<E<lt>brE<gt>> HTML tags, thus preserving the line breaks of the original text in the HTML output. [% FILTER html_line_break %] The cat sat on the mat. Mary had a little lamb. [% END %] Output: The cat sat on the mat.<br> Mary had a little lamb.<br> =head1 uri This filter URI escapes the input text, converting any characters outside of the permitted URI character set (as defined by RFC 3986) into a C<%nn> hex escape. [% 'my file.html' | uri %] Output: my%20file.html The uri filter correctly encodes all reserved characters, including C<&>, C<@>, C</>, C<;>, C<:>, C<=>, C<+>, C<?> and C<$>. This filter is typically used to encode parameters in a URL that could otherwise be interpreted as part of the URL. Here's an example: [% path = 'http://tt2.org/example' back = '/other?foo=bar&baz=bam' title = 'Earth: "Mostly Harmless"' %] <a href="[% path %]?back=[% back | uri %]&title=[% title | uri %]"> The output generated is rather long so we'll show it split across two lines: <a href="http://tt2.org/example?back=%2Fother%3Ffoo%3Dbar%26 baz%3Dbam&title=Earth%3A%20%22Mostly%20Harmless%22"> Without the uri filter the output would look like this (also split across two lines). <a href="http://tt2.org/example?back=/other?foo=bar &baz=bam&title=Earth: "Mostly Harmless""> In this rather contrived example we've manage to generate both a broken URL (the repeated C<?> is not allowed) and a broken HTML element (the href attribute is terminated by the first C<"> after C<Earth: > leaving C<Mostly Harmless"> dangling on the end of the tag in precisely the way that harmless things shouldn't dangle). So don't do that. Always use the uri filter to encode your URL parameters. However, you should B<not> use the uri filter to encode an entire URL. <a href="[% page_url | uri %]"> # WRONG! This will incorrectly encode any reserved characters like C<:> and C</> and that's almost certainly not what you want in this case. Instead you should use the B<url> (note spelling) filter for this purpose. <a href="[% page_url | url %]"> # CORRECT Please note that this behaviour was changed in version 2.16 of the Template Toolkit. Prior to that, the uri filter did not encode the reserved characters, making it technically incorrect according to the RFC 2396 specification (since superceded by RFC2732 and RFC3986). So we fixed it in 2.16 and provided the url filter to implement the old behaviour of not encoding reserved characters. As of version 2.28 of the Template Toolkit, the C<uri> and L<url> filters use the unsafe character set defined by RFC3986. This means that certain characters ("(", ")", "*", "!", "'", and '"') are now deemed unsafe and will be escaped as hex character sequences. The ability to use the RFC3986 character set was added in 2.26 but not enabled by default; double quote was incorrectly deemed safe in 2.26 but correctly escaped in 2.27. If you want to enable the old behaviour then call the C<use_rfc2732()> method in L<Template::Filters> use Template::Filters Template::Filters->use_rfc2732; =head1 url The url filter is a less aggressive version of the uri filter. It encodes any characters outside of the permitted URI character set (as defined by RFC 2396) into C<%nn> hex escapes. However, unlike the uri filter, the url filter does B<not> encode the reserved characters C<&>, C<@>, C</>, C<;>, C<:>, C<=>, C<+>, C<?> and C<$>. =head1 indent(pad) Indents the text block by a fixed pad string or width. The 'C<pad>' argument can be specified as a string, or as a numerical value to indicate a pad width (spaces). Defaults to 4 spaces if unspecified. [% FILTER indent('ME> ') %] blah blah blah cabbages, rhubard, onions [% END %] Output: ME> blah blah blah ME> cabbages, rhubard, onions =head1 truncate(length,dots) Truncates the text block to the length specified, or a default length of 32. Truncated text will be terminated with 'C<...>' (i.e. the 'C<...>' falls inside the required length, rather than appending to it). [% FILTER truncate(21) %] I have much to say on this matter that has previously been said on more than one occasion. [% END %] Output: I have much to say... If you want to use something other than 'C<...>' you can pass that as a second argument. [% FILTER truncate(26, '…') %] I have much to say on this matter that has previously been said on more than one occasion. [% END %] Output: I have much to say… =head1 repeat(iterations) Repeats the text block for as many iterations as are specified (default: 1). [% FILTER repeat(3) %] We want more beer and we want more beer, [% END %] We are the more beer wanters! Output: We want more beer and we want more beer, We want more beer and we want more beer, We want more beer and we want more beer, We are the more beer wanters! =head1 remove(string) Searches the input text for any occurrences of the specified string and removes them. A Perl regular expression may be specified as the search string. [% "The cat sat on the mat" FILTER remove('\s+') %] Output: Thecatsatonthemat =head1 replace(search, replace) Similar to the remove filter described above, but taking a second parameter which is used as a replacement string for instances of the search string. [% "The cat sat on the mat" | replace('\s+', '_') %] Output: The_cat_sat_on_the_mat =head1 redirect(file, options) The C<redirect> filter redirects the output of the block into a separate file, specified relative to the C<OUTPUT_PATH> configuration item. [% FOREACH user IN myorg.userlist %] [% FILTER redirect("users/${user.id}.html") %] [% INCLUDE userinfo %] [% END %] [% END %] or more succinctly, using side-effect notation: [% FOREACH user IN myorg.userlist; INCLUDE userinfo FILTER redirect("users/${user.id}.html"); END %] A C<file> exception will be thrown if the C<OUTPUT_PATH> option is undefined. An optional C<binmode> argument can follow the filename to explicitly set the output file to binary mode. [% PROCESS my/png/generator FILTER redirect("images/logo.png", binmode=1) %] For backwards compatibility with earlier versions, a single true/false value can be used to set binary mode. [% PROCESS my/png/generator FILTER redirect("images/logo.png", 1) %] For the sake of future compatibility and clarity, if nothing else, we would strongly recommend you explicitly use the named C<binmode> option as shown in the first example. =head1 eval / evaltt The C<eval> filter evaluates the block as template text, processing any directives embedded within it. This allows template variables to contain template fragments, or for some method to be provided for returning template fragments from an external source such as a database, which can then be processed in the template as required. my $vars = { fragment => "The cat sat on the [% place %]", }; $template->process($file, $vars); The following example: [% fragment | eval %] is therefore equivalent to The cat sat on the [% place %] The C<evaltt> filter is provided as an alias for C<eval>. =head1 perl / evalperl The C<perl> filter evaluates the block as Perl code. The C<EVAL_PERL> option must be set to a true value or a C<perl> exception will be thrown. [% my_perl_code | perl %] In most cases, the C<[% PERL %]> ... C<[% END %]> block should suffice for evaluating Perl code, given that template directives are processed before being evaluate as Perl. Thus, the previous example could have been written in the more verbose form: [% PERL %] [% my_perl_code %] [% END %] as well as [% FILTER perl %] [% my_perl_code %] [% END %] The C<evalperl> filter is provided as an alias for C<perl> for backwards compatibility. =head1 stdout(options) The stdout filter prints the output generated by the enclosing block to C<STDOUT>. The C<binmode> option can be passed as either a named parameter or a single argument to set C<STDOUT> to binary mode (see the binmode perl function). [% PROCESS something/cool FILTER stdout(binmode=1) # recommended %] [% PROCESS something/cool FILTER stdout(1) # alternate %] The C<stdout> filter can be used to force C<binmode> on C<STDOUT>, or also inside C<redirect>, C<null> or C<stderr> blocks to make sure that particular output goes to C<STDOUT>. See the C<null> filter below for an example. =head1 stderr The stderr filter prints the output generated by the enclosing block to C<STDERR>. =head1 null The C<null> filter prints nothing. This is useful for plugins whose methods return values that you don't want to appear in the output. Rather than assigning every plugin method call to a dummy variable to silence it, you can wrap the block in a null filter: [% FILTER null; USE im = GD.Image(100,100); black = im.colorAllocate(0, 0, 0); red = im.colorAllocate(255,0, 0); blue = im.colorAllocate(0, 0, 255); im.arc(50,50,95,75,0,360,blue); im.fill(50,50,red); im.png | stdout(1); END; -%] Notice the use of the C<stdout> filter to ensure that a particular expression generates output to C<STDOUT> (in this case in binary mode). =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Manual/Config.pod 0000444 00000175425 15125513451 0012052 0 ustar 00 #============================================================= -*-perl-*- # # Template::Manual::Config # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Manual::Config - Configuration options =head1 Template Style and Parsing Options =head2 ENCODING The C<ENCODING> option specifies the template files' character encoding: my $template = Template->new({ ENCODING => 'utf8', }); A template which starts with a Unicode byte order mark (BOM) will have its encoding detected automatically. =head2 START_TAG, END_TAG The C<START_TAG> and C<END_TAG> options are used to specify character sequences or regular expressions that mark the start and end of inline template directives. The default values for C<START_TAG> and C<END_TAG> are 'C<[%>' and 'C<%]>' respectively, giving us the familiar directive style: [% example %] Any Perl regex characters can be used and therefore should be escaped (or use the Perl C<quotemeta> function) if they are intended to represent literal characters. my $template = Template->new({ START_TAG => quotemeta('<+'), END_TAG => quotemeta('+>'), }); Example: <+ INCLUDE foobar +> The C<TAGS> directive can also be used to set the C<START_TAG> and C<END_TAG> values on a per-template file basis. [% TAGS <+ +> %] =head2 OUTLINE_TAG The C<OUTLINE_TAG> option can be used to enable single-line "outline" directives. my $template = Template->new({ OUTLINE_TAG => '%%', }); This allows you to use both inline and outline tags like so: %% IF user Hello [% user.name %] %% END The C<OUTLINE_TAG> string (or regex) must appear at the start of a line. The directive continues until the end of the line. The newline character at the end of the line is considered to be the invisible end-of-directive marker and is removed. =head2 TAG_STYLE The C<TAG_STYLE> option can be used to set both C<START_TAG> and C<END_TAG> according to pre-defined tag styles. my $template = Template->new({ TAG_STYLE => 'star', }); Available styles are: template [% ... %] (default) template1 [% ... %] or %% ... %% (TT version 1) metatext %% ... %% (Text::MetaText) star [* ... *] (TT alternate) php <? ... ?> (PHP) asp <% ... %> (ASP) mason <% ... > (HTML::Mason) html <!-- ... --> (HTML comments) The C<outline> style uses the default markers for C<START_TAG> and C<END_TAG> (C<[%> and C<%]> respectively) and additionally defines C<OUTLINE_TAG> to be C<%%>. my $template = Template->new({ TAG_STYLE => 'outline', }); This allows you to use both inline and outline tags like so: %% IF user Hello [% user.name %] %% END Any values specified for C<START_TAG>, C<END_TAG> and/or C<OUTLINE_TAG> will override those defined by a C<TAG_STYLE>. The C<TAGS> directive may also be used to set a C<TAG_STYLE> [% TAGS html %] <!-- INCLUDE header --> =head2 PRE_CHOMP, POST_CHOMP Anything outside a directive tag is considered plain text and is generally passed through unaltered (but see the L<INTERPOLATE> option). This includes all whitespace and newlines characters surrounding directive tags. Directives that don't generate any output will leave gaps in the output document. Example: Foo [% a = 10 %] Bar Output: Foo Bar The C<PRE_CHOMP> and C<POST_CHOMP> options can help to clean up some of this extraneous whitespace. Both are disabled by default. my $template = Template->new({ PRE_CHOMP => 1, POST_CHOMP => 1, }); With C<PRE_CHOMP> set to C<1>, the newline and whitespace preceding a directive at the start of a line will be deleted. This has the effect of concatenating a line that starts with a directive onto the end of the previous line. Foo <----------. | ,---(PRE_CHOMP)----' | `-- [% a = 10 %] --. | ,---(POST_CHOMP)---' | `-> Bar With C<POST_CHOMP> set to C<1>, any whitespace after a directive up to and including the newline will be deleted. This has the effect of joining a line that ends with a directive onto the start of the next line. If C<PRE_CHOMP> or C<POST_CHOMP> is set to C<2>, all whitespace including any number of newline will be removed and replaced with a single space. This is useful for HTML, where (usually) a contiguous block of whitespace is rendered the same as a single space. With C<PRE_CHOMP> or C<POST_CHOMP> set to C<3>, all adjacent whitespace (including newlines) will be removed entirely. These values are defined as C<CHOMP_NONE>, C<CHOMP_ONE>, C<CHOMP_COLLAPSE> and C<CHOMP_GREEDY> constants in the L<Template::Constants> module. C<CHOMP_ALL> is also defined as an alias for C<CHOMP_ONE> to provide backwards compatibility with earlier version of the Template Toolkit. Additionally the chomp tag modifiers listed below may also be used for the C<PRE_CHOMP> and C<POST_CHOMP> configuration. my $template = Template->new({ PRE_CHOMP => '~', POST_CHOMP => '-', }); C<PRE_CHOMP> and C<POST_CHOMP> can be activated for individual directives by placing a 'C<->' immediately at the start and/or end of the directive. [% FOREACH user IN userlist %] [%- user -%] [% END %] This has the same effect as C<CHOMP_ONE> in removing all whitespace before or after the directive up to and including the newline. The template will be processed as if written: [% FOREACH user IN userlist %][% user %][% END %] To remove all whitespace including any number of newlines, use the ('C<~>') tilde character instead. [% FOREACH user IN userlist %] [%~ user ~%] [% END %] To collapse all whitespace to a single space, use the 'C<=>' equals sign character. [% FOREACH user IN userlist %] [%= user =%] [% END %] Here the template is processed as if written: [% FOREACH user IN userlist %] [% user %] [% END %] If you have C<PRE_CHOMP> or C<POST_CHOMP> set as configuration options then you can use the 'C<+>' plus sign to disable any chomping options (i.e. leave the whitespace intact) on a per-directive basis. [% FOREACH user IN userlist %] User: [% user +%] [% END %] With C<POST_CHOMP> set to C<CHOMP_ONE>, the above example would be parsed as if written: [% FOREACH user IN userlist %]User: [% user %] [% END %] For reference, the C<PRE_CHOMP> and C<POST_CHOMP> configuration options may be set to any of the following: Constant Value Tag Modifier ---------------------------------- CHOMP_NONE 0 + CHOMP_ONE 1 - CHOMP_COLLAPSE 2 = CHOMP_GREEDY 3 ~ =head2 TRIM The C<TRIM> option can be set to have any leading and trailing whitespace automatically removed from the output of all template files and C<BLOCK>s. By example, the following C<BLOCK> definition [% BLOCK foo %] Line 1 of foo [% END %] will be processed is as "C<\nLine 1 of foo\n>". When C<INCLUDE>d, the surrounding newlines will also be introduced. before [% INCLUDE foo %] after Generated output: before Line 1 of foo after With the C<TRIM> option set to any true value, the leading and trailing newlines (which count as whitespace) will be removed from the output of the C<BLOCK>. before Line 1 of foo after The C<TRIM> option is disabled (C<0>) by default. =head2 INTERPOLATE The C<INTERPOLATE> flag, when set to any true value will cause variable references in plain text (i.e. not surrounded by C<START_TAG> and C<END_TAG>) to be recognised and interpolated accordingly. my $template = Template->new({ INTERPOLATE => 1, }); Variables should be prefixed by a 'C<$>' dollar sign to identify them. Curly braces 'C<{>' and 'C<}>' can be used in the familiar Perl/shell style to explicitly scope the variable name where required. # INTERPOLATE => 0 <a href="http://[% server %]/[% help %]"> <img src="[% images %]/help.gif"></a> [% myorg.name %] # INTERPOLATE => 1 <a href="http://$server/$help"> <img src="$images/help.gif"></a> $myorg.name # explicit scoping with { } <img src="$images/${icon.next}.gif"> Note that a limitation in Perl's regex engine restricts the maximum length of an interpolated template to around 32 kilobytes or possibly less. Files that exceed this limit in size will typically cause Perl to dump core with a segmentation fault. If you routinely process templates of this size then you should disable C<INTERPOLATE> or split the templates in several smaller files or blocks which can then be joined backed together via C<PROCESS> or C<INCLUDE>. =head2 ANYCASE By default, directive keywords should be expressed in UPPER CASE. The C<ANYCASE> option can be set to allow directive keywords to be specified in any case. # ANYCASE => 0 (default) [% INCLUDE foobar %] # OK [% include foobar %] # ERROR [% include = 10 %] # OK, 'include' is a variable # ANYCASE => 1 [% INCLUDE foobar %] # OK [% include foobar %] # OK [% include = 10 %] # ERROR, 'include' is reserved word One side-effect of enabling C<ANYCASE> is that you cannot use a variable of the same name as a reserved word, regardless of case. The reserved words are currently: GET CALL SET DEFAULT INSERT INCLUDE PROCESS WRAPPER IF UNLESS ELSE ELSIF FOR FOREACH WHILE SWITCH CASE USE PLUGIN FILTER MACRO PERL RAWPERL BLOCK META TRY THROW CATCH FINAL NEXT LAST BREAK RETURN STOP CLEAR TO STEP AND OR NOT MOD DIV END The only lower case reserved words that cannot be used for variables, regardless of the C<ANYCASE> option, are the operators: and or not mod div =head1 Template Files and Blocks =head2 INCLUDE_PATH The C<INCLUDE_PATH> is used to specify one or more directories in which template files are located. When a template is requested that isn't defined locally as a C<BLOCK>, each of the C<INCLUDE_PATH> directories is searched in turn to locate the template file. Multiple directories can be specified as a reference to a list or as a single string where each directory is delimited by the 'C<:>' colon character. my $template = Template->new({ INCLUDE_PATH => '/usr/local/templates', }); my $template = Template->new({ INCLUDE_PATH => '/usr/local/templates:/tmp/my/templates', }); my $template = Template->new({ INCLUDE_PATH => [ '/usr/local/templates', '/tmp/my/templates' ], }); On Win32 systems, a little extra magic is invoked, ignoring delimiters that have 'C<:>' colon followed by a 'C</>' slash or 'C<\>' blackslash. This avoids confusion when using directory names like 'C<C:\Blah Blah>'. When specified as a list, the C<INCLUDE_PATH> path can contain elements which dynamically generate a list of C<INCLUDE_PATH> directories. These generator elements can be specified as a reference to a subroutine or an object which implements a C<paths()> method. my $template = Template->new({ INCLUDE_PATH => [ '/usr/local/templates', \&incpath_generator, My::IncPath::Generator->new( ... ) ], }); Each time a template is requested and the C<INCLUDE_PATH> examined, the subroutine or object method will be called. A reference to a list of directories should be returned. Generator subroutines should report errors using C<die()>. Generator objects should return undef and make an error available via its C<error()> method. For example: sub incpath_generator { # ...some code... if ($all_is_well) { return \@list_of_directories; } else { die "cannot generate INCLUDE_PATH...\n"; } } or: package My::IncPath::Generator; # Template::Base (or Class::Base) provides error() method use Template::Base; use base qw( Template::Base ); sub paths { my $self = shift; # ...some code... if ($all_is_well) { return \@list_of_directories; } else { return $self->error("cannot generate INCLUDE_PATH...\n"); } } 1; =head2 DELIMITER Used to provide an alternative delimiter character sequence for separating paths specified in the C<INCLUDE_PATH>. The default value for C<DELIMITER> is the 'C<:>' colon character. my $template = Template->new({ DELIMITER => '; ', INCLUDE_PATH => 'C:/HERE/NOW; D:/THERE/THEN', }); On Win32 systems, the default delimiter is a little more intelligent, splitting paths only on 'C<:>' colon characters that aren't followed by a 'C</>' slash character. This means that the following should work as planned, splitting the C<INCLUDE_PATH> into 2 separate directories, C<C:/foo> and C<C:/bar>. # on Win32 only my $template = Template->new({ INCLUDE_PATH => 'C:/Foo:C:/Bar' }); However, if you're using Win32 then it's recommended that you explicitly set the C<DELIMITER> character to something else (e.g. 'C<;>' semicolon) rather than rely on this subtle magic. =head2 ABSOLUTE The C<ABSOLUTE> flag is used to indicate if templates specified with absolute filenames (e.g. 'C</foo/bar>') should be processed. It is disabled by default and any attempt to load a template by such a name will cause a 'C<file>' exception to be raised. my $template = Template->new({ ABSOLUTE => 1, }); # this is why it's disabled by default [% INSERT /etc/passwd %] On Win32 systems, the regular expression for matching absolute pathnames is tweaked slightly to also detect filenames that start with a driver letter and colon, such as: C:/Foo/Bar =head2 RELATIVE The C<RELATIVE> flag is used to indicate if templates specified with filenames relative to the current directory (e.g. 'C<./foo/bar>' or 'C<../../some/where/else>') should be loaded. It is also disabled by default, and will raise a 'C<file>' error if such template names are encountered. my $template = Template->new({ RELATIVE => 1, }); [% INCLUDE ../logs/error.log %] =head2 DEFAULT The C<DEFAULT> option can be used to specify a default template which should be used whenever a specified template can't be found in the C<INCLUDE_PATH>. my $template = Template->new({ DEFAULT => 'notfound.html', }); If a non-existent template is requested through the Template L<process()|Template#process()> method, or by an C<INCLUDE>, C<PROCESS> or C<WRAPPER> directive, then the C<DEFAULT> template will instead be processed, if defined. Note that the C<DEFAULT> template is not used when templates are specified with absolute or relative filenames, or as a reference to a input file handle or text string. =head2 BLOCKS The C<BLOCKS> option can be used to pre-define a default set of template blocks. These should be specified as a reference to a hash array mapping template names to template text, subroutines or L<Template::Document> objects. my $template = Template->new({ BLOCKS => { header => 'The Header. [% title %]', footer => sub { return $some_output_text }, another => Template::Document->new({ ... }), }, }); =head2 VIEWS The VIEWS option can be used to define one or more L<Template::View> objects. They can be specified as a reference to a hash array or list reference. my $template = Template->new({ VIEWS => { my_view => { prefix => 'my_templates/' }, }, }); Be aware of the fact that Perl's hash array are unordered, so if you want to specify multiple views of which one or more are based on other views, then you should use a list reference to preserve the order of definition. my $template = Template->new({ VIEWS => [ bottom => { prefix => 'bottom/' }, middle => { prefix => 'middle/', base => 'bottom' }, top => { prefix => 'top/', base => 'middle' }, ], }); =head2 AUTO_RESET The C<AUTO_RESET> option is set by default and causes the local C<BLOCKS> cache for the L<Template::Context> object to be reset on each call to the Template L<process()|Template#process()> method. This ensures that any C<BLOCK>s defined within a template will only persist until that template is finished processing. This prevents C<BLOCK>s defined in one processing request from interfering with other independent requests subsequently processed by the same context object. The C<BLOCKS> item may be used to specify a default set of block definitions for the L<Template::Context> object. Subsequent C<BLOCK> definitions in templates will over-ride these but they will be reinstated on each reset if C<AUTO_RESET> is enabled (default), or if the L<Template::Context> L<reset()|Template::Context#reset()> method is called. =head2 RECURSION The template processor will raise a file exception if it detects direct or indirect recursion into a template. Setting this option to any true value will allow templates to include each other recursively. =head1 Template Variables =head2 VARIABLES The C<VARIABLES> option (or C<PRE_DEFINE> - they're equivalent) can be used to specify a hash array of template variables that should be used to pre-initialise the stash when it is created. These items are ignored if the C<STASH> item is defined. my $template = Template->new({ VARIABLES => { title => 'A Demo Page', author => 'Joe Random Hacker', version => 3.14, }, }; or my $template = Template->new({ PRE_DEFINE => { title => 'A Demo Page', author => 'Joe Random Hacker', version => 3.14, }, }; =head2 CONSTANTS The C<CONSTANTS> option can be used to specify a hash array of template variables that are compile-time constants. These variables are resolved once when the template is compiled, and thus don't require further resolution at runtime. This results in significantly faster processing of the compiled templates and can be used for variables that don't change from one request to the next. my $template = Template->new({ CONSTANTS => { title => 'A Demo Page', author => 'Joe Random Hacker', version => 3.14, }, }; =head2 CONSTANT_NAMESPACE Constant variables are accessed via the C<constants> namespace by default. [% constants.title %] The C<CONSTANTS_NAMESPACE> option can be set to specify an alternate namespace. my $template = Template->new({ CONSTANTS => { title => 'A Demo Page', # ...etc... }, CONSTANTS_NAMESPACE => 'const', }; In this case the constants would then be accessed as: [% const.title %] =head2 NAMESPACE The constant folding mechanism described above is an example of a namespace handler. Namespace handlers can be defined to provide alternate parsing mechanisms for variables in different namespaces. Under the hood, the L<Template> module converts a constructor configuration such as: my $template = Template->new({ CONSTANTS => { title => 'A Demo Page', # ...etc... }, CONSTANTS_NAMESPACE => 'const', }; into one like: my $template = Template->new({ NAMESPACE => { const => Template:::Namespace::Constants->new({ title => 'A Demo Page', # ...etc... }), }, }; You can use this mechanism to define multiple constant namespaces, or to install custom handlers of your own. my $template = Template->new({ NAMESPACE => { site => Template:::Namespace::Constants->new({ title => "Wardley's Widgets", version => 2.718, }), author => Template:::Namespace::Constants->new({ name => 'Andy Wardley', email => 'abw@andywardley.com', }), voodoo => My::Namespace::Handler->new( ... ), }, }; Now you have two constant namespaces, for example: [% site.title %] [% author.name %] as well as your own custom namespace handler installed for the 'voodoo' namespace. [% voodoo.magic %] See L<Template::Namespace::Constants> for an example of what a namespace handler looks like on the inside. =head1 Template Processing Options The following options are used to specify any additional templates that should be processed before, after, around or instead of the template passed as the first argument to the L<Template> L<process()|Template#process()> method. These options can be perform various useful tasks such as adding standard headers or footers to all pages, wrapping page output in other templates, pre-defining variables or performing initialisation or cleanup tasks, automatically generating page summary information, navigation elements, and so on. The task of processing the template is delegated internally to the L<Template::Service> module which, unsurprisingly, also has a L<process()|Template::Service#process()> method. Any templates defined by the C<PRE_PROCESS> option are processed first and any output generated is added to the output buffer. Then the main template is processed, or if one or more C<PROCESS> templates are defined then they are instead processed in turn. In this case, one of the C<PROCESS> templates is responsible for processing the main template, by a directive such as: [% PROCESS $template %] The output of processing the main template or the C<PROCESS> template(s) is then wrapped in any C<WRAPPER> templates, if defined. C<WRAPPER> templates don't need to worry about explicitly processing the template because it will have been done for them already. Instead C<WRAPPER> templates access the content they are wrapping via the C<content> variable. wrapper before [% content %] wrapper after This output generated from processing the main template, and/or any C<PROCESS> or C<WRAPPER> templates is added to the output buffer. Finally, any C<POST_PROCESS> templates are processed and their output is also added to the output buffer which is then returned. If the main template throws an exception during processing then any relevant template(s) defined via the C<ERROR> option will be processed instead. If defined and successfully processed, the output from the error template will be added to the output buffer in place of the template that generated the error and processing will continue, applying any C<WRAPPER> and C<POST_PROCESS> templates. If no relevant C<ERROR> option is defined, or if the error occurs in one of the C<PRE_PROCESS>, C<WRAPPER> or C<POST_PROCESS> templates, then the process will terminate immediately and the error will be returned. =head2 PRE_PROCESS, POST_PROCESS These values may be set to contain the name(s) of template files (relative to C<INCLUDE_PATH>) which should be processed immediately before and/or after each template. These do not get added to templates processed into a document via directives such as C<INCLUDE>, C<PROCESS>, C<WRAPPER> etc. my $template = Template->new({ PRE_PROCESS => 'header', POST_PROCESS => 'footer', }; Multiple templates may be specified as a reference to a list. Each is processed in the order defined. my $template = Template->new({ PRE_PROCESS => [ 'config', 'header' ], POST_PROCESS => 'footer', }; Alternately, multiple template may be specified as a single string, delimited by 'C<:>'. This delimiter string can be changed via the C<DELIMITER> option. my $template = Template->new({ PRE_PROCESS => 'config:header', POST_PROCESS => 'footer', }; The C<PRE_PROCESS> and C<POST_PROCESS> templates are evaluated in the same variable context as the main document and may define or update variables for subsequent use. config: [% # set some site-wide variables bgcolor = '#ffffff' version = 2.718 %] header: [% DEFAULT title = 'My Funky Web Site' %] <html> <head> <title>[% title %]</title> </head> <body bgcolor="[% bgcolor %]"> footer: <hr> Version [% version %] </body> </html> The L<Template::Document> object representing the main template being processed is available within C<PRE_PROCESS> and C<POST_PROCESS> templates as the C<template> variable. Metadata items defined via the C<META> directive may be accessed accordingly. $template->process('mydoc.html', $vars); mydoc.html: [% META title = 'My Document Title' %] blah blah blah ... header: <html> <head> <title>[% template.title %]</title> </head> <body bgcolor="[% bgcolor %]"> =head2 PROCESS The C<PROCESS> option may be set to contain the name(s) of template files (relative to C<INCLUDE_PATH>) which should be processed instead of the main template passed to the L<Template> L<process()|Template#process()> method. This can be used to apply consistent wrappers around all templates, similar to the use of C<PRE_PROCESS> and C<POST_PROCESS> templates. my $template = Template->new({ PROCESS => 'content', }; # processes 'content' instead of 'foo.html' $template->process('foo.html'); A reference to the original template is available in the C<template> variable. Metadata items can be inspected and the template can be processed by specifying it as a variable reference (i.e. prefixed by C<$>) to an C<INCLUDE>, C<PROCESS> or C<WRAPPER> directive. content: <html> <head> <title>[% template.title %]</title> </head> <body> <!-- begin content --> [% PROCESS $template %] <!-- end content --> <hr> © Copyright [% template.copyright %] </body> </html> foo.html: [% META title = 'The Foo Page' author = 'Fred Foo' copyright = '2000 Fred Foo' %] <h1>[% template.title %]</h1> Welcome to the Foo Page, blah blah blah output: <html> <head> <title>The Foo Page</title> </head> <body> <!-- begin content --> <h1>The Foo Page</h1> Welcome to the Foo Page, blah blah blah <!-- end content --> <hr> © Copyright 2000 Fred Foo </body> </html> =head2 WRAPPER The C<WRAPPER> option can be used to specify one or more templates which should be used to wrap around the output of the main page template. The main template is processed first (or any C<PROCESS> template(s)) and the output generated is then passed as the C<content> variable to the C<WRAPPER> template(s) as they are processed. my $template = Template->new({ WRAPPER => 'wrapper', }; # process 'foo' then wrap in 'wrapper' $template->process('foo', { message => 'Hello World!' }); wrapper: <wrapper> [% content %] </wrapper> foo: This is the foo file! Message: [% message %] The output generated from this example is: <wrapper> This is the foo file! Message: Hello World! </wrapper> You can specify more than one C<WRAPPER> template by setting the value to be a reference to a list of templates. The C<WRAPPER> templates will be processed in reverse order with the output of each being passed to the next (or previous, depending on how you look at it) as the 'content' variable. It sounds complicated, but the end result is that it just "Does The Right Thing" to make wrapper templates nest in the order you specify. my $template = Template->new({ WRAPPER => [ 'outer', 'inner' ], }; # process 'foo' then wrap in 'inner', then in 'outer' $template->process('foo', { message => 'Hello World!' }); outer: <outer> [% content %] </outer> inner: <inner> [% content %] </inner> The output generated is then: <outer> <inner> This is the foo file! Message: Hello World! </inner> </outer> One side-effect of the "inside-out" processing of the C<WRAPPER> configuration item (and also the C<WRAPPER> directive) is that any variables set in the template being wrapped will be visible to the template doing the wrapping, but not the other way around. You can use this to good effect in allowing page templates to set pre-defined values which are then used in the wrapper templates. For example, our main page template 'foo' might look like this: foo: [% page = { title = 'Foo Page' subtitle = 'Everything There is to Know About Foo' author = 'Frank Oliver Octagon' } %] <p> Welcome to the page that tells you everything about foo blah blah blah... </p> The C<foo> template is processed before the wrapper template meaning that the C<page> data structure will be defined for use in the wrapper template. wrapper: <html> <head> <title>[% page.title %]</title> </head> <body> <h1>[% page.title %]</h1> <h2>[% page.subtitle %]</h1> <h3>by [% page.author %]</h3> [% content %] </body> </html> It achieves the same effect as defining C<META> items which are then accessed via the C<template> variable (which you are still free to use within C<WRAPPER> templates), but gives you more flexibility in the type and complexity of data that you can define. =head2 ERROR The C<ERROR> (or C<ERRORS> if you prefer) configuration item can be used to name a single template or specify a hash array mapping exception types to templates which should be used for error handling. If an uncaught exception is raised from within a template then the appropriate error template will instead be processed. If specified as a single value then that template will be processed for all uncaught exceptions. my $template = Template->new({ ERROR => 'error.html' }); If the C<ERROR> item is a hash reference the keys are assumed to be exception types and the relevant template for a given exception will be selected. A C<default> template may be provided for the general case. Note that C<ERROR> can be pluralised to C<ERRORS> if you find it more appropriate in this case. my $template = Template->new({ ERRORS => { user => 'user/index.html', dbi => 'error/database', default => 'error/default', }, }); In this example, any C<user> exceptions thrown will cause the F<user/index.html> template to be processed, C<dbi> errors are handled by F<error/database> and all others by the F<error/default> template. Any C<PRE_PROCESS> and/or C<POST_PROCESS> templates will also be applied to these error templates. Note that exception types are hierarchical and a C<foo> handler will catch all C<foo.*> errors (e.g. C<foo.bar>, C<foo.bar.baz>) if a more specific handler isn't defined. Be sure to quote any exception types that contain periods to prevent Perl concatenating them into a single string (i.e. C<user.passwd> is parsed as C<'user'.'passwd'>). my $template = Template->new({ ERROR => { 'user.login' => 'user/login.html', 'user.passwd' => 'user/badpasswd.html', 'user' => 'user/index.html', 'default' => 'error/default', }, }); In this example, any template processed by the C<$template> object, or other templates or code called from within, can raise a C<user.login> exception and have the service redirect to the F<user/login.html> template. Similarly, a C<user.passwd> exception has a specific handling template, F<user/badpasswd.html>, while all other C<user> or C<user.*> exceptions cause a redirection to the F<user/index.html> page. All other exception types are handled by F<error/default>. Exceptions can be raised in a template using the C<THROW> directive, [% THROW user.login 'no user id: please login' %] or by calling the L<throw()|Template::Context#throw()> method on the current L<Template::Context> object, $context->throw('user.passwd', 'Incorrect Password'); $context->throw('Incorrect Password'); # type 'undef' or from Perl code by calling C<die()> with a L<Template::Exception> object, die (Template::Exception->new('user.denied', 'Invalid User ID')); or by simply calling L<die()> with an error string. This is automagically caught and converted to an exception of 'C<undef>' type which can then be handled in the usual way. die "I'm sorry Dave, I can't do that"; Note that the 'C<undef>' we're talking about here is a literal string rather than Perl's C<undef> used to represent undefined values. =head1 Template Runtime Options =head2 EVAL_PERL This flag is used to indicate if C<PERL> and/or C<RAWPERL> blocks should be evaluated. It is disabled by default and any C<PERL> or C<RAWPERL> blocks encountered will raise exceptions of type 'C<perl>' with the message 'C<EVAL_PERL not set>'. Note however that any C<RAWPERL> blocks should always contain valid Perl code, regardless of the C<EVAL_PERL> flag. The parser will fail to compile templates that contain invalid Perl code in C<RAWPERL> blocks and will throw a 'C<file>' exception. When using compiled templates (see L<Caching and Compiling Options>), the C<EVAL_PERL> has an affect when the template is compiled, and again when the templates is subsequently processed, possibly in a different context to the one that compiled it. If the C<EVAL_PERL> is set when a template is compiled, then all C<PERL> and C<RAWPERL> blocks will be included in the compiled template. If the C<EVAL_PERL> option isn't set, then Perl code will be generated which B<always> throws a 'C<perl>' exception with the message 'C<EVAL_PERL not set>' B<whenever> the compiled template code is run. Thus, you must have C<EVAL_PERL> set if you want your compiled templates to include C<PERL> and C<RAWPERL> blocks. At some point in the future, using a different invocation of the Template Toolkit, you may come to process such a pre-compiled template. Assuming the C<EVAL_PERL> option was set at the time the template was compiled, then the output of any C<RAWPERL> blocks will be included in the compiled template and will get executed when the template is processed. This will happen regardless of the runtime C<EVAL_PERL> status. Regular C<PERL> blocks are a little more cautious, however. If the C<EVAL_PERL> flag isn't set for the I<current> context, that is, the one which is trying to process it, then it will throw the familiar 'C<perl>' exception with the message, 'C<EVAL_PERL not set>'. Thus you can compile templates to include C<PERL> blocks, but optionally disable them when you process them later. Note however that it is possible for a C<PERL> block to contain a Perl "C<BEGIN { # some code }>" block which will always get run regardless of the runtime C<EVAL_PERL> status. Thus, if you set C<EVAL_PERL> when compiling templates, it is assumed that you trust the templates to Do The Right Thing. Otherwise you must accept the fact that there's no bulletproof way to prevent any included code from trampling around in the living room of the runtime environment, making a real nuisance of itself if it really wants to. If you don't like the idea of such uninvited guests causing a bother, then you can accept the default and keep C<EVAL_PERL> disabled. =head2 OUTPUT Default output location or handler. This may be specified as one of: a file name (relative to C<OUTPUT_PATH>, if defined, or the current working directory if not specified absolutely); a file handle (e.g. C<GLOB> or L<IO::Handle>) opened for writing; a reference to a text string to which the output is appended (the string isn't cleared); a reference to a subroutine which is called, passing the output text as an argument; as a reference to an array, onto which the content will be C<push()>ed; or as a reference to any object that supports the C<print()> method. This latter option includes the C<Apache::Request> object which is passed as the argument to Apache/mod_perl handlers. example 1 (file name): my $template = Template->new({ OUTPUT => "/tmp/foo", }); example 2 (text string): my $output = ''; my $template = Template->new({ OUTPUT => \$output, }); example 3 (file handle): open (TOUT, ">", $file) || die "$file: $!\n"; my $template = Template->new({ OUTPUT => \*TOUT, }); example 4 (subroutine): sub output { my $out = shift; print "OUTPUT: $out" } my $template = Template->new({ OUTPUT => \&output, }); example 5 (array reference): my $template = Template->new({ OUTPUT => \@output, }) example 6 (Apache/mod_perl handler): sub handler { my $r = shift; my $t = Template->new({ OUTPUT => $r, }); ... } The default C<OUTPUT> location be overridden by passing a third parameter to the L<Template> L<process()|Template#process()> method. This can be specified as any of the above argument types. $t->process($file, $vars, "/tmp/foo"); $t->process($file, $vars, \$output); $t->process($file, $vars, \*MYGLOB); $t->process($file, $vars, \@output); $t->process($file, $vars, $r); # Apache::Request ... =head2 OUTPUT_PATH The C<OUTPUT_PATH> allows a directory to be specified into which output files should be written. An output file can be specified by the C<OUTPUT> option, or passed by name as the third parameter to the L<Template> L<process()|Template#process()> method. my $template = Template->new({ INCLUDE_PATH => "/tmp/src", OUTPUT_PATH => "/tmp/dest", }); my $vars = { ... }; foreach my $file ('foo.html', 'bar.html') { $template->process($file, $vars, $file) || die $template->error(); } This example will read the input files F</tmp/src/foo.html> and F</tmp/src/bar.html> and write the processed output to F</tmp/dest/foo.html> and F</tmp/dest/bar.html>, respectively. =head2 STRICT By default the Template Toolkit will silently ignore the use of undefined variables (a bad design decision that I regret). When the C<STRICT> option is set, the use of any undefined variables or values will cause an exception to be throw. The exception will have a C<type> of C<var.undef> and a message of the form "undefined variable: xxx". my $template = Template->new( STRICT => 1 ); =head2 DEBUG The C<DEBUG> option can be used to enable debugging within the various different modules that comprise the Template Toolkit. The L<Template::Constants> module defines a set of C<DEBUG_XXXX> constants which can be combined using the logical OR operator, 'C<|>'. use Template::Constants qw( :debug ); my $template = Template->new({ DEBUG => DEBUG_PARSER | DEBUG_PROVIDER, }); For convenience, you can also provide a string containing a list of lower case debug options, separated by any non-word characters. my $template = Template->new({ DEBUG => 'parser, provider', }); The following C<DEBUG_XXXX> flags can be used: =over 4 =item DEBUG_SERVICE Enables general debugging messages for the L<Template::Service> module. =item DEBUG_CONTEXT Enables general debugging messages for the L<Template::Context> module. =item DEBUG_PROVIDER Enables general debugging messages for the L<Template::Provider> module. =item DEBUG_PLUGINS Enables general debugging messages for the L<Template::Plugins> module. =item DEBUG_FILTERS Enables general debugging messages for the L<Template::Filters> module. =item DEBUG_PARSER This flag causes the L<Template::Parser> to generate debugging messages that show the Perl code generated by parsing and compiling each template. =item DEBUG_UNDEF This option causes the Template Toolkit to throw an 'C<undef>' error whenever it encounters an undefined variable value. =item DEBUG_DIRS This option causes the Template Toolkit to generate comments indicating the source file, line and original text of each directive in the template. These comments are embedded in the template output using the format defined in the C<DEBUG_FORMAT> configuration item, or a simple default format if unspecified. For example, the following template fragment: Hello World would generate this output: ## input text line 1 : ## Hello ## input text line 2 : World ## World =item DEBUG_ALL Enables all debugging messages. =item DEBUG_CALLER This option causes all debug messages that aren't newline terminated to have the file name and line number of the caller appended to them. =back =head2 DEBUG_FORMAT The C<DEBUG_FORMAT> option can be used to specify a format string for the debugging messages generated via the C<DEBUG_DIRS> option described above. Any occurrences of C<$file>, C<$line> or C<$text> will be replaced with the current file name, line or directive text, respectively. Notice how the format is single quoted to prevent Perl from interpolating those tokens as variables. my $template = Template->new({ DEBUG => 'dirs', DEBUG_FORMAT => '<!-- $file line $line : [% $text %] -->', }); The following template fragment: [% foo = 'World' %] Hello [% foo %] would then generate this output: <!-- input text line 2 : [% foo = 'World' %] --> Hello <!-- input text line 3 : [% foo %] -->World The DEBUG directive can also be used to set a debug format within a template. [% DEBUG format '<!-- $file line $line : [% $text %] -->' %] =head1 Caching and Compiling Options =head2 CACHE_SIZE The L<Template::Provider> module caches compiled templates to avoid the need to re-parse template files or blocks each time they are used. The C<CACHE_SIZE> option is used to limit the number of compiled templates that the module should cache. By default, the C<CACHE_SIZE> is undefined and all compiled templates are cached. When set to any positive value, the cache will be limited to storing no more than that number of compiled templates. When a new template is loaded and compiled and the cache is full (i.e. the number of entries == C<CACHE_SIZE>), the least recently used compiled template is discarded to make room for the new one. The C<CACHE_SIZE> can be set to C<0> to disable caching altogether. my $template = Template->new({ CACHE_SIZE => 64, # only cache 64 compiled templates }); my $template = Template->new({ CACHE_SIZE => 0, # don't cache any compiled templates }); As well as caching templates as they are found, the L<Template::Provider> also implements negative caching to keep track of templates that are I<not> found. This allows the provider to quickly decline a request for a template that it has previously failed to locate, saving the effort of going to look for it again. This is useful when an C<INCLUDE_PATH> includes multiple providers, ensuring that the request is passed down through the providers as quickly as possible. =head2 STAT_TTL This value can be set to control how long the L<Template::Provider> will keep a template cached in memory before checking to see if the source template has changed. my $provider = Template::Provider->new({ STAT_TTL => 60, # one minute }); The default value is 1 (second). You'll probably want to set this to a higher value if you're running the Template Toolkit inside a persistent web server application (e.g. mod_perl). For example, set it to 60 and the provider will only look for changes to templates once a minute at most. However, during development (or any time you're making frequent changes to templates) you'll probably want to keep it set to a low value so that you don't have to wait for the provider to notice that your templates have changed. =head2 COMPILE_EXT From version 2 onwards, the Template Toolkit has the ability to compile templates to Perl code and save them to disk for subsequent use (i.e. cache persistence). The C<COMPILE_EXT> option may be provided to specify a filename extension for compiled template files. It is undefined by default and no attempt will be made to read or write any compiled template files. my $template = Template->new({ COMPILE_EXT => '.ttc', }); If C<COMPILE_EXT> is defined (and C<COMPILE_DIR> isn't, see below) then compiled template files with the C<COMPILE_EXT> extension will be written to the same directory from which the source template files were loaded. Compiling and subsequent reuse of templates happens automatically whenever the C<COMPILE_EXT> or C<COMPILE_DIR> options are set. The Template Toolkit will automatically reload and reuse compiled files when it finds them on disk. If the corresponding source file has been modified since the compiled version as written, then it will load and re-compile the source and write a new compiled version to disk. This form of cache persistence offers significant benefits in terms of time and resources required to reload templates. Compiled templates can be reloaded by a simple call to Perl's C<require()>, leaving Perl to handle all the parsing and compilation. This is a Good Thing. =head2 COMPILE_DIR The C<COMPILE_DIR> option is used to specify an alternate directory root under which compiled template files should be saved. my $template = Template->new({ COMPILE_DIR => '/tmp/ttc', }); The C<COMPILE_EXT> option may also be specified to have a consistent file extension added to these files. my $template1 = Template->new({ COMPILE_DIR => '/tmp/ttc', COMPILE_EXT => '.ttc1', }); my $template2 = Template->new({ COMPILE_DIR => '/tmp/ttc', COMPILE_EXT => '.ttc2', }); When C<COMPILE_EXT> is undefined, the compiled template files have the same name as the original template files, but reside in a different directory tree. Each directory in the C<INCLUDE_PATH> is replicated in full beneath the C<COMPILE_DIR> directory. This example: my $template = Template->new({ COMPILE_DIR => '/tmp/ttc', INCLUDE_PATH => '/home/abw/templates:/usr/share/templates', }); would create the following directory structure: /tmp/ttc/home/abw/templates/ /tmp/ttc/usr/share/templates/ Files loaded from different C<INCLUDE_PATH> directories will have their compiled forms save in the relevant C<COMPILE_DIR> directory. On Win32 platforms a filename may by prefixed by a drive letter and colon. e.g. C:/My Templates/header The colon will be silently stripped from the filename when it is added to the C<COMPILE_DIR> value(s) to prevent illegal filename being generated. Any colon in C<COMPILE_DIR> elements will be left intact. For example: # Win32 only my $template = Template->new({ DELIMITER => ';', COMPILE_DIR => 'C:/TT2/Cache', INCLUDE_PATH => 'C:/TT2/Templates;D:/My Templates', }); This would create the following cache directories: C:/TT2/Cache/C/TT2/Templates C:/TT2/Cache/D/My Templates =head1 Plugins and Filters =head2 PLUGINS The C<PLUGINS> options can be used to provide a reference to a hash array that maps plugin names to Perl module names. A number of standard plugins are defined (e.g. C<table>, C<format>, C<cgi>, etc.) which map to their corresponding C<Template::Plugin::*> counterparts. These can be redefined by values in the C<PLUGINS> hash. my $template = Template->new({ PLUGINS => { cgi => 'MyOrg::Template::Plugin::CGI', foo => 'MyOrg::Template::Plugin::Foo', bar => 'MyOrg::Template::Plugin::Bar', }, }); The recommended convention is to specify these plugin names in lower case. The Template Toolkit first looks for an exact case-sensitive match and then tries the lower case conversion of the name specified. [% USE Foo %] # look for 'Foo' then 'foo' If you define all your C<PLUGINS> with lower case names then they will be located regardless of how the user specifies the name in the USE directive. If, on the other hand, you define your C<PLUGINS> with upper or mixed case names then the name specified in the C<USE> directive must match the case exactly. The C<USE> directive is used to create plugin objects and does so by calling the L<plugin()|Template::Context#plugin()> method on the current L<Template::Context> object. If the plugin name is defined in the C<PLUGINS> hash then the corresponding Perl module is loaded via C<require()>. The context then calls the L<load()|Template::Plugin#load()> class method which should return the class name (default and general case) or a prototype object against which the L<new()|Template::Plugin#new()> method can be called to instantiate individual plugin objects. If the plugin name is not defined in the C<PLUGINS> hash then the C<PLUGIN_BASE> and/or C<LOAD_PERL> options come into effect. =head2 PLUGIN_BASE If a plugin is not defined in the C<PLUGINS> hash then the C<PLUGIN_BASE> is used to attempt to construct a correct Perl module name which can be successfully loaded. The C<PLUGIN_BASE> can be specified as a reference to an array of module namespaces, or as a single value which is automatically converted to a list. The default C<PLUGIN_BASE> value (C<Template::Plugin>) is then added to the end of this list. example 1: my $template = Template->new({ PLUGIN_BASE => 'MyOrg::Template::Plugin', }); [% USE Foo %] # => MyOrg::Template::Plugin::Foo or Template::Plugin::Foo example 2: my $template = Template->new({ PLUGIN_BASE => [ 'MyOrg::Template::Plugin', 'YourOrg::Template::Plugin' ], }); template: [% USE Foo %] # => MyOrg::Template::Plugin::Foo or YourOrg::Template::Plugin::Foo or Template::Plugin::Foo If you don't want the default C<Template::Plugin> namespace added to the end of the C<PLUGIN_BASE>, then set the C<$Template::Plugins::PLUGIN_BASE> variable to a false value before calling the L<new()|Template> L<Template#new()> constructor method. This is shown in the example below where the C<Foo> plugin is located as C<My::Plugin::Foo> or C<Your::Plugin::Foo> but not as C<Template::Plugin::Foo>. example 3: use Template::Plugins; $Template::Plugins::PLUGIN_BASE = ''; my $template = Template->new({ PLUGIN_BASE => [ 'My::Plugin', 'Your::Plugin' ], }); template: [% USE Foo %] # => My::Plugin::Foo or Your::Plugin::Foo =head2 LOAD_PERL If a plugin cannot be loaded using the C<PLUGINS> or C<PLUGIN_BASE> approaches then the provider can make a final attempt to load the module without prepending any prefix to the module path. This allows regular Perl modules (i.e. those that don't reside in the L<Template::Plugin> or some other such namespace) to be loaded and used as plugins. By default, the C<LOAD_PERL> option is set to C<0> and no attempt will be made to load any Perl modules that aren't named explicitly in the C<PLUGINS> hash or reside in a package as named by one of the C<PLUGIN_BASE> components. Plugins loaded using the C<PLUGINS> or C<PLUGIN_BASE> receive a reference to the current context object as the first argument to the L<new()|Template::Plugin#new()> constructor. Modules loaded using C<LOAD_PERL> are assumed to not conform to the plugin interface. They must provide a C<new()> class method for instantiating objects but it will not receive a reference to the context as the first argument. Plugin modules should provide a L<load()|Template::Plugin#load()> class method (or inherit the default one from the L<Template::Plugin> base class) which is called the first time the plugin is loaded. Regular Perl modules need not. In all other respects, regular Perl objects and Template Toolkit plugins are identical. If a particular Perl module does not conform to the common, but not unilateral, C<new()> constructor convention then a simple plugin wrapper can be written to interface to it. =head2 FILTERS The C<FILTERS> option can be used to specify custom filters which can then be used with the C<FILTER> directive like any other. These are added to the standard filters which are available by default. Filters specified via this option will mask any standard filters of the same name. The C<FILTERS> option should be specified as a reference to a hash array in which each key represents the name of a filter. The corresponding value should contain a reference to an array containing a subroutine reference and a flag which indicates if the filter is static (C<0>) or dynamic (C<1>). A filter may also be specified as a solitary subroutine reference and is assumed to be static. $template = Template->new({ FILTERS => { 'sfilt1' => \&static_filter, # static 'sfilt2' => [ \&static_filter, 0 ], # same as above 'dfilt1' => [ \&dyanamic_filter_factory, 1 ], }, }); Additional filters can be specified at any time by calling the L<define_filter()|Template::Context#define_filter()> method on the current L<Template::Context> object. The method accepts a filter name, a reference to a filter subroutine and an optional flag to indicate if the filter is dynamic. my $context = $template->context(); $context->define_filter('new_html', \&new_html); $context->define_filter('new_repeat', \&new_repeat, 1); Static filters are those where a single subroutine reference is used for all invocations of a particular filter. Filters that don't accept any configuration parameters (e.g. C<html>) can be implemented statically. The subroutine reference is simply returned when that particular filter is requested. The subroutine is called to filter the output of a template block which is passed as the only argument. The subroutine should return the modified text. sub static_filter { my $text = shift; # do something to modify $text... return $text; } The following template fragment: [% FILTER sfilt1 %] Blah blah blah. [% END %] is approximately equivalent to: &static_filter("\nBlah blah blah.\n"); Filters that can accept parameters (e.g. C<truncate>) should be implemented dynamically. In this case, the subroutine is taken to be a filter 'factory' that is called to create a unique filter subroutine each time one is requested. A reference to the current L<Template::Context> object is passed as the first parameter, followed by any additional parameters specified. The subroutine should return another subroutine reference (usually a closure) which implements the filter. sub dynamic_filter_factory { my ($context, @args) = @_; return sub { my $text = shift; # do something to modify $text... return $text; } } The following template fragment: [% FILTER dfilt1(123, 456) %] Blah blah blah [% END %] is approximately equivalent to: my $filter = &dynamic_filter_factory($context, 123, 456); &$filter("\nBlah blah blah.\n"); See the C<FILTER> directive for further examples. =head1 Customisation and Extension =head2 LOAD_TEMPLATES The C<LOAD_TEMPLATES> option can be used to provide a reference to a list of L<Template::Provider> objects or sub-classes thereof which will take responsibility for loading and compiling templates. my $template = Template->new({ LOAD_TEMPLATES => [ MyOrg::Template::Provider->new({ ... }), Template::Provider->new({ ... }), ], }); When a C<PROCESS>, C<INCLUDE> or C<WRAPPER> directive is encountered, the named template may refer to a locally defined C<BLOCK> or a file relative to the C<INCLUDE_PATH> (or an absolute or relative path if the appropriate C<ABSOLUTE> or C<RELATIVE> options are set). If a C<BLOCK> definition can't be found (see the L<Template::Context> L<template()|Template::Context#template()> method for a discussion of C<BLOCK> locality) then each of the C<LOAD_TEMPLATES> provider objects is queried in turn via the L<fetch()|Template::Provider#fetch()> method to see if it can supply the required template. Each provider can return a compiled template, an error, or decline to service the request in which case the responsibility is passed to the next provider. If none of the providers can service the request then a 'not found' error is returned. The same basic provider mechanism is also used for the C<INSERT> directive but it bypasses any C<BLOCK> definitions and doesn't attempt is to parse or process the contents of the template file. If C<LOAD_TEMPLATES> is undefined, a single default provider will be instantiated using the current configuration parameters. For example, the L<Template::Provider> C<INCLUDE_PATH> option can be specified in the L<Template> configuration and will be correctly passed to the provider's constructor method. my $template = Template->new({ INCLUDE_PATH => '/here:/there', }); =head2 LOAD_PLUGINS The C<LOAD_PLUGINS> options can be used to specify a list of provider objects (i.e. they implement the L<fetch()|Template::Plugins#fetch()> method) which are responsible for loading and instantiating template plugin objects. The L<Template::Context> L<plugin()|Template::Context#plugin()> method queries each provider in turn in a "Chain of Responsibility" as per the L<template()|Template::Context#template()> and L<filter()|Template::Context#filter()> methods. my $template = Template->new({ LOAD_PLUGINS => [ MyOrg::Template::Plugins->new({ ... }), Template::Plugins->new({ ... }), ], }); By default, a single L<Template::Plugins> object is created using the current configuration hash. Configuration items destined for the L<Template::Plugins> constructor may be added to the Template constructor. my $template = Template->new({ PLUGIN_BASE => 'MyOrg::Template::Plugins', LOAD_PERL => 1, }); =head2 LOAD_FILTERS The C<LOAD_FILTERS> option can be used to specify a list of provider objects (i.e. they implement the L<fetch()|Template::Filters#fetch()> method) which are responsible for returning and/or creating filter subroutines. The L<Template::Context> L<filter()|Template::Context#filter()> method queries each provider in turn in a "Chain of Responsibility" as per the L<template()|Template::Context#template()> and L<plugin()|Template::Context#plugin()> methods. my $template = Template->new({ LOAD_FILTERS => [ MyTemplate::Filters->new(), Template::Filters->new(), ], }); By default, a single L<Template::Filters> object is created for the C<LOAD_FILTERS> list. =head2 TOLERANT The C<TOLERANT> flag is used by the various Template Toolkit provider modules (L<Template::Provider>, L<Template::Plugins>, L<Template::Filters>) to control their behaviour when errors are encountered. By default, any errors are reported as such, with the request for the particular resource (C<template>, C<plugin>, C<filter>) being denied and an exception raised. When the C<TOLERANT> flag is set to any true values, errors will be silently ignored and the provider will instead return C<STATUS_DECLINED>. This allows a subsequent provider to take responsibility for providing the resource, rather than failing the request outright. If all providers decline to service the request, either through tolerated failure or a genuine disinclination to comply, then a 'C<E<lt>resourceE<gt> not found>' exception is raised. =head2 SERVICE A reference to a L<Template::Service> object, or sub-class thereof, to which the L<Template> module should delegate. If unspecified, a L<Template::Service> object is automatically created using the current configuration hash. my $template = Template->new({ SERVICE => MyOrg::Template::Service->new({ ... }), }); =head2 CONTEXT A reference to a L<Template::Context> object which is used to define a specific environment in which template are processed. A L<Template::Context> object is passed as the only parameter to the Perl subroutines that represent "compiled" template documents. Template subroutines make callbacks into the context object to access Template Toolkit functionality, for example, to C<INCLUDE> or C<PROCESS> another template (L<include()|Template::Context#include()> and L<process()|Template::Context#process()> methods, respectively), to C<USE> a plugin (L<plugin()|Template::Context#plugin()>) or instantiate a filter (L<filter()|Template::Context#filter()>) or to access the stash (L<stash()|Template::Context#stash()>) which manages variable definitions via the L<get()|Template::Stash#get()> and L<set()|Template::Stash#set()> methods. my $template = Template->new({ CONTEXT => MyOrg::Template::Context->new({ ... }), }); =head2 STASH A reference to a L<Template::Stash> object or sub-class which will take responsibility for managing template variables. my $stash = MyOrg::Template::Stash->new({ ... }); my $template = Template->new({ STASH => $stash, }); If unspecified, a default stash object is created using the C<VARIABLES> configuration item to initialise the stash variables. my $template = Template->new({ VARIABLES => { id => 'abw', name => 'Andy Wardley', }, }; =head2 PARSER The L<Template::Parser> module implements a parser object for compiling templates into Perl code which can then be executed. A default object of this class is created automatically and then used by the L<Template::Provider> whenever a template is loaded and requires compilation. The C<PARSER> option can be used to provide a reference to an alternate parser object. my $template = Template->new({ PARSER => MyOrg::Template::Parser->new({ ... }), }); =head2 GRAMMAR The C<GRAMMAR> configuration item can be used to specify an alternate grammar for the parser. This allows a modified or entirely new template language to be constructed and used by the Template Toolkit. Source templates are compiled to Perl code by the L<Template::Parser> using the L<Template::Grammar> (by default) to define the language structure and semantics. Compiled templates are thus inherently "compatible" with each other and there is nothing to prevent any number of different template languages being compiled and used within the same Template Toolkit processing environment (other than the usual time and memory constraints). The L<Template::Grammar> file is constructed from a YACC like grammar (using C<Parse::YAPP>) and a skeleton module template. These files are provided, along with a small script to rebuild the grammar, in the F<parser> sub-directory of the distribution. You don't have to know or worry about these unless you want to hack on the template language or define your own variant. There is a F<README> file in the same directory which provides some small guidance but it is assumed that you know what you're doing if you venture herein. If you grok LALR parsers, then you should find it comfortably familiar. By default, an instance of the default L<Template::Grammar> will be created and used automatically if a C<GRAMMAR> item isn't specified. use MyOrg::Template::Grammar; my $template = Template->new({ GRAMMAR = MyOrg::Template::Grammar->new(); }); =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Manual/Syntax.pod 0000444 00000021735 15125513451 0012125 0 ustar 00 #============================================================= -*-perl-*- # # Template::Manual::Syntax # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Manual::Syntax - Directive syntax, structure and semantics =head1 Tag Styles Template directives are embedded between start and end markers tags. By default these tag markers are C<[%> and C<%]>. [% PROCESS header %] <h1>Hello World!</h1> <a href="[% page.next %]"><img src="[% icon.next %].gif"></a> [% PROCESS footer %] You can change the tag characters using the C<START_TAG>, C<END_TAG> and C<TAG_STYLE> configuration options. You can also use the C<TAGS> directive to define a new tag style for the current template file. You can also set the C<INTERPOLATE> option to allow simple variable references to be embedded directly in templates, prefixed by a C<$>. # INTERPOLATE = 0 <td>[% name %]</td> <td>[% email %]</td> # INTERPOLATE = 1 <td>$name</td> <td>$email</td> Directives may be embedded anywhere in a line of text and can be split across several lines. Insignificant whitespace is generally ignored within the directive. [% INCLUDE header title = 'Hello World' bgcol = '#ffffff' %] [%INCLUDE menu align='right'%] Name: [% name %] ([%id%]) =head1 Outline Tags As of version 2.26, the Template Toolkit supports "outline" tags. These have a designated marker at the start of a line (C<%%> by default) and continue to the end of a line. The newline character at the end of the line is discarded (aka "chomped"). So rather than writing something like this: [% IF some.list.size -%] <ul> [% FOREACH item IN some.list -%] <li>[% item.html %]</li> [% END -%] </ul> [% END -%] You can write it like this instead: %% IF some.list.size <ul> %% FOREACH item IN some.list <li>[% item.html %]</li> %% END </ul> %% END Outline tags aren't enabled by default. There are a numbers of ways you can enable them. The first is to use the C<TAGS> directive to set the tag style to C<outline> in any templates where you want to use them. This will enable outline tags from that point on. [% TAGS outline -%] %% INCLUDE header You can set the C<TAGS> back to the C<default> value at some point later in the template if you want to disable them: [% TAGS default -%] You can set the C<TAG_STYLE> configuration option if you want then enabled in all templates by default. You can always use the C<[% TAGS default %]> directive to disable them in any templates or parts of templates if necessary. my $tt = Template->new({ TAG_STYLE => 'outline', }); The C<OUTLINE_TAG> option allows you to set the outline tag marker to something else if you're not a fan of percent signs. Setting this option will automatically enable outline tags. my $tt = Template->new({ OUTLINE_TAG => '>>', }); You can also use the C<TAGS> directive to define your own custom tags (start, end and now optionally, outline) for a template or part of a template. [% TAGS <* *> >> %] >> INCLUDE header # outline tag Hello <* name *> # inline tag If you only specify a start and end tag then outline tags will be disabled. [% TAGS <* *> %] # no outline tags =head1 Comments The C<#> character is used to indicate comments within a directive. When placed immediately inside the opening directive tag, it causes the entire directive to be ignored. [%# this entire directive is ignored no matter how many lines it wraps onto %] In any other position, it causes the remainder of the current line to be treated as a comment. [% # this is a comment theta = 20 # so is this rho = 30 # <aol>me too!</aol> %] =head1 Chomping Whitespace You can add C<-> or C<+> to the immediate start or end of a directive tag to control the whitespace chomping options. See the C<PRE_CHOMP> and C<POST_CHOMP> options for further details. [% BLOCK foo -%] # remove trailing newline This is block foo [%- END %] # remove leading newline =head1 Implicit Directives: GET and SET The simplest directives are C<GET> and C<SET> which retrieve and update variable values respectively. The C<GET> and C<SET> keywords are actually optional as the parser is smart enough to see them for what they really are (but note the caveat below on using side-effect notation). Thus, you'll generally see: [% SET foo = 10 %] [% GET foo %] written as: [% foo = 10 %] [% foo %] You can also express simple logical statements as implicit C<GET> directives: [% title or template.title or 'Default Title' %] [% mode == 'graphics' ? "Graphics Mode Enabled" : "Text Mode" %] All other directives should start with a keyword specified in UPPER CASE (but see the C<ANYCASE> option). All directives keywords are in UPPER CASE to make them visually distinctive and to distinguish them from variables of the same name but different case. It is perfectly valid, for example, to define a variable called C<stop> which is entirely separate from the C<STOP> directive. [% stop = 'Clackett Lane Bus Depot' %] The bus will next stop at [% stop %] # variable [% STOP %] # directive =head1 Block Directives Directives such as C<FOREACH>, C<WHILE>, C<BLOCK>, C<FILTER>, etc., mark the start of a block which may contain text or other directives up to the matching C<END> directive. Blocks may be nested indefinitely. The C<IF>, C<UNLESS>, C<ELSIF> and C<ELSE> directives also define blocks and may be grouped together in the usual manner. [% FOREACH item = [ 'foo' 'bar' 'baz' ] %] * Item: [% item %] [% END %] [% BLOCK footer %] Copyright 2000 [% me %] [% INCLUDE company/logo %] [% END %] [% IF foo %] [% FOREACH thing = foo.things %] [% thing %] [% END %] [% ELSIF bar %] [% INCLUDE barinfo %] [% ELSE %] do nothing... [% END %] Block directives can also be used in a convenient side-effect notation. [% INCLUDE userinfo FOREACH user = userlist %] [% INCLUDE debugtxt msg="file: $error.info" IF debugging %] [% "Danger Will Robinson" IF atrisk %] versus: [% FOREACH user = userlist %] [% INCLUDE userinfo %] [% END %] [% IF debugging %] [% INCLUDE debugtxt msg="file: $error.info" %] [% END %] [% IF atrisk %] Danger Will Robinson [% END %] =head1 Capturing Block Output The output of a directive can be captured by simply assigning the directive to a variable. [% headtext = PROCESS header title="Hello World" %] [% people = PROCESS userinfo FOREACH user = userlist %] This can be used in conjunction with the C<BLOCK> directive for defining large blocks of text or other content. [% poem = BLOCK %] The boy stood on the burning deck, His fleece was white as snow. A rolling stone gathers no moss, And Keith is sure to follow. [% END %] Note one important caveat of using this syntax in conjunction with side-effect notation. The following directive does not behave as might be expected: [% var = 'value' IF some_condition %] # does not work In this case, the directive is interpreted as (spacing added for clarity) [% var = IF some_condition %] value [% END %] rather than [% IF some_condition %] [% var = 'value' %] [% END %] The variable is assigned the output of the C<IF> block which returns C<'value'> if true, but nothing if false. In other words, the following directive will always cause 'var' to be cleared. [% var = 'value' IF 0 %] To achieve the expected behaviour, the directive should be written as: [% SET var = 'value' IF some_condition %] =head1 Chaining Filters Multiple C<FILTER> directives can be chained together in sequence. They are called in the order defined, piping the output of one into the input of the next. [% PROCESS somefile FILTER truncate(100) FILTER html %] The pipe character, C<|>, can also be used as an alias for C<FILTER>. [% PROCESS somefile | truncate(100) | html %] =head1 Multiple Directive Blocks Multiple directives can be included within a single tag when delimited by semi-colons. Note however that the C<TAGS> directive must always be specified in a tag by itself. [% IF title; INCLUDE header; ELSE; INCLUDE other/header title="Some Other Title"; END %] versus [% IF title %] [% INCLUDE header %] [% ELSE %] [% INCLUDE other/header title="Some Other Title" %] [% END %] =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Manual/Variables.pod 0000444 00000061065 15125513451 0012547 0 ustar 00 #============================================================= -*-perl-*- # # Template::Manual::Variables # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Manual::Variables - Template variables and code bindings =head1 Template Variables A reference to a hash array may be passed as the second argument to the L<process()|Template#process()> method, containing definitions of template variables. The C<VARIABLES> (a.k.a. C<PRE_DEFINE>) option can also be used to pre-define variables for all templates processed by the object. my $tt = Template->new({ VARIABLES => { version => 3.14, release => 'Sahara', }, }); my $vars = { serial_no => 271828, }; $tt->process('myfile', $vars); F<myfile> template: This is version [% version %] ([% release %]). Serial number: [% serial_no %] Generated Output: This is version 3.14 (Sahara) Serial number: 271828 Variable names may contain any alphanumeric characters or underscores. They may be lower, upper or mixed case although the usual convention is to use lower case. The case I<is> significant however, and 'C<foo>', 'C<Foo>' and 'C<FOO>' are all different variables. Upper case variable names are permitted, but not recommended due to a possible conflict with an existing or future reserved word. As of version 2.00, these are: GET CALL SET DEFAULT INSERT INCLUDE PROCESS WRAPPER IF UNLESS ELSE ELSIF FOR FOREACH WHILE SWITCH CASE USE PLUGIN FILTER MACRO PERL RAWPERL BLOCK META TRY THROW CATCH FINAL NEXT LAST BREAK RETURN STOP CLEAR TO STEP AND OR NOT MOD DIV END The variable values may be of virtually any Perl type, including simple scalars, references to lists, hash arrays, subroutines or objects. The Template Toolkit will automatically apply the correct procedure to accessing these values as they are used in the template. Example data: my $vars = { article => 'The Third Shoe', person => { id => 314, name => 'Mr. Blue', email => 'blue@nowhere.org', }, primes => [ 2, 3, 5, 7, 11, 13 ], wizard => sub { return join(' ', 'Abracadabra!', @_) }, cgi => CGI->new('mode=submit&debug=1'), }; Example template: [% article %] [% person.id %]: [% person.name %] <[% person.email %]> [% primes.first %] - [% primes.last %], including [% primes.3 %] [% primes.size %] prime numbers: [% primes.join(', ') %] [% wizard %] [% wizard('Hocus Pocus!') %] [% cgi.param('mode') %] Generated output: The Third Shoe 314: Mr. Blue <blue@nowhere.org> 2 - 13, including 7 6 prime numbers: 2, 3, 5, 7, 11, 13 Abracadabra! Abracadabra! Hocus Pocus! submit =head2 Scalar Values Regular scalar variables are accessed by simply specifying their name. As these are just entries in the top-level variable hash they can be considered special cases of hash array referencing as described below, with the main namespace hash automatically implied. [% article %] =head2 Hash Array References Members of hash arrays are accessed by specifying the hash reference and key separated by the dot 'C<.>' operator. Example data: my $vars = { 'home' => 'http://www.myserver.com/homepage.html', 'page' => { 'this' => 'mypage.html', 'next' => 'nextpage.html', 'prev' => 'prevpage.html', }, }; Example template: <a href="[% home %]">Home</a> <a href="[% page.prev %]">Previous Page</a> <a href="[% page.next %]">Next Page</a> Generated output: <a href="http://www.myserver.com/homepage.html">Home</a> <a href="prevpage.html">Previous Page</a> <a href="nextpage.html">Next Page</a> Any key in a hash which starts with a 'C<_>' or 'C<.>' character will be considered private and cannot be evaluated or updated from within a template. The undefined value will be returned for any such variable accessed which the Template Toolkit will silently ignore (unless the C<DEBUG> option is enabled). Example data: my $vars = { message => 'Hello World!', _secret => "On the Internet, no-one knows you're a dog", thing => { public => 123, _private => 456, '.hidden' => 789, }, }; Example template: [% message %] # outputs "Hello World!" [% _secret %] # no output [% thing.public %] # outputs "123" [% thing._private %] # no output [% thing..hidden %] # ERROR: unexpected token (..) You can disable this feature by setting the C<$Template::Stash::PRIVATE> package variable to a false value. $Template::Stash::PRIVATE = undef; # now you can thing._private To access a hash entry using a key stored in another variable, prefix the key variable with 'C<$>' to have it interpolated before use (see L<Variable Interpolation>). [% pagename = 'next' %] [% page.$pagename %] # same as [% page.next %] You can also access hash entry using C<item()> method. This might be helpful if you have complex key name. <pre> [% files.item('example.txt').content %] </pre> See L<Template::Manual::VMethods|Template::Manual::VMethods/"item"> for more info. When you assign to a variable that contains multiple namespace elements (i.e. it has one or more 'C<.>' characters in the name), any hashes required to represent intermediate namespaces will be created automatically. In this following example, the C<product> variable automatically springs into life as a hash array unless otherwise defined. [% product.id = 'XYZ-2000' product.desc = 'Bogon Generator' product.price = 666 %] The [% product.id %] [% product.desc %] costs $[% product.price %].00 Generated output: The XYZ-2000 Bogon Generator costs $666.00 You can use Perl's familiar C<{> ... C<}> construct to explicitly create a hash and assign it to a variable. Note that commas are optional between key/value pairs and C<=> can be used in place of C<=E<gt>>. # minimal TT style [% product = { id = 'XYZ-2000' desc = 'Bogon Generator' price = 666 } %] # perl style [% product = { id => 'XYZ-2000', desc => 'Bogon Generator', price => 666, } %] =head2 List References Items in lists are also accessed by use of the dot operator. Example data: my $vars = { people => [ 'Tom', 'Dick', 'Larry' ], }; Example template: [% people.0 %] # Tom [% people.1 %] # Dick [% people.2 %] # Larry The C<FOREACH> directive can be used to iterate through items in a list. [% FOREACH person IN people %] Hello [% person %] [% END %] Generated output: Hello Tom Hello Dick Hello Larry Lists can be constructed in-situ using the regular anonymous list C<[> ... C<]> construct. Commas between items are optional. [% cols = [ 'red', 'green', 'blue' ] %] [% FOREACH c IN cols %] [% c %] [% END %] or: [% FOREACH c IN [ 'red', 'green', 'blue' ] %] [% c %] [% END %] You can also create simple numerical sequences using the C<..> range operator: [% n = [ 1 .. 4 ] %] # n is [ 1, 2, 3, 4 ] [% x = 4 y = 8 z = [x..y] # z is [ 4, 5, 6, 7, 8 ] %] =head2 Subroutines Template variables can contain references to Perl subroutines. When the variable is used, the Template Toolkit will automatically call the subroutine, passing any additional arguments specified. The return value from the subroutine is used as the variable value and inserted into the document output. my $vars = { wizard => sub { return join(' ', 'Abracadabra!', @_) }, }; Example template: [% wizard %] # Abracadabra! [% wizard('Hocus Pocus!') %] # Abracadabra! Hocus Pocus! =head2 Objects Template variables can also contain references to Perl objects. Methods are called using the dot operator to specify the method against the object variable. Additional arguments can be specified as with subroutines. use CGI; my $vars = { # hard coded CGI params for purpose of example cgi => CGI->new('mode=submit&debug=1'), }; Example template: [% FOREACH p IN cgi.param %] # returns list of param keys [% p %] => [% cgi.param(p) %] # fetch each param value [% END %] Generated output: mode => submit debug => 1 Object methods can also be called as lvalues. That is, they can appear on the left side of an assignment. The method will be called passing the assigning value as an argument. [% myobj.method = 10 %] equivalent to: [% myobj.method(10) %] =head2 Passing Parameters and Returning Values Subroutines and methods will be passed any arguments specified in the template. Any template variables in the argument list will first be evaluated and their resultant values passed to the code. my $vars = { mycode => sub { return 'received ' . join(', ', @_) }, }; template: [% foo = 10 %] [% mycode(foo, 20) %] # received 10, 20 Named parameters may also be specified. These are automatically collected into a single hash array which is passed by reference as the B<last> parameter to the sub-routine. Named parameters can be specified using either C<=E<gt>> or C<=> and can appear anywhere in the argument list. my $vars = { myjoin => \&myjoin, }; sub myjoin { # look for hash ref as last argument my $params = ref $_[-1] eq 'HASH' ? pop : { }; return join($params->{ joint } || ' + ', @_); } Example template: [% myjoin(10, 20, 30) %] [% myjoin(10, 20, 30, joint = ' - ' %] [% myjoin(joint => ' * ', 10, 20, 30 %] Generated output: 10 + 20 + 30 10 - 20 - 30 10 * 20 * 30 Parenthesised parameters may be added to any element of a variable, not just those that are bound to code or object methods. At present, parameters will be ignored if the variable isn't "callable" but are supported for future extensions. Think of them as "hints" to that variable, rather than just arguments passed to a function. [% r = 'Romeo' %] [% r(100, 99, s, t, v) %] # outputs "Romeo" User code should return a value for the variable it represents. This can be any of the Perl data types described above: a scalar, or reference to a list, hash, subroutine or object. Where code returns a list of multiple values the items will automatically be folded into a list reference which can be accessed as per normal. my $vars = { # either is OK, first is recommended items1 => sub { return [ 'foo', 'bar', 'baz' ] }, items2 => sub { return ( 'foo', 'bar', 'baz' ) }, }; Example template: [% FOREACH i IN items1 %] ... [% END %] [% FOREACH i IN items2 %] ... [% END %] =head2 Error Handling Errors can be reported from user code by calling C<die()>. Errors raised in this way are caught by the Template Toolkit and converted to structured exceptions which can be handled from within the template. A reference to the exception object is then available as the C<error> variable. my $vars = { barf => sub { die "a sick error has occurred\n"; }, }; Example template: [% TRY %] [% barf %] # calls sub which throws error via die() [% CATCH %] [% error.info %] # outputs "a sick error has occurred\n" [% END %] Error messages thrown via C<die()> are converted to exceptions of type C<undef> (the literal string "undef" rather than the undefined value). Exceptions of user-defined types can be thrown by calling C<die()> with a reference to a L<Template::Exception> object. use Template::Exception; my $vars = { login => sub { ...do something... die Template::Exception->new( badpwd => 'password too silly' ); }, }; Example template: [% TRY %] [% login %] [% CATCH badpwd %] Bad password: [% error.info %] [% CATCH %] Some other '[% error.type %]' error: [% error.info %] [% END %] The exception types C<stop> and C<return> are used to implement the C<STOP> and C<RETURN> directives. Throwing an exception as: die (Template::Exception->new('stop')); has the same effect as the directive: [% STOP %] =head1 Virtual Methods The Template Toolkit implements a number of "virtual methods" which can be applied to scalars, hashes or lists. For example: [% mylist = [ 'foo', 'bar', 'baz' ] %] [% newlist = mylist.sort %] Here C<mylist> is a regular reference to a list, and 'sort' is a virtual method that returns a new list of the items in sorted order. You can chain multiple virtual methods together. For example: [% mylist.sort.join(', ') %] Here the C<join> virtual method is called to join the sorted list into a single string, generating the following output: bar, baz, foo See L<Template::Manual::VMethods> for details of all the virtual methods available. =head1 Variable Interpolation The Template Toolkit uses C<$> consistently to indicate that a variable should be interpolated in position. Most frequently, you see this in double-quoted strings: [% fullname = "$honorific $firstname $surname" %] Or embedded in plain text when the C<INTERPOLATE> option is set: Dear $honorific $firstname $surname, The same rules apply within directives. If a variable is prefixed with a C<$> then it is replaced with its value before being used. The most common use is to retrieve an element from a hash where the key is stored in a variable. [% uid = 'abw' %] [% users.$uid %] # same as 'users.abw' Curly braces can be used to delimit interpolated variable names where necessary. [% users.${me.id}.name %] Directives such as C<INCLUDE>, C<PROCESS>, etc., that accept a template name as the first argument, will automatically quote it for convenience. [% INCLUDE foo/bar.txt %] The above example is equivalent to: [% INCLUDE "foo/bar.txt" %] To C<INCLUDE> a template whose name is stored in a variable, simply prefix the variable name with C<$> to have it interpolated. [% myfile = 'header' %] [% INCLUDE $myfile %] This is equivalent to: [% INCLUDE header %] Note also that a variable containing a reference to a L<Template::Document> object can also be processed in this way. my $vars = { header => Template::Document->new({ ... }), }; Example template: [% INCLUDE $header %] =head1 Local and Global Variables Any simple variables that you create, or any changes you make to existing variables, will only persist while the template is being processed. The top-level variable hash is copied before processing begins and any changes to variables are made in this copy, leaving the original intact. The same thing happens when you C<INCLUDE> another template. The current namespace hash is cloned to prevent any variable changes made in the included template from interfering with existing variables. The C<PROCESS> option bypasses the localisation step altogether making it slightly faster, but requiring greater attention to the possibility of side effects caused by creating or changing any variables within the processed template. [% BLOCK change_name %] [% name = 'bar' %] [% END %] [% name = 'foo' %] [% INCLUDE change_name %] [% name %] # foo [% PROCESS change_name %] [% name %] # bar Dotted compound variables behave slightly differently because the localisation process is only skin deep. The current variable namespace hash is copied, but no attempt is made to perform a deep-copy of other structures within it (hashes, arrays, objects, etc). A variable referencing a hash, for example, will be copied to create a new reference but which points to the same hash. Thus, the general rule is that simple variables (undotted variables) are localised, but existing complex structures (dotted variables) are not. [% BLOCK all_change %] [% x = 20 %] # changes copy [% y.z = 'zulu' %] # changes original [% END %] [% x = 10 y = { z => 'zebra' } %] [% INCLUDE all_change %] [% x %] # still '10' [% y.z %] # now 'zulu' If you create a complex structure such as a hash or list reference within a local template context then it will cease to exist when the template is finished processing. [% BLOCK new_stuff %] [% # define a new 'y' hash array in local context y = { z => 'zulu' } %] [% END %] [% x = 10 %] [% INCLUDE new_stuff %] [% x %] # outputs '10' [% y %] # nothing, y is undefined Similarly, if you update an element of a compound variable which I<doesn't> already exists then a hash will be created automatically and deleted again at the end of the block. [% BLOCK new_stuff %] [% y.z = 'zulu' %] [% END %] However, if the hash I<does> already exist then you will modify the original with permanent effect. To avoid potential confusion, it is recommended that you don't update elements of complex variables from within blocks or templates included by another. If you want to create or update truly global variables then you can use the 'global' namespace. This is a hash array automatically created in the top-level namespace which all templates, localised or otherwise see the same reference to. Changes made to variables within this hash are visible across all templates. [% global.version = 123 %] =head1 Compile Time Constant Folding In addition to variables that get resolved each time a template is processed, you can also define variables that get resolved just once when the template is compiled. This generally results in templates processing faster because there is less work to be done. To define compile-time constants, specify a C<CONSTANTS> hash as a constructor item as per C<VARIABLES>. The C<CONSTANTS> hash can contain any kind of complex, nested, or dynamic data structures, just like regular variables. my $tt = Template->new({ CONSTANTS => { version => 3.14, release => 'skyrocket', col => { back => '#ffffff', fore => '#000000', }, myobj => My::Object->new(), mysub => sub { ... }, joint => ', ', }, }); Within a template, you access these variables using the C<constants> namespace prefix. Version [% constants.version %] ([% constants.release %]) Background: [% constants.col.back %] When the template is compiled, these variable references are replaced with the corresponding value. No further variable lookup is then required when the template is processed. You can call subroutines, object methods, and even virtual methods on constant variables. [% constants.mysub(10, 20) %] [% constants.myobj(30, 40) %] [% constants.col.keys.sort.join(', ') %] One important proviso is that any arguments you pass to subroutines or methods must also be literal values or compile time constants. For example, these are both fine: # literal argument [% constants.col.keys.sort.join(', ') %] # constant argument [% constants.col.keys.sort.join(constants.joint) %] But this next example will raise an error at parse time because C<joint> is a runtime variable and cannot be determined at compile time. # ERROR: runtime variable argument! [% constants.col.keys.sort.join(joint) %] The C<CONSTANTS_NAMESPACE> option can be used to provide a different namespace prefix for constant variables. For example: my $tt = Template->new({ CONSTANTS => { version => 3.14, # ...etc... }, CONSTANTS_NAMESPACE => 'const', }); Constants would then be referenced in templates as: [% const.version %] =head1 Special Variables A number of special variables are automatically defined by the Template Toolkit. =head2 template The C<template> variable contains a reference to the main template being processed, in the form of a L<Template::Document> object. This variable is correctly defined within C<PRE_PROCESS>, C<PROCESS> and C<POST_PROCESS> templates, allowing standard headers, footers, etc., to access metadata items from the main template. The C<name> and C<modtime> metadata items are automatically provided, giving the template name and modification time in seconds since the epoch. Note that the C<template> variable always references the top-level template, even when processing other template components via C<INCLUDE>, C<PROCESS>, etc. =head2 component The C<component> variable is like C<template> but always contains a reference to the current, innermost template component being processed. In the main template, the C<template> and C<component> variable will reference the same L<Template::Document> object. In any other template component called from the main template, the C<template> variable will remain unchanged, but C<component> will contain a new reference to the current component. This example should demonstrate the difference: $template->process('foo') || die $template->error(), "\n"; F<foo> template: [% template.name %] # foo [% component.name %] # foo [% PROCESS footer %] F<footer> template: [% template.name %] # foo [% component.name %] # footer Additionally, the C<component> variable has two special fields: C<caller> and C<callers>. C<caller> contains the name of the template that called the current template (or undef if the values of C<template> and C<component> are the same). C<callers> contains a reference to a list of all the templates that have been called on the road to calling the current component template (like a call stack), with the outer-most template first. Here's an example: F<outer.tt2> template: [% component.name %] # 'outer.tt2' [% component.caller %] # undef [% component.callers %] # undef [% PROCESS 'middle.tt2' %] F<middle.tt2> template: [% component.name %] # 'middle.tt2' [% component.caller %] # 'outer.tt2' [% component.callers %] # [ 'outer.tt2' ] [% PROCESS 'inner.tt2' %] F<inner.tt2> template: [% component.name %] # 'inner.tt2' [% component.caller %] # 'middle.tt2' [% component.callers %] # [ 'outer.tt2', 'middle.tt2' ] =head2 loop Within a C<FOREACH> loop, the C<loop> variable references the L<Template::Iterator> object responsible for controlling the loop. [% FOREACH item = [ 'foo', 'bar', 'baz' ] -%] [% "Items:\n" IF loop.first -%] [% loop.count %]/[% loop.size %]: [% item %] [% END %] =head2 error Within a C<CATCH> block, the C<error> variable contains a reference to the L<Template::Exception> object thrown from within the C<TRY> block. The C<type> and C<info> methods can be called or the variable itself can be printed for automatic stringification into a message of the form "C<$type error - $info>". See L<Template::Exception> for further details. [% TRY %] ... [% CATCH %] [% error %] [% END %] =head2 content The C<WRAPPER> method captures the output from a template block and then includes a named template, passing the captured output as the 'content' variable. [% WRAPPER box %] Be not afeard; the isle is full of noises, Sounds and sweet airs, that give delight and hurt not. [% END %] [% BLOCK box %] <blockquote class="prose"> [% content %] </blockquote> [% END %] =head1 Compound Variables Compound 'dotted' variables may contain any number of separate elements. Each element may evaluate to any of the permitted variable types and the processor will then correctly use this value to evaluate the rest of the variable. Arguments may be passed to any of the intermediate elements. [% myorg.people.sort('surname').first.fullname %] Intermediate variables may be used and will behave entirely as expected. [% sorted = myorg.people.sort('surname') %] [% sorted.first.fullname %] This simplified dotted notation has the benefit of hiding the implementation details of your data. For example, you could implement a data structure as a hash array one day and then change it to an object the next without requiring any change to the templates. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Manual/Views.pod 0000444 00000045213 15125513451 0011731 0 ustar 00 #============================================================= -*-perl-*- # # Template::Manual::Views # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Manual::Views - Template Toolkit views (experimental) =head1 Overview A view is effectively a collection of templates and/or variable definitions which can be passed around as a self-contained unit. This then represents a particular interface or presentation style for other objects or items of data. You can use views to implement custom "skins" for an application or content set. You can use them to help simplify the presentation of common objects or data types. You can even use then to automate the presentation of complex data structures such as that generated in an C<XML::DOM> tree or similar. You let an iterator do the walking, and the view does the talking (or in this case, the presenting). Voila - you have view independent, structure shy traversal using templates. In general, views can be used in a number of different ways to achieve several different things. They elegantly solve some problems which were otherwise difficult or complicated, and make easy some things that were previously hard. At the moment, they're still very experimental. The directive syntax and underlying API are likely to change quite considerably over the next version or two. Please be very wary about building your multi-million dollar e-commerce solutions based around this feature. =head1 Views as Template Collectors/Providers The C<VIEW> directive starts a view definition and includes a name by which the view can be referenced. The view definition continues up to the matching C<END> directive. [% VIEW myview %] ... [% END %] The first role of a view is to act as a collector and provider of templates. The C<include()> method can be called on a view to effectively do the same thing as the C<INCLUDE> directive. The template name is passed as the first argument, followed by any local variable definitions for the template. [% myview.include('header', title='The Title') %] # equivalent to [% INCLUDE header title='The Title' %] Views accept a number of configuration options which can be used to control different aspects of their behaviour. The 'C<prefix>' and 'C<suffix>' options can be specified to add a fixed prefix and/or suffix to the name of each template. [% VIEW myview prefix = 'my/' suffix = '.tt2' ; END %] Now the call [% myview.include('header', title='The Title') %] is equivalent to [% INCLUDE my/header.tt2 title='The Title' %] Views provide an C<AUTOLOAD> method which maps method names to the C<include()> method. Thus, the following are all equivalent: [% myview.include('header', title='Hello World') %] [% myview.include_header(title='Hello World') %] [% myview.header(title='Hello World') %] =head1 Local BLOCK Definitions A C<VIEW> definition can include C<BLOCK> definitions which remain local to the view. A request for a particular template will return a C<BLOCK>, if defined, in preference to any other template of the same name. [% BLOCK foo %] public foo block [% END %] [% VIEW plain %] [% BLOCK foo %] plain foo block [% END %] [% END %] [% VIEW fancy %] [% BLOCK foo %] fancy foo block [% END %] [% END %] [% INCLUDE foo %] # public foo block [% plain.foo %] # plain foo block [% fancy.foo %] # fancy foo block In addition to C<BLOCK> definitions, a C<VIEW> can contain any other template directives. The entire C<VIEW> definition block is processed to initialise the view but no output is generated (this may change RSN - and get stored as 'C<output>' item, subsequently accessible as C<[% view.output %]>). However, directives that have side-effects, such as those that update a variable, will have noticeable consequences. =head1 Preserving Variable State within Views Views can also be used to save the values of any existing variables, or to create new ones at the point at which the view is defined. Unlike simple template metadata (C<META>) which can only contain static string values, the view initialisation block can contain any template directives and generate any kind of dynamic output and/or data items. [% VIEW my_web_site %] [% view.title = title or 'My Cool Web Site' %] [% view.author = "$abw.name, $abw.email" %] [% view.sidebar = INCLUDE my/sidebar.tt2 %] [% END %] Note that additional data items can be specified as arguments to the C<VIEW> directive. Anything that doesn't look like a configuration parameter is assumed to be a data item. This can be a little hazardous, of course, because you never know when a new configuration item might get added which interferes with your data. [% VIEW my_web_site # config options prefix = 'my/' # misc data title = title or 'My Cool Web Site' author = "$abw.name, $abw.email" sidebar = INCLUDE my/sidebar.tt2 %] ... [% END %] Outside of the view definition you can access the view variables as, for example: [% my_web_site.title %] One important feature is the equivalence of simple variables and templates. You can implement the view item 'C<title>' as a simple variable, a template defined in an external file, possibly with a prefix/suffix automatically appended, or as a local C<BLOCK> definition within the C<[% VIEW %] ... [% END %]> definition. If you use the syntax above then the view will Do The Right Thing to return the appropriate output. At the C<END> of the C<VIEW> definition the view is "sealed" to prevent you from accidentally updating any variable values. If you attempt to change the value of a variable after the C<END> of the C<VIEW> definition block then a C<view> error will be thrown. [% TRY; my_web_site.title = 'New Title'; CATCH; error; END %] The error above will be reported as: view error - cannot update item in sealed view: title The same is true if you pass a parameter to a view variable. This is interpreted as an attempt to update the variable and will raise the same warning. [% my_web_site.title('New Title') %] # view error! You can set the C<silent> parameter to have the view ignore these parameters and simply return the variable value. [% VIEW my_web_site silent = 1 title = title or 'My Cool Web Site' # ... ; END %] [% my_web_site.title('Blah Blah') %] # My Cool Web Site Alternately, you can specify that a view is unsealed allowing existing variables to be updated and new variables defined. [% VIEW my_web_site sealed = 0 title = title or 'My Cool Web Site' # ... ; END %] [% my_web_site.title('Blah Blah') %] # Blah Blah [% my_web_site.title %] # Blah Blah =head2 Inheritance, Delegation and Reuse Views can be inherited from previously defined views by use of the C<base> parameter. This example shows how a base class view is defined which applies a C<view/default/> prefix to all template names. [% VIEW my.view.default prefix = 'view/default/'; END %] Thus the directive: [% my.view.default.header(title='Hello World') %] is now equivalent to: [% INCLUDE view/default/header title='Hello World' %] A second view can be defined which specifies the default view as a base. [% VIEW my.view.fancy base = my.view.default prefix = 'view/fancy/'; END %] Now the directive: [% my.view.fancy.header(title='Hello World') %] will resolve to: [% INCLUDE view/fancy/header title='Hello World' %] or if that doesn't exist, it will be handled by the base view as: [% INCLUDE view/default/header title='Hello World' %] When a parent view is specified via the C<base> parameter, the delegation of a view to its parent for fetching templates and accessing user defined variables is automatic. You can also implement your own inheritance, delegation or other reuse patterns by explicitly delegating to other views. [% BLOCK foo %] public foo block [% END %] [% VIEW plain %] [% BLOCK foo %] <plain>[% PROCESS foo %]</plain> [% END %] [% END %] [% VIEW fancy %] [% BLOCK foo %] [% plain.foo | replace('plain', 'fancy') %] [% END %] [% END %] [% plain.foo %] # <plain>public foo block</plain> [% fancy.foo %] # <fancy>public foo block</fancy> Note that the regular C<INCLUDE/PROCESS/WRAPPER> directives work entirely independently of views and will always get the original, unaltered template name rather than any local per-view definition. =head2 Self-Reference A reference to the view object under definition is available with the C<VIEW ... END> block by its specified name and also by the special name 'C<view>' (similar to the C<my $self = shift;> in a Perl method or the 'C<this>' pointer in C++, etc). The view is initially unsealed allowing any data items to be defined and updated within the C<VIEW ... END> block. The view is automatically sealed at the end of the definition block, preventing any view data from being subsequently changed. (NOTE: sealing should be optional. As well as sealing a view to prevent updates (C<SEALED>), it should be possible to set an option in the view to allow external contexts to update existing variables (C<UPDATE>) or even create totally new view variables (C<CREATE>)). [% VIEW fancy %] [% fancy.title = 'My Fancy Title' %] [% fancy.author = 'Frank Open' %] [% fancy.col = { bg => '#ffffff', bar => '#a0a0ff' } %] [% END %] or [% VIEW fancy %] [% view.title = 'My Fancy Title' %] [% view.author = 'Frank Open' %] [% view.col = { bg => '#ffffff', bar => '#a0a0ff' } %] [% END %] It makes no real difference in this case if you refer to the view by its name, 'C<fancy>', or by the general name, 'C<view>'. Outside of the view block, however, you should always use the given name, 'C<fancy>': [% fancy.title %] [% fancy.author %] [% fancy.col.bg %] The choice of given name or 'C<view>' is much more important when it comes to C<BLOCK> definitions within a C<VIEW>. It is generally recommended that you use 'C<view>' inside a C<VIEW> definition because this is guaranteed to be correctly defined at any point in the future when the block gets called. The original name of the view might have long since been changed or reused but the self-reference via 'C<view>' should always be intact and valid. Take the following VIEW as an example: [% VIEW foo %] [% view.title = 'Hello World' %] [% BLOCK header %] Title: [% view.title %] [% END %] [% END %] Even if we rename the view, or create a new C<foo> variable, the header block still correctly accesses the C<title> attribute of the view to which it belongs. Whenever a view C<BLOCK> is processed, the C<view> variable is always updated to contain the correct reference to the view object to which it belongs. [% bar = foo %] [% foo = { title => "New Foo" } %] # no problem [% bar.header %] # => Title: Hello World =head2 Saving References to External Views When it comes to view inheritance, it's always a good idea to take a local copy of a parent or delegate view and store it as an attribute within the view for later use. This ensures that the correct view reference is always available, even if the external name of a view has been changed. [% VIEW plain %] ... [% END %] [% VIEW fancy %] [% view.plain = plain %] [% BLOCK foo %] [% view.plain.foo | replace('plain', 'fancy') %] [% END %] [% END %] [% plain.foo %] # => <plain>public foo block</plain> [% plain = 'blah' %] # no problem [% fancy.foo %] # => <fancy>public foo block</fancy> =head2 Views as Data Presenters Another key role of a view is to act as a dispatcher to automatically apply the correct template to present a particular object or data item. This is handled via the C<print()> method. Here's an example: [% VIEW foo %] [% BLOCK text %] Some text: [% item %] [% END %] [% BLOCK hash %] a hash: [% FOREACH key = item.keys.sort -%] [% key %] => [% item.$key %] [% END -%] [% END %] [% BLOCK list %] a list: [% item.sort.join(', ') %] [% END %] [% END %] We can now use the view to print text, hashes or lists. The C<print()> method includes the right template depending on the typing of the argument (or arguments) passed. [% some_text = 'I read the news today, oh boy.' %] [% a_hash = { house => 'Lords', hall => 'Albert' } %] [% a_list = [ 'sure', 'Nobody', 'really' ] %] [% view.print(some_text) %] # Some text: I read the news today, oh boy. [% view.print(a_hash) %] # a hash: hall => Albert house => Lords [% view.print(a_list) %] # a list: Nobody, really, sure You can also provide templates to print objects of any other class. The class name is mapped to a template name with all non-word character sequences such as 'C<::>' converted to a single 'C<_>'. [% VIEW foo %] [% BLOCK Foo_Bar %] a Foo::Bar object: thingies: [% view.print(item.thingies) %] doodahs: [% view.print(item.doodahs) %] [% END %] [% END %] [% USE fubar = Foo::Bar(...) %] [% foo.print(fubar) %] Note how we use the view object to display various items within the objects ('C<thingies>' and 'C<doodahs>'). We don't need to worry what kind of data these represent (text, list, hash, etc) because we can let the view worry about it, automatically mapping the data type to the correct template. Views may define their own type =E<gt> template map. [% VIEW foo map = { TEXT => 'plain_text', ARRAY => 'show_list', HASH => 'show_hash', My::Module => 'template_name' default => 'any_old_data' } %] [% BLOCK plain_text %] ... [% END %] ... [% END %] They can also provide a C<default> map entry, specified as part of the C<map> hash or as a parameter by itself. [% VIEW foo map = { ... }, default = 'whatever' %] ... [% END %] or [% VIEW foo %] [% view.map = { ... } view.default = 'whatever' %] ... [% END %] The C<print()> method provides one more piece of magic. If you pass it a reference to an object which provides a C<present()> method, then the method will be called passing the view as an argument. This then gives any object a chance to determine how it should be presented via the view. package Foo::Bar; ... sub present { my ($self, $view) = @_; return "a Foo::Bar object:\n" . "thingies: " . $view->print($self->{ _THINGIES }) . "\n" . "doodahs: " . $view->print($self->{ _DOODAHS }) . "\n"; } The object is free to delve deeply into its innards and mess around with its own private data, before presenting the relevant data via the view. In a more complex example, a C<present()> method might walk part of a tree making calls back against the view to present different nodes within the tree. We may not want to expose the internal structure of the tree (because that would break encapsulation and make our presentation code dependant on it) but we want to have some way of walking the tree and presenting items found in a particular manner. This is known as I<Structure Shy Traversal>. Our view object doesn't require prior knowledge about the internal structure of any data set to be able to traverse it and present the data contained therein. The data items themselves, via the C<present()> method, can implement the internal iterators to guide the view along the right path to presentation happiness. The upshot is that you can use views to greatly simplify the display of data structures like C<XML::DOM> trees. The documentation for the C<Template::Plugin::XML::DOM> module contains an example of this. In essence, it looks something like this: XML source: <user name="Andy Wardley"> <project id="iCan" title="iCan, but theyCan't"/> <project id="p45" title="iDid, but theyDidn't"/> </user> TT View: [% VIEW fancy %] [% BLOCK user %] User: [% item.name %] [% item.content(myview) %] [% END %] [% BLOCK project %] Project: [% project.id %] - [% project.name %] [% END %] [% END %] Generate view: [% USE dom = XML.DOM %] [% fancy.print(dom.parse(xml_source)) %] Output: User: Andy Wardley Project: iCan - iCan, but theyCan't Project: p45 - iDid, but theyDidn't The same approach can be applied to many other areas. Here's an example from the C<File>/C<Directory> plugins. [% VIEW myview %] [% BLOCK file %] - [% item.name %] [% END %] [% BLOCK directory %] * [% item.name %] [% item.content(myview) FILTER indent %] [% END %] [% END %] [% USE dir = Directory(dirpath) %] [% myview.print(dir) %] And here's the same approach use to convert POD documentation to any other format via template. [% # load Pod plugin and parse source file into Pod Object Model USE Pod; pom = Pod.parse_file(my_pod_file); # define view to map all Pod elements to "pod/html/xxx" templates VIEW pod2html prefix='pod/html'; END; # now print document via view (i.e. as HTML) pod2html.print(pom) %] Here we simply define a template prefix for the view which causes the view to look for C<pod/html/head1>, C<pod/html/head2>, C<pod/html/over> as templates to present the different sections of the parsed Pod document. There are some examples in the Template Toolkit test suite: F<t/pod.t> and F<t/view.t> which may shed some more light on this. See the distribution sub-directory F<examples/pod/html> for examples of Pod -E<gt> HTML templates. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Manual/VMethods.pod 0000444 00000051013 15125513451 0012360 0 ustar 00 #============================================================= -*-perl-*- # # Template::Manual::VMethods # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Manual::VMethods - Virtual Methods =head1 Scalar Virtual Methods =head2 chunk(size) Splits the value into a list of chunks of a certain size. [% ccard_no = "1234567824683579"; ccard_no.chunk(4).join %] Output: 1234 5678 2468 3579 If the size is specified as a negative number then the text will be chunked from right-to-left. This gives the correct grouping for numbers, for example. [% number = 1234567; number.chunk(-3).join(',') %] Output: 1,234,567 =head2 collapse Returns the text with any leading and trailing whitespace removed and any internal sequences of whitespace converted to a single space [% text = " The bird\n is the word" %] [% text.collapse %] # The bird is the word =head2 defined Returns true if the value is defined. [% user = get_user(uid) IF uid.defined %] =head2 dquote Returns the text with any double quote characters escaped with a backslash prefix. Any newline characters in the text will be replaced with "\n". [% quote = 'He said "Oh really?"' %] [% quote.dquote %] # He said \"Oh really?\" =head2 hash Return the value as a hash reference containing a single entry with the key C<value> indicating the original scalar value. As with the C<list> virtual method, this is generally used to help massage data into different formats. =head2 lcfirst Returns the text with the first letter converted to lower case. [% word = 'BIRD' %] [% word.lcfirst %] # bIRD =head2 length Returns the length of the string representation of the item: [% IF password.length < 8 %] Password too short, dumbass! [% END %] =head2 empty Returns true if the string is empty: [% IF details.empty %] No details specified [% END %] =head2 list Return the value as a single element list. This can be useful if you have a variable which may contain a single item or a list and you want to treat them equally. The C<list> method can be called against a list reference and will simply return the original reference, effectively a no-op. [% thing.list.size %] # thing can be a scalar or a list =head2 lower Returns the text in lower case. [% word = 'BIRD' %] [% word.lower %] # bird =head2 match(pattern, global) Performs a regular expression match on the string using the pattern passed as an argument. If the pattern matches the string then the method returns a reference to a list of any strings captured within parenthesis in the pattern. [% name = 'Larry Wall' %] [% matches = name.match('(\w+) (\w+)') %] [% matches.1 %], [% matches.0 %] # Wall, Larry If the pattern does not match then the method returns false, rather than returning an empty list which Perl and the Template Toolkit both consider to be a true value. This allows you to write expression like this. [% "We're not worthy!" IF name.match('Larry Wall') %] [% IF (matches = name.match('(\w+) (\w+)')) %] pattern matches: [% matches.join(', ') %] [% ELSE %] pattern does not match [% END %] Any regex modifiers, like C</s>, should be added in the regex using the C<(?s)> syntax. For example, to modify the regex to disregard whitespace (the C</x> switch), use: [% re = '(?x) (\w+) [ ] (\w+) '; matches = name.match(re); %] To perform a global search to match the pattern as many times as it appears in the source string, provide a true value for the C<global> argument following the pattern. [% text = 'bandanna'; text.match('an+', 1).join(', ') # an, ann %] =head2 repeat(n) Repeat the string a specified number of times. [% name = 'foo' %] [% name.repeat(3) %] # foofoofoo =head2 replace(search, replace) Outputs the string with all instances of the first argument (specified as a Perl regular expression) with the second. [% name = 'foo, bar & baz' %] [% name.replace('\W+', '_') %] # foo_bar_baz You can use C<$1>, C<$2>, etc., to reference captured parts (in parentheses) in the regular expression. Just be careful to I<single> quote the replacement string. If you use I<double> quotes then TT will try and interpolate the variables before passing the string to the C<replace> vmethod. [% name = 'FooBarBaz' %] [% name.replace('([A-Z])', ' $1') %] # Foo Bar Baz =head2 remove(pattern) Outputs the string with all instances of the pattern (specified as a Perl regular expression) removed. [% name = 'foo, bar & baz' %] [% name.remove('\W+') %] # foobarbaz =head2 search(pattern) Performs a similar function to L<match> but simply returns true if the string matches the regular expression pattern passed as an argument. [% name = 'foo bar baz' %] [% name.search('bar') ? 'bar' : 'no bar' %] # bar This virtual method is now deprecated in favour of L<match>. Move along now, there's nothing more to see here. =head2 size Always returns 1 for scalar values. This method is provided for consistency with the hash and list size methods. =head2 split(pattern) Calls Perl's C<split()> function to split a string into a list of strings. [% FOREACH dir IN mypath.split(':') %] [% dir %] [% END %] =head2 substr(offset, length, replacement) Returns a substring starting at C<offset>, for C<length> characters. [% str 'foo bar baz wiz waz woz') %] [% str.substr(4, 3) %] # bar If C<length> is not specified then it returns everything from the C<offset> to the end of the string. [% str.substr(12) %] # wiz waz woz If both C<length> and C<replacement> are specified, then the method replaces everything from C<offset> for C<length> characters with C<$replacement>. The substring removed from the string is then returned. [% str.substr(0, 11, 'FOO') %] # foo bar baz [% str %] # FOO wiz waz woz =head2 squote Returns the text with any single quote characters escaped with a backslash prefix. [% tim = "Tim O'Reilly" %] [% tim.squote %] # Tim O\'Reilly =head2 trim Returns the text with any leading and trailing whitespace removed. [% text = ' hello world ' %] [% text.trim %] # hello world =head2 ucfirst Returns the text with the first letter converted to upper case. [% word = 'bird' %] [% word.ucfirst %] # Bird =head2 upper Returns the text in upper case. [% word = 'bird' %] [% word.upper %] # BIRD =head1 Hash Virtual Methods =head2 keys Returns a list of keys in the hash. They are not returned in any particular order, but the order is the same as for the corresponding values method. [% FOREACH key IN hash.keys %] * [% key %] [% END %] If you want the keys in sorted order, use the list C<sort> method. [% FOREACH key IN hash.keys.sort %] * [% key %] [% END %] Having got the keys in sorted order, you can then use variable interpolation to fetch the value. This is shown in the following example by the use of C<$key> to fetch the item from C<hash> whose key is stored in the C<key> variable. [% FOREACH key IN hash.keys.sort %] * [% key %] = [% hash.$key %] [% END %] Alternately, you can use the C<pairs> method to get a list of key/value pairs in sorted order. =head2 values Returns a list of the values in the hash. As with the C<keys> method, they are not returned in any particular order, although it is the same order that the keys are returned in. [% hash.values.join(', ') %] =head2 items Returns a list of both the keys and the values expanded into a single list. [% hash = { a = 10 b = 20 }; hash.items.join(', ') # a, 10, b, 20 %] =head2 each This method currently returns the same thing as the C<items> method. However, please note that this method will change in the next major version of the Template Toolkit (v3) to return the same thing as the C<pairs> method. This will be done in an effort to make these virtual method more consistent with each other and how Perl works. In anticipation of this, we recommend that you stop using C<hash.each> and instead use C<hash.items>. =head2 pairs This method returns a list of key/value pairs. They are returned in sorted order according to the keys. [% FOREACH pair IN product.pairs %] * [% pair.key %] is [% pair.value %] [% END %] =head2 list Returns the contents of the hash in list form. An argument can be passed to indicate the desired items required in the list: C<keys> to return a list of the keys (same as C<hash.keys>), C<values> to return a list of the values (same as C<hash.values>), C<each> to return as list of key and values (same as C<hash.each>), or C<pairs> to return a list of key/value pairs (same as C<hash.pairs>). [% keys = hash.list('keys') %] [% values = hash.list('values') %] [% items = hash.list('each') %] [% pairs = hash.list('pairs') %] When called without an argument it currently returns the same thing as the C<pairs> method. However, please note that this method will change in the next major version of the Template Toolkit (v3) to return a reference to a list containing the single hash reference (as per the scalar list method). In anticipation of this, we recommend that you stop using C<hash.list> and instead use C<hash.pairs>. =head2 sort, nsort Return a list of the keys, sorted alphabetically (C<sort>) or numerically (C<nsort>) according to the corresponding values in the hash. [% FOREACH n IN phones.sort %] [% phones.$n %] is [% n %], [% END %] =head2 import The C<import> method can be called on a hash array to import the contents of another hash array. [% hash1 = { foo = 'Foo' bar = 'Bar' } hash2 = { wiz = 'Wiz' woz = 'Woz' } %] [% hash1.import(hash2) %] [% hash1.wiz %] # Wiz You can also call the C<import()> method by itself to import a hash array into the current namespace hash. [% user = { id => 'lwall', name => 'Larry Wall' } %] [% import(user) %] [% id %]: [% name %] # lwall: Larry Wall =head2 defined, exists Returns a true or false value if an item in the hash denoted by the key passed as an argument is defined or exists, respectively. [% hash.defined('somekey') ? 'yes' : 'no' %] [% hash.exists('somekey') ? 'yes' : 'no' %] When called without any argument, C<hash.defined> returns true if the hash itself is defined (e.g. the same effect as C<scalar.defined>). =head2 delete Delete one or more items from the hash. [% hash.delete('foo', 'bar') %] =head2 size Returns the number of key/value pairs in the hash. =head2 empty Returns true if the hash is empty: [% IF config.empty %] No configuration available [% END %] =head2 item Returns an item from the hash using a key passed as an argument. [% hash.item('foo') %] # same as hash.foo =head1 List Virtual Methods =head2 first, last Returns the first/last item in the list. The item is not removed from the list. [% results.first %] to [% results.last %] If either is given a numeric argument C<n>, they return the first or last C<n> elements: The first 5 results are [% results.first(5).join(", ") %]. =head2 size, max Returns the size of a list (number of elements) and the maximum index number (size - 1), respectively. [% results.size %] search results matched your query =head2 empty Returns true if the list is empty: [% IF results.empty %] No results found [% END %] =head2 defined Returns a true or false value if the item in the list denoted by the argument is defined. [% list.defined(3) ? 'yes' : 'no' %] When called without any argument, C<list.defined> returns true if the list itself is defined (e.g. the same effect as C<scalar.defined>). =head2 reverse Returns the items of the list in reverse order. [% FOREACH s IN scores.reverse %] ... [% END %] =head2 join Joins the items in the list into a single string, using Perl's C<join()> function. [% items.join(', ') %] =head2 grep Returns a list of the items in the list that match a regular expression pattern. [% FOREACH directory.files.grep('\.txt$') %] ... [% END %] =head2 sort, nsort Returns the items in alpha (C<sort>) or numerical (C<nsort>) order. [% library = books.sort %] An argument can be provided to specify a search key. Where an item in the list is a hash reference, the search key will be used to retrieve a value from the hash which will then be used as the comparison value. Where an item is an object which implements a method of that name, the method will be called to return a comparison value. [% library = books.sort('author') %] In the example, the C<books> list can contains hash references with an C<author> key or objects with an C<author> method. You can also specify multiple sort keys. [% library = books.sort('author', 'title') %] In this case the books will be sorted primarily by author. If two or more books have authors with the same name then they will be sorted by title. =head2 unshift(item), push(item) The C<push()> method adds an item or items to the end of list. [% mylist.push(foo) %] [% mylist.push(foo, bar) %] The C<unshift()> method adds an item or items to the start of a list. [% mylist.unshift(foo) %] [% mylist.push(foo, bar) %] =head2 shift, pop Removes the first/last item from the list and returns it. [% first = mylist.shift %] [% last = mylist.pop %] =head2 unique Returns a list of the unique elements in a list, in the same order as in the list itself. [% mylist = [ 1, 2, 3, 2, 3, 4, 1, 4, 3, 4, 5 ] %] [% numbers = mylist.unique %] While this can be explicitly sorted, it is not required that the list be sorted before the unique elements are pulled out (unlike the Unix command line utility). [% numbers = mylist.unique.sort %] =head2 import Appends the contents of one or more other lists to the end of the current list. [% one = [ 1 2 3 ]; two = [ 4 5 6 ]; three = [ 7 8 9 ]; one.import(two, three); one.join(', '); # 1, 2, 3, 4, 5, 6, 7, 8, 9 %] Import also allows chaining. The below syntax is equivalent. [% one = [ 1 2 3 ]; two = [ 4 5 6 ]; three = [ 7 8 9 ]; one.import(two, three).join(', '); # 1, 2, 3, 4, 5, 6, 7, 8, 9 # or: one.import(two).import(three).join(', '); # 1, 2, 3, 4, 5, 6, 7, 8, 9 %] =head2 merge Returns a list composed of zero or more other lists: [% list_one = [ 1 2 3 ]; list_two = [ 4 5 6 ]; list_three = [ 7 8 9 ]; list_four = list_one.merge(list_two, list_three); %] The original lists are not modified. =head2 slice(from, to) Returns a slice of items in the list between the bounds passed as arguments. If the second argument, C<to>, isn't specified, then it defaults to the last item in the list. The original list is not modified. [% first_three = list.slice(0,2) %] [% last_three = list.slice(-3, -1) %] =head2 splice(offset, length, list) Behaves just like Perl's C<splice()> function allowing you to selectively remove and/or replace elements in a list. It removes C<length> items from the list, starting at C<offset> and replaces them with the items in C<list>. [% play_game = [ 'play', 'scrabble' ]; ping_pong = [ 'ping', 'pong' ]; redundant = play_game.splice(1, 1, ping_pong); redundant.join; # scrabble play_game.join; # play ping pong %] The method returns a list of the items removed by the splice. You can use the C<CALL> directive to ignore the output if you're not planning to do anything with it. [% CALL play_game.splice(1, 1, ping_pong) %] As well as providing a reference to a list of replacement values, you can pass in a list of items. [% CALL list.splice(-1, 0, 'foo', 'bar') %] Be careful about passing just one item in as a replacement value. If it is a reference to a list then the contents of the list will be used. If it's not a list, then it will be treated as a single value. You can use square brackets around a single item if you need to be explicit: [% # push a single item, an_item CALL list.splice(-1, 0, an_item); # push the items from another_list CALL list.splice(-1, 0, another_list); # push a reference to another_list CALL list.splice(-1, 0, [ another_list ]); %] =head2 hash Returns a reference to a hash array comprised of the elements in the list. The even-numbered elements (0, 2, 4, etc) become the keys and the odd-numbered elements (1, 3, 5, etc) the values. [% list = ['pi', 3.14, 'e', 2.718] %] [% hash = list.hash %] [% hash.pi %] # 3.14 [% hash.e %] # 2.718 If a numerical argument is provided then the hash returned will have keys generated for each item starting at the number specified. [% list = ['beer', 'peanuts'] %] [% hash = list.hash(1) %] [% hash.1 %] # beer [% hash.2 %] # peanuts =head2 item Returns an item from the list using an index passed as an argument. [% list.item(0) %] # same as list.0 =head1 Automagic Promotion of Scalar to List for Virtual Methods In addition to the scalar virtual methods listed in the previous section, you can also call any list virtual method against a scalar. The item will be automagically promoted to a single element list and the appropriate list virtual method will be called. One particular benefit of this comes when calling subroutines or object methods that return a list of items, rather than the preferred reference to a list of items. In this case, the Template Toolkit automatically folds the items returned into a list. The upshot is that you can continue to use existing Perl modules or code that returns lists of items, without having to refactor it just to keep the Template Toolkit happy (by returning references to list). C<Class::DBI> module is just one example of a particularly useful module which returns values this way. If only a single item is returned from a subroutine then the Template Toolkit assumes it meant to return a single item (rather than a list of 1 item) and leaves it well alone, returning the single value as it is. If you're executing a database query, for example, you might get 1 item returned, or perhaps many items which are then folded into a list. The C<FOREACH> directive will happily accept either a list or a single item which it will treat as a list. So it's safe to write directives like this, where we assume that the C<something> variable is bound to a subroutine which may return one or more items: [% FOREACH item IN something %] ... [% END %] The automagic promotion of scalars to single item lists means that you can also use list virtual methods safely, even if you only get one item returned. For example: [% something.first %] [% something.join %] [% something.reverse.join(', ') %] Note that this is very much a last-ditch behaviour. If the single item return is an object with a C<first> method, for example, then that will be called, as expected, in preference to the list virtual method. =head1 Defining Custom Virtual Methods You can define your own virtual methods for scalars, lists and hash arrays. The L<Template::Stash> package variables C<$SCALAR_OPS>, C<$LIST_OPS> and C<$HASH_OPS> are references to hash arrays that define these virtual methods. C<HASH_OPS> and C<LIST_OPS> methods are subroutines that accept a hash/list reference as the first item. C<SCALAR_OPS> are subroutines that accept a scalar value as the first item. Any other arguments specified when the method is called will be passed to the subroutine. # load Template::Stash to make method tables visible use Template::Stash; # define list method to return new list of odd numbers only $Template::Stash::LIST_OPS->{ odd } = sub { my $list = shift; return [ grep { $_ % 2 } @$list ]; }; Example template: [% primes = [ 2, 3, 5, 7, 9 ] %] [% primes.odd.join(', ') %] # 3, 5, 7, 9 TODO: document the define_vmethod() method which makes this even easier =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Manual/Directives.pod 0000444 00000170310 15125513451 0012732 0 ustar 00 #============================================================= -*-perl-*- # # Template::Manual::Directives # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Manual::Directives - Template directives =head1 Accessing and Updating Template Variables =head2 GET The C<GET> directive retrieves and outputs the value of the named variable. [% GET foo %] The C<GET> keyword is optional. A variable can be specified in a directive tag by itself. [% foo %] The variable can have an unlimited number of elements, each separated by a dot. Each element can have arguments specified within parentheses. [% foo %] [% bar.baz %] [% biz.baz(10) %] ...etc... See L<Template::Manual::Variables> for a full discussion on template variables. You can also specify expressions using the logical (C<and>, C<or>, C<not>, C<?>, C<:>) and mathematic operators (C<+>, C<->, C<*>, C</>, C<%>, C<mod>, C<div>). [% template.title or default.title %] [% score * 100 %] [% order.nitems ? checkout(order.total) : 'no items' %] The C<div> operator returns the integer result of division. Both C<%> and C<mod> return the modulus (i.e. remainder) of division. [% 15 / 6 %] # 2.5 [% 15 div 6 %] # 2 [% 15 mod 6 %] # 3 =head2 CALL The C<CALL> directive is similar to C<GET> in evaluating the variable named, but doesn't print the result returned. This can be useful when a variable is bound to a sub-routine or object method which you want to call but aren't interested in the value returned. [% CALL dbi.disconnect %] [% CALL inc_page_counter(page_count) %] =head2 SET The C<SET> directive allows you to assign new values to existing variables or create new temporary variables. [% SET title = 'Hello World' %] The C<SET> keyword is also optional. [% title = 'Hello World' %] Variables may be assigned the values of other variables, unquoted numbers (2.718), literal text ('single quotes') or quoted text ("double quotes"). In the latter case, any variable references within the text will be interpolated when the string is evaluated. Variables should be prefixed by C<$>, using curly braces to explicitly scope the variable name where necessary. [% foo = 'Foo' %] # literal value 'Foo' [% bar = foo %] # value of variable 'foo' [% cost = '$100' %] # literal value '$100' [% item = "$bar: ${cost}.00" %] # value "Foo: $100.00" Multiple variables may be assigned in the same directive and are evaluated in the order specified. Thus, the above could have been written: [% foo = 'Foo' bar = foo cost = '$100' item = "$bar: ${cost}.00" %] Simple expressions can also be used, as per C<GET>. [% ten = 10 twenty = 20 thirty = twenty + ten forty = 2 * twenty fifty = 100 div 2 six = twenty mod 7 %] You can concatenate strings together using the C<'_'> underscore operator. In Perl 5, the C<.> dot is used for string concatenation, but in Perl 6, as in the Template Toolkit, the C<.> dot will be used as the method calling operator and C<'_'> underscore will be used for string concatenation. Note that the operator must be specified with surrounding whitespace which, as Larry says, is construed as a feature: [% copyright = '(C) Copyright' _ year _ ' ' _ author %] You can, of course, achieve a similar effect with double quoted string interpolation. [% copyright = "(C) Copyright $year $author" %] =head2 DEFAULT The C<DEFAULT> directive is similar to C<SET> but only updates variables that are currently undefined or have no "true" value (in the Perl sense). [% DEFAULT name = 'John Doe' id = 'jdoe' %] This can be particularly useful in common template components to ensure that some sensible default are provided for otherwise undefined variables. [% DEFAULT title = 'Hello World' bgcol = '#ffffff' %] <html> <head> <title>[% title %]</title> </head> <body bgcolor="[% bgcol %]"> ...etc... =head1 Processing Template Files and Blocks =head2 INSERT The C<INSERT> directive is used to insert the contents of an external file at the current position. [% INSERT myfile %] No attempt to parse or process the file is made. The contents, possibly including any embedded template directives, are inserted intact. The filename specified should be relative to one of the C<INCLUDE_PATH> directories. Absolute (i.e. starting with C</>) and relative (i.e. starting with C<.>) filenames may be used if the C<ABSOLUTE> and C<RELATIVE> options are set, respectively. Both these options are disabled by default. my $template = Template->new({ INCLUDE_PATH => '/here:/there', }); $template->process('myfile'); F<myfile>: [% INSERT foo %] # looks for /here/foo then /there/foo [% INSERT /etc/passwd %] # file error: ABSOLUTE not set [% INSERT ../secret %] # file error: RELATIVE not set For convenience, the filename does not need to be quoted as long as it contains only alphanumeric characters, underscores, dots or forward slashes. Names containing any other characters should be quoted. [% INSERT misc/legalese.txt %] [% INSERT 'dos98/Program Files/stupid' %] To evaluate a variable to specify a filename, you should explicitly prefix it with a C<$> or use double-quoted string interpolation. [% language = 'en' legalese = 'misc/legalese.txt' %] [% INSERT $legalese %] # misc/legalese.txt [% INSERT "$language/$legalese" %] # en/misc/legalese.txt Multiple files can be specified using C<+> as a delimiter. All files should be unquoted names or quoted strings. Any variables should be interpolated into double-quoted strings. [% INSERT legalese.txt + warning.txt %] [% INSERT "$legalese" + warning.txt %] # requires quoting =head2 INCLUDE The C<INCLUDE> directive is used to process and include the output of another template file or block. [% INCLUDE header %] If a C<BLOCK> of the specified name is defined in the same file, or in a file from which the current template has been called (i.e. a parent template) then it will be used in preference to any file of the same name. [% INCLUDE table %] # uses BLOCK defined below [% BLOCK table %] <table> ... </table> [% END %] If a C<BLOCK> definition is not currently visible then the template name should be a file relative to one of the C<INCLUDE_PATH> directories, or an absolute or relative file name if the C<ABSOLUTE>/C<RELATIVE> options are appropriately enabled. The C<INCLUDE> directive automatically quotes the filename specified, as per C<INSERT> described above. When a variable contains the name of the template for the C<INCLUDE> directive, it should be explicitly prefixed by C<$> or double-quoted [% myheader = 'my/misc/header' %] [% INCLUDE myheader %] # 'myheader' [% INCLUDE $myheader %] # 'my/misc/header' [% INCLUDE "$myheader" %] # 'my/misc/header' Any template directives embedded within the file will be processed accordingly. All variables currently defined will be visible and accessible from within the included template. [% title = 'Hello World' %] [% INCLUDE header %] <body> ... F<header>: <html> <title>[% title %]</title> output: <html> <title>Hello World</title> <body> ... Local variable definitions may be specified after the template name, temporarily masking any existing variables. Insignificant whitespace is ignored within directives so you can add variable definitions on the same line, the next line or split across several line with comments interspersed, if you prefer. [% INCLUDE table %] [% INCLUDE table title="Active Projects" %] [% INCLUDE table title = "Active Projects" bgcolor = "#80ff00" # chartreuse border = 2 %] The C<INCLUDE> directive localises (i.e. copies) all variables before processing the template. Any changes made within the included template will not affect variables in the including template. [% foo = 10 %] foo is originally [% foo %] [% INCLUDE bar %] foo is still [% foo %] [% BLOCK bar %] foo was [% foo %] [% foo = 20 %] foo is now [% foo %] [% END %] output: foo is originally 10 foo was 10 foo is now 20 foo is still 10 Technical Note: the localisation of the stash (that is, the process by which variables are copied before an C<INCLUDE> to prevent being overwritten) is only skin deep. The top-level variable namespace (hash) is copied, but no attempt is made to perform a deep-copy of other structures (hashes, arrays, objects, etc.) Therefore, a C<foo> variable referencing a hash will be copied to create a new C<foo> variable but which points to the same hash array. Thus, if you update compound variables (e.g. C<foo.bar>) then you will change the original copy, regardless of any stash localisation. If you're not worried about preserving variable values, or you trust the templates you're including then you might prefer to use the C<PROCESS> directive which is faster by virtue of not performing any localisation. You can specify dotted variables as "local" variables to an C<INCLUDE> directive. However, be aware that because of the localisation issues explained above (if you skipped the previous Technical Note above then you might want to go back and read it or skip this section too), the variables might not actually be "local". If the first element of the variable name already references a hash array then the variable update will affect the original variable. [% foo = { bar = 'Baz' } %] [% INCLUDE somefile foo.bar='Boz' %] [% foo.bar %] # Boz This behaviour can be a little unpredictable (and may well be improved upon in a future version). If you know what you're doing with it and you're sure that the variables in question are defined (nor not) as you expect them to be, then you can rely on this feature to implement some powerful "global" data sharing techniques. Otherwise, you might prefer to steer well clear and always pass simple (undotted) variables as parameters to C<INCLUDE> and other similar directives. If you want to process several templates in one go then you can specify each of their names (quoted or unquoted names only, no unquoted C<$variables>) joined together by C<+>. The C<INCLUDE> directive will then process them in order. [% INCLUDE html/header + "site/$header" + site/menu title = "My Groovy Web Site" %] The variable stash is localised once and then the templates specified are processed in order, all within that same variable context. This makes it slightly faster than specifying several separate C<INCLUDE> directives (because you only clone the variable stash once instead of n times), but not quite as "safe" because any variable changes in the first file will be visible in the second, third and so on. This might be what you want, of course, but then again, it might not. =head2 PROCESS The PROCESS directive is similar to C<INCLUDE> but does not perform any localisation of variables before processing the template. Any changes made to variables within the included template will be visible in the including template. [% foo = 10 %] foo is [% foo %] [% PROCESS bar %] foo is [% foo %] [% BLOCK bar %] [% foo = 20 %] changed foo to [% foo %] [% END %] output: foo is 10 changed foo to 20 foo is 20 Parameters may be specified in the C<PROCESS> directive, but these too will become visible changes to current variable values. [% foo = 10 %] foo is [% foo %] [% PROCESS bar foo = 20 %] foo is [% foo %] [% BLOCK bar %] this is bar, foo is [% foo %] [% END %] output: foo is 10 this is bar, foo is 20 foo is 20 The C<PROCESS> directive is slightly faster than C<INCLUDE> because it avoids the need to localise (i.e. copy) the variable stash before processing the template. As with C<INSERT> and C<INCLUDE>, the first parameter does not need to be quoted as long as it contains only alphanumeric characters, underscores, periods or forward slashes. A C<$> prefix can be used to explicitly indicate a variable which should be interpolated to provide the template name: [% myheader = 'my/misc/header' %] [% PROCESS myheader %] # 'myheader' [% PROCESS $myheader %] # 'my/misc/header' As with C<INCLUDE>, multiple templates can be specified, delimited by C<+>, and are processed in order. [% PROCESS html/header + my/header %] =head2 WRAPPER It's not unusual to find yourself adding common headers and footers to pages or sub-sections within a page. Something like this: [% INCLUDE section/header title = 'Quantum Mechanics' %] Quantum mechanics is a very interesting subject wish should prove easy for the layman to fully comprehend. [% INCLUDE section/footer %] [% INCLUDE section/header title = 'Desktop Nuclear Fusion for under $50' %] This describes a simple device which generates significant sustainable electrical power from common tap water by process of nuclear fusion. [% INCLUDE section/footer %] The individual template components being included might look like these: section/header: <p> <h2>[% title %]</h2> section/footer: </p> The C<WRAPPER> directive provides a way of simplifying this a little. It encloses a block up to a matching C<END> directive, which is first processed to generate some output. This is then passed to the named template file or C<BLOCK> as the C<content> variable. [% WRAPPER section title = 'Quantum Mechanics' %] Quantum mechanics is a very interesting subject wish should prove easy for the layman to fully comprehend. [% END %] [% WRAPPER section title = 'Desktop Nuclear Fusion for under $50' %] This describes a simple device which generates significant sustainable electrical power from common tap water by process of nuclear fusion. [% END %] The single 'section' template can then be defined as: <h2>[% title %]</h2> <p> [% content %] </p> Like other block directives, it can be used in side-effect notation: [% INSERT legalese.txt WRAPPER big_bold_table %] It's also possible to specify multiple templates to a C<WRAPPER> directive. The specification order indicates outermost to innermost wrapper templates. For example, given the following template block definitions: [% BLOCK bold %]<b>[% content %]</b>[% END %] [% BLOCK italic %]<i>[% content %]</i>[% END %] the directive [% WRAPPER bold+italic %]Hello World[% END %] would generate the following output: <b><i>Hello World</i></b> =head2 BLOCK The C<BLOCK>...C<END> construct can be used to define template component blocks which can be processed with the C<INCLUDE>, C<PROCESS> and C<WRAPPER> directives. [% BLOCK tabrow %] <tr> <td>[% name %]<td> <td>[% email %]</td> </tr> [% END %] <table> [% PROCESS tabrow name='Fred' email='fred@nowhere.com' %] [% PROCESS tabrow name='Alan' email='alan@nowhere.com' %] </table> A C<BLOCK> definition can be used before it is defined, as long as the definition resides in the same file. The block definition itself does not generate any output. [% PROCESS tmpblk %] [% BLOCK tmpblk %] This is OK [% END %] You can use an anonymous C<BLOCK> to capture the output of a template fragment. [% julius = BLOCK %] And Caesar's spirit, ranging for revenge, With Ate by his side come hot from hell, Shall in these confines with a monarch's voice Cry 'Havoc', and let slip the dogs of war; That this foul deed shall smell above the earth With carrion men, groaning for burial. [% END %] Like a named block, it can contain any other template directives which are processed when the block is defined. The output generated by the block is then assigned to the variable C<julius>. Anonymous C<BLOCK>s can also be used to define block macros. The enclosing block is processed each time the macro is called. [% MACRO locate BLOCK %] The [% animal %] sat on the [% place %]. [% END %] [% locate(animal='cat', place='mat') %] # The cat sat on the mat [% locate(animal='dog', place='log') %] # The dog sat on the log =head1 Conditional Processing =head2 IF / UNLESS / ELSIF / ELSE The C<IF> and C<UNLESS> directives can be used to process or ignore a block based on some run-time condition. [% IF frames %] [% INCLUDE frameset %] [% END %] [% UNLESS text_mode %] [% INCLUDE biglogo %] [% END %] Multiple conditions may be joined with C<ELSIF> and/or C<ELSE> blocks. [% IF age < 10 %] Hello [% name %], does your mother know you're using her AOL account? [% ELSIF age < 18 %] Sorry, you're not old enough to enter (and too dumb to lie about your age) [% ELSE %] Welcome [% name %]. [% END %] The following conditional and boolean operators may be used: == != < <= > >= && || ! and or not Conditions may be arbitrarily complex and are evaluated with the same precedence as in Perl. Parenthesis may be used to explicitly determine evaluation order. # ridiculously contrived complex example [% IF (name == 'admin' || uid <= 0) && mode == 'debug' %] I'm confused. [% ELSIF more > less %] That's more or less correct. [% END %] The C<and>, C<or> and C<not> operator are provided as aliases for C<&&>, C<||> and C<!>, respectively. Unlike Perl, which treats C<and>, C<or> and C<not> as separate, lower-precedence versions of the other operators, the Template Toolkit performs a straightforward substitution of C<and> for C<&&>, and so on. That means that C<and>, C<or> and C<not> have the same operator precedence as C<&&>, C<||> and C<!>. =head2 SWITCH / CASE The C<SWITCH> / C<CASE> construct can be used to perform a multi-way conditional test. The C<SWITCH> directive expects an expression which is first evaluated and then compared against each CASE statement in turn. Each C<CASE> directive should contain a single value or a list of values which should match. C<CASE> may also be left blank or written as C<[% CASE DEFAULT %]> to specify a default match. Only one C<CASE> matches, there is no drop-through between C<CASE> statements. [% SWITCH myvar %] [% CASE 'value1' %] ... [% CASE ['value2', 'value3'] %] # multiple values ... [% CASE myhash.keys %] # ditto ... [% CASE %] # default ... [% END %] =head1 Loop Processing =head2 FOREACH The C<FOREACH> directive will iterate through the items in a list, processing the enclosed block for each one. [% foo = 'Foo' items = [ 'one', 'two', 'three' ] %] Things: [% FOREACH thing IN [ foo 'Bar' "$foo Baz" ] %] * [% thing %] [% END %] Items: [% FOREACH i IN items %] * [% i %] [% END %] Stuff: [% stuff = [ foo "$foo Bar" ] %] [% FOREACH s IN stuff %] * [% s %] [% END %] output: Things: * Foo * Bar * Foo Baz Items: * one * two * three Stuff: * Foo * Foo Bar You can use also use C<=> instead of C<IN> if you prefer. [% FOREACH i = items %] When the C<FOREACH> directive is used without specifying a target variable, any iterated values which are hash references will be automatically imported. [% userlist = [ { id => 'tom', name => 'Thomas' }, { id => 'dick', name => 'Richard' }, { id => 'larry', name => 'Lawrence' }, ] %] [% FOREACH user IN userlist %] [% user.id %] [% user.name %] [% END %] short form: [% FOREACH userlist %] [% id %] [% name %] [% END %] Note that this particular usage creates a localised variable context to prevent the imported hash keys from overwriting any existing variables. The imported definitions and any other variables defined in such a C<FOREACH> loop will be lost at the end of the loop, when the previous context and variable values are restored. However, under normal operation, the loop variable remains in scope after the C<FOREACH> loop has ended (caveat: overwriting any variable previously in scope). This is useful as the loop variable is secretly an iterator object (see below) and can be used to analyse the last entry processed by the loop. The C<FOREACH> directive can also be used to iterate through the entries in a hash array. Each entry in the hash is returned in sorted order (based on the key) as a hash array containing 'key' and 'value' items. [% users = { tom => 'Thomas', dick => 'Richard', larry => 'Lawrence', } %] [% FOREACH u IN users %] * [% u.key %] : [% u.value %] [% END %] Output: * dick : Richard * larry : Lawrence * tom : Thomas The C<NEXT> directive starts the next iteration in the C<FOREACH> loop. [% FOREACH user IN userlist %] [% NEXT IF user.isguest %] Name: [% user.name %] Email: [% user.email %] [% END %] The C<LAST> directive can be used to prematurely exit the loop. C<BREAK> is also provided as an alias for C<LAST>. [% FOREACH match IN results.nsort('score').reverse %] [% LAST IF match.score < 50 %] [% match.score %] : [% match.url %] [% END %] The C<FOREACH> directive is implemented using the L<Template::Iterator> module. A reference to the iterator object for a C<FOREACH> directive is implicitly available in the C<loop> variable. The following methods can be called on the C<loop> iterator. size() number of elements in the list max() index number of last element (size - 1) index() index of current iteration from 0 to max() count() iteration counter from 1 to size() (i.e. index() + 1) first() true if the current iteration is the first last() true if the current iteration is the last prev() return the previous item in the list next() return the next item in the list See L<Template::Iterator> for further details. Example: [% FOREACH item IN [ 'foo', 'bar', 'baz' ] -%] [%- "<ul>\n" IF loop.first %] <li>[% loop.count %]/[% loop.size %]: [% item %] [%- "</ul>\n" IF loop.last %] [% END %] Output: <ul> <li>1/3: foo <li>2/3: bar <li>3/3: baz </ul> Nested loops will work as expected, with the C<loop> variable correctly referencing the innermost loop and being restored to any previous value (i.e. an outer loop) at the end of the loop. [% FOREACH group IN grouplist; # loop => group iterator "Groups:\n" IF loop.first; FOREACH user IN group.userlist; # loop => user iterator "$loop.count: $user.name\n"; END; # loop => group iterator "End of Groups\n" IF loop.last; END %] The C<iterator> plugin can also be used to explicitly create an iterator object. This can be useful within nested loops where you need to keep a reference to the outer iterator within the inner loop. The iterator plugin effectively allows you to create an iterator by a name other than C<loop>. See L<Template::Plugin::Iterator> for further details. [% USE giter = iterator(grouplist) %] [% FOREACH group IN giter %] [% FOREACH user IN group.userlist %] user #[% loop.count %] in group [% giter.count %] is named [% user.name %] [% END %] [% END %] =head2 WHILE The C<WHILE> directive can be used to repeatedly process a template block while a conditional expression evaluates true. The expression may be arbitrarily complex as per C<IF> / C<UNLESS>. [% WHILE total < 100 %] ... [% total = calculate_new_total %] [% END %] An assignment can be enclosed in parenthesis to evaluate the assigned value. [% WHILE (user = get_next_user_record) %] [% user.name %] [% END %] The C<NEXT> directive can be used to start the next iteration of a C<WHILE> loop and C<BREAK> can be used to exit the loop, both as per C<FOREACH>. The Template Toolkit uses a failsafe counter to prevent runaway C<WHILE> loops which would otherwise never terminate. If the loop exceeds 1000 iterations then an C<undef> exception will be thrown, reporting the error: WHILE loop terminated (> 1000 iterations) The C<$Template::Directive::WHILE_MAX> variable controls this behaviour and can be set to a higher value if necessary. =head1 Filters, Plugins, Macros and Perl =head2 FILTER The C<FILTER> directive can be used to post-process the output of a block. A number of standard filters are provided with the Template Toolkit. The C<html> filter, for example, escapes the 'E<lt>', 'E<gt>' and '&' characters to prevent them from being interpreted as HTML tags or entity reference markers. [% FILTER html %] HTML text may have < and > characters embedded which you want converted to the correct HTML entities. [% END %] output: HTML text may have < and > characters embedded which you want converted to the correct HTML entities. The C<FILTER> directive can also follow various other non-block directives. For example: [% INCLUDE mytext FILTER html %] The C<|> character can also be used as an alias for C<FILTER>. [% INCLUDE mytext | html %] Multiple filters can be chained together and will be called in sequence. [% INCLUDE mytext FILTER html FILTER html_para %] or [% INCLUDE mytext | html | html_para %] Filters come in two flavours, known as 'static' or 'dynamic'. A static filter is a simple subroutine which accepts a text string as the only argument and returns the modified text. The C<html> filter is an example of a static filter, implemented as: sub html_filter { my $text = shift; for ($text) { s/&/&/g; s/</</g; s/>/>/g; } return $text; } Dynamic filters can accept arguments which are specified when the filter is called from a template. The C<repeat> filter is such an example, accepting a numerical argument which specifies the number of times that the input text should be repeated. [% FILTER repeat(3) %]blah [% END %] output: blah blah blah These are implemented as filter 'factories'. The factory subroutine is passed a reference to the current L<Template::Context> object along with any additional arguments specified. It should then return a subroutine reference (e.g. a closure) which implements the filter. The C<repeat> filter factory is implemented like this: sub repeat_filter_factory { my ($context, $iter) = @_; $iter = 1 unless defined $iter; return sub { my $text = shift; $text = '' unless defined $text; return join('\n', $text) x $iter; } } The C<FILTERS> option, described in L<Template::Manual::Config>, allows custom filters to be defined when a Template object is instantiated. The L<define_filter()|Template::Context#define_filter()> method allows further filters to be defined at any time. When using a filter, it is possible to assign an alias to it for further use. This is most useful for dynamic filters that you want to re-use with the same configuration. [% FILTER echo = repeat(2) %] Is there anybody out there? [% END %] [% FILTER echo %] Mother, should I build a wall? [% END %] Output: Is there anybody out there? Is there anybody out there? Mother, should I build a wall? Mother, should I build a wall? The C<FILTER> directive automatically quotes the name of the filter. As with C<INCLUDE> et al, you can use a variable to provide the name of the filter, prefixed by C<$>. [% myfilter = 'html' %] [% FILTER $myfilter %] # same as [% FILTER html %] ... [% END %] A template variable can also be used to define a static filter subroutine. However, the Template Toolkit will automatically call any subroutine bound to a variable and use the value returned. Thus, the above example could be implemented as: my $vars = { myfilter => sub { return 'html' }, }; template: [% FILTER $myfilter %] # same as [% FILTER html %] ... [% END %] To define a template variable that evaluates to a subroutine reference that can be used by the C<FILTER> directive, you should create a subroutine that, when called automatically by the Template Toolkit, returns another subroutine reference which can then be used to perform the filter operation. Note that only static filters can be implemented in this way. my $vars = { myfilter => sub { \&my_filter_sub }, }; sub my_filter_sub { my $text = shift; # do something return $text; } template: [% FILTER $myfilter %] ... [% END %] Alternately, you can bless a subroutine reference into a class (any class will do) to fool the Template Toolkit into thinking it's an object rather than a subroutine. This will then bypass the automatic "call-a-subroutine-to-return-a-value" magic. my $vars = { myfilter => bless(\&my_filter_sub, 'anything_you_like'), }; template: [% FILTER $myfilter %] ... [% END %] Filters bound to template variables remain local to the variable context in which they are defined. That is, if you define a filter in a C<PERL> block within a template that is loaded via C<INCLUDE>, then the filter definition will only exist until the end of that template when the stash is delocalised, restoring the previous variable state. If you want to define a filter which persists for the lifetime of the processor, or define additional dynamic filter factories, then you can call the L<define_filter()|Template::Context#define_filter()> method on the current L<Template::Context> object. See L<Template::Manual::Filters> for a complete list of available filters, their descriptions and examples of use. =head2 USE The C<USE> directive can be used to load and initialise "plugin" extension modules. [% USE myplugin %] A plugin is a regular Perl module that conforms to a particular object-oriented interface, allowing it to be loaded into and used automatically by the Template Toolkit. For details of this interface and information on writing plugins, consult L<Template::Plugin>. A number of standard plugins are included with the Template Toolkit (see below and L<Template::Manual::Plugins>). The names of these standard plugins are case insensitive. [% USE CGI %] # => Template::Plugin::CGI [% USE Cgi %] # => Template::Plugin::CGI [% USE cgi %] # => Template::Plugin::CGI You can also define further plugins using the C<PLUGINS> option. my $tt = Template->new({ PLUGINS => { foo => 'My::Plugin::Foo', bar => 'My::Plugin::Bar', }, }); The recommended convention is to specify these plugin names in lower case. The Template Toolkit first looks for an exact case-sensitive match and then tries the lower case conversion of the name specified. [% USE Foo %] # look for 'Foo' then 'foo' If you define all your C<PLUGINS> with lower case names then they will be located regardless of how the user specifies the name in the C<USE> directive. If, on the other hand, you define your C<PLUGINS> with upper or mixed case names then the name specified in the C<USE> directive must match the case exactly. If the plugin isn't defined in either the standard plugins (C<$Template::Plugins::STD_PLUGINS>) or via the C<PLUGINS> option, then the C<PLUGIN_BASE> is searched. In this case the plugin name I<is> case-sensitive. It is appended to each of the C<PLUGIN_BASE> module namespaces in turn (default: C<Template::Plugin>) to construct a full module name which it attempts to locate and load. Any periods, 'C<.>', in the name will be converted to 'C<::>'. [% USE MyPlugin %] # => Template::Plugin::MyPlugin [% USE Foo.Bar %] # => Template::Plugin::Foo::Bar The C<LOAD_PERL> option (disabled by default) provides a further way by which external Perl modules may be loaded. If a regular Perl module (i.e. not a C<Template::Plugin::*> or other module relative to some C<PLUGIN_BASE>) supports an object-oriented interface and a C<new()> constructor then it can be loaded and instantiated automatically. The following trivial example shows how the IO::File module might be used. [% USE file = IO.File('/tmp/mydata') %] [% WHILE (line = file.getline) %] <!-- [% line %] --> [% END %] Any additional parameters supplied in parenthesis after the plugin name will be also be passed to the C<new()> constructor. A reference to the current L<Template::Context> object is passed as the first parameter. [% USE MyPlugin('foo', 123) %] equivalent to: Template::Plugin::MyPlugin->new($context, 'foo', 123); The only exception to this is when a module is loaded via the C<LOAD_PERL> option. In this case the C<$context> reference is I<not> passed to the C<new()> constructor. This is based on the assumption that the module is a regular Perl module rather than a Template Toolkit plugin so isn't expecting a context reference and wouldn't know what to do with it anyway. Named parameters may also be specified. These are collated into a hash which is passed by reference as the last parameter to the constructor, as per the general code calling interface. [% USE url('/cgi-bin/foo', mode='submit', debug=1) %] equivalent to: Template::Plugin::URL->new( $context, '/cgi-bin/foo' { mode => 'submit', debug => 1 } ); The plugin may represent any data type; a simple variable, hash, list or code reference, but in the general case it will be an object reference. Methods can be called on the object (or the relevant members of the specific data type) in the usual way: [% USE table(mydata, rows=3) %] [% FOREACH row IN table.rows %] <tr> [% FOREACH item IN row %] <td>[% item %]</td> [% END %] </tr> [% END %] An alternative name may be provided for the plugin by which it can be referenced: [% USE scores = table(myscores, cols=5) %] [% FOREACH row IN scores.rows %] ... [% END %] You can use this approach to create multiple plugin objects with different configurations. This example shows how the L<format|Template::Plugin::Format> plugin is used to create sub-routines bound to variables for formatting text as per C<printf()>. [% USE bold = format('<b>%s</b>') %] [% USE ital = format('<i>%s</i>') %] [% bold('This is bold') %] [% ital('This is italic') %] Output: <b>This is bold</b> <i>This is italic</i> This next example shows how the L<URL|Template::Plugin::URL> plugin can be used to build dynamic URLs from a base part and optional query parameters. [% USE mycgi = URL('/cgi-bin/foo.pl', debug=1) %] <a href="[% mycgi %]">... <a href="[% mycgi(mode='submit') %]"... Output: <a href="/cgi-bin/foo.pl?debug=1">... <a href="/cgi-bin/foo.pl?mode=submit&debug=1">... The L<CGI|Template::Plugin::CGI> plugin is an example of one which delegates to another Perl module. In this case, to Lincoln Stein's C<CGI> module. All of the methods provided by the C<CGI> module are available via the plugin. [% USE CGI; CGI.start_form; CGI.checkbox_group( name = 'colours', values = [ 'red' 'green' 'blue' ] ); CGI.popup_menu( name = 'items', values = [ 'foo' 'bar' 'baz' ] ); CGI.end_form %] See L<Template::Manual::Plugins> for more information on the plugins distributed with the toolkit or available from CPAN. =head2 MACRO The C<MACRO> directive allows you to define a directive or directive block which is then evaluated each time the macro is called. [% MACRO header INCLUDE header %] Calling the macro as: [% header %] is then equivalent to: [% INCLUDE header %] Macros can be passed named parameters when called. These values remain local to the macro. [% header(title='Hello World') %] equivalent to: [% INCLUDE header title='Hello World' %] A C<MACRO> definition may include parameter names. Values passed to the macros are then mapped to these local variables. Other named parameters may follow these. [% MACRO header(title) INCLUDE header %] [% header('Hello World') %] [% header('Hello World', bgcol='#123456') %] equivalent to: [% INCLUDE header title='Hello World' %] [% INCLUDE header title='Hello World' bgcol='#123456' %] Here's another example, defining a macro for display numbers in comma-delimited groups of 3, using the chunk and join virtual method. [% MACRO number(n) GET n.chunk(-3).join(',') %] [% number(1234567) %] # 1,234,567 A C<MACRO> may precede any directive and must conform to the structure of the directive. [% MACRO header IF frames %] [% INCLUDE frames/header %] [% ELSE %] [% INCLUDE header %] [% END %] [% header %] A C<MACRO> may also be defined as an anonymous C<BLOCK>. The block will be evaluated each time the macro is called. [% MACRO header BLOCK %] ...content... [% END %] [% header %] If you've got the C<EVAL_PERL> option set, then you can even define a C<MACRO> as a C<PERL> block (see below): [% MACRO triple(n) PERL %] my $n = $stash->get('n'); print $n * 3; [% END -%] =head2 PERL (for the advanced reader) The C<PERL> directive is used to mark the start of a block which contains Perl code for evaluation. The C<EVAL_PERL> option must be enabled for Perl code to be evaluated or a C<perl> exception will be thrown with the message 'C<EVAL_PERL not set>'. Perl code is evaluated in the C<Template::Perl> package. The C<$context> package variable contains a reference to the current L<Template::Context> object. This can be used to access the functionality of the Template Toolkit to process other templates, load plugins, filters, etc. See L<Template::Context> for further details. [% PERL %] print $context->include('myfile'); [% END %] The L<$stash> variable contains a reference to the top-level stash object which manages template variables. Through this, variable values can be retrieved and updated. See L<Template::Stash> for further details. [% PERL %] $stash->set(foo => 'bar'); print "foo value: ", $stash->get('foo'); [% END %] Output: foo value: bar Output is generated from the C<PERL> block by calling C<print()>. Note that the C<Template::Perl::PERLOUT> handle is selected (tied to an output buffer) instead of C<STDOUT>. [% PERL %] print "foo\n"; # OK print PERLOUT "bar\n"; # OK, same as above print Template::Perl::PERLOUT "baz\n"; # OK, same as above print STDOUT "qux\n"; # WRONG! [% END %] The C<PERL> block may contain other template directives. These are processed before the Perl code is evaluated. [% name = 'Fred Smith' %] [% PERL %] print "[% name %]\n"; [% END %] Thus, the Perl code in the above example is evaluated as: print "Fred Smith\n"; Exceptions may be thrown from within C<PERL> blocks using C<die()>. They will be correctly caught by enclosing C<TRY> blocks. [% TRY %] [% PERL %] die "nothing to live for\n"; [% END %] [% CATCH %] error: [% error.info %] [% END %] output: error: nothing to live for =head2 RAWPERL (for the very advanced reader) The Template Toolkit parser reads a source template and generates the text of a Perl subroutine as output. It then uses C<eval()> to evaluate it into a subroutine reference. This subroutine is then called to process the template, passing a reference to the current L<Template::Context> object through which the functionality of the Template Toolkit can be accessed. The subroutine reference can be cached, allowing the template to be processed repeatedly without requiring any further parsing. For example, a template such as: [% PROCESS header %] The [% animal %] sat on the [% location %] [% PROCESS footer %] is converted into the following Perl subroutine definition: sub { my $context = shift; my $stash = $context->stash; my $output = ''; my $error; eval { BLOCK: { $output .= $context->process('header'); $output .= "The "; $output .= $stash->get('animal'); $output .= " sat on the "; $output .= $stash->get('location'); $output .= $context->process('footer'); $output .= "\n"; } }; if ($@) { $error = $context->catch($@, \$output); die $error unless $error->type eq 'return'; } return $output; } To examine the Perl code generated, such as in the above example, set the C<$Template::Parser::DEBUG> package variable to any true value. You can also set the C<$Template::Directive::PRETTY> variable true to have the code formatted in a readable manner for human consumption. The source code for each generated template subroutine will be printed to C<STDERR> on compilation (i.e. the first time a template is used). $Template::Parser::DEBUG = 1; $Template::Directive::PRETTY = 1; $template->process($file, $vars) || die $template->error(), "\n"; The C<PERL> ... C<END> construct allows Perl code to be embedded into a template when the C<EVAL_PERL> option is set. It is evaluated at "runtime" using C<eval()> each time the template subroutine is called. This is inherently flexible, but not as efficient as it could be, especially in a persistent server environment where a template may be processed many times. The C<RAWPERL> directive allows you to write Perl code that is integrated directly into the generated Perl subroutine text. It is evaluated once at compile time and is stored in cached form as part of the compiled template subroutine. This makes C<RAWPERL> blocks more efficient than C<PERL> blocks. The downside is that you must code much closer to the metal. For example, in a C<PERL> block you can call L<print()> to generate some output. C<RAWPERL> blocks don't afford such luxury. The code is inserted directly into the generated subroutine text and should conform to the convention of appending to the C<$output> variable. [% PROCESS header %] [% RAWPERL %] $output .= "Some output\n"; ... $output .= "Some more output\n"; [% END %] The critical section of the generated subroutine for this example would then look something like: ... eval { BLOCK: { $output .= $context->process('header'); $output .= "\n"; $output .= "Some output\n"; ... $output .= "Some more output\n"; $output .= "\n"; } }; ... As with C<PERL> blocks, the L<$context|Template::Context> and L<$stash|Template::Stash> references are pre-defined and available for use within C<RAWPERL> code. =head1 Exception Handling and Flow Control =head2 TRY / THROW / CATCH / FINAL (more advanced material) The Template Toolkit supports fully functional, nested exception handling. The C<TRY> directive introduces an exception handling scope which continues until the matching C<END> directive. Any errors that occur within that block will be caught and can be handled by one of the C<CATCH> blocks defined. [% TRY %] ...blah...blah... [% CALL somecode %] ...etc... [% INCLUDE someblock %] ...and so on... [% CATCH %] An error occurred! [% END %] Errors are raised as exceptions (objects of the L<Template::Exception> class) which contain two fields: C<type> and C<info>. The exception C<type> is used to indicate the kind of error that occurred. It is a simple text string which can contain letters, numbers, 'C<_>' or 'C<.>'. The C<info> field contains an error message indicating what actually went wrong. Within a catch block, the exception object is aliased to the C<error> variable. You can access the C<type> and C<info> fields directly. [% mydsn = 'dbi:MySQL:foobar' %] ... [% TRY %] [% USE DBI(mydsn) %] [% CATCH %] ERROR! Type: [% error.type %] Info: [% error.info %] [% END %] output (assuming a non-existent database called 'C<foobar>'): ERROR! Type: DBI Info: Unknown database "foobar" The C<error> variable can also be specified by itself and will return a string of the form "C<$type error - $info>". ... [% CATCH %] ERROR: [% error %] [% END %] Output: ERROR: DBI error - Unknown database "foobar" Each C<CATCH> block may be specified with a particular exception type denoting the kind of error that it should catch. Multiple C<CATCH> blocks can be provided to handle different types of exception that may be thrown in the C<TRY> block. A C<CATCH> block specified without any type, as in the previous example, is a default handler which will catch any otherwise uncaught exceptions. This can also be specified as C<[% CATCH DEFAULT %]>. [% TRY %] [% INCLUDE myfile %] [% USE DBI(mydsn) %] [% CALL somecode %] [% CATCH file %] File Error! [% error.info %] [% CATCH DBI %] [% INCLUDE database/error.html %] [% CATCH %] [% error %] [% END %] Remember that you can specify multiple directives within a single tag, each delimited by 'C<;>'. So the above example can be written more concisely as: [% TRY; INCLUDE myfile; USE DBI(mydsn); CALL somecode; CATCH file; "File Error! $error.info"; CATCH DBI; INCLUDE database/error.html; CATCH; error; END %] The C<DBI> plugin throws exceptions of the C<DBI> type (in case that wasn't already obvious). The other specific exception caught here is of the C<file> type. A C<file> exception is automatically thrown by the Template Toolkit when it can't find a file, or fails to load, parse or process a file that has been requested by an C<INCLUDE>, C<PROCESS>, C<INSERT> or C<WRAPPER> directive. If C<myfile> can't be found in the example above, the C<[% INCLUDE myfile %]> directive will raise a C<file> exception which is then caught by the C<[% CATCH file %]> block. The output generated would be: File Error! myfile: not found Note that the C<DEFAULT> option (disabled by default) allows you to specify a default file to be used any time a template file can't be found. This will prevent file exceptions from ever being raised when a non-existent file is requested (unless, of course, the C<DEFAULT> file your specify doesn't exist). Errors encountered once the file has been found (i.e. read error, parse error) will be raised as file exceptions as per usual. Uncaught exceptions (i.e. if the C<TRY> block doesn't have a type specific or default C<CATCH> handler) may be caught by enclosing C<TRY> blocks which can be nested indefinitely across multiple templates. If the error isn't caught at any level then processing will stop and the Template L<process()|Template#process()> method will return a false value to the caller. The relevant L<Template::Exception> object can be retrieved by calling the L<error()|Template#error()> method. [% TRY %] ... [% TRY %] [% INCLUDE $user.header %] [% CATCH file %] [% INCLUDE header %] [% END %] ... [% CATCH DBI %] [% INCLUDE database/error.html %] [% END %] In this example, the inner C<TRY> block is used to ensure that the first C<INCLUDE> directive works as expected. We're using a variable to provide the name of the template we want to include, C<user.header>, and it's possible this contains the name of a non-existent template, or perhaps one containing invalid template directives. If the C<INCLUDE> fails with a C<file> error then we C<CATCH> it in the inner block and C<INCLUDE> the default C<header> file instead. Any C<DBI> errors that occur within the scope of the outer C<TRY> block will be caught in the relevant C<CATCH> block, causing the C<database/error.html> template to be processed. Note that included templates inherit all currently defined template variable so these error files can quite happily access the <error> variable to retrieve information about the currently caught exception. For example, the C<database/error.html> template might look like this: <h2>Database Error</h2> A database error has occurred: [% error.info %] You can also specify a C<FINAL> block. This is always processed regardless of the outcome of the C<TRY> and/or C<CATCH> blocks. If an exception is uncaught then the C<FINAL> block is processed before jumping to the enclosing block or returning to the caller. [% TRY %] ... [% CATCH this %] ... [% CATCH that %] ... [% FINAL %] All done! [% END %] The output from the C<TRY> block is left intact up to the point where an exception occurs. For example, this template: [% TRY %] This gets printed [% THROW food 'carrots' %] This doesn't [% CATCH food %] culinary delights: [% error.info %] [% END %] generates the following output: This gets printed culinary delights: carrots The C<CLEAR> directive can be used in a C<CATCH> or C<FINAL> block to clear any output created in the C<TRY> block. [% TRY %] This gets printed [% THROW food 'carrots' %] This doesn't [% CATCH food %] [% CLEAR %] culinary delights: [% error.info %] [% END %] Output: culinary delights: carrots Exception types are hierarchical, with each level being separated by the familiar dot operator. A C<DBI.connect> exception is a more specific kind of C<DBI> error. Similarly, an C<example.error.barf> is a more specific kind of C<example.error> type which itself is also a C<example> error. A C<CATCH> handler that specifies a general exception type (such as C<DBI> or C<example.error>) will also catch more specific types that have the same prefix as long as a more specific handler isn't defined. Note that the order in which C<CATCH> handlers are defined is irrelevant; a more specific handler will always catch an exception in preference to a more generic or default one. [% TRY %] ... [% CATCH DBI ; INCLUDE database/error.html ; CATCH DBI.connect ; INCLUDE database/connect.html ; CATCH ; INCLUDE error.html ; END %] In this example, a C<DBI.connect> error has it's own handler, a more general C<DBI> block is used for all other C<DBI> or C<DBI.*> errors and a default handler catches everything else. Exceptions can be raised in a template using the C<THROW> directive. The first parameter is the exception type which doesn't need to be quoted (but can be, it's the same as C<INCLUDE>) followed by the relevant error message which can be any regular value such as a quoted string, variable, etc. [% THROW food "Missing ingredients: $recipe.error" %] [% THROW user.login 'no user id: please login' %] [% THROW $myerror.type "My Error: $myerror.info" %] It's also possible to specify additional positional or named parameters to the C<THROW> directive if you want to pass more than just a simple message back as the error info field. [% THROW food 'eggs' 'flour' msg='Missing Ingredients' %] In this case, the error C<info> field will be a hash array containing the named arguments and an C<args> item which contains a list of the positional arguments. type => 'food', info => { msg => 'Missing Ingredients', args => ['eggs', 'flour'], } In addition to specifying individual positional arguments as C<[% error.info.args.n %]>, the C<info> hash contains keys directly pointing to the positional arguments, as a convenient shortcut. [% error.info.0 %] # same as [% error.info.args.0 %] Exceptions can also be thrown from Perl code which you've bound to template variables, or defined as a plugin or other extension. To raise an exception, call C<die()> passing a reference to a L<Template::Exception> object as the argument. This will then be caught by any enclosing C<TRY> blocks from where the code was called. use Template::Exception; ... my $vars = { foo => sub { # ... do something ... die Template::Exception->new('myerr.naughty', 'Bad, bad error'); }, }; Template: [% TRY %] [% foo %] [% CATCH myerr ; "Error: $error" ; END %] Output: Error: myerr.naughty error - Bad, bad error The C<info> field can also be a reference to another object or data structure, if required. die Template::Exception->new('myerror', { module => 'foo.pl', errors => [ 'bad permissions', 'naughty boy' ], }); Later, in a template: [% TRY %] ... [% CATCH myerror %] [% error.info.errors.size or 'no'; error.info.errors.size == 1 ? ' error' : ' errors' %] in [% error.info.module %]: [% error.info.errors.join(', ') %]. [% END %] Generating the output: 2 errors in foo.pl: bad permissions, naughty boy. You can also call C<die()> with a single string, as is common in much existing Perl code. This will automatically be converted to an exception of the 'C<undef>' type (that's the literal string 'C<undef>', not the undefined value). If the string isn't terminated with a newline then Perl will append the familiar C<" at $file line $line"> message. sub foo { # ... do something ... die "I'm sorry, Dave, I can't do that\n"; } If you're writing a plugin, or some extension code that has the current L<Template::Context> in scope (you can safely skip this section if this means nothing to you) then you can also raise an exception by calling the context L<throw()|Template::Context#throw()> method. You can pass it an L<Template::Exception> object reference, a pair of C<($type, $info)> parameters or just an C<$info> string to create an exception of 'C<undef>' type. $context->throw($e); # exception object $context->throw('Denied'); # 'undef' type $context->throw('user.passwd', 'Bad Password'); =head2 NEXT The C<NEXT> directive can be used to start the next iteration of a C<FOREACH> or C<WHILE> loop. [% FOREACH user IN users %] [% NEXT IF user.isguest %] Name: [% user.name %] Email: [% user.email %] [% END %] =head2 LAST The C<LAST> directive can be used to prematurely exit a C<FOREACH> or C<WHILE> loop. [% FOREACH user IN users %] Name: [% user.name %] Email: [% user.email %] [% LAST IF some.condition %] [% END %] C<BREAK> can also be used as an alias for C<LAST>. =head2 RETURN The C<RETURN> directive can be used to stop processing the current template and return to the template from which it was called, resuming processing at the point immediately after the C<INCLUDE>, C<PROCESS> or C<WRAPPER> directive. If there is no enclosing template then the Template L<process()|Template#process()> method will return to the calling code with a true value. Before [% INCLUDE half_wit %] After [% BLOCK half_wit %] This is just half... [% RETURN %] ...a complete block [% END %] Output: Before This is just half... After =head2 STOP The C<STOP> directive can be used to indicate that the processor should stop gracefully without processing any more of the template document. This is a planned stop and the Template L<process()|Template#process()> method will return a B<true> value to the caller. This indicates that the template was processed successfully according to the directives within it. [% IF something.terrible.happened %] [% INCLUDE fatal/error.html %] [% STOP %] [% END %] [% TRY %] [% USE DBI(mydsn) %] ... [% CATCH DBI.connect %] <h1>Cannot connect to the database: [% error.info %]</h1> <p> We apologise for the inconvenience. </p> [% INCLUDE footer %] [% STOP %] [% END %] =head2 CLEAR The C<CLEAR> directive can be used to clear the output buffer for the current enclosing block. It is most commonly used to clear the output generated from a C<TRY> block up to the point where the error occurred. [% TRY %] blah blah blah # this is normally left intact [% THROW some 'error' %] # up to the point of error ... [% CATCH %] [% CLEAR %] # clear the TRY output [% error %] # print error string [% END %] =head1 Miscellaneous =head2 META The C<META> directive allows simple metadata items to be defined within a template. These are evaluated when the template is parsed and as such may only contain simple values (e.g. it's not possible to interpolate other variables values into C<META> variables). [% META title = 'The Cat in the Hat' author = 'Dr. Seuss' version = 1.23 %] The C<template> variable contains a reference to the main template being processed. These metadata items may be retrieved as attributes of the template. <h1>[% template.title %]</h1> <h2>[% template.author %]</h2> The C<name> and C<modtime> metadata items are automatically defined for each template to contain its name and modification time in seconds since the epoch. [% USE date %] # use Date plugin to format time ... [% template.name %] last modified at [% date.format(template.modtime) %] The C<PRE_PROCESS> and C<POST_PROCESS> options allow common headers and footers to be added to all templates. The C<template> reference is correctly defined when these templates are processed, allowing headers and footers to reference metadata items from the main template. $template = Template->new({ PRE_PROCESS => 'header', POST_PROCESS => 'footer', }); $template->process('cat_in_hat'); header: <html> <head> <title>[% template.title %]</title> </head> <body> cat_in_hat: [% META title = 'The Cat in the Hat' author = 'Dr. Seuss' version = 1.23 year = 2000 %] The cat in the hat sat on the mat. footer: <hr> © [% template.year %] [% template.author %] </body> </html> The output generated from the above example is: <html> <head> <title>The Cat in the Hat</title> </head> <body> The cat in the hat sat on the mat. <hr> © 2000 Dr. Seuss </body> </html> =head2 TAGS The C<TAGS> directive can be used to set the C<START_TAG> and C<END_TAG> values on a per-template file basis. [% TAGS <+ +> %] <+ INCLUDE header +> The TAGS directive may also be used to set a named C<TAG_STYLE> [% TAGS html %] <!-- INCLUDE header --> See the L<TAGS|Template::Manual::Config#TAGS> and L<TAG_STYLE|Template::Manual::Config#TAG_STYLE> configuration options for further details. =head2 DEBUG The C<DEBUG> directive can be used to enable or disable directive debug messages within a template. The C<DEBUG> configuration option must be set to include C<DEBUG_DIRS> for the C<DEBUG> directives to have any effect. If C<DEBUG_DIRS> is not set then the parser will automatically ignore and remove any C<DEBUG> directives. The C<DEBUG> directive can be used with an C<on> or C<off> parameter to enable or disable directive debugging messages from that point forward. When enabled, the output of each directive in the generated output will be prefixed by a comment indicate the file, line and original directive text. [% DEBUG on %] directive debugging is on (assuming DEBUG option is set true) [% DEBUG off %] directive debugging is off The C<format> parameter can be used to change the format of the debugging message. [% DEBUG format '<!-- $file line $line : [% $text %] -->' %] =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Filters.pm 0000444 00000060652 15125513451 0010665 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Filters # # DESCRIPTION # Defines filter plugins as used by the FILTER directive. # # AUTHORS # Andy Wardley <abw@wardley.org>, with a number of filters contributed # by Leslie Michael Orchard <deus_x@nijacode.com> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Filters; use strict; use warnings; use locale; use base 'Template::Base'; use Template::Constants; use Scalar::Util 'blessed'; our $VERSION = '3.100'; our $AVAILABLE = { }; our $TRUNCATE_LENGTH = 32; our $TRUNCATE_ADDON = '...'; #------------------------------------------------------------------------ # standard filters, defined in one of the following forms: # name => \&static_filter # name => [ \&subref, $is_dynamic ] # If the $is_dynamic flag is set then the sub-routine reference # is called to create a new filter each time it is requested; if # not set, then it is a single, static sub-routine which is returned # for every filter request for that name. #------------------------------------------------------------------------ our $FILTERS = { # static filters 'html' => \&html_filter, 'html_para' => \&html_paragraph, 'html_break' => \&html_para_break, 'html_para_break' => \&html_para_break, 'html_line_break' => \&html_line_break, 'xml' => \&xml_filter, 'uri' => \&uri_filter, 'url' => \&url_filter, 'upper' => sub { uc $_[0] }, 'lower' => sub { lc $_[0] }, 'ucfirst' => sub { ucfirst $_[0] }, 'lcfirst' => sub { lcfirst $_[0] }, 'stderr' => sub { print STDERR @_; return '' }, 'trim' => sub { for ($_[0]) { s/^\s+//; s/\s+$// }; $_[0] }, 'null' => sub { return '' }, 'collapse' => sub { for ($_[0]) { s/^\s+//; s/\s+$//; s/\s+/ /g }; $_[0] }, # dynamic filters 'html_entity' => [ \&html_entity_filter_factory, 1 ], 'indent' => [ \&indent_filter_factory, 1 ], 'format' => [ \&format_filter_factory, 1 ], 'truncate' => [ \&truncate_filter_factory, 1 ], 'repeat' => [ \&repeat_filter_factory, 1 ], 'replace' => [ \&replace_filter_factory, 1 ], 'remove' => [ \&remove_filter_factory, 1 ], 'eval' => [ \&eval_filter_factory, 1 ], 'evaltt' => [ \&eval_filter_factory, 1 ], # alias 'perl' => [ \&perl_filter_factory, 1 ], 'evalperl' => [ \&perl_filter_factory, 1 ], # alias 'redirect' => [ \&redirect_filter_factory, 1 ], 'file' => [ \&redirect_filter_factory, 1 ], # alias 'stdout' => [ \&stdout_filter_factory, 1 ], }; # name of module implementing plugin filters our $PLUGIN_FILTER = 'Template::Plugin::Filter'; #======================================================================== # -- PUBLIC METHODS -- #======================================================================== #------------------------------------------------------------------------ # fetch($name, \@args, $context) # # Attempts to instantiate or return a reference to a filter sub-routine # named by the first parameter, $name, with additional constructor # arguments passed by reference to a list as the second parameter, # $args. A reference to the calling Template::Context object is # passed as the third parameter. # # Returns a reference to a filter sub-routine or a pair of values # (undef, STATUS_DECLINED) or ($error, STATUS_ERROR) to decline to # deliver the filter or to indicate an error. #------------------------------------------------------------------------ sub fetch { my ($self, $name, $args, $context) = @_; my ($factory, $is_dynamic, $filter, $error); $self->debug("fetch($name, ", defined $args ? ('[ ', join(', ', @$args), ' ]') : '<no args>', ', ', defined $context ? $context : '<no context>', ')') if $self->{ DEBUG }; # allow $name to be specified as a reference to # a plugin filter object; any other ref is # assumed to be a coderef and hence already a filter; # non-refs are assumed to be regular name lookups if (ref $name) { if (blessed($name) && $name->isa($PLUGIN_FILTER)) { $factory = $name->factory() || return $self->error($name->error()); } else { return $name; } } else { return (undef, Template::Constants::STATUS_DECLINED) unless ($factory = $self->{ FILTERS }->{ $name } || $FILTERS->{ $name }); } # factory can be an [ $code, $dynamic ] or just $code if (ref $factory eq 'ARRAY') { ($factory, $is_dynamic) = @$factory; } else { $is_dynamic = 0; } if (ref $factory eq 'CODE') { if ($is_dynamic) { # if the dynamic flag is set then the sub-routine is a # factory which should be called to create the actual # filter... eval { ($filter, $error) = &$factory($context, $args ? @$args : ()); }; $error ||= $@; $error = "invalid FILTER for '$name' (not a CODE ref)" unless $error || ref($filter) eq 'CODE'; } else { # ...otherwise, it's a static filter sub-routine $filter = $factory; } } else { $error = "invalid FILTER entry for '$name' (not a CODE ref)"; } if ($error) { return $self->{ TOLERANT } ? (undef, Template::Constants::STATUS_DECLINED) : ($error, Template::Constants::STATUS_ERROR) ; } else { return $filter; } } #------------------------------------------------------------------------ # store($name, \&filter) # # Stores a new filter in the internal FILTERS hash. The first parameter # is the filter name, the second a reference to a subroutine or # array, as per the standard $FILTERS entries. #------------------------------------------------------------------------ sub store { my ($self, $name, $filter) = @_; $self->debug("store($name, $filter)") if $self->{ DEBUG }; $self->{ FILTERS }->{ $name } = $filter; return 1; } #======================================================================== # -- PRIVATE METHODS -- #======================================================================== #------------------------------------------------------------------------ # _init(\%config) # # Private initialisation method. #------------------------------------------------------------------------ sub _init { my ($self, $params) = @_; $self->{ FILTERS } = $params->{ FILTERS } || { }; $self->{ TOLERANT } = $params->{ TOLERANT } || 0; $self->{ DEBUG } = ( $params->{ DEBUG } || 0 ) & Template::Constants::DEBUG_FILTERS; return $self; } #======================================================================== # -- STATIC FILTER SUBS -- #======================================================================== #------------------------------------------------------------------------ # uri_filter() and url_filter() below can match using either RFC3986 or # RFC2732. See https://github.com/abw/Template2/issues/13 #----------------------------------------------------------------------- our $UNSAFE_SPEC = { RFC2732 => q{A-Za-z0-9\-_.~!*'()}, RFC3986 => q{A-Za-z0-9\-_.~}, }; our $UNSAFE_CHARS = $UNSAFE_SPEC->{ RFC3986 }; our $URI_REGEX; our $URL_REGEX; our $URI_ESCAPES; sub use_rfc2732 { $UNSAFE_CHARS = $UNSAFE_SPEC->{ RFC2732 }; $URI_REGEX = $URL_REGEX = undef; } sub use_rfc3986 { $UNSAFE_CHARS = $UNSAFE_SPEC->{ RFC3986 }; $URI_REGEX = $URL_REGEX = undef; } sub uri_escapes { return { map { ( chr($_), sprintf("%%%02X", $_) ) } (0..255), }; } #------------------------------------------------------------------------ # uri_filter() [% FILTER uri %] # # URI escape a string. This code is borrowed from Gisle Aas' URI::Escape # module, copyright 1995-2004. See RFC2396, RFC2732 and RFC3986 for # details. #----------------------------------------------------------------------- sub uri_filter { my $text = shift; $URI_REGEX ||= qr/([^$UNSAFE_CHARS])/; $URI_ESCAPES ||= uri_escapes(); if ($] >= 5.008 && utf8::is_utf8($text)) { utf8::encode($text); } $text =~ s/$URI_REGEX/$URI_ESCAPES->{$1}/eg; $text; } #------------------------------------------------------------------------ # url_filter() [% FILTER uri %] # # NOTE: the difference: url vs uri. # This implements the old-style, non-strict behaviour of the uri filter # which allows any valid URL characters to pass through so that # http://example.com/blah.html does not get the ':' and '/' characters # munged. #----------------------------------------------------------------------- sub url_filter { my $text = shift; $URL_REGEX ||= qr/([^;\/?:@&=+\$,$UNSAFE_CHARS])/; $URI_ESCAPES ||= uri_escapes(); if ($] >= 5.008 && utf8::is_utf8($text)) { utf8::encode($text); } $text =~ s/$URL_REGEX/$URI_ESCAPES->{$1}/eg; $text; } #------------------------------------------------------------------------ # html_filter() [% FILTER html %] # # Convert any '<', '>' or '&' characters to the HTML equivalents, '<', # '>' and '&', respectively. #------------------------------------------------------------------------ sub html_filter { my $text = shift; for ($text) { s/&/&/g; s/</</g; s/>/>/g; s/"/"/g; } return $text; } #------------------------------------------------------------------------ # xml_filter() [% FILTER xml %] # # Same as the html filter, but adds the conversion of ' to ' which # is native to XML. #------------------------------------------------------------------------ sub xml_filter { my $text = shift; for ($text) { s/&/&/g; s/</</g; s/>/>/g; s/"/"/g; s/'/'/g; } return $text; } #------------------------------------------------------------------------ # html_paragraph() [% FILTER html_para %] # # Wrap each paragraph of text (delimited by two or more newlines) in the # <p>...</p> HTML tags. #------------------------------------------------------------------------ sub html_paragraph { my $text = shift; return "<p>\n" . join("\n</p>\n\n<p>\n", split(/(?:\r?\n){2,}/, $text)) . "</p>\n"; } #------------------------------------------------------------------------ # html_para_break() [% FILTER html_para_break %] # # Join each paragraph of text (delimited by two or more newlines) with # <br><br> HTML tags. #------------------------------------------------------------------------ sub html_para_break { my $text = shift; $text =~ s|(\r?\n){2,}|$1<br />$1<br />$1|g; return $text; } #------------------------------------------------------------------------ # html_line_break() [% FILTER html_line_break %] # # replaces any newlines with <br> HTML tags. #------------------------------------------------------------------------ sub html_line_break { my $text = shift; $text =~ s|(\r?\n)|<br />$1|g; return $text; } #======================================================================== # -- DYNAMIC FILTER FACTORIES -- #======================================================================== #------------------------------------------------------------------------ # html_entity_filter_factory(\%options) [% FILTER html %] # # Dynamic version of the static html filter which attempts to locate the # Apache::Util or HTML::Entities modules to perform full entity encoding # of the text passed. Returns an exception if one or other of the # modules can't be located. #------------------------------------------------------------------------ sub use_html_entities { require HTML::Entities; return ($AVAILABLE->{ HTML_ENTITY } = \&HTML::Entities::encode_entities); } sub use_apache_util { require Apache::Util; Apache::Util::escape_html(''); # TODO: explain this return ($AVAILABLE->{ HTML_ENTITY } = \&Apache::Util::escape_html); } sub html_entity_filter_factory { my $context = shift; my $haz; # if Apache::Util is installed then we use escape_html $haz = $AVAILABLE->{ HTML_ENTITY } || eval { use_apache_util() } || eval { use_html_entities() } || -1; # we use -1 for "not available" because it's a true value return ref $haz eq 'CODE' ? $haz : (undef, Template::Exception->new( html_entity => 'cannot locate Apache::Util or HTML::Entities' ) ); } #------------------------------------------------------------------------ # indent_filter_factory($pad) [% FILTER indent(pad) %] # # Create a filter to indent text by a fixed pad string or when $pad is # numerical, a number of space. #------------------------------------------------------------------------ sub indent_filter_factory { my ($context, $pad) = @_; $pad = 4 unless defined $pad; $pad = ' ' x $pad if $pad =~ /^\d+$/; return sub { my $text = shift; $text = '' unless defined $text; $text =~ s/^/$pad/mg; return $text; } } #------------------------------------------------------------------------ # format_filter_factory() [% FILTER format(format) %] # # Create a filter to format text according to a printf()-like format # string. #------------------------------------------------------------------------ sub format_filter_factory { my ($context, $format) = @_; $format = '%s' unless defined $format; return sub { my $text = shift; $text = '' unless defined $text; return join("\n", map{ sprintf($format, $_) } split(/\n/, $text)); } } #------------------------------------------------------------------------ # repeat_filter_factory($n) [% FILTER repeat(n) %] # # Create a filter to repeat text n times. #------------------------------------------------------------------------ sub repeat_filter_factory { my ($context, $iter) = @_; $iter = 1 unless defined $iter and length $iter; return sub { my $text = shift; $text = '' unless defined $text; return join('\n', $text) x $iter; } } #------------------------------------------------------------------------ # replace_filter_factory($s, $r) [% FILTER replace(search, replace) %] # # Create a filter to replace 'search' text with 'replace' #------------------------------------------------------------------------ sub replace_filter_factory { my ($context, $search, $replace) = @_; $search = '' unless defined $search; $replace = '' unless defined $replace; return sub { my $text = shift; $text = '' unless defined $text; $text =~ s/$search/$replace/g; return $text; } } #------------------------------------------------------------------------ # remove_filter_factory($text) [% FILTER remove(text) %] # # Create a filter to remove 'search' string from the input text. #------------------------------------------------------------------------ sub remove_filter_factory { my ($context, $search) = @_; return sub { my $text = shift; $text = '' unless defined $text; $text =~ s/$search//g; return $text; } } #------------------------------------------------------------------------ # truncate_filter_factory($n) [% FILTER truncate(n) %] # # Create a filter to truncate text after n characters. #------------------------------------------------------------------------ sub truncate_filter_factory { my ($context, $len, $char) = @_; $len = $TRUNCATE_LENGTH unless defined $len; $char = $TRUNCATE_ADDON unless defined $char; # Length of char is the minimum length my $lchar = length $char; if ($len < $lchar) { $char = substr($char, 0, $len); $lchar = $len; } return sub { my $text = shift; return $text if length $text <= $len; return substr($text, 0, $len - $lchar) . $char; } } #------------------------------------------------------------------------ # eval_filter_factory [% FILTER eval %] # # Create a filter to evaluate template text. #------------------------------------------------------------------------ sub eval_filter_factory { my $context = shift; return sub { my $text = shift; $context->process(\$text); } } #------------------------------------------------------------------------ # perl_filter_factory [% FILTER perl %] # # Create a filter to process Perl text iff the context EVAL_PERL flag # is set. #------------------------------------------------------------------------ sub perl_filter_factory { my $context = shift; my $stash = $context->stash; return (undef, Template::Exception->new('perl', 'EVAL_PERL is not set')) unless $context->eval_perl(); return sub { my $text = shift; local($Template::Perl::context) = $context; local($Template::Perl::stash) = $stash; my $out = eval <<EOF; package Template::Perl; \$stash = \$context->stash(); $text EOF $context->throw($@) if $@; return $out; } } #------------------------------------------------------------------------ # redirect_filter_factory($context, $file) [% FILTER redirect(file) %] # # Create a filter to redirect the block text to a file. #------------------------------------------------------------------------ sub redirect_filter_factory { my ($context, $file, $options) = @_; my $outpath = $context->config->{ OUTPUT_PATH }; return (undef, Template::Exception->new('redirect', 'OUTPUT_PATH is not set')) unless $outpath; $context->throw('redirect', "relative filenames are not supported: $file") if $file =~ m{(^|/)\.\./}; $options = { binmode => $options } unless ref $options; sub { my $text = shift; my $outpath = $context->config->{ OUTPUT_PATH } || return ''; $outpath .= "/$file"; my $error = Template::_output($outpath, \$text, $options); die Template::Exception->new('redirect', $error) if $error; return ''; } } #------------------------------------------------------------------------ # stdout_filter_factory($context, $binmode) [% FILTER stdout(binmode) %] # # Create a filter to print a block to stdout, with an optional binmode. #------------------------------------------------------------------------ sub stdout_filter_factory { my ($context, $options) = @_; $options = { binmode => $options } unless ref $options; sub { my $text = shift; binmode(STDOUT) if $options->{ binmode }; print STDOUT $text; return ''; } } 1; __END__ =head1 NAME Template::Filters - Post-processing filters for template blocks =head1 SYNOPSIS use Template::Filters; $filters = Template::Filters->new(\%config); ($filter, $error) = $filters->fetch($name, \@args, $context); if ($filter) { print &$filter("some text"); } else { print "Could not fetch $name filter: $error\n"; } =head1 DESCRIPTION The C<Template::Filters> module implements a provider for creating subroutines that implement the standard filters. Additional custom filters may be provided via the L<FILTERS> configuration option. =head1 METHODS =head2 new(\%params) Constructor method which instantiates and returns a reference to a C<Template::Filters> object. A reference to a hash array of configuration items may be passed as a parameter. These are described below. my $filters = Template::Filters->new({ FILTERS => { ... }, }); my $template = Template->new({ LOAD_FILTERS => [ $filters ], }); A default C<Template::Filters> module is created by the L<Template> module if the L<LOAD_FILTERS> option isn't specified. All configuration parameters are forwarded to the constructor. $template = Template->new({ FILTERS => { ... }, }); =head2 fetch($name, \@args, $context) Called to request that a filter of a given name be provided. The name of the filter should be specified as the first parameter. This should be one of the standard filters or one specified in the L<FILTERS> configuration hash. The second argument should be a reference to an array containing configuration parameters for the filter. This may be specified as 0, or undef where no parameters are provided. The third argument should be a reference to the current L<Template::Context> object. The method returns a reference to a filter sub-routine on success. It may also return C<(undef, STATUS_DECLINE)> to decline the request, to allow delegation onto other filter providers in the L<LOAD_FILTERS> chain of responsibility. On error, C<($error, STATUS_ERROR)> is returned where $error is an error message or L<Template::Exception> object indicating the error that occurred. When the C<TOLERANT> option is set, errors are automatically downgraded to a C<STATUS_DECLINE> response. =head2 use_html_entities() This class method can be called to configure the C<html_entity> filter to use the L<HTML::Entities> module. An error will be raised if it is not installed on your system. use Template::Filters; Template::Filters->use_html_entities(); =head2 use_apache_util() This class method can be called to configure the C<html_entity> filter to use the L<Apache::Util> module. An error will be raised if it is not installed on your system. use Template::Filters; Template::Filters->use_apache_util(); =head2 use_rfc2732() This class method can be called to configure the C<uri> and C<url> filters to use the older RFC2732 standard for matching unsafe characters. =head2 use_rfc3986() This class method can be called to configure the C<uri> and C<url> filters to use the newer RFC3986 standard for matching unsafe characters. =head1 CONFIGURATION OPTIONS The following list summarises the configuration options that can be provided to the C<Template::Filters> L<new()> constructor. Please see L<Template::Manual::Config> for further information about each option. =head2 FILTERS The L<FILTERS|Template::Manual::Config#FILTERS> option can be used to specify custom filters which can then be used with the L<FILTER|Template::Manual::Directives#FILTER> directive like any other. These are added to the standard filters which are available by default. $filters = Template::Filters->new({ FILTERS => { 'sfilt1' => \&static_filter, 'dfilt1' => [ \&dyanamic_filter_factory, 1 ], }, }); =head2 TOLERANT The L<TOLERANT|Template::Manual::Config#TOLERANT> flag can be set to indicate that the C<Template::Filters> module should ignore any errors and instead return C<STATUS_DECLINED>. =head2 DEBUG The L<DEBUG|Template::Manual::Config#DEBUG> option can be used to enable debugging messages for the Template::Filters module by setting it to include the C<DEBUG_FILTERS> value. use Template::Constants qw( :debug ); my $template = Template->new({ DEBUG => DEBUG_FILTERS | DEBUG_PLUGINS, }); =head1 STANDARD FILTERS Please see L<Template::Manual::Filters> for a list of the filters provided with the Template Toolkit, complete with examples of use. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-20202Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Manual::Filters>, L<Template>, L<Template::Context> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Document.pm 0000444 00000037751 15125513451 0011037 0 ustar 00 ##============================================================= -*-Perl-*- # # Template::Document # # DESCRIPTION # Module defining a class of objects which encapsulate compiled # templates, storing additional block definitions and metadata # as well as the compiled Perl sub-routine representing the main # template content. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Document; use strict; use warnings; use base 'Template::Base'; use Template::Constants; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $ERROR = ''; our ($COMPERR, $AUTOLOAD, $UNICODE); BEGIN { # UNICODE is supported in versions of Perl from 5.008 onwards if ($UNICODE = $] > 5.007 ? 1 : 0) { if ($] > 5.008) { # utf8::is_utf8() available from Perl 5.8.1 onwards *is_utf8 = \&utf8::is_utf8; } elsif ($] == 5.008) { # use Encode::is_utf8() for Perl 5.8.0 require Encode; *is_utf8 = \&Encode::is_utf8; } } } #======================================================================== # ----- PUBLIC METHODS ----- #======================================================================== #------------------------------------------------------------------------ # new(\%document) # # Creates a new self-contained Template::Document object which # encapsulates a compiled Perl sub-routine, $block, any additional # BLOCKs defined within the document ($defblocks, also Perl sub-routines) # and additional $metadata about the document. #------------------------------------------------------------------------ sub new { my ($class, $doc) = @_; my ($block, $defblocks, $variables, $metadata) = @$doc{ qw( BLOCK DEFBLOCKS VARIABLES METADATA ) }; $defblocks ||= { }; $metadata ||= { }; # evaluate Perl code in $block to create sub-routine reference if necessary unless (ref $block) { local $SIG{__WARN__} = \&catch_warnings; $COMPERR = ''; # DON'T LOOK NOW! - blindly untainting can make you go blind! { no warnings 'syntax'; $block = each %{ { $block => undef } } if ${^TAINT}; #untaint } $block = eval $block; return $class->error($@) unless defined $block; } # same for any additional BLOCK definitions @$defblocks{ keys %$defblocks } = # MORE BLIND UNTAINTING - turn away if you're squeamish map { ref($_) ? $_ : ( /(.*)/s && eval($1) or return $class->error($@) ) } values %$defblocks; bless { %$metadata, _BLOCK => $block, _DEFBLOCKS => $defblocks, _VARIABLES => $variables, _HOT => 0, }, $class; } #------------------------------------------------------------------------ # block() # # Returns a reference to the internal sub-routine reference, _BLOCK, # that constitutes the main document template. #------------------------------------------------------------------------ sub block { return $_[0]->{ _BLOCK }; } #------------------------------------------------------------------------ # blocks() # # Returns a reference to a hash array containing any BLOCK definitions # from the template. The hash keys are the BLOCK name and the values # are references to Template::Document objects. Returns 0 (# an empty hash) # if no blocks are defined. #------------------------------------------------------------------------ sub blocks { return $_[0]->{ _DEFBLOCKS }; } #----------------------------------------------------------------------- # variables() # # Returns a reference to a hash of variables used in the template. # This requires the TRACE_VARS option to be enabled. #----------------------------------------------------------------------- sub variables { return $_[0]->{ _VARIABLES }; } #------------------------------------------------------------------------ # process($context) # # Process the document in a particular context. Checks for recursion, # registers the document with the context via visit(), processes itself, # and then unwinds with a large gin and tonic. #------------------------------------------------------------------------ sub process { my ($self, $context) = @_; my $defblocks = $self->{ _DEFBLOCKS }; my $output; # check we're not already visiting this template return $context->throw( Template::Constants::ERROR_FILE, "recursion into '$self->{ name }'" ) if $self->{ _HOT } && ! $context->{ RECURSION }; ## RETURN ## $context->visit($self, $defblocks); $self->{ _HOT } = 1; eval { my $block = $self->{ _BLOCK }; $output = &$block($context); }; $self->{ _HOT } = 0; $context->leave(); die $context->catch($@) if $@; return $output; } #------------------------------------------------------------------------ # meta() # # Return the META items, i.e. anything that isn't prefixed with a _, e.g. # _BLOCKS, or the name or modtime items. #------------------------------------------------------------------------ sub meta { my $self = shift; return { map { $_ => $self->{ $_ } } grep { ! /^(_|modtime$|name$)/ } keys %$self }; } #------------------------------------------------------------------------ # AUTOLOAD # # Provides pseudo-methods for read-only access to various internal # members. #------------------------------------------------------------------------ sub AUTOLOAD { my $self = shift; my $method = $AUTOLOAD; $method =~ s/.*:://; return if $method eq 'DESTROY'; # my ($pkg, $file, $line) = caller(); # print STDERR "called $self->AUTOLOAD($method) from $file line $line\n"; return $self->{ $method }; } #======================================================================== # ----- CLASS METHODS ----- #======================================================================== #------------------------------------------------------------------------ # as_perl($content) # # This method expects a reference to a hash passed as the first argument # containing 3 items: # METADATA # a hash of template metadata # BLOCK # string containing Perl sub definition for main block # DEFBLOCKS # hash containing further subs for addional BLOCK defs # It returns a string containing Perl code which, when evaluated and # executed, will instantiate a new Template::Document object with the # above data. On error, it returns undef with an appropriate error # message set in $ERROR. #------------------------------------------------------------------------ sub as_perl { my ($class, $content) = @_; my ($block, $defblocks, $metadata) = @$content{ qw( BLOCK DEFBLOCKS METADATA ) }; $block =~ s/\s+$//; $defblocks = join('', map { my $code = $defblocks->{ $_ }; $code =~ s/\s*$//; " '$_' => $code,\n"; } keys %$defblocks); $defblocks =~ s/\s+$//; $metadata = join( '', map { my $x = $metadata->{ $_ }; $x =~ s/(['\\])/\\$1/g; " '$_' => '$x',\n"; } keys %$metadata ); $metadata =~ s/\s+$//; return <<EOF #------------------------------------------------------------------------ # Compiled template generated by the Template Toolkit version $Template::VERSION #------------------------------------------------------------------------ $class->new({ METADATA => { $metadata }, BLOCK => $block, DEFBLOCKS => { $defblocks }, }); EOF } #------------------------------------------------------------------------ # write_perl_file($filename, \%content) # # This method calls as_perl() to generate the Perl code to represent a # compiled template with the content passed as the second argument. # It then writes this to the file denoted by the first argument. # # Returns 1 on success. On error, sets the $ERROR package variable # to contain an error message and returns undef. #------------------------------------------------------------------------ sub write_perl_file { my ($class, $file, $content) = @_; my ($fh, $tmpfile); return $class->error("invalid filename: $file") unless defined $file && length $file; eval { require File::Temp; require File::Basename; ($fh, $tmpfile) = File::Temp::tempfile( DIR => File::Basename::dirname($file) ); my $perlcode = $class->as_perl($content) || die $!; if ($UNICODE && is_utf8($perlcode)) { $perlcode = "use utf8;\n\n$perlcode"; binmode $fh, ":utf8"; } print $fh $perlcode; close($fh); }; return $class->error($@) if $@; return rename($tmpfile, $file) || $class->error($!); } #------------------------------------------------------------------------ # catch_warnings($msg) # # Installed as #------------------------------------------------------------------------ sub catch_warnings { $COMPERR .= join('', @_); } 1; __END__ =head1 NAME Template::Document - Compiled template document object =head1 SYNOPSIS use Template::Document; $doc = Template::Document->new({ BLOCK => sub { # some perl code; return $some_text }, DEFBLOCKS => { header => sub { # more perl code; return $some_text }, footer => sub { # blah blah blah; return $some_text }, }, METADATA => { author => 'Andy Wardley', version => 3.14, } }) || die $Template::Document::ERROR; print $doc->process($context); =head1 DESCRIPTION This module defines an object class whose instances represent compiled template documents. The L<Template::Parser> module creates a C<Template::Document> instance to encapsulate a template as it is compiled into Perl code. The constructor method, L<new()>, expects a reference to a hash array containing the C<BLOCK>, C<DEFBLOCKS> and C<METADATA> items. The C<BLOCK> item should contain a reference to a Perl subroutine or a textual representation of Perl code, as generated by the L<Template::Parser> module. This is then evaluated into a subroutine reference using C<eval()>. The C<DEFBLOCKS> item should reference a hash array containing further named C<BLOCK>s which may be defined in the template. The keys represent C<BLOCK> names and the values should be subroutine references or text strings of Perl code as per the main C<BLOCK> item. The C<METADATA> item should reference a hash array of metadata items relevant to the document. The L<process()> method can then be called on the instantiated C<Template::Document> object, passing a reference to a L<Template::Context> object as the first parameter. This will install any locally defined blocks (C<DEFBLOCKS>) in the C<BLOCKS> cache in the context (via a call to L<visit()|Template::Context#visit()>) so that they may be subsequently resolved by the context. The main C<BLOCK> subroutine is then executed, passing the context reference on as a parameter. The text returned from the template subroutine is then returned by the L<process()> method, after calling the context L<leave()|Template::Context#leave()> method to permit cleanup and de-registration of named C<BLOCKS> previously installed. An C<AUTOLOAD> method provides access to the C<METADATA> items for the document. The L<Template::Service> module installs a reference to the main C<Template::Document> object in the stash as the C<template> variable. This allows metadata items to be accessed from within templates, including C<PRE_PROCESS> templates. header: <html> <head> <title>[% template.title %] </head> ... C<Template::Document> objects are usually created by the L<Template::Parser> but can be manually instantiated or sub-classed to provide custom template components. =head1 METHODS =head2 new(\%config) Constructor method which accept a reference to a hash array containing the structure as shown in this example: $doc = Template::Document->new({ BLOCK => sub { # some perl code; return $some_text }, DEFBLOCKS => { header => sub { # more perl code; return $some_text }, footer => sub { # blah blah blah; return $some_text }, }, METADATA => { author => 'Andy Wardley', version => 3.14, } }) || die $Template::Document::ERROR; C<BLOCK> and C<DEFBLOCKS> items may be expressed as references to Perl subroutines or as text strings containing Perl subroutine definitions, as is generated by the L<Template::Parser> module. These are evaluated into subroutine references using C<eval()>. Returns a new C<Template::Document> object or C<undef> on error. The L<error()|Template::Base#error()> class method can be called, or the C<$ERROR> package variable inspected to retrieve the relevant error message. =head2 process($context) Main processing routine for the compiled template document. A reference to a L<Template::Context> object should be passed as the first parameter. The method installs any locally defined blocks via a call to the context L<visit()|Template::Context#visit()> method, processes its own template, (passing the context reference as a parameter) and then calls L<leave()|Template::Context#leave()> in the context to allow cleanup. print $doc->process($context); Returns a text string representing the generated output for the template. Errors are thrown via C<die()>. =head2 block() Returns a reference to the main C<BLOCK> subroutine. =head2 blocks() Returns a reference to the hash array of named C<DEFBLOCKS> subroutines. =head2 variables() Returns a reference to a hash of variables used in the template. This requires the L<TRACE_VARS|Template::Manual::Config#TRACE_VARS> option to be enabled. =head2 meta() Return a reference to a hash of any META items defined in the template. =head2 AUTOLOAD An autoload method returns C<METADATA> items. print $doc->author(); =head1 CLASS METHODS These methods are used internally. =head2 as_perl($content) This method generate a Perl representation of the template. my $perl = Template::Document->as_perl({ BLOCK => $main_block, DEFBLOCKS => { foo => $foo_block, bar => $bar_block, }, METADATA => { name => 'my_template', } }); =head2 write_perl_file(\%config) This method is used to write compiled Perl templates to disk. If the C<COMPILE_EXT> option (to indicate a file extension for saving compiled templates) then the L<Template::Parser> module calls this subroutine before calling the L<new()> constructor. At this stage, the parser has a representation of the template as text strings containing Perl code. We can write that to a file, enclosed in a small wrapper which will allow us to subsequently C<require()> the file and have Perl parse and compile it into a C<Template::Document>. Thus we have persistence of compiled templates. =head1 INTERNAL FUNCTIONS =head2 catch_warnings() This is a simple handler used to catch any errors that arise when the compiled Perl template is first evaluated (that is, evaluated by Perl to create a template subroutine at compile, rather than the template being processed at runtime). =head2 is_utf8() This is mapped to C<utf8::is_utf8> for versions of Perl that have it (> 5.008) or to C<Encode::is_utf8> for Perl 5.008. Earlier versions of Perl are not supported. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2013 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template>, L<Template::Parser> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Toolkit.pm 0000444 00000013136 15125513451 0010675 0 ustar 00 #============================================================= -*-perl-*- # # Template::Toolkit # # DESCRIPTION # Front-page for the Template Toolkit documentation # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== package Template::Toolkit; our $VERSION = '3.100'; 1; __END__ =head1 NAME Template::Toolkit - Template Processing System =head1 Introduction The Template Toolkit is a collection of Perl modules which implement a fast, flexible, powerful and extensible template processing system. It is "input-agnostic" and can be used equally well for processing any kind of text documents: HTML, XML, CSS, Javascript, Perl code, plain text, and so on. However, it is most often used for generating static and dynamic web content, so that's what we'll focus on here. Although the Template Toolkit is written in Perl, you don't need to be a Perl programmer to use it. It was designed to allow non-programmers to easily create and maintain template-based web sites without having to mess around writing Perl code or going crazy with cut-n-paste. However, the Template Toolkit is also designed to be extremely flexible and extensible. If you are a Perl programmer, or know someone who is, then you can easily hook the Template Toolkit into your existing code, data, databases and web applications. Furthermore, you can easily extend the Template Toolkit through the use of its plugin mechanism and other developer APIs. Whatever context you use it in, the primary purpose of the Template Toolkit is to allow you to create a clear separation between the presentation elements of your web site and everything else. If you're generating static web pages, then you can use it to separate the commonly repeated user interface elements on each page (headers, menus, footers, etc.) from the core content. If you're generating dynamic web pages for the front end of a web application, then you'll also be using it to keep the back-end Perl code entirely separate from the front-end HTML templates. Either way, a I<clear separation of concerns> is what allow you to concentrate on one thing at a time without the other things getting in your way. And that's what the Template Toolkit is all about. =head1 Documentation The documentation for the Template Toolkit is organised into five sections. The L<Template::Manual> contains detailed information about using the Template Toolkit. It gives examples of its use and includes a full reference of the template language, configuration options, filters, plugins and other component parts. The L<Template::Modules> page lists the Perl modules that comprise the Template Toolkit. It gives a brief explanation of what each of them does, and provides a link to the complete documentation for each module for further information. If you're a Perl programmer looking to use the Template Toolkit from your Perl programs then this section is likely to be of interest. Most, if not all of the information you need to call the Template Toolkit from Perl is in the documentation for the L<Template> module. You only really need to start thinking about the other modules if you want to extend or modify the Template Toolkit in some way, or if you're interested in looking under the hood to see how it all works. The documentation for each module is embedded as POD in each module, so you can always use C<perldoc> from the command line to read a module's documentation. e.g. $ perldoc Template $ perldoc Template::Context ...etc... It's worth noting that all the other documentation, including the user manual is available as POD. e.g. $ perldoc Template::Manual $ perldoc Template::Manual::Config ...etc... The L<Template::Tools> section contains the documentation for L<Template::Tools::tpage|tpage> and L<Template::Tools::ttree|ttree>. These are two command line programs that are distributed with the Template Toolkit. L<tpage|Template::Tools::tpage> is used to process a single template file, L<ttree|Template::Tools::ttree> for processing entire directories of template files. The L<Template::Tutorial> section contains two introductory tutorials on using the Template Toolkit. The first is L<Template::Tutorial::Web> on generating web content. The second is L<Template::Tutorial::Datafile> on using the Template Toolkit to generate other data formats including XML. The final section of the manual is L<Template::FAQ> which contains answers to some of the Frequently Asked Questions about the Template Toolkit. You can read the documentation in HTML format either online at the Template Toolkit web site, L<http://template-toolkit.org/>, or by downloading the HTML version of the documentation from L<http://template-toolkit.org/download/index.html#html_docs> and unpacking it on your local machine. =head1 Author The Template Toolkit was written by Andy Wardley (L<http://wardley.org/> L<mailto:abw@wardley.org>) with assistance and contributions from a great number of people. Please see L<Template::Manual::Credits> for a full list. =head1 Copyright Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 See Also L<Template>, L<Template::Manual>, L<Template::Modules>, L<Template::Tools>, L<Template::Tutorial> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Manual.pod 0000444 00000004574 15125513451 0010641 0 ustar 00 #============================================================= -*-perl-*- # # Template::Manual # # DESCRIPTION # Front-page for the TT manual. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Manual - Template Toolkit User Manual =head1 Template Toolkit Manual The Template Toolkit manual contains documentation on using and extending the Template Toolkit. =head2 Template::Manual::Intro The L<Template::Manual::Intro> page provides an introduction to the Template Toolkit =head2 Template::Manual::Syntax The L<Template::Manual::Syntax> describes the syntax and structure of templates and the directive tags embedded within them. =head2 Template::Manual::Directives The L<Template::Manual::Directives> page lists all the Template Toolkit directives and gives examples of their use. =head2 Template::Manual::Variables The L<Template::Manual::Variables> page describes the use of variables in templates. =head2 Template::Manual::VMethods The L<Template::Manual::VMethods> page provides a full list of virtual methods that can be used in conjunction with variables, and gives examples of their use. =head2 Template::Manual::Config The L<Template::Manual::Config> page describes all of the Template Toolkit configuration options. =head2 Template::Manual::Filters The L<Template::Manual::Filters> page lists all of the Template Toolkit filters and gives examples of their use. =head2 Template::Manual::Plugins The L<Template::Manual::Plugins> page lists all of the standard plugins distributed with Template Toolkit and gives examples of their use. =head2 Template::Manual::Internals The L<Template::Manual::Internals> page describes the internal workings of the Template Toolkit. It is aimed at developers who wish to extend or modify the =head2 Template::Manual::Views The L<Template::Manual::Views> page describes the experimental C<VIEW> directive. =head2 Template::Manual::Credits The L<Template::Manual::Credits> page lists the people who have contributed to the Template Toolkit. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Namespace/Constants.pm 0000444 00000010545 15125513451 0013121 0 ustar 00 #================================================================= -*-Perl-*- # # Template::Namespace::Constants # # DESCRIPTION # Plugin compiler module for performing constant folding at compile time # on variables in a particular namespace. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Namespace::Constants; use strict; use warnings; use base 'Template::Base'; use Template::Config; use Template::Directive; use Template::Exception; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; sub _init { my ($self, $config) = @_; $self->{ STASH } = Template::Config->stash($config) || return $self->error(Template::Config->error()); return $self; } #------------------------------------------------------------------------ # ident(\@ident) foo.bar(baz) #------------------------------------------------------------------------ sub ident { my ($self, $ident) = @_; my @save = @$ident; # discard first node indicating constants namespace splice(@$ident, 0, 2); my $nelems = @$ident / 2; my ($e, $result); local $" = ', '; print STDERR "constant ident [ @$ident ] " if $DEBUG; foreach $e (0..$nelems-1) { # node name must be a constant unless ($ident->[$e * 2] =~ s/^'(.+)'$/$1/s) { $self->DEBUG(" * deferred (non-constant item: ", $ident->[$e * 2], ")\n") if $DEBUG; return Template::Directive->ident(\@save); } # if args is non-zero then it must be eval'ed if ($ident->[$e * 2 + 1]) { my $args = $ident->[$e * 2 + 1]; my $comp = eval "$args"; if ($@) { $self->DEBUG(" * deferred (non-constant args: $args)\n") if $DEBUG; return Template::Directive->ident(\@save); } $self->DEBUG("($args) ") if $comp && $DEBUG; $ident->[$e * 2 + 1] = $comp; } } $result = $self->{ STASH }->get($ident); if (! length $result || ref $result) { my $reason = length $result ? 'reference' : 'no result'; $self->DEBUG(" * deferred ($reason)\n") if $DEBUG; return Template::Directive->ident(\@save); } $result =~ s/'/\\'/g; $self->DEBUG(" * resolved => '$result'\n") if $DEBUG; return "'$result'"; } 1; __END__ =head1 NAME Template::Namespace::Constants - Compile time constant folding =head1 SYNOPSIS # easy way to define constants use Template; my $tt = Template->new({ CONSTANTS => { pi => 3.14, e => 2.718, }, }); # nitty-gritty, hands-dirty way use Template::Namespace::Constants; my $tt = Template->new({ NAMESPACE => { constants => Template::Namespace::Constants->new({ pi => 3.14, e => 2.718, }, }, }); =head1 DESCRIPTION The C<Template::Namespace::Constants> module implements a namespace handler which is plugged into the C<Template::Directive> compiler module. This then performs compile time constant folding of variables in a particular namespace. =head1 METHODS =head2 new(\%constants) The new() constructor method creates and returns a reference to a new Template::Namespace::Constants object. This creates an internal stash to store the constant variable definitions passed as arguments. my $handler = Template::Namespace::Constants->new({ pi => 3.14, e => 2.718, }); =head2 ident(\@ident) Method called to resolve a variable identifier into a compiled form. In this case, the method fetches the corresponding constant value from its internal stash and returns it. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Directive> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/View.pm 0000444 00000056714 15125513451 0010173 0 ustar 00 #============================================================= -*-Perl-*- # # Template::View # # DESCRIPTION # A custom view of a template processing context. Can be used to # implement custom "skins". # # AUTHOR # Andy Wardley <abw@kfs.org> # # COPYRIGHT # Copyright (C) 2000-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # TODO # * allowing print to have a hash ref as final args will cause problems # if you do this: [% view.print(hash1, hash2, hash3) %]. Current # work-around is to do [% view.print(hash1); view.print(hash2); # view.print(hash3) %] or [% view.print(hash1, hash2, hash3, { }) %] # #============================================================================ package Template::View; use strict; use warnings; use base 'Template::Base'; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our @BASEARGS = qw( context ); our $AUTOLOAD; our $MAP = { HASH => 'hash', ARRAY => 'list', TEXT => 'text', default => '', }; #------------------------------------------------------------------------ # _init(\%config) # # Initialisation method called by the Template::Base class new() # constructor. $self->{ context } has already been set, by virtue of # being named in @BASEARGS. Remaining config arguments are presented # as a hash reference. #------------------------------------------------------------------------ sub _init { my ($self, $config) = @_; # move 'context' somewhere more private $self->{ _CONTEXT } = $self->{ context }; delete $self->{ context }; # generate table mapping object types to templates my $map = $config->{ map } || { }; $map->{ default } = $config->{ default } unless defined $map->{ default }; $self->{ map } = { %$MAP, %$map, }; # local BLOCKs definition table $self->{ _BLOCKS } = $config->{ blocks } || { }; # name of presentation method which printed objects might provide $self->{ method } = defined $config->{ method } ? $config->{ method } : 'present'; # view is sealed by default preventing variable update after # definition, however we don't actually seal a view until the # END of the view definition my $sealed = $config->{ sealed }; $sealed = 1 unless defined $sealed; $self->{ sealed } = $sealed ? 1 : 0; # copy remaining config items from $config or set defaults foreach my $arg (qw( base prefix suffix notfound silent )) { $self->{ $arg } = $config->{ $arg } || ''; } # check that any base specified is defined return $self->error('Invalid base specified for view') if exists $config->{ base } && ! $self->{ base }; # name of data item used by view() $self->{ item } = $config->{ item } || 'item'; # map methods of form ${include_prefix}_foobar() to include('foobar')? $self->{ include_prefix } = $config->{ include_prefix } || 'include_'; # what about mapping foobar() to include('foobar')? $self->{ include_naked } = defined $config->{ include_naked } ? $config->{ include_naked } : 1; # map methods of form ${view_prefix}_foobar() to include('foobar')? $self->{ view_prefix } = $config->{ view_prefix } || 'view_'; # what about mapping foobar() to view('foobar')? $self->{ view_naked } = $config->{ view_naked } || 0; # the view is initially unsealed, allowing directives in the initial # view template to create data items via the AUTOLOAD; once sealed via # call to seal(), the AUTOLOAD will not update any internal items. delete @$config{ qw( base method map default prefix suffix notfound item include_prefix include_naked silent sealed view_prefix view_naked blocks ) }; $config = { %{ $self->{ base }->{ data } }, %$config } if $self->{ base }; $self->{ data } = $config; $self->{ SEALED } = 0; return $self; } #------------------------------------------------------------------------ # seal() # unseal() # # Seal or unseal the view to allow/prevent new data items from being # automatically created by the AUTOLOAD method. #------------------------------------------------------------------------ sub seal { my $self = shift; $self->{ SEALED } = $self->{ sealed }; } sub unseal { my $self = shift; $self->{ SEALED } = 0; } #------------------------------------------------------------------------ # clone(\%config) # # Cloning method which takes a copy of $self and then applies to it any # modifications specified in the $config hash passed as an argument. # Configuration items may also be specified as a list of "name => $value" # arguments. Returns a reference to the cloned Template::View object. # # NOTE: may need to copy BLOCKS??? #------------------------------------------------------------------------ sub clone { my $self = shift; my $clone = bless { %$self }, ref $self; my $config = ref $_[0] eq 'HASH' ? shift : { @_ }; # merge maps $clone->{ map } = { %{ $self->{ map } }, %{ $config->{ map } || { } }, }; # "map => { default=>'xxx' }" can be specified as "default => 'xxx'" $clone->{ map }->{ default } = $config->{ default } if defined $config->{ default }; # update any remaining config items my @args = qw( base prefix suffix notfound item method include_prefix include_naked view_prefix view_naked ); foreach my $arg (@args) { $clone->{ $arg } = $config->{ $arg } if defined $config->{ $arg }; } push(@args, qw( default map )); delete @$config{ @args }; # anything left is data my $data = $clone->{ data } = { %{ $self->{ data } } }; @$data{ keys %$config } = values %$config; return $clone; } #------------------------------------------------------------------------ # print(@items, ..., \%config) # # Prints @items in turn by mapping each to an appropriate template using # the internal 'map' hash. If an entry isn't found and the item is an # object that implements the method named in the internal 'method' item, # (default: 'present'), then the method will be called passing a reference # to $self, against which the presenter method may make callbacks (e.g. # to view_item()). If the presenter method isn't implemented, then the # 'default' map entry is consulted and used if defined. The final argument # may be a reference to a hash array providing local overrides to the internal # defaults for various items (prefix, suffix, etc). In the presence # of this parameter, a clone of the current object is first made, applying # any configuration updates, and control is then delegated to it. #------------------------------------------------------------------------ sub print { my $self = shift; # if final config hash is specified then create a clone and delegate to it # NOTE: potential problem when called print(\%data_hash1, \%data_hash2); if ((scalar @_ > 1) && (ref $_[-1] eq 'HASH')) { my $cfg = pop @_; my $clone = $self->clone($cfg) || return; return $clone->print(@_) || $self->error($clone->error()); } my ($item, $type, $template, $present); my $method = $self->{ method }; my $map = $self->{ map }; my $output = ''; # print each argument foreach $item (@_) { my $newtype; if (! ($type = ref $item)) { # non-references are TEXT $type = 'TEXT'; $template = $map->{ $type }; } elsif (! defined ($template = $map->{ $type })) { # no specific map entry for object, maybe it implements a # 'present' (or other) method? if ( $method && UNIVERSAL::can($item, $method) ) { $present = $item->$method($self); ## call item method # undef returned indicates error, note that we expect # $item to have called error() on the view return unless defined $present; $output .= $present; next; ## NEXT } elsif ( ref($item) eq 'HASH' && defined($newtype = $item->{$method}) && defined($template = $map->{"$method=>$newtype"})) { } elsif ( defined($newtype) && defined($template = $map->{"$method=>*"}) ) { $template =~ s/\*/$newtype/; } elsif (! ($template = $map->{ default }) ) { # default not defined, so construct template name from type ($template = $type) =~ s/\W+/_/g; } } # else { # $self->DEBUG("defined map type for $type: $template\n"); # } $self->DEBUG("printing view '", $template || '', "', $item\n") if $DEBUG; $output .= $self->view($template, $item) if $template; } return $output; } #------------------------------------------------------------------------ # view($template, $item, \%vars) # # Wrapper around include() which expects a template name, $template, # followed by a data item, $item, and optionally, a further hash array # of template variables. The $item is added as an entry to the $vars # hash (which is created empty if not passed as an argument) under the # name specified by the internal 'item' member, which is appropriately # 'item' by default. Thus an external object present() method can # callback against this object method, simply passing a data item to # be displayed. The external object doesn't have to know what the # view expects the item to be called in the $vars hash. #------------------------------------------------------------------------ sub view { my ($self, $template, $item) = splice(@_, 0, 3); my $vars = ref $_[0] eq 'HASH' ? shift : { @_ }; $vars->{ $self->{ item } } = $item if defined $item; $self->include($template, $vars); } #------------------------------------------------------------------------ # include($template, \%vars) # # INCLUDE a template, $template, mapped according to the current prefix, # suffix, default, etc., where $vars is an optional hash reference # containing template variable definitions. If the template isn't found # then the method will default to any 'notfound' template, if defined # as an internal item. #------------------------------------------------------------------------ sub include { my ($self, $template, $vars) = @_; my $context = $self->{ _CONTEXT }; $template = $self->template($template); $vars = { } unless ref $vars eq 'HASH'; $vars->{ view } ||= $self; $context->include( $template, $vars ); # DEBUGGING # my $out = $context->include( $template, $vars ); # print STDERR "VIEW return [$out]\n"; # return $out; } #------------------------------------------------------------------------ # template($template) # # Returns a compiled template for the specified template name, according # to the current configuration parameters. #------------------------------------------------------------------------ sub template { my ($self, $name) = @_; my $context = $self->{ _CONTEXT }; return $context->throw( Template::Constants::ERROR_VIEW, "no view template specified" ) unless $name; my $notfound = $self->{ notfound }; my $base = $self->{ base }; my ($template, $block, $error); return $block if ($block = $self->{ _BLOCKS }->{ $name }); # try the named template $template = $self->template_name($name); $self->DEBUG("looking for $template\n") if $DEBUG; eval { $template = $context->template($template) }; # try asking the base view if not found if (($error = $@) && $base) { $self->DEBUG("asking base for $name\n") if $DEBUG; eval { $template = $base->template($name) }; } # try the 'notfound' template (if defined) if that failed if (($error = $@) && $notfound) { unless ($template = $self->{ _BLOCKS }->{ $notfound }) { $notfound = $self->template_name($notfound); $self->DEBUG("not found, looking for $notfound\n") if $DEBUG; eval { $template = $context->template($notfound) }; return $context->throw(Template::Constants::ERROR_VIEW, $error) if $@; # return first error } } elsif ($error) { $self->DEBUG("no 'notfound'\n") if $DEBUG; return $context->throw(Template::Constants::ERROR_VIEW, $error); } return $template; } #------------------------------------------------------------------------ # template_name($template) # # Returns the name of the specified template with any appropriate prefix # and/or suffix added. #------------------------------------------------------------------------ sub template_name { my ($self, $template) = @_; $template = $self->{ prefix } . $template . $self->{ suffix } if $template; $self->DEBUG("template name: $template\n") if $DEBUG; return $template; } #------------------------------------------------------------------------ # default($val) # # Special case accessor to retrieve/update 'default' as an alias for # '$map->{ default }'. #------------------------------------------------------------------------ sub default { my $self = shift; return @_ ? ($self->{ map }->{ default } = shift) : $self->{ map }->{ default }; } #------------------------------------------------------------------------ # AUTOLOAD # # Returns/updates public internal data items (i.e. not prefixed '_' or # '.') or presents a view if the method matches the view_prefix item, # e.g. view_foo(...) => view('foo', ...). Similarly, the # include_prefix is used, if defined, to map include_foo(...) to # include('foo', ...). If that fails then the entire method name will # be used as the name of a template to include iff the include_named # parameter is set (default: 1). Last attempt is to match the entire # method name to a view() call, iff view_naked is set. Otherwise, a # 'view' exception is raised reporting the error "no such view member: # $method". #------------------------------------------------------------------------ sub AUTOLOAD { my $self = shift; my $item = $AUTOLOAD; $item =~ s/.*:://; return if $item eq 'DESTROY'; my $starts_with = substr($item,0,1); if ($starts_with eq '.' || $starts_with eq '_') { return $self->{ _CONTEXT }->throw(Template::Constants::ERROR_VIEW, "attempt to view private member: $item"); } elsif (exists $self->{ $item }) { # update existing config item (e.g. 'prefix') if unsealed return $self->{ _CONTEXT }->throw(Template::Constants::ERROR_VIEW, "cannot update config item in sealed view: $item") if @_ && $self->{ SEALED }; $self->DEBUG("accessing item: $item\n") if $DEBUG; return @_ ? ($self->{ $item } = shift) : $self->{ $item }; } elsif (exists $self->{ data }->{ $item }) { # get/update existing data item (must be unsealed to update) if (@_ && $self->{ SEALED }) { return $self->{ _CONTEXT }->throw( Template::Constants::ERROR_VIEW, "cannot update item in sealed view: $item" ) unless $self->{ silent }; # ignore args if silent @_ = (); } $self->DEBUG(@_ ? "updating data item: $item <= $_[0]\n" : "returning data item: $item\n" ) if $DEBUG; return @_ ? ($self->{ data }->{ $item } = shift) : $self->{ data }->{ $item }; } elsif (@_ && ! $self->{ SEALED }) { # set data item if unsealed $self->DEBUG("setting unsealed data: $item => @_\n") if $DEBUG; $self->{ data }->{ $item } = shift; } elsif ($item =~ s/^$self->{ view_prefix }//) { $self->DEBUG("returning view($item)\n") if $DEBUG; return $self->view($item, @_); } elsif ($item =~ s/^$self->{ include_prefix }//) { $self->DEBUG("returning include($item)\n") if $DEBUG; return $self->include($item, @_); } elsif ($self->{ include_naked }) { $self->DEBUG("returning naked include($item)\n") if $DEBUG; return $self->include($item, @_); } elsif ($self->{ view_naked }) { $self->DEBUG("returning naked view($item)\n") if $DEBUG; return $self->view($item, @_); } else { return $self->{ _CONTEXT }->throw( Template::Constants::ERROR_VIEW, "no such view member: $item" ); } } 1; __END__ =head1 NAME Template::View - customised view of a template processing context =head1 SYNOPSIS # define a view [% VIEW view # some standard args prefix => 'my_', suffix => '.tt2', notfound => 'no_such_file' ... # any other data title => 'My View title' other_item => 'Joe Random Data' ... %] # add new data definitions, via 'my' self reference [% my.author = "$abw.name <$abw.email>" %] [% my.copy = "© Copyright 2000 $my.author" %] # define a local block [% BLOCK header %] This is the header block, title: [% title or my.title %] [% END %] [% END %] # access data items for view [% view.title %] [% view.other_item %] # access blocks directly ('include_naked' option, set by default) [% view.header %] [% view.header(title => 'New Title') %] # non-local templates have prefix/suffix attached [% view.footer %] # => [% INCLUDE my_footer.tt2 %] # more verbose form of block access [% view.include( 'header', title => 'The Header Title' ) %] [% view.include_header( title => 'The Header Title' ) %] # very short form of above ('include_naked' option, set by default) [% view.header( title => 'The Header Title' ) %] # non-local templates have prefix/suffix attached [% view.footer %] # => [% INCLUDE my_footer.tt2 %] # fallback on the 'notfound' template ('my_no_such_file.tt2') # if template not found [% view.include('missing') %] [% view.include_missing %] [% view.missing %] # print() includes a template relevant to argument type [% view.print("some text") %] # type=TEXT, template='text' [% BLOCK my_text.tt2 %] # 'text' with prefix/suffix Text: [% item %] [% END %] # now print() a hash ref, mapped to 'hash' template [% view.print(some_hash_ref) %] # type=HASH, template='hash' [% BLOCK my_hash.tt2 %] # 'hash' with prefix/suffix hash keys: [% item.keys.sort.join(', ') [% END %] # now print() a list ref, mapped to 'list' template [% view.print(my_list_ref) %] # type=ARRAY, template='list' [% BLOCK my_list.tt2 %] # 'list' with prefix/suffix list: [% item.join(', ') %] [% END %] # print() maps 'My::Object' to 'My_Object' [% view.print(myobj) %] [% BLOCK my_My_Object.tt2 %] [% item.this %], [% item.that %] [% END %] # update mapping table [% view.map.ARRAY = 'my_list_template' %] [% view.map.TEXT = 'my_text_block' %] # change prefix, suffix, item name, etc. [% view.prefix = 'your_' %] [% view.default = 'anyobj' %] ... =head1 DESCRIPTION TODO =head1 METHODS =head2 new($context, \%config) Creates a new Template::View presenting a custom view of the specified $context object. A reference to a hash array of configuration options may be passed as the second argument. =over 4 =item prefix Prefix added to all template names. [% USE view(prefix => 'my_') %] [% view.view('foo', a => 20) %] # => my_foo =item suffix Suffix added to all template names. [% USE view(suffix => '.tt2') %] [% view.view('foo', a => 20) %] # => foo.tt2 =item map Hash array mapping reference types to template names. The print() method uses this to determine which template to use to present any particular item. The TEXT, HASH and ARRAY items default to 'test', 'hash' and 'list' appropriately. [% USE view(map => { ARRAY => 'my_list', HASH => 'your_hash', My::Foo => 'my_foo', } ) %] [% view.print(some_text) %] # => text [% view.print(a_list) %] # => my_list [% view.print(a_hash) %] # => your_hash [% view.print(a_foo) %] # => my_foo [% BLOCK text %] Text: [% item %] [% END %] [% BLOCK my_list %] list: [% item.join(', ') %] [% END %] [% BLOCK your_hash %] hash keys: [% item.keys.sort.join(', ') [% END %] [% BLOCK my_foo %] Foo: [% item.this %], [% item.that %] [% END %] =item method Name of a method which objects passed to print() may provide for presenting themselves to the view. If a specific map entry can't be found for an object reference and it supports the method (default: 'present') then the method will be called, passing the view as an argument. The object can then make callbacks against the view to present itself. package Foo; sub present { my ($self, $view) = @_; return "a regular view of a Foo\n"; } sub debug { my ($self, $view) = @_; return "a debug view of a Foo\n"; } In a template: [% USE view %] [% view.print(my_foo_object) %] # a regular view of a Foo [% USE view(method => 'debug') %] [% view.print(my_foo_object) %] # a debug view of a Foo =item default Default template to use if no specific map entry is found for an item. [% USE view(default => 'my_object') %] [% view.print(objref) %] # => my_object If no map entry or default is provided then the view will attempt to construct a template name from the object class, substituting any sequence of non-word characters to single underscores, e.g. # 'fubar' is an object of class Foo::Bar [% view.print(fubar) %] # => Foo_Bar Any current prefix and suffix will be added to both the default template name and any name constructed from the object class. =item notfound Fallback template to use if any other isn't found. =item item Name of the template variable to which the print() method assigns the current item. Defaults to 'item'. [% USE view %] [% BLOCK list %] [% item.join(', ') %] [% END %] [% view.print(a_list) %] [% USE view(item => 'thing') %] [% BLOCK list %] [% thing.join(', ') %] [% END %] [% view.print(a_list) %] =item view_prefix Prefix of methods which should be mapped to view() by AUTOLOAD. Defaults to 'view_'. [% USE view %] [% view.view_header() %] # => view('header') [% USE view(view_prefix => 'show_me_the_' %] [% view.show_me_the_header() %] # => view('header') =item view_naked Flag to indicate if any attempt should be made to map method names to template names where they don't match the view_prefix. Defaults to 0. [% USE view(view_naked => 1) %] [% view.header() %] # => view('header') =back =head2 print( $obj1, $obj2, ... \%config) TODO =head2 view( $template, \%vars, \%config ); TODO =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 2000-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin> =cut 5.32/Template/Stash.pm 0000444 00000070164 15125513451 0010336 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Stash # # DESCRIPTION # Definition of an object class which stores and manages access to # variables for the Template Toolkit. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Stash; use strict; use warnings; use Template::VMethods; use Template::Exception; use Scalar::Util qw( blessed reftype ); our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $PRIVATE = qr/^[_.]/; our $UNDEF_TYPE = 'var.undef'; our $UNDEF_INFO = 'undefined variable: %s'; # alias _dotop() to dotop() so that we have a consistent method name # between the Perl and XS stash implementations *dotop = \&_dotop; #------------------------------------------------------------------------ # Virtual Methods # # If any of $ROOT_OPS, $SCALAR_OPS, $HASH_OPS or $LIST_OPS are already # defined then we merge their contents with the default virtual methods # define by Template::VMethods. Otherwise we can directly alias the # corresponding Template::VMethod package vars. #------------------------------------------------------------------------ our $ROOT_OPS = defined $ROOT_OPS ? { %{$Template::VMethods::ROOT_VMETHODS}, %$ROOT_OPS } : $Template::VMethods::ROOT_VMETHODS; our $SCALAR_OPS = defined $SCALAR_OPS ? { %{$Template::VMethods::TEXT_VMETHODS}, %$SCALAR_OPS } : $Template::VMethods::TEXT_VMETHODS; our $HASH_OPS = defined $HASH_OPS ? { %{$Template::VMethods::HASH_VMETHODS}, %$HASH_OPS } : $Template::VMethods::HASH_VMETHODS; our $LIST_OPS = defined $LIST_OPS ? { %{$Template::VMethods::LIST_VMETHODS}, %$LIST_OPS } : $Template::VMethods::LIST_VMETHODS; #------------------------------------------------------------------------ # define_vmethod($type, $name, \&sub) # # Defines a virtual method of type $type (SCALAR, HASH, or LIST), with # name $name, that invokes &sub when called. It is expected that &sub # be able to handle the type that it will be called upon. #------------------------------------------------------------------------ sub define_vmethod { my ($class, $type, $name, $sub) = @_; my $op; $type = lc $type; if ($type eq 'scalar' || $type eq 'item') { $op = $SCALAR_OPS; } elsif ($type eq 'hash') { $op = $HASH_OPS; } elsif ($type eq 'list' || $type eq 'array') { $op = $LIST_OPS; } else { die "invalid vmethod type: $type\n"; } $op->{ $name } = $sub; return 1; } #======================================================================== # ----- CLASS METHODS ----- #======================================================================== #------------------------------------------------------------------------ # new(\%params) # # Constructor method which creates a new Template::Stash object. # An optional hash reference may be passed containing variable # definitions that will be used to initialise the stash. # # Returns a reference to a newly created Template::Stash. #------------------------------------------------------------------------ sub new { my $class = shift; my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ }; my $self = { global => { }, %$params, %$ROOT_OPS, '_PARENT' => undef, }; bless $self, $class; } #======================================================================== # ----- PUBLIC OBJECT METHODS ----- #======================================================================== #------------------------------------------------------------------------ # clone(\%params) # # Creates a copy of the current stash object to effect localisation # of variables. The new stash is blessed into the same class as the # parent (which may be a derived class) and has a '_PARENT' member added # which contains a reference to the parent stash that created it # ($self). This member is used in a successive declone() method call to # return the reference to the parent. # # A parameter may be provided which should reference a hash of # variable/values which should be defined in the new stash. The # update() method is called to define these new variables in the cloned # stash. # # Returns a reference to a cloned Template::Stash. #------------------------------------------------------------------------ sub clone { my ($self, $params) = @_; $params ||= { }; # look out for magical 'import' argument which imports another hash my $import = $params->{ import }; if (ref $import eq 'HASH') { delete $params->{ import }; } else { undef $import; } my $clone = bless { %$self, # copy all parent members %$params, # copy all new data '_PARENT' => $self, # link to parent }, ref $self; # perform hash import if defined &{ $HASH_OPS->{ import } }($clone, $import) if defined $import; return $clone; } #------------------------------------------------------------------------ # declone($export) # # Returns a reference to the PARENT stash. When called in the following # manner: # $stash = $stash->declone(); # the reference count on the current stash will drop to 0 and be "freed" # and the caller will be left with a reference to the parent. This # contains the state of the stash before it was cloned. #------------------------------------------------------------------------ sub declone { my $self = shift; $self->{ _PARENT } || $self; } #------------------------------------------------------------------------ # get($ident) # # Returns the value for an variable stored in the stash. The variable # may be specified as a simple string, e.g. 'foo', or as an array # reference representing compound variables. In the latter case, each # pair of successive elements in the list represent a node in the # compound variable. The first is the variable name, the second a # list reference of arguments or 0 if undefined. So, the compound # variable [% foo.bar('foo').baz %] would be represented as the list # [ 'foo', 0, 'bar', ['foo'], 'baz', 0 ]. Returns the value of the # identifier or an empty string if undefined. Errors are thrown via # die(). #------------------------------------------------------------------------ sub get { my ($self, $ident, $args) = @_; my ($root, $result); $root = $self; if (ref $ident eq 'ARRAY' || (index($ident,'.') > -1) && ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ])) { my $size = $#$ident; # if $ident is a list reference, then we evaluate each item in the # identifier against the previous result, using the root stash # ($self) as the first implicit 'result'... foreach (my $i = 0; $i <= $size; $i += 2) { $result = $self->_dotop($root, @$ident[$i, $i+1]); last unless defined $result; $root = $result; } } else { $result = $self->_dotop($root, $ident, $args); } return defined $result ? $result : $self->undefined($ident, $args); } #------------------------------------------------------------------------ # set($ident, $value, $default) # # Updates the value for a variable in the stash. The first parameter # should be the variable name or array, as per get(). The second # parameter should be the intended value for the variable. The third, # optional parameter is a flag which may be set to indicate 'default' # mode. When set true, the variable will only be updated if it is # currently undefined or has a false value. The magical 'IMPORT' # variable identifier may be used to indicate that $value is a hash # reference whose values should be imported. Returns the value set, # or an empty string if not set (e.g. default mode). In the case of # IMPORT, returns the number of items imported from the hash. #------------------------------------------------------------------------ sub set { my ($self, $ident, $value, $default) = @_; my ($root, $result, $error); $root = $self; ELEMENT: { if (ref $ident eq 'ARRAY' || (index($ident,'.') != -1) # has a '.' in it somewhere && ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ])) { # a compound identifier may contain multiple elements (e.g. # foo.bar.baz) and we must first resolve all but the last, # using _dotop() with the $lvalue flag set which will create # intermediate hashes if necessary... my $size = $#$ident; foreach (my $i = 0; $i < $size - 2; $i += 2) { $result = $self->_dotop($root, @$ident[$i, $i+1], 1); last ELEMENT unless defined $result; $root = $result; } # then we call _assign() to assign the value to the last element $result = $self->_assign( $root, @$ident[$size-1, $size], $value, $default ); } else { $result = $self->_assign($root, $ident, 0, $value, $default); } } return defined $result ? $result : ''; } #------------------------------------------------------------------------ # getref($ident) # # Returns a "reference" to a particular item. This is represented as a # closure which will return the actual stash item when called. #------------------------------------------------------------------------ sub getref { my ($self, $ident, $args) = @_; my ($root, $item, $result); $root = $self; if (ref $ident eq 'ARRAY') { my $size = $#$ident; foreach (my $i = 0; $i <= $size; $i += 2) { ($item, $args) = @$ident[$i, $i + 1]; last if $i >= $size - 2; # don't evaluate last node last unless defined ($root = $self->_dotop($root, $item, $args)); } } else { $item = $ident; } if (defined $root) { return sub { my @args = (@{$args||[]}, @_); $self->_dotop($root, $item, \@args); } } else { return sub { '' }; } } #------------------------------------------------------------------------ # update(\%params) # # Update multiple variables en masse. No magic is performed. Simple # variable names only. #------------------------------------------------------------------------ sub update { my ($self, $params) = @_; # look out for magical 'import' argument to import another hash my $import = $params->{ import }; if (ref $import eq 'HASH') { @$self{ keys %$import } = values %$import; delete $params->{ import }; } @$self{ keys %$params } = values %$params; } #------------------------------------------------------------------------ # undefined($ident, $args) # # Method called when a get() returns an undefined value. Can be redefined # in a subclass to implement alternate handling. #------------------------------------------------------------------------ sub undefined { my ($self, $ident, $args) = @_; if ($self->{ _STRICT }) { # Sorry, but we can't provide a sensible source file and line without # re-designing the whole architecture of TT (see TT3) die Template::Exception->new( $UNDEF_TYPE, sprintf( $UNDEF_INFO, $self->_reconstruct_ident($ident) ) ) if $self->{ _STRICT }; } else { # There was a time when I thought this was a good idea. But it's not. return ''; } } sub _reconstruct_ident { my ($self, $ident) = @_; my ($name, $args, @output); my @input = ref $ident eq 'ARRAY' ? @$ident : ($ident); while (@input) { $name = shift @input; $args = shift @input || 0; $name .= '(' . join(', ', map { /^\d+$/ ? $_ : "'$_'" } @$args) . ')' if $args && ref $args eq 'ARRAY'; push(@output, $name); } return join('.', @output); } #======================================================================== # ----- PRIVATE OBJECT METHODS ----- #======================================================================== #------------------------------------------------------------------------ # _dotop($root, $item, \@args, $lvalue) # # This is the core 'dot' operation method which evaluates elements of # variables against their root. All variables have an implicit root # which is the stash object itself (a hash). Thus, a non-compound # variable 'foo' is actually '(stash.)foo', the compound 'foo.bar' is # '(stash.)foo.bar'. The first parameter is a reference to the current # root, initially the stash itself. The second parameter contains the # name of the variable element, e.g. 'foo'. The third optional # parameter is a reference to a list of any parenthesised arguments # specified for the variable, which are passed to sub-routines, object # methods, etc. The final parameter is an optional flag to indicate # if this variable is being evaluated on the left side of an assignment # (e.g. foo.bar.baz = 10). When set true, intermediated hashes will # be created (e.g. bar) if necessary. # # Returns the result of evaluating the item against the root, having # performed any variable "magic". The value returned can then be used # as the root of the next _dotop() in a compound sequence. Returns # undef if the variable is undefined. #------------------------------------------------------------------------ sub _dotop { my ($self, $root, $item, $args, $lvalue) = @_; my $rootref = ref $root; my $atroot = (blessed $root && $root->isa(ref $self)); my ($value, @result); $args ||= [ ]; $lvalue ||= 0; # print STDERR "_dotop(root=$root, item=$item, args=[@$args])\n" # if $DEBUG; # return undef without an error if either side of the dot is unviable return undef unless defined($root) and defined($item); # or if an attempt is made to access a private member, starting _ or . return undef if $PRIVATE && $item =~ /$PRIVATE/; if ($atroot || $rootref eq 'HASH') { # if $root is a regular HASH or a Template::Stash kinda HASH (the # *real* root of everything). We first lookup the named key # in the hash, or create an empty hash in its place if undefined # and the $lvalue flag is set. Otherwise, we check the HASH_OPS # pseudo-methods table, calling the code if found, or return undef. if (defined($value = $root->{ $item })) { return $value unless ref $value eq 'CODE'; ## RETURN @result = &$value(@$args); ## @result } elsif ($lvalue) { # we create an intermediate hash if this is an lvalue return $root->{ $item } = { }; ## RETURN } # ugly hack: only allow import vmeth to be called on root stash elsif (($value = $HASH_OPS->{ $item }) && ! $atroot || $item eq 'import') { @result = &$value($root, @$args); ## @result } elsif ( ref $item eq 'ARRAY' ) { # hash slice return [@$root{@$item}]; ## RETURN } } elsif ($rootref eq 'ARRAY') { # if root is an ARRAY then we check for a LIST_OPS pseudo-method # or return the numerical index into the array, or undef if ($value = $LIST_OPS->{ $item }) { @result = &$value($root, @$args); ## @result } elsif ($item =~ /^-?\d+$/) { $value = $root->[$item]; return $value unless ref $value eq 'CODE'; ## RETURN @result = &$value(@$args); ## @result } elsif ( ref $item eq 'ARRAY' ) { # array slice return [@$root[@$item]]; ## RETURN } } # NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL') # doesn't appear to work with CGI, returning true for the first call # and false for all subsequent calls. # UPDATE: that doesn't appear to be the case any more elsif (blessed($root) && $root->can('can')) { # if $root is a blessed reference (i.e. inherits from the # UNIVERSAL object base class) then we call the item as a method. # If that fails then we try to fallback on HASH behaviour if # possible. eval { @result = $root->$item(@$args); }; if ($@) { # temporary hack - required to propagate errors thrown # by views; if $@ is a ref (e.g. Template::Exception # object then we assume it's a real error that needs # real throwing my $class = ref($root) || $root; # Fail only if the function exists die $@ if ( ref($@) || $root->can($item) ); # failed to call object method, so try some fallbacks if (reftype $root eq 'HASH') { if( defined($value = $root->{ $item })) { return $value unless ref $value eq 'CODE'; ## RETURN @result = &$value(@$args); } elsif ($value = $HASH_OPS->{ $item }) { @result = &$value($root, @$args); } elsif ($value = $LIST_OPS->{ $item }) { @result = &$value([$root], @$args); } } elsif (reftype $root eq 'ARRAY') { if( $value = $LIST_OPS->{ $item }) { @result = &$value($root, @$args); } elsif( $item =~ /^-?\d+$/ ) { $value = $root->[$item]; return $value unless ref $value eq 'CODE'; ## RETURN @result = &$value(@$args); ## @result } elsif ( ref $item eq 'ARRAY' ) { # array slice return [@$root[@$item]]; ## RETURN } } elsif ($value = $SCALAR_OPS->{ $item }) { @result = &$value($root, @$args); } elsif ($value = $LIST_OPS->{ $item }) { @result = &$value([$root], @$args); } elsif ($self->{ _DEBUG }) { @result = (undef, $@); } } } elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) { # at this point, it doesn't look like we've got a reference to # anything we know about, so we try the SCALAR_OPS pseudo-methods # table (but not for l-values) @result = &$value($root, @$args); ## @result } elsif (($value = $LIST_OPS->{ $item }) && ! $lvalue) { # last-ditch: can we promote a scalar to a one-element # list and apply a LIST_OPS virtual method? @result = &$value([$root], @$args); } elsif ($self->{ _DEBUG }) { die "don't know how to access [ $root ].$item\n"; ## DIE } else { @result = (); } # fold multiple return items into a list unless first item is undef if (defined $result[0]) { return ## RETURN scalar @result > 1 ? [ @result ] : $result[0]; } elsif (defined $result[1]) { die $result[1]; ## DIE } elsif ($self->{ _DEBUG }) { die "$item is undefined\n"; ## DIE } return undef; } #------------------------------------------------------------------------ # _assign($root, $item, \@args, $value, $default) # # Similar to _dotop() above, but assigns a value to the given variable # instead of simply returning it. The first three parameters are the # root item, the item and arguments, as per _dotop(), followed by the # value to which the variable should be set and an optional $default # flag. If set true, the variable will only be set if currently false # (undefined/zero) #------------------------------------------------------------------------ sub _assign { my ($self, $root, $item, $args, $value, $default) = @_; my $rootref = ref $root; my $atroot = ($root eq $self); my $result; $args ||= [ ]; $default ||= 0; # return undef without an error if either side of the dot is unviable return undef unless $root and defined $item; # or if an attempt is made to update a private member, starting _ or . return undef if $PRIVATE && $item =~ /$PRIVATE/; if ($rootref eq 'HASH' || $atroot) { # if the root is a hash we set the named key return ($root->{ $item } = $value) ## RETURN unless $default && $root->{ $item }; } elsif ($rootref eq 'ARRAY' && $item =~ /^-?\d+$/) { # or set a list item by index number return ($root->[$item] = $value) ## RETURN unless $default && $root->{ $item }; } elsif (blessed($root)) { # try to call the item as a method of an object return $root->$item(@$args, $value) ## RETURN unless $default && $root->$item(); # 2 issues: # - method call should be wrapped in eval { } # - fallback on hash methods if object method not found # # eval { $result = $root->$item(@$args, $value); }; # # if ($@) { # die $@ if ref($@) || ($@ !~ /Can't locate object method/); # # # failed to call object method, so try some fallbacks # if (UNIVERSAL::isa($root, 'HASH') && exists $root->{ $item }) { # $result = ($root->{ $item } = $value) # unless $default && $root->{ $item }; # } # } # return $result; ## RETURN } else { die "don't know how to assign to [$root].[$item]\n"; ## DIE } return undef; } 1; __END__ =head1 NAME Template::Stash - Magical storage for template variables =head1 SYNOPSIS use Template::Stash; my $stash = Template::Stash->new(\%vars); # get variable values $value = $stash->get($variable); $value = $stash->get(\@compound); # set variable value $stash->set($variable, $value); $stash->set(\@compound, $value); # default variable value $stash->set($variable, $value, 1); $stash->set(\@compound, $value, 1); # set variable values en masse $stash->update(\%new_vars) # methods for (de-)localising variables $stash = $stash->clone(\%new_vars); $stash = $stash->declone(); =head1 DESCRIPTION The C<Template::Stash> module defines an object class which is used to store variable values for the runtime use of the template processor. Variable values are stored internally in a hash reference (which itself is blessed to create the object) and are accessible via the L<get()> and L<set()> methods. Variables may reference hash arrays, lists, subroutines and objects as well as simple values. The stash automatically performs the right magic when dealing with variables, calling code or object methods, indexing into lists, hashes, etc. The stash has L<clone()> and L<declone()> methods which are used by the template processor to make temporary copies of the stash for localising changes made to variables. =head1 PUBLIC METHODS =head2 new(\%params) The C<new()> constructor method creates and returns a reference to a new C<Template::Stash> object. my $stash = Template::Stash->new(); A hash reference may be passed to provide variables and values which should be used to initialise the stash. my $stash = Template::Stash->new({ var1 => 'value1', var2 => 'value2' }); =head2 get($variable) The C<get()> method retrieves the variable named by the first parameter. $value = $stash->get('var1'); Dotted compound variables can be retrieved by specifying the variable elements by reference to a list. Each node in the variable occupies two entries in the list. The first gives the name of the variable element, the second is a reference to a list of arguments for that element, or C<0> if none. [% foo.bar(10).baz(20) %] $stash->get([ 'foo', 0, 'bar', [ 10 ], 'baz', [ 20 ] ]); =head2 set($variable, $value, $default) The C<set()> method sets the variable name in the first parameter to the value specified in the second. $stash->set('var1', 'value1'); If the third parameter evaluates to a true value, the variable is set only if it did not have a true value before. $stash->set('var2', 'default_value', 1); Dotted compound variables may be specified as per L<get()> above. [% foo.bar = 30 %] $stash->set([ 'foo', 0, 'bar', 0 ], 30); The magical variable 'C<IMPORT>' can be specified whose corresponding value should be a hash reference. The contents of the hash array are copied (i.e. imported) into the current namespace. # foo.bar = baz, foo.wiz = waz $stash->set('foo', { 'bar' => 'baz', 'wiz' => 'waz' }); # import 'foo' into main namespace: bar = baz, wiz = waz $stash->set('IMPORT', $stash->get('foo')); =head2 update($variables) This method can be used to set or update several variables in one go. $stash->update({ foo => 10, bar => 20, }); =head2 getref($variable) This undocumented feature returns a closure which can be called to get the value of a variable. It is used to implement variable references which are evaluated lazily. [% x = \foo.bar.baz %] # x is a reference to foo.bar.baz [% x %] # evalautes foo.bar.baz =head2 clone(\%params) The C<clone()> method creates and returns a new C<Template::Stash> object which represents a localised copy of the parent stash. Variables can be freely updated in the cloned stash and when L<declone()> is called, the original stash is returned with all its members intact and in the same state as they were before C<clone()> was called. For convenience, a hash of parameters may be passed into C<clone()> which is used to update any simple variable (i.e. those that don't contain any namespace elements like C<foo> and C<bar> but not C<foo.bar>) variables while cloning the stash. For adding and updating complex variables, the L<set()> method should be used after calling C<clone().> This will correctly resolve and/or create any necessary namespace hashes. A cloned stash maintains a reference to the stash that it was copied from in its C<_PARENT> member. =head2 declone() The C<declone()> method returns the C<_PARENT> reference and can be used to restore the state of a stash as described above. =head2 define_vmethod($type, $name, $code) This method can be used to define new virtual methods. The first argument should be either C<scalar> or C<item> to define scalar virtual method, C<hash> to define hash virtual methods, or either C<array> or C<list> for list virtual methods. The second argument should be the name of the new method. The third argument should be a reference to a subroutine implementing the method. The data item on which the virtual method is called is passed to the subroutine as the first argument. $stash->define_vmethod( item => ucfirst => sub { my $text = shift; return ucfirst $text } ); =head1 INTERNAL METHODS =head2 dotop($root, $item, \@args, $lvalue) This is the core C<dot> operation method which evaluates elements of variables against their root. =head2 undefined($ident, $args) This method is called when L<get()> encounters an undefined value. If the L<STRICT|Template::Manual::Config#STRICT> option is in effect then it will throw an exception indicating the use of an undefined value. Otherwise it will silently return an empty string. The method can be redefined in a subclass to implement alternate handling of undefined values. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template>, L<Template::Context> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Parser.pm 0000444 00000117266 15125513451 0010515 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Parser # # DESCRIPTION # This module implements a LALR(1) parser and associated support # methods to parse template documents into the appropriate "compiled" # format. Much of the parser DFA code (see _parse() method) is based # on Francois Desarmenien's Parse::Yapp module. Kudos to him. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # The following copyright notice appears in the Parse::Yapp # documentation. # # The Parse::Yapp module and its related modules and shell # scripts are copyright (c) 1998 Francois Desarmenien, # France. All rights reserved. # # You may use and distribute them under the terms of either # the GNU General Public License or the Artistic License, as # specified in the Perl README file. # #============================================================================ package Template::Parser; use strict; use warnings; use base 'Template::Base'; use Template::Constants qw( :status :chomp ); use Template::Directive; use Template::Grammar; # parser state constants use constant CONTINUE => 0; use constant ACCEPT => 1; use constant ERROR => 2; use constant ABORT => 3; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $ERROR = ''; # The ANYCASE option can cause conflicts when reserved words are used as # variable names, hash keys, template names, plugin names, etc. The # # $ANYCASE_BEFORE regex identifies where such a word precedes an assignment, # either as a variable (C<wrapper = 'html'>) or hash key (C<{ wrapper => 'html' }). # In that case it is treated as a simple words rather than being the lower case # equivalent of the upper case keyword (e.g. WRAPPER). # # $ANYCASE_AFTER is used to identify when such a word follows a symbols that # suggests it can't be a keyword, e.g. after BLOCK INCLUDE WRAPPER, USE, etc. our $ANYCASE_BEFORE = qr/\G((?=\s*[=\.]))/; our $ANYCASE_AFTER = { map { $_ => 1 } qw( GET SET CALL DEFAULT INSERT INCLUDE PROCESS WRAPPER BLOCK USE PLUGIN FILTER MACRO IN TO STEP AND OR NOT DIV MOD DOT IF UNLESS ELSIF FOR WHILE SWITCH CASE META THROW CATCH VIEW CMPOP BINOP COMMA ), '(', '[', '{' # not sure about ASSIGN as it breaks C<header_html = include header> }; #======================================================================== # -- COMMON TAG STYLES -- #======================================================================== our $TAG_STYLE = { 'outline' => [ '\[%', '%\]', '%%' ], # NEW! Outline tag 'default' => [ '\[%', '%\]' ], 'template1' => [ '[\[%]%', '%[\]%]' ], 'metatext' => [ '%%', '%%' ], 'html' => [ '<!--', '-->' ], 'mason' => [ '<%', '>' ], 'asp' => [ '<%', '%>' ], 'php' => [ '<\?', '\?>' ], 'star' => [ '\[\*', '\*\]' ], }; $TAG_STYLE->{ template } = $TAG_STYLE->{ tt2 } = $TAG_STYLE->{ default }; our $DEFAULT_STYLE = { START_TAG => $TAG_STYLE->{ default }->[0], END_TAG => $TAG_STYLE->{ default }->[1], OUTLINE_TAG => $TAG_STYLE->{ default }->[2], # TAG_STYLE => 'default', ANYCASE => 0, INTERPOLATE => 0, PRE_CHOMP => 0, POST_CHOMP => 0, V1DOLLAR => 0, EVAL_PERL => 0, }; our $QUOTED_ESCAPES = { n => "\n", r => "\r", t => "\t", }; # note that '-' must come first so Perl doesn't think it denotes a range our $CHOMP_FLAGS = qr/[-=~+]/; #======================================================================== # ----- PUBLIC METHODS ----- #======================================================================== #------------------------------------------------------------------------ # new(\%config) # # Constructor method. #------------------------------------------------------------------------ sub new { my $class = shift; my $config = $_[0] && ref($_[0]) eq 'HASH' ? shift(@_) : { @_ }; my ($tagstyle, $debug, $start, $end, $defaults, $grammar, $hash, $key, $udef); my $self = bless { START_TAG => undef, END_TAG => undef, OUTLINE_TAG => undef, TAG_STYLE => 'default', ANYCASE => 0, INTERPOLATE => 0, PRE_CHOMP => 0, POST_CHOMP => 0, V1DOLLAR => 0, EVAL_PERL => 0, FILE_INFO => 1, GRAMMAR => undef, _ERROR => '', IN_BLOCK => [ ], TRACE_VARS => $config->{ TRACE_VARS }, FACTORY => $config->{ FACTORY } || 'Template::Directive', }, $class; # update self with any relevant keys in config foreach $key (keys %$self) { $self->{ $key } = $config->{ $key } if defined $config->{ $key }; } $self->{ FILEINFO } = [ ]; # DEBUG config item can be a bitmask if (defined ($debug = $config->{ DEBUG })) { $self->{ DEBUG } = $debug & ( Template::Constants::DEBUG_PARSER | Template::Constants::DEBUG_FLAGS ); $self->{ DEBUG_DIRS } = $debug & Template::Constants::DEBUG_DIRS; } # package variable can be set to 1 to support previous behaviour elsif ($DEBUG == 1) { $self->{ DEBUG } = Template::Constants::DEBUG_PARSER; $self->{ DEBUG_DIRS } = 0; } # otherwise let $DEBUG be a bitmask else { $self->{ DEBUG } = $DEBUG & ( Template::Constants::DEBUG_PARSER | Template::Constants::DEBUG_FLAGS ); $self->{ DEBUG_DIRS } = $DEBUG & Template::Constants::DEBUG_DIRS; } $grammar = $self->{ GRAMMAR } ||= do { require Template::Grammar; Template::Grammar->new(); }; # instantiate a FACTORY object unless (ref $self->{ FACTORY }) { my $fclass = $self->{ FACTORY }; $self->{ FACTORY } = $self->{ FACTORY }->new( NAMESPACE => $config->{ NAMESPACE } ) || return $class->error($self->{ FACTORY }->error()); } # load grammar rules, states and lex table @$self{ qw( LEXTABLE STATES RULES ) } = @$grammar{ qw( LEXTABLE STATES RULES ) }; $self->new_style($config) || return $class->error($self->error()); return $self; } #----------------------------------------------------------------------- # These methods are used to track nested IF and WHILE blocks. Each # generated if/while block is given a label indicating the directive # type and nesting depth, e.g. FOR0, WHILE1, FOR2, WHILE3, etc. The # NEXT and LAST directives use the innermost label, e.g. last WHILE3; #----------------------------------------------------------------------- sub enter_block { my ($self, $name) = @_; my $blocks = $self->{ IN_BLOCK }; push(@{ $self->{ IN_BLOCK } }, $name); } sub leave_block { my $self = shift; my $label = $self->block_label; pop(@{ $self->{ IN_BLOCK } }); return $label; } sub in_block { my ($self, $name) = @_; my $blocks = $self->{ IN_BLOCK }; return @$blocks && $blocks->[-1] eq $name; } sub block_label { my ($self, $prefix, $suffix) = @_; my $blocks = $self->{ IN_BLOCK }; my $name = @$blocks ? $blocks->[-1] . scalar @$blocks : undef; return join('', grep { defined $_ } $prefix, $name, $suffix); } #------------------------------------------------------------------------ # new_style(\%config) # # Install a new (stacked) parser style. This feature is currently # experimental but should mimic the previous behaviour with regard to # TAG_STYLE, START_TAG, END_TAG, etc. #------------------------------------------------------------------------ sub new_style { my ($self, $config) = @_; my $styles = $self->{ STYLE } ||= [ ]; my ($tagstyle, $tags, $start, $end, $out, $key); # clone new style from previous or default style my $style = { %{ $styles->[-1] || $DEFAULT_STYLE } }; # expand START_TAG and END_TAG from specified TAG_STYLE if ($tagstyle = $config->{ TAG_STYLE }) { return $self->error("Invalid tag style: $tagstyle") unless defined ($tags = $TAG_STYLE->{ $tagstyle }); ($start, $end, $out) = @$tags; $config->{ START_TAG } ||= $start; $config->{ END_TAG } ||= $end; $config->{ OUTLINE_TAG } ||= $out; } foreach $key (keys %$DEFAULT_STYLE) { $style->{ $key } = $config->{ $key } if defined $config->{ $key }; } $start = $style->{ START_TAG }; $end = $style->{ END_TAG }; $out = $style->{ OUTLINE_TAG }; $style->{ TEXT_SPLIT } = $self->text_splitter($start, $end, $out); push(@$styles, $style); return $style; } sub text_splitter { my ($self, $start, $end, $out) = @_; if (defined $out) { return qr/ \A(.*?) # $1 - start of line up to directive (?: (?: ^$out # outline tag at start of line (.*? # $2 - content of that line (?:\n|$) # end of that line or file ) ) | (?: $start # start of tag (.*?) # $3 - tag contents $end # end of tag ) ) /msx; } else { return qr/ ^(.*?) # $1 - start of line up to directive (?: $start # start of tag (.*?) # $2 - tag contents $end # end of tag ) /sx; } } #------------------------------------------------------------------------ # old_style() # # Pop the current parser style and revert to the previous one. See # new_style(). ** experimental ** #------------------------------------------------------------------------ sub old_style { my $self = shift; my $styles = $self->{ STYLE }; return $self->error('only 1 parser style remaining') unless (@$styles > 1); pop @$styles; return $styles->[-1]; } #------------------------------------------------------------------------ # parse($text, $data) # # Parses the text string, $text and returns a hash array representing # the compiled template block(s) as Perl code, in the format expected # by Template::Document. #------------------------------------------------------------------------ sub parse { my ($self, $text, $info) = @_; my ($tokens, $block); $info->{ DEBUG } = $self->{ DEBUG_DIRS } unless defined $info->{ DEBUG }; # print "info: { ", join(', ', map { "$_ => $info->{ $_ }" } keys %$info), " }\n"; # store for blocks defined in the template (see define_block()) my $defblock = $self->{ DEFBLOCK } = { }; my $metadata = $self->{ METADATA } = [ ]; my $variables = $self->{ VARIABLES } = { }; $self->{ DEFBLOCKS } = [ ]; $self->{ _ERROR } = ''; # split file into TEXT/DIRECTIVE chunks $tokens = $self->split_text($text) || return undef; ## RETURN ## push(@{ $self->{ FILEINFO } }, $info); # parse chunks $block = $self->_parse($tokens, $info); pop(@{ $self->{ FILEINFO } }); return undef unless $block; ## RETURN ## $self->debug("compiled main template document block:\n$block") if $self->{ DEBUG } & Template::Constants::DEBUG_PARSER; return { BLOCK => $block, DEFBLOCKS => $defblock, VARIABLES => $variables, METADATA => { @$metadata }, }; } #------------------------------------------------------------------------ # split_text($text) # # Split input template text into directives and raw text chunks. #------------------------------------------------------------------------ sub split_text { my ($self, $text) = @_; my ($pre, $dir, $prelines, $dirlines, $postlines, $chomp, $tags, @tags); my $style = $self->{ STYLE }->[-1]; my ($start, $end, $out, $prechomp, $postchomp, $interp ) = @$style{ qw( START_TAG END_TAG OUTLINE_TAG PRE_CHOMP POST_CHOMP INTERPOLATE ) }; my $tags_dir = $self->{ANYCASE} ? qr<TAGS>i : qr<TAGS>; my $split = $style->{ TEXT_SPLIT }; my $has_out = defined $out; my @tokens = (); my $line = 1; return \@tokens ## RETURN ## unless defined $text && length $text; # extract all directives from the text while ($text =~ s/$split//) { $pre = $1; $dir = defined($2) ? $2 : $3; $pre = '' unless defined $pre; $dir = '' unless defined $dir; $prelines = ($pre =~ tr/\n//); # newlines in preceding text $dirlines = ($dir =~ tr/\n//); # newlines in directive tag $postlines = 0; # newlines chomped after tag for ($dir) { if (/^\#/) { # comment out entire directive except for any end chomp flag $dir = ($dir =~ /($CHOMP_FLAGS)$/o) ? $1 : ''; } else { if(s/^($CHOMP_FLAGS)?(\s*)//so && $2) { my $chomped = $2; my $linecount = ($chomped =~ tr/\n//); # newlines in chomped whitespace $linecount ||= 0; $prelines += $linecount; $dirlines -= $linecount; } # PRE_CHOMP: process whitespace before tag $chomp = $1 ? $1 : $prechomp; $chomp =~ tr/-=~+/1230/; if ($chomp && $pre) { # chomp off whitespace and newline preceding directive if ($chomp == CHOMP_ALL) { $pre =~ s{ (\r?\n|^) [^\S\n]* \z }{}mx; } elsif ($chomp == CHOMP_COLLAPSE) { $pre =~ s{ (\s+) \z }{ }x; } elsif ($chomp == CHOMP_GREEDY) { $pre =~ s{ (\s+) \z }{}x; } } } # POST_CHOMP: process whitespace after tag s/\s*($CHOMP_FLAGS)?\s*$//so; $chomp = $1 ? $1 : $postchomp; $chomp =~ tr/-=~+/1230/; if ($chomp) { if ($chomp == CHOMP_ALL) { $text =~ s{ ^ ([^\S\n]* \n) }{}x && $postlines++; } elsif ($chomp == CHOMP_COLLAPSE) { $text =~ s{ ^ (\s+) }{ }x && ($postlines += $1=~y/\n//); } # any trailing whitespace elsif ($chomp == CHOMP_GREEDY) { $text =~ s{ ^ (\s+) }{}x && ($postlines += $1=~y/\n//); } } } # any text preceding the directive can now be added if (length $pre) { push(@tokens, $interp ? [ $pre, $line, 'ITEXT' ] : ('TEXT', $pre) ); } $line += $prelines; # and now the directive, along with line number information if (length $dir) { # the TAGS directive is a compile-time switch if ($dir =~ /^$tags_dir\s+(.*)/) { my @tags = split(/\s+/, $1); if (scalar @tags > 1) { ($start, $end, $out) = map { quotemeta($_) } @tags; $split = $self->text_splitter($start, $end, $out); } elsif ($tags = $TAG_STYLE->{ $tags[0] }) { ($start, $end, $out) = @$tags; $split = $self->text_splitter($start, $end, $out); } else { warn "invalid TAGS style: $tags[0]\n"; } } else { # DIRECTIVE is pushed as: # [ $dirtext, $line_no(s), \@tokens ] push(@tokens, [ $dir, ($dirlines ? sprintf("%d-%d", $line, $line + $dirlines) : $line), $self->tokenise_directive($dir) ]); } } # update line counter to include directive lines and any extra # newline chomped off the start of the following text $line += $dirlines + $postlines; } # anything remaining in the string is plain text push(@tokens, $interp ? [ $text, $line, 'ITEXT' ] : ( 'TEXT', $text) ) if length $text; return \@tokens; ## RETURN ## } #------------------------------------------------------------------------ # interpolate_text($text, $line) # # Examines $text looking for any variable references embedded like # $this or like ${ this }. #------------------------------------------------------------------------ sub interpolate_text { my ($self, $text, $line) = @_; my @tokens = (); my ($pre, $var, $dir); while ($text =~ / ( (?: \\. | [^\$] ){1,3000} ) # escaped or non-'$' character [$1] | ( \$ (?: # embedded variable [$2] (?: \{ ([^\}]*) \} ) # ${ ... } [$3] | ([\w\.]+) # $word [$4] ) ) /gx) { ($pre, $var, $dir) = ($1, $3 || $4, $2); # preceding text if (defined($pre) && length($pre)) { $line += $pre =~ tr/\n//; $pre =~ s/\\\$/\$/g; push(@tokens, 'TEXT', $pre); } # $variable reference if ($var) { $line += $dir =~ tr/\n/ /; push(@tokens, [ $dir, $line, $self->tokenise_directive($var) ]); } # other '$' reference - treated as text elsif ($dir) { $line += $dir =~ tr/\n//; push(@tokens, 'TEXT', $dir); } } return \@tokens; } #------------------------------------------------------------------------ # tokenise_directive($text) # # Called by the private _parse() method when it encounters a DIRECTIVE # token in the list provided by the split_text() or interpolate_text() # methods. The directive text is passed by parameter. # # The method splits the directive into individual tokens as recognised # by the parser grammar (see Template::Grammar for details). It # constructs a list of tokens each represented by 2 elements, as per # split_text() et al. The first element contains the token type, the # second the token itself. # # The method tokenises the string using a complex (but fast) regex. # For a deeper understanding of the regex magic at work here, see # Jeffrey Friedl's excellent book "Mastering Regular Expressions", # from O'Reilly, ISBN 1-56592-257-3 # # Returns a reference to the list of chunks (each one being 2 elements) # identified in the directive text. On error, the internal _ERROR string # is set and undef is returned. #------------------------------------------------------------------------ sub tokenise_directive { my ($self, $text, $line) = @_; my ($token, $uctoken, $type, $lookup); my $lextable = $self->{ LEXTABLE }; my $style = $self->{ STYLE }->[-1]; my ($anycase, $start, $end) = @$style{ qw( ANYCASE START_TAG END_TAG ) }; my @tokens = ( ); while ($text =~ / # strip out any comments (\#[^\n]*) | # a quoted phrase matches in $3 (["']) # $2 - opening quote, ' or " ( # $3 - quoted text buffer (?: # repeat group (no backreference) \\\\ # an escaped backslash \\ | # ...or... \\\2 # an escaped quote \" or \' (match $1) | # ...or... . # any other character | \n )*? # non-greedy repeat ) # end of $3 \2 # match opening quote | # an unquoted number matches in $4 (-?\d+(?:\.\d+)?) # numbers | # filename matches in $5 ( \/?\w+(?:(?:\/|::?)\w*)+ | \/\w+) | # an identifier matches in $6 (\w+) # variable identifier | # an unquoted word or symbol matches in $7 ( [(){}\[\]:;,\/\\] # misc parenthesis and symbols # | \-> # arrow operator (for future?) | [+\-*] # math operations | \$\{? # dollar with option left brace | => # like '=' | [=!<>]?= | [!<>] # eqality tests | &&? | \|\|? # boolean ops | \.\.? # n..n sequence | \S+ # something unquoted ) # end of $7 /gmxo) { # ignore comments to EOL next if $1; # quoted string if (defined ($token = $3)) { # double-quoted string may include $variable references if ($2 eq '"') { if ($token =~ /[\$\\]/) { $type = 'QUOTED'; # unescape " and \ but leave \$ escaped so that # interpolate_text() doesn't incorrectly treat it # as a variable reference # $token =~ s/\\([\\"])/$1/g; for ($token) { s/\\([^\$nrt])/$1/g; s/\\([nrt])/$QUOTED_ESCAPES->{ $1 }/ge; } push(@tokens, ('"') x 2, @{ $self->interpolate_text($token) }, ('"') x 2); next; } else { $type = 'LITERAL'; $token =~ s['][\\']g; $token = "'$token'"; } } else { $type = 'LITERAL'; $token = "'$token'"; } } # number elsif (defined ($token = $4)) { $type = 'NUMBER'; } elsif (defined($token = $5)) { $type = 'FILENAME'; } elsif (defined($token = $6)) { # Fold potential keywords to UPPER CASE if the ANYCASE option is # set, unless (we've got some preceding tokens and) the previous # token is a DOT op. This prevents the 'last' in 'data.last' # from being interpreted as the LAST keyword. if ($anycase) { # if the token follows a dot or precedes an assignment then # it's not for folding, e.g. the 'wrapper' in this: # [% page = { wrapper='html' }; page.wrapper %] if ((@tokens && $ANYCASE_AFTER->{ $tokens[-2] }) || ($text =~ /$ANYCASE_BEFORE/gc)) { # keep the token unmodified $uctoken = $token; } else { $uctoken = uc $token; } } else { $uctoken = $token; } if (defined ($type = $lextable->{ $uctoken })) { $token = $uctoken; } else { $type = 'IDENT'; } } elsif (defined ($token = $7)) { # reserved words may be in lower case unless case sensitive $uctoken = $anycase ? uc $token : $token; unless (defined ($type = $lextable->{ $uctoken })) { $type = 'UNQUOTED'; } } push(@tokens, $type, $token); # print(STDERR " +[ $type, $token ]\n") # if $DEBUG; } # print STDERR "tokenise directive() returning:\n [ @tokens ]\n" # if $DEBUG; return \@tokens; ## RETURN ## } #------------------------------------------------------------------------ # define_block($name, $block) # # Called by the parser 'defblock' rule when a BLOCK definition is # encountered in the template. The name of the block is passed in the # first parameter and a reference to the compiled block is passed in # the second. This method stores the block in the $self->{ DEFBLOCK } # hash which has been initialised by parse() and will later be used # by the same method to call the store() method on the calling cache # to define the block "externally". #------------------------------------------------------------------------ sub define_block { my ($self, $name, $block) = @_; my $defblock = $self->{ DEFBLOCK } || return undef; $self->debug("compiled block '$name':\n$block") if $self->{ DEBUG } & Template::Constants::DEBUG_PARSER; warn "Block redefined: $name\n" if exists $defblock->{ $name }; $defblock->{ $name } = $block; return undef; } sub push_defblock { my $self = shift; my $stack = $self->{ DEFBLOCK_STACK } ||= []; push(@$stack, $self->{ DEFBLOCK } ); $self->{ DEFBLOCK } = { }; } sub pop_defblock { my $self = shift; my $defs = $self->{ DEFBLOCK }; my $stack = $self->{ DEFBLOCK_STACK } || return $defs; return $defs unless @$stack; $self->{ DEFBLOCK } = pop @$stack; return $defs; } #------------------------------------------------------------------------ # add_metadata(\@setlist) #------------------------------------------------------------------------ sub add_metadata { my ($self, $setlist) = @_; my $metadata = $self->{ METADATA } || return undef; push(@$metadata, @$setlist); return undef; } #------------------------------------------------------------------------ # location() # # Return Perl comment indicating current parser file and line #------------------------------------------------------------------------ sub location { my $self = shift; return "\n" unless $self->{ FILE_INFO }; my $line = ${ $self->{ LINE } }; my $info = $self->{ FILEINFO }->[-1]; my $file = $info->{ path } || $info->{ name } || '(unknown template)'; $line =~ s/\-.*$//; # might be 'n-n' $line ||= 1; return "#line $line \"$file\"\n"; } #======================================================================== # ----- PRIVATE METHODS ----- #======================================================================== #------------------------------------------------------------------------ # _parse(\@tokens, \@info) # # Parses the list of input tokens passed by reference and returns a # Template::Directive::Block object which contains the compiled # representation of the template. # # This is the main parser DFA loop. See embedded comments for # further details. # # On error, undef is returned and the internal _ERROR field is set to # indicate the error. This can be retrieved by calling the error() # method. #------------------------------------------------------------------------ sub _parse { my ($self, $tokens, $info) = @_; my ($token, $value, $text, $line, $inperl); my ($state, $stateno, $status, $action, $lookup, $coderet, @codevars); my ($lhs, $len, $code); # rule contents my $stack = [ [ 0, undef ] ]; # DFA stack # DEBUG # local $" = ', '; # retrieve internal rule and state tables my ($states, $rules) = @$self{ qw( STATES RULES ) }; # If we're tracing variable usage then we need to give the factory a # reference to our $self->{ VARIABLES } for it to fill in. This is a # bit of a hack to back-patch this functionality into TT2. $self->{ FACTORY }->trace_vars($self->{ VARIABLES }) if $self->{ TRACE_VARS }; # call the grammar set_factory method to install emitter factory $self->{ GRAMMAR }->install_factory($self->{ FACTORY }); $line = $inperl = 0; $self->{ LINE } = \$line; $self->{ FILE } = $info->{ name }; $self->{ INPERL } = \$inperl; $status = CONTINUE; my $in_string = 0; while(1) { # get state number and state $stateno = $stack->[-1]->[0]; $state = $states->[$stateno]; # see if any lookaheads exist for the current state if (exists $state->{'ACTIONS'}) { # get next token and expand any directives (i.e. token is an # array ref) onto the front of the token list while (! defined $token && @$tokens) { $token = shift(@$tokens); if (ref $token) { ($text, $line, $token) = @$token; if (ref $token) { if ($info->{ DEBUG } && ! $in_string) { # - - - - - - - - - - - - - - - - - - - - - - - - - # This is gnarly. Look away now if you're easily # frightened. We're pushing parse tokens onto the # pending list to simulate a DEBUG directive like so: # [% DEBUG msg line='20' text='INCLUDE foo' %] # - - - - - - - - - - - - - - - - - - - - - - - - - my $dtext = $text; $dtext =~ s[(['\\])][\\$1]g; unshift(@$tokens, DEBUG => 'DEBUG', IDENT => 'msg', IDENT => 'line', ASSIGN => '=', LITERAL => "'$line'", IDENT => 'text', ASSIGN => '=', LITERAL => "'$dtext'", IDENT => 'file', ASSIGN => '=', LITERAL => "'$info->{ name }'", (';') x 2, @$token, (';') x 2); } else { unshift(@$tokens, @$token, (';') x 2); } $token = undef; # force redo } elsif ($token eq 'ITEXT') { if ($inperl) { # don't perform interpolation in PERL blocks $token = 'TEXT'; $value = $text; } else { unshift(@$tokens, @{ $self->interpolate_text($text, $line) }); $token = undef; # force redo } } } else { # toggle string flag to indicate if we're crossing # a string boundary $in_string = ! $in_string if $token eq '"'; $value = shift(@$tokens); } }; # clear undefined token to avoid 'undefined variable blah blah' # warnings and let the parser logic pick it up in a minute $token = '' unless defined $token; # get the next state for the current lookahead token $action = defined ($lookup = $state->{'ACTIONS'}->{ $token }) ? $lookup : defined ($lookup = $state->{'DEFAULT'}) ? $lookup : undef; } else { # no lookahead actions $action = $state->{'DEFAULT'}; } # ERROR: no ACTION last unless defined $action; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - # shift (+ive ACTION) # - - - - - - - - - - - - - - - - - - - - - - - - - - - - if ($action > 0) { push(@$stack, [ $action, $value ]); $token = $value = undef; redo; }; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - # reduce (-ive ACTION) # - - - - - - - - - - - - - - - - - - - - - - - - - - - - ($lhs, $len, $code) = @{ $rules->[ -$action ] }; # no action imples ACCEPTance $action or $status = ACCEPT; # use dummy sub if code ref doesn't exist if ( !$code ) { $coderet = $len ? $stack->[ -$len ]->[1] : undef; } else { # $code = sub { $_[1] } # unless $code; @codevars = $len ? map { $_->[1] } @$stack[ -$len .. -1 ] : (); eval { $coderet = &$code( $self, @codevars ); }; if ($@) { my $err = $@; chomp $err; return $self->_parse_error($err); } } # reduce stack by $len splice(@$stack, -$len, $len); # ACCEPT return $coderet ## RETURN ## if $status == ACCEPT; # ABORT return undef ## RETURN ## if $status == ABORT; # ERROR last if $status == ERROR; } continue { push(@$stack, [ $states->[ $stack->[-1][0] ]->{'GOTOS'}->{ $lhs }, $coderet ]), } # ERROR ## RETURN ## return $self->_parse_error('unexpected end of input') unless defined $value; # munge text of last directive to make it readable # $text =~ s/\n/\\n/g; return $self->_parse_error("unexpected end of directive", $text) if $value eq ';'; # end of directive SEPARATOR return $self->_parse_error("unexpected token ($value)", $text); } #------------------------------------------------------------------------ # _parse_error($msg, $dirtext) # # Method used to handle errors encountered during the parse process # in the _parse() method. #------------------------------------------------------------------------ sub _parse_error { my ($self, $msg, $text) = @_; my $line = $self->{ LINE }; $line = ref($line) ? $$line : $line; $line = 'unknown' unless $line; $msg .= "\n [% $text %]" if defined $text; return $self->error("line $line: $msg"); } 1; __END__ =head1 NAME Template::Parser - LALR(1) parser for compiling template documents =head1 SYNOPSIS use Template::Parser; $parser = Template::Parser->new(\%config); $template = $parser->parse($text) || die $parser->error(), "\n"; =head1 DESCRIPTION The C<Template::Parser> module implements a LALR(1) parser and associated methods for parsing template documents into Perl code. =head1 PUBLIC METHODS =head2 new(\%params) The C<new()> constructor creates and returns a reference to a new C<Template::Parser> object. A reference to a hash may be supplied as a parameter to provide configuration values. See L<CONFIGURATION OPTIONS> below for a summary of these options and L<Template::Manual::Config> for full details. my $parser = Template::Parser->new({ START_TAG => quotemeta('<+'), END_TAG => quotemeta('+>'), }); =head2 parse($text) The C<parse()> method parses the text passed in the first parameter and returns a reference to a hash array of data defining the compiled representation of the template text, suitable for passing to the L<Template::Document> L<new()|Template::Document#new()> constructor method. On error, undef is returned. $data = $parser->parse($text) || die $parser->error(); The C<$data> hash reference returned contains a C<BLOCK> item containing the compiled Perl code for the template, a C<DEFBLOCKS> item containing a reference to a hash array of sub-template C<BLOCK>s defined within in the template, and a C<METADATA> item containing a reference to a hash array of metadata values defined in C<META> tags. =head1 CONFIGURATION OPTIONS The C<Template::Parser> module accepts the following configuration options. Please see L<Template::Manual::Config> for further details on each option. =head2 START_TAG, END_TAG The L<START_TAG|Template::Manual::Config#START_TAG_END_TAG> and L<END_TAG|Template::Manual::Config#START_TAG_END_TAG> options are used to specify character sequences or regular expressions that mark the start and end of a template directive. my $parser = Template::Parser->new({ START_TAG => quotemeta('<+'), END_TAG => quotemeta('+>'), }); =head2 TAG_STYLE The L<TAG_STYLE|Template::Manual::Config#TAG_STYLE> option can be used to set both L<START_TAG> and L<END_TAG> according to pre-defined tag styles. my $parser = Template::Parser->new({ TAG_STYLE => 'star', # [* ... *] }); =head2 PRE_CHOMP, POST_CHOMP The L<PRE_CHOMP|Template::Manual::Config#PRE_CHOMP_POST_CHOMP> and L<POST_CHOMP|Template::Manual::Config#PRE_CHOMP_POST_CHOMP> can be set to remove any whitespace before or after a directive tag, respectively. my $parser = Template::Parser-E<gt>new({ PRE_CHOMP => 1, POST_CHOMP => 1, }); =head2 INTERPOLATE The L<INTERPOLATE|Template::Manual::Config#INTERPOLATE> flag can be set to allow variables to be embedded in plain text blocks. my $parser = Template::Parser->new({ INTERPOLATE => 1, }); Variables should be prefixed by a C<$> to identify them, using curly braces to explicitly scope the variable name where necessary. Hello ${name}, The day today is ${day.today}. =head2 ANYCASE The L<ANYCASE|Template::Manual::Config#ANYCASE> option can be set to allow directive keywords to be specified in any case. # with ANYCASE set to 1 [% INCLUDE foobar %] # OK [% include foobar %] # OK [% include = 10 %] # ERROR, 'include' is a reserved word =head2 GRAMMAR The L<GRAMMAR|Template::Manual::Config#GRAMMAR> configuration item can be used to specify an alternate grammar for the parser. This allows a modified or entirely new template language to be constructed and used by the Template Toolkit. use MyOrg::Template::Grammar; my $parser = Template::Parser->new({ GRAMMAR = MyOrg::Template::Grammar->new(); }); By default, an instance of the default L<Template::Grammar> will be created and used automatically if a C<GRAMMAR> item isn't specified. =head2 DEBUG The L<DEBUG|Template::Manual::Config#DEBUG> option can be used to enable various debugging features of the C<Template::Parser> module. use Template::Constants qw( :debug ); my $template = Template->new({ DEBUG => DEBUG_PARSER | DEBUG_DIRS, }); =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The main parsing loop of the C<Template::Parser> module was derived from a standalone parser generated by version 0.16 of the C<Parse::Yapp> module. The following copyright notice appears in the C<Parse::Yapp> documentation. The Parse::Yapp module and its related modules and shell scripts are copyright (c) 1998 Francois Desarmenien, France. All rights reserved. You may use and distribute them under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =head1 SEE ALSO L<Template>, L<Template::Grammar>, L<Template::Directive> 5.32/Template/Plugins.pm 0000444 00000033407 15125513451 0010674 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugins # # DESCRIPTION # Plugin provider which handles the loading of plugin modules and # instantiation of plugin objects. # # AUTHORS # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugins; use strict; use warnings; use base 'Template::Base'; use Template::Constants; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $PLUGIN_BASE = 'Template::Plugin'; our $STD_PLUGINS = { 'assert' => 'Template::Plugin::Assert', 'cgi' => 'Template::Plugin::CGI', 'datafile' => 'Template::Plugin::Datafile', 'date' => 'Template::Plugin::Date', 'debug' => 'Template::Plugin::Debug', 'directory' => 'Template::Plugin::Directory', 'dbi' => 'Template::Plugin::DBI', 'dumper' => 'Template::Plugin::Dumper', 'file' => 'Template::Plugin::File', 'format' => 'Template::Plugin::Format', 'html' => 'Template::Plugin::HTML', 'image' => 'Template::Plugin::Image', 'iterator' => 'Template::Plugin::Iterator', 'latex' => 'Template::Plugin::Latex', 'pod' => 'Template::Plugin::Pod', 'scalar' => 'Template::Plugin::Scalar', 'table' => 'Template::Plugin::Table', 'url' => 'Template::Plugin::URL', 'view' => 'Template::Plugin::View', 'wrap' => 'Template::Plugin::Wrap', 'xml' => 'Template::Plugin::XML', 'xmlstyle' => 'Template::Plugin::XML::Style', }; #======================================================================== # -- PUBLIC METHODS -- #======================================================================== #------------------------------------------------------------------------ # fetch($name, \@args, $context) # # General purpose method for requesting instantiation of a plugin # object. The name of the plugin is passed as the first parameter. # The internal FACTORY lookup table is consulted to retrieve the # appropriate factory object or class name. If undefined, the _load() # method is called to attempt to load the module and return a factory # class/object which is then cached for subsequent use. A reference # to the calling context should be passed as the third parameter. # This is passed to the _load() class method. The new() method is # then called against the factory class name or prototype object to # instantiate a new plugin object, passing any arguments specified by # list reference as the second parameter. e.g. where $factory is the # class name 'MyClass', the new() method is called as a class method, # $factory->new(...), equivalent to MyClass->new(...) . Where # $factory is a prototype object, the new() method is called as an # object method, $myobject->new(...). This latter approach allows # plugins to act as Singletons, cache shared data, etc. # # Returns a reference to a plugin, (undef, STATUS_DECLINE) to decline # the request or ($error, STATUS_ERROR) on error. #------------------------------------------------------------------------ sub fetch { my ($self, $name, $args, $context) = @_; my ($factory, $plugin, $error); $self->debug("fetch($name, ", defined $args ? ('[ ', join(', ', @$args), ' ]') : '<no args>', ', ', defined $context ? $context : '<no context>', ')') if $self->{ DEBUG }; # NOTE: # the $context ref gets passed as the first parameter to all regular # plugins, but not to those loaded via LOAD_PERL; to hack around # this until we have a better implementation, we pass the $args # reference to _load() and let it unshift the first args in the # LOAD_PERL case $args ||= [ ]; unshift @$args, $context; $factory = $self->{ FACTORY }->{ $name } ||= do { ($factory, $error) = $self->_load($name, $context); return ($factory, $error) if $error; ## RETURN $factory; }; # call the new() method on the factory object or class name eval { if (ref $factory eq 'CODE') { defined( $plugin = &$factory(@$args) ) || die "$name plugin failed\n"; } else { defined( $plugin = $factory->new(@$args) ) || die "$name plugin failed: ", $factory->error(), "\n"; } }; if ($error = $@) { # chomp $error; return $self->{ TOLERANT } ? (undef, Template::Constants::STATUS_DECLINED) : ($error, Template::Constants::STATUS_ERROR); } return $plugin; } #======================================================================== # -- PRIVATE METHODS -- #======================================================================== #------------------------------------------------------------------------ # _init(\%config) # # Private initialisation method. #------------------------------------------------------------------------ sub _init { my ($self, $params) = @_; my ($pbase, $plugins, $factory) = @$params{ qw( PLUGIN_BASE PLUGINS PLUGIN_FACTORY ) }; $plugins ||= { }; # update PLUGIN_BASE to an array ref if necessary $pbase = [ ] unless defined $pbase; $pbase = [ $pbase ] unless ref($pbase) eq 'ARRAY'; # add default plugin base (Template::Plugin) if set push(@$pbase, $PLUGIN_BASE) if $PLUGIN_BASE; $self->{ PLUGIN_BASE } = $pbase; $self->{ PLUGINS } = { %$STD_PLUGINS, %$plugins }; $self->{ TOLERANT } = $params->{ TOLERANT } || 0; $self->{ LOAD_PERL } = $params->{ LOAD_PERL } || 0; $self->{ FACTORY } = $factory || { }; $self->{ DEBUG } = ( $params->{ DEBUG } || 0 ) & Template::Constants::DEBUG_PLUGINS; return $self; } #------------------------------------------------------------------------ # _load($name, $context) # # Private method which attempts to load a plugin module and determine the # correct factory name or object by calling the load() class method in # the loaded module. #------------------------------------------------------------------------ sub _load { my ($self, $name, $context) = @_; my ($factory, $module, $base, $pkg, $file, $ok, $error); if ($module = $self->{ PLUGINS }->{ $name } || $self->{ PLUGINS }->{ lc $name }) { # plugin module name is explicitly stated in PLUGIN_NAME $pkg = $module; ($file = $module) =~ s|::|/|g; $file =~ s|::|/|g; $self->debug("loading $module.pm (PLUGIN_NAME)") if $self->{ DEBUG }; $ok = eval { require "$file.pm" }; $error = $@; } else { # try each of the PLUGIN_BASE values to build module name ($module = $name) =~ s/\./::/g; foreach $base (@{ $self->{ PLUGIN_BASE } }) { $pkg = $base . '::' . $module; ($file = $pkg) =~ s|::|/|g; $self->debug("loading $file.pm (PLUGIN_BASE)") if $self->{ DEBUG }; $ok = eval { require "$file.pm" }; last unless $@; $error .= "$@\n" unless ($@ =~ /^Can\'t locate $file\.pm/); } } if ($ok) { $self->debug("calling $pkg->load()") if $self->{ DEBUG }; $factory = eval { $pkg->load($context) }; $error = ''; if ($@ || ! $factory) { $error = $@ || 'load() returned a false value'; } } elsif ($self->{ LOAD_PERL }) { # fallback - is it a regular Perl module? ($file = $module) =~ s|::|/|g; eval { require "$file.pm" }; if ($@) { $error = $@; } else { # this is a regular Perl module so the new() constructor # isn't expecting a $context reference as the first argument; # so we construct a closure which removes it before calling # $module->new(@_); $factory = sub { shift; $module->new(@_); }; $error = ''; } } if ($factory) { $self->debug("$name => $factory") if $self->{ DEBUG }; return $factory; } elsif ($error) { return $self->{ TOLERANT } ? (undef, Template::Constants::STATUS_DECLINED) : ($error, Template::Constants::STATUS_ERROR); } else { return (undef, Template::Constants::STATUS_DECLINED); } } 1; __END__ =head1 NAME Template::Plugins - Plugin provider module =head1 SYNOPSIS use Template::Plugins; $plugin_provider = Template::Plugins->new(\%options); ($plugin, $error) = $plugin_provider->fetch($name, @args); =head1 DESCRIPTION The C<Template::Plugins> module defines a provider class which can be used to load and instantiate Template Toolkit plugin modules. =head1 METHODS =head2 new(\%params) Constructor method which instantiates and returns a reference to a C<Template::Plugins> object. A reference to a hash array of configuration items may be passed as a parameter. These are described below. Note that the L<Template> front-end module creates a C<Template::Plugins> provider, passing all configuration items. Thus, the examples shown below in the form: $plugprov = Template::Plugins->new({ PLUGIN_BASE => 'MyTemplate::Plugin', LOAD_PERL => 1, ... }); can also be used via the L<Template> module as: $ttengine = Template->new({ PLUGIN_BASE => 'MyTemplate::Plugin', LOAD_PERL => 1, ... }); as well as the more explicit form of: $plugprov = Template::Plugins->new({ PLUGIN_BASE => 'MyTemplate::Plugin', LOAD_PERL => 1, ... }); $ttengine = Template->new({ LOAD_PLUGINS => [ $plugprov ], }); =head2 fetch($name, @args) Called to request that a plugin of a given name be provided. The relevant module is first loaded (if necessary) and the L<load()|Template::Plugin#load()> class method called to return the factory class name (usually the same package name) or a factory object (a prototype). The L<new()|Template::Plugin#new()> method is then called as a class or object method against the factory, passing all remaining parameters. Returns a reference to a new plugin object or C<($error, STATUS_ERROR)> on error. May also return C<(undef, STATUS_DECLINED)> to decline to serve the request. If C<TOLERANT> is set then all errors will be returned as declines. =head1 CONFIGURATION OPTIONS The following list summarises the configuration options that can be provided to the C<Template::Plugins> L<new()> constructor. Please consult L<Template::Manual::Config> for further details and examples of each configuration option in use. =head2 PLUGINS The L<PLUGINS|Template::Manual::Config#PLUGINS> option can be used to provide a reference to a hash array that maps plugin names to Perl module names. my $plugins = Template::Plugins->new({ PLUGINS => { cgi => 'MyOrg::Template::Plugin::CGI', foo => 'MyOrg::Template::Plugin::Foo', bar => 'MyOrg::Template::Plugin::Bar', }, }); =head2 PLUGIN_BASE If a plugin is not defined in the L<PLUGINS|Template::Manual::Config#PLUGINS> hash then the L<PLUGIN_BASE|Template::Manual::Config#PLUGIN_BASE> is used to attempt to construct a correct Perl module name which can be successfully loaded. # single value PLUGIN_BASE my $plugins = Template::Plugins->new({ PLUGIN_BASE => 'MyOrg::Template::Plugin', }); # multiple value PLUGIN_BASE my $plugins = Template::Plugins->new({ PLUGIN_BASE => [ 'MyOrg::Template::Plugin', 'YourOrg::Template::Plugin' ], }); =head2 LOAD_PERL The L<LOAD_PERL|Template::Manual::Config#LOAD_PERL> option can be set to allow you to load regular Perl modules (i.e. those that don't reside in the C<Template::Plugin> or another user-defined namespace) as plugins. If a plugin cannot be loaded using the L<PLUGINS|Template::Manual::Config#PLUGINS> or L<PLUGIN_BASE|Template::Manual::Config#PLUGIN_BASE> approaches then, if the L<LOAD_PERL|Template::Manual::Config#LOAD_PERL> is set, the provider will make a final attempt to load the module without prepending any prefix to the module path. Unlike regular plugins, modules loaded using L<LOAD_PERL|Template::Manual::Config#LOAD_PERL> do not receive a L<Template::Context> reference as the first argument to the C<new()> constructor method. =head2 TOLERANT The L<TOLERANT|Template::Manual::Config#TOLERANT> flag can be set to indicate that the C<Template::Plugins> module should ignore any errors encountered while loading a plugin and instead return C<STATUS_DECLINED>. =head2 DEBUG The L<DEBUG|Template::Manual::Config#DEBUG> option can be used to enable debugging messages for the C<Template::Plugins> module by setting it to include the C<DEBUG_PLUGINS> value. use Template::Constants qw( :debug ); my $template = Template->new({ DEBUG => DEBUG_FILTERS | DEBUG_PLUGINS, }); =head1 TEMPLATE TOOLKIT PLUGINS Please see L<Template::Manual::Plugins> For a complete list of all the plugin modules distributed with the Template Toolkit. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Manual::Plugins>, L<Template::Plugin>, L<Template::Context>, L<Template>. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Exception.pm 0000444 00000014343 15125513451 0011207 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Exception # # DESCRIPTION # Module implementing a generic exception class used for error handling # in the Template Toolkit. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== package Template::Exception; use strict; use warnings; use constant TYPE => 0; use constant INFO => 1; use constant TEXT => 2; use overload q|""| => "as_string", fallback => 1; our $VERSION = '3.100'; #------------------------------------------------------------------------ # new($type, $info, \$text) # # Constructor method used to instantiate a new Template::Exception # object. The first parameter should contain the exception type. This # can be any arbitrary string of the caller's choice to represent a # specific exception. The second parameter should contain any # information (i.e. error message or data reference) relevant to the # specific exception event. The third optional parameter may be a # reference to a scalar containing output text from the template # block up to the point where the exception was thrown. #------------------------------------------------------------------------ sub new { my ($class, $type, $info, $textref) = @_; bless [ $type, $info, $textref ], $class; } #------------------------------------------------------------------------ # type() # info() # type_info() # # Accessor methods to return the internal TYPE and INFO fields. #------------------------------------------------------------------------ sub type { $_[0]->[ TYPE ]; } sub info { $_[0]->[ INFO ]; } sub type_info { my $self = shift; @$self[ TYPE, INFO ]; } #------------------------------------------------------------------------ # text() # text(\$pretext) # # Method to return the text referenced by the TEXT member. A text # reference may be passed as a parameter to supercede the existing # member. The existing text is added to the *end* of the new text # before being stored. This facility is provided for template blocks # to gracefully de-nest when an exception occurs and allows them to # reconstruct their output in the correct order. #------------------------------------------------------------------------ sub text { my ($self, $newtextref) = @_; my $textref = $self->[ TEXT ]; if ($newtextref) { $$newtextref .= $$textref if $textref && $textref ne $newtextref; $self->[ TEXT ] = $newtextref; return ''; } elsif ($textref) { return $$textref; } else { return ''; } } #------------------------------------------------------------------------ # as_string() # # Accessor method to return a string indicating the exception type and # information. #------------------------------------------------------------------------ sub as_string { my $self = shift; return $self->[ TYPE ] . ' error - ' . $self->[ INFO ]; } #------------------------------------------------------------------------ # select_handler(@types) # # Selects the most appropriate handler for the exception TYPE, from # the list of types passed in as parameters. The method returns the # item which is an exact match for TYPE or the closest, more # generic handler (e.g. foo being more generic than foo.bar, etc.) #------------------------------------------------------------------------ sub select_handler { my ($self, @options) = @_; my $type = $self->[ TYPE ]; my %hlut; @hlut{ @options } = (1) x @options; while ($type) { return $type if $hlut{ $type }; # strip .element from the end of the exception type to find a # more generic handler $type =~ s/\.?[^\.]*$//; } return undef; } 1; __END__ =head1 NAME Template::Exception - Exception handling class module =head1 SYNOPSIS use Template::Exception; my $exception = Template::Exception->new($type, $info); $type = $exception->type; $info = $exception->info; ($type, $info) = $exception->type_info; print $exception->as_string(); $handler = $exception->select_handler(\@candidates); =head1 DESCRIPTION The C<Template::Exception> module defines an object class for representing exceptions within the template processing life cycle. Exceptions can be raised by modules within the Template Toolkit, or can be generated and returned by user code bound to template variables. Exceptions can be raised in a template using the C<THROW> directive, [% THROW user.login 'no user id: please login' %] or by calling the L<throw()|Template::Context#throw()> method on the current L<Template::Context> object, $context->throw('user.passwd', 'Incorrect Password'); $context->throw('Incorrect Password'); # type 'undef' or from Perl code by calling C<die()> with a C<Template::Exception> object, die (Template::Exception->new('user.denied', 'Invalid User ID')); or by simply calling C<die()> with an error string. This is automagically caught and converted to an exception of 'C<undef>' type (that's the literal string 'C<undef>' rather than Perl's undefined value) which can then be handled in the usual way. die "I'm sorry Dave, I can't do that"; Each exception is defined by its type and a information component (e.g. error message). The type can be any identifying string and may contain dotted components (e.g. 'C<foo>', 'C<foo.bar>', 'C<foo.bar.baz>'). Exception types are considered to be hierarchical such that 'C<foo.bar>' would be a specific type of the more general 'C<foo>' type. =head1 METHODS =head2 type() Returns the exception type. =head2 info() Returns the exception information. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template>, L<Template::Context> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Directive.pm 0000444 00000071460 15125513451 0011172 0 ustar 00 #================================================================= -*-Perl-*- # # Template::Directive # # DESCRIPTION # Factory module for constructing templates from Perl code. # # AUTHOR # Andy Wardley <abw@wardley.org> # # WARNING # Much of this module is hairy, even furry in places. It needs # a lot of tidying up and may even be moved into a different place # altogether. The generator code is often inefficient, particularly in # being very anal about pretty-printing the Perl code all neatly, but # at the moment, that's still high priority for the sake of easier # debugging. # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Directive; use strict; use warnings; use base 'Template::Base'; use Template::Constants; use Template::Exception; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $WHILE_MAX = 1000 unless defined $WHILE_MAX; our $PRETTY = 0 unless defined $PRETTY; our $OUTPUT = '$output .= '; sub _init { my ($self, $config) = @_; $self->{ NAMESPACE } = $config->{ NAMESPACE }; return $self; } sub trace_vars { my $self = shift; return @_ ? ($self->{ TRACE_VARS } = shift) : $self->{ TRACE_VARS }; } sub pad { my ($text, $pad) = @_; $pad = ' ' x ($pad * 4); $text =~ s/^(?!#line)/$pad/gm; $text; } #======================================================================== # FACTORY METHODS # # These methods are called by the parser to construct directive instances. #======================================================================== #------------------------------------------------------------------------ # template($block) #------------------------------------------------------------------------ sub template { my ($self, $block) = @_; $block = pad($block, 2) if $PRETTY; return "sub { return '' }" unless $block =~ /\S/; return <<EOF; sub { my \$context = shift || die "template sub called without context\\n"; my \$stash = \$context->stash; my \$output = ''; my \$_tt_error; eval { BLOCK: { $block } }; if (\$@) { \$_tt_error = \$context->catch(\$@, \\\$output); die \$_tt_error unless \$_tt_error->type eq 'return'; } return \$output; } EOF } #------------------------------------------------------------------------ # anon_block($block) [% BLOCK %] ... [% END %] #------------------------------------------------------------------------ sub anon_block { my ($self, $block) = @_; $block = pad($block, 2) if $PRETTY; return <<EOF; # BLOCK $OUTPUT do { my \$output = ''; my \$_tt_error; eval { BLOCK: { $block } }; if (\$@) { \$_tt_error = \$context->catch(\$@, \\\$output); die \$_tt_error unless \$_tt_error->type eq 'return'; } \$output; }; EOF } #------------------------------------------------------------------------ # block($blocktext) #------------------------------------------------------------------------ sub block { my ($self, $block) = @_; return join("\n", @{ $block || [] }); } #------------------------------------------------------------------------ # textblock($text) #------------------------------------------------------------------------ sub textblock { my ($self, $text) = @_; return "$OUTPUT " . &text($self, $text) . ';'; } #------------------------------------------------------------------------ # text($text) #------------------------------------------------------------------------ sub text { my ( $self, $text ) = @_; return '' if !length $text; if ( $text =~ tr{$@\\}{} ) { $text =~ s/(["\$\@\\])/\\$1/g; $text =~ s/\n/\\n/g; return '"' . $text . '"'; } $text =~ s{'}{\\'}g if index( $text, q{'} ) != -1; return q{'} . $text . q{'}; } #------------------------------------------------------------------------ # quoted(\@items) "foo$bar" #------------------------------------------------------------------------ sub quoted { my ($self, $items) = @_; return '' unless @$items; return ("('' . " . $items->[0] . ')') if scalar @$items == 1; return '(' . join(' . ', @$items) . ')'; # my $r = '(' . join(' . ', @$items) . ' . "")'; # print STDERR "[$r]\n"; # return $r; } #------------------------------------------------------------------------ # ident(\@ident) foo.bar(baz) #------------------------------------------------------------------------ sub ident { my ($self, $ident) = @_; return "''" unless @$ident; my $ns; # Careful! Template::Parser always creates a Template::Directive object # (as of v2.22_1) so $self is usually an object. However, we used to # allow Template::Directive methods to be called as class methods and # Template::Namespace::Constants module takes advantage of this fact # by calling Template::Directive->ident() when it needs to generate an # identifier. This hack guards against Mr Fuckup from coming to town # when that happens. if (ref $self) { # trace variable usage if ($self->{ TRACE_VARS }) { my $root = $self->{ TRACE_VARS }; my $n = 0; my $v; while ($n < @$ident) { $v = $ident->[$n]; for ($v) { s/^'//; s/'$// }; $root = $root->{ $v } ||= { }; $n += 2; } } # does the first element of the identifier have a NAMESPACE # handler defined? if (@$ident > 2 && ($ns = $self->{ NAMESPACE })) { my $key = $ident->[0]; # a faster alternate to $key =~ s/^'(.+)'$/$1/s if ( index( $key, q[']) == 0 ) { substr( $key, 0, 1, '' ); substr( $key, -1, 1, '' ); # remove the last char blindly } if ($ns = $ns->{ $key }) { return $ns->ident($ident); } } } if (scalar @$ident <= 2 && ! $ident->[1]) { $ident = $ident->[0]; } else { $ident = '[' . join(', ', @$ident) . ']'; } return "\$stash->get($ident)"; } #------------------------------------------------------------------------ # identref(\@ident) \foo.bar(baz) #------------------------------------------------------------------------ sub identref { my ($self, $ident) = @_; return "''" unless @$ident; if (scalar @$ident <= 2 && ! $ident->[1]) { $ident = $ident->[0]; } else { $ident = '[' . join(', ', @$ident) . ']'; } return "\$stash->getref($ident)"; } #------------------------------------------------------------------------ # assign(\@ident, $value, $default) foo = bar #------------------------------------------------------------------------ sub assign { my ($self, $var, $val, $default) = @_; if (ref $var) { if (scalar @$var == 2 && ! $var->[1]) { $var = $var->[0]; } else { $var = '[' . join(', ', @$var) . ']'; } } $val .= ', 1' if $default; return "\$stash->set($var, $val)"; } #------------------------------------------------------------------------ # args(\@args) foo, bar, baz = qux #------------------------------------------------------------------------ sub args { my ($self, $args) = @_; my $hash = shift @$args; push(@$args, '{ ' . join(', ', @$hash) . ' }') if @$hash; return '0' unless @$args; return '[ ' . join(', ', @$args) . ' ]'; } #------------------------------------------------------------------------ # filenames(\@names) #------------------------------------------------------------------------ sub filenames { my ($self, $names) = @_; if (@$names > 1) { $names = '[ ' . join(', ', @$names) . ' ]'; } else { $names = shift @$names; } return $names; } #------------------------------------------------------------------------ # get($expr) [% foo %] #------------------------------------------------------------------------ sub get { my ($self, $expr) = @_; return "$OUTPUT $expr;"; } #------------------------------------------------------------------------ # call($expr) [% CALL bar %] #------------------------------------------------------------------------ sub call { my ($self, $expr) = @_; $expr .= ';'; return $expr; } #------------------------------------------------------------------------ # set(\@setlist) [% foo = bar, baz = qux %] #------------------------------------------------------------------------ sub set { my ($self, $setlist) = @_; my $output; while (my ($var, $val) = splice(@$setlist, 0, 2)) { $output .= &assign($self, $var, $val) . ";\n"; } chomp $output; return $output; } #------------------------------------------------------------------------ # default(\@setlist) [% DEFAULT foo = bar, baz = qux %] #------------------------------------------------------------------------ sub default { my ($self, $setlist) = @_; my $output; while (my ($var, $val) = splice(@$setlist, 0, 2)) { $output .= &assign($self, $var, $val, 1) . ";\n"; } chomp $output; return $output; } #------------------------------------------------------------------------ # insert(\@nameargs) [% INSERT file %] # # => [ [ $file, ... ], \@args ] #------------------------------------------------------------------------ sub insert { my ($self, $nameargs) = @_; my ($file, $args) = @$nameargs; $file = $self->filenames($file); return "$OUTPUT \$context->insert($file);"; } #------------------------------------------------------------------------ # include(\@nameargs) [% INCLUDE template foo = bar %] # # => [ [ $file, ... ], \@args ] #------------------------------------------------------------------------ sub include { my ($self, $nameargs) = @_; my ($file, $args) = @$nameargs; my $hash = shift @$args; $file = $self->filenames($file); $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; return "$OUTPUT \$context->include($file);"; } #------------------------------------------------------------------------ # process(\@nameargs) [% PROCESS template foo = bar %] # # => [ [ $file, ... ], \@args ] #------------------------------------------------------------------------ sub process { my ($self, $nameargs) = @_; my ($file, $args) = @$nameargs; my $hash = shift @$args; $file = $self->filenames($file); $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; return "$OUTPUT \$context->process($file);"; } #------------------------------------------------------------------------ # if($expr, $block, $else) [% IF foo < bar %] # ... # [% ELSE %] # ... # [% END %] #------------------------------------------------------------------------ sub if { my ($self, $expr, $block, $else) = @_; my @else = $else ? @$else : (); $else = pop @else; $block = pad($block, 1) if $PRETTY; my $output = "if ($expr) {\n$block\n}\n"; foreach my $elsif (@else) { ($expr, $block) = @$elsif; $block = pad($block, 1) if $PRETTY; $output .= "elsif ($expr) {\n$block\n}\n"; } if (defined $else) { $else = pad($else, 1) if $PRETTY; $output .= "else {\n$else\n}\n"; } return $output; } #------------------------------------------------------------------------ # foreach($target, $list, $args, $block) [% FOREACH x = [ foo bar ] %] # ... # [% END %] #------------------------------------------------------------------------ sub foreach { my ($self, $target, $list, $args, $block, $label) = @_; $args = shift @$args; $args = @$args ? ', { ' . join(', ', @$args) . ' }' : ''; $label ||= 'LOOP'; my ($loop_save, $loop_set, $loop_restore, $setiter); if ($target) { $loop_save = 'eval { $_tt_oldloop = ' . &ident($self, ["'loop'"]) . ' }'; $loop_set = "\$stash->{'$target'} = \$_tt_value"; $loop_restore = "\$stash->set('loop', \$_tt_oldloop)"; } else { $loop_save = '$stash = $context->localise()'; # $loop_set = "\$stash->set('import', \$_tt_value) " # . "if ref \$value eq 'HASH'"; $loop_set = "\$stash->get(['import', [\$_tt_value]]) " . "if ref \$_tt_value eq 'HASH'"; $loop_restore = '$stash = $context->delocalise()'; } $block = pad($block, 3) if $PRETTY; return <<EOF; # FOREACH do { my (\$_tt_value, \$_tt_error, \$_tt_oldloop); my \$_tt_list = $list; unless (UNIVERSAL::isa(\$_tt_list, 'Template::Iterator')) { \$_tt_list = Template::Config->iterator(\$_tt_list) || die \$Template::Config::ERROR, "\\n"; } (\$_tt_value, \$_tt_error) = \$_tt_list->get_first(); $loop_save; \$stash->set('loop', \$_tt_list); eval { $label: while (! \$_tt_error) { $loop_set; $block; (\$_tt_value, \$_tt_error) = \$_tt_list->get_next(); } }; $loop_restore; die \$@ if \$@; \$_tt_error = 0 if \$_tt_error && \$_tt_error eq Template::Constants::STATUS_DONE; die \$_tt_error if \$_tt_error; }; EOF } #------------------------------------------------------------------------ # next() [% NEXT %] # # Next iteration of a FOREACH loop (experimental) #------------------------------------------------------------------------ sub next { my ($self, $label) = @_; $label ||= 'LOOP'; return <<EOF; (\$_tt_value, \$_tt_error) = \$_tt_list->get_next(); next $label; EOF } #------------------------------------------------------------------------ # wrapper(\@nameargs, $block) [% WRAPPER template foo = bar %] # # => [ [$file,...], \@args ] #------------------------------------------------------------------------ sub wrapper { my ($self, $nameargs, $block) = @_; my ($file, $args) = @$nameargs; my $hash = shift @$args; local $" = ', '; # print STDERR "wrapper([@$file], { @$hash })\n"; return $self->multi_wrapper($file, $hash, $block) if @$file > 1; $file = shift @$file; $block = pad($block, 1) if $PRETTY; push(@$hash, "'content'", '$output'); $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; return <<EOF; # WRAPPER $OUTPUT do { my \$output = ''; $block \$context->include($file); }; EOF } sub multi_wrapper { my ($self, $file, $hash, $block) = @_; $block = pad($block, 1) if $PRETTY; push(@$hash, "'content'", '$output'); $hash = @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; $file = join(', ', reverse @$file); # print STDERR "multi wrapper: $file\n"; return <<EOF; # WRAPPER $OUTPUT do { my \$output = ''; $block foreach ($file) { \$output = \$context->include(\$_$hash); } \$output; }; EOF } #------------------------------------------------------------------------ # while($expr, $block) [% WHILE x < 10 %] # ... # [% END %] #------------------------------------------------------------------------ sub while { my ($self, $expr, $block, $label) = @_; $block = pad($block, 2) if $PRETTY; $label ||= 'LOOP'; return <<EOF; # WHILE do { my \$_tt_failsafe = $WHILE_MAX; $label: while (($expr) && --\$_tt_failsafe >= 0) { $block } die "WHILE loop terminated (> $WHILE_MAX iterations)\\n" if \$_tt_failsafe < 0; }; EOF } #------------------------------------------------------------------------ # switch($expr, \@case) [% SWITCH %] # [% CASE foo %] # ... # [% END %] #------------------------------------------------------------------------ sub switch { my ($self, $expr, $case) = @_; my @case = @$case; my ($match, $block, $default); my $caseblock = ''; $default = pop @case; foreach $case (@case) { $match = $case->[0]; $block = $case->[1]; $block = pad($block, 1) if $PRETTY; $caseblock .= <<EOF; \$_tt_match = $match; \$_tt_match = [ \$_tt_match ] unless ref \$_tt_match eq 'ARRAY'; if (grep(/^\\Q\$_tt_result\\E\$/, \@\$_tt_match)) { $block last SWITCH; } EOF } $caseblock .= $default if defined $default; $caseblock = pad($caseblock, 2) if $PRETTY; return <<EOF; # SWITCH do { my \$_tt_result = $expr; my \$_tt_match; SWITCH: { $caseblock } }; EOF } #------------------------------------------------------------------------ # try($block, \@catch) [% TRY %] # ... # [% CATCH %] # ... # [% END %] #------------------------------------------------------------------------ sub try { my ($self, $block, $catch) = @_; my @catch = @$catch; my ($match, $mblock, $default, $final, $n); my $catchblock = ''; my $handlers = []; $block = pad($block, 2) if $PRETTY; $final = pop @catch; $final = "# FINAL\n" . ($final ? "$final\n" : '') . 'die $_tt_error if $_tt_error;' . "\n" . '$output;'; $final = pad($final, 1) if $PRETTY; $n = 0; foreach $catch (@catch) { $match = $catch->[0] || do { $default ||= $catch->[1]; next; }; $mblock = $catch->[1]; $mblock = pad($mblock, 1) if $PRETTY; push(@$handlers, "'$match'"); $catchblock .= $n++ ? "elsif (\$_tt_handler eq '$match') {\n$mblock\n}\n" : "if (\$_tt_handler eq '$match') {\n$mblock\n}\n"; } $catchblock .= "\$_tt_error = 0;"; $catchblock = pad($catchblock, 3) if $PRETTY; if ($default) { $default = pad($default, 1) if $PRETTY; $default = "else {\n # DEFAULT\n$default\n \$_tt_error = '';\n}"; } else { $default = '# NO DEFAULT'; } $default = pad($default, 2) if $PRETTY; $handlers = join(', ', @$handlers); return <<EOF; # TRY $OUTPUT do { my \$output = ''; my (\$_tt_error, \$_tt_handler); eval { $block }; if (\$@) { \$_tt_error = \$context->catch(\$@, \\\$output); die \$_tt_error if \$_tt_error->type =~ /^(return|stop)\$/; \$stash->set('error', \$_tt_error); \$stash->set('e', \$_tt_error); if (defined (\$_tt_handler = \$_tt_error->select_handler($handlers))) { $catchblock } $default } $final }; EOF } #------------------------------------------------------------------------ # throw(\@nameargs) [% THROW foo "bar error" %] # # => [ [$type], \@args ] #------------------------------------------------------------------------ sub throw { my ($self, $nameargs) = @_; my ($type, $args) = @$nameargs; my $hash = shift(@$args); my $info = shift(@$args); $type = shift @$type; # uses same parser production as INCLUDE # etc., which allow multiple names # e.g. INCLUDE foo+bar+baz if (! $info) { $args = "$type, undef"; } elsif (@$hash || @$args) { local $" = ', '; my $i = 0; $args = "$type, { args => [ " . join(', ', $info, @$args) . ' ], ' . join(', ', (map { "'" . $i++ . "' => $_" } ($info, @$args)), @$hash) . ' }'; } else { $args = "$type, $info"; } return "\$context->throw($args, \\\$output);"; } #------------------------------------------------------------------------ # clear() [% CLEAR %] # # NOTE: this is redundant, being hard-coded (for now) into Parser.yp #------------------------------------------------------------------------ sub clear { return "\$output = '';"; } #------------------------------------------------------------------------ # break() [% BREAK %] # # NOTE: this is redundant, being hard-coded (for now) into Parser.yp #------------------------------------------------------------------------ sub OLD_break { return 'last LOOP;'; } #------------------------------------------------------------------------ # return() [% RETURN %] #------------------------------------------------------------------------ sub return { return "\$context->throw('return', '', \\\$output);"; } #------------------------------------------------------------------------ # stop() [% STOP %] #------------------------------------------------------------------------ sub stop { return "\$context->throw('stop', '', \\\$output);"; } #------------------------------------------------------------------------ # use(\@lnameargs) [% USE alias = plugin(args) %] # # => [ [$file, ...], \@args, $alias ] #------------------------------------------------------------------------ sub use { my ($self, $lnameargs) = @_; my ($file, $args, $alias) = @$lnameargs; $file = shift @$file; # same production rule as INCLUDE $alias ||= $file; $args = &args($self, $args); $file .= ", $args" if $args; # my $set = &assign($self, $alias, '$plugin'); return "# USE\n" . "\$stash->set($alias,\n" . " \$context->plugin($file));"; } #------------------------------------------------------------------------ # view(\@nameargs, $block) [% VIEW name args %] # # => [ [$file, ... ], \@args ] #------------------------------------------------------------------------ sub view { my ($self, $nameargs, $block, $defblocks) = @_; my ($name, $args) = @$nameargs; my $hash = shift @$args; $name = shift @$name; # same production rule as INCLUDE $block = pad($block, 1) if $PRETTY; if (%$defblocks) { $defblocks = join(",\n", map { "'$_' => $defblocks->{ $_ }" } keys %$defblocks); $defblocks = pad($defblocks, 1) if $PRETTY; $defblocks = "{\n$defblocks\n}"; push(@$hash, "'blocks'", $defblocks); } $hash = @$hash ? '{ ' . join(', ', @$hash) . ' }' : ''; return <<EOF; # VIEW do { my \$output = ''; my \$_tt_oldv = \$stash->get('view'); my \$_tt_view = \$context->view($hash); \$stash->set($name, \$_tt_view); \$stash->set('view', \$_tt_view); $block \$stash->set('view', \$_tt_oldv); \$_tt_view->seal(); # \$output; # not used - commented out to avoid warning }; EOF } #------------------------------------------------------------------------ # perl($block) #------------------------------------------------------------------------ sub perl { my ($self, $block) = @_; $block = pad($block, 1) if $PRETTY; return <<EOF; # PERL \$context->throw('perl', 'EVAL_PERL not set') unless \$context->eval_perl(); $OUTPUT do { my \$output = "package Template::Perl;\\n"; $block local(\$Template::Perl::context) = \$context; local(\$Template::Perl::stash) = \$stash; my \$_tt_result = ''; tie *Template::Perl::PERLOUT, 'Template::TieString', \\\$_tt_result; my \$_tt_save_stdout = select *Template::Perl::PERLOUT; eval \$output; select \$_tt_save_stdout; \$context->throw(\$@) if \$@; \$_tt_result; }; EOF } #------------------------------------------------------------------------ # no_perl() #------------------------------------------------------------------------ sub no_perl { my $self = shift; return "\$context->throw('perl', 'EVAL_PERL not set');"; } #------------------------------------------------------------------------ # rawperl($block) # # NOTE: perhaps test context EVAL_PERL switch at compile time rather than # runtime? #------------------------------------------------------------------------ sub rawperl { my ($self, $block, $line) = @_; for ($block) { s/^\n+//; s/\n+$//; } $block = pad($block, 1) if $PRETTY; $line = $line ? " (starting line $line)" : ''; return <<EOF; # RAWPERL #line 1 "RAWPERL block$line" $block EOF } #------------------------------------------------------------------------ # filter() #------------------------------------------------------------------------ sub filter { my ($self, $lnameargs, $block) = @_; my ($name, $args, $alias) = @$lnameargs; $name = shift @$name; $args = &args($self, $args); $args = $args ? "$args, $alias" : ", undef, $alias" if $alias; $name .= ", $args" if $args; $block = pad($block, 1) if $PRETTY; return <<EOF; # FILTER $OUTPUT do { my \$output = ''; my \$_tt_filter = \$context->filter($name) || \$context->throw(\$context->error); $block &\$_tt_filter(\$output); }; EOF } #------------------------------------------------------------------------ # capture($name, $block) #------------------------------------------------------------------------ sub capture { my ($self, $name, $block) = @_; if (ref $name) { if (scalar @$name == 2 && ! $name->[1]) { $name = $name->[0]; } else { $name = '[' . join(', ', @$name) . ']'; } } $block = pad($block, 1) if $PRETTY; return <<EOF; # CAPTURE \$stash->set($name, do { my \$output = ''; $block \$output; }); EOF } #------------------------------------------------------------------------ # macro($name, $block, \@args) #------------------------------------------------------------------------ sub macro { my ($self, $ident, $block, $args) = @_; $block = pad($block, 2) if $PRETTY; if ($args) { my $nargs = scalar @$args; $args = join(', ', map { "'$_'" } @$args); $args = $nargs > 1 ? "\@_tt_args{ $args } = splice(\@_, 0, $nargs)" : "\$_tt_args{ $args } = shift"; return <<EOF; # MACRO \$stash->set('$ident', sub { my \$output = ''; my (%_tt_args, \$_tt_params); $args; \$_tt_params = shift; \$_tt_params = { } unless ref(\$_tt_params) eq 'HASH'; \$_tt_params = { \%_tt_args, %\$_tt_params }; my \$stash = \$context->localise(\$_tt_params); eval { $block }; \$stash = \$context->delocalise(); die \$@ if \$@; return \$output; }); EOF } else { return <<EOF; # MACRO \$stash->set('$ident', sub { my \$_tt_params = \$_[0] if ref(\$_[0]) eq 'HASH'; my \$output = ''; my \$stash = \$context->localise(\$_tt_params); eval { $block }; \$stash = \$context->delocalise(); die \$@ if \$@; return \$output; }); EOF } } sub debug { my ($self, $nameargs) = @_; my ($file, $args) = @$nameargs; my $hash = shift @$args; $args = join(', ', @$file, @$args); $args .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; return "$OUTPUT \$context->debugging($args); ## DEBUG ##"; } 1; __END__ =head1 NAME Template::Directive - Perl code generator for template directives =head1 SYNOPSIS # no user serviceable parts inside =head1 DESCRIPTION The C<Template::Directive> module defines a number of methods that generate Perl code for the runtime representation of the various Template Toolkit directives. It is used internally by the L<Template::Parser> module. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Parser> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Tutorial/Web.pod 0000444 00000064422 15125513451 0011742 0 ustar 00 #============================================================= -*-perl-*- # # Template::Tutorial::Web # # DESCRIPTION # Tutorial on generating web content with the Template Toolkit # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2008 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Tutorial::Web - Generating Web Content Using the Template Toolkit =head1 Overview This tutorial document provides a introduction to the Template Toolkit and demonstrates some of the typical ways it may be used for generating web content. It covers the generation of static pages from templates using the L<tpage|Template::Tools::tpage> and L<ttree|Template::Tools::ttree> scripts and then goes on to show dynamic content generation using CGI scripts and Apache/mod_perl handlers. Various features of the Template Toolkit are introduced and described briefly and explained by use of example. For further information, see L<Template>, L<Template::Manual> and the various sections within it. e.g perldoc Template # Template.pm module usage perldoc Template::Manual # index to manual perldoc Template::Manual::Config # e.g. configuration options The documentation is also available in HTML format to read online, or download from the Template Toolkit web site: http://template-toolkit.org/docs/ =head1 Introduction The Template Toolkit is a set of Perl modules which collectively implement a template processing system. A template is a text document with special markup tags embedded in it. By default, the Template Toolkit uses 'C<[%>' and 'C<%]>' to denote the start and end of a tag. Here's an example: [% INCLUDE header %] People of [% planet %], your attention please. This is [% captain %] of the Galactic Hyperspace Planning Council. As you will no doubt be aware, the plans for development of the outlying regions of the Galaxy require the building of a hyperspatial express route through your star system, and regrettably your planet is one of those scheduled for destruction. The process will take slightly less than [% time %]. Thank you. [% INCLUDE footer %] Tags can contain simple I<variables> (like C<planet> and C<captain>) and more complex I<directives> that start with an upper case keyword (like C<INCLUDE>). A directive is an instruction that tells the template processor to perform some action, like processing another template (C<header> and C<footer> in this example) and inserting the output into the current template. In fact, the simple variables we mentioned are actually C<GET> directives, but the C<GET> keyword is optional. People of [% planet %], your attention please. # short form People of [% GET planet %], your attention please. # long form Other directives include C<SET> to set a variable value (the C<SET> keyword is also optional), C<FOREACH> to iterate through a list of values, and C<IF>, C<UNLESS>, C<ELSIF> and C<ELSE> to declare conditional blocks. The Template Toolkit processes all I<text> files equally, regardless of what kind of content they contain. So you can use TT to generate HTML, XML, CSS, Javascript, Perl, RTF, LaTeX, or any other text-based format. In this tutorial, however, we'll be concentrating on generating HTML for web pages. =head1 Generating Static Web Content Here's an example of a template used to generate an HTML document. [% INCLUDE header title = 'This is an HTML example'; pages = [ { url = 'http://foo.org' title = 'The Foo Organisation' } { url = 'http://bar.org' title = 'The Bar Organisation' } ] %] <h1>Some Interesting Links</h1> <ul> [% FOREACH page IN pages %] <li><a href="[% page.url %]">[% page.title %]</a> [% END %] </ul> [% INCLUDE footer %] This example shows how the C<INCLUDE> directive is used to load and process separate 'C<header>' and 'C<footer>' template files, including the output in the current document. These files might look something like this: header: <html> <head> <title>[% title %]</title> </head> <body> footer: <div class="copyright"> © Copyright 2007 Arthur Dent </div> </body> </html> The example also uses the C<FOREACH> directive to iterate through the 'C<pages>' list to build a table of links. In this example, we have defined this list within the template to contain a number of hash references, each containing a 'C<url>' and 'C<title>' member. The C<FOREACH> directive iterates through the list, aliasing 'C<page>' to each item (in this case, hash array references). The C<[% page.url %]> and C<[% page.title %]> directives then access the individual values in the hash arrays and insert them into the document. =head2 Using tpage Having created a template file we can now process it to generate some real output. The quickest and easiest way to do this is to use the L<tpage|Template::Tools::tpage> script. This is provided as part of the Template Toolkit and should be installed in your usual Perl bin directory. Assuming you saved your template file as F<example.html>, you would run the command: $ tpage example.html This will process the template file, sending the output to C<STDOUT> (i.e. whizzing past you on the screen). You may want to redirect the output to a file but be careful not to specify the same name as the template file, or you'll overwrite it. You may want to use one prefix for your templates (e.g. 'C<.tt>') and another (e.g. 'C<.html>') for the output files. $ tpage example.tt > example.html Or you can redirect the output to another directory. e.g. $ tpage templates/example.tt > html/example.html The output generated would look like this: <html> <head> <title>This is an HTML example</title> </head> <body> <h1>Some Interesting Links</h1> <ul> <li><a href="http://foo.org">The Foo Organsiation</a> <li><a href="http://bar.org">The Bar Organsiation</a> </ul> <div class="copyright"> © Copyright 2007 Arthur Dent </div> </body> </html> The F<header> and F<footer> template files have been included (assuming you created them and they're in the current directory) and the link data has been built into an HTML list. =head2 Using ttree The L<tpage|Template::Tools::tpage> script gives you a simple and easy way to process a single template without having to write any Perl code. The L<ttree:Template::Tools::ttree> script, also distributed as part of the Template Toolkit, provides a more flexible way to process a number of template documents in one go. The first time you run the script, it will ask you if it should create a configuration file (F<.ttreerc>) in your home directory. Answer C<y> to have it create the file. The L<ttree:Template::Tools::ttree> documentation describes how you can change the location of this file and also explains the syntax and meaning of the various options in the file. Comments are written to the sample configuration file which should also help. In brief, the configuration file describes the directories in which template files are to be found (C<src>), where the corresponding output should be written to (C<dest>), and any other directories (C<lib>) that may contain template files that you plan to C<INCLUDE> into your source documents. You can also specify processing options (such as C<verbose> and C<recurse>) and provide regular expression to match files that you don't want to process (C<ignore>, C<accept>)> or should be copied instead of being processed as templates (C<copy>). An example F<.ttreerc> file is shown here: $HOME/.ttreerc: verbose recurse # this is where I keep other ttree config files cfg = ~/.ttree src = ~/websrc/src lib = ~/websrc/lib dest = ~/public_html/test ignore = \b(CVS|RCS)\b ignore = ^# You can create many different configuration files and store them in the directory specified in the C<cfg> option, shown above. You then add the C<-f filename> option to C<ttree> to have it read that file. When you run the script, it compares all the files in the C<src> directory (including those in sub-directories if the C<recurse> option is set), with those in the C<dest> directory. If the destination file doesn't exist or has an earlier modification time than the corresponding source file, then the source will be processed with the output written to the destination file. The C<-a> option forces all files to be processed, regardless of modification times. The script I<doesn't> process any of the files in the C<lib> directory, but it does add it to the C<INCLUDE_PATH> for the template processor so that it can locate these files via an C<INCLUDE>, C<PROCESS> or C<WRAPPER> directive. Thus, the C<lib> directory is an excellent place to keep template elements such as header, footers, etc., that aren't complete documents in their own right. You can also specify various Template Toolkit options from the configuration file. Consult the L<ttree|Template::Tools::ttree> documentation and help summary (C<ttree -h>) for full details. e.g. $HOME/.ttreerc: pre_process = config interpolate post_chomp The C<pre_process> option allows you to specify a template file which should be processed before each file. Unsurprisingly, there's also a C<post_process> option to add a template after each file. In the fragment above, we have specified that the C<config> template should be used as a prefix template. We can create this file in the C<lib> directory and use it to define some common variables, including those web page links we defined earlier and might want to re-use in other templates. We could also include an HTML header, title, or menu bar in this file which would then be prepended to each and every template file, but for now we'll keep all that in a separate C<header> file. $lib/config: [% root = '~/abw' home = "$root/index.html" images = "$root/images" email = 'abw@wardley.org' graphics = 1 webpages = [ { url => 'http://foo.org', title => 'The Foo Organsiation' } { url => 'http://bar.org', title => 'The Bar Organsiation' } ] %] Assuming you've created or copied the C<header> and C<footer> files from the earlier example into your C<lib> directory, you can now start to create web pages like the following in your C<src> directory and process them with C<ttree>. $src/newpage.html: [% INCLUDE header title = 'Another Template Toolkit Test Page' %] <a href="[% home %]">Home</a> <a href="mailto:[% email %]">Email</a> [% IF graphics %] <img src="[% images %]/logo.gif" align=right width=60 height=40> [% END %] [% INCLUDE footer %] Here we've shown how pre-defined variables can be used as flags to enable certain feature (e.g. C<graphics>) and to specify common items such as an email address and URL's for the home page, images directory and so on. This approach allows you to define these values once so that they're consistent across all pages and can easily be changed to new values. When you run F<ttree>, you should see output similar to the following (assuming you have the verbose flag set). ttree 2.9 (Template Toolkit version 2.20) Source: /home/abw/websrc/src Destination: /home/abw/public_html/test Include Path: [ /home/abw/websrc/lib ] Ignore: [ \b(CVS|RCS)\b, ^# ] Copy: [ ] Accept: [ * ] + newpage.html The C<+> in front of the C<newpage.html> filename shows that the file was processed, with the output being written to the destination directory. If you run the same command again, you'll see the following line displayed instead showing a C<-> and giving a reason why the file wasn't processed. - newpage.html (not modified) It has detected a C<newpage.html> in the destination directory which is more recent than that in the source directory and so hasn't bothered to waste time re-processing it. To force all files to be processed, use the C<-a> option. You can also specify one or more filenames as command line arguments to C<ttree>: tpage newpage.html This is what the destination page looks like. $dest/newpage.html: <html> <head> <title>Another Template Toolkit Test Page</title> </head> <body> <a href="~/abw/index.html">Home</a> <a href="mailto:abw@wardley.org">Email me</a> <img src="~/abw/images/logo.gif" align=right width=60 height=40> <div class="copyright"> © Copyright 2007 Arthur Dent </div> </body> </html> You can add as many documents as you like to the C<src> directory and C<ttree> will apply the same process to them all. In this way, it is possible to build an entire tree of static content for a web site with a single command. The added benefit is that you can be assured of consistency in links, header style, or whatever else you choose to implement in terms of common templates elements or variables. =head1 Dynamic Content Generation Via CGI Script The L<Template> module provides a simple front-end to the Template Toolkit for use in CGI scripts and Apache/mod_perl handlers. Simply C<use> the L<Template> module, create an object instance with the L<new()> method and then call the L<process()> method on the object, passing the name of the template file as a parameter. The second parameter passed is a reference to a hash array of variables that we want made available to the template: #!/usr/bin/perl use strict; use warnings; use Template; my $file = 'src/greeting.html'; my $vars = { message => "Hello World\n" }; my $template = Template->new(); $template->process($file, $vars) || die "Template process failed: ", $template->error(), "\n"; So that our scripts will work with the same template files as our earlier examples, we'll can add some configuration options to the constructor to tell it about our environment: my $template->new({ # where to find template files INCLUDE_PATH => ['/home/abw/websrc/src', '/home/abw/websrc/lib'], # pre-process lib/config to define any extra values PRE_PROCESS => 'config', }); Note that here we specify the C<config> file as a C<PRE_PROCESS> option. This means that the templates we process can use the same global variables defined earlier for our static pages. We don't have to replicate their definitions in this script. However, we can supply additional data and functionality specific to this script via the hash of variables that we pass to the C<process()> method. These entries in this hash may contain simple text or other values, references to lists, others hashes, sub-routines or objects. The Template Toolkit will automatically apply the correct procedure to access these different types when you use the variables in a template. Here's a more detailed example to look over. Amongst the different template variables we define in C<$vars>, we create a reference to a L<CGI> object and a C<get_user_projects()> sub-routine. #!/usr/bin/perl use strict; use warnings; use Template; use CGI; $| = 1; print "Content-type: text/html\n\n"; my $file = 'userinfo.html'; my $vars = { 'version' => 3.14, 'days' => [ qw( mon tue wed thu fri sat sun ) ], 'worklist' => \&get_user_projects, 'cgi' => CGI->new(), 'me' => { 'id' => 'abw', 'name' => 'Andy Wardley', }, }; sub get_user_projects { my $user = shift; my @projects = ... # do something to retrieve data return \@projects; } my $template = Template->new({ INCLUDE_PATH => '/home/abw/websrc/src:/home/abw/websrc/lib', PRE_PROCESS => 'config', }); $template->process($file, $vars) || die $template->error(); Here's a sample template file that we might create to build the output for this script. $src/userinfo.html: [% INCLUDE header title = 'Template Toolkit CGI Test' %] <a href="mailto:[% email %]">Email [% me.name %]</a> <p>This is version [% version %]</p> <h3>Projects</h3> <ul> [% FOREACH project IN worklist(me.id) %] <li> <a href="[% project.url %]">[% project.name %]</a> [% END %] </ul> [% INCLUDE footer %] This example shows how we've separated the Perl implementation (code) from the presentation (HTML). This not only makes them easier to maintain in isolation, but also allows the re-use of existing template elements such as headers and footers, etc. By using template to create the output of your CGI scripts, you can give them the same consistency as your static pages built via L<ttree|Template::Tools::ttree> or other means. Furthermore, we can modify our script so that it processes any one of a number of different templates based on some condition. A CGI script to maintain a user database, for example, might process one template to provide an empty form for new users, the same form with some default values set for updating an existing user record, a third template for listing all users in the system, and so on. You can use any Perl functionality you care to write to implement the logic of your application and then choose one or other template to generate the desired output for the application state. =head1 Dynamic Content Generation Via Apache/Mod_Perl Handler B<NOTE:> the L<Apache::Template> module is available from CPAN and provides a simple and easy to use Apache/mod_perl interface to the Template Toolkit. Although basic, it implements most, if not all of what is described below, and it avoids the need to write your own handler. However, in many cases, you'll want to write your own handler to customise processing for your own need, and this section will show you how to get started. The L<Template> module can be used from an Apache/mod_perl handler. Here's an example of a typical Apache F<httpd.conf> file: PerlModule CGI; PerlModule Template PerlModule MyOrg::Apache::User PerlSetVar websrc_root /home/abw/websrc <Location /user/bin> SetHandler perl-script PerlHandler MyOrg::Apache::User </Location> This defines a location called C</user/bin> to which all requests will be forwarded to the C<handler()> method of the C<MyOrg::Apache::User> module. That module might look something like this: package MyOrg::Apache::User; use strict; use Apache::Constants qw( :common ); use Template; use CGI; our $VERSION = 1.59; sub handler { my $r = shift; my $websrc = $r->dir_config('websrc_root') or return fail($r, SERVER_ERROR, "'websrc_root' not specified"); my $template = Template->new({ INCLUDE_PATH => "$websrc/src/user:$websrc/lib", PRE_PROCESS => 'config', OUTPUT => $r, # direct output to Apache request }); my $params = { uri => $r->uri, cgi => CGI->new, }; # use the path_info to determine which template file to process my $file = $r->path_info; $file =~ s[^/][]; $r->content_type('text/html'); $r->send_http_header; $template->process($file, $params) || return fail($r, SERVER_ERROR, $template->error()); return OK; } sub fail { my ($r, $status, $message) = @_; $r->log_reason($message, $r->filename); return $status; } The handler accepts the request and uses it to determine the C<websrc_root> value from the config file. This is then used to define an C<INCLUDE_PATH> for a new L<Template> object. The URI is extracted from the request and a L<CGI> object is created. These are both defined as template variables. The name of the template file itself is taken from the C<PATH_INFO> element of the request. In this case, it would comprise the part of the URL coming after C</user/bin>, e.g for C</user/bin/edit>, the template file would be C<edit> located in C<$websrc/src/user>. The headers are sent and the template file is processed. All output is sent directly to the C<print()> method of the Apache request object. =head1 Using Plugins to Extend Functionality As we've already shown, it is possible to bind Perl data and functions to template variables when creating dynamic content via a CGI script or Apache/mod_perl process. The Template Toolkit also supports a plugin interface which allows you define such additional data and/or functionality in a separate module and then load and use it as required with the C<USE> directive. The main benefit to this approach is that you can load the extension into any template document, even those that are processed "statically" by C<tpage> or C<ttree>. You I<don't> need to write a Perl wrapper to explicitly load the module and make it available via the stash. Let's demonstrate this principle using the C<DBI> plugin written by Simon Matthews (available from CPAN). You can create this template in your C<src> directory and process it using C<ttree> to see the results. Of course, this example relies on the existence of the appropriate SQL database but you should be able to adapt it to your own resources, or at least use it as a demonstrative example of what's possible. [% INCLUDE header title = 'User Info' %] [% USE DBI('dbi:mSQL:mydbname') %] <table border=0 width="100%"> <tr> <th>User ID</th> <th>Name</th> <th>Email</th> </tr> [% FOREACH user IN DBI.query('SELECT * FROM user ORDER BY id') %] <tr> <td>[% user.id %]</td> <td>[% user.name %]</td> <td>[% user.email %]</td> </tr> [% END %] </table> [% INCLUDE footer %] A plugin is simply a Perl module in a known location and conforming to a known standard such that the Template Toolkit can find and load it automatically. You can create your own plugin by inheriting from the L<Template::Plugin> module. Here's an example which defines some data items (C<foo> and C<people>) and also an object method (C<bar>). We'll call the plugin C<FooBar> for want of a better name and create it in the C<MyOrg::Template::Plugin::FooBar> package. We've added a C<MyOrg> to the regular C<Template::Plugin::*> package to avoid any conflict with existing plugins. package MyOrg::Template::Plugin::FooBar; use base 'Template::Plugin' our $VERSION = 1.23; sub new { my ($class, $context, @params) = @_; bless { _CONTEXT => $context, foo => 25, people => [ 'tom', 'dick', 'harry' ], }, $class; } sub bar { my ($self, @params) = @_; # ...do something... return $some_value; } The plugin constructor C<new()> receives the class name as the first parameter, as is usual in Perl, followed by a reference to something called a L<Template::Context> object. You don't need to worry too much about this at the moment, other than to know that it's the main processing object for the Template Toolkit. It provides access to the functionality of the processor and some plugins may need to communicate with it. We don't at this stage, but we'll save the reference anyway in the C<_CONTEXT> member. The leading underscore is a convention which indicates that this item is private and the Template Toolkit won't attempt to access this member. The other members defined, C<foo> and C<people> are regular data items which will be made available to templates using this plugin. Following the context reference are passed any additional parameters specified with the USE directive, such as the data source parameter, C<dbi:mSQL:mydbname>, that we used in the earlier DBI example. If you don't or can't install it to the regular place for your Perl modules (perhaps because you don't have the required privileges) then you can set the PERL5LIB environment variable to specify another location. If you're using C<ttree> then you can add the following line to your configuration file instead. $HOME/.ttreerc: perl5lib = /path/to/modules One further configuration item must be added to inform the toolkit of the new package name we have adopted for our plugins: $HOME/.ttreerc: plugin_base = 'MyOrg::Template::Plugin' If you're writing Perl code to control the L<Template> modules directly, then this value can be passed as a configuration parameter when you create the module. use Template; my $template = Template->new({ PLUGIN_BASE => 'MyOrg::Template::Plugin' }); Now we can create a template which uses this plugin: [% INCLUDE header title = 'FooBar Plugin Test' %] [% USE FooBar %] Some values available from this plugin: [% FooBar.foo %] [% FooBar.bar %] The users defined in the 'people' list: [% FOREACH uid = FooBar.people %] * [% uid %] [% END %] [% INCLUDE footer %] The C<foo>, C<bar>, and C<people> items of the FooBar plugin are automatically resolved to the appropriate data items or method calls on the underlying object. Using this approach, it is possible to create application functionality in a single module which can then be loaded and used on demand in any template. The simple interface between template directives and plugin objects allows complex, dynamic content to be built from a few simple template documents without knowing anything about the underlying implementation. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Tutorial/Datafile.pod 0000444 00000034064 15125513451 0012735 0 ustar 00 #============================================================= -*-perl-*- # # Template::Tutorial::Datafile # # DESCRIPTION # # AUTHOR # Dave Cross <dave@dave.org.uk> # # COPYRIGHT # Copyright (C) 1996-2008 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Tutorial::Datafile - Creating Data Output Files Using the Template Toolkit =head1 DESCRIPTION =head1 Introducing the Template Toolkit There are a number of Perl modules that are universally recognised as The Right Thing To Use for certain tasks. If you accessed a database without using DBI, pulled data from the WWW without using one of the LWP modules or parsed XML without using XML::Parser or one of its subclasses then you'd run the risk of being shunned by polite Perl society. I believe that the year 2000 saw the emergence of another 'must have' Perl module - the Template Toolkit. I don't think I'm alone in this belief as the Template Toolkit won the 'Best New Module' award at the Perl Conference last summer. Version 2.0 of the Template Toolkit (known as TT2 to its friends) was recently released to the CPAN. TT2 was designed and written by Andy Wardley E<lt>abw@wardley.orgE<gt>. It was born out of Andy's previous templating module, Text::Metatext, in best Fred Brooks 'plan to throw one away' manner; and aims to be the most useful (or, at least, the most I<used>) Perl templating system. TT2 provides a way to take a file of fixed boilerplate text (the template) and embed variable data within it. One obvious use of this is in the creation of dynamic web pages and this is where a lot of the attention that TT2 has received has been focussed. In this article, I hope to demonstrate that TT2 is just as useful in non-web applications. =head1 Using the Template Toolkit Let's look at how we'd use TT2 to process a simple data file. TT2 is an object oriented Perl module. Having downloaded it from CPAN and installed it in the usual manner, using it in your program is as easy as putting the lines use Template; my $tt = Template->new; in your code. The constructor function, C<new>, takes a number of optional parameters which are documented in the copious manual pages that come with the module, but for the purposes of this article we'll keep things as simple as possible. To process the template, you would call the C<process> method like this $tt->process('my_template', \%data) || die $tt->error; We pass two parameters to C<process>, the first is the name of the file containing the template to process (in this case, my_template) and the second is a reference to a hash which contains the data items that you want to use in the template. If processing the template gives any kind of error, the program will die with a (hopefully) useful error message. So what kinds of things can go in C<%data>? The answer is just about anything. Here's an example showing data about English Premier League football teams. my @teams = ({ name => 'Man Utd', played => 16, won => 12, drawn => 3, lost => 1 }, { name => 'Bradford', played => 16, won => 2, drawn => 5, lost => 9 }); my %data = ( name => 'English Premier League', season => '2000/01', teams => \@teams ); This creates three data items which can be accessed within the template, called C<name>, C<season> and C<teams>. Notice that C<teams> is a complex data structure. Here is a template that we might use to process this data. League Standings League Name: [% name %] Season : [% season %] Teams: [% FOREACH team = teams -%] [% team.name %] [% team.played -%] [% team.won %] [% team.drawn %] [% team.lost %] [% END %] Running this template with this data gives us the following output League Standings League Name: English Premier League Season : 2000/01 Teams: Man Utd 16 12 3 1 Bradford 16 2 5 9 Hopefully the syntax of the template is simple enough to follow. There are a few points to note. =over 4 =item * Template processing directives are written using a simple language which is not Perl. =item * The keys of the C<%data> have become the names of the data variables within the template. =item * Template processing directives are surrounded by C<[%> and C<%]> sequences. =item * If these tags are replaced with C<[%-> C<-%]> then the preceding or following linefeed is suppressed. =item * In the C<FOREACH> loop, each element of the C<teams> list was assigned, in turn, to the temporary variable C<team>. =item * Each item assigned to the C<team> variable is a Perl hash. Individual values within the hash are accessed using a dot notation. =back It's probably the first and last of these points which are the most important. The first point emphasises the separation of the data acquisition logic from the presentation logic. The person creating the presentation template doesn't need to know Perl, they only need to know the data items which will be passed into the template. The last point demonstrates the way that TT2 protects the template designer from the implementation of the data structures. The data objects passed to the template processor can be scalars, arrays, hashes, objects or even subroutines. The template processor will just interpret your data correctly and Do The Right Thing to return the correct value to you. In this example each team was a hash, but in a larger system each team might be an object, in which case C<name>, C<played>, etc. would be accessor methods to the underlying object attributes. No changes would be required to the template as the template processor would realise that it needed to call methods rather than access hash values. =head2 A more complex example Stats about the English Football League are usually presented in a slightly more complex format than the one we used above. A full set of stats will show the number of games that a team has won, lost or drawn, the number of goals scored for and against the team and the number of points that the team therefore has. Teams gain three points for a win and one point for a draw. When teams have the same number of points they are separated by the goal difference, that is the number of goals the team has scored minus the number of team scored against them. To complicate things even further, the games won, drawn and lost and the goals for and against are often split between home and away games. Therefore if you have a data source which lists the team name together with the games won, drawn and lost and the goals for and against split into home and away (a total of eleven data items) you can calculate all of the other items (goal difference, points awarded and even position in the league). Let's take such a file, but we'll only look at the top three teams. It will look something like this: Man Utd,7,1,0,26,4,5,2,1,15,6 Arsenal,7,1,0,17,4,2,3,3,7,9 Leicester,4,3,1,10,8,4,2,2,7,4 A simple script to read this data into an array of hashes will look something like this (I've simplified the names of the data columns - w, d, and l are games won, drawn and lost and f and a are goals scored for and against; h and a at the front of a data item name indicates whether it's a home or away statistic): my @cols = qw(name hw hd hl hf ha aw ad al af aa); my @teams; while (<>) { chomp; my %team; @team{@cols} = split /,/; push @teams, \%team; } We can then go thru the teams again and calculate all of the derived data items: foreach (@teams) { $_->{w} = $_->{hw} + $_->{aw}; $_->{d} = $_->{hd} + $_->{ad}; $_->{l} = $_->{hl} + $_->{al}; $_->{pl} = $_->{w} + $_->{d} + $_->{l}; $_->{f} = $_->{hf} + $_->{af}; $_->{a} = $_->{ha} + $_->{aa}; $_->{gd} = $_->{f} - $_->{a}; $_->{pt} = (3 * $_->{w}) + $_->{d}; } And then produce a list sorted in descending order: @teams = sort { $b->{pt} <=> $b->{pt} || $b->{gd} <=> $a->{gd} } @teams; And finally add the league position data item: $teams[$_]->{pos} = $_ + 1 foreach 0 .. $#teams; Having pulled all of our data into an internal data structure we can start to produce output using out templates. A template to create a CSV file containing the data split between home and away stats would look like this: [% FOREACH team = teams -%] [% team.pos %],[% team.name %],[% team.pl %],[% team.hw %], [%- team.hd %],[% team.hl %],[% team.hf %],[% team.ha %], [%- team.aw %],[% team.ad %],[% team.al %],[% team.af %], [%- team.aa %],[% team.gd %],[% team.pt %] [%- END %] And processing it like this: $tt->process('split.tt', { teams => \@teams }, 'split.csv') || die $tt->error; produces the following output: 1,Man Utd,16,7,1,0,26,4,5,2,1,15,6,31,39 2,Arsenal,16,7,1,0,17,4,2,3,3,7,9,11,31 3,Leicester,16,4,3,1,10,8,4,2,2,7,4,5,29 Notice that we've introduced the third parameter to C<process>. If this parameter is missing then the TT2 sends its output to C<STDOUT>. If this parameter is a scalar then it is taken as the name of a file to write the output to. This parameter can also be (amongst other things) a filehandle or a reference to an object which is assumed to implement a C<print> method. If we weren't interested in the split between home and away games, then we could use a simpler template like this: [% FOREACH team = teams -%] [% team.pos %],[% team.name %],[% team.pl %],[% team.w %], [%- team.d %],[% team.l %],[% team.f %],[% team.a %], [%- team.aa %],[% team.gd %],[% team.pt %] [% END -%] Which would produce output like this: 1,Man Utd,16,12,3,1,41,10,6,31,39 2,Arsenal,16,9,4,3,24,13,9,11,31 3,Leicester,16,8,5,3,17,12,4,5,29 =head1 Producing XML This is starting to show some of the power and flexibility of TT2, but you may be thinking that you could just as easily produce this output with a C<foreach> loop and a couple of C<print> statements in your code. This is, of course, true; but that's because I've chosen a deliberately simple example to explain the concepts. What if we wanted to produce an XML file containing the data? And what if (as I mentioned earlier) the league data was held in an object? The code would then look even easier as most of the code we've written earlier would be hidden away in C<FootballLeague.pm>. use FootballLeague; use Template; my $league = FootballLeague->new(name => 'English Premier'); my $tt = Template->new; $tt->process('league_xml.tt', { league => $league }) || die $tt->error; And the template in C<league_xml.tt> would look something like this: <?xml version="1.0"?> <!DOCTYPE LEAGUE SYSTEM "league.dtd"> <league name="[% league.name %]" season="[% league.season %]"> [% FOREACH team = league.teams -%] <team name="[% team.name %]" pos="[% team.pos %]" played="[% team.pl %]" goal_diff="[% team.gd %]" points="[% team.pt %]"> <stats type="home"> win="[% team.hw %]" draw="[%- team.hd %]" lose="[% team.hl %]" for="[% team.hf %]" against="[% team.ha %]" /> <stats type="away"> win="[% team.aw %]" draw="[%- team.ad %]" lose="[% team.al %]" for="[% team.af %]" against="[% team.aa %]" /> </team> [% END -%] &/league> Notice that as we've passed the whole object into C<process> then we need to put an extra level of indirection on our template variables - everything is now a component of the C<league> variable. Other than that, everything in the template is very similar to what we've used before. Presumably now C<team.name> calls an accessor function rather than carrying out a hash lookup, but all of this is transparent to our template designer. =head1 Multiple Formats As a final example, let's suppose that we need to create output football league tables in a number of formats. Perhaps we are passing this data on to other people and they can't all use the same format. Some of our users need CSV files and others need XML. Some require data split between home and away matches and other just want the totals. In total, then, we'll need four different templates, but the good news is that they can use the same data object. All the script needs to do is to establish which template is required and process it. use FootballLeague; use Template; my ($name, $type, $stats) = @_; my $league = FootballLeague->new(name => $name); my $tt = Template->new; $tt->process("league_${type}_$stats.tt", { league => $league } "league_$stats.$type") || die $tt->error; For example, you can call this script as league.pl 'English Premier' xml split This will process a template called C<league_xml_split.tt> and put the results in a file called C<league_split.xml>. This starts to show the true strength of the Template Toolkit. If we later wanted to add another file format - perhaps we wanted to create a league table HTML page or even a LaTeX document - then we would just need to create the appropriate template and name it according to our existing naming convention. We would need to make no changes to the code. I hope you can now see why the Template Toolkit is fast becoming an essential part of many people's Perl installation. =head1 AUTHOR Dave Cross E<lt>dave@dave.org.ukE<gt> =head1 VERSION Template Toolkit version 2.19, released on 27 April 2007. =head1 COPYRIGHT Copyright (C) 2001 Dave Cross E<lt>dave@dave.org.ukE<gt> This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/Math.pm 0000444 00000007772 15125513451 0011410 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::Math # # DESCRIPTION # Plugin implementing numerous mathematical functions. # # AUTHORS # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 2002-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::Math; use strict; use warnings; use base 'Template::Plugin'; our $VERSION = '3.100'; our $AUTOLOAD; #------------------------------------------------------------------------ # new($context, \%config) # # This constructor method creates a simple, empty object to act as a # receiver for future object calls. No doubt there are many interesting # configuration options that might be passed, but I'll leave that for # someone more knowledgable in these areas to contribute... #------------------------------------------------------------------------ sub new { my ($class, $context, $config) = @_; $config ||= { }; bless { %$config, }, $class; } sub abs { shift; CORE::abs($_[0]); } sub atan2 { shift; CORE::atan2($_[0], $_[1]); } # prototyped (ugg) sub cos { shift; CORE::cos($_[0]); } sub exp { shift; CORE::exp($_[0]); } sub hex { shift; CORE::hex($_[0]); } sub int { shift; CORE::int($_[0]); } sub log { shift; CORE::log($_[0]); } sub oct { shift; CORE::oct($_[0]); } sub rand { shift; @_ ? CORE::rand($_[0]) : CORE::rand(); } sub sin { shift; CORE::sin($_[0]); } sub sqrt { shift; CORE::sqrt($_[0]); } sub srand { shift; @_ ? CORE::srand($_[0]) : CORE::srand(); } # Use the Math::TrulyRandom module # XXX This is *sloooooooowwwwwwww* sub truly_random { eval { require Math::TrulyRandom; } or die(Template::Exception->new("plugin", "Can't load Math::TrulyRandom")); return Math::TrulyRandom::truly_random_value(); } eval { require Math::Trig; no strict qw(refs); for my $trig_func (@Math::Trig::EXPORT) { my $sub = Math::Trig->can($trig_func); *{$trig_func} = sub { shift; &$sub(@_) }; } }; # To catch errors from a missing Math::Trig sub AUTOLOAD { return; } 1; __END__ =head1 NAME Template::Plugin::Math - Plugin providing mathematical functions =head1 SYNOPSIS [% USE Math %] [% Math.sqrt(9) %] =head1 DESCRIPTION The Math plugin provides numerous mathematical functions for use within templates. =head1 METHODS C<Template::Plugin::Math> makes available the following functions from the Perl core: =over 4 =item abs =item atan2 =item cos =item exp =item hex =item int =item log =item oct =item rand =item sin =item sqrt =item srand =back In addition, if the L<Math::Trig> module can be loaded, the following functions are also available: =over 4 =item pi =item tan =item csc =item cosec =item sec =item cot =item cotan =item asin =item acos =item atan =item acsc =item acosec =item asec =item acot =item acotan =item sinh =item cosh =item tanh =item csch =item cosech =item sech =item coth =item cotanh =item asinh =item acosh =item atanh =item acsch =item acosech =item asech =item acoth =item acotanh =item rad2deg =item rad2grad =item deg2rad =item deg2grad =item grad2rad =item grad2deg =back If the L<Math::TrulyRandom> module is available, and you've got the time to wait, the C<truly_random_number> method is available: [% Math.truly_random_number %] =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/Datafile.pm 0000444 00000010632 15125513451 0012215 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::Datafile # # DESCRIPTION # Template Toolkit Plugin which reads a datafile and constructs a # list object containing hashes representing records in the file. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::Datafile; use strict; use warnings; use base 'Template::Plugin'; our $VERSION = '3.100'; sub new { my ($class, $context, $filename, $params) = @_; my ($delim, $encoding, $line, @fields, @data, @results); my $self = [ ]; local *FD; local $/ = "\n"; $params ||= { }; $delim = $params->{'delim'} || ':'; $delim = quotemeta($delim); $encoding = defined $params->{'encoding'} ? ':encoding('.$params->{'encoding'}.')' : ''; return $class->error("No filename specified") unless $filename; open(FD, '<'.$encoding, $filename) || return $class->error("$filename: $!"); # first line of file should contain field definitions while (! $line || $line =~ /^#/) { $line = <FD>; chomp $line; $line =~ s/\r$//; } (@fields = split(/\s*$delim\s*/, $line)) || return $class->error("first line of file must contain field names"); # read each line of the file while (<FD>) { chomp; s/\r$//; # ignore comments and blank lines next if /^#/ || /^\s*$/; # split line into fields @data = split(/\s*$delim\s*/); # create hash record to represent data my %record; @record{ @fields } = @data; push(@$self, \%record); } # return $self; bless $self, $class; } sub as_list { return $_[0]; } 1; __END__ =head1 NAME Template::Plugin::Datafile - Plugin to construct records from a simple data file =head1 SYNOPSIS [% USE mydata = datafile('/path/to/datafile') %] [% USE mydata = datafile('/path/to/datafile', delim = '|') %] [% USE mydata = datafile('/path/to/datafile', encoding = 'UTF-8') %] [% FOREACH record = mydata %] [% record.this %] [% record.that %] [% END %] =head1 DESCRIPTION This plugin provides a simple facility to construct a list of hash references, each of which represents a data record of known structure, from a data file. [% USE datafile(filename) %] A absolute filename must be specified (for this initial implementation at least - in a future version it might also use the C<INCLUDE_PATH>). An optional C<delim> parameter may also be provided to specify an alternate delimiter character. The optional C<encoding> parameter may be used to specify the input file encoding. [% USE userlist = datafile('/path/to/file/users') %] [% USE things = datafile('items', delim = '|') %] The format of the file is intentionally simple. The first line defines the field names, delimited by colons with optional surrounding whitespace. Subsequent lines then defines records containing data items, also delimited by colons. e.g. id : name : email : tel abw : Andy Wardley : abw@tt2.org : 555-1234 sam : Simon Matthews : sam@tt2.org : 555-9876 Each line is read, split into composite fields, and then used to initialise a hash array containing the field names as relevant keys. The plugin returns a blessed list reference containing the hash references in the order as defined in the file. [% FOREACH user = userlist %] [% user.id %]: [% user.name %] [% END %] The first line of the file B<must> contain the field definitions. After the first line, blank lines will be ignored, along with comment line which start with a 'C<#>'. =head1 BUGS Should handle file names relative to C<INCLUDE_PATH>. Doesn't permit use of 'C<:>' in a field. Some escaping mechanism is required. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/View.pm 0000444 00000004631 15125513451 0011420 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::View # # DESCRIPTION # A user-definable view based on templates. Similar to the concept of # a "Skin". # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 2000-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::View; use strict; use warnings; use base 'Template::Plugin'; our $VERSION = '3.100'; use Template::View; #------------------------------------------------------------------------ # new($context, \%config) #------------------------------------------------------------------------ sub new { my $class = shift; my $context = shift; my $view = Template::View->new($context, @_) || return $class->error($Template::View::ERROR); $view->seal(); return $view; } 1; __END__ =head1 NAME Template::Plugin::View - Plugin to create views (Template::View) =head1 SYNOPSIS [% USE view( prefix = 'splash/' # template prefix/suffix suffix = '.tt2' bgcol = '#ffffff' # and any other variables you style = 'Fancy HTML' # care to define as view metadata, items = [ foo, bar.baz ] # including complex data and foo = bar ? baz : x.y.z # expressions %] [% view.title %] # access view metadata [% view.header(title = 'Foo!') %] # view "methods" process blocks or [% view.footer %] # templates with prefix/suffix added =head1 DESCRIPTION This plugin module creates L<Template::View> objects. Views are an experimental feature and are subject to change in the near future. In the mean time, please consult L<Template::View> for further info. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin>, L<Template::View>, L<Template::Manual::Views> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/Filter.pm 0000444 00000023204 15125513451 0011730 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::Filter # # DESCRIPTION # Template Toolkit module implementing a base class plugin # object which acts like a filter and can be used with the # FILTER directive. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 2001-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::Filter; use strict; use warnings; use base 'Template::Plugin'; use Scalar::Util 'weaken', 'isweak'; our $VERSION = '3.100'; our $DYNAMIC = 0 unless defined $DYNAMIC; sub new { my ($class, $context, @args) = @_; my $config = @args && ref $args[-1] eq 'HASH' ? pop(@args) : { }; # look for $DYNAMIC my $dynamic; { no strict 'refs'; $dynamic = ${"$class\::DYNAMIC"}; } $dynamic = $DYNAMIC unless defined $dynamic; my $self = bless { _CONTEXT => $context, _DYNAMIC => $dynamic, _ARGS => \@args, _CONFIG => $config, }, $class; return $self->init($config) || $class->error($self->error()); } sub init { my ($self, $config) = @_; return $self; } sub factory { my $self = shift; my $this = $self; # avoid a memory leak weaken( $this->{_CONTEXT} ) if ref $this->{_CONTEXT} && !isweak $this->{_CONTEXT}; if ($self->{ _DYNAMIC }) { return [ sub { my ($context, @args) = @_; my $config = ref $args[-1] eq 'HASH' ? pop(@args) : { }; return sub { $this->filter(shift, \@args, $config); }; }, 1 ]; } else { return sub { $this->filter(shift); }; } } sub filter { my ($self, $text, $args, $config) = @_; return $text; } sub merge_config { my ($self, $newcfg) = @_; my $owncfg = $self->{ _CONFIG }; return $owncfg unless $newcfg; return { %$owncfg, %$newcfg }; } sub merge_args { my ($self, $newargs) = @_; my $ownargs = $self->{ _ARGS }; return $ownargs unless $newargs; return [ @$ownargs, @$newargs ]; } sub install_filter { my ($self, $name) = @_; $self->{ _CONTEXT }->define_filter( $name => $self->factory ); return $self; } 1; __END__ =head1 NAME Template::Plugin::Filter - Base class for plugin filters =head1 SYNOPSIS package MyOrg::Template::Plugin::MyFilter; use Template::Plugin::Filter; use base qw( Template::Plugin::Filter ); sub filter { my ($self, $text) = @_; # ...mungify $text... return $text; } # now load it... [% USE MyFilter %] # ...and use the returned object as a filter [% FILTER $MyFilter %] ... [% END %] =head1 DESCRIPTION This module implements a base class for plugin filters. It hides the underlying complexity involved in creating and using filters that get defined and made available by loading a plugin. To use the module, simply create your own plugin module that is inherited from the C<Template::Plugin::Filter> class. package MyOrg::Template::Plugin::MyFilter; use Template::Plugin::Filter; use base qw( Template::Plugin::Filter ); Then simply define your C<filter()> method. When called, you get passed a reference to your plugin object (C<$self>) and the text to be filtered. sub filter { my ($self, $text) = @_; # ...mungify $text... return $text; } To use your custom plugin, you have to make sure that the Template Toolkit knows about your plugin namespace. my $tt2 = Template->new({ PLUGIN_BASE => 'MyOrg::Template::Plugin', }); Or for individual plugins you can do it like this: my $tt2 = Template->new({ PLUGINS => { MyFilter => 'MyOrg::Template::Plugin::MyFilter', }, }); Then you C<USE> your plugin in the normal way. [% USE MyFilter %] The object returned is stored in the variable of the same name, 'C<MyFilter>'. When you come to use it as a C<FILTER>, you should add a dollar prefix. This indicates that you want to use the filter stored in the variable 'C<MyFilter>' rather than the filter named 'C<MyFilter>', which is an entirely different thing (see later for information on defining filters by name). [% FILTER $MyFilter %] ...text to be filtered... [% END %] You can, of course, assign it to a different variable. [% USE blat = MyFilter %] [% FILTER $blat %] ...text to be filtered... [% END %] Any configuration parameters passed to the plugin constructor from the C<USE> directive are stored internally in the object for inspection by the C<filter()> method (or indeed any other method). Positional arguments are stored as a reference to a list in the C<_ARGS> item while named configuration parameters are stored as a reference to a hash array in the C<_CONFIG> item. For example, loading a plugin as shown here: [% USE blat = MyFilter 'foo' 'bar' baz = 'blam' %] would allow the C<filter()> method to do something like this: sub filter { my ($self, $text) = @_; my $args = $self->{ _ARGS }; # [ 'foo', 'bar' ] my $conf = $self->{ _CONFIG }; # { baz => 'blam' } # ...munge $text... return $text; } By default, plugins derived from this module will create static filters. A static filter is created once when the plugin gets loaded via the C<USE> directive and re-used for all subsequent C<FILTER> operations. That means that any argument specified with the C<FILTER> directive are ignored. Dynamic filters, on the other hand, are re-created each time they are used by a C<FILTER> directive. This allows them to act on any parameters passed from the C<FILTER> directive and modify their behaviour accordingly. There are two ways to create a dynamic filter. The first is to define a C<$DYNAMIC> class variable set to a true value. package MyOrg::Template::Plugin::MyFilter; use base 'Template::Plugin::Filter'; our $DYNAMIC = 1; The other way is to set the internal C<_DYNAMIC> value within the C<init()> method which gets called by the C<new()> constructor. sub init { my $self = shift; $self->{ _DYNAMIC } = 1; return $self; } When this is set to a true value, the plugin will automatically create a dynamic filter. The outcome is that the C<filter()> method will now also get passed a reference to an array of positional arguments and a reference to a hash array of named parameters. So, using a plugin filter like this: [% FILTER $blat 'foo' 'bar' baz = 'blam' %] would allow the C<filter()> method to work like this: sub filter { my ($self, $text, $args, $conf) = @_; # $args = [ 'foo', 'bar' ] # $conf = { baz => 'blam' } } In this case can pass parameters to both the USE and FILTER directives, so your filter() method should probably take that into account. [% USE MyFilter 'foo' wiz => 'waz' %] [% FILTER $MyFilter 'bar' biz => 'baz' %] ... [% END %] You can use the C<merge_args()> and C<merge_config()> methods to do a quick and easy job of merging the local (e.g. C<FILTER>) parameters with the internal (e.g. C<USE>) values and returning new sets of conglomerated data. sub filter { my ($self, $text, $args, $conf) = @_; $args = $self->merge_args($args); $conf = $self->merge_config($conf); # $args = [ 'foo', 'bar' ] # $conf = { wiz => 'waz', biz => 'baz' } ... } You can also have your plugin install itself as a named filter by calling the C<install_filter()> method from the C<init()> method. You should provide a name for the filter, something that you might like to make a configuration option. sub init { my $self = shift; my $name = $self->{ _CONFIG }->{ name } || 'myfilter'; $self->install_filter($name); return $self; } This allows the plugin filter to be used as follows: [% USE MyFilter %] [% FILTER myfilter %] ... [% END %] or [% USE MyFilter name = 'swipe' %] [% FILTER swipe %] ... [% END %] Alternately, you can allow a filter name to be specified as the first positional argument. sub init { my $self = shift; my $name = $self->{ _ARGS }->[0] || 'myfilter'; $self->install_filter($name); return $self; } [% USE MyFilter 'swipe' %] [% FILTER swipe %] ... [% END %] =head1 EXAMPLE Here's a complete example of a plugin filter module. package My::Template::Plugin::Change; use Template::Plugin::Filter; use base qw( Template::Plugin::Filter ); sub init { my $self = shift; $self->{ _DYNAMIC } = 1; # first arg can specify filter name $self->install_filter($self->{ _ARGS }->[0] || 'change'); return $self; } sub filter { my ($self, $text, $args, $config) = @_; $config = $self->merge_config($config); my $regex = join('|', keys %$config); $text =~ s/($regex)/$config->{ $1 }/ge; return $text; } 1; =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin>, L<Template::Filters>, L<Template::Manual::Filters> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/Pod.pm 0000444 00000003162 15125513451 0011226 0 ustar 00 #============================================================================== # # Template::Plugin::Pod # # DESCRIPTION # Pod parser and object model. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 2000-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::Pod; use strict; use warnings; use base 'Template::Plugin'; use Pod::POM; our $VERSION = '3.100'; #------------------------------------------------------------------------ # new($context, \%config) #------------------------------------------------------------------------ sub new { my $class = shift; my $context = shift; Pod::POM->new(@_); } 1; __END__ =head1 NAME Template::Plugin::Pod - Plugin interface to Pod::POM (Pod Object Model) =head1 SYNOPSIS [% USE Pod(podfile) %] [% FOREACH head1 = Pod.head1; FOREACH head2 = head1/head2; ... END; END %] =head1 DESCRIPTION This plugin is an interface to the L<Pod::POM> module. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin>, L<Pod::POM> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/File.pm 0000444 00000025653 15125513451 0011374 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::File # # DESCRIPTION # Plugin for encapsulating information about a system file. # # AUTHOR # Originally written by Michael Stevens <michael@etla.org> as the # Directory plugin, then mutilated by Andy Wardley <abw@kfs.org> # into separate File and Directory plugins, with some additional # code for working with views, etc. # # COPYRIGHT # Copyright 2000-2022 Michael Stevens, Andy Wardley. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::File; use strict; use warnings; use Cwd; use File::Spec; use File::Basename; use base 'Template::Plugin'; our $VERSION = '3.100'; our @STAT_KEYS = qw( dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks ); #------------------------------------------------------------------------ # new($context, $file, \%config) # # Create a new File object. Takes the pathname of the file as # the argument following the context and an optional # hash reference of configuration parameters. #------------------------------------------------------------------------ sub new { my $config = ref($_[-1]) eq 'HASH' ? pop(@_) : { }; my ($class, $context, $path) = @_; my ($root, $home, @stat, $abs); return $class->throw('no file specified') unless defined $path and length $path; # path, dir, name, root, home if (File::Spec->file_name_is_absolute($path)) { $root = ''; } elsif (($root = $config->{ root })) { # strip any trailing '/' from root $root =~ s[/$][]; } else { $root = ''; } my ($name, $dir, $ext) = fileparse($path, '\.\w+'); # fixup various items $dir =~ s[/$][]; $dir = '' if $dir eq '.'; $name = $name . $ext; $ext =~ s/^\.//g; my @fields = File::Spec->splitdir($dir); shift @fields if @fields && ! length $fields[0]; $home = join('/', ('..') x @fields); $abs = File::Spec->catfile($root ? $root : (), $path); my $self = { path => $path, name => $name, root => $root, home => $home, dir => $dir, ext => $ext, abs => $abs, user => '', group => '', isdir => '', stat => defined $config->{ stat } ? $config->{ stat } : ! $config->{ nostat }, map { ($_ => '') } @STAT_KEYS, }; if ($self->{ stat }) { (@stat = stat( $abs )) || return $class->throw("$abs: $!"); @$self{ @STAT_KEYS } = @stat; unless ($config->{ noid }) { $self->{ user } = eval { getpwuid( $self->{ uid }) || $self->{ uid } }; $self->{ group } = eval { getgrgid( $self->{ gid }) || $self->{ gid } }; } $self->{ isdir } = -d $abs; } bless $self, $class; } #------------------------------------------------------------------------- # rel($file) # # Generate a relative filename for some other file relative to this one. #------------------------------------------------------------------------ sub rel { my ($self, $path) = @_; $path = $path->{ path } if ref $path eq ref $self; # assumes same root return $path if $path =~ m[^/]; return $path unless $self->{ home }; return $self->{ home } . '/' . $path; } #------------------------------------------------------------------------ # present($view) # # Present self to a Template::View. #------------------------------------------------------------------------ sub present { my ($self, $view) = @_; $view->view_file($self); } sub throw { my ($self, $error) = @_; die (Template::Exception->new('File', $error)); } 1; __END__ =head1 NAME Template::Plugin::File - Plugin providing information about files =head1 SYNOPSIS [% USE File(filepath) %] [% File.path %] # full path [% File.name %] # filename [% File.dir %] # directory =head1 DESCRIPTION This plugin provides an abstraction of a file. It can be used to fetch details about files from the file system, or to represent abstract files (e.g. when creating an index page) that may or may not exist on a file system. A file name or path should be specified as a constructor argument. e.g. [% USE File('foo.html') %] [% USE File('foo/bar/baz.html') %] [% USE File('/foo/bar/baz.html') %] The file should exist on the current file system (unless C<nostat> option set, see below) as an absolute file when specified with as leading 'C</>' as per 'C</foo/bar/baz.html>', or otherwise as one relative to the current working directory. The constructor performs a C<stat()> on the file and makes the 13 elements returned available as the plugin items: dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks e.g. [% USE File('/foo/bar/baz.html') %] [% File.mtime %] [% File.mode %] ... In addition, the C<user> and C<group> items are set to contain the user and group names as returned by calls to C<getpwuid()> and C<getgrgid()> for the file C<uid> and C<gid> elements, respectively. On Win32 platforms on which C<getpwuid()> and C<getgrid()> are not available, these values are undefined. [% USE File('/tmp/foo.html') %] [% File.uid %] # e.g. 500 [% File.user %] # e.g. abw This user/group lookup can be disabled by setting the C<noid> option. [% USE File('/tmp/foo.html', noid=1) %] [% File.uid %] # e.g. 500 [% File.user %] # nothing The C<isdir> flag will be set if the file is a directory. [% USE File('/tmp') %] [% File.isdir %] # 1 If the C<stat()> on the file fails (e.g. file doesn't exists, bad permission, etc) then the constructor will throw a C<File> exception. This can be caught within a C<TRY...CATCH> block. [% TRY %] [% USE File('/tmp/myfile') %] File exists! [% CATCH File %] File error: [% error.info %] [% END %] Note the capitalisation of the exception type, 'C<File>', to indicate an error thrown by the C<File> plugin, to distinguish it from a regular C<file> exception thrown by the Template Toolkit. Note that the C<File> plugin can also be referenced by the lower case name 'C<file>'. However, exceptions are always thrown of the C<File> type, regardless of the capitalisation of the plugin named used. [% USE file('foo.html') %] [% file.mtime %] As with any other Template Toolkit plugin, an alternate name can be specified for the object created. [% USE foo = file('foo.html') %] [% foo.mtime %] The C<nostat> option can be specified to prevent the plugin constructor from performing a C<stat()> on the file specified. In this case, the file does not have to exist in the file system, no attempt will be made to verify that it does, and no error will be thrown if it doesn't. The entries for the items usually returned by C<stat()> will be set empty. [% USE file('/some/where/over/the/rainbow.html', nostat=1) [% file.mtime %] # nothing =head1 METHODS All C<File> plugins, regardless of the C<nostat> option, have set a number of items relating to the original path specified. =head2 path The full, original file path specified to the constructor. [% USE file('/foo/bar.html') %] [% file.path %] # /foo/bar.html =head2 name The name of the file without any leading directories. [% USE file('/foo/bar.html') %] [% file.name %] # bar.html =head2 dir The directory element of the path with the filename removed. [% USE file('/foo/bar.html') %] [% file.name %] # /foo =head2 ext The file extension, if any, appearing at the end of the path following a 'C<.>' (not included in the extension). [% USE file('/foo/bar.html') %] [% file.ext %] # html =head2 home This contains a string of the form 'C<../..>' to represent the upward path from a file to its root directory. [% USE file('bar.html') %] [% file.home %] # nothing [% USE file('foo/bar.html') %] [% file.home %] # .. [% USE file('foo/bar/baz.html') %] [% file.home %] # ../.. =head2 root The C<root> item can be specified as a constructor argument, indicating a root directory in which the named file resides. This is otherwise set empty. [% USE file('foo/bar.html', root='/tmp') %] [% file.root %] # /tmp =head2 abs This returns the absolute file path by constructing a path from the C<root> and C<path> options. [% USE file('foo/bar.html', root='/tmp') %] [% file.path %] # foo/bar.html [% file.root %] # /tmp [% file.abs %] # /tmp/foo/bar.html =head2 rel(path) This returns a relative path from the current file to another path specified as an argument. It is constructed by appending the path to the 'C<home>' item. [% USE file('foo/bar/baz.html') %] [% file.rel('wiz/waz.html') %] # ../../wiz/waz.html =head1 EXAMPLES [% USE file('/foo/bar/baz.html') %] [% file.path %] # /foo/bar/baz.html [% file.dir %] # /foo/bar [% file.name %] # baz.html [% file.home %] # ../.. [% file.root %] # '' [% file.abs %] # /foo/bar/baz.html [% file.ext %] # html [% file.mtime %] # 987654321 [% file.atime %] # 987654321 [% file.uid %] # 500 [% file.user %] # abw [% USE file('foo.html') %] [% file.path %] # foo.html [% file.dir %] # '' [% file.name %] # foo.html [% file.root %] # '' [% file.home %] # '' [% file.abs %] # foo.html [% USE file('foo/bar/baz.html') %] [% file.path %] # foo/bar/baz.html [% file.dir %] # foo/bar [% file.name %] # baz.html [% file.root %] # '' [% file.home %] # ../.. [% file.abs %] # foo/bar/baz.html [% USE file('foo/bar/baz.html', root='/tmp') %] [% file.path %] # foo/bar/baz.html [% file.dir %] # foo/bar [% file.name %] # baz.html [% file.root %] # /tmp [% file.home %] # ../.. [% file.abs %] # /tmp/foo/bar/baz.html # calculate other file paths relative to this file and its root [% USE file('foo/bar/baz.html', root => '/tmp/tt2') %] [% file.path('baz/qux.html') %] # ../../baz/qux.html [% file.dir('wiz/woz.html') %] # ../../wiz/woz.html =head1 AUTHORS Michael Stevens wrote the original C<Directory> plugin on which this is based. Andy Wardley split it into separate C<File> and C<Directory> plugins, added some extra code and documentation for C<VIEW> support, and made a few other minor tweaks. =head1 COPYRIGHT Copyright 2000-2022 Michael Stevens, Andy Wardley. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin>, L<Template::Plugin::Directory>, L<Template::View> 5.32/Template/Plugin/Table.pm 0000444 00000030643 15125513451 0011537 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::Table # # DESCRIPTION # Plugin to order a linear data set into a virtual 2-dimensional table # from which row and column permutations can be fetched. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 2000-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::Table; use strict; use warnings; use base 'Template::Plugin'; use Scalar::Util 'blessed'; our $VERSION = '3.100'; our $AUTOLOAD; #------------------------------------------------------------------------ # new($context, \@data, \%args) # # This constructor method initialises the object to iterate through # the data set passed by reference to a list as the first parameter. # It calculates the shape of the permutation table based on the ROWS # or COLS parameters specified in the $args hash reference. The # OVERLAP parameter may be provided to specify the number of common # items that should be shared between subsequent columns. #------------------------------------------------------------------------ sub new { my ($class, $context, $data, $params) = @_; my ($size, $rows, $cols, $coloff, $overlap, $error); # if the data item is a reference to a Template::Iterator object, # or subclass thereof, we call its get_all() method to extract all # the data it contains if (blessed($data) && $data->isa('Template::Iterator')) { ($data, $error) = $data->get_all(); return $class->error( "iterator failed to provide data for table: ", $error ) if $error; } return $class->error('invalid table data, expecting a list') unless ref $data eq 'ARRAY'; $params ||= { }; return $class->error('invalid table parameters, expecting a hash') unless ref $params eq 'HASH'; # ensure keys are folded to upper case @$params{ map { uc } keys %$params } = values %$params; $size = scalar @$data; $overlap = $params->{ OVERLAP } || 0; # calculate number of columns based on a specified number of rows if ($rows = $params->{ ROWS }) { if ($size < $rows) { $rows = $size; # pad? $cols = 1; $coloff = 0; } else { $coloff = $rows - $overlap; $cols = int ($size / $coloff) + ($size % $coloff > $overlap ? 1 : 0) } } # calculate number of rows based on a specified number of columns elsif ($cols = $params->{ COLS }) { if ($size < $cols) { $cols = $size; $rows = 1; $coloff = 1; } else { $coloff = int ($size / $cols) + ($size % $cols > $overlap ? 1 : 0); $rows = $coloff + $overlap; } } else { $rows = $size; $cols = 1; $coloff = 0; } bless { _DATA => $data, _SIZE => $size, _NROWS => $rows, _NCOLS => $cols, _COLOFF => $coloff, _OVERLAP => $overlap, _PAD => defined $params->{ PAD } ? $params->{ PAD } : 1, }, $class; } #------------------------------------------------------------------------ # row($n) # # Returns a reference to a list containing the items in the row whose # number is specified by parameter. If the row number is undefined, # it calls rows() to return a list of all rows. #------------------------------------------------------------------------ sub row { my ($self, $row) = @_; my ($data, $cols, $offset, $size, $pad) = @$self{ qw( _DATA _NCOLS _COLOFF _SIZE _PAD) }; my @set; # return all rows if row number not specified return $self->rows() unless defined $row; return () if $row >= $self->{ _NROWS } || $row < 0; my $index = $row; for (my $c = 0; $c < $cols; $c++) { push( @set, $index < $size ? $data->[$index] : ($pad ? undef : ()) ); $index += $offset; } return \@set; } #------------------------------------------------------------------------ # col($n) # # Returns a reference to a list containing the items in the column whose # number is specified by parameter. If the column number is undefined, # it calls cols() to return a list of all columns. #------------------------------------------------------------------------ sub col { my ($self, $col) = @_; my ($data, $size) = @$self{ qw( _DATA _SIZE ) }; my ($start, $end); my $blanks = 0; # return all cols if row number not specified return $self->cols() unless defined $col; return () if $col >= $self->{ _NCOLS } || $col < 0; $start = $self->{ _COLOFF } * $col; $end = $start + $self->{ _NROWS } - 1; $end = $start if $end < $start; if ($end >= $size) { $blanks = ($end - $size) + 1; $end = $size - 1; } return () if $start >= $size; return [ @$data[$start..$end], $self->{ _PAD } ? ((undef) x $blanks) : () ]; } #------------------------------------------------------------------------ # rows() # # Returns all rows as a reference to a list of rows. #------------------------------------------------------------------------ sub rows { my $self = shift; return [ map { $self->row($_) } (0..$self->{ _NROWS }-1) ]; } #------------------------------------------------------------------------ # cols() # # Returns all rows as a reference to a list of rows. #------------------------------------------------------------------------ sub cols { my $self = shift; return [ map { $self->col($_) } (0..$self->{ _NCOLS }-1) ]; } #------------------------------------------------------------------------ # AUTOLOAD # # Provides read access to various internal data members. #------------------------------------------------------------------------ sub AUTOLOAD { my $self = shift; my $item = $AUTOLOAD; $item =~ s/.*:://; return if $item eq 'DESTROY'; if ($item =~ /^(?:data|size|nrows|ncols|overlap|pad)$/) { return $self->{ $item }; } else { return (undef, "no such table method: $item"); } } 1; __END__ =head1 NAME Template::Plugin::Table - Plugin to present data in a table =head1 SYNOPSIS [% USE table(list, rows=n, cols=n, overlap=n, pad=0) %] [% FOREACH item IN table.row(n) %] [% item %] [% END %] [% FOREACH item IN table.col(n) %] [% item %] [% END %] [% FOREACH row IN table.rows %] [% FOREACH item IN row %] [% item %] [% END %] [% END %] [% FOREACH col IN table.cols %] [% col.first %] - [% col.last %] ([% col.size %] entries) [% END %] =head1 DESCRIPTION The C<Table> plugin allows you to format a list of data items into a virtual table. When you create a C<Table> plugin via the C<USE> directive, simply pass a list reference as the first parameter and then specify a fixed number of rows or columns. [% USE Table(list, rows=5) %] [% USE table(list, cols=5) %] The C<Table> plugin name can also be specified in lower case as shown in the second example above. You can also specify an alternative variable name for the plugin as per regular Template Toolkit syntax. [% USE mydata = table(list, rows=5) %] The plugin then presents a table based view on the data set. The data isn't actually reorganised in any way but is available via the C<row()>, C<col()>, C<rows()> and C<cols()> as if formatted into a simple two dimensional table of C<n> rows x C<n> columns. So if we had a sample C<alphabet> list contained the letters 'C<a>' to 'C<z>', the above C<USE> directives would create plugins that represented the following views of the alphabet. [% USE table(alphabet, ... %] rows=5 cols=5 a f k p u z a g m s y b g l q v b h n t z c h m r w c i o u d i n s x d j p v e j o t y e k q w f l r x We can request a particular row or column using the C<row()> and C<col()> methods. [% USE table(alphabet, rows=5) %] [% FOREACH item = table.row(0) %] # [% item %] set to each of [ a f k p u z ] in turn [% END %] [% FOREACH item = table.col(2) %] # [% item %] set to each of [ m n o p q r ] in turn [% END %] Data in rows is returned from left to right, columns from top to bottom. The first row/column is 0. By default, rows or columns that contain empty values will be padded with the undefined value to fill it to the same size as all other rows or columns. For example, the last row (row 4) in the first example would contain the values C<[ e j o t y undef ]>. The Template Toolkit will safely accept these undefined values and print a empty string. You can also use the IF directive to test if the value is set. [% FOREACH item = table.row(4) %] [% IF item %] Item: [% item %] [% END %] [% END %] You can explicitly disable the C<pad> option when creating the plugin to returned shortened rows/columns where the data is empty. [% USE table(alphabet, cols=5, pad=0) %] [% FOREACH item = table.col(4) %] # [% item %] set to each of 'y z' [% END %] The C<rows()> method returns all rows/columns in the table as a reference to a list of rows (themselves list references). The C<row()> methods when called without any arguments calls C<rows()> to return all rows in the table. Ditto for C<cols()> and C<col()>. [% USE table(alphabet, cols=5) %] [% FOREACH row = table.rows %] [% FOREACH item = row %] [% item %] [% END %] [% END %] The Template Toolkit provides the C<first>, C<last> and C<size> virtual methods that can be called on list references to return the first/last entry or the number of entries in a list. The following example shows how we might use this to provide an alphabetical index split into 3 even parts. [% USE table(alphabet, cols=3, pad=0) %] [% FOREACH group = table.col %] [ [% group.first %] - [% group.last %] ([% group.size %] letters) ] [% END %] This produces the following output: [ a - i (9 letters) ] [ j - r (9 letters) ] [ s - z (8 letters) ] We can also use the general purpose C<join> virtual method which joins the items of the list using the connecting string specified. [% USE table(alphabet, cols=5) %] [% FOREACH row = table.rows %] [% row.join(' - ') %] [% END %] Data in the table is ordered downwards rather than across but can easily be transformed on output. For example, to format our data in 5 columns with data ordered across rather than down, we specify C<rows=5> to order the data as such: a f . . b g . c h d i e j and then iterate down through each column (a-e, f-j, etc.) printing the data across. a b c d e f g h i j . . . Example code to do so would be much like the following: [% USE table(alphabet, rows=3) %] [% FOREACH cols = table.cols %] [% FOREACH item = cols %] [% item %] [% END %] [% END %] Output: a b c d e f g h i j . . . In addition to a list reference, the C<Table> plugin constructor may be passed a reference to a L<Template::Iterator> object or subclass thereof. The L<Template::Iterator> L<get_all()|Template::Iterator#get_all()> method is first called on the iterator to return all remaining items. These are then available via the usual Table interface. [% USE DBI(dsn,user,pass) -%] # query() returns an iterator [% results = DBI.query('SELECT * FROM alphabet ORDER BY letter') %] # pass into Table plugin [% USE table(results, rows=8 overlap=1 pad=0) -%] [% FOREACH row = table.cols -%] [% row.first.letter %] - [% row.last.letter %]: [% row.join(', ') %] [% END %] =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/Image.pm 0000444 00000026673 15125513451 0011542 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::Image # # DESCRIPTION # Plugin for encapsulating information about an image. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::Image; use strict; use warnings; use base 'Template::Plugin'; use Template::Exception; use File::Spec; our $VERSION = '3.100'; our $AUTOLOAD; BEGIN { if (eval { require Image::Info; }) { *img_info = \&Image::Info::image_info; } elsif (eval { require Image::Size; }) { *img_info = sub { my $file = shift; my @stuff = Image::Size::imgsize($file); return { "width" => $stuff[0], "height" => $stuff[1], "error" => # imgsize returns either a three letter file type # or an error message as third value (defined($stuff[2]) && length($stuff[2]) > 3 ? $stuff[2] : undef), }; } } else { die(Template::Exception->new("image", "Couldn't load Image::Info or Image::Size: $@")); } } #------------------------------------------------------------------------ # new($context, $name, \%config) # # Create a new Image object. Takes the pathname of the file as # the argument following the context and an optional # hash reference of configuration parameters. #------------------------------------------------------------------------ sub new { my $config = ref($_[-1]) eq 'HASH' ? pop(@_) : { }; my ($class, $context, $name) = @_; my ($root, $file, $type); # name can be a positional or named argument $name = $config->{ name } unless defined $name; return $class->throw('no image file specified') unless defined $name and length $name; # name can be specified as an absolute path or relative # to a root directory if ($root = $config->{ root }) { $file = File::Spec->catfile($root, $name); } else { $file = defined $config->{file} ? $config->{file} : $name; } # Make a note of whether we are using Image::Size or # Image::Info -- at least for the test suite $type = $INC{"Image/Size.pm"} ? "Image::Size" : "Image::Info"; # set a default (empty) alt attribute for tag() $config->{ alt } = '' unless defined $config->{ alt }; # do we want to check to see if file exists? bless { %$config, name => $name, file => $file, root => $root, type => $type, }, $class; } #------------------------------------------------------------------------ # init() # # Calls image_info on $self->{ file } #------------------------------------------------------------------------ sub init { my $self = shift; return $self if $self->{ size }; my $image = img_info($self->{ file }); return $self->throw($image->{ error }) if defined $image->{ error }; @$self{ keys %$image } = values %$image; $self->{ size } = [ $image->{ width }, $image->{ height } ]; $self->{ modtime } = (stat $self->{ file })[10]; return $self; } #------------------------------------------------------------------------ # attr() # # Return the width and height as HTML/XML attributes. #------------------------------------------------------------------------ sub attr { my $self = shift; my $size = $self->size(); return "width=\"$size->[0]\" height=\"$size->[1]\""; } #------------------------------------------------------------------------ # modtime() # # Return last modification time as a time_t: # # [% date.format(image.modtime, "%Y/%m/%d") %] #------------------------------------------------------------------------ sub modtime { my $self = shift; $self->init; return $self->{ modtime }; } #------------------------------------------------------------------------ # tag(\%options) # # Return an XHTML img tag. #------------------------------------------------------------------------ sub tag { my $self = shift; my $options = ref $_[0] eq 'HASH' ? shift : { @_ }; my $tag = '<img src="' . $self->name() . '" ' . $self->attr(); # XHTML spec says that the alt attribute is mandatory, so who # are we to argue? $options->{ alt } = $self->{ alt } unless defined $options->{ alt }; if (%$options) { for my $key (sort keys %$options) { my $escaped = escape( $options->{$key} ); $tag .= qq[ $key="$escaped"]; } } $tag .= ' />'; return $tag; } sub escape { my ($text) = @_; for ($text) { s/&/&/g; s/</</g; s/>/>/g; s/"/"/g; } $text; } sub throw { my ($self, $error) = @_; die (Template::Exception->new('Image', $error)); } sub AUTOLOAD { my $self = shift; (my $a = $AUTOLOAD) =~ s/.*:://; $self->init; return $self->{ $a }; } 1; __END__ =head1 NAME Template::Plugin::Image - Plugin access to image sizes =head1 SYNOPSIS [% USE Image(filename) %] [% Image.width %] [% Image.height %] [% Image.size.join(', ') %] [% Image.attr %] [% Image.tag %] =head1 DESCRIPTION This plugin provides an interface to the L<Image::Info> or L<Image::Size> modules for determining the size of image files. You can specify the plugin name as either 'C<Image>' or 'C<image>'. The plugin object created will then have the same name. The file name of the image should be specified as a positional or named argument. [% # all these are valid, take your pick %] [% USE Image('foo.gif') %] [% USE image('bar.gif') %] [% USE Image 'ping.gif' %] [% USE image(name='baz.gif') %] [% USE Image name='pong.gif' %] A C<root> parameter can be used to specify the location of the image file: [% USE Image(root='/path/to/root', name='images/home.png') %] # image path: /path/to/root/images/home.png # img src: images/home.png In cases where the image path and image url do not match up, specify the file name directly: [% USE Image(file='/path/to/home.png', name='/images/home.png') %] The C<alt> parameter can be used to specify an alternate name for the image, for use in constructing an XHTML element (see the C<tag()> method below). [% USE Image('home.png', alt="Home") %] You can also provide an alternate name for an C<Image> plugin object. [% USE img1 = image 'foo.gif' %] [% USE img2 = image 'bar.gif' %] The C<name> method returns the image file name. [% img1.name %] # foo.gif The C<width> and C<height> methods return the width and height of the image, respectively. The C<size> method returns a reference to a 2 element list containing the width and height. [% USE image 'foo.gif' %] width: [% image.width %] height: [% image.height %] size: [% image.size.join(', ') %] The C<modtime> method returns the modification time of the file in question, suitable for use with the L<Date|Template::Plugin::Date> plugin, for example: [% USE image 'foo.gif' %] [% USE date %] [% date.format(image.modtime, "%B, %e %Y") %] The C<attr> method returns the height and width as HTML/XML attributes. [% USE image 'foo.gif' %] [% image.attr %] Typical output: width="60" height="20" The C<tag> method returns a complete XHTML tag referencing the image. [% USE image 'foo.gif' %] [% image.tag %] Typical output: <img src="foo.gif" width="60" height="20" alt="" /> You can provide any additional attributes that should be added to the XHTML tag. [% USE image 'foo.gif' %] [% image.tag(class="logo" alt="Logo") %] Typical output: <img src="foo.gif" width="60" height="20" alt="Logo" class="logo" /> Note that the C<alt> attribute is mandatory in a strict XHTML C<img> element (even if it's empty) so it is always added even if you don't explicitly provide a value for it. You can do so as an argument to the C<tag> method, as shown in the previous example, or as an argument [% USE image('foo.gif', alt='Logo') %] =head1 CATCHING ERRORS If the image file cannot be found then the above methods will throw an C<Image> error. You can enclose calls to these methods in a C<TRY...CATCH> block to catch any potential errors. [% TRY; image.width; CATCH; error; # print error END %] =head1 USING Image::Info At run time, the plugin tries to load L<Image::Info> in preference to L<Image::Size>. If L<Image::Info> is found, then some additional methods are available, in addition to C<size>, C<width>, C<height>, C<attr>, and C<tag>. These additional methods are named after the elements that L<Image::Info> retrieves from the image itself. The types of methods available depend on the type of image (see L<Image::Info> for more details). These additional methods will always include the following: =head2 file_media_type This is the MIME type that is appropriate for the given file format. The corresponding value is a string like: "C<image/png>" or "C<image/jpeg>". =head2 file_ext The is the suggested file name extension for a file of the given file format. The value is a 3 letter, lowercase string like "C<png>", "C<jpg>". =head2 color_type The value is a short string describing what kind of values the pixels encode. The value can be one of the following: Gray GrayA RGB RGBA CMYK YCbCr CIELab These names can also be prefixed by "C<Indexed->" if the image is composed of indexes into a palette. Of these, only "C<Indexed-RGB>" is likely to occur. (It is similar to the TIFF field PhotometricInterpretation, but this name was found to be too long, so we used the PNG inspired term instead.) =head2 resolution The value of this field normally gives the physical size of the image on screen or paper. When the unit specifier is missing then this field denotes the squareness of pixels in the image. The syntax of this field is: <res> <unit> <xres> "/" <yres> <unit> <xres> "/" <yres> The C<E<lt>resE<gt>>, C<E<lt>xresE<gt>> and C<E<lt>yresE<gt>> fields are numbers. The C<E<lt>unitE<gt>> is a string like C<dpi>, C<dpm> or C<dpcm> (denoting "dots per inch/cm/meter). =head2 SamplesPerPixel This says how many channels there are in the image. For some image formats this number might be higher than the number implied from the C<color_type>. =head2 BitsPerSample This says how many bits are used to encode each of samples. The value is a reference to an array containing numbers. The number of elements in the array should be the same as C<SamplesPerPixel>. =head2 Comment Textual comments found in the file. The value is a reference to an array if there are multiple comments found. =head2 Interlace If the image is interlaced, then this returns the interlace type. =head2 Compression This returns the name of the compression algorithm is used. =head2 Gamma A number indicating the gamma curve of the image (e.g. 2.2) =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin>, L<Image::Info> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/Assert.pm 0000444 00000006664 15125513451 0011757 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::Assert # # DESCRIPTION # Template Toolkit plugin module which allows you to assert that # items fetches from the stash are defined. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 2008-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::Assert; use base 'Template::Plugin'; use strict; use warnings; use Template::Exception; our $VERSION = '3.100'; our $MONAD = 'Template::Monad::Assert'; our $EXCEPTION = 'Template::Exception'; our $AUTOLOAD; sub load { my $class = shift; my $context = shift; my $stash = $context->stash; my $vmethod = sub { $MONAD->new($stash, shift); }; # define .assert vmethods for hash and list objects $context->define_vmethod( hash => assert => $vmethod ); $context->define_vmethod( list => assert => $vmethod ); return $class; } sub new { my ($class, $context, @args) = @_; # create an assert plugin object which will handle simple variable # lookups. return bless { _CONTEXT => $context }, $class; } sub AUTOLOAD { my ($self, @args) = @_; my $item = $AUTOLOAD; $item =~ s/.*:://; return if $item eq 'DESTROY'; # lookup the named values my $stash = $self->{ _CONTEXT }->stash; my $value = $stash->dotop($stash, $item, \@args); if (! defined $value) { die $EXCEPTION->new( assert => "undefined value for $item" ); } return $value; } package Template::Monad::Assert; our $EXCEPTION = 'Template::Exception'; our $AUTOLOAD; sub new { my ($class, $stash, $this) = @_; bless [$stash, $this], $class; } sub AUTOLOAD { my ($self, @args) = @_; my ($stash, $this) = @$self; my $item = $AUTOLOAD; $item =~ s/.*:://; return if $item eq 'DESTROY'; my $value = $stash->dotop($stash, $item, \@args); if (! defined $value) { die $EXCEPTION->new( assert => "undefined value for $item" ); } return $value; } 1; __END__ =head1 NAME Template::Plugin::Assert - trap undefined values =head1 SYNOPSIS [% USE assert %] # throws error if any undefined values are returned [% object.assert.method %] [% hash.assert.key %] [% list.assert.item %] =head1 DESCRIPTION This plugin defines the C<assert> virtual method that can be used to automatically throw errors when undefined values are used. For example, consider this dotop: [% user.name %] If C<user.name> is an undefined value then TT will silently ignore the fact and print nothing. If you C<USE> the C<assert> plugin then you can add the C<assert> vmethod between the C<user> and C<name> elements, like so: [% user.assert.name %] Now, if C<user.name> is an undefined value, an exception will be thrown: assert error - undefined value for name =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 2008-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/Directory.pm 0000444 00000025630 15125513451 0012454 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::Directory # # DESCRIPTION # Plugin for encapsulating information about a file system directory. # # AUTHORS # Michael Stevens <michael@etla.org>, with some mutilations from # Andy Wardley <abw@wardley.org>. # # COPYRIGHT # Copyright (C) 2000-2022 Michael Stevens, Andy Wardley. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::Directory; use strict; use warnings; use Cwd; use File::Spec; use Template::Plugin::File; use base 'Template::Plugin::File'; our $VERSION = '3.100'; #------------------------------------------------------------------------ # new(\%config) # # Constructor method. #------------------------------------------------------------------------ sub new { my $config = ref($_[-1]) eq 'HASH' ? pop(@_) : { }; my ($class, $context, $path) = @_; return $class->throw('no directory specified') unless defined $path and length $path; my $self = $class->SUPER::new($context, $path, $config); my ($dir, @files, $name, $item, $abs, $rel, $check); $self->{ files } = [ ]; $self->{ dirs } = [ ]; $self->{ list } = [ ]; $self->{ _dir } = { }; # don't read directory if 'nostat' or 'noscan' set return $self if $config->{ nostat } || $config->{ noscan }; $self->throw("$path: not a directory") unless $self->{ isdir }; $self->scan($config); return $self; } #------------------------------------------------------------------------ # scan(\%config) # # Scan directory for files and sub-directories. #------------------------------------------------------------------------ sub scan { my ($self, $config) = @_; $config ||= { }; local *DH; my ($dir, @files, $name, $abs, $rel, $item); # set 'noscan' in config if recurse isn't set, to ensure Directories # created don't try to scan deeper $config->{ noscan } = 1 unless $config->{ recurse }; $dir = $self->{ abs }; opendir(DH, $dir) or return $self->throw("$dir: $!"); @files = readdir DH; closedir(DH) or return $self->throw("$dir close: $!"); my ($path, $files, $dirs, $list) = @$self{ qw( path files dirs list ) }; @$files = @$dirs = @$list = (); foreach $name (sort @files) { next if $name =~ /^\./; $abs = File::Spec->catfile($dir, $name); $rel = File::Spec->catfile($path, $name); if (-d $abs) { $item = Template::Plugin::Directory->new(undef, $rel, $config); push(@$dirs, $item); } else { $item = Template::Plugin::File->new(undef, $rel, $config); push(@$files, $item); } push(@$list, $item); $self->{ _dir }->{ $name } = $item; } return ''; } #------------------------------------------------------------------------ # file($filename) # # Fetch a named file from this directory. #------------------------------------------------------------------------ sub file { my ($self, $name) = @_; return $self->{ _dir }->{ $name }; } #------------------------------------------------------------------------ # present($view) # # Present self to a Template::View #------------------------------------------------------------------------ sub present { my ($self, $view) = @_; $view->view_directory($self); } #------------------------------------------------------------------------ # content($view) # # Present directory content to a Template::View. #------------------------------------------------------------------------ sub content { my ($self, $view) = @_; return $self->{ list } unless $view; my $output = ''; foreach my $file (@{ $self->{ list } }) { $output .= $file->present($view); } return $output; } #------------------------------------------------------------------------ # throw($msg) # # Throw a 'Directory' exception. #------------------------------------------------------------------------ sub throw { my ($self, $error) = @_; die (Template::Exception->new('Directory', $error)); } 1; __END__ =head1 NAME Template::Plugin::Directory - Plugin for generating directory listings =head1 SYNOPSIS [% USE dir = Directory(dirpath) %] # files returns list of regular files [% FOREACH file = dir.files %] [% file.name %] [% file.path %] ... [% END %] # dirs returns list of sub-directories [% FOREACH subdir = dir.dirs %] [% subdir.name %] [% subdir.path %] ... [% END %] # list returns both interleaved in order [% FOREACH item = dir.list %] [% IF item.isdir %] Directory: [% item.name %] [% ELSE %] File: [% item.name %] [% END %] [% END %] # define a VIEW to display dirs/files [% VIEW myview %] [% BLOCK file %] File: [% item.name %] [% END %] [% BLOCK directory %] Directory: [% item.name %] [% item.content(myview) | indent -%] [% END %] [% END %] # display directory content using view [% myview.print(dir) %] =head1 DESCRIPTION This Template Toolkit plugin provides a simple interface to directory listings. It is derived from the L<Template::Plugin::File> module and uses L<Template::Plugin::File> object instances to represent files within a directory. Sub-directories within a directory are represented by further C<Template::Plugin::Directory> instances. The constructor expects a directory name as an argument. [% USE dir = Directory('/tmp') %] It then provides access to the files and sub-directories contained within the directory. # regular files (not directories) [% FOREACH file IN dir.files %] [% file.name %] [% END %] # directories only [% FOREACH file IN dir.dirs %] [% file.name %] [% END %] # files and/or directories [% FOREACH file IN dir.list %] [% file.name %] ([% file.isdir ? 'directory' : 'file' %]) [% END %] The plugin constructor will throw a C<Directory> error if the specified path does not exist, is not a directory or fails to C<stat()> (see L<Template::Plugin::File>). Otherwise, it will scan the directory and create lists named 'C<files>' containing files, 'C<dirs>' containing directories and 'C<list>' containing both files and directories combined. The C<nostat> option can be set to disable all file/directory checks and directory scanning. Each file in the directory will be represented by a L<Template::Plugin::File> object instance, and each directory by another C<Template::Plugin::Directory>. If the C<recurse> flag is set, then those directories will contain further nested entries, and so on. With the C<recurse> flag unset, as it is by default, then each is just a place marker for the directory and does not contain any further content unless its C<scan()> method is explicitly called. The C<isdir> flag can be tested against files and/or directories, returning true if the item is a directory or false if it is a regular file. [% FOREACH file = dir.list %] [% IF file.isdir %] * Directory: [% file.name %] [% ELSE %] * File: [% file.name %] [% END %] [% END %] This example shows how you might walk down a directory tree, displaying content as you go. With the recurse flag disabled, as is the default, we need to explicitly call the C<scan()> method on each directory, to force it to lookup files and further sub-directories contained within. [% USE dir = Directory(dirpath) %] * [% dir.path %] [% INCLUDE showdir %] [% BLOCK showdir -%] [% FOREACH file = dir.list -%] [% IF file.isdir -%] * [% file.name %] [% file.scan -%] [% INCLUDE showdir dir=file FILTER indent(4) -%] [% ELSE -%] - [% f.name %] [% END -%] [% END -%] [% END %] This example is adapted (with some re-formatting for clarity) from a test in F<t/directry.t> which produces the following output: * test/dir - file1 - file2 * sub_one - bar - foo * sub_two - waz.html - wiz.html - xyzfile The C<recurse> flag can be set (disabled by default) to cause the constructor to automatically recurse down into all sub-directories, creating a new C<Template::Plugin::Directory> object for each one and filling it with any further content. In this case there is no need to explicitly call the C<scan()> method. [% USE dir = Directory(dirpath, recurse=1) %] ... [% IF file.isdir -%] * [% file.name %] [% INCLUDE showdir dir=file FILTER indent(4) -%] [% ELSE -%] ... The directory plugin also provides support for views. A view can be defined as a C<VIEW ... END> block and should contain C<BLOCK> definitions for files ('C<file>') and directories ('C<directory>'). [% VIEW myview %] [% BLOCK file %] - [% item.name %] [% END %] [% BLOCK directory %] * [% item.name %] [% item.content(myview) FILTER indent %] [% END %] [% END %] The view C<print()> method can then be called, passing the C<Directory> object as an argument. [% USE dir = Directory(dirpath, recurse=1) %] [% myview.print(dir) %] When a directory is presented to a view, either as C<[% myview.print(dir) %]> or C<[% dir.present(view) %]>, then the C<directory> C<BLOCK> within the C<myview> C<VIEW> is processed. The C<item> variable will be set to alias the C<Directory> object. [% BLOCK directory %] * [% item.name %] [% item.content(myview) FILTER indent %] [% END %] In this example, the directory name is first printed and the content(view) method is then called to present each item within the directory to the view. Further directories will be mapped to the C<directory> block, and files will be mapped to the C<file> block. With the recurse option disabled, as it is by default, the C<directory> block should explicitly call a C<scan()> on each directory. [% VIEW myview %] [% BLOCK file %] - [% item.name %] [% END %] [% BLOCK directory %] * [% item.name %] [% item.scan %] [% item.content(myview) FILTER indent %] [% END %] [% END %] [% USE dir = Directory(dirpath) %] [% myview.print(dir) %] =head1 AUTHORS Michael Stevens wrote the original Directory plugin on which this is based. Andy Wardley split it into separate L<File|Template::Plugin::File> and L<Directory|Template::Plugin::Directory> plugins, added some extra code and documentation for C<VIEW> support, and made a few other minor tweaks. =head1 COPYRIGHT Copyright (C) 2000-2022 Michael Stevens, Andy Wardley. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin>, L<Template::Plugin::File>, L<Template::View> 5.32/Template/Plugin/HTML.pm 0000444 00000013573 15125513451 0011257 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::HTML # # DESCRIPTION # Template Toolkit plugin providing useful functionality for generating # HTML. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::HTML; use strict; use warnings; use base 'Template::Plugin'; our $VERSION = '3.100'; sub new { my ($class, $context, @args) = @_; my $hash = ref $args[-1] eq 'HASH' ? pop @args : { }; bless { _SORTED => $hash->{ sorted } || 0, attributes => $hash->{ attributes } || $hash->{ attrs } || { }, }, $class; } sub element { my ($self, $name, $attr) = @_; ($name, $attr) = %$name if ref $name eq 'HASH'; return '' unless defined $name and length $name; $attr = $self->attributes($attr); $attr = " $attr" if $attr; return "<$name$attr>"; } sub closed_element { my ($self, $name, $attr) = @_; ($name, $attr) = %$name if ref $name eq 'HASH'; return '' unless defined $name and length $name; $attr = $self->attributes( $attr ); $attr = " $attr" if $attr; return "<$name$attr />"; } sub attributes { my ($self, $hash) = @_; $hash ||= $self->{ attributes }; return '' unless ref $hash eq 'HASH'; my @keys = keys %$hash; @keys = sort @keys if $self->{ _SORTED }; join(' ', map { "$_=\"" . $self->escape( $hash->{ $_ } ) . '"'; } @keys); } sub add_attributes { my ($self, $attr) = @_; return unless ref $attr eq 'HASH'; my $cur = $self->{ attributes }; for (keys %{$attr}) { $cur->{$_} = exists $cur->{$_} ? $cur->{$_} . " $attr->{$_}" : $attr->{$_}; } return; } *add_attribute = \&add_attributes; *add = \&add_attributes; sub replace_attributes { my ($self, $attr) = @_; return unless ref $attr eq 'HASH'; my $cur = $self->{ attributes }; for (keys %{$attr}) { $cur->{$_} = $attr->{$_}; } return; } *replace_attribute = \&replace_attributes; *replace = \&replace_attributes; sub clear_attributes { my $self = shift; $self->{ attributes } = { }; return; } sub escape { my ($self, $text) = @_; for ($text) { s/&/&/g; s/</</g; s/>/>/g; s/"/"/g; } $text; } sub url { my ($self, $text) = @_; return undef unless defined $text; $text =~ s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg; return $text; } 1; __END__ =head1 NAME Template::Plugin::HTML - Plugin to create HTML elements =head1 SYNOPSIS [% USE HTML %] [% HTML.escape("if (a < b && c > d) ..." %] [% HTML.element(table => { border => 1, cellpadding => 2 }) %] [% HTML.attributes(border => 1, cellpadding => 2) %] =head1 DESCRIPTION The C<HTML> plugin is a very basic plugin, implementing a few useful methods for generating HTML. =head1 METHODS =head2 escape(text) Returns the source text with any HTML reserved characters such as C<E<lt>>, C<E<gt>>, etc., correctly escaped to their entity equivalents. =head2 attributes(hash) Returns the elements of the hash array passed by reference correctly formatted (e.g. values quoted and correctly escaped) as attributes for an HTML element. =head2 add_attribute(attributes) This provides a way to incrementally add attributes to the object. The values passed in are stored in the object. Calling L<element> with just a tag or L<attributes> without an parameters will used the saved attributes. USE tag = HTML; tag.add_attributes( { class => 'navbar' } ); tag.add_attributes( { id => 'foo' } ); tag.add_attributes( { class => 'active' } ); tag.element( 'li' ); # <li class="navbar active" id="foo"> This method has two aliases: add_attribute() and add(). =head2 replace_attribute(attributes) This will replace an attribute value instead of add to existing. USE tag = HTML; tag.add_attributes( { class => 'navbar' } ); tag.add_attributes( { id => 'foo' } ); tag.replace_attributes( { class => 'active' } ); tag.element( 'li' ); # <li class="active" id="foo"> This method has two aliases: replace_attribute() and replace(). =head2 clear_attributes Clears any saved attributes =head2 element(type, attributes) Generates an HTML element of the specified type and with the attributes provided as an optional hash array reference as the second argument or as named arguments. [% HTML.element(table => { border => 1, cellpadding => 2 }) %] [% HTML.element('table', border=1, cellpadding=2) %] [% HTML.element(table => attribs) %] =head1 DEBUGGING The HTML plugin accepts a C<sorted> option as a constructor argument which, when set to any true value, causes the attributes generated by the C<attributes()> method (either directly or via C<element()>) to be returned in sorted order. Order of attributes isn't important in HTML, but this is provided mainly for the purposes of debugging where it is useful to have attributes generated in a deterministic order rather than whatever order the hash happened to feel like returning the keys in. [% USE HTML(sorted=1) %] [% HTML.element( foo => { charlie => 1, bravo => 2, alpha => 3 } ) %] generates: <foo alpha="3" bravo="2" charlie="1"> =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/Date.pm 0000444 00000026340 15125513451 0011364 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::Date # # DESCRIPTION # # Plugin to generate formatted date strings. # # AUTHORS # Thierry-Michel Barral <kktos@electron-libre.com> # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 2000-2022 Thierry-Michel Barral, Andy Wardley. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::Date; use strict; use warnings; use base 'Template::Plugin'; use POSIX (); use Config (); use constant HAS_SETLOCALE => $Config::Config{d_setlocale}; our $VERSION = '3.100'; our $FORMAT = '%H:%M:%S %d-%b-%Y'; # default strftime() format our @LOCALE_SUFFIX = qw( .ISO8859-1 .ISO_8859-15 .US-ASCII .UTF-8 ); #------------------------------------------------------------------------ # new(\%options) #------------------------------------------------------------------------ sub new { my ($class, $context, $params) = @_; bless { $params ? %$params : () }, $class; } #------------------------------------------------------------------------ # now() # # Call time() to return the current system time in seconds since the epoch. #------------------------------------------------------------------------ sub now { return time(); } sub _strftime { my ( @args ) = @_; my $str = POSIX::strftime( @args ); # POSIX.pm now utf8-flags the output of strftime since perl 5.22 if ( $] < 5.022 ) { require Encode; Encode::_utf8_on( $str ); } return $str; } #------------------------------------------------------------------------ # format() # format($time) # format($time, $format) # format($time, $format, $locale) # format($time, $format, $locale, $gmt_flag) # format(\%named_params); # # Returns a formatted time/date string for the specified time, $time, # (or the current system time if unspecified) using the $format, $locale, # and $gmt values specified as arguments or internal values set defined # at construction time). Specifying a Perl-true value for $gmt will # override the local time zone and force the output to be for GMT. # Any or all of the arguments may be specified as named parameters which # get passed as a hash array reference as the final argument. # ------------------------------------------------------------------------ sub format { my $self = shift; my $params = ref($_[$#_]) eq 'HASH' ? pop(@_) : { }; my $time = shift(@_); $time = $params->{ time } || $self->{ time } || $self->now() if !defined $time; my $format = @_ ? shift(@_) : ($params->{ format } || $self->{ format } || $FORMAT); my $locale = @_ ? shift(@_) : ($params->{ locale } || $self->{ locale }); my $gmt = @_ ? shift(@_) : ($params->{ gmt } || $self->{ gmt }); my $offset = @_ ? shift(@_) : ( $params->{ use_offset } || $self->{ use_offset }); my (@date, $datestr); if ($time =~ /^-?\d+$/) { # $time is now in seconds since epoch if ($gmt) { @date = (gmtime($time))[ 0 .. ( $offset ? 6 : 8 ) ]; } else { @date = (localtime($time))[ 0 .. ( $offset ? 6 : 8 ) ]; } } else { # if $time is numeric, then we assume it's seconds since the epoch # otherwise, we try to parse it as either a 'Y:M:D H:M:S' or a # 'H:M:S D:M:Y' string my @parts = (split(/\D/, $time)); if (@parts >= 6) { if (length($parts[0]) == 4) { # year is first; assume 'Y:M:D H:M:S' @date = @parts[reverse 0..5]; } else { # year is last; assume 'H:M:S D:M:Y' @date = @parts[2,1,0,3..5]; } } if (!@date) { return ( undef, Template::Exception->new( 'date', "bad time/date string: " . "expects 'h:m:s d:m:y' got: '$time'" ) ); } $date[4] -= 1; # correct month number 1-12 to range 0-11 $date[5] -= 1900; # convert absolute year to years since 1900 $time = &POSIX::mktime(@date); if ($offset) { push @date, $gmt ? (gmtime($time))[6..8] : (localtime($time))[6..8]; } } if ($locale) { # format the date in a specific locale, saving and subsequently # restoring the current locale. my $old_locale = HAS_SETLOCALE ? &POSIX::setlocale(&POSIX::LC_ALL) : undef; # some systems expect locales to have a particular suffix for my $suffix ('', @LOCALE_SUFFIX) { my $try_locale = $locale.$suffix; my $setlocale = HAS_SETLOCALE ? &POSIX::setlocale(&POSIX::LC_ALL, $try_locale) : undef; if (defined $setlocale && $try_locale eq $setlocale) { $locale = $try_locale; last; } } $datestr = _strftime($format, @date); &POSIX::setlocale(&POSIX::LC_ALL, $old_locale) if HAS_SETLOCALE; } else { $datestr = _strftime($format, @date); } return $datestr; } sub calc { my $self = shift; eval { require "Date/Calc.pm" }; $self->throw("failed to load Date::Calc: $@") if $@; return Template::Plugin::Date::Calc->new('no context'); } sub manip { my $self = shift; eval { require "Date/Manip.pm" }; $self->throw("failed to load Date::Manip: $@") if $@; return Template::Plugin::Date::Manip->new('no context'); } sub throw { my $self = shift; die (Template::Exception->new('date', join(', ', @_))); } package Template::Plugin::Date::Calc; use base qw( Template::Plugin ); our $AUTOLOAD; *throw = \&Template::Plugin::Date::throw; sub AUTOLOAD { my $self = shift; my $method = $AUTOLOAD; $method =~ s/.*:://; return if $method eq 'DESTROY'; my $sub = \&{"Date::Calc::$method"}; $self->throw("no such Date::Calc method: $method") unless $sub; &$sub(@_); } package Template::Plugin::Date::Manip; use base qw( Template::Plugin ); our $AUTOLOAD; *throw = \&Template::Plugin::Date::throw; sub AUTOLOAD { my $self = shift; my $method = $AUTOLOAD; $method =~ s/.*:://; return if $method eq 'DESTROY'; my $sub = \&{"Date::Manip::$method"}; $self->throw("no such Date::Manip method: $method") unless $sub; &$sub(@_); } 1; __END__ =head1 NAME Template::Plugin::Date - Plugin to generate formatted date strings =head1 SYNOPSIS [% USE date %] # use current time and default format [% date.format %] # specify time as seconds since epoch # or as a 'h:m:s d-m-y' or 'y-m-d h:m:s' string [% date.format(960973980) %] [% date.format('4:20:36 21/12/2000') %] [% date.format('2000/12/21 4:20:36') %] # specify format [% date.format(mytime, '%H:%M:%S') %] # specify locale [% date.format(date.now, '%a %d %b %y', 'en_GB') %] # named parameters [% date.format(mytime, format = '%H:%M:%S') %] [% date.format(locale = 'en_GB') %] [% date.format(time = date.now, format = '%H:%M:%S', locale = 'en_GB' use_offset = 1) %] # specify default format to plugin [% USE date(format = '%H:%M:%S', locale = 'de_DE') %] [% date.format %] ... =head1 DESCRIPTION The C<Date> plugin provides an easy way to generate formatted time and date strings by delegating to the C<POSIX> C<strftime()> routine. The plugin can be loaded via the familiar USE directive. [% USE date %] This creates a plugin object with the default name of 'C<date>'. An alternate name can be specified as such: [% USE myname = date %] The plugin provides the C<format()> method which accepts a time value, a format string and a locale name. All of these parameters are optional with the current system time, default format ('C<%H:%M:%S %d-%b-%Y>') and current locale being used respectively, if undefined. Default values for the time, format and/or locale may be specified as named parameters in the C<USE> directive. [% USE date(format = '%a %d-%b-%Y', locale = 'fr_FR') %] When called without any parameters, the C<format()> method returns a string representing the current system time, formatted by C<strftime()> according to the default format and for the default locale (which may not be the current one, if locale is set in the C<USE> directive). [% date.format %] The plugin allows a time/date to be specified as seconds since the epoch, as is returned by C<time()>. File last modified: [% date.format(filemod_time) %] The time/date can also be specified as a string of the form C<h:m:s d/m/y> or C<y/m/d h:m:s>. Any of the characters : / - or space may be used to delimit fields. [% USE day = date(format => '%A', locale => 'en_GB') %] [% day.format('4:20:00 9-13-2000') %] Output: Tuesday A format string can also be passed to the C<format()> method, and a locale specification may follow that. [% date.format(filemod, '%d-%b-%Y') %] [% date.format(filemod, '%d-%b-%Y', 'en_GB') %] A fourth parameter allows you to force output in GMT, in the case of seconds-since-the-epoch input: [% date.format(filemod, '%d-%b-%Y', 'en_GB', 1) %] Note that in this case, if the local time is not GMT, then also specifying 'C<%Z>' (time zone) in the format parameter will lead to an extremely misleading result. To maintain backwards compatibility, using the C<%z> placeholder in the format string (to output the UTC offset) currently requires the C<use_offset> parameter to be set to a true value. This can also be passed as the fifth parameter to format (but the former will probably be clearer). Any or all of these parameters may be named. Positional parameters should always be in the order C<($time, $format, $locale)>. [% date.format(format => '%H:%M:%S') %] [% date.format(time => filemod, format => '%H:%M:%S') %] [% date.format(mytime, format => '%H:%M:%S') %] [% date.format(mytime, format => '%H:%M:%S', locale => 'fr_FR') %] [% date.format(mytime, format => '%H:%M:%S', gmt => 1) %] ...etc... The C<now()> method returns the current system time in seconds since the epoch. [% date.format(date.now, '%A') %] The C<calc()> method can be used to create an interface to the C<Date::Calc> module (if installed on your system). [% calc = date.calc %] [% calc.Monday_of_Week(22, 2001).join('/') %] The C<manip()> method can be used to create an interface to the C<Date::Manip> module (if installed on your system). [% manip = date.manip %] [% manip.UnixDate("Noon Yesterday","%Y %b %d %H:%M") %] =head1 AUTHORS Thierry-Michel Barral wrote the original plugin. Andy Wardley provided some minor fixups/enhancements, a test script and documentation. Mark D. Mills cloned C<Date::Manip> from the C<Date::Calc> sub-plugin. =head1 COPYRIGHT Copyright (C) 2000-2022 Thierry-Michel Barral, Andy Wardley. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin>, L<POSIX> 5.32/Template/Plugin/Iterator.pm 0000444 00000003721 15125513451 0012276 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::Iterator # # DESCRIPTION # # Plugin to create a Template::Iterator from a list of items and optional # configuration parameters. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 2000-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::Iterator; use strict; use warnings; use base 'Template::Plugin'; use Template::Iterator; our $VERSION = '3.100'; #------------------------------------------------------------------------ # new($context, \@data, \%args) #------------------------------------------------------------------------ sub new { my $class = shift; my $context = shift; Template::Iterator->new(@_); } 1; __END__ =head1 NAME Template::Plugin::Iterator - Plugin to create iterators (Template::Iterator) =head1 SYNOPSIS [% USE iterator(list, args) %] [% FOREACH item = iterator %] [% '<ul>' IF iterator.first %] <li>[% item %] [% '</ul>' IF iterator.last %] [% END %] =head1 DESCRIPTION The iterator plugin provides a way to create a L<Template::Iterator> object to iterate over a data set. An iterator is implicitly automatically by the L<FOREACH> directive. This plugin allows the iterator to be explicitly created with a given name. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin>, L<Template::Iterator> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/Wrap.pm 0000444 00000006265 15125513451 0011424 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::Wrap # # DESCRIPTION # Plugin for wrapping text via the Text::Wrap module. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::Wrap; use strict; use warnings; use base 'Template::Plugin'; use Text::Wrap; our $VERSION = '3.100'; sub new { my ($class, $context, $format) = @_;; $context->define_filter('wrap', [ \&wrap_filter_factory => 1 ]); return \&tt_wrap; } sub tt_wrap { my $text = shift; my $width = shift || 72; my $itab = shift; my $ntab = shift; $itab = '' unless defined $itab; $ntab = '' unless defined $ntab; $Text::Wrap::columns = $width; Text::Wrap::wrap($itab, $ntab, $text); } sub wrap_filter_factory { my ($context, @args) = @_; return sub { my $text = shift; tt_wrap($text, @args); } } 1; __END__ =head1 NAME Template::Plugin::Wrap - Plugin interface to Text::Wrap =head1 SYNOPSIS [% USE wrap %] # call wrap subroutine [% wrap(mytext, width, initial_tab, subsequent_tab) %] # or use wrap FILTER [% mytext FILTER wrap(width, initital_tab, subsequent_tab) %] =head1 DESCRIPTION This plugin provides an interface to the L<Text::Wrap> module which provides simple paragraph formatting. It defines a C<wrap> subroutine which can be called, passing the input text and further optional parameters to specify the page width (default: 72), and tab characters for the first and subsequent lines (no defaults). [% USE wrap %] [% text = BLOCK %] First, attach the transmutex multiplier to the cross-wired quantum homogeniser. [% END %] [% wrap(text, 40, '* ', ' ') %] Output: * First, attach the transmutex multiplier to the cross-wired quantum homogeniser. It also registers a C<wrap> filter which accepts the same three optional arguments but takes the input text directly via the filter input. Example 1: [% FILTER bullet = wrap(40, '* ', ' ') -%] First, attach the transmutex multiplier to the cross-wired quantum homogeniser. [%- END %] Output: * First, attach the transmutex multiplier to the cross-wired quantum homogeniser. Example 2: [% FILTER bullet -%] Then remodulate the shield to match the harmonic frequency, taking care to correct the phase difference. [% END %] Output: * Then remodulate the shield to match the harmonic frequency, taking care to correct the phase difference. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> The L<Text::Wrap> module was written by David Muir Sharnoff with help from Tim Pierce and many others. =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin>, L<Text::Wrap> 5.32/Template/Plugin/URL.pm 0000444 00000013251 15125513451 0011146 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::URL # # DESCRIPTION # Template Toolkit Plugin for constructing URL's from a base stem # and adaptable parameters. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 2000-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::URL; use strict; use warnings; use base 'Template::Plugin'; our $VERSION = '3.100'; our $JOINT = '&'; #------------------------------------------------------------------------ # new($context, $baseurl, \%url_params) # # Constructor method which returns a sub-routine closure for constructing # complex URL's from a base part and hash of additional parameters. #------------------------------------------------------------------------ sub new { my ($class, $context, $base, $args) = @_; $args ||= { }; return sub { my $newbase = shift unless ref $_[0] eq 'HASH'; my $newargs = shift || { }; my $combo = { %$args, %$newargs }; my $urlargs = join( $JOINT, map { args($_, $combo->{ $_ }) } grep { defined $combo->{ $_ } && length $combo->{ $_ } } sort keys %$combo ); my $query = $newbase || $base || ''; $query .= '?' if length $query && length $urlargs; $query .= $urlargs if length $urlargs; return $query } } sub args { my ($key, $val) = @_; $key = escape($key); return map { "$key=" . escape($_); } ref $val eq 'ARRAY' ? @$val : $val; } #------------------------------------------------------------------------ # escape($url) # # URL-encode data. Borrowed with minor modifications from CGI.pm. # Kudos to Lincold Stein. #------------------------------------------------------------------------ sub escape { my $toencode = shift; return undef unless defined($toencode); utf8::encode($toencode); $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg; return $toencode; } 1; __END__ =head1 NAME Template::Plugin::URL - Plugin to construct complex URLs =head1 SYNOPSIS [% USE url('/cgi-bin/foo.pl') %] [% url(debug = 1, id = 123) %] # ==> /cgi/bin/foo.pl?debug=1&id=123 [% USE mycgi = url('/cgi-bin/bar.pl', mode='browse', debug=1) %] [% mycgi %] # ==> /cgi/bin/bar.pl?mode=browse&debug=1 [% mycgi(mode='submit') %] # ==> /cgi/bin/bar.pl?mode=submit&debug=1 [% mycgi(debug='d2 p0', id='D4-2k[4]') %] # ==> /cgi-bin/bar.pl?mode=browse&debug=d2%20p0&id=D4-2k%5B4%5D =head1 DESCRIPTION The C<URL> plugin can be used to construct complex URLs from a base stem and a hash array of additional query parameters. The constructor should be passed a base URL and optionally, a hash array reference of default parameters and values. Used from with a template, it would look something like the following: [% USE url('http://www.somewhere.com/cgi-bin/foo.pl') %] [% USE url('/cgi-bin/bar.pl', mode='browse') %] [% USE url('/cgi-bin/baz.pl', mode='browse', debug=1) %] When the plugin is then called without any arguments, the default base and parameters are returned as a formatted query string. [% url %] For the above three examples, these will produce the following outputs: http://www.somewhere.com/cgi-bin/foo.pl /cgi-bin/bar.pl?mode=browse /cgi-bin/baz.pl?mode=browse&debug=1 Note that additional parameters are separated by 'C<&>' rather than simply 'C<&>'. This is the correct behaviour for HTML pages but is, unfortunately, incorrect when creating URLs that do not need to be encoded safely for HTML. This is likely to be corrected in a future version of the plugin (most probably with TT3). In the mean time, you can set C<$Template::Plugin::URL::JOINT> to C<&> to get the correct behaviour. Additional parameters may be also be specified to the URL: [% url(mode='submit', id='wiz') %] Which, for the same three examples, produces: http://www.somewhere.com/cgi-bin/foo.pl?mode=submit&id=wiz /cgi-bin/bar.pl?mode=browse&id=wiz /cgi-bin/baz.pl?mode=browse&debug=1&id=wiz A new base URL may also be specified as the first option: [% url('/cgi-bin/waz.pl', test=1) %] producing /cgi-bin/waz.pl?test=1 /cgi-bin/waz.pl?mode=browse&test=1 /cgi-bin/waz.pl?mode=browse&debug=1&test=1 The ordering of the parameters is non-deterministic due to fact that Perl's hashes themselves are unordered. This isn't a problem as the ordering of CGI parameters is insignificant (to the best of my knowledge). All values will be properly escaped thanks to some code borrowed from Lincoln Stein's C<CGI> module. e.g. [% USE url('/cgi-bin/woz.pl') %] [% url(name="Elrich von Benjy d'Weiro") %] Here the space and "C<'>" single quote characters are escaped in the output: /cgi-bin/woz.pl?name=Elrich%20von%20Benjy%20d%27Weiro An alternate name may be provided for the plugin at construction time as per regular Template Toolkit syntax. [% USE mycgi = url('cgi-bin/min.pl') %] [% mycgi(debug=1) %] =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/Procedural.pm 0000444 00000007141 15125513451 0012605 0 ustar 00 #============================================================================== # # Template::Plugin::Procedural # # DESCRIPTION # A Template Plugin to provide a Template Interface to Data::Dumper # # AUTHOR # Mark Fowler <mark@twoshortplanks.com> # # COPYRIGHT # Copyright (C) 2002 Mark Fowler. All Rights Reserved # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================== package Template::Plugin::Procedural; use strict; use warnings; use base 'Template::Plugin'; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $AUTOLOAD; #------------------------------------------------------------------------ # load #------------------------------------------------------------------------ sub load { my ($class, $context) = @_; # create a proxy namespace that will be used for objects my $proxy = "Template::Plugin::" . $class; # okay, in our proxy create the autoload routine that will # call the right method in the real class no strict "refs"; unless( defined( *{ $proxy . "::AUTOLOAD" } ) ) { *{ $proxy . "::AUTOLOAD" } = sub { # work out what the method is called $AUTOLOAD =~ s!^.*::!!; print STDERR "Calling '$AUTOLOAD' in '$class'\n" if $DEBUG; # look up the sub for that method (but in a OO way) my $uboat = $class->can($AUTOLOAD); # if it existed call it as a subroutine, not as a method if ($uboat) { shift @_; return $uboat->(@_); } print STDERR "Eeek, no such method '$AUTOLOAD'\n" if $DEBUG; return ""; }; } # create a simple new method that simply returns a blessed # scalar as the object. unless( defined( *{ $proxy . "::new" } ) ) { *{ $proxy . "::new" } = sub { my $this; return bless \$this, $_[0]; }; } return $proxy; } 1; __END__ =head1 NAME Template::Plugin::Procedural - Base class for procedural plugins =head1 SYNOPSIS package Template::Plugin::LWPSimple; use base qw(Template::Plugin::Procedural); use LWP::Simple; # exports 'get' 1; [% USE LWPSimple %] [% LWPSimple.get("http://www.tt2.org/") %] =head1 DESCRIPTION C<Template::Plugin::Procedural> is a base class for Template Toolkit plugins that causes defined subroutines to be called directly rather than as a method. Essentially this means that subroutines will not receive the class name or object as its first argument. This is most useful when creating plugins for modules that normally work by exporting subroutines that do not expect such additional arguments. Despite the fact that subroutines will not be called in an OO manner, inheritance still function as normal. A class that uses C<Template::Plugin::Procedural> can be subclassed and both subroutines defined in the subclass and subroutines defined in the original class will be available to the Template Toolkit and will be called without the class/object argument. =head1 AUTHOR Mark Fowler E<lt>mark@twoshortplanks.comE<gt> L<http://www.twoshortplanks.com> =head1 COPYRIGHT Copyright (C) 2002 Mark Fowler E<lt>mark@twoshortplanks.comE<gt> This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template>, L<Template::Plugin> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/String.pm 0000444 00000043305 15125513451 0011755 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::String # # DESCRIPTION # Template Toolkit plugin to implement a basic String object. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 2001-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::String; use strict; use warnings; use base 'Template::Plugin'; use Template::Exception; use overload q|""| => "text", fallback => 1; our $VERSION = '3.100'; our $ERROR = ''; *centre = \*center; *append = \*push; *prepend = \*unshift; #------------------------------------------------------------------------ sub new { my ($class, @args) = @_; my $context = ref $class ? undef : shift(@args); my $config = @args && ref $args[-1] eq 'HASH' ? pop(@args) : { }; $class = ref($class) || $class; my $text = defined $config->{ text } ? $config->{ text } : (@args ? shift(@args) : ''); # print STDERR "text: [$text]\n"; # print STDERR "class: [$class]\n"; my $self = bless { text => $text, filters => [ ], _CONTEXT => $context, }, $class; my $filter = $config->{ filter } || $config->{ filters }; # install any output filters specified as 'filter' or 'filters' option $self->output_filter($filter) if $filter; return $self; } sub text { my $self = shift; return $self->{ text } unless @{ $self->{ filters } }; my $text = $self->{ text }; my $context = $self->{ _CONTEXT }; foreach my $dispatch (@{ $self->{ filters } }) { my ($name, $args) = @$dispatch; my $code = $context->filter($name, $args) || $self->throw($context->error()); $text = &$code($text); } return $text; } sub copy { my $self = shift; $self->new($self->{ text }); } sub throw { my $self = shift; die (Template::Exception->new('String', join('', @_))); } #------------------------------------------------------------------------ # output_filter($filter) # # Install automatic output filter(s) for the string. $filter can a list: # [ 'name1', 'name2' => [ ..args.. ], name4 => { ..args.. } ] or a hash # { name1 => '', name2 => [ args ], name3 => { args } } #------------------------------------------------------------------------ sub output_filter { my ($self, $filter) = @_; my ($name, $args, $dispatch); my $filters = $self->{ filters }; my $count = 0; if (ref $filter eq 'HASH') { $filter = [ %$filter ]; } elsif (ref $filter ne 'ARRAY') { $filter = [ split(/\s*\W+\s*/, $filter) ]; } while (@$filter) { $name = shift @$filter; # args may follow as a reference (or empty string, e.g. { foo => '' } if (@$filter && (ref($filter->[0]) || ! length $filter->[0])) { $args = shift @$filter; if ($args) { $args = [ $args ] unless ref $args eq 'ARRAY'; } else { $args = [ ]; } } else { $args = [ ]; } # $self->DEBUG("adding output filter $name(@$args)\n"); push(@$filters, [ $name, $args ]); $count++; } return ''; } #------------------------------------------------------------------------ sub push { my $self = shift; $self->{ text } .= join('', @_); return $self; } sub unshift { my $self = shift; $self->{ text } = join('', @_) . $self->{ text }; return $self; } sub pop { my $self = shift; my $strip = shift || return $self; $self->{ text } =~ s/$strip$//; return $self; } sub shift { my $self = shift; my $strip = shift || return $self; $self->{ text } =~ s/^$strip//; return $self; } #------------------------------------------------------------------------ sub center { my ($self, $width) = @_; my $text = $self->{ text }; my $len = length $text; $width ||= 0; if ($len < $width) { my $lpad = int(($width - $len) / 2); my $rpad = $width - $len - $lpad; $self->{ text } = (' ' x $lpad) . $self->{ text } . (' ' x $rpad); } return $self; } sub left { my ($self, $width) = @_; my $len = length $self->{ text }; $width ||= 0; $self->{ text } .= (' ' x ($width - $len)) if $width > $len; return $self; } sub right { my ($self, $width) = @_; my $len = length $self->{ text }; $width ||= 0; $self->{ text } = (' ' x ($width - $len)) . $self->{ text } if $width > $len; return $self; } sub format { my ($self, $format) = @_; $format = '%s' unless defined $format; $self->{ text } = sprintf($format, $self->{ text }); return $self; } sub filter { my ($self, $name, @args) = @_; my $context = $self->{ _CONTEXT }; my $code = $context->filter($name, \@args) || $self->throw($context->error()); return &$code($self->{ text }); } #------------------------------------------------------------------------ sub upper { my $self = CORE::shift; $self->{ text } = uc $self->{ text }; return $self; } sub lower { my $self = CORE::shift; $self->{ text } = lc $self->{ text }; return $self; } sub capital { my $self = CORE::shift; $self->{ text } =~ s/^(.)/\U$1/; return $self; } #------------------------------------------------------------------------ sub chop { my $self = CORE::shift; chop $self->{ text }; return $self; } sub chomp { my $self = CORE::shift; chomp $self->{ text }; return $self; } sub trim { my $self = CORE::shift; for ($self->{ text }) { s/^\s+//; s/\s+$//; } return $self; } sub collapse { my $self = CORE::shift; for ($self->{ text }) { s/^\s+//; s/\s+$//; s/\s+/ /g } return $self; } #------------------------------------------------------------------------ sub length { my $self = CORE::shift; return length $self->{ text }; } sub truncate { my ($self, $length, $suffix) = @_; return $self unless defined $length; $suffix ||= ''; return $self if CORE::length $self->{ text } <= $length; $self->{ text } = CORE::substr($self->{ text }, 0, $length - CORE::length($suffix)) . $suffix; return $self; } sub substr { my ($self, $offset, $length, $replacement) = @_; $offset ||= 0; if(defined $length) { if (defined $replacement) { my $removed = CORE::substr( $self->{text}, $offset, $length ); CORE::substr( $self->{text}, $offset, $length ) = $replacement; return $removed; } else { return CORE::substr( $self->{text}, $offset, $length ); } } else { return CORE::substr( $self->{text}, $offset ); } } sub repeat { my ($self, $n) = @_; return $self unless defined $n; $self->{ text } = $self->{ text } x $n; return $self; } sub replace { my ($self, $search, $replace) = @_; return $self unless defined $search; $replace = '' unless defined $replace; $self->{ text } =~ s/$search/$replace/g; return $self; } sub remove { my ($self, $search) = @_; $search = '' unless defined $search; $self->{ text } =~ s/$search//g; return $self; } sub split { my $self = CORE::shift; my $split = CORE::shift; my $limit = CORE::shift || 0; $split = '\s+' unless defined $split; return [ split($split, $self->{ text }, $limit) ]; } sub search { my ($self, $pattern) = @_; return $self->{ text } =~ /$pattern/; } sub equals { my ($self, $comparison) = @_; return $self->{ text } eq $comparison; } 1; __END__ =head1 NAME Template::Plugin::String - Object oriented interface for string manipulation =head1 SYNOPSIS # create String objects via USE directive [% USE String %] [% USE String 'initial text' %] [% USE String text => 'initial text' %] # or from an existing String via new() [% newstring = String.new %] [% newstring = String.new('newstring text') %] [% newstring = String.new( text => 'newstring text' ) %] # or from an existing String via copy() [% newstring = String.copy %] # append text to string [% String.append('text to append') %] # format left, right or center/centre padded [% String.left(20) %] [% String.right(20) %] [% String.center(20) %] # American spelling [% String.centre(20) %] # European spelling # and various other methods... =head1 DESCRIPTION This module implements a C<String> class for doing stringy things to text in an object-oriented way. You can create a C<String> object via the C<USE> directive, adding any initial text value as an argument or as the named parameter C<text>. [% USE String %] [% USE String 'initial text' %] [% USE String text='initial text' %] The object created will be referenced as C<String> by default, but you can provide a different variable name for the object to be assigned to: [% USE greeting = String 'Hello World' %] Once you've got a C<String> object, you can use it as a prototype to create other C<String> objects with the C<new()> method. [% USE String %] [% greeting = String.new('Hello World') %] The C<new()> method also accepts an initial text string as an argument or the named parameter C<text>. [% greeting = String.new( text => 'Hello World' ) %] You can also call C<copy()> to create a new C<String> as a copy of the original. [% greet2 = greeting.copy %] The C<String> object has a C<text()> method to return the content of the string. [% greeting.text %] However, it is sufficient to simply print the string and let the overloaded stringification operator call the C<text()> method automatically for you. [% greeting %] Thus, you can treat C<String> objects pretty much like any regular piece of text, interpolating it into other strings, for example: [% msg = "It printed '$greeting' and then dumped core\n" %] You also have the benefit of numerous other methods for manipulating the string. [% msg.append("PS Don't eat the yellow snow") %] Note that all methods operate on and mutate the contents of the string itself. If you want to operate on a copy of the string then simply take a copy first: [% msg.copy.append("PS Don't eat the yellow snow") %] These methods return a reference to the C<String> object itself. This allows you to chain multiple methods together. [% msg.copy.append('foo').right(72) %] It also means that in the above examples, the C<String> is returned which causes the C<text()> method to be called, which results in the new value of the string being printed. To suppress printing of the string, you can use the C<CALL> directive. [% foo = String.new('foo') %] [% foo.append('bar') %] # prints "foobar" [% CALL foo.append('bar') %] # nothing =head1 CONSTRUCTOR METHODS These methods are used to create new C<String> objects. =head2 new() Creates a new string using an initial value passed as a positional argument or the named parameter C<text>. [% USE String %] [% msg = String.new('Hello World') %] [% msg = String.new( text => 'Hello World' ) %] =head2 copy() Creates a new C<String> object which contains a copy of the original string. [% msg2 = msg.copy %] =head1 INSPECTOR METHODS These methods are used to examine the string. =head2 text() Returns the internal text value of the string. The stringification operator is overloaded to call this method. Thus the following are equivalent: [% msg.text %] [% msg %] =head2 length() Returns the length of the string. [% USE String("foo") %] [% String.length %] # => 3 =head2 search($pattern) Searches the string for the regular expression specified in C<$pattern> returning true if found or false otherwise. [% item = String.new('foo bar baz wiz waz woz') %] [% item.search('wiz') ? 'WIZZY! :-)' : 'not wizzy :-(' %] =head2 split($pattern, $limit) Splits the string based on the delimiter C<$pattern> and optional C<$limit>. Delegates to Perl's internal C<split()> so the parameters are exactly the same. [% FOREACH item.split %] ... [% END %] [% FOREACH item.split('baz|waz') %] ... [% END %] =head1 MUTATOR METHODS These methods modify the internal value of the string. For example: [% USE str=String('foobar') %] [% str.append('.html') %] # str => 'foobar.html' The value of C<str> is now 'C<foobar.html>'. If you don't want to modify the string then simply take a copy first. [% str.copy.append('.html') %] These methods all return a reference to the C<String> object itself. This has two important benefits. The first is that when used as above, the C<String> object 'C<str>' returned by the C<append()> method will be stringified with a call to its C<text()> method. This will return the newly modified string content. In other words, a directive like: [% str.append('.html') %] will update the string and also print the new value. If you just want to update the string but not print the new value then use C<CALL>. [% CALL str.append('.html') %] The other benefit of these methods returning a reference to the C<String> is that you can chain as many different method calls together as you like. For example: [% String.append('.html').trim.format(href) %] Here are the methods: =head2 push($suffix, ...) / append($suffix, ...) Appends all arguments to the end of the string. The C<append()> method is provided as an alias for C<push()>. [% msg.push('foo', 'bar') %] [% msg.append('foo', 'bar') %] =head2 pop($suffix) Removes the suffix passed as an argument from the end of the String. [% USE String 'foo bar' %] [% String.pop(' bar') %] # => 'foo' =head2 unshift($prefix, ...) / prepend($prefix, ...) Prepends all arguments to the beginning of the string. The C<prepend()> method is provided as an alias for C<unshift()>. [% msg.unshift('foo ', 'bar ') %] [% msg.prepend('foo ', 'bar ') %] =head2 shift($prefix) Removes the prefix passed as an argument from the start of the String. [% USE String 'foo bar' %] [% String.shift('foo ') %] # => 'bar' =head2 left($pad) If the length of the string is less than C<$pad> then the string is left formatted and padded with spaces to C<$pad> length. [% msg.left(20) %] =head2 right($pad) As per L<left()> but right padding the C<String> to a length of C<$pad>. [% msg.right(20) %] =head2 center($pad) / centre($pad) As per L<left()> and L<right()> but formatting the C<String> to be centered within a space padded string of length C<$pad>. The C<centre()> method is provided as an alias for C<center()>. [% msg.center(20) %] # American spelling [% msg.centre(20) %] # European spelling =head2 format($format) Apply a format in the style of C<sprintf()> to the string. [% USE String("world") %] [% String.format("Hello %s\n") %] # => "Hello World\n" =head2 upper() Converts the string to upper case. [% USE String("foo") %] [% String.upper %] # => 'FOO' =head2 lower() Converts the string to lower case [% USE String("FOO") %] [% String.lower %] # => 'foo' =head2 capital() Converts the first character of the string to upper case. [% USE String("foo") %] [% String.capital %] # => 'Foo' The remainder of the string is left untouched. To force the string to be all lower case with only the first letter capitalised, you can do something like this: [% USE String("FOO") %] [% String.lower.capital %] # => 'Foo' =head2 chop() Removes the last character from the string. [% USE String("foop") %] [% String.chop %] # => 'foo' =head2 chomp() Removes the trailing newline from the string. [% USE String("foo\n") %] [% String.chomp %] # => 'foo' =head2 trim() Removes all leading and trailing whitespace from the string [% USE String(" foo \n\n ") %] [% String.trim %] # => 'foo' =head2 collapse() Removes all leading and trailing whitespace and collapses any sequences of multiple whitespace to a single space. [% USE String(" \n\r \t foo \n \n bar \n") %] [% String.collapse %] # => "foo bar" =head2 truncate($length, $suffix) Truncates the string to C<$length> characters. [% USE String('long string') %] [% String.truncate(4) %] # => 'long' If C<$suffix> is specified then it will be appended to the truncated string. In this case, the string will be further shortened by the length of the suffix to ensure that the newly constructed string complete with suffix is exactly C<$length> characters long. [% USE msg = String('Hello World') %] [% msg.truncate(8, '...') %] # => 'Hello...' =head2 replace($search, $replace) Replaces all occurrences of C<$search> in the string with C<$replace>. [% USE String('foo bar foo baz') %] [% String.replace('foo', 'wiz') %] # => 'wiz bar wiz baz' =head2 remove($search) Remove all occurrences of C<$search> in the string. [% USE String('foo bar foo baz') %] [% String.remove('foo ') %] # => 'bar baz' =head2 repeat($count) Repeats the string C<$count> times. [% USE String('foo ') %] [% String.repeat(3) %] # => 'foo foo foo ' =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/Scalar.pm 0000444 00000007263 15125513451 0011717 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::Scalar # # DESCRIPTION # Template Toolkit plugin module which allows you to call object methods # in scalar context. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 2008-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::Scalar; use base 'Template::Plugin'; use strict; use warnings; use Template::Exception; use Scalar::Util qw(); our $VERSION = '3.100'; our $MONAD = 'Template::Monad::Scalar'; our $EXCEPTION = 'Template::Exception'; our $AUTOLOAD; sub load { my $class = shift; my $context = shift; # define .scalar vmethods for hash and list objects $context->define_vmethod( hash => scalar => \&scalar_monad ); $context->define_vmethod( list => scalar => \&scalar_monad ); return $class; } sub scalar_monad { # create a .scalar monad which wraps the hash- or list-based object # and delegates any method calls back to it, calling them in scalar # context, e.g. foo.scalar.bar becomes $MONAD->new($foo)->bar and # the monad calls $foo->bar in scalar context $MONAD->new(shift); } sub new { my ($class, $context, @args) = @_; # create a scalar plugin object which will lookup a variable subroutine # and call it. e.g. scalar.foo results in a call to foo() in scalar context my $self = bless { _CONTEXT => $context, }, $class; return $self; } sub AUTOLOAD { my $self = shift; my $item = $AUTOLOAD; $item =~ s/.*:://; return if $item eq 'DESTROY'; # lookup the named values my $stash = $self->{ _CONTEXT }->stash; my $value = $stash->{ $item }; if (! defined $value) { die $EXCEPTION->new( scalar => "undefined value for scalar call: $item" ); } elsif (ref $value eq 'CODE') { $value = $value->(@_); } return $value; } package Template::Monad::Scalar; our $EXCEPTION = 'Template::Exception'; our $AUTOLOAD; sub new { my ($class, $this) = @_; bless \$this, $class; } sub AUTOLOAD { my $self = shift; my $this = $$self; my $item = $AUTOLOAD; $item =~ s/.*:://; return if $item eq 'DESTROY'; my $method; if (Scalar::Util::blessed($this)) { # lookup the method... $method = $this->can($item); } else { die $EXCEPTION->new( scalar => "invalid object method: $item" ); } # ...and call it in scalar context my $result = $method->($this, @_); return $result; } 1; __END__ =head1 NAME Template::Plugin::Scalar - call object methods in scalar context =head1 SYNOPSIS [% USE scalar %] # TT2 calls object methods in array context by default [% object.method %] # force it to use scalar context [% object.scalar.method %] # also works with subroutine references [% scalar.my_sub_ref %] =head1 DESCRIPTION The Template Toolkit calls user-defined subroutines and object methods using Perl's array context by default. This plugin module provides a way for you to call subroutines and methods in scalar context. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 2008-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin/Dumper.pm 0000444 00000007237 15125513451 0011747 0 ustar 00 #============================================================================== # # Template::Plugin::Dumper # # DESCRIPTION # # A Template Plugin to provide a Template Interface to Data::Dumper # # AUTHOR # Simon Matthews <sam@tt2.org> # # COPYRIGHT # Copyright (C) 2000 Simon Matthews. All Rights Reserved # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================== package Template::Plugin::Dumper; use strict; use warnings; use base 'Template::Plugin'; use Data::Dumper; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our @DUMPER_ARGS = qw( Indent Pad Varname Purity Useqq Terse Freezer Toaster Deepcopy Quotekeys Bless Maxdepth Sortkeys ); our $AUTOLOAD; #============================================================================== # ----- CLASS METHODS ----- #============================================================================== #------------------------------------------------------------------------ # new($context, \@params) #------------------------------------------------------------------------ sub new { my ($class, $context, $params) = @_; bless { _CONTEXT => $context, params => $params || {}, }, $class; } sub get_dump_obj { my $self = shift; my $dumper_obj = Data::Dumper->new( \@_ ); my $params = $self->{ params }; foreach my $arg ( @DUMPER_ARGS ) { my $val = exists $params->{ lc $arg } ? $params->{ lc $arg } : $params->{ $arg }; $dumper_obj->$arg( $val ) if defined $val; } return $dumper_obj; } sub dump { scalar shift->get_dump_obj( @_ )->Dump() } sub dump_html { my $self = shift; my $content = $self->dump( @_ ); for ($content) { s/&/&/g; s/</</g; s/>/>/g; s/\n/<br>\n/g; } return $content; } 1; __END__ =head1 NAME Template::Plugin::Dumper - Plugin interface to Data::Dumper =head1 SYNOPSIS [% USE Dumper %] [% Dumper.dump(variable) %] [% Dumper.dump_html(variable) %] =head1 DESCRIPTION This is a very simple Template Toolkit Plugin Interface to the L<Data::Dumper> module. A C<Dumper> object will be instantiated via the following directive: [% USE Dumper %] As a standard plugin, you can also specify its name in lower case: [% USE dumper %] The C<Data::Dumper> C<Pad>, C<Indent> and C<Varname> options are supported as constructor arguments to affect the output generated. See L<Data::Dumper> for further details. [% USE dumper(Indent=0, Pad="<br>") %] These options can also be specified in lower case. [% USE dumper(indent=0, pad="<br>") %] =head1 METHODS There are two methods supported by the C<Dumper> object. Each will output into the template the contents of the variables passed to the object method. =head2 dump() Generates a raw text dump of the data structure(s) passed [% USE Dumper %] [% Dumper.dump(myvar) %] [% Dumper.dump(myvar, yourvar) %] =head2 dump_html() Generates a dump of the data structures, as per L<dump()>, but with the characters E<lt>, E<gt> and E<amp> converted to their equivalent HTML entities and newlines converted to E<lt>brE<gt>. [% USE Dumper %] [% Dumper.dump_html(myvar) %] =head1 AUTHOR Simon Matthews E<lt>sam@tt2.orgE<gt> =head1 COPYRIGHT Copyright (C) 2000 Simon Matthews. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin>, L<Data::Dumper> 5.32/Template/Plugin/Format.pm 0000444 00000003450 15125513451 0011734 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin::Format # # DESCRIPTION # # Simple Template Toolkit Plugin which creates formatting functions. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin::Format; use strict; use warnings; use base 'Template::Plugin'; our $VERSION = '3.100'; sub new { my ($class, $context, $format) = @_;; return defined $format ? make_formatter($format) : \&make_formatter; } sub make_formatter { my $format = shift; $format = '%s' unless defined $format; return sub { my @args = @_; push(@args, '') unless @args; return sprintf($format, @args); } } 1; __END__ =head1 NAME Template::Plugin::Format - Plugin to create formatting functions =head1 SYNOPSIS [% USE format %] [% commented = format('# %s') %] [% commented('The cat sat on the mat') %] [% USE bold = format('<b>%s</b>') %] [% bold('Hello') %] =head1 DESCRIPTION The format plugin constructs sub-routines which format text according to a C<printf()>-like format string. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Plugin> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/VMethods.pm 0000444 00000036461 15125513451 0011007 0 ustar 00 #============================================================= -*-Perl-*- # # Template::VMethods # # DESCRIPTION # Module defining virtual methods for the Template Toolkit # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::VMethods; use strict; use warnings; use Scalar::Util qw( blessed looks_like_number ); use Template::Filters; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $ROOT_VMETHODS = { inc => \&root_inc, dec => \&root_dec, }; our $TEXT_VMETHODS = { item => \&text_item, list => \&text_list, hash => \&text_hash, length => \&text_length, size => \&text_size, empty => \&text_empty, defined => \&text_defined, upper => \&text_upper, lower => \&text_lower, ucfirst => \&text_ucfirst, lcfirst => \&text_lcfirst, match => \&text_match, search => \&text_search, repeat => \&text_repeat, replace => \&text_replace, remove => \&text_remove, split => \&text_split, chunk => \&text_chunk, substr => \&text_substr, trim => \&text_trim, collapse => \&text_collapse, squote => \&text_squote, dquote => \&text_dquote, html => \&Template::Filters::html_filter, xml => \&Template::Filters::xml_filter, }; our $HASH_VMETHODS = { item => \&hash_item, hash => \&hash_hash, size => \&hash_size, empty => \&hash_empty, each => \&hash_each, keys => \&hash_keys, values => \&hash_values, items => \&hash_items, pairs => \&hash_pairs, list => \&hash_list, exists => \&hash_exists, defined => \&hash_defined, delete => \&hash_delete, import => \&hash_import, sort => \&hash_sort, nsort => \&hash_nsort, }; our $LIST_VMETHODS = { item => \&list_item, list => \&list_list, hash => \&list_hash, push => \&list_push, pop => \&list_pop, unshift => \&list_unshift, shift => \&list_shift, max => \&list_max, size => \&list_size, empty => \&list_empty, defined => \&list_defined, first => \&list_first, last => \&list_last, reverse => \&list_reverse, grep => \&list_grep, join => \&list_join, sort => \&list_sort, nsort => \&list_nsort, unique => \&list_unique, import => \&list_import, merge => \&list_merge, slice => \&list_slice, splice => \&list_splice, }; # Template::Stash needs the above, so defer loading this module # until they are defined. require Template::Stash; our $PRIVATE = $Template::Stash::PRIVATE; #======================================================================== # root virtual methods #======================================================================== sub root_inc { no warnings; my $item = shift; ++$item; } sub root_dec { no warnings; my $item = shift; --$item; } #======================================================================== # text virtual methods #======================================================================== sub text_item { $_[0]; } sub text_list { [ $_[0] ]; } sub text_hash { { value => $_[0] }; } sub text_length { length $_[0]; } sub text_size { return 1; } sub text_empty { return 0 == text_length($_[0]) ? 1 : 0; } sub text_defined { return 1; } sub text_upper { return uc $_[0]; } sub text_lower { return lc $_[0]; } sub text_ucfirst { return ucfirst $_[0]; } sub text_lcfirst { return lcfirst $_[0]; } sub text_trim { for ($_[0]) { s/^\s+//; s/\s+$//; } return $_[0]; } sub text_collapse { for ($_[0]) { s/^\s+//; s/\s+$//; s/\s+/ /g } return $_[0]; } sub text_match { my ($str, $search, $global) = @_; return $str unless defined $str and defined $search; my @matches = $global ? ($str =~ /$search/g) : ($str =~ /$search/); return @matches ? \@matches : ''; } sub text_search { my ($str, $pattern) = @_; return $str unless defined $str and defined $pattern; return $str =~ /$pattern/; } sub text_repeat { my ($str, $count) = @_; $str = '' unless defined $str; return '' unless $count; $count ||= 1; return $str x $count; } sub text_replace { my ($text, $pattern, $replace, $global) = @_; $text = '' unless defined $text; $pattern = '' unless defined $pattern; $replace = '' unless defined $replace; $global = 1 unless defined $global; if ($replace =~ /\$\d+/) { # replacement string may contain backrefs my $expand = sub { my ($chunk, $start, $end) = @_; $chunk =~ s{ \\(\\|\$) | \$ (\d+) }{ $1 ? $1 : ($2 > $#$start || $2 == 0 || !defined $start->[$2]) ? '' : substr($text, $start->[$2], $end->[$2] - $start->[$2]); }exg; $chunk; }; if ($global) { $text =~ s{$pattern}{ &$expand($replace, [@-], [@+]) }eg; } else { $text =~ s{$pattern}{ &$expand($replace, [@-], [@+]) }e; } } else { if ($global) { $text =~ s/$pattern/$replace/g; } else { $text =~ s/$pattern/$replace/; } } return $text; } sub text_remove { my ($str, $search) = @_; return $str unless defined $str and defined $search; $str =~ s/$search//g; return $str; } sub text_split { my ($str, $split, $limit) = @_; $str = '' unless defined $str; # For versions of Perl prior to 5.18 we have to be very careful about # spelling out each possible combination of arguments because split() # is very sensitive to them, for example C<split(' ', ...)> behaves # differently to C<$space=' '; split($space, ...)>. Test 33 of # vmethods/text.t depends on this behaviour. if ($] < 5.018) { if (defined $limit) { return [ defined $split ? split($split, $str, $limit) : split(' ', $str, $limit) ]; } else { return [ defined $split ? split($split, $str) : split(' ', $str) ]; } } # split's behavior changed in Perl 5.18.0 making this: # C<$space=' '; split($space, ...)> # behave the same as this: # C<split(' ', ...)> # qr// behaves the same, so use that for user-defined split. my $split_re; if (defined $split) { eval { $split_re = qr/$split/; }; } $split_re = ' ' unless defined $split_re; $limit ||= 0; return [split($split_re, $str, $limit)]; } sub text_chunk { my ($string, $size) = @_; my @list; $size ||= 1; if ($size < 0) { # sexeger! It's faster to reverse the string, search # it from the front and then reverse the output than to # search it from the end, believe it nor not! $string = reverse $string; $size = -$size; unshift(@list, scalar reverse $1) while ($string =~ /((.{$size})|(.+))/g); } else { push(@list, $1) while ($string =~ /((.{$size})|(.+))/g); } return \@list; } sub text_substr { my ($text, $offset, $length, $replacement) = @_; $offset ||= 0; if(defined $length) { if (defined $replacement) { substr( $text, $offset, $length, $replacement ); return $text; } else { return substr( $text, $offset, $length ); } } else { return substr( $text, $offset ); } } sub text_squote { my $text = shift; for ($text) { s/(['\\])/\\$1/g; } return $text; } sub text_dquote { my $text = shift; for ($text) { s/(["\\])/\\$1/g; s/\n/\\n/g; } return $text; } #======================================================================== # hash virtual methods #======================================================================== sub hash_item { my ($hash, $item) = @_; $item = '' unless defined $item; return if $PRIVATE && $item =~ /$PRIVATE/; $hash->{ $item }; } sub hash_hash { $_[0]; } sub hash_size { scalar keys %{$_[0]}; } sub hash_empty { return 0 == hash_size($_[0]) ? 1 : 0; } sub hash_each { # this will be changed in TT3 to do what hash_pairs() does [ %{ $_[0] } ]; } sub hash_keys { [ keys %{ $_[0] } ]; } sub hash_values { [ values %{ $_[0] } ]; } sub hash_items { [ %{ $_[0] } ]; } sub hash_pairs { [ map { { key => $_ , value => $_[0]->{ $_ } } } sort keys %{ $_[0] } ]; } sub hash_list { my ($hash, $what) = @_; $what ||= ''; return ($what eq 'keys') ? [ keys %$hash ] : ($what eq 'values') ? [ values %$hash ] : ($what eq 'each') ? [ %$hash ] : [ # for now we do what pairs does but this will be changed # in TT3 to return [ $hash ] by default map { { key => $_ , value => $hash->{ $_ } } } sort keys %$hash ]; } sub hash_exists { exists $_[0]->{ $_[1] }; } sub hash_defined { # return the item requested, or 1 if no argument # to indicate that the hash itself is defined my $hash = shift; return @_ ? defined $hash->{ $_[0] } : 1; } sub hash_delete { my $hash = shift; delete $hash->{ $_ } for @_; } sub hash_import { my ($hash, $imp) = @_; if (ref $imp eq 'HASH') { @$hash{ keys %$imp } = values %$imp; } return ''; } sub hash_sort { my ($hash) = @_; [ sort { lc $hash->{$a} cmp lc $hash->{$b} } (keys %$hash) ]; } sub hash_nsort { my ($hash) = @_; [ sort { $hash->{$a} <=> $hash->{$b} } (keys %$hash) ]; } #======================================================================== # list virtual methods #======================================================================== sub list_item { $_[0]->[ $_[1] || 0 ]; } sub list_list { $_[0]; } sub list_hash { my $list = shift; if (@_) { my $n = shift || 0; return { map { ($n++, $_) } @$list }; } no warnings; return { @$list }; } sub list_push { my $list = shift; push(@$list, @_); return ''; } sub list_pop { my $list = shift; pop(@$list); } sub list_unshift { my $list = shift; unshift(@$list, @_); return ''; } sub list_shift { my $list = shift; shift(@$list); } sub list_max { no warnings; my $list = shift; $#$list; } sub list_size { no warnings; my $list = shift; $#$list + 1; } sub list_empty { return 0 == list_size($_[0]) ? 1 : 0; } sub list_defined { # return the item requested, or 1 if no argument to # indicate that the hash itself is defined my $list = shift; return 1 unless @_; # list.defined is always true return unless looks_like_number $_[0]; # list.defined('bah') is always false return defined $list->[$_[0]]; # list.defined(n) } sub list_first { my $list = shift; return $list->[0] unless @_; return [ @$list[0..$_[0]-1] ]; } sub list_last { my $list = shift; return $list->[-1] unless @_; return [ @$list[-$_[0]..-1] ]; } sub list_reverse { my $list = shift; [ reverse @$list ]; } sub list_grep { my ($list, $pattern) = @_; $pattern ||= ''; return [ grep /$pattern/, @$list ]; } sub list_join { my ($list, $joint) = @_; join(defined $joint ? $joint : ' ', map { defined $_ ? $_ : '' } @$list); } sub _list_sort_make_key { my ($item, $fields) = @_; my @keys; if (ref($item) eq 'HASH') { @keys = map { $item->{ $_ } } @$fields; } elsif (blessed $item) { @keys = map { $item->can($_) ? $item->$_() : $item } @$fields; } else { @keys = $item; } # ugly hack to generate a single string using a delimiter that is # unlikely (but not impossible) to be found in the wild. return lc join('/*^UNLIKELY^*/', map { defined $_ ? $_ : '' } @keys); } sub list_sort { my ($list, @fields) = @_; return $list unless @$list > 1; # no need to sort 1 item lists return [ @fields # Schwartzian Transform ? map { $_->[0] } # for case insensitivity sort { $a->[1] cmp $b->[1] } map { [ $_, _list_sort_make_key($_, \@fields) ] } @$list : map { $_->[0] } sort { $a->[1] cmp $b->[1] } map { [ $_, lc $_ ] } @$list, ]; } sub list_nsort { my ($list, @fields) = @_; return $list unless @$list > 1; # no need to sort 1 item lists my $sort = sub { my $cmp; if(@fields) { # compare each field individually for my $field (@fields) { my $A = _list_sort_make_key($a, [ $field ]); my $B = _list_sort_make_key($b, [ $field ]); ($cmp = $A <=> $B) and last; } } else { my $A = _list_sort_make_key($a); my $B = _list_sort_make_key($b); $cmp = $A <=> $B; } $cmp; }; return [ sort $sort @{ $list } ]; } sub list_unique { my %u; [ grep { ++$u{$_} == 1 } @{$_[0]} ]; } sub list_import { my $list = shift; push(@$list, grep defined, map ref eq 'ARRAY' ? @$_ : undef, @_); return $list; } sub list_merge { my $list = shift; return [ @$list, grep defined, map ref eq 'ARRAY' ? @$_ : undef, @_ ]; } sub list_slice { my ($list, $from, $to) = @_; $from ||= 0; $to = $#$list unless defined $to; $from += @$list if $from < 0; $to += @$list if $to < 0; return [ @$list[$from..$to] ]; } sub list_splice { my ($list, $offset, $length, @replace) = @_; if (@replace) { # @replace can contain a list of multiple replace items, or # be a single reference to a list @replace = @{ $replace[0] } if @replace == 1 && ref $replace[0] eq 'ARRAY'; return [ splice @$list, $offset, $length, @replace ]; } elsif (defined $length) { return [ splice @$list, $offset, $length ]; } elsif (defined $offset) { return [ splice @$list, $offset ]; } else { return [ splice(@$list) ]; } } 1; __END__ =head1 NAME Template::VMethods - Virtual methods for variables =head1 DESCRIPTION The C<Template::VMethods> module implements the virtual methods that can be applied to variables. Please see L<Template::Manual::VMethods> for further information. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Stash>, L<Template::Manual::VMethods> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Tutorial.pod 0000444 00000002022 15125513451 0011211 0 ustar 00 #============================================================= -*-perl-*- # # Template::Tutorial # # DESCRIPTION # Section index for the Template::Tutorial documentation. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Tutorial - Template Toolkit Tutorials =head1 Template Toolkit Tutorials =head2 Template::Tutorial::Web The L<Template::Tutorial::Web> tutorial shows how you can use the Template Toolkit to generate static and dynamic web content. =head2 Template::Tutorial::Datafile The L<Template::Tutorial::Datafile> tutorial shows how you can use the Template Toolkit to generate other data formats like XML. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Provider.pm 0000444 00000132673 15125513451 0011052 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Provider # # DESCRIPTION # This module implements a class which handles the loading, compiling # and caching of templates. Multiple Template::Provider objects can # be stacked and queried in turn to effect a Chain-of-Command between # them. A provider will attempt to return the requested template, # an error (STATUS_ERROR) or decline to provide the template # (STATUS_DECLINE), allowing subsequent providers to attempt to # deliver it. See 'Design Patterns' for further details. # # AUTHORS # Andy Wardley <abw@wardley.org> # # Refactored by Bill Moseley for v2.19 to add negative caching (i.e. # tracking templates that are NOTFOUND so that we can decline quickly) # and to provide better support for subclassing the provider. # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # WARNING: # This code is ugly and contorted and is being totally re-written for TT3. # In particular, we'll be throwing errors rather than messing around # returning (value, status) pairs. With the benefit of hindsight, that # was a really bad design decision on my part. I deserve to be knocked # to the ground and kicked around a bit by hoards of angry TT developers # for that one. Bill's refactoring has made the module easier to subclass, # (so you can ease off the kicking now), but it really needs to be totally # redesigned and rebuilt from the ground up along with the bits of TT that # use it. -- abw 2007/04/27 #============================================================================ package Template::Provider; use strict; use warnings; use base 'Template::Base'; use Template::Config; use Template::Constants; use Template::Document; use File::Basename; use File::Spec; use constant PREV => 0; use constant NAME => 1; # template name -- indexed by this name in LOOKUP use constant DATA => 2; # Compiled template use constant LOAD => 3; # mtime of template use constant NEXT => 4; # link to next item in cache linked list use constant STAT => 5; # Time last stat()ed use constant MSWin32 => $^O eq 'MSWin32'; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $ERROR = ''; # name of document class our $DOCUMENT = 'Template::Document' unless defined $DOCUMENT; # maximum time between performing stat() on file to check staleness our $STAT_TTL = 1 unless defined $STAT_TTL; # maximum number of directories in an INCLUDE_PATH, to prevent runaways our $MAX_DIRS = 64 unless defined $MAX_DIRS; # UNICODE is supported in versions of Perl from 5.007 onwards our $UNICODE = $] > 5.007 ? 1 : 0; my $boms = [ 'UTF-8' => "\x{ef}\x{bb}\x{bf}", 'UTF-32BE' => "\x{0}\x{0}\x{fe}\x{ff}", 'UTF-32LE' => "\x{ff}\x{fe}\x{0}\x{0}", 'UTF-16BE' => "\x{fe}\x{ff}", 'UTF-16LE' => "\x{ff}\x{fe}", ]; # regex to match relative paths our $RELATIVE_PATH = qr[(?:^|/)\.+/]; #======================================================================== # -- PUBLIC METHODS -- #======================================================================== #------------------------------------------------------------------------ # fetch($name) # # Returns a compiled template for the name specified by parameter. # The template is returned from the internal cache if it exists, or # loaded and then subsequently cached. The ABSOLUTE and RELATIVE # configuration flags determine if absolute (e.g. '/something...') # and/or relative (e.g. './something') paths should be honoured. The # INCLUDE_PATH is otherwise used to find the named file. $name may # also be a reference to a text string containing the template text, # or a file handle from which the content is read. The compiled # template is not cached in these latter cases given that there is no # filename to cache under. A subsequent call to store($name, # $compiled) can be made to cache the compiled template for future # fetch() calls, if necessary. # # Returns a compiled template or (undef, STATUS_DECLINED) if the # template could not be found. On error (e.g. the file was found # but couldn't be read or parsed), the pair ($error, STATUS_ERROR) # is returned. The TOLERANT configuration option can be set to # downgrade any errors to STATUS_DECLINE. #------------------------------------------------------------------------ sub fetch { my ($self, $name) = @_; my ($data, $error); if (ref $name) { # $name can be a reference to a scalar, GLOB or file handle ($data, $error) = $self->_load($name); ($data, $error) = $self->_compile($data) unless $error; $data = $data->{ data } unless $error; } elsif (File::Spec->file_name_is_absolute($name)) { # absolute paths (starting '/') allowed if ABSOLUTE set ($data, $error) = $self->{ ABSOLUTE } ? $self->_fetch($name) : $self->{ TOLERANT } ? (undef, Template::Constants::STATUS_DECLINED) : ("$name: absolute paths are not allowed (set ABSOLUTE option)", Template::Constants::STATUS_ERROR); } elsif ($name =~ m/$RELATIVE_PATH/o) { # anything starting "./" is relative to cwd, allowed if RELATIVE set ($data, $error) = $self->{ RELATIVE } ? $self->_fetch($name) : $self->{ TOLERANT } ? (undef, Template::Constants::STATUS_DECLINED) : ("$name: relative paths are not allowed (set RELATIVE option)", Template::Constants::STATUS_ERROR); } else { # otherwise, it's a file name relative to INCLUDE_PATH ($data, $error) = $self->{ INCLUDE_PATH } ? $self->_fetch_path($name) : (undef, Template::Constants::STATUS_DECLINED); } return ($data, $error); } #------------------------------------------------------------------------ # store($name, $data) # # Store a compiled template ($data) in the cached as $name. # Returns compiled template #------------------------------------------------------------------------ sub store { my ($self, $name, $data, $mtime) = @_; $self->_store($name, { data => $data, load => 0, mtime => $mtime }); } #------------------------------------------------------------------------ # load($name) # # Load a template without parsing/compiling it, suitable for use with # the INSERT directive. There's some duplication with fetch() and at # some point this could be reworked to integrate them a little closer. #------------------------------------------------------------------------ sub load { my ($self, $name) = @_; my ($data, $error); my $path = $name; if (File::Spec->file_name_is_absolute($name)) { # absolute paths (starting '/') allowed if ABSOLUTE set $error = "$name: absolute paths are not allowed (set ABSOLUTE option)" unless $self->{ ABSOLUTE }; } elsif ($name =~ m[$RELATIVE_PATH]o) { # anything starting "./" is relative to cwd, allowed if RELATIVE set $error = "$name: relative paths are not allowed (set RELATIVE option)" unless $self->{ RELATIVE }; } else { INCPATH: { # otherwise, it's a file name relative to INCLUDE_PATH my $paths = $self->paths() || return ($self->error(), Template::Constants::STATUS_ERROR); foreach my $dir (@$paths) { $path = File::Spec->catfile($dir, $name); last INCPATH if defined $self->_template_modified($path); } undef $path; # not found } } # Now fetch the content ($data, $error) = $self->_template_content($path) if defined $path && !$error; if ($error) { return $self->{ TOLERANT } ? (undef, Template::Constants::STATUS_DECLINED) : ($error, Template::Constants::STATUS_ERROR); } elsif (! defined $path) { return (undef, Template::Constants::STATUS_DECLINED); } else { return ($data, Template::Constants::STATUS_OK); } } #------------------------------------------------------------------------ # include_path(\@newpath) # # Accessor method for the INCLUDE_PATH setting. If called with an # argument, this method will replace the existing INCLUDE_PATH with # the new value. #------------------------------------------------------------------------ sub include_path { my ($self, $path) = @_; $self->{ INCLUDE_PATH } = $path if $path; return $self->{ INCLUDE_PATH }; } #------------------------------------------------------------------------ # paths() # # Evaluates the INCLUDE_PATH list, ignoring any blank entries, and # calling and subroutine or object references to return dynamically # generated path lists. Returns a reference to a new list of paths # or undef on error. #------------------------------------------------------------------------ sub paths { my $self = shift; my @ipaths = @{ $self->{ INCLUDE_PATH } }; my (@opaths, $dpaths, $dir); my $count = $MAX_DIRS; while (@ipaths && --$count) { $dir = shift @ipaths || next; # $dir can be a sub or object ref which returns a reference # to a dynamically generated list of search paths. if (ref $dir eq 'CODE') { eval { $dpaths = &$dir() }; if ($@) { chomp $@; return $self->error($@); } unshift(@ipaths, @$dpaths); next; } elsif (ref($dir) && UNIVERSAL::can($dir, 'paths')) { $dpaths = $dir->paths() || return $self->error($dir->error()); unshift(@ipaths, @$dpaths); next; } else { push(@opaths, $dir); } } return $self->error("INCLUDE_PATH exceeds $MAX_DIRS directories") if @ipaths; return \@opaths; } #------------------------------------------------------------------------ # DESTROY # # The provider cache is implemented as a doubly linked list which Perl # cannot free by itself due to the circular references between NEXT <=> # PREV items. This cleanup method walks the list deleting all the NEXT/PREV # references, allowing the proper cleanup to occur and memory to be # repooled. #------------------------------------------------------------------------ sub DESTROY { my $self = shift; my ($slot, $next); $slot = $self->{ HEAD }; while ($slot) { $next = $slot->[ NEXT ]; undef $slot->[ PREV ]; undef $slot->[ NEXT ]; $slot = $next; } undef $self->{ HEAD }; undef $self->{ TAIL }; } #======================================================================== # -- PRIVATE METHODS -- #======================================================================== #------------------------------------------------------------------------ # _init() # # Initialise the cache. #------------------------------------------------------------------------ sub _init { my ($self, $params) = @_; my $size = $params->{ CACHE_SIZE }; my $path = $params->{ INCLUDE_PATH } || '.'; my $cdir = $params->{ COMPILE_DIR } || ''; my $dlim = $params->{ DELIMITER }; my $debug; # tweak delim to ignore C:/ unless (defined $dlim) { $dlim = MSWin32 ? qr/:(?!\\|\/)/ : qr/:/; } # coerce INCLUDE_PATH to an array ref, if not already so $path = [ split(/$dlim/, $path) ] unless ref $path eq 'ARRAY'; # don't allow a CACHE_SIZE 1 because it breaks things and the # additional checking isn't worth it $size = 2 if defined $size && ($size == 1 || $size < 0); if (defined ($debug = $params->{ DEBUG })) { $self->{ DEBUG } = $debug & ( Template::Constants::DEBUG_PROVIDER | Template::Constants::DEBUG_FLAGS ); } else { $self->{ DEBUG } = $DEBUG; } if ($self->{ DEBUG }) { local $" = ', '; $self->debug( "creating cache of ", defined $size ? $size : 'unlimited', " slots for [ @$path ]" ); } # create COMPILE_DIR and sub-directories representing each INCLUDE_PATH # element in which to store compiled files if ($cdir) { require File::Path; foreach my $dir (@$path) { next if ref $dir; my $wdir = $dir; $wdir =~ tr[:][]d if MSWin32; { no warnings 'syntax'; $wdir = each %{ { $wdir => undef } } if ${^TAINT}; #untaint } $wdir = File::Spec->catfile($cdir, $wdir); File::Path::mkpath($wdir) unless -d $wdir; } } $self->{ LOOKUP } = { }; $self->{ NOTFOUND } = { }; # Tracks templates *not* found. $self->{ SLOTS } = 0; $self->{ SIZE } = $size; $self->{ INCLUDE_PATH } = $path; $self->{ DELIMITER } = $dlim; $self->{ COMPILE_DIR } = $cdir; $self->{ COMPILE_EXT } = $params->{ COMPILE_EXT } || ''; $self->{ ABSOLUTE } = $params->{ ABSOLUTE } || 0; $self->{ RELATIVE } = $params->{ RELATIVE } || 0; $self->{ TOLERANT } = $params->{ TOLERANT } || 0; $self->{ DOCUMENT } = $params->{ DOCUMENT } || $DOCUMENT; $self->{ PARSER } = $params->{ PARSER }; $self->{ DEFAULT } = $params->{ DEFAULT }; $self->{ ENCODING } = $params->{ ENCODING }; # $self->{ PREFIX } = $params->{ PREFIX }; $self->{ STAT_TTL } = $params->{ STAT_TTL } || $STAT_TTL; $self->{ PARAMS } = $params; # look for user-provided UNICODE parameter or use default from package var $self->{ UNICODE } = defined $params->{ UNICODE } ? $params->{ UNICODE } : $UNICODE; return $self; } #------------------------------------------------------------------------ # _fetch($name, $t_name) # # Fetch a file from cache or disk by specification of an absolute or # relative filename. No search of the INCLUDE_PATH is made. If the # file is found and loaded, it is compiled and cached. # Call with: # $name = path to search (possible prefixed by INCLUDE_PATH) # $t_name = template name #------------------------------------------------------------------------ sub _fetch { my ($self, $name, $t_name) = @_; my $stat_ttl = $self->{ STAT_TTL }; $self->debug("_fetch($name)") if $self->{ DEBUG }; # First see if the named template is in the memory cache if ((my $slot = $self->{ LOOKUP }->{ $name })) { # Test if cache is fresh, and reload/compile if not. my ($data, $error) = $self->_refresh($slot); return $error ? ( $data, $error ) # $data may contain error text : $slot->[ DATA ]; # returned document object } # Otherwise, see if we already know the template is not found if (my $last_stat_time = $self->{ NOTFOUND }->{ $name }) { my $expires_in = $last_stat_time + $stat_ttl - time; if ($expires_in > 0) { $self->debug(" file [$name] in negative cache. Expires in $expires_in seconds") if $self->{ DEBUG }; return (undef, Template::Constants::STATUS_DECLINED); } else { delete $self->{ NOTFOUND }->{ $name }; } } my($template,$error); my $uncompiled_template_mtime = $self->_template_modified( $name ); # does template exist? # some templates like Provider::FromDATA does not provide mtime information $uncompiled_template_mtime = 0 unless defined $uncompiled_template_mtime; # Is there an up-to-date compiled version on disk? if (my $template_mtime = $self->_compiled_is_current($name, $uncompiled_template_mtime)) { # require() the compiled template. my $compiled_template = $self->_load_compiled( $self->_compiled_filename($name) ); # Store and return the compiled template return $self->store( $name, $compiled_template, $template_mtime ) if $compiled_template; # Problem loading compiled template: # warn and continue to fetch source template warn($self->error(), "\n"); } # load template from source ($template, $error) = $self->_load($name, $t_name); if ($error) { # Template could not be fetched. Add to the negative/notfound cache. $self->{ NOTFOUND }->{ $name } = time; return ( $template, $error ); } # compile template source ($template, $error) = $self->_compile($template, $self->_compiled_filename($name) ); if ($error) { # return any compile time error return ($template, $error); } else { # Store compiled template and return it return $self->store($name, $template->{data}) ; } } #------------------------------------------------------------------------ # _fetch_path($name) # # Fetch a file from cache or disk by specification of an absolute cache # name (e.g. 'header') or filename relative to one of the INCLUDE_PATH # directories. If the file isn't already cached and can be found and # loaded, it is compiled and cached under the full filename. #------------------------------------------------------------------------ sub _fetch_path { my ($self, $name) = @_; $self->debug("_fetch_path($name)") if $self->{ DEBUG }; # the template may have been stored using a non-filename name # so look for the plain name in the cache first if ((my $slot = $self->{ LOOKUP }->{ $name })) { # cached entry exists, so refresh slot and extract data my ($data, $error) = $self->_refresh($slot); return $error ? ($data, $error) : ($slot->[ DATA ], $error ); } my $paths = $self->paths || return ( $self->error, Template::Constants::STATUS_ERROR ); # search the INCLUDE_PATH for the file, in cache or on disk foreach my $dir (@$paths) { my $path = File::Spec->catfile($dir, $name); $self->debug("searching path: $path\n") if $self->{ DEBUG }; my ($data, $error) = $self->_fetch( $path, $name ); # Return if no error or if a serious error. return ( $data, $error ) if !$error || $error == Template::Constants::STATUS_ERROR; } # not found in INCLUDE_PATH, now try DEFAULT return $self->_fetch_path( $self->{DEFAULT} ) if defined $self->{DEFAULT} && $name ne $self->{DEFAULT}; # We could not handle this template name return (undef, Template::Constants::STATUS_DECLINED); } sub _compiled_filename { my ($self, $file) = @_; return $self->{ COMPILEDPATH }{$file} if $self->{ COMPILEDPATH }{$file}; my ($compext, $compdir) = @$self{ qw( COMPILE_EXT COMPILE_DIR ) }; my ($path, $compiled); return undef unless $compext || $compdir; $path = $file; $path or die "invalid filename: $path"; $path =~ tr[:][]d if MSWin32; $compiled = "$path$compext"; $self->{ COMPILEDPATH }{$file} = $compiled = File::Spec->catfile($compdir, $compiled) if length $compdir; return $compiled; } sub _load_compiled { my ($self, $file) = @_; # Implicitly Relative paths are not supported # by "require" and invoke @INC traversal, where relative # paths only traditionally worked prior to Perl 5.26 # due to the presence of '.' in @INC # # Given load_compiled never wants to traverse @INC, forcing # an absolute path for the loaded file and the INC key is # sensible. # # NB: %INC Keys are always identical to their respective # "require" invocations regardless of OS, and the only time # one needs to care about slash direction is when dealing # with Module::Name -> Module/Name.pm translation. my $fpath = File::Spec->rel2abs( $file ); return $self->error("compiled template missing path") unless defined $fpath; ($fpath) = $fpath =~ /^(.*)$/s; my $compiled; # load compiled template via require(); we zap any # %INC entry to ensure it is reloaded (we don't # want 1 returned by require() to say it's in memory) delete $INC{ $fpath }; eval { $compiled = require $fpath; }; return $@ ? $self->error("compiled template $compiled: $@") : $compiled; } #------------------------------------------------------------------------ # _load($name, $alias) # # Load template text from a string ($name = scalar ref), GLOB or file # handle ($name = ref), or from an absolute filename ($name = scalar). # Returns a hash array containing the following items: # name filename or $alias, if provided, or 'input text', etc. # text template text # time modification time of file, or current time for handles/strings # load time file was loaded (now!) # # On error, returns ($error, STATUS_ERROR), or (undef, STATUS_DECLINED) # if TOLERANT is set. #------------------------------------------------------------------------ sub _load { my ($self, $name, $alias) = @_; my ($data, $error); my $tolerant = $self->{ TOLERANT }; my $now = time; $alias = $name unless defined $alias or ref $name; $self->debug("_load($name, ", defined $alias ? $alias : '<no alias>', ')') if $self->{ DEBUG }; # SCALAR ref is the template text if (ref $name eq 'SCALAR') { # $name can be a SCALAR reference to the input text... return { name => defined $alias ? $alias : 'input text', path => defined $alias ? $alias : 'input text', text => $$name, time => $now, load => 0, }; } # Otherwise, assume GLOB as a file handle if (ref $name) { local $/; my $text = <$name>; $text = $self->_decode_unicode($text) if $self->{ UNICODE }; return { name => defined $alias ? $alias : 'input file handle', path => defined $alias ? $alias : 'input file handle', text => $text, time => $now, load => 0, }; } # Otherwise, it's the name of the template if ( defined $self->_template_modified( $name ) ) { # does template exist? my ($text, $error, $mtime ) = $self->_template_content( $name ); unless ( $error ) { $text = $self->_decode_unicode($text) if $self->{ UNICODE }; return { name => $alias, path => $name, text => $text, time => $mtime, load => $now, }; } return ( $error, Template::Constants::STATUS_ERROR ) unless $tolerant; } # Unable to process template, pass onto the next Provider. return (undef, Template::Constants::STATUS_DECLINED); } #------------------------------------------------------------------------ # _refresh(\@slot) # # Private method called to mark a cache slot as most recently used. # A reference to the slot array should be passed by parameter. The # slot is relocated to the head of the linked list. If the file from # which the data was loaded has been updated since it was compiled, then # it is re-loaded from disk and re-compiled. #------------------------------------------------------------------------ sub _refresh { my ($self, $slot) = @_; my $stat_ttl = $self->{ STAT_TTL }; my ($head, $file, $data, $error); $self->debug( "_refresh([ ", join(', ', map { defined $_ ? $_ : '<undef>' } @$slot), '])' ) if $self->{ DEBUG }; # if it's more than $STAT_TTL seconds since we last performed a # stat() on the file then we need to do it again and see if the file # time has changed my $now = time; my $expires_in_sec = $slot->[ STAT ] + $stat_ttl - $now; if ( $expires_in_sec <= 0 ) { # Time to check! $slot->[ STAT ] = $now; # Grab mtime of template. # Seems like this should be abstracted to compare to # just ask for a newer compiled template (if it's newer) # and let that check for a newer template source. my $template_mtime = $self->_template_modified( $slot->[ NAME ] ); if ( ! defined $template_mtime || ( $template_mtime != $slot->[ LOAD ] )) { $self->debug("refreshing cache file ", $slot->[ NAME ]) if $self->{ DEBUG }; ($data, $error) = $self->_load($slot->[ NAME ], $slot->[ DATA ]->{ name }); ($data, $error) = $self->_compile($data) unless $error; if ($error) { # if the template failed to load/compile then we wipe out the # STAT entry. This forces the provider to try and reload it # each time instead of using the previously cached version # until $STAT_TTL is next up $slot->[ STAT ] = 0; } else { $slot->[ DATA ] = $data->{ data }; $slot->[ LOAD ] = $data->{ time }; } } } elsif ( $self->{ DEBUG } ) { $self->debug( sprintf('STAT_TTL not met for file [%s]. Expires in %d seconds', $slot->[ NAME ], $expires_in_sec ) ); } # Move this slot to the head of the list unless( $self->{ HEAD } == $slot ) { # remove existing slot from usage chain... if ($slot->[ PREV ]) { $slot->[ PREV ]->[ NEXT ] = $slot->[ NEXT ]; } else { $self->{ HEAD } = $slot->[ NEXT ]; } if ($slot->[ NEXT ]) { $slot->[ NEXT ]->[ PREV ] = $slot->[ PREV ]; } else { $self->{ TAIL } = $slot->[ PREV ]; } # ..and add to start of list $head = $self->{ HEAD }; $head->[ PREV ] = $slot if $head; $slot->[ PREV ] = undef; $slot->[ NEXT ] = $head; $self->{ HEAD } = $slot; } return ($data, $error); } #------------------------------------------------------------------------ # _store($name, $data) # # Private method called to add a data item to the cache. If the cache # size limit has been reached then the oldest entry at the tail of the # list is removed and its slot relocated to the head of the list and # reused for the new data item. If the cache is under the size limit, # or if no size limit is defined, then the item is added to the head # of the list. # Returns compiled template #------------------------------------------------------------------------ sub _store { my ($self, $name, $data, $compfile) = @_; my $size = $self->{ SIZE }; my ($slot, $head); # Return if memory cache disabled. (overriding code should also check) # $$$ What's the expected behaviour of store()? Can't tell from the # docs if you can call store() when SIZE = 0. return $data->{data} if defined $size and !$size; # check the modification time -- extra stat here my $load = $data->{ mtime } || $self->_modified($name); # extract the compiled template from the data hash $data = $data->{ data }; $self->debug("_store($name, $data)") if $self->{ DEBUG }; if (defined $size && $self->{ SLOTS } >= $size) { # cache has reached size limit, so reuse oldest entry $self->debug("reusing oldest cache entry (size limit reached: $size)\nslots: $self->{ SLOTS }") if $self->{ DEBUG }; # remove entry from tail of list $slot = $self->{ TAIL }; $slot->[ PREV ]->[ NEXT ] = undef; $self->{ TAIL } = $slot->[ PREV ]; # remove name lookup for old node delete $self->{ LOOKUP }->{ $slot->[ NAME ] }; # add modified node to head of list $head = $self->{ HEAD }; $head->[ PREV ] = $slot if $head; @$slot = ( undef, $name, $data, $load, $head, time ); $self->{ HEAD } = $slot; # add name lookup for new node $self->{ LOOKUP }->{ $name } = $slot; } else { # cache is under size limit, or none is defined $self->debug("adding new cache entry") if $self->{ DEBUG }; # add new node to head of list $head = $self->{ HEAD }; $slot = [ undef, $name, $data, $load, $head, time ]; $head->[ PREV ] = $slot if $head; $self->{ HEAD } = $slot; $self->{ TAIL } = $slot unless $self->{ TAIL }; # add lookup from name to slot and increment nslots $self->{ LOOKUP }->{ $name } = $slot; $self->{ SLOTS }++; } return $data; } #------------------------------------------------------------------------ # _compile($data) # # Private method called to parse the template text and compile it into # a runtime form. Creates and delegates a Template::Parser object to # handle the compilation, or uses a reference passed in PARSER. On # success, the compiled template is stored in the 'data' item of the # $data hash and returned. On error, ($error, STATUS_ERROR) is returned, # or (undef, STATUS_DECLINED) if the TOLERANT flag is set. # The optional $compiled parameter may be passed to specify # the name of a compiled template file to which the generated Perl # code should be written. Errors are (for now...) silently # ignored, assuming that failures to open a file for writing are # intentional (e.g directory write permission). #------------------------------------------------------------------------ sub _compile { my ($self, $data, $compfile) = @_; my $text = $data->{ text }; my ($parsedoc, $error); $self->debug("_compile($data, ", defined $compfile ? $compfile : '<no compfile>', ')') if $self->{ DEBUG }; my $parser = $self->{ PARSER } ||= Template::Config->parser($self->{ PARAMS }) || return (Template::Config->error(), Template::Constants::STATUS_ERROR); # discard the template text - we don't need it any more delete $data->{ text }; # call parser to compile template into Perl code if ($parsedoc = $parser->parse($text, $data)) { $parsedoc->{ METADATA } = { 'name' => $data->{ name }, 'modtime' => $data->{ 'time' }, %{ $parsedoc->{ METADATA } }, }; # write the Perl code to the file $compfile, if defined if ($compfile) { my $basedir = &File::Basename::dirname($compfile); { no warnings 'syntax'; $basedir = each %{ { $basedir => undef } } if ${^TAINT}; #untaint } unless (-d $basedir) { eval { File::Path::mkpath($basedir) }; $error = "failed to create compiled templates directory: $basedir ($@)" if ($@); } unless ($error) { my $docclass = $self->{ DOCUMENT }; $error = 'cache failed to write ' . &File::Basename::basename($compfile) . ': ' . $docclass->error() unless $docclass->write_perl_file($compfile, $parsedoc); } # set atime and mtime of newly compiled file, don't bother # if time is undef if (!defined($error) && defined $data->{ 'time' }) { my $cfile = do { no warnings 'syntax'; each %{ { $compfile => undef } }; }; if (!length $cfile) { return( "invalid filename: $compfile", Template::Constants::STATUS_ERROR ); }; my $ctime = $data->{ time }; if (!length $ctime || $ctime =~ tr{0-9}{}c) { return( "invalid time: $ctime", Template::Constants::STATUS_ERROR ); } utime($ctime, $ctime, $cfile); $self->debug(" cached compiled template to file [$compfile]") if $self->{ DEBUG }; } } unless ($error) { return $data ## RETURN ## if $data->{ data } = $DOCUMENT->new($parsedoc); $error = $Template::Document::ERROR; } } else { $error = Template::Exception->new( 'parse', "$data->{ name } " . $parser->error() ); } # return STATUS_ERROR, or STATUS_DECLINED if we're being tolerant return $self->{ TOLERANT } ? (undef, Template::Constants::STATUS_DECLINED) : ($error, Template::Constants::STATUS_ERROR) } #------------------------------------------------------------------------ # _compiled_is_current( $template_name ) # # Returns true if $template_name and its compiled name # exist and they have the same mtime. #------------------------------------------------------------------------ sub _compiled_is_current { my ( $self, $template_name, $uncompiled_template_mtime ) = @_; my $compiled_name = $self->_compiled_filename($template_name); return unless defined $compiled_name; my $compiled_mtime = (stat($compiled_name))[9]; return unless defined $compiled_mtime; my $template_mtime = $uncompiled_template_mtime || $self->_template_modified( $template_name ) or return; return unless defined $template_mtime; # This was >= in the 2.15, but meant that downgrading # a source template would not get picked up. return $compiled_mtime == $template_mtime ? $template_mtime : 0; } #------------------------------------------------------------------------ # _template_modified($path) # # Returns the last modified time of the $path. # Returns undef if the path does not exist. # Override if templates are not on disk, for example #------------------------------------------------------------------------ sub _template_modified { my $self = shift; my $template = shift || return; return (stat( $template ))[9]; } #------------------------------------------------------------------------ # _template_content($path) # # Fetches content pointed to by $path. # Returns the content in scalar context. # Returns ($data, $error, $mtime) in list context where # $data - content # $error - error string if there was an error, otherwise undef # $mtime - last modified time from calling stat() on the path #------------------------------------------------------------------------ sub _template_content { my ($self, $path) = @_; return (undef, "No path specified to fetch content from ") unless $path; my $data; my $mod_date; my $error; local *FH; if(-d $path) { $error = "$path: not a file"; } elsif (open(FH, "<", $path)) { local $/; binmode(FH); $data = <FH>; $mod_date = (stat($path))[9]; close(FH); } else { $error = "$path: $!"; } return wantarray ? ( $data, $error, $mod_date ) : $data; } #------------------------------------------------------------------------ # _modified($name) # _modified($name, $time) # # When called with a single argument, it returns the modification time # of the named template. When called with a second argument it returns # true if $name has been modified since $time. #------------------------------------------------------------------------ sub _modified { my ($self, $name, $time) = @_; my $load = $self->_template_modified($name); return $time ? 1 : 0 unless defined $load; return $time ? $load > $time : $load; } #------------------------------------------------------------------------ # _decode_unicode # # Decodes encoded unicode text that starts with a BOM and # turns it into perl's internal representation #------------------------------------------------------------------------ sub _decode_unicode { my $self = shift; my $string = shift; return undef unless defined $string; use bytes; require Encode; return $string if Encode::is_utf8( $string ); # try all the BOMs in order looking for one (order is important # 32bit BOMs look like 16bit BOMs) my $count = 0; while ($count < @{ $boms }) { my $enc = $boms->[$count++]; my $bom = $boms->[$count++]; # does the string start with the bom? if ($bom eq substr($string, 0, length($bom))) { # decode it and hand it back return Encode::decode($enc, substr($string, length($bom)), 1); } } return $self->{ ENCODING } ? Encode::decode( $self->{ ENCODING }, $string ) : $string; } 1; __END__ =head1 NAME Template::Provider - Provider module for loading/compiling templates =head1 SYNOPSIS $provider = Template::Provider->new(\%options); ($template, $error) = $provider->fetch($name); =head1 DESCRIPTION The L<Template::Provider> is used to load, parse, compile and cache template documents. This object may be sub-classed to provide more specific facilities for loading, or otherwise providing access to templates. The L<Template::Context> objects maintain a list of L<Template::Provider> objects which are polled in turn (via L<fetch()|Template::Context#fetch()>) to return a requested template. Each may return a compiled template, raise an error, or decline to serve the request, giving subsequent providers a chance to do so. The L<Template::Provider> can also be subclassed to provide templates from a different source, e.g. a database. See L<SUBCLASSING> below. This documentation needs work. =head1 PUBLIC METHODS =head2 new(\%options) Constructor method which instantiates and returns a new C<Template::Provider> object. A reference to a hash array of configuration options may be passed. See L<CONFIGURATION OPTIONS> below for a summary of configuration options and L<Template::Manual::Config> for full details. =head2 fetch($name) Returns a compiled template for the name specified. If the template cannot be found then C<(undef, STATUS_DECLINED)> is returned. If an error occurs (e.g. read error, parse error) then C<($error, STATUS_ERROR)> is returned, where C<$error> is the error message generated. If the L<TOLERANT> option is set the the method returns C<(undef, STATUS_DECLINED)> instead of returning an error. =head2 load($name) Loads a template without parsing or compiling it. This is used by the the L<INSERT|Template::Manual::Directives#INSERT> directive. =head2 store($name, $template) Stores the compiled template, C<$template>, in the cache under the name, C<$name>. Susbequent calls to C<fetch($name)> will return this template in preference to any disk-based file. =head2 include_path(\@newpath) Accessor method for the C<INCLUDE_PATH> setting. If called with an argument, this method will replace the existing C<INCLUDE_PATH> with the new value. =head2 paths() This method generates a copy of the C<INCLUDE_PATH> list. Any elements in the list which are dynamic generators (e.g. references to subroutines or objects implementing a C<paths()> method) will be called and the list of directories returned merged into the output list. It is possible to provide a generator which returns itself, thus sending this method into an infinite loop. To detect and prevent this from happening, the C<$MAX_DIRS> package variable, set to C<64> by default, limits the maximum number of paths that can be added to, or generated for the output list. If this number is exceeded then the method will immediately return an error reporting as much. =head1 CONFIGURATION OPTIONS The following list summarises the configuration options that can be provided to the C<Template::Provider> L<new()> constructor. Please consult L<Template::Manual::Config> for further details and examples of each configuration option in use. =head2 INCLUDE_PATH The L<INCLUDE_PATH|Template::Manual::Config#INCLUDE_PATH> option is used to specify one or more directories in which template files are located. # single path my $provider = Template::Provider->new({ INCLUDE_PATH => '/usr/local/templates', }); # multiple paths my $provider = Template::Provider->new({ INCLUDE_PATH => [ '/usr/local/templates', '/tmp/my/templates' ], }); =head2 ABSOLUTE The L<ABSOLUTE|Template::Manual::Config#ABSOLUTE> flag is used to indicate if templates specified with absolute filenames (e.g. 'C</foo/bar>') should be processed. It is disabled by default and any attempt to load a template by such a name will cause a 'C<file>' exception to be raised. my $provider = Template::Provider->new({ ABSOLUTE => 1, }); =head2 RELATIVE The L<RELATIVE|Template::Manual::Config#RELATIVE> flag is used to indicate if templates specified with filenames relative to the current directory (e.g. C<./foo/bar> or C<../../some/where/else>) should be loaded. It is also disabled by default, and will raise a C<file> error if such template names are encountered. my $provider = Template::Provider->new({ RELATIVE => 1, }); =head2 DEFAULT The L<DEFAULT|Template::Manual::Config#DEFAULT> option can be used to specify a default template which should be used whenever a specified template can't be found in the L<INCLUDE_PATH>. my $provider = Template::Provider->new({ DEFAULT => 'notfound.html', }); If a non-existant template is requested through the L<Template> L<process()|Template#process()> method, or by an C<INCLUDE>, C<PROCESS> or C<WRAPPER> directive, then the C<DEFAULT> template will instead be processed, if defined. Note that the C<DEFAULT> template is not used when templates are specified with absolute or relative filenames, or as a reference to a input file handle or text string. =head2 ENCODING The Template Toolkit will automatically decode Unicode templates that have a Byte Order Marker (BOM) at the start of the file. This option can be used to set the default encoding for templates that don't define a BOM. my $provider = Template::Provider->new({ ENCODING => 'utf8', }); See L<Encode> for further information. =head2 CACHE_SIZE The L<CACHE_SIZE|Template::Manual::Config#CACHE_SIZE> option can be used to limit the number of compiled templates that the module should cache. By default, the L<CACHE_SIZE|Template::Manual::Config#CACHE_SIZE> is undefined and all compiled templates are cached. my $provider = Template::Provider->new({ CACHE_SIZE => 64, # only cache 64 compiled templates }); =head2 STAT_TTL The L<STAT_TTL|Template::Manual::Config#STAT_TTL> value can be set to control how long the C<Template::Provider> will keep a template cached in memory before checking to see if the source template has changed. my $provider = Template::Provider->new({ STAT_TTL => 60, # one minute }); =head2 COMPILE_EXT The L<COMPILE_EXT|Template::Manual::Config#COMPILE_EXT> option can be provided to specify a filename extension for compiled template files. It is undefined by default and no attempt will be made to read or write any compiled template files. my $provider = Template::Provider->new({ COMPILE_EXT => '.ttc', }); =head2 COMPILE_DIR The L<COMPILE_DIR|Template::Manual::Config#COMPILE_DIR> option is used to specify an alternate directory root under which compiled template files should be saved. my $provider = Template::Provider->new({ COMPILE_DIR => '/tmp/ttc', }); =head2 TOLERANT The L<TOLERANT|Template::Manual::Config#TOLERANT> flag can be set to indicate that the C<Template::Provider> module should ignore any errors encountered while loading a template and instead return C<STATUS_DECLINED>. =head2 PARSER The L<PARSER|Template::Manual::Config#PARSER> option can be used to define a parser module other than the default of L<Template::Parser>. my $provider = Template::Provider->new({ PARSER => MyOrg::Template::Parser->new({ ... }), }); =head2 DEBUG The L<DEBUG|Template::Manual::Config#DEBUG> option can be used to enable debugging messages from the L<Template::Provider> module by setting it to include the C<DEBUG_PROVIDER> value. use Template::Constants qw( :debug ); my $template = Template->new({ DEBUG => DEBUG_PROVIDER, }); =head1 SUBCLASSING The C<Template::Provider> module can be subclassed to provide templates from a different source (e.g. a database). In most cases you'll just need to provide custom implementations of the C<_template_modified()> and C<_template_content()> methods. If your provider requires and custom initialisation then you'll also need to implement a new C<_init()> method. Caching in memory and on disk will still be applied (if enabled) when overriding these methods. =head2 _template_modified($path) Returns a timestamp of the C<$path> passed in by calling C<stat()>. This can be overridden, for example, to return a last modified value from a database. The value returned should be a timestamp value (as returned by C<time()>, although a sequence number should work as well. =head2 _template_content($path) This method returns the content of the template for all C<INCLUDE>, C<PROCESS>, and C<INSERT> directives. When called in scalar context, the method returns the content of the template located at C<$path>, or C<undef> if C<$path> is not found. When called in list context it returns C<($content, $error, $mtime)>, where C<$content> is the template content, C<$error> is an error string (e.g. "C<$path: File not found>"), and C<$mtime> is the template modification time. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template>, L<Template::Parser>, L<Template::Context> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/App/ttree.pm 0000444 00000100164 15125513451 0011111 0 ustar 00 package Template::App::ttree; #======================================================================== # # Template::App::ttre # # DESCRIPTION # Script for processing all directory trees containing templates. # Template files are processed and the output directed to the # relvant file in an output tree. The timestamps of the source and # destination files can then be examined for future invocations # to process only those files that have changed. In other words, # it's a lot like 'make' for templates. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2013 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2003 Canon Research Centre Europe Ltd. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== use strict; use warnings; use base 'Template::Base'; our $VERSION = '2.91'; use Template; use AppConfig qw( :expand ); use File::Copy; use File::Path; use File::Spec; use File::Basename; use Text::ParseWords qw(quotewords); use constant DEFAULT_TTMODULE => 'Template'; use constant DEFAULT_HOME => $ENV{ HOME } || ''; sub emit_warn { my $self = shift; my $msg = shift; warn $msg; } sub emit_log { my $self = shift; print @_ } sub _get_myname { my $self = shift; (split /[:]{2}/, __PACKAGE__)[-1]; } sub _get_rc_file { my $self = shift; my $NAME = $self->_get_myname(); return $ENV{"\U${NAME}rc"} || DEFAULT_HOME . "/.${NAME}rc"; } sub offer_create_a_sample_config_file { my $self = shift; my $RCFILE = $self->_get_rc_file(); # offer create a sample config file if it doesn't exist, unless a '-f' # has been specified on the command line unless (-f $RCFILE or grep(/^(-f|-h|--help)$/, @ARGV) ) { $self->emit_log("Do you want me to create a sample '.ttreerc' file for you?\n", "(file: $RCFILE) [y/n]: "); my $y = <STDIN>; if ($y =~ /^y(es)?/i) { $self->write_config($RCFILE); exit(0); } } } sub run { my $self = shift; my $NAME = $self->_get_myname(); #------------------------------------------------------------------------ # configuration options #------------------------------------------------------------------------ # read configuration file and command line arguments - I need to remember # to fix varlist() and varhash() in AppConfig to make this nicer... my $config = $self->read_config( $self->_get_rc_file() ); my $dryrun = $config->nothing; my $verbose = $config->verbose || $dryrun; my $colour = $config->colour; my $summary = $config->summary; my $recurse = $config->recurse; my $preserve = $config->preserve; my $all = $config->all; my $libdir = $config->lib; my $ignore = $config->ignore; my $copy = $config->copy; my $link = $config->link; my $accept = $config->accept; my $absolute = $config->absolute; my $relative = $config->relative; my $suffix = $config->suffix; my $binmode = $config->binmode; my $depends = $config->depend; my $depsfile = $config->depend_file; my $copy_dir = $config->copy_dir; my ($n_proc, $n_unmod, $n_skip, $n_copy, $n_link, $n_mkdir) = (0) x 6; my $srcdir = $config->src || die "Source directory not set (-s)\n"; my $destdir = $config->dest || die "Destination directory not set (-d)\n"; die "Source and destination directories may not be the same:\n $srcdir\n" if $srcdir eq $destdir; # unshift any perl5lib directories onto front of INC unshift(@INC, @{ $config->perl5lib }); # get all template_* options from the config and fold keys to UPPER CASE my %ttopts = $config->varlist('^template_', 1); my $ttmodule = delete($ttopts{ module }); my $ucttopts = { map { my $v = $ttopts{ $_ }; defined $v ? (uc $_, $v) : () } keys %ttopts, }; # get all template variable definitions my $replace = $config->get('define'); # now create complete parameter hash for creating template processor my $ttopts = { %$ucttopts, RELATIVE => $relative, ABSOLUTE => $absolute, INCLUDE_PATH => [ $srcdir, @$libdir ], OUTPUT_PATH => $destdir, }; # load custom template module if ($ttmodule) { my $ttpkg = $ttmodule; $ttpkg =~ s[::][/]g; $ttpkg .= '.pm'; require $ttpkg; } else { $ttmodule = DEFAULT_TTMODULE; } #------------------------------------------------------------------------ # inter-file dependencies #------------------------------------------------------------------------ if ($depsfile or $depends) { $depends = $self->dependencies($depsfile, $depends); } else { $depends = { }; } my $global_deps = $depends->{'*'} || [ ]; # add any PRE_PROCESS, etc., templates as global dependencies foreach my $ttopt (qw( PRE_PROCESS POST_PROCESS PROCESS WRAPPER )) { my $deps = $ucttopts->{ $ttopt } || next; my @deps = ref $deps eq 'ARRAY' ? (@$deps) : ($deps); next unless @deps; push(@$global_deps, @deps); } # remove any duplicates $global_deps = { map { ($_ => 1) } @$global_deps }; $global_deps = [ keys %$global_deps ]; # update $depends hash or delete it if there are no dependencies if (@$global_deps) { $depends->{'*'} = $global_deps; } else { delete $depends->{'*'}; $global_deps = undef; } $depends = undef unless keys %$depends; my $DEP_DEBUG = $config->depend_debug(); #------------------------------------------------------------------------ # pre-amble #------------------------------------------------------------------------ if ($colour) { no strict 'refs'; *red = \&_red; *green = \&_green; *yellow = \&_yellow; *blue = \&_blue; } else { no strict 'refs'; *red = \&_white; *green = \&_white; *yellow = \&_white; *blue = \&_white; } if ($verbose) { local $" = ', '; $self->emit_log( "$NAME $VERSION (Template Toolkit version $Template::VERSION)\n\n" ); my $sfx = join(', ', map { "$_ => $suffix->{$_}" } keys %$suffix); $self->emit_log(" Source: $srcdir\n", " Destination: $destdir\n", "Include Path: [ @$libdir ]\n", " Ignore: [ @$ignore ]\n", " Copy: [ @$copy ]\n", " Link: [ @$link ]\n", " Copy_Dir: [ @$copy_dir ]\n", " Accept: [ @$accept ]\n", " Suffix: [ $sfx ]\n"); $self->emit_log(" Module: $ttmodule ", $ttmodule->module_version(), "\n") unless $ttmodule eq DEFAULT_TTMODULE; if ($depends && $DEP_DEBUG) { $self->emit_log("Dependencies:\n"); foreach my $key ('*', grep { !/\*/ } keys %$depends) { $self->emit_log( sprintf( " %-16s %s\n", $key, join(', ', @{ $depends->{ $key } }) ) ) if defined $depends->{ $key }; } } $self->emit_log( "\n" ) if $verbose > 1; $self->emit_log( red("NOTE: dry run, doing nothing...\n") ) if $dryrun; } #------------------------------------------------------------------------ # main processing loop #------------------------------------------------------------------------ my $template = $ttmodule->new($ttopts) || die $ttmodule->error(); my $running_conf = { accept => $accept, all => $all, binmode => $binmode, config => $config, copy => $copy, copy_dir => $copy_dir, depends => $depends, destdir => $destdir, dryrun => $dryrun, ignore => $ignore, libdir => $libdir, link => $link, n_copy => $n_copy, n_link => $n_link, n_mkdir => $n_mkdir, n_proc => $n_proc, n_skip => $n_skip, n_unmod => $n_unmod, preserve => $preserve, recurse => $recurse, replace => $replace, srcdir => $srcdir, suffix => $suffix, template => $template, verbose => $verbose, }; if (@ARGV) { # explicitly process files specified on command lines foreach my $file (@ARGV) { my $path = $srcdir ? File::Spec->catfile($srcdir, $file) : $file; if ( -d $path ) { $self->process_tree($file, $running_conf); } else { $self->process_file($file, $path, $running_conf, force => 1); } } } else { # implicitly process all file in source directory $self->process_tree(undef, $running_conf); } if ($summary || $verbose) { my $format = "%13d %s %s\n"; $self->emit_log( "\n" ) if $verbose > 1; $self->emit_log( " Summary: ", $dryrun ? red("This was a dry run. Nothing was actually done\n") : "\n", green(sprintf($format, $n_proc, $n_proc == 1 ? 'file' : 'files', 'processed')), green(sprintf($format, $n_copy, $n_copy == 1 ? 'file' : 'files', 'copied')), green(sprintf($format, $n_link, $n_link == 1 ? 'file' : 'files', 'linked')), green(sprintf($format, $n_mkdir, $n_mkdir == 1 ? 'directory' : 'directories', 'created')), yellow(sprintf($format, $n_unmod, $n_unmod == 1 ? 'file' : 'files', 'skipped (not modified)')), yellow(sprintf($format, $n_skip, $n_skip == 1 ? 'file' : 'files', 'skipped (ignored)')) ); } } #======================================================================== # END #======================================================================== #------------------------------------------------------------------------ # $self->process_tree($dir) # # Walks the directory tree starting at $dir or the current directory # if unspecified, processing files as found. #------------------------------------------------------------------------ sub process_tree { my $self = shift; my $dir = shift; my $running_conf = shift; my( $destdir, $dryrun, $ignore, $n_mkdir, $n_skip, $recurse, $srcdir, $verbose, ) = @{ $running_conf }{ qw( destdir dryrun ignore n_mkdir n_skip recurse srcdir verbose )}; my ($file, $path, $abspath, $check); my $target; local *DIR; my $absdir = join('/', $srcdir ? $srcdir : (), defined $dir ? $dir : ()); $absdir ||= '.'; opendir(DIR, $absdir) || do { $self->emit_warn("$absdir: $!\n"); return undef; }; FILE: while (defined ($file = readdir(DIR))) { next if $file eq '.' || $file eq '..'; $path = defined $dir ? "$dir/$file" : $file; $abspath = "$absdir/$file"; next unless -e $abspath; # check against ignore list foreach $check (@$ignore) { if ($path =~ /$check/) { $self->emit_log( yellow(sprintf " - %-32s (ignored, matches /$check/)\n", $path ) ) if $verbose > 1; $n_skip++; next FILE; } } if (-d $abspath) { if ($recurse) { my ($uid, $gid, $mode); (undef, undef, $mode, undef, $uid, $gid, undef, undef, undef, undef, undef, undef, undef) = stat($abspath); # create target directory if required $target = "$destdir/$path"; unless (-d $target || $dryrun) { mkpath($target, $verbose, $mode) or die red("Could not mkpath ($target): $!\n"); # commented out by abw on 2000/12/04 - seems to raise a warning? # chown($uid, $gid, $target) || warn "chown($target): $!\n"; $n_mkdir++; $self->emit_log( green( sprintf " + %-32s (created target directory)\n", $path ) ) if $verbose; } # recurse into directory $self->process_tree($path, $running_conf); } else { $n_skip++; $self->emit_log( yellow(sprintf " - %-32s (directory, not recursing)\n", $path ) ) if $verbose > 1; } } else { $self->process_file($path, $abspath, $running_conf); } } closedir(DIR); } #------------------------------------------------------------------------ # $self->process_file() # # File filtering and processing sub-routine called by $self->process_tree() #------------------------------------------------------------------------ sub process_file { my $self = shift; my ($file, $absfile, $running_conf, %options) = @_; my( $accept, $all, $binmode, $config, $copy, $copy_dir, $depends, $destdir, $dryrun, $libdir, $link, $n_copy, $n_link, $n_proc, $n_skip, $n_unmod, $preserve, $replace, $srcdir, $suffix, $template, $verbose, ) = @{ $running_conf }{ qw( accept all binmode config copy copy_dir depends destdir dryrun libdir link n_copy n_link n_proc n_skip n_unmod preserve replace srcdir suffix template verbose )}; my ($dest, $destfile, $filename, $check, $srctime, $desttime, $mode, $uid, $gid); my ($old_suffix, $new_suffix); my $is_dep = 0; my $copy_file = 0; my $link_file = 0; $absfile ||= $file; $filename = basename($file); $destfile = $file; # look for any relevant suffix mapping if (%$suffix) { if ($filename =~ m/\.(.+)$/) { $old_suffix = $1; if ($new_suffix = $suffix->{ $old_suffix }) { $destfile =~ s/$old_suffix$/$new_suffix/; } } } $dest = $destdir ? "$destdir/$destfile" : $destfile; # $self->emit_log( "proc $file => $dest\n" ); unless ($link_file) { # check against link list foreach my $link_pattern (@$link) { if ($filename =~ /$link_pattern/) { $link_file = $copy_file = 1; $check = "/$link_pattern/"; last; } } } unless ($link_file) { foreach my $prefix (@$copy_dir) { if ( index($file, "$prefix/") == 0 ) { $copy_file = 1; $check = "copy_dir: $prefix"; last; } } } unless ($copy_file) { # check against copy list foreach my $copy_pattern (@$copy) { if ($filename =~ /$copy_pattern/) { $copy_file = 1; $check = "/$copy_pattern/"; last; } } } # check against acceptance list if (not $copy_file and @$accept) { unless (grep { $filename =~ /$_/ } @$accept) { $self->emit_log( yellow( sprintf " - %-32s (not accepted)\n", $file ) ) if $verbose > 1; $n_skip++; return; } } # stat the source file unconditionally, so we can preserve # mode and ownership ( undef, undef, $mode, undef, $uid, $gid, undef, undef, undef, $srctime, undef, undef, undef ) = stat($absfile); # test modification time of existing destination file if (! $all && ! $options{ force } && -f $dest) { $desttime = ( stat($dest) )[9]; if (defined $depends and not $copy_file) { my $deptime = $self->depend_time($file, $depends, $config, $libdir, $srcdir); if (defined $deptime && ($srctime < $deptime)) { $srctime = $deptime; $is_dep = 1; } } if ($desttime >= $srctime) { $self->emit_log( yellow( sprintf " - %-32s (not modified)\n", $file ) ) if $verbose > 1; $n_unmod++; return; } } # check against link list if ($link_file) { unless ($dryrun) { if (link($absfile, $dest) == 1) { $copy_file = 0; } else { $self->emit_warn( red("Could not link ($absfile to $dest) : $!\n") ); } } unless ($copy_file) { $n_link++; $self->emit_log( green( sprintf " > %-32s (linked, matches $check)\n", $file ) ) if $verbose; return; } } # check against copy list if ($copy_file) { $n_copy++; unless ($dryrun) { copy($absfile, $dest) or die red("Could not copy ($absfile to $dest) : $!\n"); if ($preserve) { chown($uid, $gid, $dest) || $self->emit_warn( red("chown($dest): $!\n") ); chmod($mode, $dest) || $self->emit_warn( red("chmod($dest): $!\n") ); } } $self->emit_log( green( sprintf " > %-32s (copied, matches $check)\n", $file ) ) if $verbose; return; } $n_proc++; if ($verbose) { $self->emit_log( green( sprintf " + %-32s", $file) ); $self->emit_log( green( sprintf " (changed suffix to $new_suffix)") ) if $new_suffix; $self->emit_log( "\n" ); } # process file unless ($dryrun) { $template->process($file, $replace, $destfile, $binmode ? {binmode => $binmode} : {}) || $self->emit_log(red(" ! "), $template->error(), "\n"); if ($preserve) { chown($uid, $gid, $dest) || $self->emit_warn( red("chown($dest): $!\n") ); chmod($mode, $dest) || $self->emit_warn( red("chmod($dest): $!\n") ); } } } #------------------------------------------------------------------------ # $self->dependencies($file, $depends) # # Read the dependencies from $file, if defined, and merge in with # those passed in as the hash array $depends, if defined. #------------------------------------------------------------------------ sub dependencies { my $self = shift; my ($file, $depend) = @_; my %depends = (); if (defined $file) { my ($fh, $text, $line); open $fh, $file or die "Can't open $file, $!"; local $/ = undef; $text = <$fh>; close($fh); $text =~ s[\\\n][]mg; foreach $line (split("\n", $text)) { next if $line =~ /^\s*(#|$)/; chomp $line; my ($file, @files) = quotewords('\s*:\s*', 0, $line); $file =~ s/^\s+//; @files = grep(defined, quotewords('(,|\s)\s*', 0, @files)); $depends{$file} = \@files; } } if (defined $depend) { foreach my $key (keys %$depend) { $depends{$key} = [ quotewords(',', 0, $depend->{$key}) ]; } } return \%depends; } #------------------------------------------------------------------------ # $self->depend_time($file, \%depends) # # Returns the mtime of the most recent in @files. #------------------------------------------------------------------------ sub depend_time { my $self = shift; my ($file, $depends, $config, $libdir, $srcdir) = @_; my ($deps, $absfile, $modtime); my $maxtime = 0; my @pending = ($file); my @files; my %seen; my $DEP_DEBUG = $config->depend_debug(); # push any global dependencies onto the pending list if ($deps = $depends->{'*'}) { push(@pending, @$deps); } $self->emit_log( " # checking dependencies for $file...\n" ) if $DEP_DEBUG; # iterate through the list of pending files while (@pending) { $file = shift @pending; next if $seen{ $file }++; if (File::Spec->file_name_is_absolute($file) && -f $file) { $modtime = (stat($file))[9]; $self->emit_log( " # $file [$modtime]\n" ) if $DEP_DEBUG; } else { $modtime = 0; foreach my $dir ($srcdir, @$libdir) { $absfile = File::Spec->catfile($dir, $file); if (-f $absfile) { $modtime = (stat($absfile))[9]; $self->emit_log( " # $absfile [$modtime]\n" ) if $DEP_DEBUG; last; } } } $maxtime = $modtime if $modtime > $maxtime; if ($deps = $depends->{ $file }) { push(@pending, @$deps); $self->emit_log( " # depends on ", join(', ', @$deps), "\n" ) if $DEP_DEBUG; } } return $maxtime; } #------------------------------------------------------------------------ # read_config($file) # # Handles reading of config file and/or command line arguments. #------------------------------------------------------------------------ sub read_config { my $self = shift; my $file = shift; my $NAME = $self->_get_myname(); my $verbose = 0; my $verbinc = sub { my ($state, $var, $value) = @_; $state->{ VARIABLE }->{ verbose } = $value ? ++$verbose : --$verbose; }; my $config = AppConfig->new( { ERROR => sub { die(@_, "\ntry `$NAME --help'\n") } }, 'help|h' => { ACTION => sub { $self->help } }, 'src|s=s' => { EXPAND => EXPAND_ALL }, 'dest|d=s' => { EXPAND => EXPAND_ALL }, 'lib|l=s@' => { EXPAND => EXPAND_ALL }, 'cfg|c=s' => { EXPAND => EXPAND_ALL, DEFAULT => '.' }, 'verbose|v' => { DEFAULT => 0, ACTION => $verbinc }, 'recurse|r' => { DEFAULT => 0 }, 'nothing|n' => { DEFAULT => 0 }, 'preserve|p' => { DEFAULT => 0 }, 'absolute' => { DEFAULT => 0 }, 'relative' => { DEFAULT => 0 }, 'colour|color'=> { DEFAULT => 0 }, 'summary' => { DEFAULT => 0 }, 'all|a' => { DEFAULT => 0 }, 'define=s%', 'suffix=s%', 'binmode=s', 'ignore=s@', 'copy=s@', 'link=s@', 'accept=s@', 'depend=s%', 'depend_debug|depdbg', 'depend_file|depfile=s' => { EXPAND => EXPAND_ALL }, 'copy_dir=s@', 'template_module|module=s', 'template_anycase|anycase', 'template_encoding|encoding=s', 'template_eval_perl|eval_perl', 'template_load_perl|load_perl', 'template_interpolate|interpolate', 'template_pre_chomp|pre_chomp|prechomp', 'template_post_chomp|post_chomp|postchomp', 'template_trim|trim', 'template_pre_process|pre_process|preprocess=s@', 'template_post_process|post_process|postprocess=s@', 'template_process|process=s', 'template_wrapper|wrapper=s', 'template_recursion|recursion', 'template_expose_blocks|expose_blocks', 'template_default|default=s', 'template_error|error=s', 'template_debug|debug=s', 'template_strict|strict', 'template_start_tag|start_tag|starttag=s', 'template_end_tag|end_tag|endtag=s', 'template_tag_style|tag_style|tagstyle=s', 'template_compile_ext|compile_ext=s', 'template_compile_dir|compile_dir=s' => { EXPAND => EXPAND_ALL }, 'template_plugin_base|plugin_base|pluginbase=s@' => { EXPAND => EXPAND_ALL }, 'perl5lib|perllib=s@' => { EXPAND => EXPAND_ALL }, ); # add the 'file' option now that we have a $config object that we # can reference in a closure $config->define( 'file|f=s@' => { EXPAND => EXPAND_ALL, ACTION => sub { my ($state, $item, $file) = @_; $file = $state->cfg . "/$file" unless $file =~ /^[\.\/]|(?:\w:)/; $config->file($file) } } ); # process main config file, then command line args $config->file($file) if -f $file; $config->args(); $config; } sub ANSI_escape { my $attr = shift; my $text = join('', @_); return join("\n", map { # look for an existing escape start sequence and add new # attribute to it, otherwise add escape start/end sequences s/ \e \[ ([1-9][\d;]*) m/\e[$1;${attr}m/gx ? $_ : "\e[${attr}m" . $_ . "\e[0m"; } split(/\n/, $text, -1) # -1 prevents it from ignoring trailing fields ); } sub _red(@) { ANSI_escape(31, @_) } sub _green(@) { ANSI_escape(32, @_) } sub _yellow(@) { ANSI_escape(33, @_) } sub _blue(@) { ANSI_escape(34, @_) } sub _white(@) { @_ } # nullop #------------------------------------------------------------------------ # $self->write_config($file) # # Writes a sample configuration file to the filename specified. #------------------------------------------------------------------------ sub write_config { my $self = shift; my $file = shift; my $NAME = $self->_get_myname(); open(CONFIG, ">", $file) || die "failed to create $file: $!\n"; print(CONFIG <<END_OF_CONFIG); #------------------------------------------------------------------------ # sample .ttreerc file created automatically by $NAME version $VERSION # # This file originally written to $file # # For more information on the contents of this configuration file, see # # perldoc ttree # ttree -h # #------------------------------------------------------------------------ # The most flexible way to use ttree is to create a separate directory # for configuration files and simply use the .ttreerc to tell ttree where # it is. # # cfg = /path/to/ttree/config/directory # print summary of what's going on verbose # recurse into any sub-directories and process files recurse # regexen of things that aren't templates and should be ignored ignore = \\b(CVS|RCS)\\b ignore = ^# # ditto for things that should be copied rather than processed. copy = \\.png\$ copy = \\.gif\$ # ditto for things that should be linked rather than copied / processed. # link = \\.flv\$ # by default, everything not ignored or copied is accepted; add 'accept' # lines if you want to filter further. e.g. # # accept = \\.html\$ # accept = \\.tt2\$ # options to rewrite files suffixes (htm => html, tt2 => html) # # suffix htm=html # suffix tt2=html # options to define dependencies between templates # # depend *=header,footer,menu # depend index.html=mainpage,sidebar # depend menu=menuitem,menubar # #------------------------------------------------------------------------ # The following options usually relate to a particular project so # you'll probably want to put them in a separate configuration file # in the directory specified by the 'cfg' option and then invoke tree # using '-f' to tell it which configuration you want to use. # However, there's nothing to stop you from adding default 'src', # 'dest' or 'lib' options in the .ttreerc. The 'src' and 'dest' options # can be re-defined in another configuration file, but be aware that 'lib' # options accumulate so any 'lib' options defined in the .ttreerc will # be applied every time you run ttree. #------------------------------------------------------------------------ # # directory containing source page templates # src = /path/to/your/source/page/templates # # # directory where output files should be written # dest = /path/to/your/html/output/directory # # # additional directories of library templates # lib = /first/path/to/your/library/templates # lib = /second/path/to/your/library/templates END_OF_CONFIG close(CONFIG); $self->emit_log( "$file created. Please edit accordingly and re-run $NAME\n" ); } #------------------------------------------------------------------------ # help() # # Prints help message and exits. #------------------------------------------------------------------------ sub help { my $self = shift; my $NAME = $self->_get_myname(); print<<END_OF_HELP; $NAME $VERSION (Template Toolkit version $Template::VERSION) usage: $NAME [options] [files] Options: -a (--all) Process all files, regardless of modification -r (--recurse) Recurse into sub-directories -p (--preserve) Preserve file ownership and permission -n (--nothing) Do nothing, just print summary (enables -v) -v (--verbose) Verbose mode. Use twice for more verbosity: -v -v -h (--help) This help -s DIR (--src=DIR) Source directory -d DIR (--dest=DIR) Destination directory -c DIR (--cfg=DIR) Location of configuration files -l DIR (--lib=DIR) Library directory (INCLUDE_PATH) (multiple) -f FILE (--file=FILE) Read named configuration file (multiple) Display options: --colour / --color Enable colo(u)rful verbose output. --summary Show processing summary. File search specifications (all may appear multiple times): --ignore=REGEX Ignore files matching REGEX --copy=REGEX Copy files matching REGEX --link=REGEX Link files matching REGEX --copy_dir=DIR Copy files in dir DIR (recursive) --accept=REGEX Process only files matching REGEX File Dependencies Options: --depend foo=bar,baz Specify that 'foo' depends on 'bar' and 'baz'. --depend_file FILE Read file dependancies from FILE. --depend_debug Enable debugging for dependencies File suffix rewriting (may appear multiple times) --suffix old=new Change any '.old' suffix to '.new' File encoding options --binmode=value Set binary mode of output files --encoding=value Set encoding of input files Additional options to set Template Toolkit configuration items: --define var=value Define template variable --interpolate Interpolate '\$var' references in text --anycase Accept directive keywords in any case. --pre_chomp Chomp leading whitespace --post_chomp Chomp trailing whitespace --trim Trim blank lines around template blocks --eval_perl Evaluate [% PERL %] ... [% END %] code blocks --load_perl Load regular Perl modules via USE directive --absolute Enable the ABSOLUTE option --relative Enable the RELATIVE option --pre_process=TEMPLATE Process TEMPLATE before each main template --post_process=TEMPLATE Process TEMPLATE after each main template --process=TEMPLATE Process TEMPLATE instead of main template --wrapper=TEMPLATE Process TEMPLATE wrapper around main template --default=TEMPLATE Use TEMPLATE as default --error=TEMPLATE Use TEMPLATE to handle errors --debug=STRING Set TT DEBUG option to STRING --start_tag=STRING STRING defines start of directive tag --end_tag=STRING STRING defined end of directive tag --tag_style=STYLE Use pre-defined tag STYLE --plugin_base=PACKAGE Base PACKAGE for plugins --compile_ext=STRING File extension for compiled template files --compile_dir=DIR Directory for compiled template files --perl5lib=DIR Specify additional Perl library directories --template_module=MODULE Specify alternate Template module See 'perldoc ttree' for further information. END_OF_HELP exit(0); } 1; __END__ =head1 NAME Template::App::ttree - Backend of ttree =head1 SYNOPSIS See L<Template::Tools::ttree|ttree>. =head1 DESCRIPTION See L<Template::Tools::ttree|ttree>. =head1 AUTHORS Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://www.wardley.org> With contributions from Dylan William Hardison (support for dependencies), Bryce Harrington (C<absolute> and C<relative> options), Mark Anderson (C<suffix> and C<debug> options), Harald Joerg and Leon Brocard who gets everywhere, it seems. =head1 COPYRIGHT Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Tools::ttree|ttree> =cut 5.32/Template/Stash/XS.pm 0000444 00000006150 15125513451 0010662 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Stash::XS # # DESCRIPTION # # Perl bootstrap for XS module. Inherits methods from # Template::Stash when not implemented in the XS module. # #======================================================================== package Template::Stash::XS; use strict; use warnings; use Template; use Template::Stash; use XSLoader; our $AUTOLOAD; our @ISA = qw( Template::Stash ); XSLoader::load 'Template::Stash::XS', $Template::VERSION; sub DESTROY { # no op 1; } # catch missing method calls here so perl doesn't barf # trying to load *.al files sub AUTOLOAD { my ($self, @args) = @_; my @c = caller(0); my $auto = $AUTOLOAD; $auto =~ s/.*:://; $self =~ s/=.*//; die "Can't locate object method \"$auto\"" . " via package \"$self\" at $c[1] line $c[2]\n"; } 1; __END__ =head1 NAME Template::Stash::XS - High-speed variable stash written in C =head1 SYNOPSIS use Template; use Template::Stash::XS; my $stash = Template::Stash::XS->new(\%vars); my $tt2 = Template->new({ STASH => $stash }); =head1 DESCRIPTION The Template:Stash::XS module is an implementation of the Template::Stash written in C. The "XS" in the name refers to Perl's XS extension system for interfacing Perl to C code. It works just like the regular Perl implementation of Template::Stash but runs about twice as fast. The easiest way to use the XS stash is to configure the Template Toolkit to use it by default. You can do this at installation time (when you run C<perl Makefile.PL>) by answering 'y' to the questions: Do you want to build the XS Stash module? y Do you want to use the XS Stash by default? y See the F<INSTALL> file distributed with the Template Toolkit for further details on installation. If you don't elect to use the XS stash by default then you should use the C<STASH> configuration item when you create a new Template object. This should reference an XS stash object that you have created manually. use Template; use Template::Stash::XS; my $stash = Template::Stash::XS->new(\%vars); my $tt2 = Template->new({ STASH => $stash }); Alternately, you can set the C<$Template::Config::STASH> package variable like so: use Template; use Template::Config; $Template::Config::STASH = 'Template::Stash::XS'; my $tt2 = Template->new(); The XS stash will then be automatically used. If you want to use the XS stash by default and don't want to re-install the Template Toolkit, then you can manually modify the C<Template/Config.pm> module near line 42 to read: $STASH = 'Template::Stash::XS'; =head1 BUGS Please report bugs to the Template Toolkit mailing list templates@template-toolkit.org =head1 AUTHORS Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> Doug Steinwand E<lt>dsteinwand@citysearch.comE<gt> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Stash> 5.32/Template/Stash/Context.pm 0000444 00000063240 15125513451 0011757 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Stash::Context # # DESCRIPTION # This is an alternate stash object which includes a patch from # Craig Barratt to implement various new virtual methods to allow # dotted template variable to denote if object methods and subroutines # should be called in scalar or list context. It adds a little overhead # to each stash call and I'm a little wary of doing that. So for now, # it's implemented as a separate stash module which will allow us to # test it out, benchmark it and switch it in or out as we require. # # This is what Craig has to say about it: # # Here's a better set of features for the core. Attached is a new version # of Stash.pm (based on TT2.02) that: # # - supports the special op "scalar" that forces scalar context on # function calls, eg: # # cgi.param("foo").scalar # # calls cgi.param("foo") in scalar context (unlike my wimpy # scalar op from last night). Array context is the default. # # With non-function operands, scalar behaves like the perl # version (eg: no-op for scalar, size for arrays, etc). # # - supports the special op "ref" that behaves like the perl ref. # If applied to a function the function is not called. Eg: # # cgi.param("foo").ref # # does *not* call cgi.param and evaluates to "CODE". Similarly, # HASH.ref, ARRAY.ref return what you expect. # # - adds a new scalar and list op called "array" that is a no-op for # arrays and promotes scalars to one-element arrays. # # - allows scalar ops to be applied to arrays and hashes in place, # eg: ARRAY.repeat(3) repeats each element in place. # # - allows list ops to be applied to scalars by promoting the scalars # to one-element arrays (like an implicit "array"). So you can # do things like SCALAR.size, SCALAR.join and get a useful result. # # This also means you can now use x.0 to safely get the first element # whether x is an array or scalar. # # The new Stash.pm passes the TT2.02 test suite. But I haven't tested the # new features very much. One nagging implementation problem is that the # "scalar" and "ref" ops have higher precedence than user variable names. # # AUTHORS # Andy Wardley <abw@kfs.org> # Craig Barratt <craig@arraycomm.com> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2001 Canon Research Centre Europe Ltd. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Stash::Context; use strict; use warnings; use base 'Template::Stash'; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; #======================================================================== # -- PACKAGE VARIABLES AND SUBS -- #======================================================================== #------------------------------------------------------------------------ # copy virtual methods from those in the regular Template::Stash #------------------------------------------------------------------------ our $ROOT_OPS = { %$Template::Stash::ROOT_OPS, defined $ROOT_OPS ? %$ROOT_OPS : (), }; our $SCALAR_OPS = { %$Template::Stash::SCALAR_OPS, 'array' => sub { return [$_[0]] }, defined $SCALAR_OPS ? %$SCALAR_OPS : (), }; our $LIST_OPS = { %$Template::Stash::LIST_OPS, 'array' => sub { return $_[0] }, defined $LIST_OPS ? %$LIST_OPS : (), }; our $HASH_OPS = { %$Template::Stash::HASH_OPS, defined $HASH_OPS ? %$HASH_OPS : (), }; #======================================================================== # ----- CLASS METHODS ----- #======================================================================== #------------------------------------------------------------------------ # new(\%params) # # Constructor method which creates a new Template::Stash object. # An optional hash reference may be passed containing variable # definitions that will be used to initialise the stash. # # Returns a reference to a newly created Template::Stash. #------------------------------------------------------------------------ sub new { my $class = shift; my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ }; my $self = { global => { }, %$params, %$ROOT_OPS, '_PARENT' => undef, '_CLASS' => $class, }; bless $self, $class; } #======================================================================== # ----- PUBLIC OBJECT METHODS ----- #======================================================================== #------------------------------------------------------------------------ # clone(\%params) # # Creates a copy of the current stash object to effect localisation # of variables. The new stash is blessed into the same class as the # parent (which may be a derived class) and has a '_PARENT' member added # which contains a reference to the parent stash that created it # ($self). This member is used in a successive declone() method call to # return the reference to the parent. # # A parameter may be provided which should reference a hash of # variable/values which should be defined in the new stash. The # update() method is called to define these new variables in the cloned # stash. # # Returns a reference to a cloned Template::Stash. #------------------------------------------------------------------------ sub clone { my ($self, $params) = @_; $params ||= { }; # look out for magical 'import' argument which imports another hash my $import = $params->{ import }; if (defined $import && UNIVERSAL::isa($import, 'HASH')) { delete $params->{ import }; } else { undef $import; } my $clone = bless { %$self, # copy all parent members %$params, # copy all new data '_PARENT' => $self, # link to parent }, ref $self; # perform hash import if defined &{ $HASH_OPS->{ import }}($clone, $import) if defined $import; return $clone; } #------------------------------------------------------------------------ # declone($export) # # Returns a reference to the PARENT stash. When called in the following # manner: # $stash = $stash->declone(); # the reference count on the current stash will drop to 0 and be "freed" # and the caller will be left with a reference to the parent. This # contains the state of the stash before it was cloned. #------------------------------------------------------------------------ sub declone { my $self = shift; $self->{ _PARENT } || $self; } #------------------------------------------------------------------------ # get($ident) # # Returns the value for an variable stored in the stash. The variable # may be specified as a simple string, e.g. 'foo', or as an array # reference representing compound variables. In the latter case, each # pair of successive elements in the list represent a node in the # compound variable. The first is the variable name, the second a # list reference of arguments or 0 if undefined. So, the compound # variable [% foo.bar('foo').baz %] would be represented as the list # [ 'foo', 0, 'bar', ['foo'], 'baz', 0 ]. Returns the value of the # identifier or an empty string if undefined. Errors are thrown via # die(). #------------------------------------------------------------------------ sub get { my ($self, $ident, $args) = @_; my ($root, $result); $root = $self; if (ref $ident eq 'ARRAY' || ($ident =~ /\./) && ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ])) { my $size = $#$ident; # if $ident is a list reference, then we evaluate each item in the # identifier against the previous result, using the root stash # ($self) as the first implicit 'result'... foreach (my $i = 0; $i <= $size; $i += 2) { if ( $i + 2 <= $size && ($ident->[$i+2] eq "scalar" || $ident->[$i+2] eq "ref") ) { $result = $self->_dotop($root, @$ident[$i, $i+1], 0, $ident->[$i+2]); $i += 2; } else { $result = $self->_dotop($root, @$ident[$i, $i+1]); } last unless defined $result; $root = $result; } } else { $result = $self->_dotop($root, $ident, $args); } return defined $result ? $result : $self->undefined($ident, $args); } #------------------------------------------------------------------------ # set($ident, $value, $default) # # Updates the value for a variable in the stash. The first parameter # should be the variable name or array, as per get(). The second # parameter should be the intended value for the variable. The third, # optional parameter is a flag which may be set to indicate 'default' # mode. When set true, the variable will only be updated if it is # currently undefined or has a false value. The magical 'IMPORT' # variable identifier may be used to indicate that $value is a hash # reference whose values should be imported. Returns the value set, # or an empty string if not set (e.g. default mode). In the case of # IMPORT, returns the number of items imported from the hash. #------------------------------------------------------------------------ sub set { my ($self, $ident, $value, $default) = @_; my ($root, $result, $error); $root = $self; ELEMENT: { if (ref $ident eq 'ARRAY' || ($ident =~ /\./) && ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ]) ) { # a compound identifier may contain multiple elements (e.g. # foo.bar.baz) and we must first resolve all but the last, # using _dotop() with the $lvalue flag set which will create # intermediate hashes if necessary... my $size = $#$ident; foreach (my $i = 0; $i < $size - 2; $i += 2) { $result = $self->_dotop($root, @$ident[$i, $i+1], 1); last ELEMENT unless defined $result; $root = $result; } # then we call _assign() to assign the value to the last element $result = $self->_assign( $root, @$ident[$size-1, $size], $value, $default ); } else { $result = $self->_assign($root, $ident, 0, $value, $default); } } return defined $result ? $result : ''; } #------------------------------------------------------------------------ # getref($ident) # # Returns a "reference" to a particular item. This is represented as a # closure which will return the actual stash item when called. # WARNING: still experimental! #------------------------------------------------------------------------ sub getref { my ($self, $ident, $args) = @_; my ($root, $item, $result); $root = $self; if (ref $ident eq 'ARRAY') { my $size = $#$ident; foreach (my $i = 0; $i <= $size; $i += 2) { ($item, $args) = @$ident[$i, $i + 1]; last if $i >= $size - 2; # don't evaluate last node last unless defined ($root = $self->_dotop($root, $item, $args)); } } else { $item = $ident; } if (defined $root) { return sub { my @args = (@{$args||[]}, @_); $self->_dotop($root, $item, \@args); } } else { return sub { '' }; } } #------------------------------------------------------------------------ # update(\%params) # # Update multiple variables en masse. No magic is performed. Simple # variable names only. #------------------------------------------------------------------------ sub update { my ($self, $params) = @_; # look out for magical 'import' argument to import another hash my $import = $params->{ import }; if (defined $import && UNIVERSAL::isa($import, 'HASH')) { @$self{ keys %$import } = values %$import; delete $params->{ import }; } @$self{ keys %$params } = values %$params; } #======================================================================== # ----- PRIVATE OBJECT METHODS ----- #======================================================================== #------------------------------------------------------------------------ # _dotop($root, $item, \@args, $lvalue, $nextItem) # # This is the core 'dot' operation method which evaluates elements of # variables against their root. All variables have an implicit root # which is the stash object itself (a hash). Thus, a non-compound # variable 'foo' is actually '(stash.)foo', the compound 'foo.bar' is # '(stash.)foo.bar'. The first parameter is a reference to the current # root, initially the stash itself. The second parameter contains the # name of the variable element, e.g. 'foo'. The third optional # parameter is a reference to a list of any parenthesised arguments # specified for the variable, which are passed to sub-routines, object # methods, etc. The final parameter is an optional flag to indicate # if this variable is being evaluated on the left side of an assignment # (e.g. foo.bar.baz = 10). When set true, intermediated hashes will # be created (e.g. bar) if necessary. # # Returns the result of evaluating the item against the root, having # performed any variable "magic". The value returned can then be used # as the root of the next _dotop() in a compound sequence. Returns # undef if the variable is undefined. #------------------------------------------------------------------------ sub _dotop { my ($self, $root, $item, $args, $lvalue, $nextItem) = @_; my $rootref = ref $root; my ($value, @result, $ret, $retVal); $nextItem ||= ""; my $scalarContext = 1 if ( $nextItem eq "scalar" ); my $returnRef = 1 if ( $nextItem eq "ref" ); $args ||= [ ]; $lvalue ||= 0; # print STDERR "_dotop(root=$root, item=$item, args=[@$args])\n" # if $DEBUG; # return undef without an error if either side of the dot is unviable # or if an attempt is made to access a private member, starting _ or . return undef unless defined($root) and defined($item) and $item !~ /^[\._]/; if (ref(\$root) eq "SCALAR" && !$lvalue && (($value = $LIST_OPS->{ $item }) || $item =~ /^-?\d+$/) ) { # # Promote scalar to one element list, to be processed below. # $rootref = 'ARRAY'; $root = [$root]; } if ($rootref eq $self->{_CLASS} || $rootref eq 'HASH') { # if $root is a regular HASH or a Template::Stash kinda HASH (the # *real* root of everything). We first lookup the named key # in the hash, or create an empty hash in its place if undefined # and the $lvalue flag is set. Otherwise, we check the HASH_OPS # pseudo-methods table, calling the code if found, or return undef. if (defined($value = $root->{ $item })) { ($ret, $retVal, @result) = _dotop_return( $value, $args, $returnRef, $scalarContext ); return $retVal if ( $ret ); ## RETURN } elsif ($lvalue) { # we create an intermediate hash if this is an lvalue return $root->{ $item } = { }; ## RETURN } elsif ($value = $HASH_OPS->{ $item }) { @result = &$value($root, @$args); ## @result } elsif (ref $item eq 'ARRAY') { # hash slice return [@$root{@$item}]; ## RETURN } elsif ($value = $SCALAR_OPS->{ $item }) { # # Apply scalar ops to every hash element, in place. # foreach my $key ( keys %$root ) { $root->{$key} = &$value($root->{$key}, @$args); } } } elsif ($rootref eq 'ARRAY') { # if root is an ARRAY then we check for a LIST_OPS pseudo-method # (except for l-values for which it doesn't make any sense) # or return the numerical index into the array, or undef if (($value = $LIST_OPS->{ $item }) && ! $lvalue) { @result = &$value($root, @$args); ## @result } elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) { # # Apply scalar ops to every array element, in place. # for ( my $i = 0 ; $i < @$root ; $i++ ) { $root->[$i] = &$value($root->[$i], @$args); ## @result } } elsif ($item =~ /^-?\d+$/) { $value = $root->[$item]; ($ret, $retVal, @result) = _dotop_return( $value, $args, $returnRef, $scalarContext ); return $retVal if ( $ret ); ## RETURN } elsif (ref $item eq 'ARRAY' ) { # array slice return [@$root[@$item]]; ## RETURN } } # NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL') # doesn't appear to work with CGI, returning true for the first call # and false for all subsequent calls. elsif (ref($root) && UNIVERSAL::can($root, 'can')) { # if $root is a blessed reference (i.e. inherits from the # UNIVERSAL object base class) then we call the item as a method. # If that fails then we try to fallback on HASH behaviour if # possible. return ref $root->can($item) if ( $returnRef ); ## RETURN eval { @result = $scalarContext ? scalar $root->$item(@$args) : $root->$item(@$args); ## @result }; if ($@) { # failed to call object method, so try some fallbacks if (UNIVERSAL::isa($root, 'HASH') && defined($value = $root->{ $item })) { ($ret, $retVal, @result) = _dotop_return( $value, $args, $returnRef, $scalarContext ); return $retVal if ( $ret ); ## RETURN } elsif (UNIVERSAL::isa($root, 'ARRAY') && ($value = $LIST_OPS->{ $item })) { @result = &$value($root, @$args); } else { @result = (undef, $@); } } } elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) { # at this point, it doesn't look like we've got a reference to # anything we know about, so we try the SCALAR_OPS pseudo-methods # table (but not for l-values) @result = &$value($root, @$args); ## @result } elsif ($self->{ _DEBUG }) { die "don't know how to access [ $root ].$item\n"; ## DIE } else { @result = (); } # fold multiple return items into a list unless first item is undef if (defined $result[0]) { return ref(@result > 1 ? [ @result ] : $result[0] ) if ( $returnRef ); ## RETURN if ( $scalarContext ) { return scalar @result if ( @result > 1 ); ## RETURN return scalar(@{$result[0]}) if ( ref $result[0] eq "ARRAY" ); return scalar(%{$result[0]}) if ( ref $result[0] eq "HASH" ); return $result[0]; ## RETURN } else { return @result > 1 ? [ @result ] : $result[0]; ## RETURN } } elsif (defined $result[1]) { die $result[1]; ## DIE } elsif ($self->{ _DEBUG }) { die "$item is undefined\n"; ## DIE } return undef; } #------------------------------------------------------------------------ # ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef, # $scalarContext); # # Handle the various return processing for _dotop #------------------------------------------------------------------------ sub _dotop_return { my($value, $args, $returnRef, $scalarContext) = @_; my(@result); return (1, ref $value) if ( $returnRef ); ## RETURN if ( $scalarContext ) { return (1, scalar(@$value)) if ref $value eq 'ARRAY'; ## RETURN return (1, scalar(%$value)) if ref $value eq 'HASH'; ## RETURN return (1, scalar($value)) unless ref $value eq 'CODE'; ## RETURN; @result = scalar &$value(@$args) ## @result; } else { return (1, $value) unless ref $value eq 'CODE'; ## RETURN @result = &$value(@$args); ## @result } return (0, undef, @result); } #------------------------------------------------------------------------ # _assign($root, $item, \@args, $value, $default) # # Similar to _dotop() above, but assigns a value to the given variable # instead of simply returning it. The first three parameters are the # root item, the item and arguments, as per _dotop(), followed by the # value to which the variable should be set and an optional $default # flag. If set true, the variable will only be set if currently false # (undefined/zero) #------------------------------------------------------------------------ sub _assign { my ($self, $root, $item, $args, $value, $default) = @_; my $rootref = ref $root; my $result; $args ||= [ ]; $default ||= 0; # print(STDERR "_assign(root=$root, item=$item, args=[@$args], \n", # "value=$value, default=$default)\n") # if $DEBUG; # return undef without an error if either side of the dot is unviable # or if an attempt is made to update a private member, starting _ or . return undef ## RETURN unless $root and defined $item and $item !~ /^[\._]/; if ($rootref eq 'HASH' || $rootref eq $self->{_CLASS}) { # if the root is a hash we set the named key return ($root->{ $item } = $value) ## RETURN unless $default && $root->{ $item }; } elsif ($rootref eq 'ARRAY' && $item =~ /^-?\d+$/) { # or set a list item by index number return ($root->[$item] = $value) ## RETURN unless $default && $root->{ $item }; } elsif (UNIVERSAL::isa($root, 'UNIVERSAL')) { # try to call the item as a method of an object return $root->$item(@$args, $value); ## RETURN } else { die "don't know how to assign to [$root].[$item]\n"; ## DIE } return undef; } 1; __END__ =head1 NAME Template::Stash::Context - Experimetal stash allowing list/scalar context definition =head1 SYNOPSIS use Template; use Template::Stash::Context; my $stash = Template::Stash::Context->new(\%vars); my $tt2 = Template->new({ STASH => $stash }); =head1 DESCRIPTION This is an alternate stash object which includes a patch from Craig Barratt to implement various new virtual methods to allow dotted template variable to denote if object methods and subroutines should be called in scalar or list context. It adds a little overhead to each stash call and I'm a little wary of applying that to the core default stash without investigating the effects first. So for now, it's implemented as a separate stash module which will allow us to test it out, benchmark it and switch it in or out as we require. This is what Craig has to say about it: Here's a better set of features for the core. Attached is a new version of Stash.pm (based on TT2.02) that: * supports the special op "scalar" that forces scalar context on function calls, eg: cgi.param("foo").scalar calls cgi.param("foo") in scalar context (unlike my wimpy scalar op from last night). Array context is the default. With non-function operands, scalar behaves like the perl version (eg: no-op for scalar, size for arrays, etc). * supports the special op "ref" that behaves like the perl ref. If applied to a function the function is not called. Eg: cgi.param("foo").ref does *not* call cgi.param and evaluates to "CODE". Similarly, HASH.ref, ARRAY.ref return what you expect. * adds a new scalar and list op called "array" that is a no-op for arrays and promotes scalars to one-element arrays. * allows scalar ops to be applied to arrays and hashes in place, eg: ARRAY.repeat(3) repeats each element in place. * allows list ops to be applied to scalars by promoting the scalars to one-element arrays (like an implicit "array"). So you can do things like SCALAR.size, SCALAR.join and get a useful result. This also means you can now use x.0 to safely get the first element whether x is an array or scalar. The new Stash.pm passes the TT2.02 test suite. But I haven't tested the new features very much. One nagging implementation problem is that the "scalar" and "ref" ops have higher precedence than user variable names. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/|http://wardley.org/> =head1 VERSION 1.63, distributed as part of the Template Toolkit version 3.100, released on 30 March 2020. =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Stash|Template::Stash> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Context.pm 0000444 00000146273 15125513451 0010705 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Context # # DESCRIPTION # Module defining a context in which a template document is processed. # This is the runtime processing interface through which templates # can access the functionality of the Template Toolkit. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Context; use strict; use warnings; use base 'Template::Base'; use Template::Base; use Template::Config; use Template::Constants; use Template::Exception; use Scalar::Util 'blessed'; use constant DOCUMENT => 'Template::Document'; use constant EXCEPTION => 'Template::Exception'; use constant BADGER_EXCEPTION => 'Badger::Exception'; use constant MSWin32 => $^O eq 'MSWin32'; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $DEBUG_FORMAT = "\n## \$file line \$line : [% \$text %] ##\n"; our $VIEW_CLASS = 'Template::View'; our $AUTOLOAD; #======================================================================== # ----- PUBLIC METHODS ----- #======================================================================== #------------------------------------------------------------------------ # template($name) # # General purpose method to fetch a template and return it in compiled # form. In the usual case, the $name parameter will be a simple string # containing the name of a template (e.g. 'header'). It may also be # a reference to Template::Document object (or sub-class) or a Perl # sub-routine. These are considered to be compiled templates and are # returned intact. Finally, it may be a reference to any other kind # of valid input source accepted by Template::Provider (e.g. scalar # ref, glob, IO handle, etc). # # Templates may be cached at one of 3 different levels. The internal # BLOCKS member is a local cache which holds references to all # template blocks used or imported via PROCESS since the context's # reset() method was last called. This is checked first and if the # template is not found, the method then walks down the BLOCKSTACK # list. This contains references to the block definition tables in # any enclosing Template::Documents that we're visiting (e.g. we've # been called via an INCLUDE and we want to access a BLOCK defined in # the template that INCLUDE'd us). If nothing is defined, then we # iterate through the LOAD_TEMPLATES providers list as a 'chain of # responsibility' (see Design Patterns) asking each object to fetch() # the template if it can. # # Returns the compiled template. On error, undef is returned and # the internal ERROR value (read via error()) is set to contain an # error message of the form "$name: $error". #------------------------------------------------------------------------ sub template { my ($self, $name) = @_; my ($prefix, $blocks, $defblocks, $provider, $template, $error); my ($shortname, $blockname, $providers); $self->debug("template($name)") if $self->{ DEBUG }; # references to Template::Document (or sub-class) objects, or # CODE references are assumed to be pre-compiled templates and are # returned intact return $name if (blessed($name) && $name->isa(DOCUMENT)) || ref($name) eq 'CODE'; $shortname = $name; unless (ref $name) { $self->debug("looking for block [$name]") if $self->{ DEBUG }; # we first look in the BLOCKS hash for a BLOCK that may have # been imported from a template (via PROCESS) return $template if ($template = $self->{ BLOCKS }->{ $name }); # then we iterate through the BLKSTACK list to see if any of the # Template::Documents we're visiting define this BLOCK foreach $blocks (@{ $self->{ BLKSTACK } }) { return $template if $blocks && ($template = $blocks->{ $name }); } # now it's time to ask the providers, so we look to see if any # prefix is specified to indicate the desired provider set. if (MSWin32) { # let C:/foo through $prefix = $1 if $shortname =~ s/^(\w{2,})://o; } else { $prefix = $1 if $shortname =~ s/^(\w+)://; } if (defined $prefix) { $providers = $self->{ PREFIX_MAP }->{ $prefix } || return $self->throw( Template::Constants::ERROR_FILE, "no providers for template prefix '$prefix'"); } } $providers = $self->{ PREFIX_MAP }->{ default } || $self->{ LOAD_TEMPLATES } unless $providers; # Finally we try the regular template providers which will # handle references to files, text, etc., as well as templates # reference by name. If $blockname = ''; while ($shortname) { $self->debug("asking providers for [$shortname] [$blockname]") if $self->{ DEBUG }; foreach my $provider (@$providers) { ($template, $error) = $provider->fetch($shortname, $prefix); if ($error) { if ($error == Template::Constants::STATUS_ERROR) { # $template contains exception object if (blessed($template) && $template->isa(EXCEPTION) && $template->type eq Template::Constants::ERROR_FILE) { $self->throw($template); } else { $self->throw( Template::Constants::ERROR_FILE, $template ); } } # DECLINE is ok, carry on } elsif (length $blockname) { return $template if $template = $template->blocks->{ $blockname }; } else { return $template; } } last if ref $shortname || ! $self->{ EXPOSE_BLOCKS }; $shortname =~ s{/([^/]+)$}{} || last; $blockname = length $blockname ? "$1/$blockname" : $1; } $self->throw(Template::Constants::ERROR_FILE, "$name: not found"); } #------------------------------------------------------------------------ # plugin($name, \@args) # # Calls on each of the LOAD_PLUGINS providers in turn to fetch() (i.e. load # and instantiate) a plugin of the specified name. Additional parameters # passed are propagated to the new() constructor for the plugin. # Returns a reference to a new plugin object or other reference. On # error, undef is returned and the appropriate error message is set for # subsequent retrieval via error(). #------------------------------------------------------------------------ sub plugin { my ($self, $name, $args) = @_; my ($provider, $plugin, $error); $self->debug("plugin($name, ", defined $args ? @$args : '[ ]', ')') if $self->{ DEBUG }; # request the named plugin from each of the LOAD_PLUGINS providers in turn foreach my $provider (@{ $self->{ LOAD_PLUGINS } }) { ($plugin, $error) = $provider->fetch($name, $args, $self); return $plugin unless $error; if ($error == Template::Constants::STATUS_ERROR) { $self->throw($plugin) if ref $plugin; $self->throw(Template::Constants::ERROR_PLUGIN, $plugin); } } $self->throw(Template::Constants::ERROR_PLUGIN, "$name: plugin not found"); } #------------------------------------------------------------------------ # filter($name, \@args, $alias) # # Similar to plugin() above, but querying the LOAD_FILTERS providers to # return filter instances. An alias may be provided which is used to # save the returned filter in a local cache. #------------------------------------------------------------------------ sub filter { my ($self, $name, $args, $alias) = @_; my ($provider, $filter, $error); $self->debug("filter($name, ", defined $args ? @$args : '[ ]', defined $alias ? $alias : '<no alias>', ')') if $self->{ DEBUG }; # use any cached version of the filter if no params provided return $filter if ! $args && ! ref $name && ($filter = $self->{ FILTER_CACHE }->{ $name }); # request the named filter from each of the FILTERS providers in turn foreach my $provider (@{ $self->{ LOAD_FILTERS } }) { ($filter, $error) = $provider->fetch($name, $args, $self); last unless $error; if ($error == Template::Constants::STATUS_ERROR) { $self->throw($filter) if ref $filter; $self->throw(Template::Constants::ERROR_FILTER, $filter); } # return $self->error($filter) # if $error == &Template::Constants::STATUS_ERROR; } return $self->error("$name: filter not found") unless $filter; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # commented out by abw on 19 Nov 2001 to fix problem with xmlstyle # plugin which may re-define a filter by calling define_filter() # multiple times. With the automatic aliasing/caching below, any # new filter definition isn't seen. Don't think this will cause # any problems as filters explicitly supplied with aliases will # still work as expected. # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # alias defaults to name if undefined # $alias = $name # unless defined($alias) or ref($name) or $args; # cache FILTER if alias is valid $self->{ FILTER_CACHE }->{ $alias } = $filter if $alias; return $filter; } #------------------------------------------------------------------------ # view(\%config) # # Create a new Template::View bound to this context. #------------------------------------------------------------------------ sub view { my $self = shift; require Template::View; return $VIEW_CLASS->new($self, @_) || $self->throw( &Template::Constants::ERROR_VIEW, $VIEW_CLASS->error ); } #------------------------------------------------------------------------ # process($template, \%params) [% PROCESS template var=val ... %] # process($template, \%params, $local) [% INCLUDE template var=val ... %] # # Processes the template named or referenced by the first parameter. # The optional second parameter may reference a hash array of variable # definitions. These are set before the template is processed by # calling update() on the stash. Note that, unless the third parameter # is true, the context is not localised and these, and any other # variables set in the template will retain their new values after this # method returns. The third parameter is in place so that this method # can handle INCLUDE calls: the stash will be localized. # # Returns the output of processing the template. Errors are thrown # as Template::Exception objects via die(). #------------------------------------------------------------------------ sub process { my ($self, $template, $params, $localize) = @_; my ($trim, $blocks) = @$self{ qw( TRIM BLOCKS ) }; my (@compiled, $name, $compiled); my ($stash, $component, $tblocks, $error, $tmpout); my $output = ''; $template = [ $template ] unless ref $template eq 'ARRAY'; $self->debug("process([ ", join(', '), @$template, ' ], ', defined $params ? $params : '<no params>', ', ', $localize ? '<localized>' : '<unlocalized>', ')') if $self->{ DEBUG }; # fetch compiled template for each name specified foreach $name (@$template) { push(@compiled, $self->template($name)); } if ($localize) { # localise the variable stash with any parameters passed $stash = $self->{ STASH } = $self->{ STASH }->clone($params); } else { # update stash with any new parameters passed $self->{ STASH }->update($params); $stash = $self->{ STASH }; } eval { # save current component eval { $component = $stash->get('component') }; foreach $name (@$template) { $compiled = shift @compiled; my $element = ref $compiled eq 'CODE' ? { (name => (ref $name ? '' : $name), modtime => time()) } : $compiled; if (blessed($component) && $component->isa(DOCUMENT)) { $element->{ caller } = $component->{ name }; $element->{ callers } = $component->{ callers } || []; push(@{$element->{ callers }}, $element->{ caller }); } $stash->set('component', $element); unless ($localize) { # merge any local blocks defined in the Template::Document # into our local BLOCKS cache @$blocks{ keys %$tblocks } = values %$tblocks if (blessed($compiled) && $compiled->isa(DOCUMENT)) && ($tblocks = $compiled->blocks); } if (ref $compiled eq 'CODE') { $tmpout = &$compiled($self); } elsif (ref $compiled) { $tmpout = $compiled->process($self); } else { $self->throw( 'file', "invalid template reference: $compiled" ); } if ($trim) { for ($tmpout) { s/^\s+//; s/\s+$//; } } $output .= $tmpout; # pop last item from callers. # NOTE - this will not be called if template throws an # error. The whole issue of caller and callers should be # revisited to try and avoid putting this info directly into # the component data structure. Perhaps use a local element # instead? pop(@{$element->{ callers }}) if (blessed($component) && $component->isa(DOCUMENT)); } $stash->set('component', $component); }; $error = $@; if ($localize) { # ensure stash is delocalised before dying $self->{ STASH } = $self->{ STASH }->declone(); } $self->throw( ref $error ? $error : (Template::Constants::ERROR_FILE, $error) ) if $error; return $output; } #------------------------------------------------------------------------ # include($template, \%params) [% INCLUDE template var = val, ... %] # # Similar to process() above but processing the template in a local # context. Any variables passed by reference to a hash as the second # parameter will be set before the template is processed and then # revert to their original values before the method returns. Similarly, # any changes made to non-global variables within the template will # persist only until the template is processed. # # Returns the output of processing the template. Errors are thrown # as Template::Exception objects via die(). #------------------------------------------------------------------------ sub include { my ($self, $template, $params) = @_; return $self->process($template, $params, 'localize me!'); } #------------------------------------------------------------------------ # insert($file) # # Insert the contents of a file without parsing. #------------------------------------------------------------------------ sub insert { my ($self, $file) = @_; my ($prefix, $providers, $text, $error); my $output = ''; my $files = ref $file eq 'ARRAY' ? $file : [ $file ]; $self->debug("insert([ ", join(', '), @$files, " ])") if $self->{ DEBUG }; FILE: foreach $file (@$files) { my $name = $file; if (MSWin32) { # let C:/foo through $prefix = $1 if $name =~ s/^(\w{2,})://o; } else { $prefix = $1 if $name =~ s/^(\w+)://; } if (defined $prefix) { $providers = $self->{ PREFIX_MAP }->{ $prefix } || return $self->throw( Template::Constants::ERROR_FILE, "no providers for file prefix '$prefix'" ); } else { $providers = $self->{ PREFIX_MAP }->{ default } || $self->{ LOAD_TEMPLATES }; } foreach my $provider (@$providers) { ($text, $error) = $provider->load($name, $prefix); next FILE unless $error; if ($error == Template::Constants::STATUS_ERROR) { $self->throw($text) if ref $text; $self->throw(Template::Constants::ERROR_FILE, $text); } } $self->throw(Template::Constants::ERROR_FILE, "$file: not found"); } continue { $output .= $text; } return $output; } #------------------------------------------------------------------------ # throw($type, $info, \$output) [% THROW errtype "Error info" %] # # Throws a Template::Exception object by calling die(). This method # may be passed a reference to an existing Template::Exception object; # a single value containing an error message which is used to # instantiate a Template::Exception of type 'undef'; or a pair of # values representing the exception type and info from which a # Template::Exception object is instantiated. e.g. # # $context->throw($exception); # $context->throw("I'm sorry Dave, I can't do that"); # $context->throw('denied', "I'm sorry Dave, I can't do that"); # # An optional third parameter can be supplied in the last case which # is a reference to the current output buffer containing the results # of processing the template up to the point at which the exception # was thrown. The RETURN and STOP directives, for example, use this # to propagate output back to the user, but it can safely be ignored # in most cases. # # This method rides on a one-way ticket to die() oblivion. It does not # return in any real sense of the word, but should get caught by a # surrounding eval { } block (e.g. a BLOCK or TRY) and handled # accordingly, or returned to the caller as an uncaught exception. #------------------------------------------------------------------------ sub throw { my ($self, $error, $info, $output) = @_; local $" = ', '; # die! die! die! if (blessed($error) && $error->isa(EXCEPTION)) { die $error; } elsif (blessed($error) && $error->isa(BADGER_EXCEPTION)) { # convert a Badger::Exception to a Template::Exception so that # things continue to work during the transition to Badger die EXCEPTION->new($error->type, $error->info); } elsif (defined $info) { die (EXCEPTION->new($error, $info, $output)); } else { $error ||= ''; die (EXCEPTION->new('undef', $error, $output)); } # not reached } #------------------------------------------------------------------------ # catch($error, \$output) # # Called by various directives after catching an error thrown via die() # from within an eval { } block. The first parameter contains the error # which may be a sanitized reference to a Template::Exception object # (such as that raised by the throw() method above, a plugin object, # and so on) or an error message thrown via die from somewhere in user # code. The latter are coerced into 'undef' Template::Exception objects. # Like throw() above, a reference to a scalar may be passed as an # additional parameter to represent the current output buffer # localised within the eval block. As exceptions are thrown upwards # and outwards from nested blocks, the catch() method reconstructs the # correct output buffer from these fragments, storing it in the # exception object for passing further onwards and upwards. # # Returns a reference to a Template::Exception object.. #------------------------------------------------------------------------ sub catch { my ($self, $error, $output) = @_; if ( blessed($error) && ( $error->isa(EXCEPTION) || $error->isa(BADGER_EXCEPTION) ) ) { $error->text($output) if $output; return $error; } else { return EXCEPTION->new('undef', $error, $output); } } #------------------------------------------------------------------------ # localise(\%params) # delocalise() # # The localise() method creates a local copy of the current stash, # allowing the existing state of variables to be saved and later # restored via delocalise(). # # A reference to a hash array may be passed containing local variable # definitions which should be added to the cloned namespace. These # values persist until delocalisation. #------------------------------------------------------------------------ sub localise { my $self = shift; $self->{ STASH } = $self->{ STASH }->clone(@_); } sub delocalise { my $self = shift; $self->{ STASH } = $self->{ STASH }->declone(); } #------------------------------------------------------------------------ # visit($document, $blocks) # # Each Template::Document calls the visit() method on the context # before processing itself. It passes a reference to the hash array # of named BLOCKs defined within the document, allowing them to be # added to the internal BLKSTACK list which is subsequently used by # template() to resolve templates. # from a provider. #------------------------------------------------------------------------ sub visit { my ($self, $document, $blocks) = @_; unshift(@{ $self->{ BLKSTACK } }, $blocks) } #------------------------------------------------------------------------ # leave() # # The leave() method is called when the document has finished # processing itself. This removes the entry from the BLKSTACK list # that was added visit() above. For persistence of BLOCK definitions, # the process() method (i.e. the PROCESS directive) does some extra # magic to copy BLOCKs into a shared hash. #------------------------------------------------------------------------ sub leave { my $self = shift; shift(@{ $self->{ BLKSTACK } }); } #------------------------------------------------------------------------ # define_block($name, $block) # # Adds a new BLOCK definition to the local BLOCKS cache. $block may # be specified as a reference to a sub-routine or Template::Document # object or as text which is compiled into a template. Returns a true # value (the $block reference or compiled block reference) if # successful or undef on failure. Call error() to retrieve the # relevant error message (i.e. compilation failure). #------------------------------------------------------------------------ sub define_block { my ($self, $name, $block) = @_; $block = $self->template(\$block) || return undef unless ref $block; $self->{ BLOCKS }->{ $name } = $block; } #------------------------------------------------------------------------ # define_filter($name, $filter, $is_dynamic) # # Adds a new FILTER definition to the local FILTER_CACHE. #------------------------------------------------------------------------ sub define_filter { my ($self, $name, $filter, $is_dynamic) = @_; my ($result, $error); $filter = [ $filter, 1 ] if $is_dynamic; foreach my $provider (@{ $self->{ LOAD_FILTERS } }) { ($result, $error) = $provider->store($name, $filter); return 1 unless $error; $self->throw(&Template::Constants::ERROR_FILTER, $result) if $error == &Template::Constants::STATUS_ERROR; } $self->throw( &Template::Constants::ERROR_FILTER, "FILTER providers declined to store filter $name" ); } #------------------------------------------------------------------------ # define_vmethod($type, $name, \&sub) # # Passes $type, $name, and &sub on to stash->define_vmethod(). #------------------------------------------------------------------------ sub define_vmethod { my $self = shift; $self->stash->define_vmethod(@_); } #------------------------------------------------------------------------ # define_view($name, $params) # # Defines a new view. #------------------------------------------------------------------------ sub define_view { my ($self, $name, $params) = @_; my $base; if (defined $params->{ base }) { my $base = $self->{ STASH }->get($params->{ base }); return $self->throw( &Template::Constants::ERROR_VIEW, "view base is not defined: $params->{ base }" ) unless $base; return $self->throw( &Template::Constants::ERROR_VIEW, "view base is not a $VIEW_CLASS object: $params->{ base } => $base" ) unless blessed($base) && $base->isa($VIEW_CLASS); $params->{ base } = $base; } my $view = $self->view($params); $view->seal(); $self->{ STASH }->set($name, $view); } #------------------------------------------------------------------------ # define_views($views) # # Defines multiple new views. #------------------------------------------------------------------------ sub define_views { my ($self, $views) = @_; # a list reference is better because the order is deterministic (and so # allows an earlier VIEW to be the base for a later VIEW), but we'll # accept a hash reference and assume that the user knows the order of # processing is undefined $views = [ %$views ] if ref $views eq 'HASH'; # make of copy so we don't destroy the original list reference my @items = @$views; my ($name, $view); while (@items) { $self->define_view(splice(@items, 0, 2)); } } #------------------------------------------------------------------------ # reset() # # Reset the state of the internal BLOCKS hash to clear any BLOCK # definitions imported via the PROCESS directive. Any original # BLOCKS definitions passed to the constructor will be restored. #------------------------------------------------------------------------ sub reset { my ($self, $blocks) = @_; $self->{ BLKSTACK } = [ ]; $self->{ BLOCKS } = { %{ $self->{ INIT_BLOCKS } } }; } #------------------------------------------------------------------------ # stash() # # Simple accessor methods to return the STASH values. This is likely # to be called quite often so we provide a direct method rather than # relying on the slower AUTOLOAD. #------------------------------------------------------------------------ sub stash { return $_[0]->{ STASH }; } #------------------------------------------------------------------------ # debugging($command, @args, \%params) # # Method for controlling the debugging status of the context. The first # argument can be 'on' or 'off' to enable/disable debugging, 'format' # to define the format of the debug message, or 'msg' to generate a # debugging message reporting the file, line, message text, etc., # according to the current debug format. #------------------------------------------------------------------------ sub debugging { my $self = shift; my $hash = ref $_[-1] eq 'HASH' ? pop : { }; my @args = @_; if (@args) { if ($args[0] eq '1' || lc($args[0]) eq 'on' ) { $self->{ DEBUG_DIRS } = 1; shift(@args); } elsif ($args[0] eq '0' || lc($args[0]) eq 'off') { $self->{ DEBUG_DIRS } = 0; shift(@args); } } if (@args) { if (lc($args[0]) eq 'msg') { return unless $self->{ DEBUG_DIRS }; my $format = $self->{ DEBUG_FORMAT }; $format = $DEBUG_FORMAT unless defined $format; $format =~ s/\$(\w+)/$hash->{ $1 }/ge; return $format; } elsif ( lc($args[0]) eq 'format' ) { $self->{ DEBUG_FORMAT } = $args[1]; } # else ignore } return ''; } #------------------------------------------------------------------------ # AUTOLOAD # # Provides pseudo-methods for read-only access to various internal # members. For example, templates(), plugins(), filters(), # eval_perl(), load_perl(), etc. These aren't called very often, or # may never be called at all. #------------------------------------------------------------------------ sub AUTOLOAD { my $self = shift; my $method = $AUTOLOAD; my $result; $method =~ s/.*:://; return if $method eq 'DESTROY'; warn "no such context method/member: $method\n" unless defined ($result = $self->{ uc $method }); return $result; } #------------------------------------------------------------------------ # DESTROY # # Stash may contain references back to the Context via macro closures, # etc. This breaks the circular references. #------------------------------------------------------------------------ sub DESTROY { my $self = shift; undef $self->{ STASH }; } #======================================================================== # -- PRIVATE METHODS -- #======================================================================== #------------------------------------------------------------------------ # _init(\%config) # # Initialisation method called by Template::Base::new() #------------------------------------------------------------------------ sub _init { my ($self, $config) = @_; my ($name, $item, $method, $block, $blocks); my @itemlut = ( LOAD_TEMPLATES => 'provider', LOAD_PLUGINS => 'plugins', LOAD_FILTERS => 'filters' ); # LOAD_TEMPLATE, LOAD_PLUGINS, LOAD_FILTERS - lists of providers while (($name, $method) = splice(@itemlut, 0, 2)) { $item = $config->{ $name } || Template::Config->$method($config) || return $self->error($Template::Config::ERROR); $self->{ $name } = ref $item eq 'ARRAY' ? $item : [ $item ]; } my $providers = $self->{ LOAD_TEMPLATES }; my $prefix_map = $self->{ PREFIX_MAP } = $config->{ PREFIX_MAP } || { }; while (my ($key, $val) = each %$prefix_map) { $prefix_map->{ $key } = [ ref $val ? $val : map { $providers->[$_] } split(/\D+/, $val) ] unless ref $val eq 'ARRAY'; } # STASH $self->{ STASH } = $config->{ STASH } || do { my $predefs = $config->{ VARIABLES } || $config->{ PRE_DEFINE } || { }; # hack to get stash to know about debug mode $predefs->{ _DEBUG } = ( ($config->{ DEBUG } || 0) & &Template::Constants::DEBUG_UNDEF ) ? 1 : 0 unless defined $predefs->{ _DEBUG }; $predefs->{ _STRICT } = $config->{ STRICT }; Template::Config->stash($predefs) || return $self->error($Template::Config::ERROR); }; # compile any template BLOCKS specified as text $blocks = $config->{ BLOCKS } || { }; $self->{ INIT_BLOCKS } = $self->{ BLOCKS } = { map { $block = $blocks->{ $_ }; $block = $self->template(\$block) || return undef unless ref $block; ($_ => $block); } keys %$blocks }; # define any VIEWS $self->define_views( $config->{ VIEWS } ) if $config->{ VIEWS }; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # RECURSION - flag indicating is recursion into templates is supported # EVAL_PERL - flag indicating if PERL blocks should be processed # TRIM - flag to remove leading and trailing whitespace from output # BLKSTACK - list of hashes of BLOCKs defined in current template(s) # CONFIG - original configuration hash # EXPOSE_BLOCKS - make blocks visible as pseudo-files # DEBUG_FORMAT - format for generating template runtime debugging messages # DEBUG - format for generating template runtime debugging messages $self->{ RECURSION } = $config->{ RECURSION } || 0; $self->{ EVAL_PERL } = $config->{ EVAL_PERL } || 0; $self->{ TRIM } = $config->{ TRIM } || 0; $self->{ BLKSTACK } = [ ]; $self->{ CONFIG } = $config; $self->{ EXPOSE_BLOCKS } = defined $config->{ EXPOSE_BLOCKS } ? $config->{ EXPOSE_BLOCKS } : 0; $self->{ DEBUG_FORMAT } = $config->{ DEBUG_FORMAT }; $self->{ DEBUG_DIRS } = ($config->{ DEBUG } || 0) & Template::Constants::DEBUG_DIRS; $self->{ DEBUG } = defined $config->{ DEBUG } ? $config->{ DEBUG } & ( Template::Constants::DEBUG_CONTEXT | Template::Constants::DEBUG_FLAGS ) : $DEBUG; return $self; } 1; __END__ =head1 NAME Template::Context - Runtime context in which templates are processed =head1 SYNOPSIS use Template::Context; # constructor $context = Template::Context->new(\%config) || die $Template::Context::ERROR; # fetch (load and compile) a template $template = $context->template($template_name); # fetch (load and instantiate) a plugin object $plugin = $context->plugin($name, \@args); # fetch (return or create) a filter subroutine $filter = $context->filter($name, \@args, $alias); # process/include a template, errors are thrown via die() $output = $context->process($template, \%vars); $output = $context->include($template, \%vars); # raise an exception via die() $context->throw($error_type, $error_message, \$output_buffer); # catch an exception, clean it up and fix output buffer $exception = $context->catch($exception, \$output_buffer); # save/restore the stash to effect variable localisation $new_stash = $context->localise(\%vars); $old_stash = $context->delocalise(); # add new BLOCK or FILTER definitions $context->define_block($name, $block); $context->define_filter($name, \&filtersub, $is_dynamic); # reset context, clearing any imported BLOCK definitions $context->reset(); # methods for accessing internal items $stash = $context->stash(); $tflag = $context->trim(); $epflag = $context->eval_perl(); $providers = $context->templates(); $providers = $context->plugins(); $providers = $context->filters(); ... =head1 DESCRIPTION The C<Template::Context> module defines an object class for representing a runtime context in which templates are processed. It provides an interface to the fundamental operations of the Template Toolkit processing engine through which compiled templates (i.e. Perl code constructed from the template source) can process templates, load plugins and filters, raise exceptions and so on. A default C<Template::Context> object is created by the L<Template> module. Any C<Template::Context> options may be passed to the L<Template> L<new()|Template#new()> constructor method and will be forwarded to the C<Template::Context> constructor. use Template; my $template = Template->new({ TRIM => 1, EVAL_PERL => 1, BLOCKS => { header => 'This is the header', footer => 'This is the footer', }, }); Similarly, the C<Template::Context> constructor will forward all configuration parameters onto other default objects (e.g. L<Template::Provider>, L<Template::Plugins>, L<Template::Filters>, etc.) that it may need to instantiate. $context = Template::Context->new({ INCLUDE_PATH => '/home/abw/templates', # provider option TAG_STYLE => 'html', # parser option }); A C<Template::Context> object (or subclass) can be explicitly instantiated and passed to the L<Template> L<new()|Template#new()> constructor method as the C<CONTEXT> configuration item. use Template; use Template::Context; my $context = Template::Context->new({ TRIM => 1 }); my $template = Template->new({ CONTEXT => $context }); The L<Template> module uses the L<Template::Config> L<context()|Template::Config#context()> factory method to create a default context object when required. The C<$Template::Config::CONTEXT> package variable may be set to specify an alternate context module. This will be loaded automatically and its L<new()> constructor method called by the L<context()|Template::Config#context()> factory method when a default context object is required. use Template; $Template::Config::CONTEXT = 'MyOrg::Template::Context'; my $template = Template->new({ EVAL_PERL => 1, EXTRA_MAGIC => 'red hot', # your extra config items ... }); =head1 METHODS =head2 new(\%params) The C<new()> constructor method is called to instantiate a C<Template::Context> object. Configuration parameters may be specified as a HASH reference or as a list of C<name =E<gt> value> pairs. my $context = Template::Context->new({ INCLUDE_PATH => 'header', POST_PROCESS => 'footer', }); my $context = Template::Context->new( EVAL_PERL => 1 ); The C<new()> method returns a C<Template::Context> object or C<undef> on error. In the latter case, a relevant error message can be retrieved by the L<error()|Template::Base#error()> class method or directly from the C<$Template::Context::ERROR> package variable. my $context = Template::Context->new(\%config) || die Template::Context->error(); my $context = Template::Context->new(\%config) || die $Template::Context::ERROR; The following configuration items may be specified. Please see L<Template::Manual::Config> for further details. =head3 VARIABLES The L<VARIABLES|Template::Manual::Config#VARIABLES> option can be used to specify a hash array of template variables. my $context = Template::Context->new({ VARIABLES => { title => 'A Demo Page', author => 'Joe Random Hacker', version => 3.14, }, }; =head3 BLOCKS The L<BLOCKS|Template::Manual::Config#BLOCKS> option can be used to pre-define a default set of template blocks. my $context = Template::Context->new({ BLOCKS => { header => 'The Header. [% title %]', footer => sub { return $some_output_text }, another => Template::Document->new({ ... }), }, }); =head3 VIEWS The L<VIEWS|Template::Manual::Config#VIEWS> option can be used to pre-define one or more L<Template::View> objects. my $context = Template::Context->new({ VIEWS => [ bottom => { prefix => 'bottom/' }, middle => { prefix => 'middle/', base => 'bottom' }, top => { prefix => 'top/', base => 'middle' }, ], }); =head3 TRIM The L<TRIM|Template::Manual::Config#TRIM> option can be set to have any leading and trailing whitespace automatically removed from the output of all template files and C<BLOCK>s. example: [% BLOCK foo %] Line 1 of foo [% END %] before [% INCLUDE foo %] after output: before Line 1 of foo after =head3 EVAL_PERL The L<EVAL_PERL|Template::Manual::Config#EVAL_PERL> is used to indicate if C<PERL> and/or C<RAWPERL> blocks should be evaluated. It is disabled by default. =head3 RECURSION The L<RECURSION|Template::Manual::Config#RECURSION> can be set to allow templates to recursively process themselves, either directly (e.g. template C<foo> calls C<INCLUDE foo>) or indirectly (e.g. C<foo> calls C<INCLUDE bar> which calls C<INCLUDE foo>). =head3 LOAD_TEMPLATES The L<LOAD_TEMPLATES|Template::Manual::Config#LOAD_TEMPLATES> option can be used to provide a reference to a list of L<Template::Provider> objects or sub-classes thereof which will take responsibility for loading and compiling templates. my $context = Template::Context->new({ LOAD_TEMPLATES => [ MyOrg::Template::Provider->new({ ... }), Template::Provider->new({ ... }), ], }); =head3 LOAD_PLUGINS The L<LOAD_PLUGINS|Template::Manual::Config#LOAD_PLUGINS> options can be used to specify a list of provider objects responsible for loading and instantiating template plugin objects. my $context = Template::Context->new({ LOAD_PLUGINS => [ MyOrg::Template::Plugins->new({ ... }), Template::Plugins->new({ ... }), ], }); =head3 LOAD_FILTERS The L<LOAD_FILTERS|Template::Manual::Config#LOAD_FILTERS> option can be used to specify a list of provider objects for returning and/or creating filter subroutines. my $context = Template::Context->new({ LOAD_FILTERS => [ MyTemplate::Filters->new(), Template::Filters->new(), ], }); =head3 STASH The L<STASH|Template::Manual::Config#STASH> option can be used to specify a L<Template::Stash> object or sub-class which will take responsibility for managing template variables. my $stash = MyOrg::Template::Stash->new({ ... }); my $context = Template::Context->new({ STASH => $stash, }); =head3 DEBUG The L<DEBUG|Template::Manual::Config#DEBUG> option can be used to enable various debugging features of the L<Template::Context> module. use Template::Constants qw( :debug ); my $template = Template->new({ DEBUG => DEBUG_CONTEXT | DEBUG_DIRS, }); =head2 template($name) Returns a compiled template by querying each of the L<LOAD_TEMPLATES> providers (instances of L<Template::Provider>, or sub-class) in turn. $template = $context->template('header'); On error, a L<Template::Exception> object of type 'C<file>' is thrown via C<die()>. This can be caught by enclosing the call to C<template()> in an C<eval> block and examining C<$@>. eval { $template = $context->template('header') }; if ($@) { print "failed to fetch template: $@\n"; } =head2 plugin($name, \@args) Instantiates a plugin object by querying each of the L<LOAD_PLUGINS> providers. The default L<LOAD_PLUGINS> provider is a L<Template::Plugins> object which attempts to load plugin modules, according the various configuration items such as L<PLUGIN_BASE|Template::Plugins#PLUGIN_BASE>, L<LOAD_PERL|Template::Plugins#LOAD_PERL>, etc., and then instantiate an object via L<new()|Template::Plugin#new()>. A reference to a list of constructor arguments may be passed as the second parameter. These are forwarded to the plugin constructor. Returns a reference to a plugin (which is generally an object, but doesn't have to be). Errors are thrown as L<Template::Exception> objects with the type set to 'C<plugin>'. $plugin = $context->plugin('DBI', 'dbi:msql:mydbname'); =head2 filter($name, \@args, $alias) Instantiates a filter subroutine by querying the L<LOAD_FILTERS> providers. The default L<LOAD_FILTERS> provider is a L<Template::Filters> object. Additional arguments may be passed by list reference along with an optional alias under which the filter will be cached for subsequent use. The filter is cached under its own C<$name> if C<$alias> is undefined. Subsequent calls to C<filter($name)> will return the cached entry, if defined. Specifying arguments bypasses the caching mechanism and always creates a new filter. Errors are thrown as L<Template::Exception> objects with the type set to 'C<filter>'. # static filter (no args) $filter = $context->filter('html'); # dynamic filter (args) aliased to 'padright' $filter = $context->filter('format', '%60s', 'padright'); # retrieve previous filter via 'padright' alias $filter = $context->filter('padright'); =head2 process($template, \%vars) Processes a template named or referenced by the first parameter and returns the output generated. An optional reference to a hash array may be passed as the second parameter, containing variable definitions which will be set before the template is processed. The template is processed in the current context, with no localisation of variables performed. Errors are thrown as L<Template::Exception> objects via C<die()>. $output = $context->process('header', { title => 'Hello World' }); =head2 include($template, \%vars) Similar to L<process()>, but using localised variables. Changes made to any variables will only persist until the C<include()> method completes. $output = $context->include('header', { title => 'Hello World' }); =head2 insert($template) This method returns the source content of a template file without performing any evaluation. It is used to implement the C<INSERT> directive. =head2 throw($error_type, $error_message, \$output) Raises an exception in the form of a L<Template::Exception> object by calling C<die()>. This method may be passed a reference to an existing L<Template::Exception> object; a single value containing an error message which is used to instantiate a L<Template::Exception> of type 'C<undef>'; or a pair of values representing the exception C<type> and C<info> from which a L<Template::Exception> object is instantiated. e.g. $context->throw($exception); $context->throw("I'm sorry Dave, I can't do that"); $context->throw('denied', "I'm sorry Dave, I can't do that"); The optional third parameter may be a reference to the current output buffer. This is then stored in the exception object when created, allowing the catcher to examine and use the output up to the point at which the exception was raised. $output .= 'blah blah blah'; $output .= 'more rhubarb'; $context->throw('yack', 'Too much yacking', \$output); =head2 catch($exception, \$output) Catches an exception thrown, either as a reference to a L<Template::Exception> object or some other value. In the latter case, the error string is promoted to a L<Template::Exception> object of 'C<undef>' type. This method also accepts a reference to the current output buffer which is passed to the L<Template::Exception> constructor, or is appended to the output buffer stored in an existing L<Template::Exception> object, if unique (i.e. not the same reference). By this process, the correct state of the output buffer can be reconstructed for simple or nested throws. =head2 define_block($name, $block) Adds a new block definition to the internal L<BLOCKS> cache. The first argument should contain the name of the block and the second a reference to a L<Template::Document> object or template sub-routine, or template text which is automatically compiled into a template sub-routine. Returns a true value (the sub-routine or L<Template::Document> reference) on success or undef on failure. The relevant error message can be retrieved by calling the L<error()|Template::Base#error()> method. =head2 define_filter($name, \&filter, $is_dynamic) Adds a new filter definition by calling the L<store()|Template::Filters#store()> method on each of the L<LOAD_FILTERS> providers until accepted (in the usual case, this is accepted straight away by the one and only L<Template::Filters> provider). The first argument should contain the name of the filter and the second a reference to a filter subroutine. The optional third argument can be set to any true value to indicate that the subroutine is a dynamic filter factory. Returns a true value or throws a 'C<filter>' exception on error. =head2 define_vmethod($type, $name, $code) This method is a wrapper around the L<Template::Stash> L<define_vmethod()|Template::Stash#define_vmethod()> method. It can be used to define new virtual methods. # define a new scalar (item) virtual method $context->define_vmethod( item => ucfirst => sub { my $text = shift; return ucfirst $text; } ) =head2 define_view($name, \%params) This method allows you to define a named L<view|Template::View>. $context->define_view( my_view => { prefix => 'my_templates/' } ); The view is then accessible as a template variable. [% my_view.print(some_data) %] =head2 define_views($views) This method allows you to define multiple named L<views|Template::View>. A reference to a hash array or list reference should be passed as an argument. $context->define_view({ # hash reference my_view_one => { prefix => 'my_templates_one/' }, my_view_two => { prefix => 'my_templates_two/' } }); If you're defining multiple views of which one or more are based on other views in the same definition then you should pass them as a list reference. This ensures that they get created in the right order (Perl does not preserve the order of items defined in a hash reference so you can't guarantee that your base class view will be defined before your subclass view). $context->define_view([ # list referenence my_view_one => { prefix => 'my_templates_one/' }, my_view_two => { prefix => 'my_templates_two/' , base => 'my_view_one', } ]); The views are then accessible as template variables. [% my_view_one.print(some_data) %] [% my_view_two.print(some_data) %] See also the L<VIEWS> option. =head2 stash() This method returns the L<Template::Stash> object used internally to manage template variables. =head2 localise(\%vars) Clones the stash to create a context with localised variables. Returns a reference to the newly cloned stash object which is also stored internally. $stash = $context->localise(); =head2 delocalise() Restore the stash to its state prior to localisation. $stash = $context->delocalise(); =head2 visit(\%blocks) This method is called by L<Template::Document> objects immediately before they process their content. It is called to register any local C<BLOCK> definitions with the context object so that they may be subsequently delivered on request. =head2 leave() Compliment to the L<visit()> method. Called by L<Template::Document> objects immediately after they process their content. =head2 view() This method creates a L<Template::View> object bound to the context. =head2 reset() Clears the local L<BLOCKS> cache of any C<BLOCK> definitions. Any initial set of L<BLOCKS> specified as a configuration item to the constructor will be reinstated. =head2 debugging($flag, @args) This method is used to control debugging output. It is used to implement the L<DEBUG|Template::Manual::Directives#DEBUG> directive. The first argument can be C<on> or C<off> to enable or disable debugging respectively. The numerical values C<0> and C<1> can also be used if you prefer. $context->debugging('on'); Alternately, the first argument can be C<format> to define a new debug message format. The second argument should be the format string which can contain any of the C<$file>, C<$line> or C<$text> symbols to indicate where the relevant values should be inserted. # note single quotes to prevent interpolated of variables $context->debugging( format => '## $file line $line: $text' ); The final use of this method is to generate debugging messages themselves. The first argument should be C<msg>, followed by a reference to a hash array of value to insert into the debugging format string. $context->debugging( msg => { line => 20, file => 'example.tt', text => 'Trampoline! Trampoline!', } ); =head2 AUTOLOAD An C<AUTOLOAD> method provides access to context configuration items. $stash = $context->stash(); $tflag = $context->trim(); $epflag = $context->eval_perl(); ... =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template>, L<Template::Document>, L<Template::Exception>, L<Template::Filters>, L<Template::Plugins>, L<Template::Provider>, L<Template::Service>, L<Template::Stash> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Tools.pod 0000444 00000002767 15125513451 0010526 0 ustar 00 #============================================================= -*-perl-*- # # Template::Tools # # DESCRIPTION # Index page for documentation about the command line tools # distributed with the Template Toolkit. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Tools - Command Line Tools for the Template Toolkit =head1 Template Tools The Template Toolkit includes the following command line tools for processing templates. =head2 tpage The L<tpage|Template::Tools::tpage> script can be used to process a single template using the Template Toolkit. $ tpage --define msg="Hello World" greeting.tt2 Use the C<-h> option to get a summary of options: $ tpage -h See the L<Template::Tools::tpage> documentation for further information and examples of use. =head2 ttree The L<ttree|Template::Tools::ttree> script can be used to process an entire directory of templates. $ ttree --src /path/to/templates --dest /path/to/output Use the C<-h> option to get a summary of options: $ ttree -h See the L<Template::Tools::ttree> documentation for further information and examples of use. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Tools/tpage.pod 0000444 00000003150 15125513451 0011611 0 ustar 00 =head1 NAME Template::Tools::tpage - Process templates from command line =head1 USAGE tpage [ --define var=value ] file(s) =head1 DESCRIPTION The B<tpage> script is a simple wrapper around the Template Toolkit processor. Files specified by name on the command line are processed in turn by the template processor and the resulting output is sent to STDOUT and can be redirected accordingly. e.g. tpage myfile > myfile.out tpage header myfile footer > myfile.html If no file names are specified on the command line then B<tpage> will read STDIN for input. The C<--define> option can be used to set the values of template variables. e.g. tpage --define author="Andy Wardley" skeleton.pm > MyModule.pm =head2 The F<.tpagerc> Configuration File You can use a F<.tpagerc> file in your home directory. The purpose of this file is to set any I<global> configuration options that you want applied I<every> time F<tpage> is run. For example, you can use the C<include_path> to use template files from a generic template directory. Run C<tpage -h> for a summary of the options available. See L<Template> for general information about the Perl Template Toolkit and the template language and features. =head1 AUTHOR Andy Wardley L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2008 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<ttree|Template::Tools::ttree> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Tools/ttree.pod 0000444 00000024510 15125513451 0011637 0 ustar 00 =head1 NAME Template::Tools::ttree - Process entire directory trees of templates =head1 SYNOPSIS ttree [options] [files] =head1 DESCRIPTION The F<ttree> script is used to process entire directory trees containing template files. The resulting output from processing each file is then written to a corresponding file in a destination directory. The script compares the modification times of source and destination files (where they already exist) and processes only those files that have been modified. In other words, it is the equivalent of 'make' for the Template Toolkit. It supports a number of options which can be used to configure behaviour, define locations and set Template Toolkit options. The script first reads the F<.ttreerc> configuration file in the HOME directory, or an alternative file specified in the TTREERC environment variable. Then, it processes any command line arguments, including any additional configuration files specified via the C<-f> (file) option. =head2 The F<.ttreerc> Configuration File When you run F<ttree> for the first time it will ask you if you want it to create a F<.ttreerc> file for you. This will be created in your home directory. $ ttree Do you want me to create a sample '.ttreerc' file for you? (file: /home/abw/.ttreerc) [y/n]: y /home/abw/.ttreerc created. Please edit accordingly and re-run ttree The purpose of this file is to set any I<global> configuration options that you want applied I<every> time F<ttree> is run. For example, you can use the C<ignore> and C<copy> option to provide regular expressions that specify which files should be ignored and which should be copied rather than being processed as templates. You may also want to set flags like C<verbose> and C<recurse> according to your preference. A minimal F<.ttreerc>: # ignore these files ignore = \b(CVS|RCS)\b ignore = ^# ignore = ~$ # copy these files copy = \.(gif|png|jpg|pdf)$ # recurse into directories recurse # provide info about what's going on verbose In most cases, you'll want to create a different F<ttree> configuration file for each project you're working on. The C<cfg> option allows you to specify a directory where F<ttree> can find further configuration files. cfg = /home/abw/.ttree The C<-f> command line option can be used to specify which configuration file should be used. You can specify a filename using an absolute or relative path: $ ttree -f /home/abw/web/example/etc/ttree.cfg $ ttree -f ./etc/ttree.cfg $ ttree -f ../etc/ttree.cfg If the configuration file does not begin with C</> or C<.> or something that looks like a MS-DOS absolute path (e.g. C<C:\\etc\\ttree.cfg>) then F<ttree> will look for it in the directory specified by the C<cfg> option. $ ttree -f test1 # /home/abw/.ttree/test1 The C<cfg> option can only be used in the F<.ttreerc> file. All the other options can be used in the F<.ttreerc> or any other F<ttree> configuration file. They can all also be specified as command line options. Remember that F<.ttreerc> is always processed I<before> any configuration file specified with the C<-f> option. Certain options like C<lib> can be used any number of times and accumulate their values. For example, consider the following configuration files: F</home/abw/.ttreerc>: cfg = /home/abw/.ttree lib = /usr/local/tt2/templates F</home/abw/.ttree/myconfig>: lib = /home/abw/web/example/templates/lib When F<ttree> is invoked as follows: $ ttree -f myconfig the C<lib> option will be set to the following directories: /usr/local/tt2/templates /home/abw/web/example/templates/lib Any templates located under F</usr/local/tt2/templates> will be used in preference to those located under F</home/abw/web/example/templates/lib>. This may be what you want, but then again, it might not. For this reason, it is good practice to keep the F<.ttreerc> as simple as possible and use different configuration files for each F<ttree> project. =head2 Directory Options The C<src> option is used to define the directory containing the source templates to be processed. It can be provided as a command line option or in a configuration file as shown here: src = /home/abw/web/example/templates/src Each template in this directory typically corresponds to a single web page or other document. The C<dest> option is used to specify the destination directory for the generated output. dest = /home/abw/web/example/html The C<lib> option is used to define one or more directories containing additional library templates. These templates are not documents in their own right and typically comprise of smaller, modular components like headers, footers and menus that are incorporated into pages templates. lib = /home/abw/web/example/templates/lib lib = /usr/local/tt2/templates The C<lib> option can be used repeatedly to add further directories to the search path. A list of templates can be passed to F<ttree> as command line arguments. $ ttree foo.html bar.html It looks for these templates in the C<src> directory and processes them through the Template Toolkit, using any additional template components from the C<lib> directories. The generated output is then written to the corresponding file in the C<dest> directory. If F<ttree> is invoked without explicitly specifying any templates to be processed then it will process every file in the C<src> directory. If the C<-r> (recurse) option is set then it will additionally iterate down through sub-directories and process and other template files it finds therein. $ ttree -r If a template has been processed previously, F<ttree> will compare the modification times of the source and destination files. If the source template (or one it is dependant on) has not been modified more recently than the generated output file then F<ttree> will not process it. The F<-a> (all) option can be used to force F<ttree> to process all files regardless of modification time. $ ttree -a Any templates explicitly named as command line argument are always processed and the modification time checking is bypassed. =head2 File Options The C<ignore>, C<copy> and C<accept> options are used to specify Perl regexen to filter file names. Files that match any of the C<ignore> options will not be processed. Remaining files that match any of the C<copy> regexen will be copied to the destination directory. Remaining files that then match any of the C<accept> criteria are then processed via the Template Toolkit. If no C<accept> parameter is specified then all files will be accepted for processing if not already copied or ignored. # ignore these files ignore = \b(CVS|RCS)\b ignore = ^# ignore = ~$ # copy these files copy = \.(gif|png|jpg|pdf)$ # accept only .tt2 templates accept = \.tt2$ The C<suffix> option is used to define mappings between the file extensions for source templates and the generated output files. The following example specifies that source templates with a C<.tt2> suffix should be output as C<.html> files: suffix tt2=html Or on the command line, --suffix tt2=html You can provide any number of different suffix mappings by repeating this option. =head2 Template Dependencies The C<depend> and C<depend_file> options allow you to specify how any given template file depends on another file or group of files. The C<depend> option is used to express a single dependency. $ ttree --depend foo=bar,baz This command line example shows the C<--depend> option being used to specify that the F<foo> file is dependant on the F<bar> and F<baz> templates. This option can be used many time on the command line: $ ttree --depend foo=bar,baz --depend crash=bang,wallop or in a configuration file: depend foo=bar,baz depend crash=bang,wallop The file appearing on the left of the C<=> is specified relative to the C<src> or C<lib> directories. The file(s) appearing on the right can be specified relative to any of these directories or as absolute file paths. For example: $ ttree --depend foo=bar,/tmp/baz To define a dependency that applies to all files, use C<*> on the left of the C<=>. $ ttree --depend *=header,footer or in a configuration file: depend *=header,footer Any templates that are defined in the C<pre_process>, C<post_process>, C<process> or C<wrapper> options will automatically be added to the list of global dependencies that apply to all templates. The C<depend_file> option can be used to specify a file that contains dependency information. $ ttree --depend_file=/home/abw/web/example/etc/ttree.dep Here is an example of a dependency file: # This is a comment. It is ignored. index.html: header footer menubar header: titlebar hotlinks menubar: menuitem # spanning multiple lines with the backslash another.html: header footer menubar \ sidebar searchform Lines beginning with the C<#> character are comments and are ignored. Blank lines are also ignored. All other lines should provide a filename followed by a colon and then a list of dependant files separated by whitespace, commas or both. Whitespace around the colon is also optional. Lines ending in the C<\> character are continued onto the following line. Files that contain spaces can be quoted. That is only necessary for files after the colon (':'). The file before the colon may be quoted if it contains a colon. As with the command line options, the C<*> character can be used as a wildcard to specify a dependency for all templates. * : config,header =head2 Template Toolkit Options F<ttree> also provides access to the usual range of Template Toolkit options. For example, the C<--pre_chomp> and C<--post_chomp> F<ttree> options correspond to the C<PRE_CHOMP> and C<POST_CHOMP> options. Run C<ttree -h> for a summary of the options available. =head1 AUTHORS Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://www.wardley.org> With contributions from Dylan William Hardison (support for dependencies), Bryce Harrington (C<absolute> and C<relative> options), Mark Anderson (C<suffix> and C<debug> options), Harald Joerg and Leon Brocard who gets everywhere, it seems. =head1 COPYRIGHT Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Tools::tpage|tpage> 5.32/Template/Iterator.pm 0000444 00000032235 15125513451 0011042 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Iterator # # DESCRIPTION # # Module defining an iterator class which is used by the FOREACH # directive for iterating through data sets. This may be # sub-classed to define more specific iterator types. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Iterator; use strict; use warnings; use base 'Template::Base'; use Template::Constants; use Template::Exception; use Scalar::Util qw(blessed); use constant ODD => 'odd'; use constant EVEN => 'even'; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $AUTOLOAD; #======================================================================== # ----- CLASS METHODS ----- #======================================================================== #------------------------------------------------------------------------ # new(\@target, \%options) # # Constructor method which creates and returns a reference to a new # Template::Iterator object. A reference to the target data (array # or hash) may be passed for the object to iterate through. #------------------------------------------------------------------------ sub new { my $class = shift; my $data = shift || [ ]; my $params = shift || { }; if (ref $data eq 'HASH') { # map a hash into a list of { key => ???, value => ??? } hashes, # one for each key, sorted by keys $data = [ map { { key => $_, value => $data->{ $_ } } } sort keys %$data ]; } elsif (blessed($data) && $data->can('as_list')) { $data = $data->as_list(); } elsif (ref $data ne 'ARRAY') { # coerce any non-list data into an array reference $data = [ $data ] ; } bless { _DATA => $data, _ERROR => '', }, $class; } #======================================================================== # ----- PUBLIC OBJECT METHODS ----- #======================================================================== #------------------------------------------------------------------------ # get_first() # # Initialises the object for iterating through the target data set. The # first record is returned, if defined, along with the STATUS_OK value. # If there is no target data, or the data is an empty set, then undef # is returned with the STATUS_DONE value. #------------------------------------------------------------------------ sub get_first { my $self = shift; my $data = $self->{ _DATA }; $self->{ _DATASET } = $self->{ _DATA }; my $size = scalar @$data; my $index = 0; return (undef, Template::Constants::STATUS_DONE) unless $size; # initialise various counters, flags, etc. @$self{ qw( SIZE MAX INDEX COUNT FIRST LAST ) } = ( $size, $size - 1, $index, 1, 1, $size > 1 ? 0 : 1, undef ); @$self{ qw( PREV NEXT ) } = ( undef, $self->{ _DATASET }->[ $index + 1 ]); return $self->{ _DATASET }->[ $index ]; } #------------------------------------------------------------------------ # get_next() # # Called repeatedly to access successive elements in the data set. # Should only be called after calling get_first() or a warning will # be raised and (undef, STATUS_DONE) returned. #------------------------------------------------------------------------ sub get_next { my ( $max, $index ) = @{ $_[0] }{qw( MAX INDEX )}; # warn about incorrect usage if ( !defined $index ) { my ( $pack, $file, $line ) = caller(); warn("iterator get_next() called before get_first() at $file line $line\n"); return ( undef, Template::Constants::STATUS_DONE ); ## RETURN ## } # if there's still some data to go... elsif ( $index >= $max ) { return ( undef, Template::Constants::STATUS_DONE ); ## RETURN ## } my $self = shift; my $dataset = $self->{_DATASET}; $index++; # update counters and flags @$self{qw( INDEX COUNT FIRST LAST PREV NEXT )} = ( $index, # INDEX $index + 1, # COUNT 0, # FIRST $index == $max ? 1 : 0, # LAST @$dataset[ $index - 1, $index + 1 ] # PREV, NEXT ); return $dataset->[ $index ]; ## RETURN ## } #------------------------------------------------------------------------ # get_all() # # Method which returns all remaining items in the iterator as a Perl list # reference. May be called at any time in the life-cycle of the iterator. # The get_first() method will be called automatically if necessary, and # then subsequent get_next() calls are made, storing each returned # result until the list is exhausted. #------------------------------------------------------------------------ sub get_all { my $self = shift; my ($max, $index) = @$self{ qw( MAX INDEX ) }; my @data; # handle cases where get_first() has yet to be called. unless (defined $index) { my ($first, $status) = $self->get_first; # refresh $max and $index, after get_first updates MAX and INDEX ($max, $index) = @$self{ qw( MAX INDEX ) }; # empty lists are handled here. if ($status && $status == Template::Constants::STATUS_DONE) { return (undef, Template::Constants::STATUS_DONE); ## RETURN ## } push @data, $first; ## if there's nothing left in the iterator, return the single value. unless ($index < $max) { return \@data; } } # if there's still some data to go... if ($index < $max) { $index++; push @data, @{ $self->{ _DATASET } } [ $index..$max ]; # update counters and flags @$self{ qw( INDEX COUNT FIRST LAST ) } = ( $max, $max + 1, 0, 1 ); return \@data; ## RETURN ## } else { return (undef, Template::Constants::STATUS_DONE); ## RETURN ## } } sub odd { shift->{ COUNT } % 2 ? 1 : 0 } sub even { shift->{ COUNT } % 2 ? 0 : 1 } sub parity { shift->{ COUNT } % 2 ? ODD : EVEN; } sub index { return $_[0]->{INDEX}; } sub count { return $_[0]->{COUNT}; } sub number { # This is here for backward compatibility per sub AUTOLOAD return $_[0]->{COUNT}; } sub first { return $_[0]->{FIRST}; } sub last { return $_[0]->{LAST}; } sub size { return $_[0]->{SIZE}; } #------------------------------------------------------------------------ # AUTOLOAD # # Provides access to internal fields (e.g. prev, next, etc) #------------------------------------------------------------------------ sub AUTOLOAD { my $self = shift; my $item = $AUTOLOAD; $item =~ s/.*:://; return if $item eq 'DESTROY'; # alias NUMBER to COUNT for backwards compatibility $item = 'COUNT' if CORE::index(uc $item,'NUMBER') > -1; return $self->{ uc $item }; } 1; __END__ =head1 NAME Template::Iterator - Data iterator used by the FOREACH directive =head1 SYNOPSIS my $iter = Template::Iterator->new(\@data, \%options); =head1 DESCRIPTION The C<Template::Iterator> module defines a generic data iterator for use by the C<FOREACH> directive. It may be used as the base class for custom iterators. =head1 PUBLIC METHODS =head2 new($data) Constructor method. A reference to a list of values is passed as the first parameter. Subsequent calls to L<get_first()> and L<get_next()> calls will return each element from the list. my $iter = Template::Iterator->new([ 'foo', 'bar', 'baz' ]); The constructor will also accept a reference to a hash array and will expand it into a list in which each entry is a hash array containing a 'C<key>' and 'C<value>' item, sorted according to the hash keys. my $iter = Template::Iterator->new({ foo => 'Foo Item', bar => 'Bar Item', }); This is equivalent to: my $iter = Template::Iterator->new([ { key => 'bar', value => 'Bar Item' }, { key => 'foo', value => 'Foo Item' }, ]); When passed a single item which is not an array reference, the constructor will automatically create a list containing that single item. my $iter = Template::Iterator->new('foo'); This is equivalent to: my $iter = Template::Iterator->new([ 'foo' ]); Note that a single item which is an object based on a blessed ARRAY references will NOT be treated as an array and will be folded into a list containing that one object reference. my $list = bless [ 'foo', 'bar' ], 'MyListClass'; my $iter = Template::Iterator->new($list); equivalent to: my $iter = Template::Iterator->new([ $list ]); If the object provides an C<as_list()> method then the L<Template::Iterator> constructor will call that method to return the list of data. For example: package MyListObject; sub new { my $class = shift; bless [ @_ ], $class; } package main; my $list = MyListObject->new('foo', 'bar'); my $iter = Template::Iterator->new($list); This is then functionally equivalent to: my $iter = Template::Iterator->new([ $list ]); The iterator will return only one item, a reference to the C<MyListObject> object, C<$list>. By adding an C<as_list()> method to the C<MyListObject> class, we can force the C<Template::Iterator> constructor to treat the object as a list and use the data contained within. package MyListObject; ... sub as_list { my $self = shift; return $self; } package main; my $list = MyListObject->new('foo', 'bar'); my $iter = Template::Iterator->new($list); The iterator will now return the two items, 'C<foo>' and 'C<bar>', which the C<MyObjectList> encapsulates. =head2 get_first() Returns a C<($value, $error)> pair for the first item in the iterator set. The C<$error> returned may be zero or undefined to indicate a valid datum was successfully returned. Returns an error of C<STATUS_DONE> if the list is empty. =head2 get_next() Returns a C<($value, $error)> pair for the next item in the iterator set. Returns an error of C<STATUS_DONE> if all items in the list have been visited. =head2 get_all() Returns a C<(\@values, $error)> pair for all remaining items in the iterator set. Returns an error of C<STATUS_DONE> if all items in the list have been visited. =head2 size() Returns the size of the data set or undef if unknown. =head2 max() Returns the maximum index number (i.e. the index of the last element) which is equivalent to L<size()> - C<1>. =head2 index() Returns the current index number which is in the range C<0> to L<max()>. =head2 count() Returns the current iteration count in the range C<1> to L<size()>. This is equivalent to L<index()> + C<1>. =head2 first() Returns a boolean value to indicate if the iterator is currently on the first iteration of the set. =head2 last() Returns a boolean value to indicate if the iterator is currently on the last iteration of the set. =head2 prev() Returns the previous item in the data set, or C<undef> if the iterator is on the first item. =head2 next() Returns the next item in the data set or C<undef> if the iterator is on the last item. =head2 number() This is an alias to 'count' to provide backward compatibility. View L<count>. =head2 parity() Returns the text string C<even> or C<odd> to indicate the parity of the current iteration count (starting at 1). This is typically used to create striped I<zebra tables>. <table> [% FOREACH name IN ['Arthur', 'Ford', 'Trillian'] -%] <tr class="[% loop.parity %]"> <td>[% name %]</td> </tr> [% END %] </table> This will produce the following output: <table> <tr class="odd"> <td>Arthur</td> </tr> <tr class="even"> <td>Ford</td> </tr> <tr class="odd"> <td>Trillian</td> </tr> </table> You can then style the C<tr.odd> and C<tr.even> elements using CSS: tr.odd td { background-color: black; color: white; } tr.even td { background-color: white; color: black; } =head2 odd() Returns a boolean (0/1) value to indicate if the current iterator count (starting at 1) is an odd number. In other words, this will return a true value for the first iterator, the third, fifth, and so on. =head2 even() Returns a boolean (0/1) value to indicate if the current iterator count (starting at 1) is an even number. In other words, this will return a true value for the second iteration, the fourth, sixth, and so on. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Constants.pm 0000444 00000022623 15125513451 0011225 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Constants.pm # # DESCRIPTION # Definition of constants for the Template Toolkit. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Constants; require Exporter; use strict; use warnings; use Exporter; use base qw( Exporter ); our ( @EXPORT_OK, %EXPORT_TAGS ); our ( $DEBUG_OPTIONS, @STATUS, @ERROR, @CHOMP, @DEBUG, @ISA ); our $VERSION = '3.100'; #======================================================================== # ----- EXPORTER ----- #======================================================================== # STATUS constants returned by directives use constant STATUS_OK => 0; # ok use constant STATUS_RETURN => 1; # ok, block ended by RETURN use constant STATUS_STOP => 2; # ok, stopped by STOP use constant STATUS_DONE => 3; # ok, iterator done use constant STATUS_DECLINED => 4; # ok, declined to service request use constant STATUS_ERROR => 255; # error condition # ERROR constants for indicating exception types use constant ERROR_RETURN => 'return'; # return a status code use constant ERROR_FILE => 'file'; # file error: I/O, parse, recursion use constant ERROR_VIEW => 'view'; # view error use constant ERROR_UNDEF => 'undef'; # undefined variable value used use constant ERROR_PERL => 'perl'; # error in [% PERL %] block use constant ERROR_FILTER => 'filter'; # filter error use constant ERROR_PLUGIN => 'plugin'; # plugin error # CHOMP constants for PRE_CHOMP and POST_CHOMP use constant CHOMP_NONE => 0; # do not remove whitespace use constant CHOMP_ALL => 1; # remove whitespace up to newline use constant CHOMP_ONE => 1; # new name for CHOMP_ALL use constant CHOMP_COLLAPSE => 2; # collapse whitespace to a single space use constant CHOMP_GREEDY => 3; # remove all whitespace including newlines # DEBUG constants to enable various debugging options use constant DEBUG_OFF => 0; # do nothing use constant DEBUG_ON => 1; # basic debugging flag use constant DEBUG_UNDEF => 2; # throw undef on undefined variables use constant DEBUG_VARS => 4; # general variable debugging use constant DEBUG_DIRS => 8; # directive debugging use constant DEBUG_STASH => 16; # general stash debugging use constant DEBUG_CONTEXT => 32; # context debugging use constant DEBUG_PARSER => 64; # parser debugging use constant DEBUG_PROVIDER => 128; # provider debugging use constant DEBUG_PLUGINS => 256; # plugins debugging use constant DEBUG_FILTERS => 512; # filters debugging use constant DEBUG_SERVICE => 1024; # context debugging use constant DEBUG_ALL => 2047; # everything # extra debugging flags use constant DEBUG_CALLER => 4096; # add caller file/line use constant DEBUG_FLAGS => 4096; # bitmask to extract flags $DEBUG_OPTIONS = { &DEBUG_OFF => off => off => &DEBUG_OFF, &DEBUG_ON => on => on => &DEBUG_ON, &DEBUG_UNDEF => undef => undef => &DEBUG_UNDEF, &DEBUG_VARS => vars => vars => &DEBUG_VARS, &DEBUG_DIRS => dirs => dirs => &DEBUG_DIRS, &DEBUG_STASH => stash => stash => &DEBUG_STASH, &DEBUG_CONTEXT => context => context => &DEBUG_CONTEXT, &DEBUG_PARSER => parser => parser => &DEBUG_PARSER, &DEBUG_PROVIDER => provider => provider => &DEBUG_PROVIDER, &DEBUG_PLUGINS => plugins => plugins => &DEBUG_PLUGINS, &DEBUG_FILTERS => filters => filters => &DEBUG_FILTERS, &DEBUG_SERVICE => service => service => &DEBUG_SERVICE, &DEBUG_ALL => all => all => &DEBUG_ALL, &DEBUG_CALLER => caller => caller => &DEBUG_CALLER, }; @STATUS = qw( STATUS_OK STATUS_RETURN STATUS_STOP STATUS_DONE STATUS_DECLINED STATUS_ERROR ); @ERROR = qw( ERROR_FILE ERROR_VIEW ERROR_UNDEF ERROR_PERL ERROR_RETURN ERROR_FILTER ERROR_PLUGIN ); @CHOMP = qw( CHOMP_NONE CHOMP_ALL CHOMP_ONE CHOMP_COLLAPSE CHOMP_GREEDY ); @DEBUG = qw( DEBUG_OFF DEBUG_ON DEBUG_UNDEF DEBUG_VARS DEBUG_DIRS DEBUG_STASH DEBUG_CONTEXT DEBUG_PARSER DEBUG_PROVIDER DEBUG_PLUGINS DEBUG_FILTERS DEBUG_SERVICE DEBUG_ALL DEBUG_CALLER DEBUG_FLAGS ); @EXPORT_OK = ( @STATUS, @ERROR, @CHOMP, @DEBUG ); %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ], 'status' => [ @STATUS ], 'error' => [ @ERROR ], 'chomp' => [ @CHOMP ], 'debug' => [ @DEBUG ], ); sub debug_flags { my ($self, $debug) = @_; my (@flags, $flag, $value); $debug = $self unless defined($debug) || ref($self); if ( $debug !~ tr{0-9}{}c) { foreach $flag (@DEBUG) { next if $flag eq 'DEBUG_OFF' || $flag eq 'DEBUG_ALL' || $flag eq 'DEBUG_FLAGS'; # don't trash the original substr($flag,0,6,'') if index($flag,'DEBUG_') == 0; $flag = lc $flag; return $self->error("no value for flag: $flag") unless defined($value = $DEBUG_OPTIONS->{ $flag }); $flag = $value; if ($debug & $flag) { $value = $DEBUG_OPTIONS->{ $flag }; return $self->error("no value for flag: $flag") unless defined $value; push(@flags, $value); } } return wantarray ? @flags : join(', ', @flags); } else { @flags = split(/\W+/, $debug); $debug = 0; foreach $flag (@flags) { $value = $DEBUG_OPTIONS->{ $flag }; return $self->error("unknown debug flag: $flag") unless defined $value; $debug |= $value; } return $debug; } } 1; __END__ =head1 NAME Template::Constants - Defines constants for the Template Toolkit =head1 SYNOPSIS use Template::Constants qw( :status :error :all ); =head1 DESCRIPTION The C<Template::Constants> modules defines, and optionally exports into the caller's namespace, a number of constants used by the L<Template> package. Constants may be used by specifying the C<Template::Constants> package explicitly: use Template::Constants; print Template::Constants::STATUS_DECLINED; Constants may be imported into the caller's namespace by naming them as options to the C<use Template::Constants> statement: use Template::Constants qw( STATUS_DECLINED ); print STATUS_DECLINED; Alternatively, one of the following tagset identifiers may be specified to import sets of constants: 'C<:status>', 'C<:error>', 'C<:all>'. use Template::Constants qw( :status ); print STATUS_DECLINED; Consult the documentation for the C<Exporter> module for more information on exporting variables. =head1 EXPORTABLE TAG SETS The following tag sets and associated constants are defined: :status STATUS_OK # no problem, continue STATUS_RETURN # ended current block then continue (ok) STATUS_STOP # controlled stop (ok) STATUS_DONE # iterator is all done (ok) STATUS_DECLINED # provider declined to service request (ok) STATUS_ERROR # general error condition (not ok) :error ERROR_RETURN # return a status code (e.g. 'stop') ERROR_FILE # file error: I/O, parse, recursion ERROR_UNDEF # undefined variable value used ERROR_PERL # error in [% PERL %] block ERROR_FILTER # filter error ERROR_PLUGIN # plugin error :chomp # for PRE_CHOMP and POST_CHOMP CHOMP_NONE # do not remove whitespace CHOMP_ONE # remove whitespace to newline CHOMP_ALL # old name for CHOMP_ONE (deprecated) CHOMP_COLLAPSE # collapse whitespace to a single space CHOMP_GREEDY # remove all whitespace including newlines :debug DEBUG_OFF # do nothing DEBUG_ON # basic debugging flag DEBUG_UNDEF # throw undef on undefined variables DEBUG_VARS # general variable debugging DEBUG_DIRS # directive debugging DEBUG_STASH # general stash debugging DEBUG_CONTEXT # context debugging DEBUG_PARSER # parser debugging DEBUG_PROVIDER # provider debugging DEBUG_PLUGINS # plugins debugging DEBUG_FILTERS # filters debugging DEBUG_SERVICE # context debugging DEBUG_ALL # everything DEBUG_CALLER # add caller file/line info DEBUG_FLAGS # bitmap used internally :all All the above constants. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template>, C<Exporter> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Plugin.pm 0000444 00000021370 15125513451 0010505 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Plugin # # DESCRIPTION # # Module defining a base class for a plugin object which can be loaded # and instantiated via the USE directive. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it an/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Plugin; use strict; use warnings; use base 'Template::Base'; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $ERROR = ''; our $AUTOLOAD; #======================================================================== # ----- CLASS METHODS ----- #======================================================================== #------------------------------------------------------------------------ # load() # # Class method called when the plugin module is first loaded. It # returns the name of a class (by default, its own class) or a prototype # object which will be used to instantiate new objects. The new() # method is then called against the class name (class method) or # prototype object (object method) to create a new instances of the # object. #------------------------------------------------------------------------ sub load { return $_[0]; } #------------------------------------------------------------------------ # new($context, $delegate, @params) # # Object constructor which is called by the Template::Context to # instantiate a new Plugin object. This base class constructor is # used as a general mechanism to load and delegate to other Perl # modules. The context is passed as the first parameter, followed by # a reference to a delegate object or the name of the module which # should be loaded and instantiated. Any additional parameters passed # to the USE directive are forwarded to the new() constructor. # # A plugin object is returned which has an AUTOLOAD method to delegate # requests to the underlying object. #------------------------------------------------------------------------ sub new { my $class = shift; bless { }, $class; } #------------------------------------------------------------------------ # fail($error) # # Version 1 error reporting function, now replaced by error() inherited # from Template::Base. Raises a "deprecated function" warning and then # calls error(). #------------------------------------------------------------------------ sub fail { my $class = shift; my ($pkg, $file, $line) = caller(); warn "Template::Plugin::fail() is deprecated at $file line $line. Please use error()\n"; $class->error(@_); } 1; __END__ =head1 NAME Template::Plugin - Base class for Template Toolkit plugins =head1 SYNOPSIS package MyOrg::Template::Plugin::MyPlugin; use base qw( Template::Plugin ); use Template::Plugin; use MyModule; sub new { my $class = shift; my $context = shift; bless { ... }, $class; } =head1 DESCRIPTION A "plugin" for the Template Toolkit is simply a Perl module which exists in a known package location (e.g. C<Template::Plugin::*>) and conforms to a regular standard, allowing it to be loaded and used automatically. The C<Template::Plugin> module defines a base class from which other plugin modules can be derived. A plugin does not have to be derived from Template::Plugin but should at least conform to its object-oriented interface. It is recommended that you create plugins in your own package namespace to avoid conflict with toolkit plugins. e.g. package MyOrg::Template::Plugin::FooBar; Use the L<PLUGIN_BASE|Template::Manual::Config#PLUGIN_BASE> option to specify the namespace that you use. e.g. use Template; my $template = Template->new({ PLUGIN_BASE => 'MyOrg::Template::Plugin', }); =head1 METHODS The following methods form the basic interface between the Template Toolkit and plugin modules. =head2 load($context) This method is called by the Template Toolkit when the plugin module is first loaded. It is called as a package method and thus implicitly receives the package name as the first parameter. A reference to the L<Template::Context> object loading the plugin is also passed. The default behaviour for the C<load()> method is to simply return the class name. The calling context then uses this class name to call the C<new()> package method. package MyPlugin; sub load { # called as MyPlugin->load($context) my ($class, $context) = @_; return $class; # returns 'MyPlugin' } =head2 new($context, @params) This method is called to instantiate a new plugin object for the C<USE> directive. It is called as a package method against the class name returned by L<load()>. A reference to the L<Template::Context> object creating the plugin is passed, along with any additional parameters specified in the C<USE> directive. sub new { # called as MyPlugin->new($context) my ($class, $context, @params) = @_; bless { _CONTEXT => $context, }, $class; # returns blessed MyPlugin object } =head2 error($error) This method, inherited from the L<Template::Base> module, is used for reporting and returning errors. It can be called as a package method to set/return the C<$ERROR> package variable, or as an object method to set/return the object C<_ERROR> member. When called with an argument, it sets the relevant variable and returns C<undef.> When called without an argument, it returns the value of the variable. package MyPlugin; use base 'Template::Plugin'; sub new { my ($class, $context, $dsn) = @_; return $class->error('No data source specified') unless $dsn; bless { _DSN => $dsn, }, $class; } package main; my $something = MyPlugin->new() || die MyPlugin->error(), "\n"; $something->do_something() || die $something->error(), "\n"; =head1 DEEPER MAGIC The L<Template::Context> object that handles the loading and use of plugins calls the L<new()> and L<error()> methods against the package name returned by the L<load()> method. In pseudo-code terms looks something like this: $class = MyPlugin->load($context); # returns 'MyPlugin' $object = $class->new($context, @params) # MyPlugin->new(...) || die $class->error(); # MyPlugin->error() The L<load()> method may alternately return a blessed reference to an object instance. In this case, L<new()> and L<error()> are then called as I<object> methods against that prototype instance. package YourPlugin; sub load { my ($class, $context) = @_; bless { _CONTEXT => $context, }, $class; } sub new { my ($self, $context, @params) = @_; return $self; } In this example, we have implemented a 'Singleton' plugin. One object gets created when L<load()> is called and this simply returns itself for each call to L<new().> Another implementation might require individual objects to be created for every call to L<new(),> but with each object sharing a reference to some other object to maintain cached data, database handles, etc. This pseudo-code example demonstrates the principle. package MyServer; sub load { my ($class, $context) = @_; bless { _CONTEXT => $context, _CACHE => { }, }, $class; } sub new { my ($self, $context, @params) = @_; MyClient->new($self, @params); } sub add_to_cache { ... } sub get_from_cache { ... } package MyClient; sub new { my ($class, $server, $blah) = @_; bless { _SERVER => $server, _BLAH => $blah, }, $class; } sub get { my $self = shift; $self->{ _SERVER }->get_from_cache(@_); } sub put { my $self = shift; $self->{ _SERVER }->add_to_cache(@_); } When the plugin is loaded, a C<MyServer> instance is created. The L<new()> method is called against this object which instantiates and returns a C<MyClient> object, primed to communicate with the creating C<MyServer>. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template>, L<Template::Plugins>, L<Template::Context> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Config.pm 0000444 00000032607 15125513451 0010461 0 ustar 00 #============================================================= -*-perl-*- # # Template::Config # # DESCRIPTION # Template Toolkit configuration module. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== package Template::Config; use strict; use warnings; use base 'Template::Base'; our $VERSION = '3.100'; our $DEBUG; $DEBUG = 0 unless defined $DEBUG; our $ERROR = ''; our $CONTEXT = 'Template::Context'; our $FILTERS = 'Template::Filters'; our $ITERATOR = 'Template::Iterator'; our $PARSER = 'Template::Parser'; our $PLUGINS = 'Template::Plugins'; our $PROVIDER = 'Template::Provider'; our $SERVICE = 'Template::Service'; our $STASH; $STASH = 'Template::Stash::XS'; our $CONSTANTS = 'Template::Namespace::Constants'; our $LATEX_PATH; our $PDFLATEX_PATH; our $DVIPS_PATH; our @PRELOAD = ( $CONTEXT, $FILTERS, $ITERATOR, $PARSER, $PLUGINS, $PROVIDER, $SERVICE, $STASH ); # the following is set at installation time by the Makefile.PL our $INSTDIR = ''; #======================================================================== # --- CLASS METHODS --- #======================================================================== #------------------------------------------------------------------------ # preload($module, $module, ...) # # Preloads all the standard TT modules that are likely to be used, along # with any other passed as arguments. #------------------------------------------------------------------------ sub preload { my $class = shift; foreach my $module (@PRELOAD, @_) { $class->load($module) || return; }; return 1; } #------------------------------------------------------------------------ # load($module) # # Load a module via require(). Any occurrences of '::' in the module name # are be converted to '/' and '.pm' is appended. Returns 1 on success # or undef on error. Use $class->error() to examine the error string. #------------------------------------------------------------------------ sub load { my ($class, $module) = @_; $module =~ s[::][/]g; $module .= '.pm'; return 1 if $INC{$module}; eval { require $module; }; return $@ ? $class->error("failed to load $module: $@") : 1; } #------------------------------------------------------------------------ # parser(\%params) # # Instantiate a new parser object of the class whose name is denoted by # the package variable $PARSER (default: Template::Parser). Returns # a reference to a newly instantiated parser object or undef on error. # The class error() method can be called without arguments to examine # the error message generated by this failure. #------------------------------------------------------------------------ sub parser { my $class = shift; my $params = defined($_[0]) && ref($_[0]) eq 'HASH' ? shift : { @_ }; return undef unless $class->load($PARSER); return $PARSER->new($params) || $class->error("failed to create parser: ", $PARSER->error); } #------------------------------------------------------------------------ # provider(\%params) # # Instantiate a new template provider object (default: Template::Provider). # Returns an object reference or undef on error, as above. #------------------------------------------------------------------------ sub provider { my $class = shift; my $params = defined($_[0]) && ref($_[0]) eq 'HASH' ? shift : { @_ }; return undef unless $class->load($PROVIDER); return $PROVIDER->new($params) || $class->error( "failed to create template provider: ", $PROVIDER->error ); } #------------------------------------------------------------------------ # plugins(\%params) # # Instantiate a new plugins provider object (default: Template::Plugins). # Returns an object reference or undef on error, as above. #------------------------------------------------------------------------ sub plugins { my $class = shift; my $params = defined($_[0]) && ref($_[0]) eq 'HASH' ? shift : { @_ }; return undef unless $class->load($PLUGINS); return $PLUGINS->new($params) || $class->error( "failed to create plugin provider: ", $PLUGINS->error ); } #------------------------------------------------------------------------ # filters(\%params) # # Instantiate a new filters provider object (default: Template::Filters). # Returns an object reference or undef on error, as above. #------------------------------------------------------------------------ sub filters { my $class = shift; my $params = defined($_[0]) && ref($_[0]) eq 'HASH' ? shift : { @_ }; return undef unless $class->load($FILTERS); return $FILTERS->new($params) || $class->error( "failed to create filter provider: ", $FILTERS->error ); } #------------------------------------------------------------------------ # iterator(\@list) # # Instantiate a new Template::Iterator object (default: Template::Iterator). # Returns an object reference or undef on error, as above. #------------------------------------------------------------------------ sub iterator { my $class = shift; my $list = shift; return undef unless $class->load($ITERATOR); return $ITERATOR->new($list, @_) || $class->error("failed to create iterator: ", $ITERATOR->error); } #------------------------------------------------------------------------ # stash(\%vars) # # Instantiate a new template variable stash object (default: # Template::Stash). Returns object or undef, as above. #------------------------------------------------------------------------ sub stash { my $class = shift; my $params = defined($_[0]) && ref($_[0]) eq 'HASH' ? shift : { @_ }; return undef unless $class->load($STASH); return $STASH->new($params) || $class->error( "failed to create stash: ", $STASH->error ); } #------------------------------------------------------------------------ # context(\%params) # # Instantiate a new template context object (default: Template::Context). # Returns object or undef, as above. #------------------------------------------------------------------------ sub context { my $class = shift; my $params = defined($_[0]) && ref($_[0]) eq 'HASH' ? shift : { @_ }; return undef unless $class->load($CONTEXT); return $CONTEXT->new($params) || $class->error( "failed to create context: ", $CONTEXT->error ); } #------------------------------------------------------------------------ # service(\%params) # # Instantiate a new template context object (default: Template::Service). # Returns object or undef, as above. #------------------------------------------------------------------------ sub service { my $class = shift; my $params = defined($_[0]) && ref($_[0]) eq 'HASH' ? shift : { @_ }; return undef unless $class->load($SERVICE); return $SERVICE->new($params) || $class->error( "failed to create context: ", $SERVICE->error ); } #------------------------------------------------------------------------ # constants(\%params) # # Instantiate a new namespace handler for compile time constant folding # (default: Template::Namespace::Constants). # Returns object or undef, as above. #------------------------------------------------------------------------ sub constants { my $class = shift; my $params = defined($_[0]) && ref($_[0]) eq 'HASH' ? shift : { @_ }; return undef unless $class->load($CONSTANTS); return $CONSTANTS->new($params) || $class->error( "failed to create constants namespace: ", $CONSTANTS->error ); } #------------------------------------------------------------------------ # instdir($dir) # # Returns the root installation directory appended with any local # component directory passed as an argument. #------------------------------------------------------------------------ sub instdir { my ($class, $dir) = @_; my $inst = $INSTDIR || return $class->error("no installation directory"); chop $inst while substr($inst,-1) eq '/'; $inst .= "/$dir" if $dir; return $inst; } #======================================================================== # This should probably be moved somewhere else in the long term, but for # now it ensures that Template::TieString is available even if the # Template::Directive module hasn't been loaded, as is the case when # using compiled templates and Template::Parser hasn't yet been loaded # on demand. #======================================================================== #------------------------------------------------------------------------ # simple package for tying $output variable to STDOUT, used by perl() #------------------------------------------------------------------------ package Template::TieString; sub TIEHANDLE { my ($class, $textref) = @_; bless $textref, $class; } sub PRINT { my $self = shift; $$self .= join('', @_); } 1; __END__ =head1 NAME Template::Config - Factory module for instantiating other TT2 modules =head1 SYNOPSIS use Template::Config; =head1 DESCRIPTION This module implements various methods for loading and instantiating other modules that comprise the Template Toolkit. It provides a consistent way to create toolkit components and allows custom modules to be used in place of the regular ones. Package variables such as C<$STASH>, C<$SERVICE>, C<$CONTEXT>, etc., contain the default module/package name for each component (L<Template::Stash>, L<Template::Service> and L<Template::Context>, respectively) and are used by the various factory methods (L<stash()>, L<service()> and L<context()>) to load the appropriate module. Changing these package variables will cause subsequent calls to the relevant factory method to load and instantiate an object from the new class. =head1 PUBLIC METHODS =head2 load($module) Load a module using Perl's L<require()>. Any occurrences of 'C<::>' in the module name are be converted to 'C</>', and 'C<.pm>' is appended. Returns 1 on success or undef on error. Use C<$class-E<gt>error()> to examine the error string. =head2 preload() This method preloads all the other C<Template::*> modules that are likely to be used. It is called automatically by the L<Template> module when running under mod_perl (C<$ENV{MOD_PERL}> is set). =head2 parser(\%config) Instantiate a new parser object of the class whose name is denoted by the package variable C<$PARSER> (default: L<Template::Parser>). Returns a reference to a newly instantiated parser object or undef on error. =head2 provider(\%config) Instantiate a new template provider object (default: L<Template::Provider>). Returns an object reference or undef on error, as above. =head2 plugins(\%config) Instantiate a new plugins provider object (default: L<Template::Plugins>). Returns an object reference or undef on error, as above. =head2 filters(\%config) Instantiate a new filter provider object (default: L<Template::Filters>). Returns an object reference or undef on error, as above. =head2 stash(\%vars) Instantiate a new stash object (L<Template::Stash> or L<Template::Stash::XS> depending on the default set at installation time) using the contents of the optional hash array passed by parameter as initial variable definitions. Returns an object reference or undef on error, as above. =head2 context(\%config) Instantiate a new template context object (default: L<Template::Context>). Returns an object reference or undef on error, as above. =head2 service(\%config) Instantiate a new template service object (default: L<Template::Service>). Returns an object reference or undef on error, as above. =head2 iterator(\%config) Instantiate a new template iterator object (default: L<Template::Iterator>). Returns an object reference or undef on error, as above. =head2 constants(\%config) Instantiate a new namespace handler for compile time constant folding (default: L<Template::Namespace::Constants>). Returns an object reference or undef on error, as above. =head2 instdir($dir) Returns the root directory of the Template Toolkit installation under which optional components are installed. Any relative directory specified as an argument will be appended to the returned directory. # e.g. returns '/usr/local/tt2' my $ttroot = Template::Config->instdir() || die "$Template::Config::ERROR\n"; # e.g. returns '/usr/local/tt2/templates' my $template = Template::Config->instdir('templates') || die "$Template::Config::ERROR\n"; Returns C<undef> and sets C<$Template::Config::ERROR> appropriately if the optional components of the Template Toolkit have not been installed. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Service.pm 0000444 00000042453 15125513451 0010654 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Service # # DESCRIPTION # Module implementing a template processing service which wraps a # template within PRE_PROCESS and POST_PROCESS templates and offers # ERROR recovery. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Service; use strict; use warnings; use base 'Template::Base'; use Template::Config; use Template::Exception; use Template::Constants; use Scalar::Util 'blessed'; use constant EXCEPTION => 'Template::Exception'; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $ERROR = ''; #======================================================================== # ----- PUBLIC METHODS ----- #======================================================================== #------------------------------------------------------------------------ # process($template, \%params) # # Process a template within a service framework. A service may encompass # PRE_PROCESS and POST_PROCESS templates and an ERROR hash which names # templates to be substituted for the main template document in case of # error. Each service invocation begins by resetting the state of the # context object via a call to reset(). The AUTO_RESET option may be set # to 0 (default: 1) to bypass this step. #------------------------------------------------------------------------ sub process { my ($self, $template, $params) = @_; my $context = $self->{ CONTEXT }; my ($name, $output, $procout, $error); $output = ''; $self->debug( "process($template, ", defined $params ? $params : '<no params>', ')' ) if $self->{ DEBUG }; $context->reset() if $self->{ AUTO_RESET }; # pre-request compiled template from context so that we can alias it # in the stash for pre-processed templates to reference eval { $template = $context->template($template) }; return $self->error($@) if $@; # localise the variable stash with any parameters passed # and set the 'template' variable $params ||= { }; # TODO: change this to C<||=> so we can use a template parameter $params->{ template } = $template unless ref $template eq 'CODE'; $context->localise($params); SERVICE: { # PRE_PROCESS eval { foreach $name (@{ $self->{ PRE_PROCESS } }) { $self->debug("PRE_PROCESS: $name") if $self->{ DEBUG }; $output .= $context->process($name); } }; last SERVICE if ($error = $@); # PROCESS eval { foreach $name (@{ $self->{ PROCESS } || [ $template ] }) { $self->debug("PROCESS: $name") if $self->{ DEBUG }; $procout .= $context->process($name); } }; if ($error = $@) { last SERVICE unless defined ($procout = $self->_recover(\$error)); } if (defined $procout) { # WRAPPER eval { foreach $name (reverse @{ $self->{ WRAPPER } }) { $self->debug("WRAPPER: $name") if $self->{ DEBUG }; $procout = $context->process($name, { content => $procout }); } }; last SERVICE if ($error = $@); $output .= $procout; } # POST_PROCESS eval { foreach $name (@{ $self->{ POST_PROCESS } }) { $self->debug("POST_PROCESS: $name") if $self->{ DEBUG }; $output .= $context->process($name); } }; last SERVICE if ($error = $@); } $context->delocalise(); delete $params->{ template }; if ($error) { # $error = $error->as_string if ref $error; return $self->error($error); } return $output; } #------------------------------------------------------------------------ # context() # # Returns the internal CONTEXT reference. #------------------------------------------------------------------------ sub context { return $_[0]->{ CONTEXT }; } #======================================================================== # -- PRIVATE METHODS -- #======================================================================== sub _init { my ($self, $config) = @_; my ($item, $data, $context, $block, $blocks); my $delim = $config->{ DELIMITER }; $delim = ':' unless defined $delim; # coerce PRE_PROCESS, PROCESS and POST_PROCESS to arrays if necessary, # by splitting on non-word characters foreach $item (qw( PRE_PROCESS PROCESS POST_PROCESS WRAPPER )) { $data = $config->{ $item }; $self->{ $item } = [ ], next unless (defined $data); $data = [ split($delim, $data || '') ] unless ref $data eq 'ARRAY'; $self->{ $item } = $data; } # unset PROCESS option unless explicitly specified in config $self->{ PROCESS } = undef unless defined $config->{ PROCESS }; $self->{ ERROR } = $config->{ ERROR } || $config->{ ERRORS }; $self->{ AUTO_RESET } = defined $config->{ AUTO_RESET } ? $config->{ AUTO_RESET } : 1; $self->{ DEBUG } = ( $config->{ DEBUG } || 0 ) & Template::Constants::DEBUG_SERVICE; $context = $self->{ CONTEXT } = $config->{ CONTEXT } || Template::Config->context($config) || return $self->error(Template::Config->error); return $self; } #------------------------------------------------------------------------ # _recover(\$exception) # # Examines the internal ERROR hash array to find a handler suitable # for the exception object passed by reference. Selecting the handler # is done by delegation to the exception's select_handler() method, # passing the set of handler keys as arguments. A 'default' handler # may also be provided. The handler value represents the name of a # template which should be processed. #------------------------------------------------------------------------ sub _recover { my ($self, $error) = @_; my $context = $self->{ CONTEXT }; my ($hkey, $handler, $output); # there shouldn't ever be a non-exception object received at this # point... unless a module like CGI::Carp messes around with the # DIE handler. return undef unless blessed($$error) && $$error->isa(EXCEPTION); # a 'stop' exception is thrown by [% STOP %] - we return the output # buffer stored in the exception object return $$error->text() if $$error->type() eq 'stop'; my $handlers = $self->{ ERROR } || return undef; ## RETURN if (ref $handlers eq 'HASH') { if ($hkey = $$error->select_handler(keys %$handlers)) { $handler = $handlers->{ $hkey }; $self->debug("using error handler for $hkey") if $self->{ DEBUG }; } elsif ($handler = $handlers->{ default }) { # use default handler $self->debug("using default error handler") if $self->{ DEBUG }; } else { return undef; ## RETURN } } else { $handler = $handlers; $self->debug("using default error handler") if $self->{ DEBUG }; } eval { $handler = $context->template($handler) }; if ($@) { $$error = $@; return undef; ## RETURN }; $context->stash->set('error', $$error); eval { $output .= $context->process($handler); }; if ($@) { $$error = $@; return undef; ## RETURN } return $output; } 1; __END__ =head1 NAME Template::Service - General purpose template processing service =head1 SYNOPSIS use Template::Service; my $service = Template::Service->new({ PRE_PROCESS => [ 'config', 'header' ], POST_PROCESS => 'footer', ERROR => { user => 'user/index.html', dbi => 'error/database', default => 'error/default', }, }); my $output = $service->process($template_name, \%replace) || die $service->error(), "\n"; =head1 DESCRIPTION The C<Template::Service> module implements an object class for providing a consistent template processing service. Standard header (L<PRE_PROCESS|PRE_PROCESS_POST_PROCESS>) and footer (L<POST_PROCESS|PRE_PROCESS_POST_PROCESS>) templates may be specified which are prepended and appended to all templates processed by the service (but not any other templates or blocks C<INCLUDE>d or C<PROCESS>ed from within). An L<ERROR> hash may be specified which redirects the service to an alternate template file in the case of uncaught exceptions being thrown. This allows errors to be automatically handled by the service and a guaranteed valid response to be generated regardless of any processing problems encountered. A default C<Template::Service> object is created by the L<Template> module. Any C<Template::Service> options may be passed to the L<Template> L<new()|Template#new()> constructor method and will be forwarded to the L<Template::Service> constructor. use Template; my $template = Template->new({ PRE_PROCESS => 'header', POST_PROCESS => 'footer', }); Similarly, the C<Template::Service> constructor will forward all configuration parameters onto other default objects (e.g. L<Template::Context>) that it may need to instantiate. A C<Template::Service> object (or subclass) can be explicitly instantiated and passed to the L<Template> L<new()|Template#new()> constructor method as the L<SERVICE> item. use Template; use Template::Service; my $service = Template::Service->new({ PRE_PROCESS => 'header', POST_PROCESS => 'footer', }); my $template = Template->new({ SERVICE => $service, }); The C<Template::Service> module can be sub-classed to create custom service handlers. use Template; use MyOrg::Template::Service; my $service = MyOrg::Template::Service->new({ PRE_PROCESS => 'header', POST_PROCESS => 'footer', COOL_OPTION => 'enabled in spades', }); my $template = Template->new({ SERVICE => $service, }); The L<Template> module uses the L<Template::Config> L<service()|Template::Config#service()> factory method to create a default service object when required. The C<$Template::Config::SERVICE> package variable may be set to specify an alternate service module. This will be loaded automatically and its L<new()> constructor method called by the L<service()|Template::Config#service()> factory method when a default service object is required. Thus the previous example could be written as: use Template; $Template::Config::SERVICE = 'MyOrg::Template::Service'; my $template = Template->new({ PRE_PROCESS => 'header', POST_PROCESS => 'footer', COOL_OPTION => 'enabled in spades', }); =head1 METHODS =head2 new(\%config) The C<new()> constructor method is called to instantiate a C<Template::Service> object. Configuration parameters may be specified as a HASH reference or as a list of C<name =E<gt> value> pairs. my $service1 = Template::Service->new({ PRE_PROCESS => 'header', POST_PROCESS => 'footer', }); my $service2 = Template::Service->new( ERROR => 'error.html' ); The C<new()> method returns a C<Template::Service> object or C<undef> on error. In the latter case, a relevant error message can be retrieved by the L<error()|Template::Base#error()> class method or directly from the C<$Template::Service::ERROR> package variable. my $service = Template::Service->new(\%config) || die Template::Service->error(); my $service = Template::Service->new(\%config) || die $Template::Service::ERROR; =head2 process($input, \%replace) The C<process()> method is called to process a template specified as the first parameter, C<$input>. This may be a file name, file handle (e.g. C<GLOB> or C<IO::Handle>) or a reference to a text string containing the template text. An additional hash reference may be passed containing template variable definitions. The method processes the template, adding any L<PRE_PROCESS|PRE_PROCESS_POST_PROCESS> or L<POST_PROCESS|PRE_PROCESS_POST_PROCESS> templates defined, and returns the output text. An uncaught exception thrown by the template will be handled by a relevant L<ERROR> handler if defined. Errors that occur in the L<PRE_PROCESS|PRE_PROCESS_POST_PROCESS> or L<POST_PROCESS|PRE_PROCESS_POST_PROCESS> templates, or those that occur in the main input template and aren't handled, cause the method to return C<undef> to indicate failure. The appropriate error message can be retrieved via the L<error()|Template::Base#error()> method. $service->process('myfile.html', { title => 'My Test File' }) || die $service->error(); =head2 context() Returns a reference to the internal context object which is, by default, an instance of the L<Template::Context> class. =head1 CONFIGURATION OPTIONS The following list summarises the configuration options that can be provided to the C<Template::Service> L<new()> constructor. Please consult L<Template::Manual::Config> for further details and examples of each configuration option in use. =head2 PRE_PROCESS, POST_PROCESS The L<PRE_PROCESS|Template::Manual::Config#PRE_PROCESS_POST_PROCESS> and L<POST_PROCESS|Template::Manual::Config#PRE_PROCESS_POST_PROCESS> options may be set to contain the name(s) of template files which should be processed immediately before and/or after each template. These do not get added to templates processed into a document via directives such as C<INCLUDE> C<PROCESS>, C<WRAPPER>, etc. my $service = Template::Service->new({ PRE_PROCESS => 'header', POST_PROCESS => 'footer', }; Multiple templates may be specified as a reference to a list. Each is processed in the order defined. my $service = Template::Service->new({ PRE_PROCESS => [ 'config', 'header' ], POST_PROCESS => 'footer', }; =head2 PROCESS The L<PROCESS|Template::Manual::Config#PROCESS> option may be set to contain the name(s) of template files which should be processed instead of the main template passed to the C<Template::Service> L<process()> method. This can be used to apply consistent wrappers around all templates, similar to the use of L<PRE_PROCESS|PRE_PROCESS_POST_PROCESS> and L<POST_PROCESS|PRE_PROCESS_POST_PROCESS> templates. my $service = Template::Service->new({ PROCESS => 'content', }; # processes 'content' instead of 'foo.html' $service->process('foo.html'); A reference to the original template is available in the C<template> variable. Metadata items can be inspected and the template can be processed by specifying it as a variable reference (i.e. prefixed by 'C<$>') to an C<INCLUDE>, C<PROCESS> or C<WRAPPER> directive. Example C<PROCESS> template: <html> <head> <title>[% template.title %]</title> </head> <body> [% PROCESS $template %] </body> </html> =head2 ERROR The L<ERROR|Template::Manual::Config#ERROR> (or C<ERRORS> if you prefer) configuration item can be used to name a single template or specify a hash array mapping exception types to templates which should be used for error handling. If an uncaught exception is raised from within a template then the appropriate error template will instead be processed. If specified as a single value then that template will be processed for all uncaught exceptions. my $service = Template::Service->new({ ERROR => 'error.html' }); If the L<ERROR or ERRORS|Template::Manual::Config#ERROR> item is a hash reference the keys are assumed to be exception types and the relevant template for a given exception will be selected. A C<default> template may be provided for the general case. my $service = Template::Service->new({ ERRORS => { user => 'user/index.html', dbi => 'error/database', default => 'error/default', }, }); =head2 AUTO_RESET The L<AUTO_RESET|Template::Manual::Config#AUTO_RESET> option is set by default and causes the local C<BLOCKS> cache for the L<Template::Context> object to be reset on each call to the L<Template> L<process()|Template#process()> method. This ensures that any C<BLOCK>s defined within a template will only persist until that template is finished processing. =head2 DEBUG The L<DEBUG|Template::Manual::Config#DEBUG> option can be used to enable debugging messages from the C<Template::Service> module by setting it to include the C<DEBUG_SERVICE> value. use Template::Constants qw( :debug ); my $template = Template->new({ DEBUG => DEBUG_SERVICE, }); =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template>, L<Template::Context> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Modules.pod 0000444 00000012571 15125513451 0011030 0 ustar 00 #============================================================= -*-perl-*- # # Template::Modules # # DESCRIPTION # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== =head1 NAME Template::Modules - Template Toolkit Modules =head1 Template Toolkit Modules This documentation provides an overview of the different modules that comprise the Template Toolkit. =head2 Template The L<Template> module is the front-end to the Template Toolkit for Perl programmers. use Template; my $tt = Template->new(); $tt->process('hello.html', message => 'Hello World'); =head2 Template::Base The L<Template::Base> module implements a base class from which the other Template Toolkit modules are derived. It implements common functionality for creating objects, error reporting, debugging, and so on. =head2 Template::Config The L<Template::Config> module defines the configuration of the Template Toolkit for your system. It is an example of a I<factory module> which is responsible for instantiating the various other modules used in the Template Toolkit. For example, the L<Template::Config> module defines the C<$STASH> package variable which indicates which version of the L<Template::Stash> you are using by default. If you elected to use the faster L<XS|Template::Stash::XS> stash when you installed the Template Toolkit, then this will be set as: $STASH = 'Template::Stash::XS'; Otherwise you'll get the regular L<Perl|Template::Stash> stash: $STASH = 'Template::Stash'; This approach means that other parts of the Template Toolkit don't have to worry about which stash you're using. They just ask the L<Template::Config> module to create a stash of the right kind. =head2 Template::Constants The L<Template::Constants> defines a number of constants that are used by the Template Toolkit. For example, the C<:chomp> tagset defines the C<CHOMP_???> constants that can be used with the C<PRE_CHOMP> and C<POST_CHOMP> configuration options. use Template::Constants ':chomp'; my $tt = Template->new({ PRE_CHOMP => CHOMP_COLLAPSE, }); =head2 Template::Context The L<Template::Context> module defines a runtime context in which templates are processed. A context keeps track of all the templates, variables, plugins, and other resources that are available (either directly or through delegate objects) and provides methods to fetch, store, and perform various operations on them. =head2 Template::Document The L<Template::Document> module implements a compiled template document object. This is generated by the L<Template::Parser> module. =head2 Template::Exception The L<Template::Exception> module implements an exception object which is used for runtime error reporting. =head2 Template::Filters The L<Template::Filters> module implements a filter provider. It includes the core collection of filters that can be used via the C<FILTER> directive. =head2 Template::Iterator The L<Template::Iterator> module implements a data iterator which steps through each item in a list in turn. It is used by the C<FOREACH> directive. Within a C<FOREACH> block, the C<loop> variable always references the current iterator object. [% FOREACH item IN list; IF loop.first; # first item in loop ELSIF loop.last; # last item in loop ELSE; # any other item in loop END; END %] =head2 Template::Namespace::Constants The L<Template::Namespace::Constants> module is used internally to represent constants. These can be resolved immediately at the point that a template is compiled. =head2 Template::Parser The L<Template::Parser> module is used to parse a source template and turn it into Perl code which can be executed. =head2 Template::Plugin The L<Template::Plugin> module is a base class for Template Toolkit plugins that can be loaded on demand from within a template using the C<USE> directive. =head2 Template::Plugins The L<Template::Plugins> module is the plugins provider. It loads and prepares plugins as and when they are requested from within a template. =head2 Template::Provider The L<Template::Provider> module is responsible for loading, compiling and caching templates. =head2 Template::Service The L<Template::Service> module implements a service layer that sits just behind the L<Template> module, and just in front of a L<Template::Context>. It handles each request to process a template (forwarded from the L<Template> module). It adds any headers and/or footers (specified via the C<PRE_PROCESS> and C<POST_PROCESS> options), applies any wrapper (the C<WRAPPER> option) and catches any errors returned (the C<ERRORS> option). =head2 Template::Stash The L<Template::Stash> module is used to fetch and store template variables. It implements all of the magic associated with the dot operator. =head2 Template::Stash::XS The L<Template::Stash::XS> module is a high-speed implementation of L<Template::Stash> written in C. =head2 Template::Test The L<Template::Test> module is used to automate the Template Toolkit test scripts. =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Test.pm 0000444 00000053201 15125513451 0010164 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Test # # DESCRIPTION # Module defining a test harness which processes template input and # then compares the output against pre-define expected output. # Generates test output compatible with Test::Harness. This was # originally the t/texpect.pl script. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Test; use strict; use warnings; use Template; use Exporter; use constant MSWin32 => $^O eq 'MSWin32'; our $VERSION = '3.100'; our $DEBUG = 0; our @ISA = qw( Exporter ); our @EXPORT = qw( ntests ok is match flush skip_all test_expect callsign banner ); our @EXPORT_OK = ( 'assert' ); our %EXPORT_TAGS = ( all => [ @EXPORT_OK, @EXPORT ] ); $| = 1; our $REASON = 'not applicable on this platform'; our $NO_FLUSH = 0; our $EXTRA = 0; # any extra tests to come after test_expect() our $PRESERVE = 0 # don't mangle newlines in output/expect unless defined $PRESERVE; our ($loaded, %callsign); # always set binmode on Win32 machines so that any output generated # is true to what we expect $Template::BINMODE = (MSWin32) ? 1 : 0; my @results = (); my ($ntests, $ok_count); *is = \&match; END { # ensure flush() is called to print any cached results flush(); } #------------------------------------------------------------------------ # ntests($n) # # Declare how many (more) tests are expected to come. If ok() is called # before ntests() then the results are cached instead of being printed # to STDOUT. When ntests() is called, the total number of tests # (including any cached) is known and the "1..$ntests" line can be # printed along with the cached results. After that, calls to ok() # generated printed output immediately. #------------------------------------------------------------------------ sub ntests { $ntests = shift; # add any pre-declared extra tests, or pre-stored test @results, to # the grand total of tests $ntests += $EXTRA + scalar @results; $ok_count = 1; print $ntests ? "1..$ntests\n" : "1..$ntests # skip $REASON\n"; # flush cached results foreach my $pre_test (@results) { ok(@$pre_test); } } #------------------------------------------------------------------------ # ok($truth, $msg) # # Tests the value passed for truth and generates an "ok $n" or "not ok $n" # line accordingly. If ntests() hasn't been called then we cached # results for later, instead. #------------------------------------------------------------------------ sub ok { my ($ok, $msg) = @_; # cache results if ntests() not yet called unless ($ok_count) { push(@results, [ $ok, $msg ]); return $ok; } $msg = defined $msg ? " - $msg" : ''; if ($ok) { print "ok ", $ok_count++, "$msg\n"; } else { print STDERR "FAILED $ok_count: $msg\n" if defined $msg; print "not ok ", $ok_count++, "$msg\n"; } } #------------------------------------------------------------------------ # assert($truth, $error) # # Test value for truth, die if false. #------------------------------------------------------------------------ sub assert { my ($ok, $err) = @_; return ok(1) if $ok; # failed my ($pkg, $file, $line) = caller(); $err ||= "assert failed"; $err .= " at $file line $line\n"; ok(0); die $err; } #------------------------------------------------------------------------ # match( $result, $expect ) #------------------------------------------------------------------------ sub match { my ($result, $expect, $msg) = @_; my $count = $ok_count ? $ok_count : scalar @results + 1; # force stringification of $result to avoid 'no eq method' overload errors $result = "$result" if ref $result; if ($result eq $expect) { return ok(1, $msg); } else { print STDERR "FAILED $count:\n expect: [$expect]\n result: [$result]\n"; return ok(0, $msg); } } #------------------------------------------------------------------------ # flush() # # Flush any tests results. #------------------------------------------------------------------------ sub flush { ntests(0) unless $ok_count || $NO_FLUSH; } #------------------------------------------------------------------------ # skip_all($reason) # # Skip all tests, setting $REASON to contain any message passed. Calls # exit(0) which triggers flush() which generates a "1..0 # $REASON" # string to keep to test harness happy. #------------------------------------------------------------------------ sub skip_all { $REASON = join('', @_); exit(0); } #------------------------------------------------------------------------ # test_expect($input, $template, \%replace) # # This is the main testing sub-routine. The $input parameter should be a # text string or a filehandle reference (e.g. GLOB or IO::Handle) from # which the input text can be read. The input should contain a number # of tests which are split up and processed individually, comparing the # generated output against the expected output. Tests should be defined # as follows: # # -- test -- # test input # -- expect -- # expected output # # -- test -- # etc... # # The number of tests is determined and ntests() is called to generate # the "0..$n" line compatible with Test::Harness. Each test input is # then processed by the Template object passed as the second parameter, # $template. This may also be a hash reference containing configuration # which are used to instantiate a Template object, or may be left # undefined in which case a default Template object will be instantiated. # The third parameter, also optional, may be a reference to a hash array # defining template variables. This is passed to the template process() # method. #------------------------------------------------------------------------ sub test_expect { my ($src, $tproc, $params) = @_; my ($input, @tests); my ($output, $expect, $match); my $count = 0; my $ttprocs; # read input text eval { local $/ = undef; $input = ref $src ? <$src> : $src; }; if ($@) { ntests(1); ok(0); warn "Cannot read input text from $src\n"; return undef; } # remove any comment lines $input =~ s/^#.*?\n//gm; # remove anything before '-- start --' and/or after '-- stop --' $input = $' if $input =~ /\s*--\s*start\s*--\s*/; $input = $` if $input =~ /\s*--\s*stop\s*--\s*/; @tests = split(/^\s*--\s*test\s*--\s*\n/im, $input); # if the first line of the file was '--test--' (optional) then the # first test will be empty and can be discarded shift(@tests) if $tests[0] =~ /^\s*$/; ntests(3 + scalar(@tests) * 2); # first test is that Template loaded OK, which it did ok(1, 'running test_expect()'); # optional second param may contain a Template reference or a HASH ref # of constructor options, or may be undefined if (ref($tproc) eq 'HASH') { # create Template object using hash of config items $tproc = Template->new($tproc) || die Template->error(), "\n"; } elsif (ref($tproc) eq 'ARRAY') { # list of [ name => $tproc, name => $tproc ], use first $tproc $ttprocs = { @$tproc }; $tproc = $tproc->[1]; } elsif (! ref $tproc) { $tproc = Template->new() || die Template->error(), "\n"; } # otherwise, we assume it's a Template reference # test: template processor created OK ok($tproc, 'template processor is engaged'); # third test is that the input read ok, which it did ok(1, 'input read and split into ' . scalar @tests . ' tests'); # the remaining tests are defined in @tests... foreach $input (@tests) { $count++; my $name = ''; if ($input =~ s/^\s*-- name:? (.*?) --\s*\n//im) { $name = $1; } else { $name = "template text $count"; } # Configure a test as TODO my $todo = ''; if ($input =~ s/^\s*-- todo:? (.*?) --\s*\n//im) { $todo = ( $1 eq '' ) ? 'No reason given' : $1; } # split input by a line like "-- expect --" ($input, $expect) = split(/^\s*--\s*expect\s*--\s*\n/im, $input); $expect = '' unless defined $expect; $output = ''; # input text may be prefixed with "-- use name --" to indicate a # Template object in the $ttproc hash which we should use if ($input =~ s/^\s*--\s*use\s+(\S+)\s*--\s*\n//im) { my $ttname = $1; my $ttlookup; if ($ttlookup = $ttprocs->{ $ttname }) { $tproc = $ttlookup; } else { warn "no such template object to use: $ttname\n"; } } # process input text $tproc->process(\$input, $params, \$output) || do { warn "Template process failed: ", $tproc->error(), "\n"; # report failure and automatically fail the expect match ok(0, "$name process FAILED: " . subtext($input)); ok(0, '(obviously did not match expected)'); next; }; # processed OK ok(1, "$name processed OK: " . subtext($input)); # another hack: if the '-- expect --' section starts with # '-- process --' then we process the expected output # before comparing it with the generated output. This is # slightly twisted but it makes it possible to run tests # where the expected output isn't static. See t/date.t for # an example. if ($expect =~ s/^\s*--+\s*process\s*--+\s*\n//im) { my $out; $tproc->process(\$expect, $params, \$out) || do { warn( "Template process failed (expect): ", $tproc->error(), "\n" ); # report failure and automatically fail the expect match ok( 0, "failed to process expected output [" . subtext($expect) . ']' ); next; }; $expect = $out; }; # strip any trailing blank lines from expected and real output foreach ($expect, $output) { s/[\n\r]*\Z//mg; } $match = ($expect eq $output) ? 1 : 0; if (! $match || $DEBUG) { print "MATCH FAILED\n" unless $match; my ($copyi, $copye, $copyo) = ($input, $expect, $output); unless ($PRESERVE) { foreach ($copyi, $copye, $copyo) { s/\n/\\n/g; } } printf( " input: [%s]\nexpect: [%s]\noutput: [%s]\n", $copyi, $copye, $copyo ); } my $testprefix = $name; if ( $todo ) { $testprefix = "# TODO $todo - $name"; } ok($match, $match ? "$testprefix matched expected" : "$testprefix did not match expected"); }; } #------------------------------------------------------------------------ # callsign() # # Returns a hash array mapping lower a..z to their phonetic alphabet # equivalent. #------------------------------------------------------------------------ sub callsign { my %callsign; @callsign{ 'a'..'z' } = qw( alpha bravo charlie delta echo foxtrot golf hotel india juliet kilo lima mike november oscar papa quebec romeo sierra tango umbrella victor whisky x-ray yankee zulu ); return \%callsign; } #------------------------------------------------------------------------ # banner($text) # # Prints a banner with the specified text if $DEBUG is set. #------------------------------------------------------------------------ sub banner { return unless $DEBUG; my $text = join('', @_); my $count = $ok_count ? $ok_count - 1 : scalar @results; print "-" x 72, "\n$text ($count tests completed)\n", "-" x 72, "\n"; } sub subtext { my $text = shift; $text =~ s/\s*$//sg; $text = substr($text, 0, 32) . '...' if length $text > 32; $text =~ s/\n/\\n/g; return $text; } 1; __END__ =head1 NAME Template::Test - Module for automating TT2 test scripts =head1 SYNOPSIS use Template::Test; $Template::Test::DEBUG = 0; # set this true to see each test running $Template::Test::EXTRA = 2; # 2 extra tests follow test_expect()... # ok() can be called any number of times before test_expect ok( $true_or_false ) # test_expect() splits $input into individual tests, processes each # and compares generated output against expected output test_expect($input, $template, \%replace ); # $input is text or filehandle (e.g. DATA section after __END__) test_expect( $text ); test_expect( \*DATA ); # $template is a Template object or configuration hash my $template_cfg = { ... }; test_expect( $input, $template_cfg ); my $template_obj = Template->new($template_cfg); test_expect( $input, $template_obj ); # $replace is a hash reference of template variables my $replace = { a => 'alpha', b => 'bravo' }; test_expect( $input, $template, $replace ); # ok() called after test_expect should be declared in $EXTRA (2) ok( $true_or_false ) ok( $true_or_false ) =head1 DESCRIPTION The C<Template::Test> module defines the L<test_expect()> and other related subroutines which can be used to automate test scripts for the Template Toolkit. See the numerous tests in the F<t> sub-directory of the distribution for examples of use. =head1 PACKAGE SUBROUTINES =head2 text_expect() The C<test_expect()> subroutine splits an input document into a number of separate tests, processes each one using the Template Toolkit and then compares the generated output against an expected output, also specified in the input document. It generates the familiar C<ok>/C<not ok> output compatible with C<Test::Harness>. The test input should be specified as a text string or a reference to a filehandle (e.g. C<GLOB> or C<IO::Handle>) from which it can be read. In particular, this allows the test input to be placed after the C<__END__> marker and read via the C<DATA> filehandle. use Template::Test; test_expect(\*DATA); __END__ # this is the first test (this is a comment) -- test -- blah blah blah [% foo %] -- expect -- blah blah blah value_of_foo # here's the second test (no surprise, so is this) -- test -- more blah blah [% bar %] -- expect -- more blah blah value_of_bar Blank lines between test sections are generally ignored. Any line starting with C<#> is treated as a comment and is ignored. The second and third parameters to C<test_expect()> are optional. The second may be either a reference to a Template object which should be used to process the template fragments, or a reference to a hash array containing configuration values which should be used to instantiate a new Template object. # pass reference to config hash my $config = { INCLUDE_PATH => '/here/there:/every/where', POST_CHOMP => 1, }; test_expect(\*DATA, $config); # or create Template object explicitly my $template = Template->new($config); test_expect(\*DATA, $template); The third parameter may be used to reference a hash array of template variable which should be defined when processing the tests. This is passed to the L<Template> L<process()|Template#process()> method. my $replace = { a => 'alpha', b => 'bravo', }; test_expect(\*DATA, $config, $replace); The second parameter may be left undefined to specify a default L<Template> configuration. test_expect(\*DATA, undef, $replace); For testing the output of different L<Template> configurations, a reference to a list of named L<Template> objects also may be passed as the second parameter. my $tt1 = Template->new({ ... }); my $tt2 = Template->new({ ... }); my @tts = [ one => $tt1, two => $tt1 ]; The first object in the list is used by default. Other objects may be switched in with a 'C<-- use $name -->' marker. This should immediately follow a 'C<-- test -->' line. That object will then be used for the rest of the test, or until a different object is selected. -- test -- -- use one -- [% blah %] -- expect -- blah, blah -- test -- still using one... -- expect -- ... -- test -- -- use two -- [% blah %] -- expect -- blah, blah, more blah The C<test_expect()> sub counts the number of tests, and then calls L<ntests()> to generate the familiar "C<1..$ntests\n>" test harness line. Each test defined generates two test numbers. The first indicates that the input was processed without error, and the second that the output matches that expected. Additional test may be run before C<test_expect()> by calling L<ok()>. These test results are cached until L<ntests()> is called and the final number of tests can be calculated. Then, the "C<1..$ntests>" line is output, along with "C<ok $n>" / "C<not ok $n>" lines for each of the cached test result. Subsequent calls to L<ok()> then generate an output line immediately. my $something = SomeObject->new(); ok( $something ); my $other = AnotherThing->new(); ok( $other ); test_expect(\*DATA); If any tests are to follow after C<test_expect()> is called then these should be pre-declared by setting the C<$EXTRA> package variable. This value (default: C<0>) is added to the grand total calculated by L<ntests()>. The results of the additional tests are also registered by calling L<ok()>. $Template::Test::EXTRA = 2; # can call ok() any number of times before test_expect() ok( $did_that_work ); ok( $make_sure ); ok( $dead_certain ); # <some> number of tests... test_expect(\*DATA, $config, $replace); # here's those $EXTRA tests ok( defined $some_result && ref $some_result eq 'ARRAY' ); ok( $some_result->[0] eq 'some expected value' ); If you don't want to call C<test_expect()> at all then you can call C<ntests($n)> to declare the number of tests and generate the test header line. After that, simply call L<ok()> for each test passing a true or false values to indicate that the test passed or failed. ntests(2); ok(1); ok(0); If you're really lazy, you can just call L<ok()> and not bother declaring the number of tests at all. All tests results will be cached until the end of the script and then printed in one go before the program exits. ok( $x ); ok( $y ); You can identify only a specific part of the input file for testing using the 'C<-- start -->' and 'C<-- stop -->' markers. Anything before the first 'C<-- start -->' is ignored, along with anything after the next 'C<-- stop -->' marker. -- test -- this is test 1 (not performed) -- expect -- this is test 1 (not performed) -- start -- -- test -- this is test 2 -- expect -- this is test 2 -- stop -- ... =head2 ntests() Subroutine used to specify how many tests you're expecting to run. =head2 ok($test) Generates an "C<ok $n>" or "C<not ok $n>" message if C<$test> is true or false. =head2 not_ok($test) The logical inverse of L<ok()>. Prints an "C<ok $n>" message is C<$test> is I<false> and vice-versa. =head2 callsign() For historical reasons and general utility, the module also defines a C<callsign()> subroutine which returns a hash mapping the letters C<a> to C<z> to their phonetic alphabet equivalent (e.g. radio callsigns). This is used by many of the test scripts as a known source of variable values. test_expect(\*DATA, $config, callsign()); =head2 banner() This subroutine prints a simple banner including any text passed as parameters. The C<$DEBUG> variable must be set for it to generate any output. banner('Testing something-or-other'); example output: #------------------------------------------------------------ # Testing something-or-other (27 tests completed) #------------------------------------------------------------ =head1 PACKAGE VARIABLES =head2 $DEBUG The $DEBUG package variable can be set to enable debugging mode. =head2 $PRESERVE The $PRESERVE package variable can be set to stop the test_expect() from converting newlines in the output and expected output into the literal strings '\n'. =head1 HISTORY This module started its butt-ugly life as the C<t/texpect.pl> script. It was cleaned up to became the C<Template::Test> module some time around version 0.29. It underwent further cosmetic surgery for version 2.00 but still retains some remarkable rear-end resemblances. Since then the C<Test::More> and related modules have appeared on CPAN making this module mostly, but not entirely, redundant. =head1 BUGS / KNOWN "FEATURES" Imports all methods by default. This is generally a Bad Thing, but this module is only used in test scripts (i.e. at build time) so a) we don't really care and b) it saves typing. The line splitter may be a bit dumb, especially if it sees lines like C<-- this --> that aren't supposed to be special markers. So don't do that. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/FAQ.pod 0000444 00000021170 15125513451 0010022 0 ustar 00 #============================================================= -*-perl-*- # # Template::FAQ # # DESCRIPTION # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. #======================================================================== =head1 NAME Template::FAQ - Frequently Asked Questions about the Template Toolkit =head1 Template Toolkit Language =head2 Why doesn't [% a = b IF c %] work as expected? There's a limitation in the TT2 parser which means that the following code doesn't work as you might expect: [% a = b IF c %] The parser interprets it as an attempt to set C<a> to the result of C<b IF c>, like this: [% a = (b IF c) %] If you want to set C<a = b> only if C<c> is true, then do this instead: [% SET a = b IF c %] The explicit C<SET> keyword gives the parser the clue it needs to do the right thing. NOTE: this will be fixed in TT3 =head2 If I'm using TT to write out a TT template, is there a good way to escape [% and %]? You can do something like this: [% stag = "[\%" etag = "%\]" %] and then: [% stag; 'hello'; etag %] Or you can use the C<TAGS> directive, like so: [% TAGS [- -] %] [- INCLUDE foo -] # is a directive [% INCLUDE foo %] # not a directive =head2 How do I iterate over a hash? This is covered in the L<Template::Manual::VMethods> section of the manual. A list of all the keys that are in the hash can be obtained with the C<keys> virtual method. You can then iterate over that list and by looking up each key in turn get the value. [% FOREACH key = product.keys %] [% key %] => [% product.$key %] [% END %] =head1 Plugins =head2 How do I get the Table plugin to order data across rather than down? Order the data into rows: Steve Karen Jeff Brooklyn Nantucket Fairfax NY MA VA [% USE table(data, rows=3) %] Then ask for each column [% FOREACH column = table.cols %] And then print each item in the column going across the output rows [% FOREACH item = column %] <td>[% item %]</td> [% END %] =head2 Accessing Cookies Jeff Boes E<lt>jboes@nexcerpt.comE<gt> asks: Does anyone have a quick-n-dirty approach to accessing cookies from templates? Jonas Liljegren answers: [% USE CGI %] <p>The value is [% CGI.cookie('cookie_name') | html %] You will need to have L<Template::Plugin::CGI> installed. =head1 Extending the Template Toolkit =head2 Can I serve templates from a database? Short answer: yes, Chris Nandor has done this for Slash. You need to subclass L<Template::Provider>. See the mailing list archives for further info. =head2 Can I fetch templates via http? To do the job properly, you should subclass L<Template::Provider> to C<Template::Provider::HTTP> and use a C<PREFIX_MAP> option to bind the C<http> template prefix to that particular provider (you may want to go digging around in the F<Changes> file around version 2.01 for more info on C<PREFIX_MAP> - it may not be properly documented anywhere else...yet!). e.g. use Template::Provider::HTTP; my $file = Template::Provider( INCLUDE_PATH => [...] ); my $http = Template::Provider::HTTP->new(...); my $tt2 = Template->new({ LOAD_TEMPLATES => [ $file, $http ], PREFIX_MAP => { file => '0', # file:foo.html http => '1', # http:foo.html default => '0', # foo.html => file:foo.html } }); Now a template specified as: [% INCLUDE foo %] will be served by the 'file' provider (the default). Otherwise you can explicitly add a prefix: [% INCLUDE file:foo.html %] [% INCLUDE http:foo.html %] [% INCLUDE http://www.xyz.com/tt2/header.tt2 %] This same principal can be used to create a DBI template provider. e.g. [% INCLUDE dbi:foo.html %] Alas, we don't yet have a DBI provider as part of the Template Toolkit. There has been some talk on the mailing list about efforts to develop DBI and/or HTTP providers but as yet no-one has stepped forward to take up the challenge... In the mean time, Craig Barrat's post from the mailing list has some useful pointers on how to achieve this using existing modules. See L<http://tt2.org/pipermail/templates/2001-May/000954.html> =head1 Miscellaneous =head2 How can I find out the name of the main template being processed? The C<template> variable contains a reference to the Template::Document object for the main template you're processing (i.e. the one provided as the first argument to the Template process() method). The C<name> method returns its name. [% template.name %] # e.g. index.html =head2 How can I find out the name of the current template being processed? The C<template> variable always references the I<main> template being processed. So even if you call [% INCLUDE header %], and that calls [% INCLUDE menu %], the C<template> variable will be unchanged. index.html: [% template.name %] # index.html [% INCLUDE header %] header: [% template.name %] # index.html [% INCLUDE menu %] menu: [% template.name %] # index.html In contrast, the C<component> variable always references the I<current> template being processed. index.html [% component.name %] # index.html [% INCLUDE header %] header: [% component.name %] # header [% INCLUDE menu %] menu: [% component.name %] # menu =head2 How do I print the modification time of the template or component? The C<template> and C<component> variables reference the main template and the current template being processed (see previous questions). The C<modtime> method returns the modification time of the corresponding template file as a number of seconds since the Unix epoch (00:00:00 GMT 1st January 1970). This number doesn't mean much to anyone (except perhaps serious Unix geeks) so you'll probably want to use the Date plugin to format it for human consumption. [% USE Date %] [% template.name %] last modified [% Date.format(template.modtime) %] =head2 How can I configure variables on a per-request basis? One easy way to achieve this is to define a single C<PRE_PROCESS> template which loads in other configuration files based on variables defined or other conditions. For example, my setup usually looks something like this: PRE_PROCESS => 'config/main' config/main: [% DEFAULT style = 'text' section = template.section or 'home'; PROCESS config/site + config/urls + config/macros + "config/style/$style" + "config/section/$section" + ... %] This allows me to set a single 'style' variable to control which config file gets pre-processed to set my various style options (colours, img paths, etc). For example: config/style/basic: [% style = { name = style # save existing 'style' var as 'style.name' # define various other style variables.... col = { back => '#ffffff' text => '#000000' # ...etc... } logo = { # ...etc... } # ...etc... } %] Each source template can declare which section it's in via a META directive: [% META title = 'General Information' section = 'info' %] ... This controls which section configuration file gets loaded to set various other variables for defining the section title, menu, etc. config/section/info: [% section = { name = section # save 'section' var as 'section.name' title = 'Information' menu = [ ... ] # ...etc... } %] This illustrates the basic principal but you can extend it to perform pretty much any kind of per-document initialisation that you require. =head2 Why do I get rubbish for my utf-8 templates? First of all, make sure that your template files define a Byte Order Mark L<http://en.wikipedia.org/wiki/Byte_Order_Mark> If you for some reason don't want to add BOM to your templates, you can force Template to use a particular encoding (e.g. C<utf8>) for your templates with the C<ENCODING> option. my $template = Template->new({ ENCODING => 'utf8' }); =head1 Questions About This FAQ =head2 Why is this FAQ so short? Because we don't have anyone maintaining it. =head2 Can I help? Yes please :-) =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Base.pm 0000444 00000016550 15125513451 0010125 0 ustar 00 #============================================================= -*-perl-*- # # Template::Base # # DESCRIPTION # Base class module implementing common functionality for various other # Template Toolkit modules. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== package Template::Base; use strict; use warnings; use Template::Constants; our $VERSION = '3.100'; #------------------------------------------------------------------------ # new(\%params) # # General purpose constructor method which expects a hash reference of # configuration parameters, or a list of name => value pairs which are # folded into a hash. Blesses a hash into an object and calls its # _init() method, passing the parameter hash reference. Returns a new # object derived from Template::Base, or undef on error. #------------------------------------------------------------------------ sub new { my $class = shift; my ($argnames, @args, $arg, $cfg); # $class->error(''); # always clear package $ERROR var? { no strict 'refs'; no warnings 'once'; $argnames = \@{"$class\::BASEARGS"} || [ ]; } # shift off all mandatory args, returning error if undefined or null foreach $arg (@$argnames) { return $class->error("no $arg specified") unless ($cfg = shift); push(@args, $cfg); } # fold all remaining args into a hash, or use provided hash ref $cfg = defined $_[0] && ref($_[0]) eq 'HASH' ? shift : { @_ }; my $self = bless { (map { ($_ => shift @args) } @$argnames), _ERROR => '', DEBUG => 0, }, $class; return $self->_init($cfg) ? $self : $class->error($self->error); } #------------------------------------------------------------------------ # error() # error($msg, ...) # # May be called as a class or object method to set or retrieve the # package variable $ERROR (class method) or internal member # $self->{ _ERROR } (object method). The presence of parameters indicates # that the error value should be set. Undef is then returned. In the # absence of parameters, the current error value is returned. #------------------------------------------------------------------------ sub error { my $self = shift; my $errvar; { no strict qw( refs ); $errvar = ref $self ? \$self->{ _ERROR } : \${"$self\::ERROR"}; } if (@_) { $$errvar = ref($_[0]) ? shift : join('', @_); return undef; } else { return $$errvar; } } #------------------------------------------------------------------------ # _init() # # Initialisation method called by the new() constructor and passing a # reference to a hash array containing any configuration items specified # as constructor arguments. Should return $self on success or undef on # error, via a call to the error() method to set the error message. #------------------------------------------------------------------------ sub _init { my ($self, $config) = @_; return $self; } sub debug { my $self = shift; my $msg = join('', @_); my ($pkg, $file, $line) = caller(); unless (substr($msg,-1) eq "\n") { $msg .= ($self->{ DEBUG } & Template::Constants::DEBUG_CALLER) ? " at $file line $line\n" : "\n"; } print STDERR "[$pkg] $msg"; } #------------------------------------------------------------------------ # module_version() # # Returns the current version number. #------------------------------------------------------------------------ sub module_version { my $self = shift; my $class = ref $self || $self; no strict 'refs'; return ${"${class}::VERSION"}; } sub DESTROY { 1 } # noop 1; __END__ =head1 NAME Template::Base - Base class module implementing common functionality =head1 SYNOPSIS package My::Module; use base qw( Template::Base ); sub _init { my ($self, $config) = @_; $self->{ doodah } = $config->{ doodah } || return $self->error("No 'doodah' specified"); return $self; } package main; my $object = My::Module->new({ doodah => 'foobar' }) || die My::Module->error(); =head1 DESCRIPTION Base class module which implements a constructor and error reporting functionality for various Template Toolkit modules. =head1 PUBLIC METHODS =head2 new(\%config) Constructor method which accepts a reference to a hash array or a list of C<name =E<gt> value> parameters which are folded into a hash. The C<_init()> method is then called, passing the configuration hash and should return true/false to indicate success or failure. A new object reference is returned, or undef on error. Any error message raised can be examined via the L<error()> class method or directly via the C<$ERROR> package variable in the derived class. my $module = My::Module->new({ ... }) || die My::Module->error(), "\n"; my $module = My::Module->new({ ... }) || die "constructor error: $My::Module::ERROR\n"; =head2 error($msg, ...) May be called as an object method to get/set the internal C<_ERROR> member or as a class method to get/set the C<$ERROR> variable in the derived class's package. my $module = My::Module->new({ ... }) || die My::Module->error(), "\n"; $module->do_something() || die $module->error(), "\n"; When called with parameters (multiple params are concatenated), this method will set the relevant variable and return undef. This is most often used within object methods to report errors to the caller. package My::Module; sub foobar { my $self = shift; # some other code... return $self->error('some kind of error...') if $some_condition; } =head2 debug($msg, ...) Generates a debugging message by concatenating all arguments passed into a string and printing it to C<STDERR>. A prefix is added to indicate the module of the caller. package My::Module; sub foobar { my $self = shift; $self->debug('called foobar()'); # some other code... } When the C<foobar()> method is called, the following message is sent to C<STDERR>: [My::Module] called foobar() Objects can set an internal C<DEBUG> value which the C<debug()> method will examine. If this value sets the relevant bits to indicate C<DEBUG_CALLER> then the file and line number of the caller will be append to the message. use Template::Constants qw( :debug ); my $module = My::Module->new({ DEBUG => DEBUG_SERVICE | DEBUG_CONTEXT | DEBUG_CALLER, }); $module->foobar(); This generates an error message such as: [My::Module] called foobar() at My/Module.pm line 6 =head2 module_version() Returns the version number for a module, as defined by the C<$VERSION> package variable. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/Template/Grammar.pm 0000444 00000301022 15125513451 0010630 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Grammar # # DESCRIPTION # Grammar file for the Template Toolkit language containing token # definitions and parser state/rules tables generated by Parse::Yapp. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # IMPORTANT NOTE # This module is constructed from the parser/Grammar.pm.skel file by # running the parser/yc script. You only need to do this if # you # have modified the grammar in the parser/Parser.yp file and need # # to-recompile it. See the README in the 'parser' directory for # more information (sub-directory of the Template distribution). # #======================================================================== package Template::Grammar; use strict; use warnings; our $VERSION = '3.100'; my (@RESERVED, %CMPOP, $LEXTABLE, $RULES, $STATES); my ($factory, $rawstart); #======================================================================== # Reserved words, comparison and binary operators #======================================================================== BEGIN { @RESERVED = qw( GET CALL SET DEFAULT INSERT INCLUDE PROCESS WRAPPER BLOCK END USE PLUGIN FILTER MACRO PERL RAWPERL TO STEP AND OR NOT DIV MOD IF UNLESS ELSE ELSIF FOR NEXT WHILE SWITCH CASE META IN TRY THROW CATCH FINAL LAST RETURN STOP CLEAR VIEW DEBUG ); # for historical reasons, != and == are converted to ne and eq to perform # stringwise comparison (mainly because it doesn't generate "non-numerical # comparison" warnings which != and == can) but the others (e.g. < > <= >=) # are not converted to their stringwise equivalents. I added 'gt' et al, # briefly for v2.04d and then took them out again in 2.04e. %CMPOP = qw( != ne == eq < < > > >= >= <= <= ); # eq eq # add these lines to the above to # lt lt # enable the eq, lt and gt operators # gt gt #======================================================================== # Lexer Token Table #======================================================================== # lookup table used by lexer is initialised with special-cases $LEXTABLE = { 'FOREACH' => 'FOR', 'BREAK' => 'LAST', '&&' => 'AND', '||' => 'OR', '!' => 'NOT', '|' => 'FILTER', '.' => 'DOT', '_' => 'CAT', '..' => 'TO', # ':' => 'MACRO', '=' => 'ASSIGN', '=>' => 'ASSIGN', # '->' => 'ARROW', ',' => 'COMMA', '\\' => 'REF', 'and' => 'AND', # explicitly specified so that qw( and or 'or' => 'OR', # not ) can always be used in lower case, 'not' => 'NOT', # regardless of ANYCASE flag 'mod' => 'MOD', 'div' => 'DIV', }; # localise the temporary variables needed to complete lexer table { my @tokens = qw< ( ) [ ] { } ${ $ + / ; : ? >; my @cmpop = keys %CMPOP; my @binop = qw( - * % ); # '+' and '/' above, in @tokens # fill lexer table, slice by slice, with reserved words and operators @$LEXTABLE{ @RESERVED, @cmpop, @binop, @tokens } = ( @RESERVED, ('CMPOP') x @cmpop, ('BINOP') x @binop, @tokens ); } } # --- END BEGIN #======================================================================== # CLASS METHODS #======================================================================== sub new { my $class = shift; bless { LEXTABLE => $LEXTABLE, STATES => $STATES, RULES => $RULES, }, $class; } # update method to set package-scoped $factory lexical sub install_factory { my ($self, $new_factory) = @_; $factory = $new_factory; } BEGIN { #======================================================================== # States #======================================================================== $STATES = [ {#State 0 ACTIONS => { 'INSERT' => 66, 'TRY' => 67, 'FILTER' => 68, 'WHILE' => 60, 'USE' => 59, "(" => 61, "{" => 62, 'PERL' => 46, "\"" => 47, "\$" => 48, 'SET' => 52, 'META' => 53, 'NEXT' => 49, 'IF' => 34, 'INCLUDE' => 43, 'RAWPERL' => 44, 'THROW' => 38, 'STOP' => 39, "[" => 41, 'NUMBER' => 23, 'VIEW' => 25, 'SWITCH' => 26, 'GET' => 27, 'LITERAL' => 31, 'BLOCK' => 32, 'FOR' => 30, 'LAST' => 14, 'DEBUG' => 16, 'REF' => 17, 'NOT' => 12, 'IDENT' => 13, 'WRAPPER' => 19, 'CLEAR' => 20, 'RETURN' => 22, "\${" => 21, ";" => -18, 'TEXT' => 7, 'CALL' => 8, 'MACRO' => 10, 'UNLESS' => 9, 'DEFAULT' => 2, 'PROCESS' => 4 }, DEFAULT => -3, GOTOS => { 'loop' => 45, 'statement' => 11, 'template' => 54, 'atomdir' => 6, 'directive' => 51, 'defblockname' => 50, 'atomexpr' => 35, 'setlist' => 37, 'rawperl' => 3, 'sterm' => 36, 'block' => 1, 'lterm' => 42, 'try' => 5, 'view' => 40, 'ident' => 24, 'condition' => 33, 'perl' => 73, 'anonblock' => 28, 'macro' => 70, 'filter' => 69, 'use' => 72, 'chunk' => 71, 'item' => 29, 'node' => 57, 'term' => 15, 'wrapper' => 56, 'capture' => 55, 'assign' => 18, 'expr' => 58, 'chunks' => 63, 'defblock' => 65, 'switch' => 64 } }, {#State 1 DEFAULT => -1 }, {#State 2 ACTIONS => { 'IDENT' => 13, 'LITERAL' => 75, "\${" => 21, "\$" => 48 }, GOTOS => { 'item' => 29, 'ident' => 74, 'assign' => 18, 'node' => 57, 'setlist' => 76 } }, {#State 3 DEFAULT => -15 }, {#State 4 ACTIONS => { "\$" => 79, "\"" => 80, 'LITERAL' => 82, 'FILENAME' => 81, 'IDENT' => 84, 'NUMBER' => 83 }, GOTOS => { 'names' => 78, 'name' => 86, 'filename' => 87, 'filepart' => 77, 'nameargs' => 85 } }, {#State 5 DEFAULT => -24 }, {#State 6 ACTIONS => { ";" => -20 }, DEFAULT => -27 }, {#State 7 DEFAULT => -6 }, {#State 8 ACTIONS => { 'REF' => 17, 'NOT' => 12, 'IDENT' => 13, "\${" => 21, "[" => 41, "{" => 62, "(" => 61, "\$" => 48, "\"" => 47, 'NUMBER' => 23, 'LITERAL' => 89 }, GOTOS => { 'ident' => 88, 'node' => 57, 'term' => 15, 'sterm' => 36, 'item' => 29, 'expr' => 90, 'lterm' => 42 } }, {#State 9 ACTIONS => { 'LITERAL' => 89, "\${" => 21, "(" => 61, "{" => 62, "[" => 41, "\"" => 47, "\$" => 48, 'REF' => 17, 'NUMBER' => 23, 'NOT' => 12, 'IDENT' => 13 }, GOTOS => { 'expr' => 91, 'ident' => 88, 'item' => 29, 'lterm' => 42, 'term' => 15, 'sterm' => 36, 'node' => 57 } }, {#State 10 ACTIONS => { 'IDENT' => 92 } }, {#State 11 ACTIONS => { ";" => 93 } }, {#State 12 ACTIONS => { "(" => 61, "{" => 62, "[" => 41, 'LITERAL' => 89, "\${" => 21, 'NUMBER' => 23, 'IDENT' => 13, 'NOT' => 12, "\"" => 47, 'REF' => 17, "\$" => 48 }, GOTOS => { 'lterm' => 42, 'sterm' => 36, 'term' => 15, 'node' => 57, 'expr' => 94, 'ident' => 88, 'item' => 29 } }, {#State 13 DEFAULT => -130 }, {#State 14 DEFAULT => -39 }, {#State 15 DEFAULT => -146 }, {#State 16 ACTIONS => { "\$" => 79, "\"" => 80, 'LITERAL' => 82, 'FILENAME' => 81, 'IDENT' => 84, 'NUMBER' => 83 }, GOTOS => { 'names' => 78, 'filename' => 87, 'name' => 86, 'filepart' => 77, 'nameargs' => 95 } }, {#State 17 ACTIONS => { 'IDENT' => 13, "\${" => 21, "\$" => 48 }, GOTOS => { 'item' => 29, 'ident' => 96, 'node' => 57 } }, {#State 18 DEFAULT => -149 }, {#State 19 ACTIONS => { 'LITERAL' => 82, "\$" => 79, "\"" => 80, 'IDENT' => 84, 'NUMBER' => 83, 'FILENAME' => 81 }, GOTOS => { 'filename' => 87, 'name' => 86, 'names' => 78, 'nameargs' => 97, 'filepart' => 77 } }, {#State 20 DEFAULT => -38 }, {#State 21 ACTIONS => { 'NUMBER' => 23, 'IDENT' => 13, "\"" => 47, "\$" => 48, 'REF' => 17, 'LITERAL' => 89, "\${" => 21 }, GOTOS => { 'ident' => 88, 'item' => 29, 'sterm' => 98, 'node' => 57 } }, {#State 22 DEFAULT => -36 }, {#State 23 DEFAULT => -113 }, {#State 24 ACTIONS => { 'ASSIGN' => 99, 'DOT' => 100 }, DEFAULT => -109 }, {#State 25 ACTIONS => { 'FILENAME' => 81, 'IDENT' => 84, 'NUMBER' => 83, "\$" => 79, "\"" => 80, 'LITERAL' => 82 }, GOTOS => { 'name' => 86, 'filename' => 87, 'names' => 78, 'nameargs' => 101, 'filepart' => 77 } }, {#State 26 ACTIONS => { 'IDENT' => 13, 'NOT' => 12, 'REF' => 17, "{" => 62, "[" => 41, "(" => 61, "\${" => 21, 'NUMBER' => 23, "\$" => 48, "\"" => 47, 'LITERAL' => 89 }, GOTOS => { 'lterm' => 42, 'node' => 57, 'term' => 15, 'sterm' => 36, 'ident' => 88, 'expr' => 102, 'item' => 29 } }, {#State 27 ACTIONS => { 'LITERAL' => 89, "\"" => 47, "\$" => 48, 'NUMBER' => 23, "\${" => 21, "(" => 61, "{" => 62, "[" => 41, 'REF' => 17, 'NOT' => 12, 'IDENT' => 13 }, GOTOS => { 'sterm' => 36, 'term' => 15, 'node' => 57, 'lterm' => 42, 'item' => 29, 'expr' => 103, 'ident' => 88 } }, {#State 28 DEFAULT => -10 }, {#State 29 ACTIONS => { "(" => 104 }, DEFAULT => -128 }, {#State 30 ACTIONS => { 'NUMBER' => 23, 'IDENT' => 107, "\"" => 47, "\$" => 48, 'REF' => 17, "[" => 41, "{" => 62, 'LITERAL' => 89, "\${" => 21 }, GOTOS => { 'sterm' => 36, 'term' => 106, 'node' => 57, 'loopvar' => 105, 'lterm' => 42, 'item' => 29, 'ident' => 88 } }, {#State 31 ACTIONS => { 'ASSIGN' => 108 }, DEFAULT => -112 }, {#State 32 ACTIONS => { 'LITERAL' => 110, 'NUMBER' => 83, 'IDENT' => 109, 'FILENAME' => 81 }, DEFAULT => -87, GOTOS => { 'blockname' => 112, 'filepart' => 77, 'filename' => 114, 'blockargs' => 111, 'meta' => 113, 'metadata' => 115 } }, {#State 33 DEFAULT => -21 }, {#State 34 ACTIONS => { 'LITERAL' => 89, "\${" => 21, "(" => 61, "[" => 41, "{" => 62, "\"" => 47, "\$" => 48, 'REF' => 17, 'NUMBER' => 23, 'NOT' => 12, 'IDENT' => 13 }, GOTOS => { 'lterm' => 42, 'sterm' => 36, 'term' => 15, 'node' => 57, 'expr' => 116, 'ident' => 88, 'item' => 29 } }, {#State 35 ACTIONS => { 'IF' => 122, 'WRAPPER' => 117, 'FOR' => 118, 'UNLESS' => 119, 'FILTER' => 121, 'WHILE' => 120 } }, {#State 36 DEFAULT => -104 }, {#State 37 ACTIONS => { "\$" => 48, 'IDENT' => 13, 'COMMA' => 124, 'LITERAL' => 75, "\${" => 21 }, DEFAULT => -19, GOTOS => { 'node' => 57, 'assign' => 123, 'ident' => 74, 'item' => 29 } }, {#State 38 ACTIONS => { 'LITERAL' => 82, "\$" => 79, "\"" => 80, 'IDENT' => 84, 'NUMBER' => 83, 'FILENAME' => 81 }, GOTOS => { 'names' => 78, 'filename' => 87, 'name' => 86, 'filepart' => 77, 'nameargs' => 125 } }, {#State 39 DEFAULT => -37 }, {#State 40 DEFAULT => -14 }, {#State 41 ACTIONS => { "\${" => 21, 'LITERAL' => 89, "{" => 62, "[" => 41, "\$" => 48, 'REF' => 17, "\"" => 47, 'IDENT' => 13, 'NUMBER' => 23, "]" => 126 }, GOTOS => { 'term' => 127, 'sterm' => 128, 'node' => 57, 'ident' => 88, 'lterm' => 42, 'range' => 130, 'list' => 129, 'item' => 29 } }, {#State 42 DEFAULT => -103 }, {#State 43 ACTIONS => { 'FILENAME' => 81, 'IDENT' => 84, 'NUMBER' => 83, "\$" => 79, "\"" => 80, 'LITERAL' => 82 }, GOTOS => { 'nameargs' => 131, 'filepart' => 77, 'name' => 86, 'filename' => 87, 'names' => 78 } }, {#State 44 DEFAULT => -78, GOTOS => { '@5-1' => 132 } }, {#State 45 DEFAULT => -23 }, {#State 46 ACTIONS => { ";" => 133 } }, {#State 47 DEFAULT => -176, GOTOS => { 'quoted' => 134 } }, {#State 48 ACTIONS => { 'IDENT' => 135 } }, {#State 49 DEFAULT => -40 }, {#State 50 ACTIONS => { 'IDENT' => 136 }, DEFAULT => -87, GOTOS => { 'metadata' => 115, 'blockargs' => 137, 'meta' => 113 } }, {#State 51 DEFAULT => -8 }, {#State 52 ACTIONS => { 'LITERAL' => 75, "\${" => 21, "\$" => 48, 'IDENT' => 13 }, GOTOS => { 'node' => 57, 'setlist' => 138, 'item' => 29, 'assign' => 18, 'ident' => 74 } }, {#State 53 ACTIONS => { 'IDENT' => 136 }, GOTOS => { 'meta' => 113, 'metadata' => 139 } }, {#State 54 ACTIONS => { '' => 140 } }, {#State 55 DEFAULT => -11 }, {#State 56 DEFAULT => -42 }, {#State 57 DEFAULT => -127 }, {#State 58 ACTIONS => { 'CAT' => 147, 'AND' => 149, 'CMPOP' => 148, "+" => 150, 'MOD' => 141, 'BINOP' => 145, "/" => 144, ";" => -16, "?" => 142, 'OR' => 143, 'DIV' => 146 }, DEFAULT => -26 }, {#State 59 ACTIONS => { "\$" => 151, "\"" => 152, "\${" => 21, 'LITERAL' => 155, 'FILENAME' => 81, 'IDENT' => 157, 'NUMBER' => 83 }, GOTOS => { 'item' => 156, 'filepart' => 77, 'names' => 78, 'nameargs' => 158, 'lvalue' => 154, 'lnameargs' => 153, 'name' => 86, 'filename' => 87 } }, {#State 60 ACTIONS => { "(" => 61, "[" => 41, "{" => 62, 'LITERAL' => 89, "\${" => 21, 'NUMBER' => 23, 'NOT' => 12, 'IDENT' => 13, "\"" => 47, 'REF' => 17, "\$" => 48 }, GOTOS => { 'item' => 29, 'ident' => 88, 'expr' => 159, 'node' => 57, 'term' => 15, 'sterm' => 36, 'lterm' => 42 } }, {#State 61 ACTIONS => { "\"" => 47, "\$" => 48, 'REF' => 17, 'NUMBER' => 23, 'NOT' => 12, 'IDENT' => 13, 'LITERAL' => 31, "\${" => 21, "(" => 61, "[" => 41, "{" => 62 }, GOTOS => { 'item' => 29, 'assign' => 161, 'expr' => 160, 'lterm' => 42, 'ident' => 162, 'node' => 57, 'sterm' => 36, 'term' => 15 } }, {#State 62 ACTIONS => { "\$" => 48, 'LITERAL' => 163, "\${" => 21, 'IDENT' => 13 }, DEFAULT => -119, GOTOS => { 'item' => 165, 'params' => 167, 'param' => 164, 'hash' => 166 } }, {#State 63 ACTIONS => { "\"" => 47, "\$" => 48, 'PERL' => 46, 'META' => 53, 'SET' => 52, 'NEXT' => 49, 'IF' => 34, 'INCLUDE' => 43, 'RAWPERL' => 44, "[" => 41, 'THROW' => 38, 'STOP' => 39, 'INSERT' => 66, 'TRY' => 67, 'FILTER' => 68, "(" => 61, "{" => 62, 'WHILE' => 60, 'USE' => 59, ";" => -18, 'CALL' => 8, 'TEXT' => 7, 'UNLESS' => 9, 'MACRO' => 10, 'DEFAULT' => 2, 'PROCESS' => 4, 'GET' => 27, 'NUMBER' => 23, 'VIEW' => 25, 'SWITCH' => 26, 'LITERAL' => 31, 'BLOCK' => 32, 'FOR' => 30, 'REF' => 17, 'DEBUG' => 16, 'LAST' => 14, 'NOT' => 12, 'IDENT' => 13, 'WRAPPER' => 19, "\${" => 21, 'RETURN' => 22, 'CLEAR' => 20 }, DEFAULT => -2, GOTOS => { 'term' => 15, 'node' => 57, 'wrapper' => 56, 'capture' => 55, 'expr' => 58, 'assign' => 18, 'switch' => 64, 'defblock' => 65, 'ident' => 24, 'condition' => 33, 'perl' => 73, 'filter' => 69, 'anonblock' => 28, 'macro' => 70, 'item' => 29, 'chunk' => 168, 'use' => 72, 'atomexpr' => 35, 'sterm' => 36, 'rawperl' => 3, 'setlist' => 37, 'lterm' => 42, 'view' => 40, 'try' => 5, 'loop' => 45, 'statement' => 11, 'atomdir' => 6, 'defblockname' => 50, 'directive' => 51 } }, {#State 64 DEFAULT => -22 }, {#State 65 DEFAULT => -9 }, {#State 66 ACTIONS => { 'FILENAME' => 81, 'NUMBER' => 83, 'IDENT' => 84, "\"" => 80, "\$" => 79, 'LITERAL' => 82 }, GOTOS => { 'nameargs' => 169, 'filepart' => 77, 'filename' => 87, 'name' => 86, 'names' => 78 } }, {#State 67 ACTIONS => { ";" => 170 } }, {#State 68 ACTIONS => { "\$" => 151, "\"" => 152, "\${" => 21, 'LITERAL' => 155, 'FILENAME' => 81, 'IDENT' => 157, 'NUMBER' => 83 }, GOTOS => { 'filename' => 87, 'name' => 86, 'lnameargs' => 171, 'lvalue' => 154, 'nameargs' => 158, 'names' => 78, 'filepart' => 77, 'item' => 156 } }, {#State 69 DEFAULT => -43 }, {#State 70 DEFAULT => -12 }, {#State 71 DEFAULT => -5 }, {#State 72 DEFAULT => -13 }, {#State 73 DEFAULT => -25 }, {#State 74 ACTIONS => { 'ASSIGN' => 172, 'DOT' => 100 } }, {#State 75 ACTIONS => { 'ASSIGN' => 108 } }, {#State 76 ACTIONS => { "\$" => 48, 'COMMA' => 124, 'LITERAL' => 75, 'IDENT' => 13, "\${" => 21 }, DEFAULT => -31, GOTOS => { 'node' => 57, 'ident' => 74, 'assign' => 123, 'item' => 29 } }, {#State 77 DEFAULT => -171 }, {#State 78 ACTIONS => { "(" => 173, "+" => 175 }, DEFAULT => -156, GOTOS => { 'args' => 174 } }, {#State 79 ACTIONS => { 'IDENT' => 13, "\${" => 21, "\$" => 48 }, GOTOS => { 'node' => 57, 'ident' => 176, 'item' => 29 } }, {#State 80 DEFAULT => -176, GOTOS => { 'quoted' => 177 } }, {#State 81 DEFAULT => -172 }, {#State 82 DEFAULT => -169 }, {#State 83 DEFAULT => -174 }, {#State 84 DEFAULT => -173 }, {#State 85 DEFAULT => -34 }, {#State 86 DEFAULT => -166 }, {#State 87 ACTIONS => { 'DOT' => 178 }, DEFAULT => -168 }, {#State 88 ACTIONS => { 'DOT' => 100 }, DEFAULT => -109 }, {#State 89 DEFAULT => -112 }, {#State 90 ACTIONS => { 'MOD' => 141, 'BINOP' => 145, "/" => 144, "?" => 142, 'OR' => 143, 'DIV' => 146, 'CAT' => 147, 'AND' => 149, 'CMPOP' => 148, "+" => 150 }, DEFAULT => -29 }, {#State 91 ACTIONS => { "+" => 150, 'CMPOP' => 148, 'AND' => 149, 'CAT' => 147, 'DIV' => 146, 'OR' => 143, "?" => 142, ";" => 179, "/" => 144, 'BINOP' => 145, 'MOD' => 141 } }, {#State 92 ACTIONS => { 'NEXT' => 49, 'CALL' => 8, 'UNLESS' => 9, 'SET' => 52, 'PERL' => 46, "\"" => 47, "\$" => 48, 'THROW' => 38, 'STOP' => 39, 'PROCESS' => 4, "[" => 41, 'INCLUDE' => 43, 'IF' => 34, 'DEFAULT' => 2, 'FILTER' => 68, 'FOR' => 30, 'BLOCK' => 180, 'LITERAL' => 31, 'NUMBER' => 23, 'INSERT' => 66, 'TRY' => 67, 'SWITCH' => 26, 'GET' => 27, 'WHILE' => 60, "(" => 183, "{" => 62, 'WRAPPER' => 19, 'RETURN' => 22, 'CLEAR' => 20, "\${" => 21, 'IDENT' => 13, 'NOT' => 12, 'LAST' => 14, 'DEBUG' => 16, 'REF' => 17 }, GOTOS => { 'atomexpr' => 35, 'node' => 57, 'setlist' => 37, 'term' => 15, 'sterm' => 36, 'wrapper' => 56, 'lterm' => 42, 'assign' => 18, 'expr' => 182, 'try' => 5, 'switch' => 64, 'ident' => 162, 'mdir' => 181, 'loop' => 45, 'perl' => 73, 'condition' => 33, 'atomdir' => 6, 'filter' => 69, 'directive' => 184, 'item' => 29 } }, {#State 93 DEFAULT => -7 }, {#State 94 ACTIONS => { 'MOD' => 141, "/" => 144, 'BINOP' => 145, 'DIV' => 146, 'CMPOP' => 148, 'CAT' => 147, "+" => 150 }, DEFAULT => -142 }, {#State 95 DEFAULT => -41 }, {#State 96 ACTIONS => { 'DOT' => 100 }, DEFAULT => -110 }, {#State 97 ACTIONS => { ";" => 185 } }, {#State 98 ACTIONS => { "}" => 186 } }, {#State 99 ACTIONS => { 'INSERT' => 66, 'NUMBER' => 23, 'TRY' => 67, 'SWITCH' => 26, 'GET' => 27, 'FILTER' => 68, 'FOR' => 30, 'BLOCK' => 180, 'LITERAL' => 31, 'NOT' => 12, 'IDENT' => 13, 'LAST' => 14, 'REF' => 17, 'DEBUG' => 16, 'WHILE' => 60, "(" => 61, "{" => 62, 'WRAPPER' => 19, 'CLEAR' => 20, "\${" => 21, 'RETURN' => 22, 'PERL' => 46, "\"" => 47, "\$" => 48, 'NEXT' => 49, 'CALL' => 8, 'UNLESS' => 9, 'SET' => 52, 'IF' => 34, 'DEFAULT' => 2, 'THROW' => 38, 'STOP' => 39, 'PROCESS' => 4, "[" => 41, 'INCLUDE' => 43 }, GOTOS => { 'ident' => 162, 'mdir' => 188, 'loop' => 45, 'condition' => 33, 'perl' => 73, 'filter' => 69, 'atomdir' => 6, 'item' => 29, 'directive' => 184, 'atomexpr' => 35, 'sterm' => 36, 'term' => 15, 'setlist' => 37, 'node' => 57, 'wrapper' => 56, 'lterm' => 42, 'expr' => 187, 'assign' => 18, 'try' => 5, 'switch' => 64 } }, {#State 100 ACTIONS => { "\${" => 21, "\$" => 48, 'NUMBER' => 190, 'IDENT' => 13 }, GOTOS => { 'node' => 189, 'item' => 29 } }, {#State 101 ACTIONS => { ";" => 191 } }, {#State 102 ACTIONS => { "/" => 144, 'CMPOP' => 148, 'BINOP' => 145, 'AND' => 149, 'MOD' => 141, 'CAT' => 147, 'DIV' => 146, 'OR' => 143, "+" => 150, "?" => 142, ";" => 192 } }, {#State 103 ACTIONS => { 'BINOP' => 145, "/" => 144, 'MOD' => 141, 'OR' => 143, 'DIV' => 146, "?" => 142, 'AND' => 149, 'CMPOP' => 148, 'CAT' => 147, "+" => 150 }, DEFAULT => -28 }, {#State 104 DEFAULT => -156, GOTOS => { 'args' => 193 } }, {#State 105 ACTIONS => { ";" => 194 } }, {#State 106 DEFAULT => -156, GOTOS => { 'args' => 195 } }, {#State 107 ACTIONS => { 'IN' => 197, 'ASSIGN' => 196 }, DEFAULT => -130 }, {#State 108 ACTIONS => { 'IDENT' => 13, 'NOT' => 12, 'NUMBER' => 23, "\$" => 48, 'REF' => 17, "\"" => 47, "[" => 41, "{" => 62, "(" => 61, "\${" => 21, 'LITERAL' => 89 }, GOTOS => { 'item' => 29, 'ident' => 88, 'expr' => 198, 'node' => 57, 'sterm' => 36, 'term' => 15, 'lterm' => 42 } }, {#State 109 ACTIONS => { 'ASSIGN' => 199 }, DEFAULT => -173 }, {#State 110 DEFAULT => -85 }, {#State 111 ACTIONS => { ";" => 200 } }, {#State 112 DEFAULT => -83 }, {#State 113 DEFAULT => -99 }, {#State 114 ACTIONS => { 'DOT' => 178 }, DEFAULT => -84 }, {#State 115 ACTIONS => { 'IDENT' => 136, 'COMMA' => 201 }, DEFAULT => -86, GOTOS => { 'meta' => 202 } }, {#State 116 ACTIONS => { 'BINOP' => 145, "/" => 144, 'MOD' => 141, 'OR' => 143, 'DIV' => 146, ";" => 203, "?" => 142, 'AND' => 149, 'CMPOP' => 148, 'CAT' => 147, "+" => 150 } }, {#State 117 ACTIONS => { 'FILENAME' => 81, 'IDENT' => 84, 'NUMBER' => 83, "\$" => 79, "\"" => 80, 'LITERAL' => 82 }, GOTOS => { 'filepart' => 77, 'nameargs' => 204, 'names' => 78, 'name' => 86, 'filename' => 87 } }, {#State 118 ACTIONS => { "\"" => 47, "\$" => 48, 'REF' => 17, 'NUMBER' => 23, 'IDENT' => 107, 'LITERAL' => 89, "\${" => 21, "{" => 62, "[" => 41 }, GOTOS => { 'loopvar' => 205, 'lterm' => 42, 'term' => 106, 'sterm' => 36, 'node' => 57, 'ident' => 88, 'item' => 29 } }, {#State 119 ACTIONS => { "\"" => 47, "\$" => 48, 'NUMBER' => 23, 'LITERAL' => 89, 'REF' => 17, 'NOT' => 12, 'IDENT' => 13, "\${" => 21, "(" => 61, "{" => 62, "[" => 41 }, GOTOS => { 'lterm' => 42, 'expr' => 206, 'item' => 29, 'node' => 57, 'term' => 15, 'sterm' => 36, 'ident' => 88 } }, {#State 120 ACTIONS => { "(" => 61, "{" => 62, "[" => 41, 'LITERAL' => 89, "\${" => 21, 'NUMBER' => 23, 'NOT' => 12, 'IDENT' => 13, "\"" => 47, "\$" => 48, 'REF' => 17 }, GOTOS => { 'item' => 29, 'expr' => 207, 'ident' => 88, 'sterm' => 36, 'term' => 15, 'node' => 57, 'lterm' => 42 } }, {#State 121 ACTIONS => { "\"" => 152, "\$" => 151, 'LITERAL' => 155, "\${" => 21, 'FILENAME' => 81, 'NUMBER' => 83, 'IDENT' => 157 }, GOTOS => { 'lvalue' => 154, 'lnameargs' => 208, 'nameargs' => 158, 'filename' => 87, 'name' => 86, 'filepart' => 77, 'item' => 156, 'names' => 78 } }, {#State 122 ACTIONS => { "[" => 41, "{" => 62, "(" => 61, "\${" => 21, 'LITERAL' => 89, 'IDENT' => 13, 'NOT' => 12, 'NUMBER' => 23, 'REF' => 17, "\$" => 48, "\"" => 47 }, GOTOS => { 'lterm' => 42, 'item' => 29, 'expr' => 209, 'term' => 15, 'sterm' => 36, 'node' => 57, 'ident' => 88 } }, {#State 123 DEFAULT => -147 }, {#State 124 DEFAULT => -148 }, {#State 125 DEFAULT => -35 }, {#State 126 DEFAULT => -107 }, {#State 127 DEFAULT => -116 }, {#State 128 ACTIONS => { 'TO' => 210 }, DEFAULT => -104 }, {#State 129 ACTIONS => { 'COMMA' => 211, 'LITERAL' => 89, "\"" => 47, "\$" => 48, 'NUMBER' => 23, "\${" => 21, "{" => 62, "[" => 41, 'REF' => 17, "]" => 212, 'IDENT' => 13 }, GOTOS => { 'ident' => 88, 'item' => 29, 'lterm' => 42, 'sterm' => 36, 'term' => 213, 'node' => 57 } }, {#State 130 ACTIONS => { "]" => 214 } }, {#State 131 DEFAULT => -33 }, {#State 132 ACTIONS => { ";" => 215 } }, {#State 133 DEFAULT => -76, GOTOS => { '@4-2' => 216 } }, {#State 134 ACTIONS => { "\$" => 48, "\"" => 221, ";" => 220, "\${" => 21, 'TEXT' => 219, 'IDENT' => 13 }, GOTOS => { 'node' => 57, 'quotable' => 218, 'item' => 29, 'ident' => 217 } }, {#State 135 DEFAULT => -132 }, {#State 136 ACTIONS => { 'ASSIGN' => 199 } }, {#State 137 ACTIONS => { ";" => 222 } }, {#State 138 ACTIONS => { 'LITERAL' => 75, 'COMMA' => 124, "\$" => 48, "\${" => 21, 'IDENT' => 13 }, DEFAULT => -30, GOTOS => { 'node' => 57, 'ident' => 74, 'assign' => 123, 'item' => 29 } }, {#State 139 ACTIONS => { 'IDENT' => 136, 'COMMA' => 201 }, DEFAULT => -17, GOTOS => { 'meta' => 202 } }, {#State 140 DEFAULT => 0 }, {#State 141 ACTIONS => { 'NOT' => 12, 'IDENT' => 13, 'NUMBER' => 23, "\$" => 48, 'REF' => 17, "\"" => 47, "[" => 41, "{" => 62, "(" => 61, "\${" => 21, 'LITERAL' => 89 }, GOTOS => { 'item' => 29, 'expr' => 223, 'ident' => 88, 'sterm' => 36, 'term' => 15, 'node' => 57, 'lterm' => 42 } }, {#State 142 ACTIONS => { 'LITERAL' => 89, 'NUMBER' => 23, "\$" => 48, "\"" => 47, "[" => 41, "{" => 62, "(" => 61, "\${" => 21, 'IDENT' => 13, 'NOT' => 12, 'REF' => 17 }, GOTOS => { 'node' => 57, 'term' => 15, 'sterm' => 36, 'ident' => 88, 'lterm' => 42, 'item' => 29, 'expr' => 224 } }, {#State 143 ACTIONS => { 'NOT' => 12, 'IDENT' => 13, 'REF' => 17, "(" => 61, "[" => 41, "{" => 62, "\${" => 21, 'NUMBER' => 23, "\"" => 47, "\$" => 48, 'LITERAL' => 89 }, GOTOS => { 'lterm' => 42, 'expr' => 225, 'item' => 29, 'node' => 57, 'term' => 15, 'sterm' => 36, 'ident' => 88 } }, {#State 144 ACTIONS => { "\$" => 48, 'REF' => 17, "\"" => 47, 'IDENT' => 13, 'NOT' => 12, 'NUMBER' => 23, "\${" => 21, 'LITERAL' => 89, "[" => 41, "{" => 62, "(" => 61 }, GOTOS => { 'ident' => 88, 'node' => 57, 'term' => 15, 'sterm' => 36, 'expr' => 226, 'item' => 29, 'lterm' => 42 } }, {#State 145 ACTIONS => { "\$" => 48, "\"" => 47, 'NUMBER' => 23, 'LITERAL' => 89, 'REF' => 17, 'IDENT' => 13, 'NOT' => 12, "\${" => 21, "[" => 41, "{" => 62, "(" => 61 }, GOTOS => { 'item' => 29, 'ident' => 88, 'expr' => 227, 'node' => 57, 'term' => 15, 'sterm' => 36, 'lterm' => 42 } }, {#State 146 ACTIONS => { 'LITERAL' => 89, 'NUMBER' => 23, "\$" => 48, "\"" => 47, "{" => 62, "[" => 41, "(" => 61, "\${" => 21, 'NOT' => 12, 'IDENT' => 13, 'REF' => 17 }, GOTOS => { 'node' => 57, 'sterm' => 36, 'term' => 15, 'lterm' => 42, 'item' => 29, 'ident' => 88, 'expr' => 228 } }, {#State 147 ACTIONS => { 'REF' => 17, "\$" => 48, "\"" => 47, 'IDENT' => 13, 'NOT' => 12, 'NUMBER' => 23, "\${" => 21, 'LITERAL' => 89, "[" => 41, "{" => 62, "(" => 61 }, GOTOS => { 'expr' => 229, 'item' => 29, 'lterm' => 42, 'ident' => 88, 'node' => 57, 'sterm' => 36, 'term' => 15 } }, {#State 148 ACTIONS => { 'NUMBER' => 23, "\$" => 48, "\"" => 47, 'LITERAL' => 89, 'NOT' => 12, 'IDENT' => 13, 'REF' => 17, "{" => 62, "[" => 41, "(" => 61, "\${" => 21 }, GOTOS => { 'ident' => 88, 'node' => 57, 'term' => 15, 'sterm' => 36, 'expr' => 230, 'item' => 29, 'lterm' => 42 } }, {#State 149 ACTIONS => { 'LITERAL' => 89, 'NUMBER' => 23, "\"" => 47, "\$" => 48, "(" => 61, "{" => 62, "[" => 41, "\${" => 21, 'IDENT' => 13, 'NOT' => 12, 'REF' => 17 }, GOTOS => { 'lterm' => 42, 'item' => 29, 'expr' => 231, 'node' => 57, 'sterm' => 36, 'term' => 15, 'ident' => 88 } }, {#State 150 ACTIONS => { "\${" => 21, "(" => 61, "{" => 62, "[" => 41, 'REF' => 17, 'IDENT' => 13, 'NOT' => 12, 'LITERAL' => 89, "\"" => 47, "\$" => 48, 'NUMBER' => 23 }, GOTOS => { 'lterm' => 42, 'sterm' => 36, 'term' => 15, 'node' => 57, 'expr' => 232, 'ident' => 88, 'item' => 29 } }, {#State 151 ACTIONS => { "\${" => 21, "\$" => 48, 'IDENT' => 233 }, GOTOS => { 'ident' => 176, 'item' => 29, 'node' => 57 } }, {#State 152 DEFAULT => -176, GOTOS => { 'quoted' => 234 } }, {#State 153 DEFAULT => -73 }, {#State 154 ACTIONS => { 'ASSIGN' => 235 } }, {#State 155 ACTIONS => { 'ASSIGN' => -161 }, DEFAULT => -169 }, {#State 156 DEFAULT => -159 }, {#State 157 ACTIONS => { 'ASSIGN' => -130 }, DEFAULT => -173 }, {#State 158 DEFAULT => -158 }, {#State 159 ACTIONS => { ";" => 236, "?" => 142, "+" => 150, 'OR' => 143, 'DIV' => 146, 'CAT' => 147, 'MOD' => 141, 'AND' => 149, 'BINOP' => 145, 'CMPOP' => 148, "/" => 144 } }, {#State 160 ACTIONS => { 'OR' => 143, 'DIV' => 146, ")" => 237, "?" => 142, 'BINOP' => 145, "/" => 144, 'MOD' => 141, "+" => 150, 'AND' => 149, 'CMPOP' => 148, 'CAT' => 147 } }, {#State 161 ACTIONS => { ")" => 238 } }, {#State 162 ACTIONS => { 'DOT' => 100, 'ASSIGN' => 172 }, DEFAULT => -109 }, {#State 163 ACTIONS => { 'ASSIGN' => 239 } }, {#State 164 DEFAULT => -122 }, {#State 165 ACTIONS => { 'ASSIGN' => 240 } }, {#State 166 ACTIONS => { "}" => 241 } }, {#State 167 ACTIONS => { "\${" => 21, 'LITERAL' => 163, 'COMMA' => 243, 'IDENT' => 13, "\$" => 48 }, DEFAULT => -118, GOTOS => { 'param' => 242, 'item' => 165 } }, {#State 168 DEFAULT => -4 }, {#State 169 DEFAULT => -32 }, {#State 170 ACTIONS => { "\"" => 47, "\$" => 48, 'PERL' => 46, 'META' => 53, 'SET' => 52, 'NEXT' => 49, 'IF' => 34, 'INCLUDE' => 43, 'RAWPERL' => 44, "[" => 41, 'THROW' => 38, 'STOP' => 39, 'INSERT' => 66, 'TRY' => 67, 'FILTER' => 68, "(" => 61, "{" => 62, 'WHILE' => 60, 'USE' => 59, ";" => -18, 'TEXT' => 7, 'CALL' => 8, 'UNLESS' => 9, 'MACRO' => 10, 'DEFAULT' => 2, 'PROCESS' => 4, 'GET' => 27, 'NUMBER' => 23, 'SWITCH' => 26, 'VIEW' => 25, 'BLOCK' => 32, 'LITERAL' => 31, 'FOR' => 30, 'DEBUG' => 16, 'REF' => 17, 'LAST' => 14, 'NOT' => 12, 'IDENT' => 13, 'WRAPPER' => 19, 'CLEAR' => 20, 'RETURN' => 22, "\${" => 21 }, DEFAULT => -3, GOTOS => { 'expr' => 58, 'assign' => 18, 'switch' => 64, 'defblock' => 65, 'chunks' => 63, 'capture' => 55, 'wrapper' => 56, 'term' => 15, 'node' => 57, 'filter' => 69, 'macro' => 70, 'anonblock' => 28, 'item' => 29, 'chunk' => 71, 'use' => 72, 'perl' => 73, 'condition' => 33, 'ident' => 24, 'view' => 40, 'try' => 5, 'lterm' => 42, 'block' => 244, 'atomexpr' => 35, 'sterm' => 36, 'rawperl' => 3, 'setlist' => 37, 'atomdir' => 6, 'defblockname' => 50, 'directive' => 51, 'statement' => 11, 'loop' => 45 } }, {#State 171 ACTIONS => { ";" => 245 } }, {#State 172 ACTIONS => { "\"" => 47, 'REF' => 17, "\$" => 48, 'NUMBER' => 23, 'NOT' => 12, 'IDENT' => 13, 'LITERAL' => 89, "\${" => 21, "(" => 61, "{" => 62, "[" => 41 }, GOTOS => { 'term' => 15, 'sterm' => 36, 'node' => 57, 'lterm' => 42, 'item' => 29, 'expr' => 246, 'ident' => 88 } }, {#State 173 DEFAULT => -156, GOTOS => { 'args' => 247 } }, {#State 174 ACTIONS => { "\${" => 21, "[" => 41, "{" => 62, "(" => 61, 'REF' => 17, 'IDENT' => 13, 'NOT' => 12, 'COMMA' => 253, 'LITERAL' => 249, "\$" => 48, "\"" => 47, 'NUMBER' => 23 }, DEFAULT => -163, GOTOS => { 'node' => 57, 'term' => 15, 'sterm' => 36, 'ident' => 252, 'lterm' => 42, 'item' => 250, 'param' => 251, 'expr' => 248 } }, {#State 175 ACTIONS => { 'NUMBER' => 83, 'IDENT' => 84, 'FILENAME' => 81, 'LITERAL' => 82, "\"" => 80 }, GOTOS => { 'filepart' => 77, 'name' => 254, 'filename' => 87 } }, {#State 176 ACTIONS => { 'DOT' => 100 }, DEFAULT => -156, GOTOS => { 'args' => 255 } }, {#State 177 ACTIONS => { "\$" => 48, ";" => 220, "\"" => 256, 'IDENT' => 13, "\${" => 21, 'TEXT' => 219 }, GOTOS => { 'quotable' => 218, 'node' => 57, 'ident' => 217, 'item' => 29 } }, {#State 178 ACTIONS => { 'FILENAME' => 81, 'IDENT' => 84, 'NUMBER' => 83 }, GOTOS => { 'filepart' => 257 } }, {#State 179 ACTIONS => { 'NEXT' => 49, 'SET' => 52, 'META' => 53, 'PERL' => 46, "\"" => 47, "\$" => 48, 'THROW' => 38, 'STOP' => 39, "[" => 41, 'INCLUDE' => 43, 'RAWPERL' => 44, 'IF' => 34, 'FILTER' => 68, 'INSERT' => 66, 'TRY' => 67, 'WHILE' => 60, 'USE' => 59, "(" => 61, "{" => 62, 'CALL' => 8, 'TEXT' => 7, 'UNLESS' => 9, 'MACRO' => 10, ";" => -18, 'PROCESS' => 4, 'DEFAULT' => 2, 'FOR' => 30, 'LITERAL' => 31, 'BLOCK' => 32, 'NUMBER' => 23, 'VIEW' => 25, 'SWITCH' => 26, 'GET' => 27, 'WRAPPER' => 19, "\${" => 21, 'RETURN' => 22, 'CLEAR' => 20, 'NOT' => 12, 'IDENT' => 13, 'LAST' => 14, 'DEBUG' => 16, 'REF' => 17 }, DEFAULT => -3, GOTOS => { 'setlist' => 37, 'rawperl' => 3, 'sterm' => 36, 'atomexpr' => 35, 'block' => 258, 'lterm' => 42, 'try' => 5, 'view' => 40, 'loop' => 45, 'statement' => 11, 'directive' => 51, 'defblockname' => 50, 'atomdir' => 6, 'node' => 57, 'term' => 15, 'capture' => 55, 'wrapper' => 56, 'chunks' => 63, 'switch' => 64, 'defblock' => 65, 'assign' => 18, 'expr' => 58, 'ident' => 24, 'perl' => 73, 'condition' => 33, 'use' => 72, 'item' => 29, 'chunk' => 71, 'macro' => 70, 'anonblock' => 28, 'filter' => 69 } }, {#State 180 ACTIONS => { ";" => 259 } }, {#State 181 DEFAULT => -91 }, {#State 182 ACTIONS => { "+" => 150, 'CAT' => 147, 'AND' => 149, 'CMPOP' => 148, "?" => 142, 'OR' => 143, 'DIV' => 146, 'MOD' => 141, 'BINOP' => 145, "/" => 144 }, DEFAULT => -26 }, {#State 183 ACTIONS => { 'REF' => 17, "\$" => 48, "\"" => 47, 'NOT' => 12, 'IDENT' => 260, 'NUMBER' => 23, "\${" => 21, 'LITERAL' => 31, "[" => 41, "{" => 62, "(" => 61 }, GOTOS => { 'lterm' => 42, 'item' => 29, 'expr' => 160, 'assign' => 161, 'sterm' => 36, 'term' => 15, 'node' => 57, 'margs' => 261, 'ident' => 162 } }, {#State 184 DEFAULT => -92 }, {#State 185 ACTIONS => { 'PROCESS' => 4, 'DEFAULT' => 2, 'MACRO' => 10, 'UNLESS' => 9, 'TEXT' => 7, 'CALL' => 8, ";" => -18, "\${" => 21, 'CLEAR' => 20, 'RETURN' => 22, 'WRAPPER' => 19, 'REF' => 17, 'DEBUG' => 16, 'LAST' => 14, 'NOT' => 12, 'IDENT' => 13, 'LITERAL' => 31, 'BLOCK' => 32, 'FOR' => 30, 'GET' => 27, 'VIEW' => 25, 'SWITCH' => 26, 'NUMBER' => 23, 'INCLUDE' => 43, 'RAWPERL' => 44, "[" => 41, 'STOP' => 39, 'THROW' => 38, 'IF' => 34, 'META' => 53, 'SET' => 52, 'NEXT' => 49, "\$" => 48, "\"" => 47, 'PERL' => 46, "{" => 62, "(" => 61, 'WHILE' => 60, 'USE' => 59, 'FILTER' => 68, 'TRY' => 67, 'INSERT' => 66 }, DEFAULT => -3, GOTOS => { 'expr' => 58, 'assign' => 18, 'switch' => 64, 'defblock' => 65, 'chunks' => 63, 'capture' => 55, 'wrapper' => 56, 'term' => 15, 'node' => 57, 'filter' => 69, 'macro' => 70, 'anonblock' => 28, 'item' => 29, 'chunk' => 71, 'use' => 72, 'perl' => 73, 'condition' => 33, 'ident' => 24, 'view' => 40, 'try' => 5, 'lterm' => 42, 'block' => 262, 'atomexpr' => 35, 'sterm' => 36, 'rawperl' => 3, 'setlist' => 37, 'atomdir' => 6, 'defblockname' => 50, 'directive' => 51, 'statement' => 11, 'loop' => 45 } }, {#State 186 DEFAULT => -131 }, {#State 187 ACTIONS => { 'BINOP' => 145, "/" => 144, 'COMMA' => -150, 'MOD' => 141, 'LITERAL' => -150, 'OR' => 143, 'DIV' => 146, "\$" => -150, ";" => -150, "?" => 142, 'AND' => 149, 'CMPOP' => 148, "\${" => -150, 'CAT' => 147, 'IDENT' => -150, "+" => 150 }, DEFAULT => -26 }, {#State 188 DEFAULT => -89 }, {#State 189 DEFAULT => -125 }, {#State 190 DEFAULT => -126 }, {#State 191 DEFAULT => -74, GOTOS => { '@3-3' => 263 } }, {#State 192 ACTIONS => { ";" => -18, 'UNLESS' => 9, 'MACRO' => 10, 'CALL' => 8, 'TEXT' => 7, 'DEFAULT' => 2, 'PROCESS' => 4, 'GET' => 27, 'VIEW' => 25, 'SWITCH' => 26, 'NUMBER' => 23, 'BLOCK' => 32, 'LITERAL' => 31, 'FOR' => 30, 'DEBUG' => 16, 'REF' => 17, 'LAST' => 14, 'NOT' => 12, 'IDENT' => 13, 'CLEAR' => 20, "\${" => 21, 'RETURN' => 22, 'WRAPPER' => 19, "\$" => 48, "\"" => 47, 'PERL' => 46, 'META' => 53, 'SET' => 52, 'NEXT' => 49, 'IF' => 34, 'INCLUDE' => 43, 'RAWPERL' => 44, "[" => 41, 'STOP' => 39, 'THROW' => 38, 'TRY' => 67, 'INSERT' => 66, 'FILTER' => 68, "{" => 62, "(" => 61, 'USE' => 59, 'WHILE' => 60 }, DEFAULT => -3, GOTOS => { 'wrapper' => 56, 'capture' => 55, 'node' => 57, 'term' => 15, 'assign' => 18, 'expr' => 58, 'switch' => 64, 'chunks' => 63, 'defblock' => 65, 'ident' => 24, 'anonblock' => 28, 'macro' => 70, 'filter' => 69, 'use' => 72, 'chunk' => 71, 'item' => 29, 'condition' => 33, 'perl' => 73, 'block' => 264, 'atomexpr' => 35, 'setlist' => 37, 'rawperl' => 3, 'sterm' => 36, 'try' => 5, 'view' => 40, 'lterm' => 42, 'loop' => 45, 'atomdir' => 6, 'directive' => 51, 'defblockname' => 50, 'statement' => 11 } }, {#State 193 ACTIONS => { "\${" => 21, "(" => 61, "[" => 41, "{" => 62, 'REF' => 17, 'NOT' => 12, 'IDENT' => 13, 'LITERAL' => 249, 'COMMA' => 253, "\"" => 47, ")" => 265, "\$" => 48, 'NUMBER' => 23 }, GOTOS => { 'lterm' => 42, 'sterm' => 36, 'term' => 15, 'node' => 57, 'expr' => 248, 'param' => 251, 'ident' => 252, 'item' => 250 } }, {#State 194 DEFAULT => -56, GOTOS => { '@1-3' => 266 } }, {#State 195 ACTIONS => { 'REF' => 17, 'IDENT' => 13, 'NOT' => 12, "\${" => 21, "[" => 41, "{" => 62, "(" => 61, "\$" => 48, "\"" => 47, 'NUMBER' => 23, 'LITERAL' => 249, 'COMMA' => 253 }, DEFAULT => -64, GOTOS => { 'expr' => 248, 'ident' => 252, 'param' => 251, 'item' => 250, 'lterm' => 42, 'term' => 15, 'sterm' => 36, 'node' => 57 } }, {#State 196 ACTIONS => { "{" => 62, "[" => 41, "\${" => 21, 'LITERAL' => 89, 'IDENT' => 13, 'NUMBER' => 23, 'REF' => 17, "\$" => 48, "\"" => 47 }, GOTOS => { 'sterm' => 36, 'term' => 267, 'node' => 57, 'ident' => 88, 'lterm' => 42, 'item' => 29 } }, {#State 197 ACTIONS => { "[" => 41, "{" => 62, 'LITERAL' => 89, "\${" => 21, 'NUMBER' => 23, 'IDENT' => 13, "\"" => 47, 'REF' => 17, "\$" => 48 }, GOTOS => { 'ident' => 88, 'node' => 57, 'term' => 268, 'sterm' => 36, 'item' => 29, 'lterm' => 42 } }, {#State 198 ACTIONS => { 'OR' => 143, "?" => 142, 'MOD' => 141, 'AND' => 149, 'DIV' => 146, "/" => 144, 'BINOP' => 145, "+" => 150, 'CMPOP' => 148, 'CAT' => 147 }, DEFAULT => -151 }, {#State 199 ACTIONS => { "\"" => 269, 'LITERAL' => 270, 'NUMBER' => 271 } }, {#State 200 ACTIONS => { 'FILTER' => 68, 'TRY' => 67, 'INSERT' => 66, "{" => 62, "(" => 61, 'USE' => 59, 'WHILE' => 60, 'NEXT' => 49, 'META' => 53, 'SET' => 52, "\$" => 48, "\"" => 47, 'PERL' => 46, "[" => 41, 'STOP' => 39, 'THROW' => 38, 'RAWPERL' => 44, 'INCLUDE' => 43, 'IF' => 34, 'FOR' => 30, 'LITERAL' => 31, 'BLOCK' => 32, 'GET' => 27, 'SWITCH' => 26, 'VIEW' => 25, 'NUMBER' => 23, 'CLEAR' => 20, "\${" => 21, 'RETURN' => 22, 'WRAPPER' => 19, 'IDENT' => 13, 'NOT' => 12, 'REF' => 17, 'DEBUG' => 16, 'LAST' => 14, 'UNLESS' => 9, 'MACRO' => 10, 'TEXT' => 7, 'CALL' => 8, ";" => -18, 'PROCESS' => 4, 'DEFAULT' => 2 }, DEFAULT => -3, GOTOS => { 'perl' => 73, 'condition' => 33, 'use' => 72, 'chunk' => 71, 'item' => 29, 'anonblock' => 28, 'macro' => 70, 'filter' => 69, 'ident' => 24, 'defblock' => 65, 'chunks' => 63, 'switch' => 64, 'assign' => 18, 'expr' => 58, 'node' => 57, 'term' => 15, 'wrapper' => 56, 'capture' => 55, 'statement' => 11, 'directive' => 51, 'defblockname' => 50, 'atomdir' => 6, 'loop' => 45, 'lterm' => 42, 'try' => 5, 'view' => 40, 'rawperl' => 3, 'setlist' => 37, 'sterm' => 36, 'atomexpr' => 35, 'block' => 272 } }, {#State 201 DEFAULT => -98 }, {#State 202 DEFAULT => -97 }, {#State 203 ACTIONS => { "{" => 62, "(" => 61, 'WHILE' => 60, 'USE' => 59, 'FILTER' => 68, 'TRY' => 67, 'INSERT' => 66, 'RAWPERL' => 44, 'INCLUDE' => 43, "[" => 41, 'STOP' => 39, 'THROW' => 38, 'IF' => 34, 'META' => 53, 'SET' => 52, 'NEXT' => 49, "\$" => 48, "\"" => 47, 'PERL' => 46, 'CLEAR' => 20, "\${" => 21, 'RETURN' => 22, 'WRAPPER' => 19, 'REF' => 17, 'DEBUG' => 16, 'LAST' => 14, 'NOT' => 12, 'IDENT' => 13, 'LITERAL' => 31, 'BLOCK' => 32, 'FOR' => 30, 'GET' => 27, 'VIEW' => 25, 'SWITCH' => 26, 'NUMBER' => 23, 'PROCESS' => 4, 'DEFAULT' => 2, 'UNLESS' => 9, 'MACRO' => 10, 'TEXT' => 7, 'CALL' => 8, ";" => -18 }, DEFAULT => -3, GOTOS => { 'loop' => 45, 'atomdir' => 6, 'defblockname' => 50, 'directive' => 51, 'statement' => 11, 'block' => 273, 'atomexpr' => 35, 'sterm' => 36, 'rawperl' => 3, 'setlist' => 37, 'view' => 40, 'try' => 5, 'lterm' => 42, 'ident' => 24, 'filter' => 69, 'macro' => 70, 'anonblock' => 28, 'item' => 29, 'chunk' => 71, 'use' => 72, 'condition' => 33, 'perl' => 73, 'capture' => 55, 'wrapper' => 56, 'term' => 15, 'node' => 57, 'expr' => 58, 'assign' => 18, 'switch' => 64, 'chunks' => 63, 'defblock' => 65 } }, {#State 204 DEFAULT => -66 }, {#State 205 DEFAULT => -58 }, {#State 206 ACTIONS => { 'OR' => 143, 'DIV' => 146, "+" => 150, "?" => 142, 'BINOP' => 145, 'AND' => 149, "/" => 144, 'CMPOP' => 148, 'CAT' => 147, 'MOD' => 141 }, DEFAULT => -47 }, {#State 207 ACTIONS => { "?" => 142, "+" => 150, 'DIV' => 146, 'OR' => 143, 'CAT' => 147, 'MOD' => 141, 'CMPOP' => 148, "/" => 144, 'AND' => 149, 'BINOP' => 145 }, DEFAULT => -61 }, {#State 208 DEFAULT => -81 }, {#State 209 ACTIONS => { "?" => 142, "+" => 150, 'OR' => 143, 'DIV' => 146, 'MOD' => 141, 'CAT' => 147, 'AND' => 149, 'BINOP' => 145, 'CMPOP' => 148, "/" => 144 }, DEFAULT => -45 }, {#State 210 ACTIONS => { "\"" => 47, 'REF' => 17, "\$" => 48, 'NUMBER' => 23, 'IDENT' => 13, 'LITERAL' => 89, "\${" => 21 }, GOTOS => { 'ident' => 88, 'item' => 29, 'sterm' => 274, 'node' => 57 } }, {#State 211 DEFAULT => -115 }, {#State 212 DEFAULT => -105 }, {#State 213 DEFAULT => -114 }, {#State 214 DEFAULT => -106 }, {#State 215 ACTIONS => { 'TEXT' => 275 } }, {#State 216 ACTIONS => { 'NUMBER' => 23, 'VIEW' => 25, 'SWITCH' => 26, 'GET' => 27, 'LITERAL' => 31, 'BLOCK' => 32, 'FOR' => 30, 'LAST' => 14, 'REF' => 17, 'DEBUG' => 16, 'NOT' => 12, 'IDENT' => 13, 'WRAPPER' => 19, 'RETURN' => 22, "\${" => 21, 'CLEAR' => 20, ";" => -18, 'CALL' => 8, 'TEXT' => 7, 'MACRO' => 10, 'UNLESS' => 9, 'DEFAULT' => 2, 'PROCESS' => 4, 'INSERT' => 66, 'TRY' => 67, 'FILTER' => 68, 'USE' => 59, 'WHILE' => 60, "(" => 61, "{" => 62, 'PERL' => 46, "\"" => 47, "\$" => 48, 'SET' => 52, 'META' => 53, 'NEXT' => 49, 'IF' => 34, 'RAWPERL' => 44, 'INCLUDE' => 43, 'THROW' => 38, 'STOP' => 39, "[" => 41 }, DEFAULT => -3, GOTOS => { 'condition' => 33, 'perl' => 73, 'anonblock' => 28, 'macro' => 70, 'filter' => 69, 'use' => 72, 'chunk' => 71, 'item' => 29, 'ident' => 24, 'assign' => 18, 'expr' => 58, 'switch' => 64, 'defblock' => 65, 'chunks' => 63, 'node' => 57, 'term' => 15, 'capture' => 55, 'wrapper' => 56, 'statement' => 11, 'atomdir' => 6, 'directive' => 51, 'defblockname' => 50, 'loop' => 45, 'lterm' => 42, 'try' => 5, 'view' => 40, 'atomexpr' => 35, 'setlist' => 37, 'rawperl' => 3, 'sterm' => 36, 'block' => 276 } }, {#State 217 ACTIONS => { 'DOT' => 100 }, DEFAULT => -177 }, {#State 218 DEFAULT => -175 }, {#State 219 DEFAULT => -178 }, {#State 220 DEFAULT => -179 }, {#State 221 DEFAULT => -111 }, {#State 222 ACTIONS => { 'FILTER' => 68, 'TRY' => 67, 'INSERT' => 66, "{" => 62, "(" => 61, 'WHILE' => 60, 'USE' => 59, 'META' => 53, 'SET' => 52, 'NEXT' => 49, "\$" => 48, "\"" => 47, 'PERL' => 46, 'RAWPERL' => 44, 'INCLUDE' => 43, "[" => 41, 'STOP' => 39, 'THROW' => 38, 'IF' => 34, 'BLOCK' => 32, 'LITERAL' => 31, 'FOR' => 30, 'GET' => 27, 'SWITCH' => 26, 'VIEW' => 25, 'NUMBER' => 23, 'CLEAR' => 20, 'RETURN' => 22, "\${" => 21, 'WRAPPER' => 19, 'DEBUG' => 16, 'REF' => 17, 'LAST' => 14, 'IDENT' => 13, 'NOT' => 12, 'MACRO' => 10, 'UNLESS' => 9, 'TEXT' => 7, 'CALL' => 8, ";" => -18, 'PROCESS' => 4, 'DEFAULT' => 2 }, DEFAULT => -3, GOTOS => { 'try' => 5, 'view' => 40, 'lterm' => 42, 'block' => 1, 'atomexpr' => 35, 'rawperl' => 3, 'setlist' => 37, 'sterm' => 36, 'atomdir' => 6, 'directive' => 51, 'defblockname' => 50, 'statement' => 11, 'template' => 277, 'loop' => 45, 'assign' => 18, 'expr' => 58, 'switch' => 64, 'defblock' => 65, 'chunks' => 63, 'wrapper' => 56, 'capture' => 55, 'node' => 57, 'term' => 15, 'anonblock' => 28, 'macro' => 70, 'filter' => 69, 'use' => 72, 'item' => 29, 'chunk' => 71, 'perl' => 73, 'condition' => 33, 'ident' => 24 } }, {#State 223 DEFAULT => -137 }, {#State 224 ACTIONS => { 'OR' => 143, ":" => 278, 'DIV' => 146, "+" => 150, "?" => 142, 'BINOP' => 145, 'AND' => 149, "/" => 144, 'CMPOP' => 148, 'MOD' => 141, 'CAT' => 147 } }, {#State 225 ACTIONS => { 'DIV' => 146, "/" => 144, 'BINOP' => 145, "+" => 150, 'CAT' => 147, 'CMPOP' => 148, 'MOD' => 141 }, DEFAULT => -141 }, {#State 226 ACTIONS => { 'DIV' => 146, 'MOD' => 141 }, DEFAULT => -134 }, {#State 227 ACTIONS => { 'MOD' => 141, "/" => 144, 'DIV' => 146, "+" => 150 }, DEFAULT => -133 }, {#State 228 ACTIONS => { 'MOD' => 141 }, DEFAULT => -136 }, {#State 229 ACTIONS => { 'MOD' => 141, "+" => 150, 'CMPOP' => 148, 'DIV' => 146, 'BINOP' => 145, "/" => 144 }, DEFAULT => -139 }, {#State 230 ACTIONS => { 'MOD' => 141, "+" => 150, 'DIV' => 146, 'BINOP' => 145, "/" => 144 }, DEFAULT => -138 }, {#State 231 ACTIONS => { "+" => 150, 'CMPOP' => 148, 'CAT' => 147, 'DIV' => 146, "/" => 144, 'BINOP' => 145, 'MOD' => 141 }, DEFAULT => -140 }, {#State 232 ACTIONS => { 'MOD' => 141, "/" => 144, 'DIV' => 146 }, DEFAULT => -135 }, {#State 233 ACTIONS => { 'ASSIGN' => -132 }, DEFAULT => -130 }, {#State 234 ACTIONS => { "\$" => 48, "\"" => 279, ";" => 220, 'IDENT' => 13, "\${" => 21, 'TEXT' => 219 }, GOTOS => { 'node' => 57, 'quotable' => 218, 'item' => 29, 'ident' => 217 } }, {#State 235 ACTIONS => { "\"" => 80, "\$" => 79, 'LITERAL' => 82, 'FILENAME' => 81, 'NUMBER' => 83, 'IDENT' => 84 }, GOTOS => { 'filepart' => 77, 'nameargs' => 280, 'names' => 78, 'filename' => 87, 'name' => 86 } }, {#State 236 DEFAULT => -59, GOTOS => { '@2-3' => 281 } }, {#State 237 DEFAULT => -145 }, {#State 238 DEFAULT => -144 }, {#State 239 ACTIONS => { "(" => 61, "[" => 41, "{" => 62, 'LITERAL' => 89, "\${" => 21, 'NUMBER' => 23, 'NOT' => 12, 'IDENT' => 13, "\"" => 47, "\$" => 48, 'REF' => 17 }, GOTOS => { 'ident' => 88, 'node' => 57, 'sterm' => 36, 'term' => 15, 'item' => 29, 'expr' => 282, 'lterm' => 42 } }, {#State 240 ACTIONS => { 'IDENT' => 13, 'NOT' => 12, 'NUMBER' => 23, "\$" => 48, 'REF' => 17, "\"" => 47, "{" => 62, "[" => 41, "(" => 61, "\${" => 21, 'LITERAL' => 89 }, GOTOS => { 'term' => 15, 'sterm' => 36, 'node' => 57, 'lterm' => 42, 'item' => 29, 'expr' => 283, 'ident' => 88 } }, {#State 241 DEFAULT => -108 }, {#State 242 DEFAULT => -120 }, {#State 243 DEFAULT => -121 }, {#State 244 ACTIONS => { 'FINAL' => 284, 'CATCH' => 285 }, DEFAULT => -72, GOTOS => { 'final' => 286 } }, {#State 245 ACTIONS => { 'GET' => 27, 'VIEW' => 25, 'SWITCH' => 26, 'NUMBER' => 23, 'FOR' => 30, 'BLOCK' => 32, 'LITERAL' => 31, 'IDENT' => 13, 'NOT' => 12, 'DEBUG' => 16, 'REF' => 17, 'LAST' => 14, 'CLEAR' => 20, 'RETURN' => 22, "\${" => 21, 'WRAPPER' => 19, ";" => -18, 'UNLESS' => 9, 'MACRO' => 10, 'CALL' => 8, 'TEXT' => 7, 'DEFAULT' => 2, 'PROCESS' => 4, 'TRY' => 67, 'INSERT' => 66, 'FILTER' => 68, "{" => 62, "(" => 61, 'WHILE' => 60, 'USE' => 59, "\$" => 48, "\"" => 47, 'PERL' => 46, 'NEXT' => 49, 'META' => 53, 'SET' => 52, 'IF' => 34, "[" => 41, 'STOP' => 39, 'THROW' => 38, 'RAWPERL' => 44, 'INCLUDE' => 43 }, DEFAULT => -3, GOTOS => { 'lterm' => 42, 'view' => 40, 'try' => 5, 'sterm' => 36, 'setlist' => 37, 'rawperl' => 3, 'atomexpr' => 35, 'block' => 287, 'statement' => 11, 'defblockname' => 50, 'directive' => 51, 'atomdir' => 6, 'loop' => 45, 'switch' => 64, 'defblock' => 65, 'chunks' => 63, 'expr' => 58, 'assign' => 18, 'term' => 15, 'node' => 57, 'capture' => 55, 'wrapper' => 56, 'condition' => 33, 'perl' => 73, 'chunk' => 71, 'item' => 29, 'use' => 72, 'filter' => 69, 'macro' => 70, 'anonblock' => 28, 'ident' => 24 } }, {#State 246 ACTIONS => { 'AND' => 149, 'OR' => 143, "?" => 142, 'MOD' => 141, "+" => 150, 'CMPOP' => 148, 'CAT' => 147, 'DIV' => 146, 'BINOP' => 145, "/" => 144 }, DEFAULT => -150 }, {#State 247 ACTIONS => { 'IDENT' => 13, 'NOT' => 12, 'REF' => 17, "(" => 61, "{" => 62, "[" => 41, "\${" => 21, 'NUMBER' => 23, "\"" => 47, ")" => 288, "\$" => 48, 'LITERAL' => 249, 'COMMA' => 253 }, GOTOS => { 'ident' => 252, 'node' => 57, 'sterm' => 36, 'term' => 15, 'item' => 250, 'param' => 251, 'expr' => 248, 'lterm' => 42 } }, {#State 248 ACTIONS => { 'MOD' => 141, 'OR' => 143, "?" => 142, 'AND' => 149, "/" => 144, 'BINOP' => 145, 'DIV' => 146, 'CMPOP' => 148, 'CAT' => 147, "+" => 150 }, DEFAULT => -152 }, {#State 249 ACTIONS => { 'ASSIGN' => 239 }, DEFAULT => -112 }, {#State 250 ACTIONS => { 'ASSIGN' => 240, "(" => 104 }, DEFAULT => -128 }, {#State 251 DEFAULT => -153 }, {#State 252 ACTIONS => { 'DOT' => 100, 'ASSIGN' => 289 }, DEFAULT => -109 }, {#State 253 DEFAULT => -155 }, {#State 254 DEFAULT => -165 }, {#State 255 ACTIONS => { 'LITERAL' => 249, 'COMMA' => 253, "\$" => 48, "\"" => 47, 'NUMBER' => 23, "\${" => 21, "{" => 62, "[" => 41, "(" => 61, 'REF' => 17, 'NOT' => 12, 'IDENT' => 13 }, DEFAULT => -162, GOTOS => { 'lterm' => 42, 'expr' => 248, 'param' => 251, 'item' => 250, 'term' => 15, 'sterm' => 36, 'node' => 57, 'ident' => 252 } }, {#State 256 DEFAULT => -167 }, {#State 257 DEFAULT => -170 }, {#State 258 ACTIONS => { 'ELSE' => 292, 'ELSIF' => 290 }, DEFAULT => -50, GOTOS => { 'else' => 291 } }, {#State 259 ACTIONS => { "(" => 61, "{" => 62, 'WHILE' => 60, 'USE' => 59, 'FILTER' => 68, 'INSERT' => 66, 'TRY' => 67, 'INCLUDE' => 43, 'RAWPERL' => 44, "[" => 41, 'THROW' => 38, 'STOP' => 39, 'IF' => 34, 'META' => 53, 'SET' => 52, 'NEXT' => 49, "\"" => 47, "\$" => 48, 'PERL' => 46, 'WRAPPER' => 19, 'CLEAR' => 20, 'RETURN' => 22, "\${" => 21, 'REF' => 17, 'DEBUG' => 16, 'LAST' => 14, 'NOT' => 12, 'IDENT' => 13, 'BLOCK' => 32, 'LITERAL' => 31, 'FOR' => 30, 'GET' => 27, 'NUMBER' => 23, 'VIEW' => 25, 'SWITCH' => 26, 'PROCESS' => 4, 'DEFAULT' => 2, 'CALL' => 8, 'TEXT' => 7, 'MACRO' => 10, 'UNLESS' => 9, ";" => -18 }, DEFAULT => -3, GOTOS => { 'block' => 293, 'atomexpr' => 35, 'rawperl' => 3, 'setlist' => 37, 'sterm' => 36, 'try' => 5, 'view' => 40, 'lterm' => 42, 'loop' => 45, 'atomdir' => 6, 'directive' => 51, 'defblockname' => 50, 'statement' => 11, 'capture' => 55, 'wrapper' => 56, 'node' => 57, 'term' => 15, 'assign' => 18, 'expr' => 58, 'switch' => 64, 'defblock' => 65, 'chunks' => 63, 'ident' => 24, 'anonblock' => 28, 'macro' => 70, 'filter' => 69, 'use' => 72, 'chunk' => 71, 'item' => 29, 'condition' => 33, 'perl' => 73 } }, {#State 260 ACTIONS => { 'IDENT' => -96, 'COMMA' => -96, ")" => -96 }, DEFAULT => -130 }, {#State 261 ACTIONS => { 'IDENT' => 295, 'COMMA' => 294, ")" => 296 } }, {#State 262 ACTIONS => { 'END' => 297 } }, {#State 263 ACTIONS => { 'WHILE' => 60, 'USE' => 59, "{" => 62, "(" => 61, 'TRY' => 67, 'INSERT' => 66, 'FILTER' => 68, 'IF' => 34, 'INCLUDE' => 43, 'RAWPERL' => 44, 'STOP' => 39, 'THROW' => 38, "[" => 41, 'PERL' => 46, "\$" => 48, "\"" => 47, 'SET' => 52, 'META' => 53, 'NEXT' => 49, 'LAST' => 14, 'REF' => 17, 'DEBUG' => 16, 'NOT' => 12, 'IDENT' => 13, 'CLEAR' => 20, "\${" => 21, 'RETURN' => 22, 'WRAPPER' => 19, 'SWITCH' => 26, 'VIEW' => 25, 'NUMBER' => 23, 'GET' => 27, 'LITERAL' => 31, 'BLOCK' => 32, 'FOR' => 30, 'DEFAULT' => 2, 'PROCESS' => 4, ";" => -18, 'MACRO' => 10, 'UNLESS' => 9, 'CALL' => 8, 'TEXT' => 7 }, DEFAULT => -3, GOTOS => { 'try' => 5, 'view' => 40, 'lterm' => 42, 'block' => 298, 'rawperl' => 3, 'setlist' => 37, 'sterm' => 36, 'atomexpr' => 35, 'directive' => 51, 'defblockname' => 50, 'atomdir' => 6, 'statement' => 11, 'loop' => 45, 'switch' => 64, 'defblock' => 65, 'chunks' => 63, 'assign' => 18, 'expr' => 58, 'wrapper' => 56, 'capture' => 55, 'node' => 57, 'term' => 15, 'use' => 72, 'item' => 29, 'chunk' => 71, 'macro' => 70, 'anonblock' => 28, 'filter' => 69, 'condition' => 33, 'perl' => 73, 'ident' => 24 } }, {#State 264 ACTIONS => { 'CASE' => 299 }, DEFAULT => -55, GOTOS => { 'case' => 300 } }, {#State 265 DEFAULT => -129 }, {#State 266 ACTIONS => { 'FILTER' => 68, 'INSERT' => 66, 'TRY' => 67, 'USE' => 59, 'WHILE' => 60, "(" => 61, "{" => 62, 'SET' => 52, 'META' => 53, 'NEXT' => 49, 'PERL' => 46, "\"" => 47, "\$" => 48, 'INCLUDE' => 43, 'RAWPERL' => 44, 'THROW' => 38, 'STOP' => 39, "[" => 41, 'IF' => 34, 'BLOCK' => 32, 'LITERAL' => 31, 'FOR' => 30, 'NUMBER' => 23, 'SWITCH' => 26, 'VIEW' => 25, 'GET' => 27, 'WRAPPER' => 19, "\${" => 21, 'CLEAR' => 20, 'RETURN' => 22, 'LAST' => 14, 'REF' => 17, 'DEBUG' => 16, 'NOT' => 12, 'IDENT' => 13, 'TEXT' => 7, 'CALL' => 8, 'MACRO' => 10, 'UNLESS' => 9, ";" => -18, 'PROCESS' => 4, 'DEFAULT' => 2 }, DEFAULT => -3, GOTOS => { 'expr' => 58, 'assign' => 18, 'defblock' => 65, 'switch' => 64, 'chunks' => 63, 'wrapper' => 56, 'capture' => 55, 'term' => 15, 'node' => 57, 'filter' => 69, 'macro' => 70, 'anonblock' => 28, 'chunk' => 71, 'item' => 29, 'use' => 72, 'perl' => 73, 'condition' => 33, 'ident' => 24, 'view' => 40, 'try' => 5, 'lterm' => 42, 'block' => 301, 'atomexpr' => 35, 'sterm' => 36, 'setlist' => 37, 'rawperl' => 3, 'atomdir' => 6, 'defblockname' => 50, 'directive' => 51, 'statement' => 11, 'loop' => 45 } }, {#State 267 DEFAULT => -156, GOTOS => { 'args' => 302 } }, {#State 268 DEFAULT => -156, GOTOS => { 'args' => 303 } }, {#State 269 ACTIONS => { 'TEXT' => 304 } }, {#State 270 DEFAULT => -100 }, {#State 271 DEFAULT => -102 }, {#State 272 ACTIONS => { 'END' => 305 } }, {#State 273 ACTIONS => { 'ELSE' => 292, 'ELSIF' => 290 }, DEFAULT => -50, GOTOS => { 'else' => 306 } }, {#State 274 DEFAULT => -117 }, {#State 275 ACTIONS => { 'END' => 307 } }, {#State 276 ACTIONS => { 'END' => 308 } }, {#State 277 ACTIONS => { 'END' => 309 } }, {#State 278 ACTIONS => { 'NOT' => 12, 'IDENT' => 13, 'NUMBER' => 23, 'REF' => 17, "\$" => 48, "\"" => 47, "[" => 41, "{" => 62, "(" => 61, "\${" => 21, 'LITERAL' => 89 }, GOTOS => { 'item' => 29, 'expr' => 310, 'lterm' => 42, 'ident' => 88, 'node' => 57, 'term' => 15, 'sterm' => 36 } }, {#State 279 ACTIONS => { 'ASSIGN' => -160 }, DEFAULT => -167 }, {#State 280 DEFAULT => -157 }, {#State 281 ACTIONS => { 'LAST' => 14, 'REF' => 17, 'DEBUG' => 16, 'IDENT' => 13, 'NOT' => 12, 'WRAPPER' => 19, 'RETURN' => 22, 'CLEAR' => 20, "\${" => 21, 'NUMBER' => 23, 'VIEW' => 25, 'SWITCH' => 26, 'GET' => 27, 'BLOCK' => 32, 'LITERAL' => 31, 'FOR' => 30, 'DEFAULT' => 2, 'PROCESS' => 4, ";" => -18, 'CALL' => 8, 'TEXT' => 7, 'UNLESS' => 9, 'MACRO' => 10, 'WHILE' => 60, 'USE' => 59, "(" => 61, "{" => 62, 'INSERT' => 66, 'TRY' => 67, 'FILTER' => 68, 'IF' => 34, 'RAWPERL' => 44, 'INCLUDE' => 43, 'THROW' => 38, 'STOP' => 39, "[" => 41, 'PERL' => 46, "\"" => 47, "\$" => 48, 'SET' => 52, 'META' => 53, 'NEXT' => 49 }, DEFAULT => -3, GOTOS => { 'ident' => 24, 'perl' => 73, 'condition' => 33, 'filter' => 69, 'anonblock' => 28, 'macro' => 70, 'item' => 29, 'chunk' => 71, 'use' => 72, 'term' => 15, 'node' => 57, 'wrapper' => 56, 'capture' => 55, 'expr' => 58, 'assign' => 18, 'switch' => 64, 'defblock' => 65, 'chunks' => 63, 'loop' => 45, 'statement' => 11, 'atomdir' => 6, 'defblockname' => 50, 'directive' => 51, 'atomexpr' => 35, 'sterm' => 36, 'rawperl' => 3, 'setlist' => 37, 'block' => 311, 'lterm' => 42, 'view' => 40, 'try' => 5 } }, {#State 282 ACTIONS => { 'CMPOP' => 148, 'CAT' => 147, "+" => 150, "/" => 144, 'BINOP' => 145, 'DIV' => 146, 'AND' => 149, 'MOD' => 141, 'OR' => 143, "?" => 142 }, DEFAULT => -123 }, {#State 283 ACTIONS => { "/" => 144, 'BINOP' => 145, 'DIV' => 146, 'CAT' => 147, 'CMPOP' => 148, "+" => 150, 'MOD' => 141, "?" => 142, 'OR' => 143, 'AND' => 149 }, DEFAULT => -124 }, {#State 284 ACTIONS => { ";" => 312 } }, {#State 285 ACTIONS => { 'FILENAME' => 81, 'IDENT' => 84, 'NUMBER' => 83, ";" => 315, 'DEFAULT' => 313 }, GOTOS => { 'filepart' => 77, 'filename' => 314 } }, {#State 286 ACTIONS => { 'END' => 316 } }, {#State 287 ACTIONS => { 'END' => 317 } }, {#State 288 DEFAULT => -164 }, {#State 289 ACTIONS => { "\"" => 47, "\$" => 48, 'REF' => 17, 'NUMBER' => 23, 'IDENT' => 13, 'NOT' => 12, 'LITERAL' => 89, "\${" => 21, "(" => 61, "[" => 41, "{" => 62 }, GOTOS => { 'lterm' => 42, 'sterm' => 36, 'term' => 15, 'node' => 57, 'expr' => 318, 'ident' => 88, 'item' => 29 } }, {#State 290 ACTIONS => { 'LITERAL' => 89, 'NUMBER' => 23, "\$" => 48, "\"" => 47, "[" => 41, "{" => 62, "(" => 61, "\${" => 21, 'IDENT' => 13, 'NOT' => 12, 'REF' => 17 }, GOTOS => { 'ident' => 88, 'term' => 15, 'sterm' => 36, 'node' => 57, 'expr' => 319, 'item' => 29, 'lterm' => 42 } }, {#State 291 ACTIONS => { 'END' => 320 } }, {#State 292 ACTIONS => { ";" => 321 } }, {#State 293 ACTIONS => { 'END' => 322 } }, {#State 294 DEFAULT => -95 }, {#State 295 DEFAULT => -94 }, {#State 296 ACTIONS => { 'PERL' => 46, "\"" => 47, "\$" => 48, 'NEXT' => 49, 'CALL' => 8, 'UNLESS' => 9, 'SET' => 52, 'IF' => 34, 'DEFAULT' => 2, 'THROW' => 38, 'STOP' => 39, 'PROCESS' => 4, "[" => 41, 'INCLUDE' => 43, 'INSERT' => 66, 'NUMBER' => 23, 'TRY' => 67, 'SWITCH' => 26, 'GET' => 27, 'FILTER' => 68, 'FOR' => 30, 'LITERAL' => 31, 'BLOCK' => 180, 'NOT' => 12, 'IDENT' => 13, 'LAST' => 14, 'DEBUG' => 16, 'REF' => 17, 'WHILE' => 60, "(" => 61, "{" => 62, 'WRAPPER' => 19, "\${" => 21, 'CLEAR' => 20, 'RETURN' => 22 }, GOTOS => { 'node' => 57, 'setlist' => 37, 'sterm' => 36, 'term' => 15, 'atomexpr' => 35, 'wrapper' => 56, 'lterm' => 42, 'try' => 5, 'switch' => 64, 'assign' => 18, 'expr' => 182, 'loop' => 45, 'ident' => 162, 'mdir' => 323, 'perl' => 73, 'condition' => 33, 'directive' => 184, 'item' => 29, 'atomdir' => 6, 'filter' => 69 } }, {#State 297 DEFAULT => -65 }, {#State 298 ACTIONS => { 'END' => 324 } }, {#State 299 ACTIONS => { 'REF' => 17, "\$" => 48, "\"" => 47, ";" => 326, 'DEFAULT' => 327, 'IDENT' => 13, 'NUMBER' => 23, "\${" => 21, 'LITERAL' => 89, "[" => 41, "{" => 62 }, GOTOS => { 'item' => 29, 'lterm' => 42, 'ident' => 88, 'node' => 57, 'sterm' => 36, 'term' => 325 } }, {#State 300 ACTIONS => { 'END' => 328 } }, {#State 301 ACTIONS => { 'END' => 329 } }, {#State 302 ACTIONS => { 'COMMA' => 253, 'LITERAL' => 249, "\$" => 48, "\"" => 47, 'NUMBER' => 23, "\${" => 21, "{" => 62, "[" => 41, "(" => 61, 'REF' => 17, 'IDENT' => 13, 'NOT' => 12 }, DEFAULT => -62, GOTOS => { 'lterm' => 42, 'item' => 250, 'expr' => 248, 'param' => 251, 'term' => 15, 'sterm' => 36, 'node' => 57, 'ident' => 252 } }, {#State 303 ACTIONS => { "(" => 61, "{" => 62, "[" => 41, "\${" => 21, 'IDENT' => 13, 'NOT' => 12, 'REF' => 17, 'COMMA' => 253, 'LITERAL' => 249, 'NUMBER' => 23, "\"" => 47, "\$" => 48 }, DEFAULT => -63, GOTOS => { 'ident' => 252, 'node' => 57, 'sterm' => 36, 'term' => 15, 'item' => 250, 'param' => 251, 'expr' => 248, 'lterm' => 42 } }, {#State 304 ACTIONS => { "\"" => 330 } }, {#State 305 DEFAULT => -88 }, {#State 306 ACTIONS => { 'END' => 331 } }, {#State 307 DEFAULT => -79 }, {#State 308 DEFAULT => -77 }, {#State 309 DEFAULT => -82 }, {#State 310 ACTIONS => { 'CMPOP' => 148, 'CAT' => 147, "+" => 150, 'BINOP' => 145, "/" => 144, 'DIV' => 146, 'AND' => 149, 'MOD' => 141, 'OR' => 143, "?" => 142 }, DEFAULT => -143 }, {#State 311 ACTIONS => { 'END' => 332 } }, {#State 312 ACTIONS => { 'USE' => 59, 'WHILE' => 60, "(" => 61, "{" => 62, 'FILTER' => 68, 'INSERT' => 66, 'TRY' => 67, 'RAWPERL' => 44, 'INCLUDE' => 43, 'THROW' => 38, 'STOP' => 39, "[" => 41, 'IF' => 34, 'SET' => 52, 'META' => 53, 'NEXT' => 49, 'PERL' => 46, "\"" => 47, "\$" => 48, 'WRAPPER' => 19, "\${" => 21, 'CLEAR' => 20, 'RETURN' => 22, 'LAST' => 14, 'REF' => 17, 'DEBUG' => 16, 'NOT' => 12, 'IDENT' => 13, 'BLOCK' => 32, 'LITERAL' => 31, 'FOR' => 30, 'NUMBER' => 23, 'VIEW' => 25, 'SWITCH' => 26, 'GET' => 27, 'PROCESS' => 4, 'DEFAULT' => 2, 'TEXT' => 7, 'CALL' => 8, 'UNLESS' => 9, 'MACRO' => 10, ";" => -18 }, DEFAULT => -3, GOTOS => { 'atomdir' => 6, 'directive' => 51, 'defblockname' => 50, 'statement' => 11, 'loop' => 45, 'try' => 5, 'view' => 40, 'lterm' => 42, 'block' => 333, 'atomexpr' => 35, 'setlist' => 37, 'rawperl' => 3, 'sterm' => 36, 'macro' => 70, 'anonblock' => 28, 'filter' => 69, 'use' => 72, 'chunk' => 71, 'item' => 29, 'condition' => 33, 'perl' => 73, 'ident' => 24, 'assign' => 18, 'expr' => 58, 'switch' => 64, 'defblock' => 65, 'chunks' => 63, 'capture' => 55, 'wrapper' => 56, 'node' => 57, 'term' => 15 } }, {#State 313 ACTIONS => { ";" => 334 } }, {#State 314 ACTIONS => { ";" => 335, 'DOT' => 178 } }, {#State 315 ACTIONS => { 'STOP' => 39, 'THROW' => 38, "[" => 41, 'RAWPERL' => 44, 'INCLUDE' => 43, 'IF' => 34, 'NEXT' => 49, 'SET' => 52, 'META' => 53, 'PERL' => 46, "\$" => 48, "\"" => 47, 'WHILE' => 60, 'USE' => 59, "{" => 62, "(" => 61, 'FILTER' => 68, 'TRY' => 67, 'INSERT' => 66, 'PROCESS' => 4, 'DEFAULT' => 2, 'MACRO' => 10, 'UNLESS' => 9, 'CALL' => 8, 'TEXT' => 7, ";" => -18, 'CLEAR' => 20, "\${" => 21, 'RETURN' => 22, 'WRAPPER' => 19, 'IDENT' => 13, 'NOT' => 12, 'LAST' => 14, 'DEBUG' => 16, 'REF' => 17, 'FOR' => 30, 'LITERAL' => 31, 'BLOCK' => 32, 'VIEW' => 25, 'SWITCH' => 26, 'NUMBER' => 23, 'GET' => 27 }, DEFAULT => -3, GOTOS => { 'lterm' => 42, 'view' => 40, 'try' => 5, 'sterm' => 36, 'rawperl' => 3, 'setlist' => 37, 'atomexpr' => 35, 'block' => 336, 'statement' => 11, 'defblockname' => 50, 'directive' => 51, 'atomdir' => 6, 'loop' => 45, 'chunks' => 63, 'switch' => 64, 'defblock' => 65, 'expr' => 58, 'assign' => 18, 'term' => 15, 'node' => 57, 'wrapper' => 56, 'capture' => 55, 'condition' => 33, 'perl' => 73, 'chunk' => 71, 'item' => 29, 'use' => 72, 'filter' => 69, 'anonblock' => 28, 'macro' => 70, 'ident' => 24 } }, {#State 316 DEFAULT => -67 }, {#State 317 DEFAULT => -80 }, {#State 318 ACTIONS => { 'AND' => 149, 'MOD' => 141, "?" => 142, 'OR' => 143, 'CAT' => 147, 'CMPOP' => 148, "+" => 150, "/" => 144, 'BINOP' => 145, 'DIV' => 146 }, DEFAULT => -154 }, {#State 319 ACTIONS => { 'CAT' => 147, 'MOD' => 141, 'BINOP' => 145, 'AND' => 149, "/" => 144, 'CMPOP' => 148, ";" => 337, "+" => 150, "?" => 142, 'OR' => 143, 'DIV' => 146 } }, {#State 320 DEFAULT => -46 }, {#State 321 ACTIONS => { 'TRY' => 67, 'INSERT' => 66, 'FILTER' => 68, 'WHILE' => 60, 'USE' => 59, "{" => 62, "(" => 61, 'PERL' => 46, "\$" => 48, "\"" => 47, 'NEXT' => 49, 'SET' => 52, 'META' => 53, 'IF' => 34, 'STOP' => 39, 'THROW' => 38, "[" => 41, 'RAWPERL' => 44, 'INCLUDE' => 43, 'SWITCH' => 26, 'VIEW' => 25, 'NUMBER' => 23, 'GET' => 27, 'FOR' => 30, 'BLOCK' => 32, 'LITERAL' => 31, 'NOT' => 12, 'IDENT' => 13, 'LAST' => 14, 'REF' => 17, 'DEBUG' => 16, "\${" => 21, 'RETURN' => 22, 'CLEAR' => 20, 'WRAPPER' => 19, ";" => -18, 'UNLESS' => 9, 'MACRO' => 10, 'CALL' => 8, 'TEXT' => 7, 'DEFAULT' => 2, 'PROCESS' => 4 }, DEFAULT => -3, GOTOS => { 'term' => 15, 'node' => 57, 'wrapper' => 56, 'capture' => 55, 'expr' => 58, 'assign' => 18, 'switch' => 64, 'defblock' => 65, 'chunks' => 63, 'ident' => 24, 'condition' => 33, 'perl' => 73, 'filter' => 69, 'anonblock' => 28, 'macro' => 70, 'chunk' => 71, 'item' => 29, 'use' => 72, 'atomexpr' => 35, 'sterm' => 36, 'rawperl' => 3, 'setlist' => 37, 'block' => 338, 'lterm' => 42, 'view' => 40, 'try' => 5, 'loop' => 45, 'statement' => 11, 'atomdir' => 6, 'defblockname' => 50, 'directive' => 51 } }, {#State 322 DEFAULT => -93 }, {#State 323 DEFAULT => -90 }, {#State 324 DEFAULT => -75 }, {#State 325 ACTIONS => { ";" => 339 } }, {#State 326 ACTIONS => { 'FOR' => 30, 'BLOCK' => 32, 'LITERAL' => 31, 'NUMBER' => 23, 'SWITCH' => 26, 'VIEW' => 25, 'GET' => 27, 'WRAPPER' => 19, "\${" => 21, 'RETURN' => 22, 'CLEAR' => 20, 'IDENT' => 13, 'NOT' => 12, 'LAST' => 14, 'DEBUG' => 16, 'REF' => 17, 'TEXT' => 7, 'CALL' => 8, 'MACRO' => 10, 'UNLESS' => 9, ";" => -18, 'PROCESS' => 4, 'DEFAULT' => 2, 'FILTER' => 68, 'INSERT' => 66, 'TRY' => 67, 'USE' => 59, 'WHILE' => 60, "(" => 61, "{" => 62, 'NEXT' => 49, 'SET' => 52, 'META' => 53, 'PERL' => 46, "\"" => 47, "\$" => 48, 'THROW' => 38, 'STOP' => 39, "[" => 41, 'INCLUDE' => 43, 'RAWPERL' => 44, 'IF' => 34 }, DEFAULT => -3, GOTOS => { 'atomdir' => 6, 'directive' => 51, 'defblockname' => 50, 'statement' => 11, 'loop' => 45, 'try' => 5, 'view' => 40, 'lterm' => 42, 'block' => 340, 'atomexpr' => 35, 'rawperl' => 3, 'setlist' => 37, 'sterm' => 36, 'macro' => 70, 'anonblock' => 28, 'filter' => 69, 'use' => 72, 'chunk' => 71, 'item' => 29, 'condition' => 33, 'perl' => 73, 'ident' => 24, 'assign' => 18, 'expr' => 58, 'switch' => 64, 'defblock' => 65, 'chunks' => 63, 'capture' => 55, 'wrapper' => 56, 'node' => 57, 'term' => 15 } }, {#State 327 ACTIONS => { ";" => 341 } }, {#State 328 DEFAULT => -51 }, {#State 329 DEFAULT => -57 }, {#State 330 DEFAULT => -101 }, {#State 331 DEFAULT => -44 }, {#State 332 DEFAULT => -60 }, {#State 333 DEFAULT => -71 }, {#State 334 ACTIONS => { "[" => 41, 'THROW' => 38, 'STOP' => 39, 'INCLUDE' => 43, 'RAWPERL' => 44, 'IF' => 34, 'NEXT' => 49, 'META' => 53, 'SET' => 52, "\"" => 47, "\$" => 48, 'PERL' => 46, "(" => 61, "{" => 62, 'USE' => 59, 'WHILE' => 60, 'FILTER' => 68, 'INSERT' => 66, 'TRY' => 67, 'PROCESS' => 4, 'DEFAULT' => 2, 'CALL' => 8, 'TEXT' => 7, 'UNLESS' => 9, 'MACRO' => 10, ";" => -18, 'WRAPPER' => 19, 'RETURN' => 22, 'CLEAR' => 20, "\${" => 21, 'NOT' => 12, 'IDENT' => 13, 'DEBUG' => 16, 'REF' => 17, 'LAST' => 14, 'FOR' => 30, 'BLOCK' => 32, 'LITERAL' => 31, 'GET' => 27, 'NUMBER' => 23, 'VIEW' => 25, 'SWITCH' => 26 }, DEFAULT => -3, GOTOS => { 'node' => 57, 'term' => 15, 'capture' => 55, 'wrapper' => 56, 'assign' => 18, 'expr' => 58, 'defblock' => 65, 'switch' => 64, 'chunks' => 63, 'ident' => 24, 'condition' => 33, 'perl' => 73, 'anonblock' => 28, 'macro' => 70, 'filter' => 69, 'use' => 72, 'chunk' => 71, 'item' => 29, 'atomexpr' => 35, 'setlist' => 37, 'rawperl' => 3, 'sterm' => 36, 'block' => 342, 'lterm' => 42, 'try' => 5, 'view' => 40, 'loop' => 45, 'statement' => 11, 'atomdir' => 6, 'directive' => 51, 'defblockname' => 50 } }, {#State 335 ACTIONS => { 'FOR' => 30, 'BLOCK' => 32, 'LITERAL' => 31, 'VIEW' => 25, 'SWITCH' => 26, 'NUMBER' => 23, 'GET' => 27, 'CLEAR' => 20, "\${" => 21, 'RETURN' => 22, 'WRAPPER' => 19, 'NOT' => 12, 'IDENT' => 13, 'LAST' => 14, 'REF' => 17, 'DEBUG' => 16, 'UNLESS' => 9, 'MACRO' => 10, 'CALL' => 8, 'TEXT' => 7, ";" => -18, 'PROCESS' => 4, 'DEFAULT' => 2, 'FILTER' => 68, 'TRY' => 67, 'INSERT' => 66, 'USE' => 59, 'WHILE' => 60, "{" => 62, "(" => 61, 'NEXT' => 49, 'SET' => 52, 'META' => 53, 'PERL' => 46, "\$" => 48, "\"" => 47, 'STOP' => 39, 'THROW' => 38, "[" => 41, 'RAWPERL' => 44, 'INCLUDE' => 43, 'IF' => 34 }, DEFAULT => -3, GOTOS => { 'perl' => 73, 'condition' => 33, 'chunk' => 71, 'item' => 29, 'use' => 72, 'filter' => 69, 'anonblock' => 28, 'macro' => 70, 'ident' => 24, 'defblock' => 65, 'switch' => 64, 'chunks' => 63, 'expr' => 58, 'assign' => 18, 'term' => 15, 'node' => 57, 'wrapper' => 56, 'capture' => 55, 'statement' => 11, 'defblockname' => 50, 'directive' => 51, 'atomdir' => 6, 'loop' => 45, 'lterm' => 42, 'view' => 40, 'try' => 5, 'sterm' => 36, 'rawperl' => 3, 'setlist' => 37, 'atomexpr' => 35, 'block' => 343 } }, {#State 336 ACTIONS => { 'CATCH' => 285, 'FINAL' => 284 }, DEFAULT => -72, GOTOS => { 'final' => 344 } }, {#State 337 ACTIONS => { 'WRAPPER' => 19, "\${" => 21, 'RETURN' => 22, 'CLEAR' => 20, 'NOT' => 12, 'IDENT' => 13, 'LAST' => 14, 'DEBUG' => 16, 'REF' => 17, 'FOR' => 30, 'BLOCK' => 32, 'LITERAL' => 31, 'NUMBER' => 23, 'SWITCH' => 26, 'VIEW' => 25, 'GET' => 27, 'PROCESS' => 4, 'DEFAULT' => 2, 'CALL' => 8, 'TEXT' => 7, 'UNLESS' => 9, 'MACRO' => 10, ";" => -18, 'WHILE' => 60, 'USE' => 59, "(" => 61, "{" => 62, 'FILTER' => 68, 'INSERT' => 66, 'TRY' => 67, 'THROW' => 38, 'STOP' => 39, "[" => 41, 'RAWPERL' => 44, 'INCLUDE' => 43, 'IF' => 34, 'NEXT' => 49, 'SET' => 52, 'META' => 53, 'PERL' => 46, "\"" => 47, "\$" => 48 }, DEFAULT => -3, GOTOS => { 'defblock' => 65, 'switch' => 64, 'chunks' => 63, 'assign' => 18, 'expr' => 58, 'wrapper' => 56, 'capture' => 55, 'node' => 57, 'term' => 15, 'use' => 72, 'chunk' => 71, 'item' => 29, 'macro' => 70, 'anonblock' => 28, 'filter' => 69, 'perl' => 73, 'condition' => 33, 'ident' => 24, 'try' => 5, 'view' => 40, 'lterm' => 42, 'block' => 345, 'setlist' => 37, 'rawperl' => 3, 'sterm' => 36, 'atomexpr' => 35, 'directive' => 51, 'defblockname' => 50, 'atomdir' => 6, 'statement' => 11, 'loop' => 45 } }, {#State 338 DEFAULT => -49 }, {#State 339 ACTIONS => { 'META' => 53, 'SET' => 52, 'NEXT' => 49, "\$" => 48, "\"" => 47, 'PERL' => 46, 'INCLUDE' => 43, 'RAWPERL' => 44, "[" => 41, 'STOP' => 39, 'THROW' => 38, 'IF' => 34, 'FILTER' => 68, 'TRY' => 67, 'INSERT' => 66, "{" => 62, "(" => 61, 'USE' => 59, 'WHILE' => 60, 'UNLESS' => 9, 'MACRO' => 10, 'TEXT' => 7, 'CALL' => 8, ";" => -18, 'PROCESS' => 4, 'DEFAULT' => 2, 'LITERAL' => 31, 'BLOCK' => 32, 'FOR' => 30, 'GET' => 27, 'VIEW' => 25, 'SWITCH' => 26, 'NUMBER' => 23, 'RETURN' => 22, 'CLEAR' => 20, "\${" => 21, 'WRAPPER' => 19, 'DEBUG' => 16, 'REF' => 17, 'LAST' => 14, 'NOT' => 12, 'IDENT' => 13 }, DEFAULT => -3, GOTOS => { 'statement' => 11, 'directive' => 51, 'defblockname' => 50, 'atomdir' => 6, 'loop' => 45, 'lterm' => 42, 'try' => 5, 'view' => 40, 'setlist' => 37, 'rawperl' => 3, 'sterm' => 36, 'atomexpr' => 35, 'block' => 346, 'condition' => 33, 'perl' => 73, 'use' => 72, 'item' => 29, 'chunk' => 71, 'macro' => 70, 'anonblock' => 28, 'filter' => 69, 'ident' => 24, 'chunks' => 63, 'defblock' => 65, 'switch' => 64, 'assign' => 18, 'expr' => 58, 'node' => 57, 'term' => 15, 'capture' => 55, 'wrapper' => 56 } }, {#State 340 DEFAULT => -54 }, {#State 341 ACTIONS => { 'IDENT' => 13, 'NOT' => 12, 'DEBUG' => 16, 'REF' => 17, 'LAST' => 14, 'WRAPPER' => 19, 'RETURN' => 22, 'CLEAR' => 20, "\${" => 21, 'GET' => 27, 'NUMBER' => 23, 'VIEW' => 25, 'SWITCH' => 26, 'FOR' => 30, 'LITERAL' => 31, 'BLOCK' => 32, 'DEFAULT' => 2, 'PROCESS' => 4, ";" => -18, 'TEXT' => 7, 'CALL' => 8, 'UNLESS' => 9, 'MACRO' => 10, "(" => 61, "{" => 62, 'WHILE' => 60, 'USE' => 59, 'INSERT' => 66, 'TRY' => 67, 'FILTER' => 68, 'IF' => 34, "[" => 41, 'THROW' => 38, 'STOP' => 39, 'INCLUDE' => 43, 'RAWPERL' => 44, "\"" => 47, "\$" => 48, 'PERL' => 46, 'NEXT' => 49, 'META' => 53, 'SET' => 52 }, DEFAULT => -3, GOTOS => { 'chunks' => 63, 'switch' => 64, 'defblock' => 65, 'assign' => 18, 'expr' => 58, 'node' => 57, 'term' => 15, 'wrapper' => 56, 'capture' => 55, 'condition' => 33, 'perl' => 73, 'use' => 72, 'item' => 29, 'chunk' => 71, 'macro' => 70, 'anonblock' => 28, 'filter' => 69, 'ident' => 24, 'lterm' => 42, 'try' => 5, 'view' => 40, 'rawperl' => 3, 'setlist' => 37, 'sterm' => 36, 'atomexpr' => 35, 'block' => 347, 'statement' => 11, 'directive' => 51, 'defblockname' => 50, 'atomdir' => 6, 'loop' => 45 } }, {#State 342 ACTIONS => { 'CATCH' => 285, 'FINAL' => 284 }, DEFAULT => -72, GOTOS => { 'final' => 348 } }, {#State 343 ACTIONS => { 'FINAL' => 284, 'CATCH' => 285 }, DEFAULT => -72, GOTOS => { 'final' => 349 } }, {#State 344 DEFAULT => -70 }, {#State 345 ACTIONS => { 'ELSE' => 292, 'ELSIF' => 290 }, DEFAULT => -50, GOTOS => { 'else' => 350 } }, {#State 346 ACTIONS => { 'CASE' => 299 }, DEFAULT => -55, GOTOS => { 'case' => 351 } }, {#State 347 DEFAULT => -53 }, {#State 348 DEFAULT => -69 }, {#State 349 DEFAULT => -68 }, {#State 350 DEFAULT => -48 }, {#State 351 DEFAULT => -52 } ]; #======================================================================== # Rules #======================================================================== $RULES = [ [#Rule 0 '$start', 2, undef ], [#Rule 1 'template', 1, sub #line 64 "Parser.yp" { $factory->template($_[1]) } ], [#Rule 2 'block', 1, sub #line 67 "Parser.yp" { $factory->block($_[1]) } ], [#Rule 3 'block', 0, sub #line 68 "Parser.yp" { $factory->block() } ], [#Rule 4 'chunks', 2, sub #line 71 "Parser.yp" { push(@{$_[1]}, $_[2]) if defined $_[2]; $_[1] } ], [#Rule 5 'chunks', 1, sub #line 73 "Parser.yp" { defined $_[1] ? [ $_[1] ] : [ ] } ], [#Rule 6 'chunk', 1, sub #line 76 "Parser.yp" { $factory->textblock($_[1]) } ], [#Rule 7 'chunk', 2, sub #line 77 "Parser.yp" { return '' unless $_[1]; $_[0]->location() . $_[1]; } ], [#Rule 8 'statement', 1, undef ], [#Rule 9 'statement', 1, undef ], [#Rule 10 'statement', 1, undef ], [#Rule 11 'statement', 1, undef ], [#Rule 12 'statement', 1, undef ], [#Rule 13 'statement', 1, undef ], [#Rule 14 'statement', 1, undef ], [#Rule 15 'statement', 1, undef ], [#Rule 16 'statement', 1, sub #line 90 "Parser.yp" { $factory->get($_[1]) } ], [#Rule 17 'statement', 2, sub #line 91 "Parser.yp" { $_[0]->add_metadata($_[2]); } ], [#Rule 18 'statement', 0, undef ], [#Rule 19 'directive', 1, sub #line 95 "Parser.yp" { $factory->set($_[1]) } ], [#Rule 20 'directive', 1, undef ], [#Rule 21 'directive', 1, undef ], [#Rule 22 'directive', 1, undef ], [#Rule 23 'directive', 1, undef ], [#Rule 24 'directive', 1, undef ], [#Rule 25 'directive', 1, undef ], [#Rule 26 'atomexpr', 1, sub #line 109 "Parser.yp" { $factory->get($_[1]) } ], [#Rule 27 'atomexpr', 1, undef ], [#Rule 28 'atomdir', 2, sub #line 113 "Parser.yp" { $factory->get($_[2]) } ], [#Rule 29 'atomdir', 2, sub #line 114 "Parser.yp" { $factory->call($_[2]) } ], [#Rule 30 'atomdir', 2, sub #line 115 "Parser.yp" { $factory->set($_[2]) } ], [#Rule 31 'atomdir', 2, sub #line 116 "Parser.yp" { $factory->default($_[2]) } ], [#Rule 32 'atomdir', 2, sub #line 117 "Parser.yp" { $factory->insert($_[2]) } ], [#Rule 33 'atomdir', 2, sub #line 118 "Parser.yp" { $factory->include($_[2]) } ], [#Rule 34 'atomdir', 2, sub #line 119 "Parser.yp" { $factory->process($_[2]) } ], [#Rule 35 'atomdir', 2, sub #line 120 "Parser.yp" { $factory->throw($_[2]) } ], [#Rule 36 'atomdir', 1, sub #line 121 "Parser.yp" { $factory->return() } ], [#Rule 37 'atomdir', 1, sub #line 122 "Parser.yp" { $factory->stop() } ], [#Rule 38 'atomdir', 1, sub #line 123 "Parser.yp" { "\$output = '';"; } ], [#Rule 39 'atomdir', 1, sub #line 124 "Parser.yp" { $_[0]->block_label('last ', ';') } ], [#Rule 40 'atomdir', 1, sub #line 125 "Parser.yp" { $_[0]->in_block('FOR') ? $factory->next($_[0]->block_label) : $_[0]->block_label('next ', ';') } ], [#Rule 41 'atomdir', 2, sub #line 128 "Parser.yp" { if ($_[2]->[0]->[0] =~ /^'(on|off)'$/) { $_[0]->{ DEBUG_DIRS } = ($1 eq 'on'); $factory->debug($_[2]); } else { $_[0]->{ DEBUG_DIRS } ? $factory->debug($_[2]) : ''; } } ], [#Rule 42 'atomdir', 1, undef ], [#Rule 43 'atomdir', 1, undef ], [#Rule 44 'condition', 6, sub #line 141 "Parser.yp" { $factory->if(@_[2, 4, 5]) } ], [#Rule 45 'condition', 3, sub #line 142 "Parser.yp" { $factory->if(@_[3, 1]) } ], [#Rule 46 'condition', 6, sub #line 144 "Parser.yp" { $factory->if("!($_[2])", @_[4, 5]) } ], [#Rule 47 'condition', 3, sub #line 145 "Parser.yp" { $factory->if("!($_[3])", $_[1]) } ], [#Rule 48 'else', 5, sub #line 149 "Parser.yp" { unshift(@{$_[5]}, [ @_[2, 4] ]); $_[5]; } ], [#Rule 49 'else', 3, sub #line 151 "Parser.yp" { [ $_[3] ] } ], [#Rule 50 'else', 0, sub #line 152 "Parser.yp" { [ undef ] } ], [#Rule 51 'switch', 6, sub #line 156 "Parser.yp" { $factory->switch(@_[2, 5]) } ], [#Rule 52 'case', 5, sub #line 160 "Parser.yp" { unshift(@{$_[5]}, [ @_[2, 4] ]); $_[5]; } ], [#Rule 53 'case', 4, sub #line 162 "Parser.yp" { [ $_[4] ] } ], [#Rule 54 'case', 3, sub #line 163 "Parser.yp" { [ $_[3] ] } ], [#Rule 55 'case', 0, sub #line 164 "Parser.yp" { [ undef ] } ], [#Rule 56 '@1-3', 0, sub #line 167 "Parser.yp" { $_[0]->enter_block('FOR') } ], [#Rule 57 'loop', 6, sub #line 168 "Parser.yp" { $factory->foreach(@{$_[2]}, $_[5], $_[0]->leave_block) } ], [#Rule 58 'loop', 3, sub #line 169 "Parser.yp" { $factory->foreach(@{$_[3]}, $_[1]) } ], [#Rule 59 '@2-3', 0, sub #line 170 "Parser.yp" { $_[0]->enter_block('WHILE') } ], [#Rule 60 'loop', 6, sub #line 171 "Parser.yp" { $factory->while(@_[2, 5], $_[0]->leave_block) } ], [#Rule 61 'loop', 3, sub #line 172 "Parser.yp" { $factory->while(@_[3, 1]) } ], [#Rule 62 'loopvar', 4, sub #line 175 "Parser.yp" { [ @_[1, 3, 4] ] } ], [#Rule 63 'loopvar', 4, sub #line 176 "Parser.yp" { [ @_[1, 3, 4] ] } ], [#Rule 64 'loopvar', 2, sub #line 177 "Parser.yp" { [ 0, @_[1, 2] ] } ], [#Rule 65 'wrapper', 5, sub #line 181 "Parser.yp" { $factory->wrapper(@_[2, 4]) } ], [#Rule 66 'wrapper', 3, sub #line 183 "Parser.yp" { $factory->wrapper(@_[3, 1]) } ], [#Rule 67 'try', 5, sub #line 187 "Parser.yp" { $factory->try(@_[3, 4]) } ], [#Rule 68 'final', 5, sub #line 191 "Parser.yp" { unshift(@{$_[5]}, [ @_[2,4] ]); $_[5]; } ], [#Rule 69 'final', 5, sub #line 194 "Parser.yp" { unshift(@{$_[5]}, [ undef, $_[4] ]); $_[5]; } ], [#Rule 70 'final', 4, sub #line 197 "Parser.yp" { unshift(@{$_[4]}, [ undef, $_[3] ]); $_[4]; } ], [#Rule 71 'final', 3, sub #line 199 "Parser.yp" { [ $_[3] ] } ], [#Rule 72 'final', 0, sub #line 200 "Parser.yp" { [ 0 ] } ], [#Rule 73 'use', 2, sub #line 203 "Parser.yp" { $factory->use($_[2]) } ], [#Rule 74 '@3-3', 0, sub #line 206 "Parser.yp" { $_[0]->push_defblock(); } ], [#Rule 75 'view', 6, sub #line 207 "Parser.yp" { $factory->view(@_[2,5], $_[0]->pop_defblock) } ], [#Rule 76 '@4-2', 0, sub #line 211 "Parser.yp" { ${$_[0]->{ INPERL }}++; } ], [#Rule 77 'perl', 5, sub #line 212 "Parser.yp" { ${$_[0]->{ INPERL }}--; $_[0]->{ EVAL_PERL } ? $factory->perl($_[4]) : $factory->no_perl(); } ], [#Rule 78 '@5-1', 0, sub #line 218 "Parser.yp" { ${$_[0]->{ INPERL }}++; $rawstart = ${$_[0]->{'LINE'}}; } ], [#Rule 79 'rawperl', 5, sub #line 220 "Parser.yp" { ${$_[0]->{ INPERL }}--; $_[0]->{ EVAL_PERL } ? $factory->rawperl($_[4], $rawstart) : $factory->no_perl(); } ], [#Rule 80 'filter', 5, sub #line 227 "Parser.yp" { $factory->filter(@_[2,4]) } ], [#Rule 81 'filter', 3, sub #line 229 "Parser.yp" { $factory->filter(@_[3,1]) } ], [#Rule 82 'defblock', 5, sub #line 234 "Parser.yp" { my $name = join('/', @{ $_[0]->{ DEFBLOCKS } }); pop(@{ $_[0]->{ DEFBLOCKS } }); $_[0]->define_block($name, $_[4]); undef } ], [#Rule 83 'defblockname', 2, sub #line 241 "Parser.yp" { push(@{ $_[0]->{ DEFBLOCKS } }, $_[2]); $_[2]; } ], [#Rule 84 'blockname', 1, undef ], [#Rule 85 'blockname', 1, sub #line 247 "Parser.yp" { $_[1] =~ s/^'(.*)'$/$1/; $_[1] } ], [#Rule 86 'blockargs', 1, undef ], [#Rule 87 'blockargs', 0, undef ], [#Rule 88 'anonblock', 5, sub #line 255 "Parser.yp" { local $" = ', '; print STDERR "experimental block args: [@{ $_[2] }]\n" if $_[2]; $factory->anon_block($_[4]) } ], [#Rule 89 'capture', 3, sub #line 261 "Parser.yp" { $factory->capture(@_[1, 3]) } ], [#Rule 90 'macro', 6, sub #line 265 "Parser.yp" { $factory->macro(@_[2, 6, 4]) } ], [#Rule 91 'macro', 3, sub #line 266 "Parser.yp" { $factory->macro(@_[2, 3]) } ], [#Rule 92 'mdir', 1, undef ], [#Rule 93 'mdir', 4, sub #line 270 "Parser.yp" { $_[3] } ], [#Rule 94 'margs', 2, sub #line 273 "Parser.yp" { push(@{$_[1]}, $_[2]); $_[1] } ], [#Rule 95 'margs', 2, sub #line 274 "Parser.yp" { $_[1] } ], [#Rule 96 'margs', 1, sub #line 275 "Parser.yp" { [ $_[1] ] } ], [#Rule 97 'metadata', 2, sub #line 278 "Parser.yp" { push(@{$_[1]}, @{$_[2]}); $_[1] } ], [#Rule 98 'metadata', 2, undef ], [#Rule 99 'metadata', 1, undef ], [#Rule 100 'meta', 3, sub #line 283 "Parser.yp" { for ($_[3]) { s/^'//; s/'$//; s/\\'/'/g }; [ @_[1,3] ] } ], [#Rule 101 'meta', 5, sub #line 286 "Parser.yp" { [ @_[1,4] ] } ], [#Rule 102 'meta', 3, sub #line 287 "Parser.yp" { [ @_[1,3] ] } ], [#Rule 103 'term', 1, undef ], [#Rule 104 'term', 1, undef ], [#Rule 105 'lterm', 3, sub #line 299 "Parser.yp" { "[ $_[2] ]" } ], [#Rule 106 'lterm', 3, sub #line 300 "Parser.yp" { "[ $_[2] ]" } ], [#Rule 107 'lterm', 2, sub #line 301 "Parser.yp" { "[ ]" } ], [#Rule 108 'lterm', 3, sub #line 302 "Parser.yp" { "{ $_[2] }" } ], [#Rule 109 'sterm', 1, sub #line 305 "Parser.yp" { $factory->ident($_[1]) } ], [#Rule 110 'sterm', 2, sub #line 306 "Parser.yp" { $factory->identref($_[2]) } ], [#Rule 111 'sterm', 3, sub #line 307 "Parser.yp" { $factory->quoted($_[2]) } ], [#Rule 112 'sterm', 1, undef ], [#Rule 113 'sterm', 1, undef ], [#Rule 114 'list', 2, sub #line 312 "Parser.yp" { "$_[1], $_[2]" } ], [#Rule 115 'list', 2, undef ], [#Rule 116 'list', 1, undef ], [#Rule 117 'range', 3, sub #line 317 "Parser.yp" { $_[1] . '..' . $_[3] } ], [#Rule 118 'hash', 1, undef ], [#Rule 119 'hash', 0, sub #line 322 "Parser.yp" { "" } ], [#Rule 120 'params', 2, sub #line 325 "Parser.yp" { "$_[1], $_[2]" } ], [#Rule 121 'params', 2, undef ], [#Rule 122 'params', 1, undef ], [#Rule 123 'param', 3, sub #line 330 "Parser.yp" { "$_[1] => $_[3]" } ], [#Rule 124 'param', 3, sub #line 331 "Parser.yp" { "$_[1] => $_[3]" } ], [#Rule 125 'ident', 3, sub #line 334 "Parser.yp" { push(@{$_[1]}, @{$_[3]}); $_[1] } ], [#Rule 126 'ident', 3, sub #line 335 "Parser.yp" { push(@{$_[1]}, map {($_, 0)} split(/\./, $_[3])); $_[1]; } ], [#Rule 127 'ident', 1, undef ], [#Rule 128 'node', 1, sub #line 341 "Parser.yp" { [ $_[1], 0 ] } ], [#Rule 129 'node', 4, sub #line 342 "Parser.yp" { [ $_[1], $factory->args($_[3]) ] } ], [#Rule 130 'item', 1, sub #line 345 "Parser.yp" { "'$_[1]'" } ], [#Rule 131 'item', 3, sub #line 346 "Parser.yp" { $_[2] } ], [#Rule 132 'item', 2, sub #line 347 "Parser.yp" { $_[0]->{ V1DOLLAR } ? "'$_[2]'" : $factory->ident(["'$_[2]'", 0]) } ], [#Rule 133 'expr', 3, sub #line 352 "Parser.yp" { "$_[1] $_[2] $_[3]" } ], [#Rule 134 'expr', 3, sub #line 353 "Parser.yp" { "$_[1] $_[2] $_[3]" } ], [#Rule 135 'expr', 3, sub #line 354 "Parser.yp" { "$_[1] $_[2] $_[3]" } ], [#Rule 136 'expr', 3, sub #line 355 "Parser.yp" { "int($_[1] / $_[3])" } ], [#Rule 137 'expr', 3, sub #line 356 "Parser.yp" { "$_[1] % $_[3]" } ], [#Rule 138 'expr', 3, sub #line 357 "Parser.yp" { "$_[1] $CMPOP{ $_[2] } $_[3]" } ], [#Rule 139 'expr', 3, sub #line 358 "Parser.yp" { "$_[1] . $_[3]" } ], [#Rule 140 'expr', 3, sub #line 359 "Parser.yp" { "$_[1] && $_[3]" } ], [#Rule 141 'expr', 3, sub #line 360 "Parser.yp" { "$_[1] || $_[3]" } ], [#Rule 142 'expr', 2, sub #line 361 "Parser.yp" { "! $_[2]" } ], [#Rule 143 'expr', 5, sub #line 362 "Parser.yp" { "$_[1] ? $_[3] : $_[5]" } ], [#Rule 144 'expr', 3, sub #line 363 "Parser.yp" { $factory->assign(@{$_[2]}) } ], [#Rule 145 'expr', 3, sub #line 364 "Parser.yp" { "($_[2])" } ], [#Rule 146 'expr', 1, undef ], [#Rule 147 'setlist', 2, sub #line 368 "Parser.yp" { push(@{$_[1]}, @{$_[2]}); $_[1] } ], [#Rule 148 'setlist', 2, undef ], [#Rule 149 'setlist', 1, undef ], [#Rule 150 'assign', 3, sub #line 374 "Parser.yp" { [ $_[1], $_[3] ] } ], [#Rule 151 'assign', 3, sub #line 375 "Parser.yp" { [ @_[1,3] ] } ], [#Rule 152 'args', 2, sub #line 382 "Parser.yp" { push(@{$_[1]}, $_[2]); $_[1] } ], [#Rule 153 'args', 2, sub #line 383 "Parser.yp" { push(@{$_[1]->[0]}, $_[2]); $_[1] } ], [#Rule 154 'args', 4, sub #line 384 "Parser.yp" { push(@{$_[1]->[0]}, "'', " . $factory->assign(@_[2,4])); $_[1] } ], [#Rule 155 'args', 2, sub #line 386 "Parser.yp" { $_[1] } ], [#Rule 156 'args', 0, sub #line 387 "Parser.yp" { [ [ ] ] } ], [#Rule 157 'lnameargs', 3, sub #line 397 "Parser.yp" { push(@{$_[3]}, $_[1]); $_[3] } ], [#Rule 158 'lnameargs', 1, undef ], [#Rule 159 'lvalue', 1, undef ], [#Rule 160 'lvalue', 3, sub #line 402 "Parser.yp" { $factory->quoted($_[2]) } ], [#Rule 161 'lvalue', 1, undef ], [#Rule 162 'nameargs', 3, sub #line 406 "Parser.yp" { [ [$factory->ident($_[2])], $_[3] ] } ], [#Rule 163 'nameargs', 2, sub #line 407 "Parser.yp" { [ @_[1,2] ] } ], [#Rule 164 'nameargs', 4, sub #line 408 "Parser.yp" { [ @_[1,3] ] } ], [#Rule 165 'names', 3, sub #line 411 "Parser.yp" { push(@{$_[1]}, $_[3]); $_[1] } ], [#Rule 166 'names', 1, sub #line 412 "Parser.yp" { [ $_[1] ] } ], [#Rule 167 'name', 3, sub #line 415 "Parser.yp" { $factory->quoted($_[2]) } ], [#Rule 168 'name', 1, sub #line 416 "Parser.yp" { "'$_[1]'" } ], [#Rule 169 'name', 1, undef ], [#Rule 170 'filename', 3, sub #line 420 "Parser.yp" { "$_[1].$_[3]" } ], [#Rule 171 'filename', 1, undef ], [#Rule 172 'filepart', 1, undef ], [#Rule 173 'filepart', 1, undef ], [#Rule 174 'filepart', 1, undef ], [#Rule 175 'quoted', 2, sub #line 434 "Parser.yp" { push(@{$_[1]}, $_[2]) if defined $_[2]; $_[1] } ], [#Rule 176 'quoted', 0, sub #line 436 "Parser.yp" { [ ] } ], [#Rule 177 'quotable', 1, sub #line 439 "Parser.yp" { $factory->ident($_[1]) } ], [#Rule 178 'quotable', 1, sub #line 440 "Parser.yp" { $factory->text($_[1]) } ], [#Rule 179 'quotable', 1, sub #line 441 "Parser.yp" { undef } ] ]; } #--- END BEGIN 1; __END__ =head1 NAME Template::Grammar - Parser state/rule tables for the TT grammar =head1 SYNOPSIS # no user serviceable parts inside =head1 DESCRIPTION This module defines the state and rule tables that the L<Template::Parser> module uses to parse templates. It is generated from a YACC-like grammar using the C<Parse::Yapp> module. The F<parser> sub-directory of the Template Toolkit source distribution contains the grammar and other files required to generate this module. But you don't need to worry about any of that unless you're planning to modify the Template Toolkit language. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Parser> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: 5.32/NetAddr/IP/UtilPP.pm 0000444 00000036551 15125513451 0010511 0 ustar 00 #!/usr/bin/perl package NetAddr::IP::UtilPP; use strict; #use diagnostics; #use lib qw(blib lib); use AutoLoader qw(AUTOLOAD); use vars qw($VERSION @EXPORT_OK @ISA %EXPORT_TAGS); require Exporter; @ISA = qw(Exporter); $VERSION = do { my @r = (q$Revision: 1.9 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; @EXPORT_OK = qw( hasbits shiftleft addconst add128 sub128 notcontiguous ipv4to6 mask4to6 ipanyto6 maskanyto6 ipv6to4 bin2bcd bcd2bin comp128 bin2bcdn bcdn2txt bcdn2bin simple_pack ); %EXPORT_TAGS = ( all => [@EXPORT_OK], ); sub DESTROY {}; 1; __END__ =head1 NAME NetAddr::IP::UtilPP -- pure Perl functions for NetAddr::IP::Util =head1 SYNOPSIS use NetAddr::IP::UtilPP qw( hasbits shiftleft addconst add128 sub128 notcontiguous ipv4to6 mask4to6 ipanyto6 maskanyto6 ipv6to4 bin2bcd bcd2bin ); use NetAddr::IP::UtilPP qw(:all) $rv = hasbits($bits128); $bitsX2 = shiftleft($bits128,$n); $carry = addconst($ipv6naddr,$signed_32con); ($carry,$ipv6naddr)=addconst($ipv6naddr,$signed_32con); $carry = add128($ipv6naddr1,$ipv6naddr2); ($carry,$ipv6naddr)=add128($ipv6naddr1,$ipv6naddr2); $carry = sub128($ipv6naddr1,$ipv6naddr2); ($spurious,$cidr) = notcontiguous($mask128); ($carry,$ipv6naddr)=sub128($ipv6naddr1,$ipv6naddr2); $ipv6naddr = ipv4to6($netaddr); $ipv6naddr = mask4to6($netaddr); $ipv6naddr = ipanyto6($netaddr); $ipv6naddr = maskanyto6($netaddr); $netaddr = ipv6to4($pv6naddr); $bcdtext = bin2bcd($bits128); $bits128 = bcd2bin($bcdtxt); =head1 DESCRIPTION B<NetAddr::IP::UtilPP> provides pure Perl functions for B<NetAddr::IP::Util> =over 4 =item * $rv = hasbits($bits128); This function returns true if there are one's present in the 128 bit string and false if all the bits are zero. i.e. if (hasbits($bits128)) { &do_something; } or if (hasbits($bits128 & $mask128) { &do_something; } This allows the implementation of logical functions of the form of: if ($bits128 & $mask128) { ... input: 128 bit IPv6 string returns: true if any bits are present =cut sub _deadlen { my($len,$should) = @_; $len *= 8; $should = 128 unless $should; my $sub = (caller(1))[3]; die "Bad argument length for $sub, is $len, should be $should"; } sub hasbits { _deadlen(length($_[0])) if length($_[0]) != 16; return 1 if vec($_[0],0,32); return 1 if vec($_[0],1,32); return 1 if vec($_[0],2,32); return 1 if vec($_[0],3,32); return 0; } #=item * $rv = isIPv4($bits128); # #This function returns true if there are no on bits present in the IPv6 #portion of the 128 bit string and false otherwise. # #=cut # #sub xisIPv4 { # _deadlen(length($_[0])) # if length($_[0]) != 16; # return 0 if vec($_[0],0,32); # return 0 if vec($_[0],1,32); # return 0 if vec($_[0],2,32); # return 1; #} =item * $bitsXn = shiftleft($bits128,$n); input: 128 bit string variable, number of shifts [optional] returns: bits X n shifts NOTE: input bits are returned if $n is not specified =cut # multiply x 2 # sub _128x2 { my $inp = shift; $$inp[0] = ($$inp[0] << 1 & 0xffffffff) + (($$inp[1] & 0x80000000) ? 1:0); $$inp[1] = ($$inp[1] << 1 & 0xffffffff) + (($$inp[2] & 0x80000000) ? 1:0); $$inp[2] = ($$inp[2] << 1 & 0xffffffff) + (($$inp[3] & 0x80000000) ? 1:0); $$inp[3] = $$inp[3] << 1 & 0xffffffff; } # multiply x 10 # sub _128x10 { my($a128p) = @_; _128x2($a128p); # x2 my @x2 = @$a128p; # save the x2 value _128x2($a128p); _128x2($a128p); # x8 _sa128($a128p,\@x2,0); # add for x10 } sub shiftleft { _deadlen(length($_[0])) if length($_[0]) != 16; my($bits,$shifts) = @_; return $bits unless $shifts; die "Bad arg value for ".__PACKAGE__.":shiftleft, length should be 0 thru 128" if $shifts < 0 || $shifts > 128; my @uint32t = unpack('N4',$bits); do { $bits = _128x2(\@uint32t); $shifts-- } while $shifts > 0; pack('N4',@uint32t); } sub slowadd128 { my @ua = unpack('N4',$_[0]); my @ub = unpack('N4',$_[1]); my $carry = _sa128(\@ua,\@ub,$_[2]); return ($carry,pack('N4',@ua)) if wantarray; return $carry; } sub _sa128 { my($uap,$ubp,$carry) = @_; if (($$uap[3] += $$ubp[3] + $carry) > 0xffffffff) { $$uap[3] -= 4294967296; # 0x1_00000000 $carry = 1; } else { $carry = 0; } if (($$uap[2] += $$ubp[2] + $carry) > 0xffffffff) { $$uap[2] -= 4294967296; $carry = 1; } else { $carry = 0; } if (($$uap[1] += $$ubp[1] + $carry) > 0xffffffff) { $$uap[1] -= 4294967296; $carry = 1; } else { $carry = 0; } if (($$uap[0] += $$ubp[0] + $carry) > 0xffffffff) { $$uap[0] -= 4294967296; $carry = 1; } else { $carry = 0; } $carry; } =item * addconst($ipv6naddr,$signed_32con); Add a signed constant to a 128 bit string variable. input: 128 bit IPv6 string, signed 32 bit integer returns: scalar carry array (carry, result) =cut sub addconst { my($a128,$const) = @_; _deadlen(length($a128)) if length($a128) != 16; unless ($const) { return (wantarray) ? ($const,$a128) : $const; } my $sign = ($const < 0) ? 0xffffffff : 0; my $b128 = pack('N4',$sign,$sign,$sign,$const); @_ = ($a128,$b128,0); # perl 5.8.4 fails with this operation. see perl bug [ 23429] # goto &slowadd128; slowadd128(@_); } =item * add128($ipv6naddr1,$ipv6naddr2); Add two 128 bit string variables. input: 128 bit string var1, 128 bit string var2 returns: scalar carry array (carry, result) =cut sub add128 { my($a128,$b128) = @_; _deadlen(length($a128)) if length($a128) != 16; _deadlen(length($b128)) if length($b128) != 16; @_ = ($a128,$b128,0); # perl 5.8.4 fails with this operation. see perl bug [ 23429] # goto &slowadd128; slowadd128(@_); } =item * sub128($ipv6naddr1,$ipv6naddr2); Subtract two 128 bit string variables. input: 128 bit string var1, 128 bit string var2 returns: scalar carry array (carry, result) Note: The carry from this operation is the result of adding the one's complement of ARG2 +1 to the ARG1. It is logically B<NOT borrow>. i.e. if ARG1 >= ARG2 then carry = 1 or if ARG1 < ARG2 then carry = 0 =cut sub sub128 { _deadlen(length($_[0])) if length($_[0]) != 16; _deadlen(length($_[1])) if length($_[1]) != 16; my $a128 = $_[0]; my $b128 = ~$_[1]; @_ = ($a128,$b128,1); # perl 5.8.4 fails with this operation. see perl bug [ 23429] # goto &slowadd128; slowadd128(@_); } =item * ($spurious,$cidr) = notcontiguous($mask128); This function counts the bit positions remaining in the mask when the rightmost '0's are removed. input: 128 bit netmask returns true if there are spurious zero bits remaining in the mask, false if the mask is contiguous one's, 128 bit cidr =cut sub notcontiguous { _deadlen(length($_[0])) if length($_[0]) != 16; my @ua = unpack('N4', ~$_[0]); my $count; for ($count = 128;$count > 0; $count--) { last unless $ua[3] & 1; $ua[3] >>= 1; $ua[3] |= 0x80000000 if $ua[2] & 1; $ua[2] >>= 1; $ua[2] |= 0x80000000 if $ua[1] & 1; $ua[1] >>= 1; $ua[1] |= 0x80000000 if $ua[0] & 1; $ua[0] >>= 1; } my $spurious = $ua[0] | $ua[1] | $ua[2] | $ua[3]; return $spurious unless wantarray; return ($spurious,$count); } =item * $ipv6naddr = ipv4to6($netaddr); Convert an ipv4 network address into an ipv6 network address. input: 32 bit network address returns: 128 bit network address =cut sub ipv4to6 { _deadlen(length($_[0]),32) if length($_[0]) != 4; # return pack('L3H8',0,0,0,unpack('H8',$_[0])); return pack('L3a4',0,0,0,$_[0]); } =item * $ipv6naddr = mask4to6($netaddr); Convert an ipv4 netowrk address into an ipv6 network mask. input: 32 bit network/mask address returns: 128 bit network/mask address NOTE: returns the high 96 bits as one's =cut sub mask4to6 { _deadlen(length($_[0]),32) if length($_[0]) != 4; # return pack('L3H8',0xffffffff,0xffffffff,0xffffffff,unpack('H8',$_[0])); return pack('L3a4',0xffffffff,0xffffffff,0xffffffff,$_[0]); } =item * $ipv6naddr = ipanyto6($netaddr); Similar to ipv4to6 except that this function takes either an IPv4 or IPv6 input and always returns a 128 bit IPv6 network address. input: 32 or 128 bit network address returns: 128 bit network address =cut sub ipanyto6 { my $naddr = shift; my $len = length($naddr); return $naddr if $len == 16; # return pack('L3H8',0,0,0,unpack('H8',$naddr)) return pack('L3a4',0,0,0,$naddr) if $len == 4; _deadlen($len,'32 or 128'); } =item * $ipv6naddr = maskanyto6($netaddr); Similar to mask4to6 except that this function takes either an IPv4 or IPv6 netmask and always returns a 128 bit IPv6 netmask. input: 32 or 128 bit network mask returns: 128 bit network mask =cut sub maskanyto6 { my $naddr = shift; my $len = length($naddr); return $naddr if $len == 16; # return pack('L3H8',0xffffffff,0xffffffff,0xffffffff,unpack('H8',$naddr)) return pack('L3a4',0xffffffff,0xffffffff,0xffffffff,$naddr) if $len == 4; _deadlen($len,'32 or 128'); } =item * $netaddr = ipv6to4($pv6naddr); Truncate the upper 96 bits of a 128 bit address and return the lower 32 bits. Returns an IPv4 address as returned by inet_aton. input: 128 bit network address returns: 32 bit inet_aton network address =cut sub ipv6to4 { my $naddr = shift; _deadlen(length($naddr)) if length($naddr) != 16; @_ = unpack('L3H8',$naddr); return pack('H8',@{_}[3..10]); } =item * $bcdtext = bin2bcd($bits128); Convert a 128 bit binary string into binary coded decimal text digits. input: 128 bit string variable returns: string of bcd text digits =cut sub bin2bcd { _deadlen(length($_[0])) if length($_[0]) != 16; unpack("H40",&_bin2bcdn) =~ /^0*(.+)/; $1; } =item * $bits128 = bcd2bin($bcdtxt); Convert a bcd text string to 128 bit string variable input: string of bcd text digits returns: 128 bit string variable =cut sub bcd2bin { &_bcdcheck; # perl 5.8.4 fails with this operation. see perl bug [ 23429] # goto &_bcd2bin; &_bcd2bin; } =pod =back =cut #=item * $onescomp = comp128($ipv6addr); # #This function is for testing, it is more efficient to use perl " ~ " #on the bit string directly. This interface to the B<C> routine is published for #module testing purposes because it is used internally in the B<sub128> routine. The #function is very fast, but calling if from perl directly is very slow. It is almost #33% faster to use B<sub128> than to do a 1's comp with perl and then call #B<add128>. In the PurePerl version, it is a call to # # sub {return ~ $_[0]}; # #=cut sub comp128 { _deadlen(length($_[0])) if length($_[0]) != 16; return ~ $_[0]; } #=item * $bcdpacked = bin2bcdn($bits128); # #Convert a 128 bit binary string into binary coded decimal digits. #This function is for testing only. # # input: 128 bit string variable # returns: string of packed decimal digits # # i.e. text = unpack("H*", $bcd); # #=cut sub bin2bcdn { _deadlen(length($_[0])) if length($_[0]) != 16; # perl 5.8.4 fails with this operation. see perl bug [ 23429] # goto &_bin2bcdn; &_bin2bcdn; } sub _bin2bcdn { my($b128) = @_; my @binary = unpack('N4',$b128); my @nbcd = (0,0,0,0,0); # 5 - 32 bit registers my ($add3, $msk8, $bcd8, $carry, $tmp); my $j = 0; my $k = -1; my $binmsk = 0; foreach(0..127) { unless ($binmsk) { $binmsk = 0x80000000; $k++; } $carry = $binary[$k] & $binmsk; $binmsk >>= 1; next unless $carry || $j; # skip leading zeros foreach(4,3,2,1,0) { $bcd8 = $nbcd[$_]; $add3 = 3; $msk8 = 8; $j = 0; while ($j < 8) { $tmp = $bcd8 + $add3; if ($tmp & $msk8) { $bcd8 = $tmp; } $add3 <<= 4; $msk8 <<= 4; $j++; } $tmp = $bcd8 & 0x80000000; # propagate carry $bcd8 <<= 1; # x2 if ($carry) { $bcd8 += 1; } $nbcd[$_] = $bcd8; $carry = $tmp; } } pack('N5',@nbcd); } #=item * $bcdtext = bcdn2txt($bcdpacked); # #Convert a packed bcd string into text digits, suppress the leading zeros. #This function is for testing only. # # input: string of packed decimal digits # consisting of exactly 40 digits # returns: hexdecimal digits # #Similar to unpack("H*", $bcd); # #=cut sub bcdn2txt { die "Bad argument length for ".__PACKAGE__.":bcdn2txt, is ".(2 * length($_[0])).", should be exactly 40 digits" if length($_[0]) != 20; (unpack('H40',$_[0])) =~ /^0*(.+)/; $1; } #=item * $bits128 = bcdn2bin($bcdpacked,$ndigits); # # Convert a packed bcd string into a 128 bit string variable # # input: packed bcd string # number of digits in string # returns: 128 bit string variable # sub bcdn2bin { my($bcd,$dc) = @_; $dc = 0 unless $dc; die "Bad argument length for ".__PACKAGE__.":bcdn2txt, is ".(2 * length($bcd)).", should be 1 to 40 digits" if length($bcd) > 20; die "Bad digit count for ".__PACKAGE__.":bcdn2bin, is $dc, should be 1 to 40 digits" if $dc < 1 || $dc > 40; return _bcd2bin(unpack("H$dc",$bcd)); } sub _bcd2bin { my @bcd = split('',$_[0]); my @hbits = (0,0,0,0); my @digit = (0,0,0,0); my $found = 0; foreach(@bcd) { my $bcd = $_ & 0xf; # just the nibble unless ($found) { next unless $bcd; # skip leading zeros $found = 1; $hbits[3] = $bcd; # set the first digit, no x10 necessary next; } _128x10(\@hbits); $digit[3] = $bcd; _sa128(\@hbits,\@digit,0); } return pack('N4',@hbits); } #=item * $bcdpacked = simple_pack($bcdtext); # #Convert a numeric string into a packed bcd string, left fill with zeros #This function is for testing only. # # input: string of decimal digits # returns: string of packed decimal digits # #Similar to pack("H*", $bcdtext); # sub _bcdcheck { my($bcd) = @_;; my $sub = (caller(1))[3]; my $len = length($bcd); die "Bad bcd number length $_ ".__PACKAGE__.":simple_pack, should be 1 to 40 digits" if $len > 40 || $len < 1; die "Bad character in decimal input string '$1' for ".__PACKAGE__.":simple_pack" if $bcd =~ /(\D)/; } sub simple_pack { &_bcdcheck; my($bcd) = @_; while (length($bcd) < 40) { $bcd = '0'. $bcd; } return pack('H40',$bcd); } =head1 EXPORT_OK hasbits shiftleft addconst add128 sub128 notcontiguous ipv4to6 mask4to6 ipanyto6 maskanyto6 ipv6to4 bin2bcd bcd2bin comp128 bin2bcdn bcdn2txt bcdn2bin simple_pack threads =head1 AUTHOR Michael Robinton E<lt>michael@bizsystems.comE<gt> =head1 COPYRIGHT Copyright 2003 - 2012, Michael Robinton E<lt>michael@bizsystems.comE<gt> All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version, or b) the "Artistic License" which comes with this distribution. 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 either the GNU General Public License or the Artistic License for more details. You should have received a copy of the Artistic License with this distribution, in the file named "Artistic". If not, I'll be glad to provide one. You should also have received a copy of the GNU General Public License along with this program in the file named "Copying". If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor Boston, MA 02110-1301 USA or visit their web page on the internet at: http://www.gnu.org/copyleft/gpl.html. =head1 AUTHOR Michael Robinton <michael@bizsystems.com> =cut 1; 5.32/NetAddr/IP/Lite.pm 0000444 00000125630 15125513451 0010226 0 ustar 00 #!/usr/bin/perl package NetAddr::IP::Lite; use Carp; use strict; #use diagnostics; #use warnings; use NetAddr::IP::InetBase qw( inet_any2n isIPv4 inet_n2dx inet_aton ipv6_aton ipv6_n2x fillIPv4 ); use NetAddr::IP::Util qw( addconst sub128 ipv6to4 notcontiguous shiftleft hasbits bin2bcd bcd2bin mask4to6 ipv4to6 naip_gethostbyname havegethostbyname2 ); use vars qw(@ISA @EXPORT_OK $VERSION $Accept_Binary_IP $Old_nth $NoFQDN $AUTOLOAD *Zero); $VERSION = do { my @r = (q$Revision: 1.57 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(Zeros Zero Ones V4mask V4net); # Set to true, to enable recognizing of ipV4 && ipV6 binary notation IP # addresses. Thanks to Steve Snodgrass for reporting. This can be done # at the time of use-ing the module. See docs for details. $Accept_Binary_IP = 0; $Old_nth = 0; *Zero = \&Zeros; =pod =encoding UTF-8 =head1 NAME NetAddr::IP::Lite - Manages IPv4 and IPv6 addresses and subnets =head1 SYNOPSIS use NetAddr::IP::Lite qw( Zeros Ones V4mask V4net :aton DEPRECATED ! :old_nth :upper :lower :nofqdn ); my $ip = new NetAddr::IP::Lite '127.0.0.1'; or if your prefer my $ip = NetAddr::IP::Lite->new('127.0.0.1); or from a packed IPv4 address my $ip = new_from_aton NetAddr::IP::Lite (inet_aton('127.0.0.1')); or from an octal filtered IPv4 address my $ip = new_no NetAddr::IP::Lite '127.012.0.0'; print "The address is ", $ip->addr, " with mask ", $ip->mask, "\n" ; if ($ip->within(new NetAddr::IP::Lite "127.0.0.0", "255.0.0.0")) { print "Is a loopback address\n"; } # This prints 127.0.0.1/32 print "You can also say $ip...\n"; The following four functions return ipV6 representations of: :: = Zeros(); FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF = Ones(); FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:: = V4mask(); ::FFFF:FFFF = V4net(); Will also return an ipV4 or ipV6 representation of a resolvable Fully Qualified Domanin Name (FQDN). =head1 INSTALLATION Un-tar the distribution in an appropriate directory and type: perl Makefile.PL make make test make install B<NetAddr::IP::Lite> depends on B<NetAddr::IP::Util> which installs by default with its primary functions compiled using Perl's XS extensions to build a 'C' library. If you do not have a 'C' complier available or would like the slower Pure Perl version for some other reason, then type: perl Makefile.PL -noxs make make test make install =head1 DESCRIPTION This module provides an object-oriented abstraction on top of IP addresses or IP subnets, that allows for easy manipulations. Most of the operations of NetAddr::IP are supported. This module will work with older versions of Perl and is compatible with Math::BigInt. * By default B<NetAddr::IP> functions and methods return string IPv6 addresses in uppercase. To change that to lowercase: NOTE: the AUGUST 2010 RFC5952 states: 4.3. Lowercase The characters "a", "b", "c", "d", "e", and "f" in an IPv6 address MUST be represented in lowercase. It is recommended that all NEW applications using NetAddr::IP::Lite be invoked as shown on the next line. use NetAddr::IP::Lite qw(:lower); * To ensure the current IPv6 string case behavior even if the default changes: use NetAddr::IP::Lite qw(:upper); The internal representation of all IP objects is in 128 bit IPv6 notation. IPv4 and IPv6 objects may be freely mixed. The supported operations are described below: =cut # in the off chance that NetAddr::IP::Lite objects are created # and the caller later loads NetAddr::IP and expects to use # those objects, let the AUTOLOAD routine find and redirect # NetAddr::IP::Lite method and subroutine calls to NetAddr::IP. # my $parent = 'NetAddr::IP'; # test function # # input: subroutine name in NetAddr::IP # output: t/f if sub name exists in NetAddr::IP namespace # #sub sub_exists { # my $other = $parent .'::'; # return exists ${$other}{$_[0]}; #} sub DESTROY {}; sub AUTOLOAD { no strict; my ($pkg,$func) = ($AUTOLOAD =~ /(.*)::([^:]+)$/); my $other = $parent .'::'; if ($pkg =~ /^$other/o && exists ${$other}{$func}) { $other .= $func; goto &{$other}; } my @stack = caller(0); if ( $pkg eq ref $_[0] ) { $other = qq|Can't locate object method "$func" via|; } else { $other = qq|Undefined subroutine \&$AUTOLOAD not found in|; } die $other . qq| package "$parent" or "$pkg" (did you forgot to load a module?) at $stack[1] line $stack[2].\n|; } =head2 Overloaded Operators =cut # these really should be packed in Network Long order but since they are # symmetrical, that extra internal processing can be skipped my $_v4zero = pack('L',0); my $_zero = pack('L4',0,0,0,0); my $_ones = ~$_zero; my $_v4mask = pack('L4',0xffffffff,0xffffffff,0xffffffff,0); my $_v4net = ~ $_v4mask; my $_ipv4FFFF = pack('N4',0,0,0xffff,0); sub Zeros() { return $_zero; } sub Ones() { return $_ones; } sub V4mask() { return $_v4mask; } sub V4net() { return $_v4net; } ############################################# # These are the overload methods, placed here # for convenience. ############################################# use overload '+' => \&plus, '-' => \&minus, '++' => \&plusplus, '--' => \&minusminus, "=" => \©, '""' => sub { $_[0]->cidr(); }, 'eq' => sub { my $a = (UNIVERSAL::isa($_[0],__PACKAGE__)) ? $_[0]->cidr : $_[0]; my $b = (UNIVERSAL::isa($_[1],__PACKAGE__)) ? $_[1]->cidr : $_[1]; $a eq $b; }, 'ne' => sub { my $a = (UNIVERSAL::isa($_[0],__PACKAGE__)) ? $_[0]->cidr : $_[0]; my $b = (UNIVERSAL::isa($_[1],__PACKAGE__)) ? $_[1]->cidr : $_[1]; $a ne $b; }, '==' => sub { return 0 unless UNIVERSAL::isa($_[0],__PACKAGE__) && UNIVERSAL::isa($_[1],__PACKAGE__); $_[0]->cidr eq $_[1]->cidr; }, '!=' => sub { return 1 unless UNIVERSAL::isa($_[0],__PACKAGE__) && UNIVERSAL::isa($_[1],__PACKAGE__); $_[0]->cidr ne $_[1]->cidr; }, '>' => sub { return &comp_addr_mask > 0 ? 1 : 0; }, '<' => sub { return &comp_addr_mask < 0 ? 1 : 0; }, '>=' => sub { return &comp_addr_mask < 0 ? 0 : 1; }, '<=' => sub { return &comp_addr_mask > 0 ? 0 : 1; }, '<=>' => \&comp_addr_mask, 'cmp' => \&comp_addr_mask; sub comp_addr_mask { my($c,$rv) = sub128($_[0]->{addr},$_[1]->{addr}); return -1 unless $c; return 1 if hasbits($rv); ($c,$rv) = sub128($_[0]->{mask},$_[1]->{mask}); return -1 unless $c; return hasbits($rv) ? 1 : 0; } #sub comp_addr { # my($c,$rv) = sub128($_[0]->{addr},$_[1]->{addr}); # return -1 unless $c; # return hasbits($rv) ? 1 : 0; #} =pod =over =item B<Assignment (C<=>)> Has been optimized to copy one NetAddr::IP::Lite object to another very quickly. =item B<C<-E<gt>copy()>> The B<assignment (C<=>)> operation is only put in to operation when the copied object is further mutated by another overloaded operation. See L<overload> B<SPECIAL SYMBOLS FOR "use overload"> for details. B<C<-E<gt>copy()>> actually creates a new object when called. =cut sub copy { return _new($_[0],$_[0]->{addr}, $_[0]->{mask}); } =item B<Stringification> An object can be used just as a string. For instance, the following code my $ip = new NetAddr::IP::Lite '192.168.1.123'; print "$ip\n"; Will print the string 192.168.1.123/32. my $ip = new6 NetAddr::IP::Lite '192.168.1.123'; print "$ip\n"; Will print the string 0:0:0:0:0:0:C0A8:17B/128 =item B<Equality> You can test for equality with either C<eq>, C<ne>, C<==> or C<!=>. C<eq>, C<ne> allows the comparison with arbitrary strings as well as NetAddr::IP::Lite objects. The following example: if (NetAddr::IP::Lite->new('127.0.0.1','255.0.0.0') eq '127.0.0.1/8') { print "Yes\n"; } Will print out "Yes". Comparison with C<==> and C<!=> requires both operands to be NetAddr::IP::Lite objects. =item B<Comparison via E<gt>, E<lt>, E<gt>=, E<lt>=, E<lt>=E<gt> and C<cmp>> Internally, all network objects are represented in 128 bit format. The numeric representation of the network is compared through the corresponding operation. Comparisons are tried first on the address portion of the object and if that is equal then the NUMERIC cidr portion of the masks are compared. This leads to the counterintuitive result that /24 > /16 Comparison should not be done on netaddr objects with different CIDR as this may produce indeterminate - unexpected results, rather the determination of which netblock is larger or smaller should be done by comparing $ip1->masklen <=> $ip2->masklen =item B<Addition of a constant (C<+>)> Add a 32 bit signed constant to the address part of a NetAddr object. This operation changes the address part to point so many hosts above the current objects start address. For instance, this code: print NetAddr::IP::Lite->new('127.0.0.1/8') + 5; will output 127.0.0.6/8. The address will wrap around at the broadcast back to the network address. This code: print NetAddr::IP::Lite->new('10.0.0.1/24') + 255; outputs 10.0.0.0/24. Returns the the unchanged object when the constant is missing or out of range. 2147483647 <= constant >= -2147483648 =cut sub plus { my $ip = shift; my $const = shift; return $ip unless $const && $const < 2147483648 && $const > -2147483649; my $a = $ip->{addr}; my $m = $ip->{mask}; my $lo = $a & ~$m; my $hi = $a & $m; my $new = ((addconst($lo,$const))[1] & ~$m) | $hi; return _new($ip,$new,$m); } =item B<Subtraction of a constant (C<->)> The complement of the addition of a constant. =item B<Difference (C<->)> Returns the difference between the address parts of two NetAddr::IP::Lite objects address parts as a 32 bit signed number. Returns B<undef> if the difference is out of range. =cut my $_smsk = pack('L3N',0xffffffff,0xffffffff,0xffffffff,0x80000000); sub minus { my $ip = shift; my $arg = shift; unless (ref $arg) { return plus($ip, -$arg); } my($carry,$dif) = sub128($ip->{addr},$arg->{addr}); if ($carry) { # value is positive return undef if hasbits($dif & $_smsk); # all sign bits should be 0's return (unpack('L3N',$dif))[3]; } else { return undef if hasbits(($dif & $_smsk) ^ $_smsk); # sign is 1's return (unpack('L3N',$dif))[3] - 4294967296; } } # Auto-increment an object =item B<Auto-increment> Auto-incrementing a NetAddr::IP::Lite object causes the address part to be adjusted to the next host address within the subnet. It will wrap at the broadcast address and start again from the network address. =cut sub plusplus { my $ip = shift; my $a = $ip->{addr}; my $m = $ip->{mask}; my $lo = $a & ~ $m; my $hi = $a & $m; $ip->{addr} = ((addconst($lo,1))[1] & ~ $m) | $hi; return $ip; } =item B<Auto-decrement> Auto-decrementing a NetAddr::IP::Lite object performs exactly the opposite of auto-incrementing it, as you would expect. =cut sub minusminus { my $ip = shift; my $a = $ip->{addr}; my $m = $ip->{mask}; my $lo = $a & ~$m; my $hi = $a & $m; $ip->{addr} = ((addconst($lo,-1))[1] & ~$m) | $hi; return $ip; } ############################################# # End of the overload methods. ############################################# # Preloaded methods go here. # This is a variant to ->new() that # creates and blesses a new object # without the fancy parsing of # IP formats and shorthands. # return a blessed IP object without parsing # input: prototype, naddr, nmask # returns: blessed IP object # sub _new ($$$) { my $proto = shift; my $class = ref($proto) || die "reference required"; $proto = $proto->{isv6}; my $self = { addr => $_[0], mask => $_[1], isv6 => $proto, }; return bless $self, $class; } =pod =back =head2 Methods =over =item C<-E<gt>new([$addr, [ $mask|IPv6 ]])> =item C<-E<gt>new6([$addr, [ $mask]])> =item C<-E<gt>new6FFFF([$addr, [ $mask]])> =item C<-E<gt>new_no([$addr, [ $mask]])> =item C<-E<gt>new_from_aton($netaddr)> =item new_cis and new_cis6 are DEPRECATED =item C<-E<gt>new_cis("$addr $mask)> =item C<-E<gt>new_cis6("$addr $mask)> The first three methods create a new address with the supplied address in C<$addr> and an optional netmask C<$mask>, which can be omitted to get a /32 or /128 netmask for IPv4 / IPv6 addresses respectively. new6FFFF specifically returns an IPv4 address in IPv6 format according to RFC4291 new6 ::xxxx:xxxx new6FFFF ::FFFF:xxxx:xxxx The third method C<new_no> is exclusively for IPv4 addresses and filters improperly formatted dot quad strings for leading 0's that would normally be interpreted as octal format by NetAddr per the specifications for inet_aton. B<new_from_aton> takes a packed IPv4 address and assumes a /32 mask. This function replaces the DEPRECATED :aton functionality which is fundamentally broken. The last two methods B<new_cis> and B<new_cis6> differ from B<new> and B<new6> only in that they except the common Cisco address notation for address/mask pairs with a B<space> as a separator instead of a slash (/) These methods are DEPRECATED because the functionality is now included in the other "new" methods i.e. ->new_cis('1.2.3.0 24') or ->new_cis6('::1.2.3.0 120') C<-E<gt>new6> and C<-E<gt>new_cis6> mark the address as being in ipV6 address space even if the format would suggest otherwise. i.e. ->new6('1.2.3.4') will result in ::102:304 addresses submitted to ->new in ipV6 notation will remain in that notation permanently. i.e. ->new('::1.2.3.4') will result in ::102:304 whereas new('1.2.3.4') would print out as 1.2.3.4 See "STRINGIFICATION" below. C<$addr> can be almost anything that can be resolved to an IP address in all the notations I have seen over time. It can optionally contain the mask in CIDR notation. If the OPTIONAL perl module Socket6 is available in the local library it will autoload and ipV6 host6 names will be resolved as well as ipV4 hostnames. B<prefix> notation is understood, with the limitation that the range specified by the prefix must match with a valid subnet. Addresses in the same format returned by C<inet_aton> or C<gethostbyname> can also be understood, although no mask can be specified for them. The default is to not attempt to recognize this format, as it seems to be seldom used. ###### DEPRECATED, will be remove in version 5 ############ To accept addresses in that format, invoke the module as in use NetAddr::IP::Lite ':aton' ###### USE new_from_aton instead ########################## If called with no arguments, 'default' is assumed. If called with an empty string as the argument, returns 'undef' C<$addr> can be any of the following and possibly more... n.n n.n/mm n.n mm n.n.n n.n.n/mm n.n.n mm n.n.n.n n.n.n.n/mm 32 bit cidr notation n.n.n.n mm n.n.n.n/m.m.m.m n.n.n.n m.m.m.m loopback, localhost, broadcast, any, default x.x.x.x/host 0xABCDEF, 0b111111000101011110, (or a bcd number) a netaddr as returned by 'inet_aton' Any RFC1884 notation ::n.n.n.n ::n.n.n.n/mmm 128 bit cidr notation ::n.n.n.n/::m.m.m.m ::x:x ::x:x/mmm x:x:x:x:x:x:x:x x:x:x:x:x:x:x:x/mmm x:x:x:x:x:x:x:x/m:m:m:m:m:m:m:m any RFC1884 notation loopback, localhost, unspecified, any, default ::x:x/host 0xABCDEF, 0b111111000101011110 within the limits of perl's number resolution 123456789012 a 'big' bcd number (bigger than perl likes) and Math::BigInt A Fully Qualified Domain Name which returns an ipV4 address or an ipV6 address, embodied in that order. This previously undocumented feature may be disabled with: use NetAddr::IP::Lite ':nofqdn'; If called with no arguments, 'default' is assumed. If called with and empty string as the argument, 'undef' is returned; =cut my $lbmask = inet_aton('255.0.0.0'); my $_p4broad = inet_any2n('255.255.255.255'); my $_p4loop = inet_any2n('127.0.0.1'); my $_p4mloop = inet_aton('255.0.0.0'); $_p4mloop = mask4to6($_p4mloop); my $_p6loop = inet_any2n('::1'); my %fip4 = ( default => Zeros, any => Zeros, broadcast => $_p4broad, loopback => $_p4loop, unspecified => undef, ); my %fip4m = ( default => Zeros, any => Zeros, broadcast => Ones, loopback => $_p4mloop, unspecified => undef, # not applicable for ipV4 host => Ones, ); my %fip6 = ( default => Zeros, any => Zeros, broadcast => undef, # not applicable for ipV6 loopback => $_p6loop, unspecified => Zeros, ); my %fip6m = ( default => Zeros, any => Zeros, broadcast => undef, # not applicable for ipV6 loopback => Ones, unspecified => Ones, host => Ones, ); my $ff000000 = pack('L3N',0xffffffff,0xffffffff,0xffffffff,0xFF000000); my $ffff0000 = pack('L3N',0xffffffff,0xffffffff,0xffffffff,0xFFFF0000); my $ffffff00 = pack('L3N',0xffffffff,0xffffffff,0xffffffff,0xFFFFFF00); sub _obits ($$) { my($lo,$hi) = @_; return 0xFF if $lo == $hi; return (~ ($hi ^ $lo)) & 0xFF; } sub new_no($;$$) { unshift @_, -1; goto &_xnew; } sub new($;$$) { unshift @_, 0; goto &_xnew; } sub new_from_aton($$) { my $proto = shift; my $class = ref $proto || $proto || __PACKAGE__; my $ip = shift; return undef unless defined $ip; my $addrlen = length($ip); return undef unless $addrlen == 4; my $self = { addr => ipv4to6($ip), mask => &Ones, isv6 => 0, }; return bless $self, $class; } sub new6($;$$) { unshift @_, 1; goto &_xnew; } sub new6FFFF($;$$) { my $ip = _xnew(1,@_); $ip->{addr} |= $_ipv4FFFF; return $ip; } sub new_cis($;$$) { my @in = @_; if ( $in[1] && $in[1] =~ m!^(.+)\s+(.+)$! ) { $in[1] = $1 .'/'. $2; } @_ = (0,@in); goto &_xnew; } sub new_cis6($;$$) { my @in = @_; if ( $in[1] && $in[1] =~ m!^(.+)\s+(.+)$! ) { $in[1] = $1 .'/'. $2; } @_ = (1,@in); goto &_xnew; } sub _no_octal { # $_[0] =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/; # return sprintf("%d.%d.%d.%d",$1,$2,$3,$4); (my $rv = $_[0]) =~ s#\b0*([1-9]\d*/?|0/?)#$1#g; # suppress leading zeros $rv; } sub _xnew($$;$$) { my $noctal = 0; my $isV6 = shift; if ($isV6 < 0) { # flag for no octal? $isV6 = 0; $noctal = 1; } my $proto = shift; my $class = ref $proto || $proto || __PACKAGE__; my $ip = shift; if ($ip && $noctal && $ip !~ m|(?:[^\s0123456789/. -])|) { # octal suppression required if not an IPv4 address $ip = _no_octal($ip); } # fix for bug #75976 return undef if defined $ip && $ip eq ''; $ip = 'default' unless defined $ip; $ip = _retMBIstring($ip) # treat as big bcd string if ref $ip && ref $ip eq 'Math::BigInt'; # can /CIDR notation my $hasmask = 1; my($mask,$tmp); # IP to lower case AFTER ref test for Math::BigInt. 'lc' strips blessing $ip = lc $ip; while (1) { # process IP's with no CIDR or that have the CIDR as part of the IP argument string unless (@_) { # if ($ip =~ m!^(.+)/(.+)$!) { if ($ip !~ /\D/) { # binary number notation $ip = bcd2bin($ip); $mask = Ones; last; } elsif ($ip =~ m!^([a-z0-9.:-]+)(?:/|\s+)([a-z0-9.:-]+)$! || $ip =~ m!^[\[]{1}([a-z0-9.:-]+)(?:/|\s+)([a-z0-9.:-]+)[\]]{1}$!) { $ip = $1; $mask = $2; } elsif (grep($ip eq $_,(qw(default any broadcast loopback unspecified)))) { $isV6 = 1 if $ip eq 'unspecified'; if ($isV6) { $mask = $fip6m{$ip}; return undef unless defined ($ip = $fip6{$ip}); } else { $mask = $fip4m{$ip}; return undef unless defined ($ip = $fip4{$ip}); } last; } } # process "ipv6" token and default IP's elsif (defined $_[0]) { if ($_[0] =~ /ipv6/i || $isV6) { if (grep($ip eq $_,(qw(default any loopback unspecified)))) { $mask = $fip6m{$ip}; $ip = $fip6{$ip}; last; } else { return undef unless $isV6; # add for ipv6 notation "12345, 1" } # $mask = lc $_[0]; # } else { # $mask = lc $_[0]; } # extract mask $mask = $_[0]; } ### ### process mask unless (defined $mask) { $hasmask = 0; $mask = 'host'; } # two kinds of IP's can turn on the isV6 flag # 1) big digits that are over the IPv4 boundry # 2) IPv6 IP syntax # # check these conditions and set isV6 as appropriate # my $try; $isV6 = 1 if # check big bcd and IPv6 rfc1884 ( $ip !~ /\D/ && # ip is all decimal (length($ip) > 3 || $ip > 255) && # exclude a single digit in the range of zero to 255, could be funny IPv4 ($try = bcd2bin($ip)) && ! isIPv4($try)) || # precedence so $try is not corrupted (index($ip,':') >= 0 && ($try = ipv6_aton($ip))); # fails if not an rfc1884 address # if either of the above conditions is true, $try contains the NetAddr 128 bit address # checkfor Math::BigInt mask $mask = _retMBIstring($mask) # treat as big bcd string if ref $mask && ref $mask eq 'Math::BigInt'; # MASK to lower case AFTER ref test for Math::BigInt, 'lc' strips blessing $mask = lc $mask; if ($mask !~ /\D/) { # bcd or CIDR notation my $isCIDR = length($mask) < 4 && $mask < 129; if ($isV6) { if ($isCIDR) { my($dq1,$dq2,$dq3,$dq4); if ($ip =~ /^(\d+)(?:|\.(\d+)(?:|\.(\d+)(?:|\.(\d+))))$/ && do {$dq1 = $1; $dq2 = $2 || 0; $dq3 = $3 || 0; $dq4 = $4 || 0; 1; } && $dq1 >= 0 && $dq1 < 256 && $dq2 >= 0 && $dq2 < 256 && $dq3 >= 0 && $dq3 < 256 && $dq4 >= 0 && $dq4 < 256 ) { # corner condition of IPv4 with isV6 $ip = join('.',$dq1,$dq2,$dq3,$dq4); $try = ipv4to6(inet_aton($ip)); if ($mask < 32) { $mask = shiftleft(Ones,32 -$mask); } elsif ($mask == 32) { $mask = Ones; } else { return undef; # undoubtably an error } } elsif ($mask < 128) { $mask = shiftleft(Ones,128 -$mask); # small cidr } else { $mask = Ones(); } } else { $mask = bcd2bin($mask); } } elsif ($isCIDR && $mask < 33) { # is V4 # if ($ip && $noctal && $ip !~ m|(?:[^\s0123456789.])|) { # octal suppression required if not an IPv4 address # $mask = _no_octal($mask); # } if ($mask < 32) { $mask = shiftleft(Ones,32 -$mask); } elsif ( $mask == 32) { $mask = Ones; } else { $mask = bcd2bin($mask); $mask |= $_v4mask; # v4 always } } else { # also V4 $mask = bcd2bin($mask); $mask |= $_v4mask; } if ($try) { # is a big number $ip = $try; last; } } elsif ($mask =~ m/^\d+\.\d+\.\d+\.\d+$/) { # ipv4 form of mask $mask = _no_octal($mask) if $noctal; # filter for octal return undef unless defined ($mask = inet_aton($mask)); $mask = mask4to6($mask); } elsif (grep($mask eq $_,qw(default any broadcast loopback unspecified host))) { if (index($ip,':') < 0 && ! $isV6) { return undef unless defined ($mask = $fip4m{$mask}); } else { return undef unless defined ($mask = $fip6m{$mask}); } } else { return undef unless defined ($mask = ipv6_aton($mask)); # try ipv6 form of mask } # process remaining IP's if (index($ip,':') < 0) { # ipv4 address if ($ip =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) { ; # the common case } elsif (grep($ip eq $_,(qw(default any broadcast loopback)))) { return undef unless defined ($ip = $fip4{$ip}); last; } elsif ($ip =~ m/^(\d+)\.(\d+)$/) { $ip = ($hasmask) ? "${1}.${2}.0.0" : "${1}.0.0.${2}"; } elsif ($ip =~ m/^(\d+)\.(\d+)\.(\d+)$/) { $ip = ($hasmask) ? "${1}.${2}.${3}.0" : "${1}.${2}.0.${3}"; } elsif ($ip =~ /^(\d+)$/ && $hasmask && $1 >= 0 and $1 < 256) { # pure numeric $ip = sprintf("%d.0.0.0",$1); } # elsif ($ip =~ /^\d+$/ && !$hasmask) { # a big integer elsif ($ip =~ /^\d+$/ ) { # a big integer $ip = bcd2bin($ip); last; } # these next three might be broken??? but they have been in the code a long time and no one has complained elsif ($ip =~ /^0[xb]\d+$/ && $hasmask && (($tmp = eval "$ip") || 1) && $tmp >= 0 && $tmp < 256) { $ip = sprintf("%d.0.0.0",$tmp); } elsif ($ip =~ /^-?\d+$/) { $ip += 2 ** 32 if $ip < 0; $ip = pack('L3N',0,0,0,$ip); last; } elsif ($ip =~ /^-?0[xb]\d+$/) { $ip = eval "$ip"; $ip = pack('L3N',0,0,0,$ip); last; } # notations below include an implicit mask specification elsif ($ip =~ m/^(\d+)\.$/) { $ip = "${1}.0.0.0"; $mask = $ff000000; } elsif ($ip =~ m/^(\d+)\.(\d+)-(\d+)\.?$/ && $2 <= $3 && $3 < 256) { $ip = "${1}.${2}.0.0"; $mask = pack('L3C4',0xffffffff,0xffffffff,0xffffffff,255,_obits($2,$3),0,0); } elsif ($ip =~ m/^(\d+)-(\d+)\.?$/ and $1 <= $2 && $2 < 256) { $ip = "${1}.0.0.0"; $mask = pack('L3C4',0xffffffff,0xffffffff,0xffffffff,_obits($1,$2),0,0,0) } elsif ($ip =~ m/^(\d+)\.(\d+)\.$/) { $ip = "${1}.${2}.0.0"; $mask = $ffff0000; } elsif ($ip =~ m/^(\d+)\.(\d+)\.(\d+)-(\d+)\.?$/ && $3 <= $4 && $4 < 256) { $ip = "${1}.${2}.${3}.0"; $mask = pack('L3C4',0xffffffff,0xffffffff,0xffffffff,255,255,_obits($3,$4),0); } elsif ($ip =~ m/^(\d+)\.(\d+)\.(\d+)\.$/) { $ip = "${1}.${2}.${3}.0"; $mask = $ffffff00; } elsif ($ip =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)-(\d+)$/ && $4 <= $5 && $5 < 256) { $ip = "${1}.${2}.${3}.${4}"; $mask = pack('L3C4',0xffffffff,0xffffffff,0xffffffff,255,255,255,_obits($4,$5)); } elsif ($ip =~ m/^(\d+\.\d+\.\d+\.\d+) \s*-\s*(\d+\.\d+\.\d+\.\d+)$/x) { # if ($noctal) { # return undef unless ($ip = inet_aton(_no_octal($1))); # return undef unless ($tmp = inet_aton(_no_octal($2))); # } else { return undef unless ($ip = inet_aton($1)); return undef unless ($tmp = inet_aton($2)); # } # check for left side greater than right side # save numeric difference in $mask return undef if ($tmp = unpack('N',$tmp) - unpack('N',$ip)) < 0; $ip = ipv4to6($ip); $tmp = pack('L3N',0,0,0,$tmp); $mask = ~$tmp; return undef if notcontiguous($mask); # check for non-aligned left side return undef if hasbits($ip & $tmp); last; } # check for resolvable IPv4 hosts elsif (! $NoFQDN && $ip !~ /[^a-zA-Z0-9\._-]/ && ($tmp = gethostbyname(fillIPv4($ip))) && $tmp ne $_v4zero && $tmp ne $_zero ) { $ip = ipv4to6($tmp); last; } # check for resolvable IPv6 hosts elsif (! $NoFQDN && $ip !~ /[^a-zA-Z0-9\._-]/ && havegethostbyname2() && ($tmp = naip_gethostbyname($ip))) { $ip = $tmp; $isV6 = 1; last; } elsif ($Accept_Binary_IP && ! $hasmask) { if (length($ip) == 4) { $ip = ipv4to6($ip); } elsif (length($ip) == 16) { $isV6 = 1; } else { return undef; } last; } else { return undef; } return undef unless defined ($ip = inet_aton($ip)); $ip = ipv4to6($ip); last; } ########## continuing else { # ipv6 address $isV6 = 1; $ip = $1 if $ip =~ /\[([^\]]+)\]/; # transform URI notation if (defined ($tmp = ipv6_aton($ip))) { $ip = $tmp; last; } last if grep($ip eq $_,(qw(default any loopback unspecified))) && defined ($ip = $fip6{$ip}); return undef; } } # end while (1) return undef if notcontiguous($mask); # invalid if not contiguous my $self = { addr => $ip, mask => $mask, isv6 => $isV6, }; return bless $self, $class; } =item C<-E<gt>broadcast()> Returns a new object referring to the broadcast address of a given subnet. The broadcast address has all ones in all the bit positions where the netmask has zero bits. This is normally used to address all the hosts in a given subnet. =cut sub broadcast ($) { my $ip = _new($_[0],$_[0]->{addr} | ~$_[0]->{mask},$_[0]->{mask}); $ip->{addr} &= V4net unless $ip->{isv6}; return $ip; } =item C<-E<gt>network()> Returns a new object referring to the network address of a given subnet. A network address has all zero bits where the bits of the netmask are zero. Normally this is used to refer to a subnet. =cut sub network ($) { return _new($_[0],$_[0]->{addr} & $_[0]->{mask},$_[0]->{mask}); } =item C<-E<gt>addr()> Returns a scalar with the address part of the object as an IPv4 or IPv6 text string as appropriate. This is useful for printing or for passing the address part of the NetAddr::IP::Lite object to other components that expect an IP address. If the object is an ipV6 address or was created using ->new6($ip) it will be reported in ipV6 hex format otherwise it will be reported in dot quad format only if it resides in ipV4 address space. =cut sub addr ($) { return ($_[0]->{isv6}) ? ipv6_n2x($_[0]->{addr}) : inet_n2dx($_[0]->{addr}); } =item C<-E<gt>mask()> Returns a scalar with the mask as an IPv4 or IPv6 text string as described above. =cut sub mask ($) { return ipv6_n2x($_[0]->{mask}) if $_[0]->{isv6}; my $mask = isIPv4($_[0]->{addr}) ? $_[0]->{mask} & V4net : $_[0]->{mask}; return inet_n2dx($mask); } =item C<-E<gt>masklen()> Returns a scalar the number of one bits in the mask. =cut sub masklen ($) { my $len = (notcontiguous($_[0]->{mask}))[1]; return 0 unless $len; return $len if $_[0]->{isv6}; return isIPv4($_[0]->{addr}) ? $len -96 : $len; } =item C<-E<gt>bits()> Returns the width of the address in bits. Normally 32 for v4 and 128 for v6. =cut sub bits { return $_[0]->{isv6} ? 128 : 32; } =item C<-E<gt>version()> Returns the version of the address or subnet. Currently this can be either 4 or 6. =cut sub version { my $self = shift; return $self->{isv6} ? 6 : 4; } =item C<-E<gt>cidr()> Returns a scalar with the address and mask in CIDR notation. A NetAddr::IP::Lite object I<stringifies> to the result of this function. (see comments about ->new6() and ->addr() for output formats) =cut sub cidr ($) { return $_[0]->addr . '/' . $_[0]->masklen; } =item C<-E<gt>aton()> Returns the address part of the NetAddr::IP::Lite object in the same format as the C<inet_aton()> or C<ipv6_aton> function respectively. If the object was created using ->new6($ip), the address returned will always be in ipV6 format, even for addresses in ipV4 address space. =cut sub aton { return $_[0]->{addr} if $_[0]->{isv6}; return isIPv4($_[0]->{addr}) ? ipv6to4($_[0]->{addr}) : $_[0]->{addr}; } =item C<-E<gt>range()> Returns a scalar with the base address and the broadcast address separated by a dash and spaces. This is called range notation. =cut sub range ($) { return $_[0]->network->addr . ' - ' . $_[0]->broadcast->addr; } =item C<-E<gt>numeric()> When called in a scalar context, will return a numeric representation of the address part of the IP address. When called in an array context, it returns a list of two elements. The first element is as described, the second element is the numeric representation of the netmask. This method is essential for serializing the representation of a subnet. =cut sub numeric ($) { if (wantarray) { if (! $_[0]->{isv6} && isIPv4($_[0]->{addr})) { return ( sprintf("%u",unpack('N',ipv6to4($_[0]->{addr}))), sprintf("%u",unpack('N',ipv6to4($_[0]->{mask})))); } else { return ( bin2bcd($_[0]->{addr}), bin2bcd($_[0]->{mask})); } } return (! $_[0]->{isv6} && isIPv4($_[0]->{addr})) ? sprintf("%u",unpack('N',ipv6to4($_[0]->{addr}))) : bin2bcd($_[0]->{addr}); } =item C<-E<gt>bigint()> When called in a scalar context, will return a Math::BigInt representation of the address part of the IP address. When called in an array contest, it returns a list of two elements. The first element is as described, the second element is the Math::BigInt representation of the netmask. =cut my $biloaded; my $bi2strng; my $no_mbi_emu = 1; # function to force into test development mode # sub _force_bi_emu { undef $biloaded; undef $bi2strng; $no_mbi_emu = 0; print STDERR "\n\n\tWARNING: test development mode, this \tmessage SHOULD NEVER BE SEEN IN PRODUCTION! set my \$no_mbi_emu = 1 in t/bigint.t to remove this warning\n\n"; } # function to stringify various flavors of Math::BigInt objects # tests to see if the object is a hash or a signed scalar sub _bi_stfy { "$_[0]" =~ /(\d+)/; # stringify and remove '+' if present $1; } sub _fakebi2strg { ${$_[0]} =~ /(\d+)/; $1; } # fake new from bi string Math::BigInt 0.01 # sub _bi_fake { bless \('+'. $_[1]), 'Math::BigInt'; } # as of this writing there are three known flavors of Math::BigInt # v0.01 MBI::new returns a scalar ref # v1.?? - 1.69 CALC::_new takes a reference to a scalar, returns an array, MBI returns a hash ref # v1.70 and up CALC::_new takes a scalar, returns and array, MBI returns a hash ref sub _loadMBI { # load Math::BigInt on demand if (eval {$no_mbi_emu && require Math::BigInt}) { # any version should work, three known import Math::BigInt; $biloaded = \&Math::BigInt::new; $bi2strng = \&_bi_stfy; } else { $biloaded = \&_bi_fake; $bi2strng = \&_fakebi2strg; } } sub _retMBIstring { _loadMBI unless $biloaded; # load Math::BigInt on demand $bi2strng->(@_); } sub _biRef { _loadMBI unless $biloaded; # load Math::BigInt on demand $biloaded->('Math::BigInt',$_[0]); } sub bigint($) { my($addr,$mask); if (wantarray) { if (! $_[0]->{isv6} && isIPv4($_[0]->{addr})) { $addr = $_[0]->{addr} ? sprintf("%u",unpack('N',ipv6to4($_[0]->{addr}))) : 0; $mask = $_[0]->{mask} ? sprintf("%u",unpack('N',ipv6to4($_[0]->{mask}))) : 0; } else { $addr = $_[0]->{addr} ? bin2bcd($_[0]->{addr}) : 0; $mask = $_[0]->{mask} ? bin2bcd($_[0]->{mask}) : 0; } (_biRef($addr),_biRef($mask)); } else { # not wantarray if (! $_[0]->{isv6} && isIPv4($_[0]->{addr})) { $addr = $_[0]->{addr} ? sprintf("%u",unpack('N',ipv6to4($_[0]->{addr}))) : 0; } else { $addr = $_[0]->{addr} ? bin2bcd($_[0]->{addr}) : 0; } _biRef($addr); } } =item C<$me-E<gt>contains($other)> Returns true when C<$me> completely contains C<$other>. False is returned otherwise and C<undef> is returned if C<$me> and C<$other> are not both C<NetAddr::IP::Lite> objects. =cut sub contains ($$) { return within(@_[1,0]); } =item C<$me-E<gt>within($other)> The complement of C<-E<gt>contains()>. Returns true when C<$me> is completely contained within C<$other>, undef if C<$me> and C<$other> are not both C<NetAddr::IP::Lite> objects. =cut sub within ($$) { return 1 unless hasbits($_[1]->{mask}); # 0x0 contains everything my $netme = $_[0]->{addr} & $_[0]->{mask}; my $brdme = $_[0]->{addr} | ~ $_[0]->{mask}; my $neto = $_[1]->{addr} & $_[1]->{mask}; my $brdo = $_[1]->{addr} | ~ $_[1]->{mask}; return (sub128($netme,$neto) && sub128($brdo,$brdme)) ? 1 : 0; } =item C-E<gt>is_rfc1918()> Returns true when C<$me> is an RFC 1918 address. 10.0.0.0 - 10.255.255.255 (10/8 prefix) 172.16.0.0 - 172.31.255.255 (172.16/12 prefix) 192.168.0.0 - 192.168.255.255 (192.168/16 prefix) =cut my $ip_10 = NetAddr::IP::Lite->new('10.0.0.0/8'); my $ip_10n = $ip_10->{addr}; # already the right value my $ip_10b = $ip_10n | ~ $ip_10->{mask}; my $ip_172 = NetAddr::IP::Lite->new('172.16.0.0/12'); my $ip_172n = $ip_172->{addr}; # already the right value my $ip_172b = $ip_172n | ~ $ip_172->{mask}; my $ip_192 = NetAddr::IP::Lite->new('192.168.0.0/16'); my $ip_192n = $ip_192->{addr}; # already the right value my $ip_192b = $ip_192n | ~ $ip_192->{mask}; sub is_rfc1918 ($) { my $netme = $_[0]->{addr} & $_[0]->{mask}; my $brdme = $_[0]->{addr} | ~ $_[0]->{mask}; return 1 if (sub128($netme,$ip_10n) && sub128($ip_10b,$brdme)); return 1 if (sub128($netme,$ip_192n) && sub128($ip_192b,$brdme)); return (sub128($netme,$ip_172n) && sub128($ip_172b,$brdme)) ? 1 : 0; } =item C<-E<gt>is_local()> Returns true when C<$me> is a local network address. i.e. ipV4 127.0.0.0 - 127.255.255.255 or ipV6 === ::1 =cut my $_lclhost6 = NetAddr::IP::Lite->new('::1'); my $_lclnet = NetAddr::IP::Lite->new('127/8'); sub is_local ($) { return ($_[0]->{isv6}) ? $_[0] == $_lclhost6 : $_[0]->within($_lclnet); } =item C<-E<gt>first()> Returns a new object representing the first usable IP address within the subnet (ie, the first host address). =cut my $_cidr127 = pack('N4',0xffffffff,0xffffffff,0xffffffff,0xfffffffe); sub first ($) { if (hasbits($_[0]->{mask} ^ $_cidr127)) { return $_[0]->network + 1; } else { return $_[0]->network; } # return $_[0]->network + 1; } =item C<-E<gt>last()> Returns a new object representing the last usable IP address within the subnet (ie, one less than the broadcast address). =cut sub last ($) { if (hasbits($_[0]->{mask} ^ $_cidr127)) { return $_[0]->broadcast - 1; } else { return $_[0]->broadcast; } # return $_[0]->broadcast - 1; } =item C<-E<gt>nth($index)> Returns a new object representing the I<n>-th usable IP address within the subnet (ie, the I<n>-th host address). If no address is available (for example, when the network is too small for C<$index> hosts), C<undef> is returned. Version 4.00 of NetAddr::IP and version 1.00 of NetAddr::IP::Lite implements C<-E<gt>nth($index)> and C<-E<gt>num()> exactly as the documentation states. Previous versions behaved slightly differently and not in a consistent manner. To use the old behavior for C<-E<gt>nth($index)> and C<-E<gt>num()>: use NetAddr::IP::Lite qw(:old_nth); old behavior: NetAddr::IP->new('10/32')->nth(0) == undef NetAddr::IP->new('10/32')->nth(1) == undef NetAddr::IP->new('10/31')->nth(0) == undef NetAddr::IP->new('10/31')->nth(1) == 10.0.0.1/31 NetAddr::IP->new('10/30')->nth(0) == undef NetAddr::IP->new('10/30')->nth(1) == 10.0.0.1/30 NetAddr::IP->new('10/30')->nth(2) == 10.0.0.2/30 NetAddr::IP->new('10/30')->nth(3) == 10.0.0.3/30 Note that in each case, the broadcast address is represented in the output set and that the 'zero'th index is alway undef except for a point-to-point /31 or /127 network where there are exactly two addresses in the network. new behavior: NetAddr::IP->new('10/32')->nth(0) == 10.0.0.0/32 NetAddr::IP->new('10.1/32'->nth(0) == 10.0.0.1/32 NetAddr::IP->new('10/31')->nth(0) == 10.0.0.0/32 NetAddr::IP->new('10/31')->nth(1) == 10.0.0.1/32 NetAddr::IP->new('10/30')->nth(0) == 10.0.0.1/30 NetAddr::IP->new('10/30')->nth(1) == 10.0.0.2/30 NetAddr::IP->new('10/30')->nth(2) == undef Note that a /32 net always has 1 usable address while a /31 has exactly two usable addresses for point-to-point addressing. The first index (0) returns the address immediately following the network address except for a /31 or /127 when it return the network address. =cut sub nth ($$) { my $self = shift; my $count = shift; my $slash31 = ! hasbits($self->{mask} ^ $_cidr127); if ($Old_nth) { return undef if $slash31 && $count != 1; return undef if ($count < 1 or $count > $self->num ()); } elsif ($slash31) { return undef if ($count && $count != 1); # only index 0, 1 allowed for /31 } else { ++$count; return undef if ($count < 1 or $count > $self->num ()); } return $self->network + $count; } =item C<-E<gt>num()> As of version 4.42 of NetAddr::IP and version 1.27 of NetAddr::IP::Lite a /31 and /127 with return a net B<num> value of 2 instead of 0 (zero) for point-to-point networks. Version 4.00 of NetAddr::IP and version 1.00 of NetAddr::IP::Lite return the number of usable IP addresses within the subnet, not counting the broadcast or network address. Previous versions worked only for ipV4 addresses, returned a maximum span of 2**32 and returned the number of IP addresses not counting the broadcast address. (one greater than the new behavior) To use the old behavior for C<-E<gt>nth($index)> and C<-E<gt>num()>: use NetAddr::IP::Lite qw(:old_nth); WARNING: NetAddr::IP will calculate and return a numeric string for network ranges as large as 2**128. These values are TEXT strings and perl can treat them as integers for numeric calculations. Perl on 32 bit platforms only handles integer numbers up to 2**32 and on 64 bit platforms to 2**64. If you wish to manipulate numeric strings returned by NetAddr::IP that are larger than 2**32 or 2**64, respectively, you must load additional modules such as Math::BigInt, bignum or some similar package to do the integer math. =cut sub num ($) { if ($Old_nth) { my @net = unpack('L3N',$_[0]->{mask} ^ Ones); # number of ip's less broadcast return 0xfffffffe if $net[0] || $net[1] || $net[2]; # 2**32 -1 return $net[3] if $net[3]; } else { # returns 1 for /32 /128, 2 for /31 /127 else n-2 up to 2**32 (undef, my $net) = addconst($_[0]->{mask},1); return 1 unless hasbits($net); # ipV4/32 or ipV6/128 $net = $net ^ Ones; return 2 unless hasbits($net); # ipV4/31 or ipV6/127 $net &= $_v4net unless $_[0]->{isv6}; return bin2bcd($net); } } # deprecated #sub num ($) { # my @net = unpack('L3N',$_[0]->{mask} ^ Ones); # if ($Old_nth) { ## number of ip's less broadcast # return 0xfffffffe if $net[0] || $net[1] || $net[2]; # 2**32 -1 # return $net[3] if $net[3]; # } else { # returns 1 for /32 /128, 0 for /31 /127 else n-2 up to 2**32 ## number of usable IP's === number of ip's less broadcast & network addys # return 0xfffffffd if $net[0] || $net[1] || $net[2]; # 2**32 -2 # return 1 unless $net[3]; # $net[3]--; # } # return $net[3]; #} =pod =back =cut sub import { if (grep { $_ eq ':aton' } @_) { $Accept_Binary_IP = 1; @_ = grep { $_ ne ':aton' } @_; } if (grep { $_ eq ':old_nth' } @_) { $Old_nth = 1; @_ = grep { $_ ne ':old_nth' } @_; } if (grep { $_ eq ':lower' } @_) { NetAddr::IP::Util::lower(); @_ = grep { $_ ne ':lower' } @_; } if (grep { $_ eq ':upper' } @_) { NetAddr::IP::Util::upper(); @_ = grep { $_ ne ':upper' } @_; } if (grep { $_ eq ':nofqdn' } @_) { $NoFQDN = 1; @_ = grep { $_ ne ':nofqdn' } @_; } NetAddr::IP::Lite->export_to_level(1, @_); } =head1 EXPORT_OK Zeros Ones V4mask V4net :aton DEPRECATED :old_nth :upper :lower :nofqdn =head1 AUTHORS Luis E. Muñoz E<lt>luismunoz@cpan.orgE<gt>, Michael Robinton E<lt>michael@bizsystems.comE<gt> =head1 WARRANTY This software comes with the same warranty as perl itself (ie, none), so by using it you accept any and all the liability. =head1 COPYRIGHT This software is (c) Luis E. Muñoz, 1999 - 2005 and (c) Michael Robinton, 2006 - 2014. All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version, or b) the "Artistic License" which comes with this distribution. 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 either the GNU General Public License or the Artistic License for more details. You should have received a copy of the Artistic License with this distribution, in the file named "Artistic". If not, I'll be glad to provide one. You should also have received a copy of the GNU General Public License along with this program in the file named "Copying". If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor Boston, MA 02110-1301 USA or visit their web page on the internet at: http://www.gnu.org/copyleft/gpl.html. =head1 SEE ALSO NetAddr::IP(3), NetAddr::IP::Util(3), NetAddr::IP::InetBase(3) =cut 1; 5.32/NetAddr/IP/Util.pm 0000444 00000053776 15125513451 0010261 0 ustar 00 #!/usr/bin/perl package NetAddr::IP::Util; use strict; #use diagnostics; #use lib qw(blib/lib); use vars qw($VERSION @EXPORT_OK @ISA %EXPORT_TAGS $Mode); use AutoLoader qw(AUTOLOAD); use NetAddr::IP::Util_IS; use NetAddr::IP::InetBase qw( :upper :all ); *NetAddr::IP::Util::upper = \&NetAddr::IP::InetBase::upper; *NetAddr::IP::Util::lower = \&NetAddr::IP::InetBase::lower; require DynaLoader; require Exporter; @ISA = qw(Exporter DynaLoader); $VERSION = do { my @r = (q$Revision: 1.53 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; @EXPORT_OK = qw( inet_aton inet_ntoa ipv6_aton ipv6_ntoa ipv6_n2x ipv6_n2d inet_any2n hasbits isIPv4 isNewIPv4 isAnyIPv4 inet_n2dx inet_n2ad inet_pton inet_ntop inet_4map6 shiftleft addconst add128 sub128 notcontiguous bin2bcd bcd2bin mode ipv4to6 mask4to6 ipanyto6 maskanyto6 ipv6to4 bin2bcdn bcdn2txt bcdn2bin simple_pack comp128 packzeros AF_INET AF_INET6 naip_gethostbyname havegethostbyname2 ); %EXPORT_TAGS = ( all => [@EXPORT_OK], inet => [qw( inet_aton inet_ntoa ipv6_aton ipv6_ntoa ipv6_n2x ipv6_n2d inet_any2n inet_n2dx inet_n2ad inet_pton inet_ntop inet_4map6 ipv4to6 mask4to6 ipanyto6 maskanyto6 ipv6to4 packzeros naip_gethostbyname )], math => [qw( shiftleft hasbits isIPv4 isNewIPv4 isAnyIPv4 addconst add128 sub128 notcontiguous bin2bcd bcd2bin )], ipv4 => [qw( inet_aton inet_ntoa )], ipv6 => [qw( ipv6_aton ipv6_ntoa ipv6_n2x ipv6_n2d inet_any2n inet_n2dx inet_n2ad inet_pton inet_ntop inet_4map6 ipv4to6 mask4to6 ipanyto6 maskanyto6 ipv6to4 packzeros naip_gethostbyname )], ); if (NetAddr::IP::Util_IS->not_pure) { eval { ## attempt to load 'C' version of utilities bootstrap NetAddr::IP::Util $VERSION; }; } if (NetAddr::IP::Util_IS->pure || $@) { ## load the pure perl version if 'C' lib missing require NetAddr::IP::UtilPP; import NetAddr::IP::UtilPP qw( :all ); # require Socket; # import Socket qw(inet_ntoa); # *yinet_aton = \&Socket::inet_aton; $Mode = 'Pure Perl'; } else { $Mode = 'CC XS'; } # if Socket lib is broken in some way, check for overange values # #my $overange = yinet_aton('256.1') ? 1:0; #my $overange = gethostbyname('256.1') ? 1:0; sub mode() { $Mode }; my $_newV4compat = pack('N4',0,0,0xffff,0); sub inet_4map6 { my $naddr = shift; if (length($naddr) == 4) { $naddr = ipv4to6($naddr); } elsif (length($naddr) == 16) { ; # is OK return undef unless isAnyIPv4($naddr); } else { return undef; } $naddr |= $_newV4compat; return $naddr; } sub DESTROY {}; my $havegethostbyname2 = 0; my $mygethostbyname; my $_Sock6ok = 1; # for testing gethostbyname sub havegethostbyname2 { return $_Sock6ok ? $havegethostbyname2 : 0; } sub import { if (grep { $_ eq ':noSock6' } @_) { $_Sock6ok = 0; @_ = grep { $_ ne ':noSock6' } @_; } NetAddr::IP::Util->export_to_level(1,@_); } package NetAddr::IP::UtilPolluted; # Socket pollutes the name space with all of its symbols. Since # we don't want them all, confine them to this name space. use strict; use Socket; my $_v4zero = pack('L',0); my $_zero = pack('L4',0,0,0,0); # invoke replacement subroutine for Perl's "gethostbyname" # if Socket6 is available. # # NOTE: in certain BSD implementations, Perl's gethostbyname is broken # we will use our own InetBase::inet_aton instead sub _end_gethostbyname { # my ($name,$aliases,$addrtype,$length,@addrs) = @_; my @rv = @_; # first ip address = rv[4] my $tip = $rv[4]; unless ($tip && $tip ne $_v4zero && $tip ne $_zero) { @rv = (); } # length = rv[3] elsif ($rv[3] && $rv[3] == 4) { foreach (4..$#rv) { $rv[$_] = NetAddr::IP::Util::inet_4map6(NetAddr::IP::Util::ipv4to6($rv[$_])); } $rv[3] = 16; # unconditionally set length to 16 } elsif ($rv[3] == 16) { ; # is ok } else { @rv = (); } return @rv; } unless ( eval { require Socket6 }) { $mygethostbyname = sub { # SEE NOTE above about broken BSD my @tip = gethostbyname(NetAddr::IP::InetBase::fillIPv4($_[0])); return &_end_gethostbyname(@tip); }; } else { import Socket6 qw( gethostbyname2 getipnodebyname ); my $try = eval { my @try = gethostbyname2('127.0.0.1',NetAddr::IP::Util::AF_INET()); $try[4] }; if (! $@ && $try && $try eq INADDR_LOOPBACK()) { *_ghbn2 = \&Socket6::gethostbyname2; $havegethostbyname2 = 1; } else { *_ghbn2 = sub { return () }; # use failure branch below } $mygethostbyname = sub { my @tip; unless ($_Sock6ok && (@tip = _ghbn2($_[0],NetAddr::IP::Util::AF_INET6())) && @tip > 1) { # SEE NOTE above about broken BSD @tip = gethostbyname(NetAddr::IP::InetBase::fillIPv4($_[0])); } return &_end_gethostbyname(@tip); }; } package NetAddr::IP::Util; sub naip_gethostbyname { # turn off complaint from Socket6 about missing numeric argument undef local $^W; my @rv = &$mygethostbyname($_[0]); return wantarray ? @rv : $rv[4]; } 1; __END__ =head1 NAME NetAddr::IP::Util -- IPv4/6 and 128 bit number utilities =head1 SYNOPSIS use NetAddr::IP::Util qw( inet_aton inet_ntoa ipv6_aton ipv6_ntoa ipv6_n2x ipv6_n2d inet_any2n hasbits isIPv4 isNewIPv4 isAnyIPv4 inet_n2dx inet_n2ad inet_pton inet_ntop inet_4map6 ipv4to6 mask4to6 ipanyto6 maskanyto6 ipv6to4 packzeros shiftleft addconst add128 sub128 notcontiguous bin2bcd bcd2bin mode AF_INET AF_INET6 naip_gethostbyname ); use NetAddr::IP::Util qw(:all :inet :ipv4 :ipv6 :math) :inet => inet_aton, inet_ntoa, ipv6_aton ipv6_ntoa, ipv6_n2x, ipv6_n2d, inet_any2n, inet_n2dx, inet_n2ad, inet_pton, inet_ntop, inet_4map6, ipv4to6, mask4to6, ipanyto6, packzeros maskanyto6, ipv6to4, naip_gethostbyname :ipv4 => inet_aton, inet_ntoa :ipv6 => ipv6_aton, ipv6_ntoa, ipv6_n2x, ipv6_n2d, inet_any2n, inet_n2dx, inet_n2ad, inet_pton, inet_ntop, inet_4map6, ipv4to6, mask4to6, ipanyto6, maskanyto6, ipv6to4, packzeros, naip_gethostbyname :math => hasbits, isIPv4, isNewIPv4, isAnyIPv4, addconst, add128, sub128, notcontiguous, bin2bcd, bcd2bin, shiftleft $dotquad = inet_ntoa($netaddr); $netaddr = inet_aton($dotquad); $ipv6naddr = ipv6_aton($ipv6_text); $ipv6_text = ipvt_ntoa($ipv6naddr); $hex_text = ipv6_n2x($ipv6naddr); $dec_text = ipv6_n2d($ipv6naddr); $hex_text = packzeros($hex_text); $ipv6naddr = inet_any2n($dotquad or $ipv6_text); $ipv6naddr = inet_4map6($netaddr or $ipv6naddr); $rv = hasbits($bits128); $rv = isIPv4($bits128); $rv = isNewIPv4($bits128); $rv = isAnyIPv4($bits128); $dotquad or $hex_text = inet_n2dx($ipv6naddr); $dotquad or $dec_text = inet_n2ad($ipv6naddr); $netaddr = inet_pton($AF_family,$hex_text); $hex_text = inet_ntop($AF_family,$netaddr); $ipv6naddr = ipv4to6($netaddr); $ipv6naddr = mask4to6($netaddr); $ipv6naddr = ipanyto6($netaddr); $ipv6naddr = maskanyto6($netaddr); $netaddr = ipv6to4($pv6naddr); $bitsX2 = shiftleft($bits128,$n); $carry = addconst($ipv6naddr,$signed_32con); ($carry,$ipv6naddr)=addconst($ipv6naddr,$signed_32con); $carry = add128($ipv6naddr1,$ipv6naddr2); ($carry,$ipv6naddr)=add128($ipv6naddr1,$ipv6naddr2); $carry = sub128($ipv6naddr1,$ipv6naddr2); ($carry,$ipv6naddr)=sub128($ipv6naddr1,$ipv6naddr2); ($spurious,$cidr) = notcontiguous($mask128); $bcdtext = bin2bcd($bits128); $bits128 = bcd2bin($bcdtxt); $modetext = mode; ($name,$aliases,$addrtype,$length,@addrs)=naip_gethostbyname(NAME); $trueif = havegethostbyname2(); NetAddr::IP::Util::lower(); NetAddr::IP::Util::upper(); =head1 INSTALLATION Un-tar the distribution in an appropriate directory and type: perl Makefile.PL make make test make install B<NetAddr::IP::Util> installs by default with its primary functions compiled using Perl's XS extensions to build a 'C' library. If you do not have a 'C' complier available or would like the slower Pure Perl version for some other reason, then type: perl Makefile.PL -noxs make make test make install =head1 DESCRIPTION B<NetAddr::IP::Util> provides a suite of tools for manipulating and converting IPv4 and IPv6 addresses into 128 bit string context and back to text. The strings can be manipulated with Perl's logical operators: and & or | xor ^ ~ compliment in the same manner as 'vec' strings. The IPv6 functions support all rfc1884 formats. i.e. x:x:x:x:x:x:x:x:x x:x:x:x:x:x:x:d.d.d.d ::x:x:x ::x:d.d.d.d and so on... =over 4 =item * $dotquad = inet_ntoa($netaddr); Convert a packed IPv4 network address to a dot-quad IP address. input: packed network address returns: IP address i.e. 10.4.12.123 =item * $netaddr = inet_aton($dotquad); Convert a dot-quad IP address into an IPv4 packed network address. input: IP address i.e. 192.5.16.32 returns: packed network address =item * $ipv6addr = ipv6_aton($ipv6_text); Takes an IPv6 address of the form described in rfc1884 and returns a 128 bit binary RDATA string. input: ipv6 text returns: 128 bit RDATA string =item * $ipv6_text = ipv6_ntoa($ipv6naddr); Convert a 128 bit binary IPv6 address to compressed rfc 1884 text representation. input: 128 bit RDATA string returns: ipv6 text =item * $hex_text = ipv6_n2x($ipv6addr); Takes an IPv6 RDATA string and returns an 8 segment IPv6 hex address input: 128 bit RDATA string returns: x:x:x:x:x:x:x:x =item * $dec_text = ipv6_n2d($ipv6addr); Takes an IPv6 RDATA string and returns a mixed hex - decimal IPv6 address with the 6 uppermost chunks in hex and the lower 32 bits in dot-quad representation. input: 128 bit RDATA string returns: x:x:x:x:x:x:d.d.d.d =item * $ipv6naddr = inet_any2n($dotquad or $ipv6_text); This function converts a text IPv4 or IPv6 address in text format in any standard notation into a 128 bit IPv6 string address. It prefixes any dot-quad address (if found) with '::' and passes it to B<ipv6_aton>. input: dot-quad or rfc1844 address returns: 128 bit IPv6 string =item * $rv = hasbits($bits128); This function returns true if there are one's present in the 128 bit string and false if all the bits are zero. i.e. if (hasbits($bits128)) { &do_something; } or if (hasbits($bits128 & $mask128) { &do_something; } This allows the implementation of logical functions of the form of: if ($bits128 & $mask128) { ... input: 128 bit IPv6 string returns: true if any bits are present =item * $ipv6naddr = inet_4map6($netaddr or $ipv6naddr This function returns an ipV6 network address with the first 80 bits set to zero and the next 16 bits set to one, while the last 32 bits are filled with the ipV4 address. input: ipV4 netaddr or ipV6 netaddr returns: ipV6 netaddr returns: undef on error An ipV6 network address must be in one of the two compatible ipV4 mapped address spaces. i.e. ::ffff::d.d.d.d or ::d.d.d.d =item * $rv = isIPv4($bits128); This function returns true if there are no on bits present in the IPv6 portion of the 128 bit string and false otherwise. i.e. the address must be of the form - ::d.d.d.d Note: this is an old and deprecated ipV4 compatible ipV6 address =item * $rv = isNewIPv4($bits128); This function return true if the IPv6 128 bit string is of the form ::ffff::d.d.d.d =item * $rv = isAnyIPv4($bits128); This function return true if the IPv6 bit string is of the form ::d.d.d.d or ::ffff::d.d.d.d =item * $dotquad or $hex_text = inet_n2dx($ipv6naddr); This function B<does the right thing> and returns the text for either a dot-quad IPv4 or a hex notation IPv6 address. input: 128 bit IPv6 string returns: ddd.ddd.ddd.ddd or x:x:x:x:x:x:x:x =item * $dotquad or $dec_text = inet_n2ad($ipv6naddr); This function B<does the right thing> and returns the text for either a dot-quad IPv4 or a hex::decimal notation IPv6 address. input: 128 bit IPv6 string returns: ddd.ddd.ddd.ddd or x:x:x:x:x:x:ddd.ddd.ddd.dd =item * $netaddr = inet_pton($AF_family,$hex_text); This function takes an IP address in IPv4 or IPv6 text format and converts it into binary format. The type of IP address conversion is controlled by the FAMILY argument. =item * $hex_text = inet_ntop($AF_family,$netaddr); This function takes and IP address in binary format and converts it into text format. The type of IP address conversion is controlled by the FAMILY argument. NOTE: inet_ntop ALWAYS returns lowercase characters. =item * $hex_text = packzeros($hex_text); This function optimizes and rfc 1884 IPv6 hex address to reduce the number of long strings of zero bits as specified in rfc 1884, 2.2 (2) by substituting B<::> for the first occurence of the longest string of zeros in the address. =item * $ipv6naddr = ipv4to6($netaddr); Convert an ipv4 network address into an IPv6 network address. input: 32 bit network address returns: 128 bit network address =item * $ipv6naddr = mask4to6($netaddr); Convert an ipv4 network address/mask into an ipv6 network mask. input: 32 bit network/mask address returns: 128 bit network/mask address NOTE: returns the high 96 bits as one's =item * $ipv6naddr = ipanyto6($netaddr); Similar to ipv4to6 except that this function takes either an IPv4 or IPv6 input and always returns a 128 bit IPv6 network address. input: 32 or 128 bit network address returns: 128 bit network address =item * $ipv6naddr = maskanyto6($netaddr); Similar to mask4to6 except that this function takes either an IPv4 or IPv6 netmask and always returns a 128 bit IPv6 netmask. input: 32 or 128 bit network mask returns: 128 bit network mask =item * $netaddr = ipv6to4($pv6naddr); Truncate the upper 96 bits of a 128 bit address and return the lower 32 bits. Returns an IPv4 address as returned by inet_aton. input: 128 bit network address returns: 32 bit inet_aton network address =item * $bitsXn = shiftleft($bits128,$n); input: 128 bit string variable, number of shifts [optional] returns: bits X n shifts NOTE: a single shift is performed if $n is not specified =item * addconst($ipv6naddr,$signed_32con); Add a signed constant to a 128 bit string variable. input: 128 bit IPv6 string, signed 32 bit integer returns: scalar carry array (carry, result) =item * add128($ipv6naddr1,$ipv6naddr2); Add two 128 bit string variables. input: 128 bit string var1, 128 bit string var2 returns: scalar carry array (carry, result) =item * sub128($ipv6naddr1,$ipv6naddr2); Subtract two 128 bit string variables. input: 128 bit string var1, 128 bit string var2 returns: scalar carry array (carry, result) Note: The carry from this operation is the result of adding the one's complement of ARG2 +1 to the ARG1. It is logically B<NOT borrow>. i.e. if ARG1 >= ARG2 then carry = 1 or if ARG1 < ARG2 then carry = 0 =item * ($spurious,$cidr) = notcontiguous($mask128); This function counts the bit positions remaining in the mask when the rightmost '0's are removed. input: 128 bit netmask returns true if there are spurious zero bits remaining in the mask, false if the mask is contiguous one's, 128 bit cidr number =item * $bcdtext = bin2bcd($bits128); Convert a 128 bit binary string into binary coded decimal text digits. input: 128 bit string variable returns: string of bcd text digits =item * $bits128 = bcd2bin($bcdtxt); Convert a bcd text string to 128 bit string variable input: string of bcd text digits returns: 128 bit string variable =cut #=item * $onescomp=NetAddr::IP::Util::comp128($ipv6addr); # #This function is not exported because it is more efficient to use perl " ~ " #on the bit string directly. This interface to the B<C> routine is published for #module testing purposes because it is used internally in the B<sub128> routine. The #function is very fast, but calling if from perl directly is very slow. It is almost #33% faster to use B<sub128> than to do a 1's comp with perl and then call #B<add128>. # #=item * $bcdpacked = NetAddr::IP::Util::bin2bcdn($bits128); # #Convert a 128 bit binary string into binary coded decimal digits. #This function is not exported. # # input: 128 bit string variable # returns: string of packed decimal digits # # i.e. text = unpack("H*", $bcd); # #=item * $bcdtext = NetAddr::IP::Util::bcdn2txt($bcdpacked); # #Convert a packed bcd string into text digits, suppress the leading zeros. #This function is not exported. # # input: string of packed decimal digits # returns: hexadecimal digits # #Similar to unpack("H*", $bcd); # #=item * $bcdpacked = NetAddr::IP::Util::simple_pack($bcdtext); # #Convert a numeric string into a packed bcd string, left fill with zeros # # input: string of decimal digits # returns: string of packed decimal digits # #Similar to pack("H*", $bcdtext); =item * $modetext = mode; Returns the operating mode of this module. input: none returns: "Pure Perl" or "CC XS" =item * ($name,$aliases,$addrtype,$length,@addrs)=naip_gethostbyname(NAME); Replacement for Perl's gethostbyname if Socket6 is available In ARRAY context, returns a list of five elements, the hostname or NAME, a space separated list of C_NAMES, AF family, length of the address structure, and an array of one or more netaddr's In SCALAR context, returns the first netaddr. This function ALWAYS returns an IPv6 address, even on IPv4 only systems. IPv4 addresses are mapped into IPv6 space in the form: ::FFFF:FFFF:d.d.d.d This is NOT the expected result from Perl's gethostbyname2. It is instead equivalent to: On an IPv4 only system: $ipv6naddr = ipv4to6 scalar ( gethostbyname( name )); On a system with Socket6 and a working gethostbyname2: $ipv6naddr = gethostbyname2( name, AF_INET6 ); and if that fails, the IPv4 conversion above. For a gethostbyname2 emulator that behave like Socket6, see: L<Net::DNS::Dig> =item * $trueif = havegethostbyname2(); This function returns TRUE if Socket6 has a functioning B<gethostbyname2>, otherwise it returns FALSE. See the comments above about the behavior of B<naip_gethostbyname>. =item * NetAddr::IP::Util::lower(); Return IPv6 strings in lowercase. =item * NetAddr::IP::Util::upper(); Return IPv6 strings in uppercase. This is the default. =back =head1 EXAMPLES # convert any textual IP address into a 128 bit vector # sub text2vec { my($anyIP,$anyMask) = @_; # not IPv4 bit mask my $notiv4 = ipv6_aton('FFFF:FFFF:FFFF:FFFF:FFFF:FFFF::'); my $vecip = inet_any2n($anyIP); my $mask = inet_any2n($anyMask); # extend mask bits for IPv4 my $bits = 128; # default unless (hasbits($mask & $notiv4)) { $mask |= $notiv4; $bits = 32; } return ($vecip, $mask, $bits); } ... alternate implementation, a little faster sub text2vec { my($anyIP,$anyMask) = @_; # not IPv4 bit mask my $notiv4 = ipv6_aton('FFFF:FFFF:FFFF:FFFF:FFFF:FFFF::'); my $vecip = inet_any2n($anyIP); my $mask = inet_any2n($anyMask); # extend mask bits for IPv4 my $bits = 128; # default if (isIPv4($mask)) { $mask |= $notiv4; $bits = 32; } return ($vecip, $mask, $bits); } ... elsewhere $nip = { addr => $vecip, mask => $mask, bits => $bits, }; # return network and broadcast addresses from IP and Mask # sub netbroad { my($nip) = shift; my $notmask = ~ $nip->{mask}; my $bcast = $nip->{addr} | $notmask; my $network = $nip->{addr} & $nip->{mask}; return ($network, $broadcast); } # check if address is within a network # sub within { my($nip,$net) = @_; my $addr = $nip->{addr} my($nw,$bc) = netbroad($net); # arg1 >= arg2, sub128 returns true return (sub128($addr,$nw) && sub128($bc,$addr)) ? 1 : 0; } # truely hard way to do $ip++ # add a constant, wrapping at netblock boundaries # to subtract the constant, negate it before calling # 'addwrap' since 'addconst' will extend the sign bits # sub addwrap { my($nip,$const) = @_; my $addr = $nip->{addr}; my $mask = $nip->{mask}; my $bits = $nip->{bits}; my $notmask = ~ $mask; my $hibits = $addr & $mask; $addr = addconst($addr,$const); my $wraponly = $addr & $notmask; my $newip = { addr => $hibits | $wraponly, mask => $mask, bits => $bits, }; # bless $newip as appropriate return $newip; } # something more useful # increment a /24 net to the NEXT net at the boundry my $nextnet = 256; # for /24 LOOP: while (...continuing) { your code.... ... my $lastip = $ip-copy(); $ip++; if ($ip < $lastip) { # host part wrapped? # discard carry (undef, $ip->{addr} = addconst($ip->{addr}, $nextnet); } next LOOP; } =head1 EXPORT_OK inet_aton inet_ntoa ipv6_aton ipv6_ntoa ipv6_n2x ipv6_n2d inet_any2n hasbits isIPv4 isNewIPv4 isAnyIPv4 inet_n2dx inet_n2ad inet_pton inet_ntop inet_4map6 ipv4to6 mask4to6 ipanyto6 maskanyto6 ipv6to4 packzeros shiftleft addconst add128 sub128 notcontiguous bin2bcd bcd2bin mode naip_gethostbyname havegethostbyname2 =head1 AUTHOR Michael Robinton <michael@bizsystems.com> =head1 COPYRIGHT Copyright 2003 - 2014, Michael Robinton E<lt>michael@bizsystems.comE<gt> All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version, or b) the "Artistic License" which comes with this distribution. 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 either the GNU General Public License or the Artistic License for more details. You should have received a copy of the Artistic License with this distribution, in the file named "Artistic". If not, I'll be glad to provide one. You should also have received a copy of the GNU General Public License along with this program in the file named "Copying". If not, write to the Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor Boston, MA 02110-1301 USA. or visit their web page on the internet at: http://www.gnu.org/copyleft/gpl.html. =head1 AUTHOR Michael Robinton <michael@bizsystems.com> =head1 SEE ALSO NetAddr::IP(3), NetAddr::IP::Lite(3), NetAddr::IP::InetBase(3) =cut 1; 5.32/NetAddr/IP/Util_IS.pm 0000444 00000001330 15125513451 0010627 0 ustar 00 #!/usr/bin/perl # # DO NOT ALTER THIS FILE # IT IS WRITTEN BY Makefile.PL # EDIT THAT INSTEAD # package NetAddr::IP::Util_IS; use vars qw($VERSION); $VERSION = 1.00; sub pure { return 0; } sub not_pure { return 1; } 1; __END__ =head1 NAME NetAddr::IP::Util_IS - Tell about Pure Perl =head1 SYNOPSIS use NetAddr::IP::Util_IS; $rv = NetAddr::IP::Util_IS->pure; $rv = NetAddr::IP::Util_IS->not_pure; =head1 DESCRIPTION Util_IS indicates whether or not B<NetAddr::IP::Util> was compiled in Pure Perl mode. =over 4 =item * $rv = NetAddr::IP::Util_IS->pure; Returns true if PurePerl mode, else false. =item * $rv = NetAddr::IP::Util_IS->not_pure; Returns true if NOT PurePerl mode, else false =back =cut 1; 5.32/NetAddr/IP/InetBase.pm 0000444 00000045421 15125513451 0011022 0 ustar 00 #!/usr/bin/perl package NetAddr::IP::InetBase; use strict; #use diagnostics; #use lib qw(blib lib); use vars qw($VERSION @EXPORT_OK @ISA %EXPORT_TAGS $Mode); use AutoLoader qw(AUTOLOAD); require Exporter; @ISA = qw(Exporter); $VERSION = do { my @r = (q$Revision: 0.08 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; @EXPORT_OK = qw( inet_aton inet_ntoa ipv6_aton ipv6_ntoa ipv6_n2x ipv6_n2d inet_any2n inet_n2dx inet_n2ad inet_ntop inet_pton packzeros isIPv4 isNewIPv4 isAnyIPv4 AF_INET AF_INET6 fake_AF_INET6 fillIPv4 ); %EXPORT_TAGS = ( all => [@EXPORT_OK], ipv4 => [qw( inet_aton inet_ntoa fillIPv4 )], ipv6 => [qw( ipv6_aton ipv6_ntoa ipv6_n2x ipv6_n2d inet_any2n inet_n2dx inet_n2ad inet_pton inet_ntop packzeros )], ); # prototypes sub inet_ntoa; sub ipv6_aton; sub ipv6_ntoa; sub inet_any2n($); sub inet_n2dx($); sub inet_n2ad($); sub _inet_ntop; sub _inet_pton; my $emulateAF_INET6 = 0; { no warnings 'once'; *packzeros = \&_packzeros; ## dynamic configuraton for IPv6 require Socket; *AF_INET = \&Socket::AF_INET; if (eval { AF_INET6() } ) { *AF_INET6 = \&Socket::AF_INET6; $emulateAF_INET6 = -1; # have it, remind below } if (eval{ require Socket6 } ) { import Socket6 qw( inet_pton inet_ntop ); unless ($emulateAF_INET6) { *AF_INET6 = \&Socket6::AF_INET6; } $emulateAF_INET6 = 0; # clear, have it from elsewhere or here } else { unless ($emulateAF_INET6) { # unlikely at this point if ($^O =~ /(?:free|dragon.+)bsd/i) { # FreeBSD, DragonFlyBSD $emulateAF_INET6 = 28; } elsif ($^O =~ /bsd/i) { # other BSD flavors like NetBDS, OpenBSD, BSD $emulateAF_INET6 = 24; } elsif ($^O =~ /(?:darwin|mac)/i) { # Mac OS X $emulateAF_INET6 = 30; } elsif ($^O =~ /win/i) { # Windows $emulateAF_INET6 = 23; } elsif ($^O =~ /(?:solaris|sun)/i) { # Sun box $emulateAF_INET6 = 26; } else { # use linux default $emulateAF_INET6 = 10; } *AF_INET6 = sub { $emulateAF_INET6; }; } else { $emulateAF_INET6 = 0; # clear, have it from elsewhere } *inet_pton = \&_inet_pton; *inet_ntop = \&_inet_ntop; } } # end no warnings 'once' sub fake_AF_INET6 { return $emulateAF_INET6; } # allow user to choose upper or lower case BEGIN { use vars qw($n2x_format $n2d_format); $n2x_format = "%x:%x:%x:%x:%x:%x:%x:%x"; $n2d_format = "%x:%x:%x:%x:%x:%x:%d.%d.%d.%d"; } my $case = 0; # default lower case sub upper { $n2x_format = uc($n2x_format); $n2d_format = uc($n2d_format); $case = 1; } sub lower { $n2x_format = lc($n2x_format); $n2d_format = lc($n2d_format); $case = 0; } sub ipv6_n2x { die "Bad arg length for 'ipv6_n2x', length is ". length($_[0]) ." should be 16" unless length($_[0]) == 16; return sprintf($n2x_format,unpack("n8",$_[0])); } sub ipv6_n2d { die "Bad arg length for 'ipv6_n2d', length is ". length($_[0]) ." should be 16" unless length($_[0]) == 16; my @hex = (unpack("n8",$_[0])); $hex[9] = $hex[7] & 0xff; $hex[8] = $hex[7] >> 8; $hex[7] = $hex[6] & 0xff; $hex[6] >>= 8; return sprintf($n2d_format,@hex); } # if Socket lib is broken in some way, check for overange values # #my $overange = yinet_aton('256.1') ? 1:0; #my $overange = gethostbyname('256.1') ? 1:0; #sub inet_aton { # unless (! $overange || $_[0] =~ /[^0-9\.]/) { # hostname # my @dq = split(/\./,$_[0]); # foreach (@dq) { # return undef if $_ > 255; # } # } # scalar gethostbyname($_[0]); #} sub fillIPv4 { my $host = $_[0]; return undef unless defined $host; if ($host =~ /^(\d+)(?:|\.(\d+)(?:|\.(\d+)(?:|\.(\d+))))$/) { if (defined $4) { return undef unless $1 >= 0 && $1 < 256 && $2 >= 0 && $2 < 256 && $3 >= 0 && $3 < 256 && $4 >= 0 && $4 < 256; $host = $1.'.'.$2.'.'.$3.'.'.$4; # return pack('C4',$1,$2,$3,$4); # $host = ($1 << 24) + ($2 << 16) + ($3 << 8) + $4; } elsif (defined $3) { return undef unless $1 >= 0 && $1 < 256 && $2 >= 0 && $2 < 256 && $3 >= 0 && $3 < 256; $host = $1.'.'.$2.'.0.'.$3 # return pack('C4',$1,$2,0,$3); # $host = ($1 << 24) + ($2 << 16) + $3; } elsif (defined $2) { return undef unless $1 >= 0 && $1 < 256 && $2 >= 0 && $2 < 256; $host = $1.'.0.0.'.$2; # return pack('C4',$1,0,0,$2); # $host = ($1 << 24) + $2; } else { $host = '0.0.0.'.$1; # return pack('C4',0,0,0,$1); # $host = $1; } # return pack('N',$host); } $host; } sub inet_aton { my $host = fillIPv4($_[0]); return $host ? scalar gethostbyname($host) : undef; } #sub inet_aton { # my $host = $_[0]; # return undef unless defined $host; # if ($host =~ /^(\d+)(?:|\.(\d+)(?:|\.(\d+)(?:|\.(\d+))))$/) { # if (defined $4) { # return undef unless # $1 >= 0 && $1 < 256 && # $2 >= 0 && $2 < 256 && # $3 >= 0 && $3 < 256 && # $4 >= 0 && $4 < 256; # return pack('C4',$1,$2,$3,$4); ## $host = ($1 << 24) + ($2 << 16) + ($3 << 8) + $4; # } elsif (defined $3) { # return undef unless # $1 >= 0 && $1 < 256 && # $2 >= 0 && $2 < 256 && # $3 >= 0 && $3 < 256; # return pack('C4',$1,$2,0,$3); ## $host = ($1 << 24) + ($2 << 16) + $3; # } elsif (defined $2) { # return undef unless # $1 >= 0 && $1 < 256 && # $2 >= 0 && $2 < 256; # return pack('C4',$1,0,0,$2); ## $host = ($1 << 24) + $2; # } else { # return pack('C4',0,0,0,$1); ## $host = $1; # } ## return pack('N',$host); # } # scalar gethostbyname($host); #} my $_zero = pack('L4',0,0,0,0); my $_ipv4mask = pack('L4',0xffffffff,0xffffffff,0xffffffff,0); sub isIPv4 { if (length($_[0]) != 16) { my $sub = (caller(1))[3] || (caller(0))[3]; die "Bad arg length for $sub, length is ". (length($_[0]) *8) .", should be 128"; } return ($_[0] & $_ipv4mask) eq $_zero ? 1 : 0; } my $_newV4compat = pack('N4',0,0,0xffff,0); sub isNewIPv4 { my $naddr = $_[0] ^ $_newV4compat; return isIPv4($naddr); } sub isAnyIPv4 { my $naddr = $_[0]; my $rv = isIPv4($_[0]); return $rv if $rv; return isNewIPv4($naddr); } sub DESTROY {}; sub import { if (grep { $_ eq ':upper' } @_) { upper(); @_ = grep { $_ ne ':upper' } @_; } NetAddr::IP::InetBase->export_to_level(1,@_); } 1; __END__ =head1 NAME NetAddr::IP::InetBase -- IPv4 and IPV6 utilities =head1 SYNOPSIS use NetAddr::IP::Base qw( :upper inet_aton inet_ntoa ipv6_aton ipv6_ntoa ipv6_n2x ipv6_n2d inet_any2n inet_n2dx inet_n2ad inet_pton inet_ntop packzeros isIPv4 isNewIPv4 isAnyIPv4 AF_INET AF_INET6 fake_AF_INET6 fillIPv4 ); use NetAddr::IP::Util qw(:all :inet :ipv4 :ipv6 :math) :ipv4 => inet_aton, inet_ntoa, fillIPv4 :ipv6 => ipv6_aton, ipv6_ntoa,ipv6_n2x, ipv6_n2d, inet_any2n, inet_n2dx, inet_n2ad inet_pton, inet_ntop, packzeros $dotquad = inet_ntoa($netaddr); $netaddr = inet_aton($dotquad); $ipv6naddr = ipv6_aton($ipv6_text); $ipv6_text = ipv6_ntoa($ipv6naddr); $hex_text = ipv6_n2x($ipv6naddr); $dec_text = ipv6_n2d($ipv6naddr); $ipv6naddr = inet_any2n($dotquad or $ipv6_text); $dotquad or $hex_text = inet_n2dx($ipv6naddr); $dotquad or $dec_text = inet_n2ad($ipv6naddr); $netaddr = inet_pton($AF_family,$text_addr); $text_addr = inet_ntop($AF_family,$netaddr); $hex_text = packzeros($hex_text); $rv = isIPv4($bits128); $rv = isNewIPv4($bits128); $rv = isAnyIPv4($bits128); $constant = AF_INET(); $constant = AF_INET6(); $trueif = fake_AF_INET6(); $ip_filled = fillIPv4($shortIP); NetAddr::IP::InetBase::lower(); NetAddr::IP::InetBase::upper(); =head1 INSTALLATION Un-tar the distribution in an appropriate directory and type: perl Makefile.PL make make test make install =head1 DESCRIPTION B<NetAddr::IP::InetBase> provides a suite network of conversion functions written in pure Perl for converting both IPv4 and IPv6 addresses to and from network address format and text format. The IPv6 functions support all rfc1884 formats. i.e. x:x:x:x:x:x:x:x:x x:x:x:x:x:x:x:d.d.d.d ::x:x:x ::x:d.d.d.d and so on... =over 4 =item * $dotquad = inet_ntoa($netaddr); Convert a packed IPv4 network address to a dot-quad IP address. input: packed network address returns: IP address i.e. 10.4.12.123 =cut sub inet_ntoa { die 'Bad arg length for '. __PACKAGE__ ."::inet_ntoa, length is ". length($_[0]) ." should be 4" unless length($_[0]) == 4; my @hex = (unpack("n2",$_[0])); $hex[3] = $hex[1] & 0xff; $hex[2] = $hex[1] >> 8; $hex[1] = $hex[0] & 0xff; $hex[0] >>= 8; return sprintf("%d.%d.%d.%d",@hex); } =item * $netaddr = inet_aton($dotquad); Convert a dot-quad IP address into an IPv4 packed network address. input: IP address i.e. 192.5.16.32 returns: packed network address =item * $ipv6addr = ipv6_aton($ipv6_text); Takes an IPv6 address of the form described in rfc1884 and returns a 128 bit binary RDATA string. input: ipv6 text returns: 128 bit RDATA string =cut sub ipv6_aton { my($ipv6) = @_; return undef unless $ipv6; local($1,$2,$3,$4,$5); if ($ipv6 =~ /^(.*:)(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/) { # mixed hex, dot-quad return undef if $2 > 255 || $3 > 255 || $4 > 255 || $5 > 255; $ipv6 = sprintf("%s%X%02X:%X%02X",$1,$2,$3,$4,$5); # convert to pure hex } my $c; return undef if $ipv6 =~ /[^:0-9a-fA-F]/ || # non-hex character (($c = $ipv6) =~ s/::/x/ && $c =~ /(?:x|:):/) || # double :: ::? $ipv6 =~ /[0-9a-fA-F]{5,}/; # more than 4 digits $c = $ipv6 =~ tr/:/:/; # count the colons return undef if $c < 7 && $ipv6 !~ /::/; if ($c > 7) { # strip leading or trailing :: return undef unless $ipv6 =~ s/^::/:/ || $ipv6 =~ s/::$/:/; return undef if --$c > 7; } while ($c++ < 7) { # expand compressed fields $ipv6 =~ s/::/:::/; } $ipv6 .= 0 if $ipv6 =~ /:$/; my @hex = split(/:/,$ipv6); foreach(0..$#hex) { $hex[$_] = hex($hex[$_] || 0); } pack("n8",@hex); } =item * $ipv6text = ipv6_ntoa($ipv6naddr); Convert a 128 bit binary IPv6 address to compressed rfc 1884 text representation. input: 128 bit RDATA string returns: ipv6 text =cut sub ipv6_ntoa { return inet_ntop(AF_INET6(),$_[0]); } =item * $hex_text = ipv6_n2x($ipv6addr); Takes an IPv6 RDATA string and returns an 8 segment IPv6 hex address input: 128 bit RDATA string returns: x:x:x:x:x:x:x:x Note: this function does NOT compress adjacent strings of 0:0:0:0 into the :: format =item * $dec_text = ipv6_n2d($ipv6addr); Takes an IPv6 RDATA string and returns a mixed hex - decimal IPv6 address with the 6 uppermost chunks in hex and the lower 32 bits in dot-quad representation. input: 128 bit RDATA string returns: x:x:x:x:x:x:d.d.d.d Note: this function does NOT compress adjacent strings of 0:0:0:0 into the :: format =item * $ipv6naddr = inet_any2n($dotquad or $ipv6_text); This function converts a text IPv4 or IPv6 address in text format in any standard notation into a 128 bit IPv6 string address. It prefixes any dot-quad address (if found) with '::' and passes it to B<ipv6_aton>. input: dot-quad or rfc1844 address returns: 128 bit IPv6 string =cut sub inet_any2n($) { my($addr) = @_; $addr = '' unless $addr; $addr = '::' . $addr unless $addr =~ /:/; return ipv6_aton($addr); } =item * $dotquad or $hex_text = inet_n2dx($ipv6naddr); This function B<does the right thing> and returns the text for either a dot-quad IPv4 or a hex notation IPv6 address. input: 128 bit IPv6 string returns: ddd.ddd.ddd.ddd or x:x:x:x:x:x:x:x Note: this function does NOT compress adjacent strings of 0:0:0:0 into the :: format =cut sub inet_n2dx($) { my($nadr) = @_; if (isAnyIPv4($nadr)) { local $1; ipv6_n2d($nadr) =~ /([^:]+)$/; return $1; } return ipv6_n2x($nadr); } =item * $dotquad or $dec_text = inet_n2ad($ipv6naddr); This function B<does the right thing> and returns the text for either a dot-quad IPv4 or a hex::decimal notation IPv6 address. input: 128 bit IPv6 string returns: ddd.ddd.ddd.ddd or x:x:x:x:x:x:ddd.ddd.ddd.dd Note: this function does NOT compress adjacent strings of 0:0:0:0 into the :: format =cut sub inet_n2ad($) { my($nadr) = @_; my $addr = ipv6_n2d($nadr); return $addr unless isAnyIPv4($nadr); local $1; $addr =~ /([^:]+)$/; return $1; } =item * $netaddr = inet_pton($AF_family,$text_addr); This function takes an IP address in IPv4 or IPv6 text format and converts it into binary format. The type of IP address conversion is controlled by the FAMILY argument. NOTE: inet_pton, inet_ntop and AF_INET6 come from the Socket6 library if it is present on this host. =cut sub _inet_pton { my($af,$ip) = @_; die 'Bad address family for '. __PACKAGE__ ."::inet_pton, got $af" unless $af == AF_INET6() || $af == AF_INET(); if ($af == AF_INET()) { inet_aton($ip); } else { ipv6_aton($ip); } } =item * $text_addr = inet_ntop($AF_family,$netaddr); This function takes and IP address in binary format and converts it into text format. The type of IP address conversion is controlled by the FAMILY argument. NOTE: inet_ntop ALWAYS returns lowercase characters. NOTE: inet_pton, inet_ntop and AF_INET6 come from the Socket6 library if it is present on this host. =cut sub _inet_ntop { my($af,$naddr) = @_; die 'Unsupported address family for '. __PACKAGE__ ."::inet_ntop, af is $af" unless $af == AF_INET6() || $af == AF_INET(); if ($af == AF_INET()) { inet_ntoa($naddr); } else { return ($case) ? lc packzeros(ipv6_n2x($naddr)) : _packzeros(ipv6_n2x($naddr)); } } =item * $hex_text = packzeros($hex_text); This function optimizes and rfc 1884 IPv6 hex address to reduce the number of long strings of zero bits as specified in rfc 1884, 2.2 (2) by substituting B<::> for the first occurence of the longest string of zeros in the address. =cut sub _packzeros { my $x6 = shift; if ($x6 =~ /\:\:/) { # already contains :: # then re-optimize $x6 = ($x6 =~ /\:\d+\.\d+\.\d+\.\d+/) # ipv4 notation ? ? ipv6_n2d(ipv6_aton($x6)) : ipv6_n2x(ipv6_aton($x6)); } $x6 = ':'. lc $x6; # prefix : & always lower case my $d = ''; if ($x6 =~ /(.+\:)(\d+\.\d+\.\d+\.\d+)/) { # if contains dot quad $x6 = $1; # save hex piece $d = $2; # and dot quad piece } $x6 .= ':'; # suffix : $x6 =~ s/\:0+/\:0/g; # compress strings of 0's to single '0' $x6 =~ s/\:0([1-9a-f]+)/\:$1/g; # eliminate leading 0's in hex strings my @x = $x6 =~ /(?:\:0)*/g; # split only strings of :0:0..." my $m = 0; my $i = 0; for (0..$#x) { # find next longest pattern :0:0:0... my $len = length($x[$_]); next unless $len > $m; $m = $len; $i = $_; # index to first longest pattern } if ($m > 2) { # there was a string of 2 or more zeros $x6 =~ s/$x[$i]/\:/; # replace first longest :0:0:0... with "::" unless ($i) { # if it is the first match, $i = 0 $x6 = substr($x6,0,-1); # keep the leading ::, remove trailing ':' } else { $x6 = substr($x6,1,-1); # else remove leading & trailing ':' } $x6 .= ':' unless $x6 =~ /\:\:/; # restore ':' if match and we can't see it, implies trailing '::' } else { # there was no match $x6 = substr($x6,1,-1); # remove leading & trailing ':' } $x6 .= $d; # append digits if any return $case ? uc $x6 : $x6; } =item * $ipv6naddr = ipv4to6($netaddr); Convert an ipv4 network address into an ipv6 network address. input: 32 bit network address returns: 128 bit network address =item * $rv = isIPv4($bits128); This function returns true if there are no on bits present in the IPv6 portion of the 128 bit string and false otherwise. i.e. the address must be of the form - ::d.d.d.d Note: this is an old and deprecated ipV4 compatible ipV6 address =item * $rv = isNewIPv4($bits128); This function return true if the IPv6 128 bit string is of the form ::ffff:d.d.d.d =item * $rv = isAnyIPv4($bits128); This function return true if the IPv6 bit string is of the form ::d.d.d.d or ::ffff:d.d.d.d =item * NetAddr::IP::InetBase::lower(); Return IPv6 strings in lowercase. This is the default. =item * NetAddr::IP::InetBase::upper(); Return IPv6 strings in uppercase. The default may be set to uppercase when the module is loaded by invoking the TAG :upper. i.e. use NetAddr::IP::InetBase qw( :upper ); =item * $constant = AF_INET; This function returns the system value for AF_INET. =item * $constant = AF_INET6; AF_INET6 is sometimes present in the Socket library and always present in the Socket6 library. When the Socket library does not contain AF_INET6 and when Socket6 is not present, a place holder value is C<guessed> based on the underlying host operating system. See B<fake_AF_INET6> below. NOTE: inet_pton, inet_ntop and AF_INET6 come from the Socket6 library if it is present on this host. =item * $trueif = fake_AF_INET6; This function return FALSE if AF_INET6 is provided by Socket or Socket6. Otherwise, it returns the best guess value based on name of the host operating system. =item * $ip_filled = fillIPv4($shortIP); This function converts IPv4 addresses of the form 127.1 to the long form 127.0.0.1 If the function is passed an argument that does not match the form of an IP address, the original argument is returned. i.e. pass it a hostname or a short IP and it will return a hostname or a filled IP. =back =head1 EXPORT_OK :upper inet_aton inet_ntoa ipv6_aton ipv6_ntoa ipv6_n2x ipv6_n2d inet_any2n inet_n2dx inet_n2ad inet_pton inet_ntop packzeros isIPv4 isNewIPv4 isAnyIPv4 AF_INET AF_INET6 fake_AF_INET6 fillIPv4 =head1 %EXPORT_TAGS :all :ipv4 :ipv6 :upper =head1 AUTHOR Michael Robinton <michael@bizsystems.com> =head1 COPYRIGHT Copyright 2003 - 2012, Michael Robinton E<lt>michael@bizsystems.comE<gt> All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version, or b) the "Artistic License" which comes with this distribution. 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 either the GNU General Public License or the Artistic License for more details. You should have received a copy of the Artistic License with this distribution, in the file named "Artistic". If not, I'll be glad to provide one. You should also have received a copy of the GNU General Public License along with this program in the file named "Copying". If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor Boston, MA 02110-1301 USA or visit their web page on the internet at: http://www.gnu.org/copyleft/gpl.html. =head1 AUTHOR Michael Robinton <michael@bizsystems.com> =head1 SEE ALSO NetAddr::IP(3), NetAddr::IP::Lite(3), NetAddr::IP::Util(3) =cut 1; 5.32/NetAddr/IP.pm 0000444 00000125103 15125513451 0007324 0 ustar 00 #!/usr/bin/perl -w package NetAddr::IP; use strict; #use diagnostics; use Carp; use NetAddr::IP::Lite 1.57 qw(Zero Zeros Ones V4mask V4net); use NetAddr::IP::Util 1.53 qw( sub128 inet_aton inet_any2n ipv6_aton isIPv4 ipv4to6 mask4to6 shiftleft addconst hasbits notcontiguous ); use AutoLoader qw(AUTOLOAD); use vars qw( @EXPORT_OK @EXPORT_FAIL @ISA $VERSION $_netlimit $rfc3021 ); require Exporter; @EXPORT_OK = qw(Compact Coalesce Zero Zeros Ones V4mask V4net netlimit); @EXPORT_FAIL = qw($_netlimit); @ISA = qw(Exporter NetAddr::IP::Lite); $VERSION = do { sprintf " %d.%03d", (q$Revision: 4.79 $ =~ /\d+/g) }; $rfc3021 = 0; =pod =encoding UTF-8 =head1 NAME NetAddr::IP - Manages IPv4 and IPv6 addresses and subnets =head1 SYNOPSIS use NetAddr::IP qw( Compact Coalesce Zeros Ones V4mask V4net netlimit :aton DEPRECATED :lower :upper :old_storable :old_nth :rfc3021 :nofqdn ); NOTE: NetAddr::IP::Util has a full complement of network address utilities to convert back and forth between binary and text. inet_aton, inet_ntoa, ipv6_aton, ipv6_ntoa ipv6_n2x, ipv6_n2d inet_any2d, inet_n2dx, inet_n2ad, inetanyto6, ipv6to4 See L<NetAddr::IP::Util> my $ip = new NetAddr::IP '127.0.0.1'; or if you prefer my $ip = NetAddr::IP->new('127.0.0.1); or from a packed IPv4 address my $ip = new_from_aton NetAddr::IP (inet_aton('127.0.0.1')); or from an octal filtered IPv4 address my $ip = new_no NetAddr::IP '127.012.0.0'; print "The address is ", $ip->addr, " with mask ", $ip->mask, "\n" ; if ($ip->within(new NetAddr::IP "127.0.0.0", "255.0.0.0")) { print "Is a loopback address\n"; } # This prints 127.0.0.1/32 print "You can also say $ip...\n"; * The following four functions return ipV6 representations of: :: = Zeros(); FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF = Ones(); FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:: = V4mask(); ::FFFF:FFFF = V4net(); Will also return an ipV4 or ipV6 representation of a resolvable Fully Qualified Domanin Name (FQDN). ###### DEPRECATED, will be remove in version 5 ############ * To accept addresses in the format as returned by inet_aton, invoke the module as: use NetAddr::IP qw(:aton); ###### USE new_from_aton instead ########################## * To enable usage of legacy data files containing NetAddr::IP objects stored using the L<Storable> module. use NetAddr::IP qw(:old_storable); * To compact many smaller subnets (see: C<$me-E<gt>compact($addr1,$addr2,...)> @compacted_object_list = Compact(@object_list) * Return a reference to list of C<NetAddr::IP> subnets of C<$masklen> mask length, when C<$number> or more addresses from C<@list_of_subnets> are found to be contained in said subnet. $arrayref = Coalesce($masklen, $number, @list_of_subnets) * By default B<NetAddr::IP> functions and methods return string IPv6 addresses in uppercase. To change that to lowercase: NOTE: the AUGUST 2010 RFC5952 states: 4.3. Lowercase The characters "a", "b", "c", "d", "e", and "f" in an IPv6 address MUST be represented in lowercase. It is recommended that all NEW applications using NetAddr::IP be invoked as shown on the next line. use NetAddr::IP qw(:lower); * To ensure the current IPv6 string case behavior even if the default changes: use NetAddr::IP qw(:upper); * To set a limit on the size of B<nets> processed or returned by NetAddr::IP. Set the maximum number of nets beyond which NetAddr::IP will return an error as a power of 2 (default 16 or 65536 nets). Each 2**16 consumes approximately 4 megs of memory. A 2**20 consumes 64 megs of memory, A 2**24 consumes 1 gigabyte of memory. use NetAddr::IP qw(netlimit); netlimit 20; The maximum B<netlimit> allowed is 2**24. Attempts to set limits below the default of 16 or above the maximum of 24 are ignored. Returns true on success, otherwise C<undef>. =cut $_netlimit = 2 ** 16; # default sub netlimit($) { return undef unless $_[0]; return undef if $_[0] =~ /\D/; return undef if $_[0] < 16; return undef if $_[0] > 24; $_netlimit = 2 ** $_[0]; }; =head1 INSTALLATION Un-tar the distribution in an appropriate directory and type: perl Makefile.PL make make test make install B<NetAddr::IP> depends on B<NetAddr::IP::Util> which installs by default with its primary functions compiled using Perl's XS extensions to build a C library. If you do not have a C complier available or would like the slower Pure Perl version for some other reason, then type: perl Makefile.PL -noxs make make test make install =head1 DESCRIPTION This module provides an object-oriented abstraction on top of IP addresses or IP subnets that allows for easy manipulations. Version 4.xx of NetAddr::IP will work with older versions of Perl and is compatible with Math::BigInt. The internal representation of all IP objects is in 128 bit IPv6 notation. IPv4 and IPv6 objects may be freely mixed. =head2 Overloaded Operators Many operators have been overloaded, as described below: =cut ############################################# # These are the overload methods, placed here # for convenience. ############################################# use overload '@{}' => sub { return [ $_[0]->hostenum ]; }; =pod =over =item B<Assignment (C<=>)> Has been optimized to copy one NetAddr::IP object to another very quickly. =item B<C<-E<gt>copy()>> The B<assignment (C<=>)> operation is only put in to operation when the copied object is further mutated by another overloaded operation. See L<overload> B<SPECIAL SYMBOLS FOR "use overload"> for details. B<C<-E<gt>copy()>> actually creates a new object when called. =item B<Stringification> An object can be used just as a string. For instance, the following code my $ip = new NetAddr::IP '192.168.1.123'; print "$ip\n"; Will print the string 192.168.1.123/32. =item B<Equality> You can test for equality with either C<eq> or C<==>. C<eq> allows comparison with arbitrary strings as well as NetAddr::IP objects. The following example: if (NetAddr::IP->new('127.0.0.1','255.0.0.0') eq '127.0.0.1/8') { print "Yes\n"; } will print out "Yes". Comparison with C<==> requires both operands to be NetAddr::IP objects. In both cases, a true value is returned if the CIDR representation of the operands is equal. =item B<Comparison via E<gt>, E<lt>, E<gt>=, E<lt>=, E<lt>=E<gt> and C<cmp>> Internally, all network objects are represented in 128 bit format. The numeric representation of the network is compared through the corresponding operation. Comparisons are tried first on the address portion of the object and if that is equal then the NUMERIC cidr portion of the masks are compared. This leads to the counterintuitive result that /24 > /16 Comparison should not be done on netaddr objects with different CIDR as this may produce indeterminate - unexpected results, rather the determination of which netblock is larger or smaller should be done by comparing $ip1->masklen <=> $ip2->masklen =item B<Addition of a constant (C<+>)> Add a 32 bit signed constant to the address part of a NetAddr object. This operation changes the address part to point so many hosts above the current objects start address. For instance, this code: print NetAddr::IP->new('127.0.0.1/8') + 5; will output 127.0.0.6/8. The address will wrap around at the broadcast back to the network address. This code: print NetAddr::IP->new('10.0.0.1/24') + 255; outputs 10.0.0.0/24. Returns the the unchanged object when the constant is missing or out of range. 2147483647 <= constant >= -2147483648 =item B<Subtraction of a constant (C<->)> The complement of the addition of a constant. =item B<Difference (C<->)> Returns the difference between the address parts of two NetAddr::IP objects address parts as a 32 bit signed number. Returns B<undef> if the difference is out of range. (See range restrictions on Addition above) =item B<Auto-increment> Auto-incrementing a NetAddr::IP object causes the address part to be adjusted to the next host address within the subnet. It will wrap at the broadcast address and start again from the network address. =item B<Auto-decrement> Auto-decrementing a NetAddr::IP object performs exactly the opposite of auto-incrementing it, as you would expect. =cut ############################################# # End of the overload methods. ############################################# # Preloaded methods go here. =pod =back =head2 Serializing and Deserializing This module defines hooks to collaborate with L<Storable> for serializing C<NetAddr::IP> objects, through compact and human readable strings. You can revert to the old format by invoking this module as use NetAddr::IP ':old_storable'; You must do this if you have legacy data files containing NetAddr::IP objects stored using the L<Storable> module. =cut my $full_format = "%04X:%04X:%04X:%04X:%04X:%04X:%D.%D.%D.%D"; my $full6_format = "%04X:%04X:%04X:%04X:%04X:%04X:%04X:%04X"; sub import { if (grep { $_ eq ':old_storable' } @_) { @_ = grep { $_ ne ':old_storable' } @_; } else { *{STORABLE_freeze} = sub { my $self = shift; return $self->cidr(); # use stringification }; *{STORABLE_thaw} = sub { my $self = shift; my $cloning = shift; # Not used my $serial = shift; my $ip = new NetAddr::IP $serial; $self->{addr} = $ip->{addr}; $self->{mask} = $ip->{mask}; $self->{isv6} = $ip->{isv6}; return; }; } if (grep { $_ eq ':aton' } @_) { $NetAddr::IP::Lite::Accept_Binary_IP = 1; @_ = grep { $_ ne ':aton' } @_; } if (grep { $_ eq ':old_nth' } @_) { $NetAddr::IP::Lite::Old_nth = 1; @_ = grep { $_ ne ':old_nth' } @_; } if (grep { $_ eq ':nofqdn'} @_) { $NetAddr::IP::NetAddr::IP::Lite::NoFQDN = 1; @_ = grep { $_ ne ':nofqdn' } @_; } if (grep { $_ eq ':lower' } @_) { $full_format = lc($full_format); $full6_format = lc($full6_format); NetAddr::IP::Util::lower(); @_ = grep { $_ ne ':lower' } @_; } if (grep { $_ eq ':upper' } @_) { $full_format = uc($full_format); $full6_format = uc($full6_format); NetAddr::IP::Util::upper(); @_ = grep { $_ ne ':upper' } @_; } if (grep { $_ eq ':rfc3021' } @_) { $rfc3021 = 1; @_ = grep { $_ ne ':rfc3021' } @_; } NetAddr::IP->export_to_level(1, @_); } sub compact { return (ref $_[0] eq 'ARRAY') ? compactref($_[0]) # Compact(\@list) : @{compactref(\@_)}; # Compact(@list) or ->compact(@list) } *Compact = \&compact; sub Coalesce { return &coalesce; } sub hostenumref($) { my $r = _splitref(0,$_[0]); unless ((notcontiguous($_[0]->{mask}))[1] == 128 || ($rfc3021 && $_[0]->masklen == 31) ) { splice(@$r, 0, 1); splice(@$r, scalar @$r - 1, 1); } return $r; } sub splitref { unshift @_, 0; # mark as no reverse # perl 5.8.4 fails with this operation. see perl bug [ 23429] # goto &_splitref; &_splitref; } sub rsplitref { unshift @_, 1; # mark as reversed # perl 5.8.4 fails with this operation. see perl bug [ 23429] # goto &_splitref; &_splitref; } sub split { unshift @_, 0; # mark as no reverse my $rv = &_splitref; return $rv ? @$rv : (); } sub rsplit { unshift @_, 1; # mark as reversed my $rv = &_splitref; return $rv ? @$rv : (); } sub full($) { if (! $_[0]->{isv6} && isIPv4($_[0]->{addr})) { my @hex = (unpack("n8",$_[0]->{addr})); $hex[9] = $hex[7] & 0xff; $hex[8] = $hex[7] >> 8; $hex[7] = $hex[6] & 0xff; $hex[6] >>= 8; return sprintf($full_format,@hex); } else { &full6; } } sub full6($) { my @hex = (unpack("n8",$_[0]->{addr})); return sprintf($full6_format,@hex); } sub full6m($) { my @hex = (unpack("n8",$_[0]->{mask})); return sprintf($full6_format,@hex); } sub DESTROY {}; 1; __END__ sub do_prefix ($$$) { my $mask = shift; my $faddr = shift; my $laddr = shift; if ($mask > 24) { return "$faddr->[0].$faddr->[1].$faddr->[2].$faddr->[3]-$laddr->[3]"; } elsif ($mask == 24) { return "$faddr->[0].$faddr->[1].$faddr->[2]."; } elsif ($mask > 16) { return "$faddr->[0].$faddr->[1].$faddr->[2]-$laddr->[2]."; } elsif ($mask == 16) { return "$faddr->[0].$faddr->[1]."; } elsif ($mask > 8) { return "$faddr->[0].$faddr->[1]-$laddr->[1]."; } elsif ($mask == 8) { return "$faddr->[0]."; } else { return "$faddr->[0]-$laddr->[0]"; } } =pod =head2 Methods =over =item C<-E<gt>new([$addr, [ $mask|IPv6 ]])> =item C<-E<gt>new6([$addr, [ $mask]])> =item C<-E<gt>new_no([$addr, [ $mask]])> =item C<-E<gt>new_from_aton($netaddr)> =item new_cis and new_cis6 are DEPRECATED =item C<-E<gt>new_cis("$addr $mask)> =item C<-E<gt>new_cis6("$addr $mask)> The first two methods create a new address with the supplied address in C<$addr> and an optional netmask C<$mask>, which can be omitted to get a /32 or /128 netmask for IPv4 / IPv6 addresses respectively. The third method C<new_no> is exclusively for IPv4 addresses and filters improperly formatted dot quad strings for leading 0's that would normally be interpreted as octal format by NetAddr per the specifications for inet_aton. B<new_from_aton> takes a packed IPv4 address and assumes a /32 mask. This function replaces the DEPRECATED :aton functionality which is fundamentally broken. The last two methods B<new_cis> and B<new_cis6> differ from B<new> and B<new6> only in that they except the common Cisco address notation for address/mask pairs with a B<space> as a separator instead of a slash (/) These methods are DEPRECATED because the functionality is now included in the other "new" methods i.e. ->new_cis('1.2.3.0 24') or ->new_cis6('::1.2.3.0 120') C<-E<gt>new6> and C<-E<gt>new_cis6> mark the address as being in ipV6 address space even if the format would suggest otherwise. i.e. ->new6('1.2.3.4') will result in ::102:304 addresses submitted to ->new in ipV6 notation will remain in that notation permanently. i.e. ->new('::1.2.3.4') will result in ::102:304 whereas new('1.2.3.4') would print out as 1.2.3.4 See "STRINGIFICATION" below. C<$addr> can be almost anything that can be resolved to an IP address in all the notations I have seen over time. It can optionally contain the mask in CIDR notation. B<prefix> notation is understood, with the limitation that the range specified by the prefix must match with a valid subnet. Addresses in the same format returned by C<inet_aton> or C<gethostbyname> can also be understood, although no mask can be specified for them. The default is to not attempt to recognize this format, as it seems to be seldom used. To accept addresses in that format, invoke the module as in use NetAddr::IP ':aton' If called with no arguments, 'default' is assumed. If called with an empty string as the argument, returns 'undef' C<$addr> can be any of the following and possibly more... n.n n.n/mm n.n.n n.n.n/mm n.n.n.n n.n.n.n/mm 32 bit cidr notation n.n.n.n/m.m.m.m loopback, localhost, broadcast, any, default x.x.x.x/host 0xABCDEF, 0b111111000101011110, (a bcd number) a netaddr as returned by 'inet_aton' Any RFC1884 notation ::n.n.n.n ::n.n.n.n/mmm 128 bit cidr notation ::n.n.n.n/::m.m.m.m ::x:x ::x:x/mmm x:x:x:x:x:x:x:x x:x:x:x:x:x:x:x/mmm x:x:x:x:x:x:x:x/m:m:m:m:m:m:m:m any RFC1884 notation loopback, localhost, unspecified, any, default ::x:x/host 0xABCDEF, 0b111111000101011110 within the limits of perl's number resolution 123456789012 a 'big' bcd number (bigger than perl likes) and Math::BigInt A Fully Qualified Domain Name which returns an ipV4 address or an ipV6 address, embodied in that order. This previously undocumented feature may be disabled with: use NetAddr::IP::Lite ':nofqdn'; If called with no arguments, 'default' is assumed. If called with an empty string as the argument, returns 'undef' =item C<-E<gt>broadcast()> Returns a new object referring to the broadcast address of a given subnet. The broadcast address has all ones in all the bit positions where the netmask has zero bits. This is normally used to address all the hosts in a given subnet. =item C<-E<gt>network()> Returns a new object referring to the network address of a given subnet. A network address has all zero bits where the bits of the netmask are zero. Normally this is used to refer to a subnet. =item C<-E<gt>addr()> Returns a scalar with the address part of the object as an IPv4 or IPv6 text string as appropriate. This is useful for printing or for passing the address part of the NetAddr::IP object to other components that expect an IP address. If the object is an ipV6 address or was created using ->new6($ip) it will be reported in ipV6 hex format otherwise it will be reported in dot quad format only if it resides in ipV4 address space. =item C<-E<gt>mask()> Returns a scalar with the mask as an IPv4 or IPv6 text string as described above. =item C<-E<gt>masklen()> Returns a scalar the number of one bits in the mask. =item C<-E<gt>bits()> Returns the width of the address in bits. Normally 32 for v4 and 128 for v6. =item C<-E<gt>version()> Returns the version of the address or subnet. Currently this can be either 4 or 6. =item C<-E<gt>cidr()> Returns a scalar with the address and mask in CIDR notation. A NetAddr::IP object I<stringifies> to the result of this function. (see comments about ->new6() and ->addr() for output formats) =item C<-E<gt>aton()> Returns the address part of the NetAddr::IP object in the same format as the C<inet_aton()> or C<ipv6_aton> function respectively. If the object was created using ->new6($ip), the address returned will always be in ipV6 format, even for addresses in ipV4 address space. =item C<-E<gt>range()> Returns a scalar with the base address and the broadcast address separated by a dash and spaces. This is called range notation. =item C<-E<gt>prefix()> Returns a scalar with the address and mask in ipV4 prefix representation. This is useful for some programs, which expect its input to be in this format. This method will include the broadcast address in the encoding. =cut # only applicable to ipV4 sub prefix($) { return undef if $_[0]->{isv6}; my $mask = (notcontiguous($_[0]->{mask}))[1]; return $_[0]->addr if $mask == 128; $mask -= 96; my @faddr = split (/\./, $_[0]->first->addr); my @laddr = split (/\./, $_[0]->broadcast->addr); return do_prefix $mask, \@faddr, \@laddr; } =item C<-E<gt>nprefix()> Just as C<-E<gt>prefix()>, but does not include the broadcast address. =cut # only applicable to ipV4 sub nprefix($) { return undef if $_[0]->{isv6}; my $mask = (notcontiguous($_[0]->{mask}))[1]; return $_[0]->addr if $mask == 128; $mask -= 96; my @faddr = split (/\./, $_[0]->first->addr); my @laddr = split (/\./, $_[0]->last->addr); return do_prefix $mask, \@faddr, \@laddr; } =pod =item C<-E<gt>numeric()> When called in a scalar context, will return a numeric representation of the address part of the IP address. When called in an array contest, it returns a list of two elements. The first element is as described, the second element is the numeric representation of the netmask. This method is essential for serializing the representation of a subnet. =item C<-E<gt>bigint()> When called in scalar context, will return a Math::BigInt representation of the address part of the IP address. When called in an array context, it returns a list of two elements, The first element is as described, the second element is the Math::BigInt representation of the netmask. =item C<-E<gt>wildcard()> When called in a scalar context, returns the wildcard bits corresponding to the mask, in dotted-quad or ipV6 format as applicable. When called in an array context, returns a two-element array. The first element, is the address part. The second element, is the wildcard translation of the mask. =cut sub wildcard($) { my $copy = $_[0]->copy; $copy->{addr} = ~ $copy->{mask}; $copy->{addr} &= V4net unless $copy->{isv6}; if (wantarray) { return ($_[0]->addr, $copy->addr); } return $copy->addr; } =pod =item C<-E<gt>short()> Returns the address part in a short or compact notation. (ie, 127.0.0.1 becomes 127.1). Works with both, V4 and V6. =cut sub _compact_v6 ($) { my $addr = shift; my @o = split /:/, $addr; return $addr unless @o and grep { $_ =~ m/^0+$/ } @o; my @candidates = (); my $start = undef; for my $i (0 .. $#o) { if (defined $start) { if ($o[$i] !~ m/^0+$/) { push @candidates, [ $start, $i - $start ]; $start = undef; } } else { $start = $i if $o[$i] =~ m/^0+$/; } } push @candidates, [$start, 8 - $start] if defined $start; my $l = (sort { $b->[1] <=> $a->[1] } @candidates)[0]; return $addr unless defined $l; $addr = $l->[0] == 0 ? '' : join ':', @o[0 .. $l->[0] - 1]; $addr .= '::'; $addr .= join ':', @o[$l->[0] + $l->[1] .. $#o]; $addr =~ s/(^|:)0{1,3}/$1/g; return $addr; } #sub _old_compV6 { # my @addr = split(':',shift); # my $found = 0; # my $v; # foreach(0..$#addr) { # ($v = $addr[$_]) =~ s/^0+//; # $addr[$_] = $v || 0; # } # @_ = reverse(1..$#addr); # foreach(@_) { # if ($addr[$_] || $addr[$_ -1]) { # last if $found; # next; # } # $addr[$_] = $addr[$_ -1] = ''; # $found = '1'; # } # (my $rv = join(':',@addr)) =~ s/:+:/::/; # return $rv; #} # thanks to Rob Riepel <riepel@networking.Stanford.EDU> # for this faster and more compact solution 11-17-08 sub _compV6 ($) { my $ip = shift; return $ip unless my @candidates = $ip =~ /((?:^|:)0(?::0)+(?::|$))/g; my $longest = (sort { length($b) <=> length($a) } @candidates)[0]; $ip =~ s/$longest/::/; return $ip; } sub short($) { my $addr = $_[0]->addr; if (! $_[0]->{isv6} && isIPv4($_[0]->{addr})) { my @o = split(/\./, $addr, 4); splice(@o, 1, 2) if $o[1] == 0 and $o[2] == 0; return join '.', @o; } return _compV6($addr); } =item C<-E<gt>canon()> Returns the address part in canonical notation as a string. For ipV4, this is dotted quad, and is the same as the return value from "->addr()". For ipV6 it is as per RFC5952, and is the same as the LOWER CASE value returned by "->short()". =cut sub canon($) { my $addr = $_[0]->addr; return $_[0]->{isv6} ? lc _compV6($addr) : $addr; } =item C<-E<gt>full()> Returns the address part in FULL notation for ipV4 and ipV6 respectively. i.e. for ipV4 0000:0000:0000:0000:0000:0000:127.0.0.1 for ipV6 0000:0000:0000:0000:0000:0000:0000:0000 To force ipV4 addresses into full ipV6 format use: =item C<-E<gt>full6()> Returns the address part in FULL ipV6 notation =item C<-E<gt>full6m()> Returns the mask part in FULL ipV6 notation =item C<$me-E<gt>contains($other)> Returns true when C<$me> completely contains C<$other>. False is returned otherwise and C<undef> is returned if C<$me> and C<$other> are not both C<NetAddr::IP> objects. =item C<$me-E<gt>within($other)> The complement of C<-E<gt>contains()>. Returns true when C<$me> is completely contained within C<$other>. Note that C<$me> and C<$other> must be C<NetAddr::IP> objects. =item C-E<gt>is_rfc1918()> Returns true when C<$me> is an RFC 1918 address. 10.0.0.0 - 10.255.255.255 (10/8 prefix) 172.16.0.0 - 172.31.255.255 (172.16/12 prefix) 192.168.0.0 - 192.168.255.255 (192.168/16 prefix) =item C<-E<gt>is_local()> Returns true when C<$me> is a local network address. i.e. ipV4 127.0.0.0 - 127.255.255.255 or ipV6 === ::1 =item C<-E<gt>splitref($bits,[optional $bits1,$bits2,...])> Returns a reference to a list of objects, representing subnets of C<bits> mask produced by splitting the original object, which is left unchanged. Note that C<$bits> must be longer than the original mask in order for it to be splittable. ERROR conditions: ->splitref will DIE with the message 'netlimit exceeded' if the number of return objects exceeds 'netlimit'. See function 'netlimit' above (default 2**16 or 65536 nets). ->splitref returns undef when C<bits> or the (bits list) will not fit within the original object. ->splitref returns undef if a supplied ipV4, ipV6, or NetAddr mask in inappropriately formatted, B<bits> may be a CIDR mask, a dot quad or ipV6 string or a NetAddr::IP object. If C<bits> is missing, the object is split for into all available addresses within the ipV4 or ipV6 object ( auto-mask of CIDR 32, 128 respectively ). With optional additional C<bits> list, the original object is split into parts sized based on the list. NOTE: a short list will replicate the last item. If the last item is too large to for what remains of the object after splitting off the first parts of the list, a "best fits" list of remaining objects will be returned based on an increasing sort of the CIDR values of the C<bits> list. i.e. my $ip = new NetAddr::IP('192.168.0.0/24'); my $objptr = $ip->split(28, 29, 28, 29, 26); has split plan 28 29 28 29 26 26 26 28 and returns this list of objects 192.168.0.0/28 192.168.0.16/29 192.168.0.24/28 192.168.0.40/29 192.168.0.48/26 192.168.0.112/26 192.168.0.176/26 192.168.0.240/28 NOTE: that /26 replicates twice beyond the original request and /28 fills the remaining return object requirement. =item C<-E<gt>rsplitref($bits,[optional $bits1,$bits2,...])> C<-E<gt>rsplitref> is the same as C<-E<gt>splitref> above except that the split plan is applied to the original object in reverse order. i.e. my $ip = new NetAddr::IP('192.168.0.0/24'); my @objects = $ip->split(28, 29, 28, 29, 26); has split plan 28 26 26 26 29 28 29 28 and returns this list of objects 192.168.0.0/28 192.168.0.16/26 192.168.0.80/26 192.168.0.144/26 192.168.0.208/29 192.168.0.216/28 192.168.0.232/29 192.168.0.240/28 =item C<-E<gt>split($bits,[optional $bits1,$bits2,...])> Similar to C<-E<gt>splitref> above but returns the list rather than a list reference. You may not want to use this if a large number of objects is expected. =item C<-E<gt>rsplit($bits,[optional $bits1,$bits2,...])> Similar to C<-E<gt>rsplitref> above but returns the list rather than a list reference. You may not want to use this if a large number of objects is expected. =cut # input: $naip, # @bits, list of masks for splits # # returns: empty array request will not fit in submitted net # (\@bits,undef) if there is just one plan item i.e. return original net # (\@bits,\%masks) for a real plan # sub _splitplan { my($ip,@bits) = @_; my $addr = $ip->addr(); my $isV6 = $ip->{isv6}; unless (@bits) { $bits[0] = $isV6 ? 128 : 32; } my $basem = $ip->masklen(); my(%nets,$dif); my $denom = 0; my($x,$maddr); foreach(@bits) { if (ref $_) { # is a NetAddr::IP $x = $_->{isv6} ? $_->{addr} : $_->{addr} | V4mask; ($x,$maddr) = notcontiguous($x); return () if $x; # spurious bits $_ = $isV6 ? $maddr : $maddr - 96; } elsif ( $_ =~ /^d+$/ ) { # is a negative number of the form -nnnn ; } elsif ($_ = NetAddr::IP->new($addr,$_,$isV6)) { # will be undefined if bad mask and will fall into oops! $_ = $_->masklen(); } else { return (); # oops! } $dif = $_ - $basem; # for normalization return () if $dif < 0; # overange nets not allowed return (\@bits,undef) unless ($dif || $#bits); # return if original net = mask alone $denom = $dif if $dif > $denom; next if exists $nets{$_}; $nets{$_} = $_ - $basem; # for normalization } # $denom is the normalization denominator, since these are all exponents # normalization can use add/subtract to accomplish normalization # # keys of %nets are the masks used by this split # values of %nets are the normalized weighting for # calculating when the split is "full" or complete # %masks values contain the actual masks for each split subnet # @bits contains the masks in the order the user actually wants them # my %masks; # calculate masks my $maskbase = $isV6 ? 128 : 32; foreach( keys %nets ) { $nets{$_} = 2 ** ($denom - $nets{$_}); $masks{$_} = shiftleft(Ones, $maskbase - $_); } my @plan; my $idx = 0; $denom = 2 ** $denom; PLAN: while ($denom > 0) { # make a net plan my $nexmask = ($idx < $#bits) ? $bits[$idx] : $bits[$#bits]; ++$idx; unless (($denom -= $nets{$nexmask}) < 0) { return () if (push @plan, $nexmask) > $_netlimit; next; } # a fractional net is needed that is not in the mask list or the replicant $denom += $nets{$nexmask}; # restore mistake TRY: foreach (sort { $a <=> $b } keys %nets) { next TRY if $nexmask > $_; do { next TRY if $denom - $nets{$_} < 0; return () if (push @plan, $_) > $_netlimit; $denom -= $nets{$_}; } while $denom; } die 'ERROR: miscalculated weights' if $denom; } return () if $idx < @bits; # overrange original subnet request return (\@plan,\%masks); } # input: $rev, # t/f # $naip, # @bits # list of masks for split # sub _splitref { my $rev = shift; my($plan,$masks) = &_splitplan; # bug report 82719 croak("netmask error: overrange or spurious bits") unless defined $plan; # return undef unless $plan; my $net = $_[0]->network(); return [$net] unless $masks; my $addr = $net->{addr}; my $isV6 = $net->{isv6}; my @plan = $rev ? reverse @$plan : @$plan; # print "plan @plan\n"; # create splits my @ret; while ($_ = shift @plan) { my $mask = $masks->{$_}; push @ret, $net->_new($addr,$mask,$isV6); last unless @plan; $addr = (sub128($addr,$mask))[1]; } return \@ret; } =pod =item C<-E<gt>hostenum()> Returns the list of hosts within a subnet. ERROR conditions: ->hostenum will DIE with the message 'netlimit exceeded' if the number of return objects exceeds 'netlimit'. See function 'netlimit' above (default 2**16 or 65536 nets). =cut sub hostenum ($) { return @{$_[0]->hostenumref}; } =pod =item C<-E<gt>hostenumref()> Faster version of C<-E<gt>hostenum()>, returning a reference to a list. NOTE: hostenum and hostenumref report zero (0) useable hosts in a /31 network. This is the behavior expected prior to RFC 3021. To report 2 useable hosts for use in point-to-point networks, use B<:rfc3021> tag. use NetAddr::IP qw(:rfc3021); This will cause hostenum and hostenumref to return two (2) useable hosts in a /31 network. =item C<$me-E<gt>compact($addr1, $addr2, ...)> =item C<@compacted_object_list = Compact(@object_list)> Given a list of objects (including C<$me>), this method will compact all the addresses and subnets into the largest (ie, least specific) subnets possible that contain exactly all of the given objects. Note that in versions prior to 3.02, if fed with the same IP subnets multiple times, these subnets would be returned. From 3.02 on, a more "correct" approach has been adopted and only one address would be returned. Note that C<$me> and all C<$addr>'s must be C<NetAddr::IP> objects. =item C<$me-E<gt>compactref(\@list)> =item C<$compacted_object_list = Compact(\@list)> As usual, a faster version of C<-E<gt>compact()> that returns a reference to a list. Note that this method takes a reference to a list instead. Note that C<$me> must be a C<NetAddr::IP> object. =cut sub compactref($) { # my @r = sort { NetAddr::IP::Lite::comp_addr_mask($a,$b) } @{$_[0]} # use overload 'cmp' function # or return []; # return [] unless @r; my @r; { my $unr = []; my $args = $_[0]; if (ref $_[0] eq __PACKAGE__ and ref $_[1] eq 'ARRAY') { # ->compactref(\@list) # $unr = [$_[0], @{$_[1]}]; # keeping structures intact } else { # Compact(@list) or ->compact(@list) or Compact(\@list) # $unr = $args; } return [] unless @$unr; foreach(@$unr) { $_->{addr} = $_->network->{addr}; } @r = sort @$unr; } my $changed; do { $changed = 0; for(my $i=0; $i <= $#r -1;$i++) { if ($r[$i]->contains($r[$i +1])) { splice(@r,$i +1,1); ++$changed; --$i; } elsif ((notcontiguous($r[$i]->{mask}))[1] == (notcontiguous($r[$i +1]->{mask}))[1]) { # masks the same if (hasbits($r[$i]->{addr} ^ $r[$i +1]->{addr})) { # if not the same netblock my $upnet = $r[$i]->copy; $upnet->{mask} = shiftleft($upnet->{mask},1); if ($upnet->contains($r[$i +1])) { # adjacent nets in next net up $r[$i] = $upnet; splice(@r,$i +1,1); ++$changed; --$i; } } else { # identical nets splice(@r,$i +1,1); ++$changed; --$i; } } } } while $changed; return \@r; } =pod =item C<$me-E<gt>coalesce($masklen, $number, @list_of_subnets)> =item C<$arrayref = Coalesce($masklen,$number,@list_of_subnets)> Will return a reference to list of C<NetAddr::IP> subnets of C<$masklen> mask length, when C<$number> or more addresses from C<@list_of_subnets> are found to be contained in said subnet. Subnets from C<@list_of_subnets> with a mask shorter than C<$masklen> are passed "as is" to the return list. Subnets from C<@list_of_subnets> with a mask longer than C<$masklen> will be counted (actually, the number of IP addresses is counted) towards C<$number>. Called as a method, the array will include C<$me>. WARNING: the list of subnet must be the same type. i.e ipV4 or ipV6 =cut sub coalesce { my $masklen = shift; if (ref $masklen && ref $masklen eq __PACKAGE__ ) { # if called as a method push @_,$masklen; $masklen = shift; } my $number = shift; # Addresses are at @_ return [] unless @_; my %ret = (); my $type = $_[0]->{isv6}; return [] unless defined $type; for my $ip (@_) { return [] unless $ip->{isv6} == $type; $type = $ip->{isv6}; my $n = NetAddr::IP->new($ip->addr . '/' . $masklen)->network; if ($ip->masklen > $masklen) { $ret{$n} += $ip->num + $NetAddr::IP::Lite::Old_nth; } } my @ret = (); # Add to @ret any arguments with netmasks longer than our argument for my $c (sort { $a->masklen <=> $b->masklen } grep { $_->masklen <= $masklen } @_) { next if grep { $_->contains($c) } @ret; push @ret, $c->network; } # Now add to @ret all the subnets with more than $number hits for my $c (map { new NetAddr::IP $_ } grep { $ret{$_} >= $number } keys %ret) { next if grep { $_->contains($c) } @ret; push @ret, $c; } return \@ret; } =pod =item C<-E<gt>first()> Returns a new object representing the first usable IP address within the subnet (ie, the first host address). =item C<-E<gt>last()> Returns a new object representing the last usable IP address within the subnet (ie, one less than the broadcast address). =item C<-E<gt>nth($index)> Returns a new object representing the I<n>-th usable IP address within the subnet (ie, the I<n>-th host address). If no address is available (for example, when the network is too small for C<$index> hosts), C<undef> is returned. Version 4.00 of NetAddr::IP and version 1.00 of NetAddr::IP::Lite implements C<-E<gt>nth($index)> and C<-E<gt>num()> exactly as the documentation states. Previous versions behaved slightly differently and not in a consistent manner. See the README file for details. To use the old behavior for C<-E<gt>nth($index)> and C<-E<gt>num()>: use NetAddr::IP::Lite qw(:old_nth); old behavior: NetAddr::IP->new('10/32')->nth(0) == undef NetAddr::IP->new('10/32')->nth(1) == undef NetAddr::IP->new('10/31')->nth(0) == undef NetAddr::IP->new('10/31')->nth(1) == 10.0.0.1/31 NetAddr::IP->new('10/30')->nth(0) == undef NetAddr::IP->new('10/30')->nth(1) == 10.0.0.1/30 NetAddr::IP->new('10/30')->nth(2) == 10.0.0.2/30 NetAddr::IP->new('10/30')->nth(3) == 10.0.0.3/30 Note that in each case, the broadcast address is represented in the output set and that the 'zero'th index is alway undef except for a point-to-point /31 or /127 network where there are exactly two addresses in the network. new behavior: NetAddr::IP->new('10/32')->nth(0) == 10.0.0.0/32 NetAddr::IP->new('10.1/32'->nth(0) == 10.0.0.1/32 NetAddr::IP->new('10/31')->nth(0) == 10.0.0.0/31 NetAddr::IP->new('10/31')->nth(1) == 10.0.0.1/31 NetAddr::IP->new('10/30')->nth(0) == 10.0.0.1/30 NetAddr::IP->new('10/30')->nth(1) == 10.0.0.2/30 NetAddr::IP->new('10/30')->nth(2) == undef Note that a /32 net always has 1 usable address while a /31 has exactly two usable addresses for point-to-point addressing. The first index (0) returns the address immediately following the network address except for a /31 or /127 when it return the network address. =item C<-E<gt>num()> As of version 4.42 of NetAddr::IP and version 1.27 of NetAddr::IP::Lite a /31 and /127 with return a net B<num> value of 2 instead of 0 (zero) for point-to-point networks. Version 4.00 of NetAddr::IP and version 1.00 of NetAddr::IP::Lite return the number of usable IP addresses within the subnet, not counting the broadcast or network address. Previous versions worked only for ipV4 addresses, returned a maximum span of 2**32 and returned the number of IP addresses not counting the broadcast address. (one greater than the new behavior) To use the old behavior for C<-E<gt>nth($index)> and C<-E<gt>num()>: use NetAddr::IP::Lite qw(:old_nth); WARNING: NetAddr::IP will calculate and return a numeric string for network ranges as large as 2**128. These values are TEXT strings and perl can treat them as integers for numeric calculations. Perl on 32 bit platforms only handles integer numbers up to 2**32 and on 64 bit platforms to 2**64. If you wish to manipulate numeric strings returned by NetAddr::IP that are larger than 2**32 or 2**64, respectively, you must load additional modules such as Math::BigInt, bignum or some similar package to do the integer math. =item C<-E<gt>re()> Returns a Perl regular expression that will match an IP address within the given subnet. Defaults to ipV4 notation. Will return an ipV6 regex if the address in not in ipV4 space. =cut sub re ($) { return &re6 unless isIPv4($_[0]->{addr}); my $self = shift->network; # Insure a "zero" host part my ($addr, $mlen) = ($self->addr, $self->masklen); my @o = split('\.', $addr, 4); my $octet= '(?:[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5])'; my @r = @o; my $d; # for my $i (0 .. $#o) # { # warn "# $self: $r[$i] == $o[$i]\n"; # } if ($mlen != 32) { if ($mlen > 24) { $d = 2 ** (32 - $mlen) - 1; $r[3] = '(?:' . join('|', ($o[3]..$o[3] + $d)) . ')'; } else { $r[3] = $octet; if ($mlen > 16) { $d = 2 ** (24 - $mlen) - 1; $r[2] = '(?:' . join('|', ($o[2]..$o[2] + $d)) . ')'; } else { $r[2] = $octet; if ($mlen > 8) { $d = 2 ** (16 - $mlen) - 1; $r[1] = '(?:' . join('|', ($o[1]..$o[1] + $d)) . ')'; } else { $r[1] = $octet; if ($mlen > 0) { $d = 2 ** (8 - $mlen) - 1; $r[0] = '(?:' . join('|', ($o[0] .. $o[0] + $d)) . ')'; } else { $r[0] = $octet; } } } } } ### no digit before nor after (look-behind, look-ahead) return "(?:(?<![0-9])$r[0]\\.$r[1]\\.$r[2]\\.$r[3](?![0-9]))"; } =item C<-E<gt>re6()> Returns a Perl regular expression that will match an IP address within the given subnet. Always returns an ipV6 regex. =cut sub re6($) { my @net = split('',sprintf("%04X%04X%04X%04X%04X%04X%04X%04X",unpack('n8',$_[0]->network->{addr}))); my @brd = split('',sprintf("%04X%04X%04X%04X%04X%04X%04X%04X",unpack('n8',$_[0]->broadcast->{addr}))); my @dig; foreach(0..$#net) { my $n = $net[$_]; my $b = $brd[$_]; my $m; if ($n.'' eq $b.'') { if ($n =~ /\d/) { push @dig, $n; } else { push @dig, '['.(lc $n).$n.']'; } } else { my $n = $net[$_]; my $b = $brd[$_]; if ($n.'' eq 0 && $b =~ /F/) { push @dig, 'x'; } elsif ($n =~ /\d/ && $b =~ /\d/) { push @dig, '['.$n.'-'.$b.']'; } elsif ($n =~ /[A-F]/ && $b =~ /[A-F]/) { $n .= '-'.$b; push @dig, '['.(lc $n).$n.']'; } elsif ($n =~ /\d/ && $b =~ /[A-F]/) { $m = ($n == 9) ? 9 : $n .'-9'; if ($b =~ /A/) { $m .= 'aA'; } else { $b = 'A-'. $b; $m .= (lc $b). $b; } push @dig, '['.$m.']'; } elsif ($n =~ /[A-F]/ && $b =~ /\d/) { if ($n =~ /A/) { $m = 'aA'; } else { $n .= '-F'; $m = (lc $n).$n; } if ($b == 9) { $m .= 9; } else { $m .= $b .'-9'; } push @dig, '['.$m.']'; } } } my @grp; do { my $grp = join('',splice(@dig,0,4)); if ($grp =~ /^(0+)/) { my $l = length($1); if ($l == 4) { $grp = '0{1,4}'; } else { $grp =~ s/^${1}/0\{0,$l\}/; } } if ($grp =~ /(x+)$/) { my $l = length($1); if ($l == 4) { $grp = '[0-9a-fA-F]{1,4}'; } else { $grp =~ s/x+/\[0\-9a\-fA\-F\]\{$l\}/; } } push @grp, $grp; } while @dig > 0; return '('. join(':',@grp) .')'; } sub mod_version { return $VERSION; &Compact; # suppress warnings about these symbols &Coalesce; &STORABLE_freeze; &STORABLE_thaw; } =pod =back =head1 EXPORT_OK Compact Coalesce Zeros Ones V4mask V4net netlimit =head1 NOTES / BUGS ... FEATURES NetAddr::IP only runs in Pure Perl mode on Windows boxes because I don't have the resources or know how to get the "configure" stuff working in the Windows environment. Volunteers WELCOME to port the "C" portion of this module to Windows. =head1 HISTORY =over 4 See the Changes file =back =head1 AUTHORS Luis E. Muñoz E<lt>luismunoz@cpan.orgE<gt>, Michael Robinton E<lt>michael@bizsystems.comE<gt> =head1 WARRANTY This software comes with the same warranty as Perl itself (ie, none), so by using it you accept any and all the liability. =head1 COPYRIGHT This software is (c) Luis E. Muñoz, 1999 - 2007, and (c) Michael Robinton, 2006 - 2014. All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version, or b) the "Artistic License" which comes with this distribution. 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 either the GNU General Public License or the Artistic License for more details. You should have received a copy of the Artistic License with this distribution, in the file named "Artistic". If not, I'll be glad to provide one. You should also have received a copy of the GNU General Public License along with this program in the file named "Copying". If not, write to the Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor Boston, MA 02110-1301 USA. or visit their web page on the internet at: http://www.gnu.org/copyleft/gpl.html. =head1 SEE ALSO perl(1) L<NetAddr::IP::Lite>, L<NetAddr::IP::Util>, L<NetAddr::IP::InetBase> =cut 1; 5.32/Test/LeakTrace/Script.pm 0000555 00000001750 15125513451 0011515 0 ustar 00 package Test::LeakTrace::Script; use strict; use warnings; use Test::LeakTrace (); my $Mode = $ENV{TEST_LEAKTRACE}; sub import{ shift; $Mode = shift if @_; } no warnings 'void'; INIT{ Test::LeakTrace::_start(1); } END{ $Mode = -simple unless defined $Mode; Test::LeakTrace::_finish($Mode); return; } 1; __END__ =head1 NAME Test::LeakTrace::Script - A LeakTrace interface for whole scripts =head1 SYNOPSIS #!perl -w use Test::LeakTrace::Script sub{ my($svref, $file, $line) = @_; warn "leaked $svref from $file line $line.\n"; }; =head1 DESCRIPTION This is a interface to C<Test::LeakTrace> for whole scripts. =head1 INTERFACE =head2 Command line interface $ perl -MTest::LeakTrace::Script script.pl $ perl -MTest::LeakTrace::Script=-verbose script.pl $ TEST_LEAKTRACE=-lines script.pl =head1 ENVIRONMENT VARIABLES =head2 TEST_LEAKTRACE=mode =head3 -simple (DEFAULT) =head3 -sv_dump =head3 -lines =head3 -verbose =head1 SEE ALSO L<Test::LeakTrace>. =cut 5.32/Test/LeakTrace/JA.pod 0000444 00000024025 15125513451 0010706 0 ustar 00 =encoding utf-8 =head1 NAME Test::LeakTrace::JA - メモリリークを追跡する =head1 VERSION This document describes Test::LeakTrace version 0.17. =head1 SYNOPSIS use Test::LeakTrace; # simple report leaktrace{ # ... }; # verbose output leaktrace{ # ... } -verbose; # with callback leaktrace{ # ... } sub { my($ref, $file, $line) = @_; warn "leaked $ref from $file line\n"; }; my @refs = leaked_refs{ # ... }; my @info = leaked_info{ # ... }; my $count = leaked_count{ # ... }; # standard test interface use Test::LeakTrace; no_leaks_ok{ # ... } "description"; leaks_cmp_ok{ # ... } '<', 10; =head1 DESCRIPTION PerlのGCはリファレンスカウンタを用いたものなので,オブジェクトが開放されるタイミングが明確であることや体感速度が高速であることなど数々の利点があります。 その一方で,循環参照を開放できないこと,Cレベルでの操作でミスしやすいなど,問題点がいくつかあります。それらの問題点のほとんどはメモリリークに関することですから,メモリリークを追跡することは非常に重要な課題です。 C<Test::LeakTrce>はメモリリークを追跡するためのいくつかのユーティリティとC<Test::Builder>ベースのテスト関数を提供します。このモジュールはPerlのメモリアロケーションシステムであるアリーナを走査するため,SVに関することであれば与えられたコードのどんなメモリリークでも検出できます。つまり,Perlレベルでの循環参照を始めとして,XSモジュールやPerl自身のバグによるメモリリークを追跡することができます。 ここでB<リーク>とは,特定のスコープ内で新たに作成されて,そのスコープ終了後にも残っている値を意味します。これは,新たに作成されたグローバルな値やPerlが暗黙のうちに作成するキャッシュの値も含みます。たとえば,リーク追跡を行っている最中に新たに名前つきサブルーチンを定義すれば,それはリークとみなされます。また,継承したメソッドを呼び出したり,オブジェクトを作成したりするだけで様々なキャッシュが生成され,リークが報告される可能性があります。 =head1 INTERFACE =head2 Exported functions =head3 C<< leaked_info { BLOCK } >> I<BLOCK>を実行し,追跡結果をリストで返します。 結果はリークした値のリファレンス,ファイル名,行番号の三要素を持つ配列,つまりC<< [$ref, $file, $line] >>のリストとなっています。 なお,この関数はPerl内部で使用する値を返す可能性があります。そのような内部用の値を変更するとPerl実行環境に致命的な影響を与える可能性があるので注意してください。また,配列やハッシュの要素として,リファレンスではない配列やハッシュそれ自体が含まれる可能性があります。そのような値は通常Perlレベルで操作することができません。たとえばC<Data::Dumper>などで出力することはできません。 =head3 C<< leaked_refs { BLOCK } >> I<BLOCK>を実行し,リークしたSVのリファレンスのリストを返します。 C<< map{ $_->[0] } leaked_info{ BLOCK } >>と同じですが,より高速です。 =head3 C<< leaked_count { BLOCK } >> I<BLOCK>を実行し,リークしたSVのリファレンスの個数を返します。 C<leaked_info()>とC<leaked_refs()>もスカラコンテキストでは個数を返しますが, C<leaked_count()>はコンテキストに依存しません。 =head3 C<< leaktrace { BLOCK } ?($mode | \&callback) >> I<BLOCK>を実行し,その中で起きたメモリリークをC<*STDERR>に報告します。 メモリリークの報告はI<$mode>で指定したモードに従います。 受け付けるI<$mode>は以下の通りです: =over 4 =item -simple デフォルトのモードです。リークしたSVの型とアドレス,ファイル名,行番号を報告します。 =item -sv_dump B<-simple>に加えて,C<sv_dump()>でSVの中身をダンプします。 これは,C<Devel::Peek::Dump()>の出力とほぼ同じです。 =item -lines B<-simple>に加えて,リークしていると見られる行の周辺を出力します。 =item -verbose B<-simple>とB<-sv_dump>とB<-lines>の全てを出力します。 =back より細かな制御のためにコールバックを指定することもできます。 I<\&callback>はリークしたSV毎に呼び出され,その引数はリークしたSVのリファレンス,ファイル名,行番号の3つです。 =head3 C<< no_leaks_ok { BLOCK } ?$description >> I<BLOCK>にメモリリークがないことテストします。 これはC<Test::Builder>ベースのテスト関数です。 なお,I<BLOCK>は複数回実行されます。これは,初回の実行でキャッシュを用意する可能性を考慮するためです。 =head3 C<< leaks_cmp_ok { BLOCK } $cmp_op, $count, ?$description >> I<BLOCK>のメモリリーク数と特定の数値を比較するテストを行います。 これはC<Test::Builder>ベースのテスト関数です。 なお,I<BLOCK>は複数回実行されます。これは,初回の実行でキャッシュを用意する可能性を考慮するためです。 =head2 Script interface C<Devel::LeakTrace>と同様に,スクリプトのリーク追跡のためにC<Test::LeakTrace::Script>が提供されます。C<use Test::LeakTrace::Script>宣言の引数はC<leaktrace()>と同じです。 $ TEST_LEAKTRACE=-sv_dump perl -MTest::LeakTrace::Script script.pl $ perl -MTest::LeakTrace::Script=-verbose script.pl #!perl # ... use Test::LeakTrace::Script sub{ my($ref, $file, $line) = @_; # ... }; # ... =head1 EXAMPLES =head2 Testing modules 以下はモジュールのメモリリークをチェックするテストスクリプトのテンプレートです。 #!perl -w use strict; use constant HAS_LEAKTRACE => eval{ require Test::LeakTrace }; use Test::More HAS_LEAKTRACE ? (tests => 1) : (skip_all => 'require Test::LeakTrace'); use Test::LeakTrace; use Some::Module; leaks_cmp_ok{ my $o = Some::Module->new(); $o->something(); $o->something_else(); } '<', 1; =head1 GUTS C<Test::LeakTrace>はアリーナを走査します。アリーナとは,Perlが作成するSVのためのメモリアロケーションシステムであり,F<sv.c>で実装されています。 アリーナの走査にはF<sv.c>にあるC<S_visit()>のコードを元にしたマクロを用いています。 さて,アリーナを走査すれば,メモリリークの検出そのものは簡単にできるように思えます。まず,コードブロックを実行する前に一度アリーナを走査し,全てのSVに「使用済み」の印を付けておきます。次に,コードブロック実行後にもう一度アリーナを走査し,使用済みの印がついていないSVがあれば,それはコードブロック内で作成され,開放されなかったSVだと考えます。あとはそれを報告するだけです。実際には,SVに対して使用済みの印を付けるスペースがないため,インサイドアウト法を応用して外部のコンテナに使用済みの印を保存します。 これを仮にPerlコードで書くと以下のようになります。 my %used_sv; foreach my $sv(@ARENA){ $used_sv{$sv}++; } $block->(); my @leaked foreach my $sv(@ARENA){ if(not exists $used_sv{$sv}){ push @leaked, $sv; } } say 'leaked count: ', scalar @leaked; リークしたSVを得るだけならこの方法で十分です。実際,C<leaked_refs()>とC<leaked_count()>はこのような方法でリークしたSVやその個数を調べています。 しかし,リークしたSVのステートメントの情報,つまりファイル名や行番号を得るためにはこれだけでは不十分です。Perl 5.10以降にはSVが作成されたときのステートメント情報を追跡する機能があるのですが,この機能を利用するためには,コンパイラオプションとしてにC<-DDEBUG_LEAKING_SCALARS>を与えてPerlをビルドしなければなりません。 そこで,C<Test::LeakTrace>では拡張可能なC<PL_runops>を利用して,Perl VMがOPコードを実行する1ステートメント毎にアリーナを走査し,ステートメント情報を記録します。これは,1ステートメント毎にマーク&スイープのような処理を行うのに等しく,非常に時間が掛かります。しかし,Perlを特殊な条件の下でビルドする必要もなく,バージョンに依存した機能もほとんど使用しないため,多くの環境で動かすことができます。 また,C<no_leaks_ok()>のようなテスト関数はまずC<leaked_count()>でリークしたSVの個数を得てから,必要に応じてリークした位置を特定するためにC<leaktrace()>を実行するため,テストが成功する限りは時間の掛かる追跡処理はしません。 =head1 DEPENDENCIES Perl 5.8.1 or later, and a C compiler. =head1 CAVEATS C<Test::LeakTrace>はC<Devel::Cover>と一緒に動かすことはできません。 したがって,C<Devel::Cover>の元で動いていることが検出されると,テスト関数は何も行わずにテストをパスさせます。 =head1 BUGS No bugs have been reported. Please report any bugs or feature requests to the author. =head1 SEE ALSO L<Devel::LeakTrace>. L<Devel::LeakTrace::Fast>. L<Test::TraceObject>. L<Test::Weak>. For guts: L<perlguts>. L<perlhack>. L<sv.c>. =head1 AUTHOR Goro Fuji E<lt>gfuji(at)cpan.orgE<gt>. =head1 LICENSE AND COPYRIGHT Copyright (c) 2009, Goro Fuji. Some rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 5.32/Test/LeakTrace.pm 0000444 00000016136 15125513451 0010252 0 ustar 00 package Test::LeakTrace; use 5.008_001; use strict; use warnings; our $VERSION = '0.17'; use XSLoader; XSLoader::load(__PACKAGE__, $VERSION); use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); use Exporter qw(import); # use Exporter::import for backward compatibility our @EXPORT = qw( leaktrace leaked_refs leaked_info leaked_count no_leaks_ok leaks_cmp_ok count_sv ); our %EXPORT_TAGS = ( all => \@EXPORT, test => [qw(no_leaks_ok leaks_cmp_ok)], util => [qw(leaktrace leaked_refs leaked_info leaked_count count_sv)], ); sub _do_leaktrace{ my($block, $name, $need_stateinfo, $mode) = @_; if(!defined($mode) && !defined wantarray){ warnings::warnif void => "Useless use of $name() in void context"; } if($name eq 'leaked_count') { my $start; $start = count_sv(); $block->(); return count_sv() - $start; } local $SIG{__DIE__} = 'DEFAULT'; _start($need_stateinfo); eval{ $block->(); }; if($@){ _finish(-silent); die $@; } return _finish($mode); } sub leaked_refs(&){ my($block) = @_; return _do_leaktrace($block, 'leaked_refs', 0); } sub leaked_info(&){ my($block) = @_; return _do_leaktrace($block, 'leaked_refs', 1); } sub leaked_count(&){ my($block) = @_; return scalar _do_leaktrace($block, 'leaked_count', 0); } sub leaktrace(&;$){ my($block, $mode) = @_; _do_leaktrace($block, 'leaktrace', 1, defined($mode) ? $mode : -simple); return; } sub leaks_cmp_ok(&$$;$){ my($block, $cmp_op, $expected, $description) = @_; my $Test = __PACKAGE__->builder; if(!_runops_installed()){ my $mod = exists $INC{'Devel/Cover.pm'} ? 'Devel::Cover' : 'strange runops routines'; return $Test->ok(1, "skipped (under $mod)"); } # calls to prepare cache in $block $block->(); my $got = _do_leaktrace($block, 'leaked_count', 0); my $desc = sprintf 'leaks %s %-2s %s', $got, $cmp_op, $expected; if(defined $description){ $description .= " ($desc)"; } else{ $description = $desc; } my $result = $Test->cmp_ok($got, $cmp_op, $expected, $description); if(!$result){ open local(*STDERR), '>', \(my $content = ''); $block->(); # calls it again because opening *STDERR changes the run-time environment _do_leaktrace($block, 'leaktrace', 1, -verbose); $Test->diag($content); } return $result; } sub no_leaks_ok(&;$){ # ($block, $description) splice @_, 1, 0, ('<=', 0); # ($block, '<=', 0, $description); goto &leaks_cmp_ok; } 1; __END__ =for stopwords sv gfx =head1 NAME Test::LeakTrace - Traces memory leaks =head1 VERSION This document describes Test::LeakTrace version 0.17. =head1 SYNOPSIS use Test::LeakTrace; # simple report leaktrace{ # ... }; # verbose output leaktrace{ # ... } -verbose; # with callback leaktrace{ # ... } sub { my($ref, $file, $line) = @_; warn "leaked $ref from $file line\n"; }; my @refs = leaked_refs{ # ... }; my @info = leaked_info{ # ... }; my $count = leaked_count{ # ... }; # standard test interface use Test::LeakTrace; no_leaks_ok{ # ... } 'no memory leaks'; leaks_cmp_ok{ # ... } '<', 10; =head1 DESCRIPTION C<Test::LeakTrace> provides several functions that trace memory leaks. This module scans arenas, the memory allocation system, so it can detect any leaked SVs in given blocks. B<Leaked SVs> are SVs which are not released after the end of the scope they have been created. These SVs include global variables and internal caches. For example, if you call a method in a tracing block, perl might prepare a cache for the method. Thus, to trace true leaks, C<no_leaks_ok()> and C<leaks_cmp_ok()> executes a block more than once. =head1 INTERFACE =head2 Exported functions =head3 C<< leaked_info { BLOCK } >> Executes I<BLOCK> and returns a list of leaked SVs and places where the SVs come from, i.e. C<< [$ref, $file, $line] >>. =head3 C<< leaked_refs { BLOCK } >> Executes I<BLOCK> and returns a list of leaked SVs. =head3 C<< leaked_count { BLOCK } >> Executes I<BLOCK> and returns the number of leaked SVs. =head3 C<< leaktrace { BLOCK } ?($mode | \&callback) >> Executes I<BLOCK> and reports leaked SVs to C<*STDERR>. Defined I<$mode>s are: =over 4 =item -simple Default. Reports the leaked SV identity (type and address), file name and line number. =item -sv_dump In addition to B<-simple>, dumps the sv content using C<sv_dump()>, which also implements C<Devel::Peek::Dump()>. =item -lines In addition to B<-simple>, prints suspicious source lines. =item -verbose Both B<-sv_dump> and B<-lines>. =back =head3 C<< no_leaks_ok { BLOCK } ?$description >> Tests that I<BLOCK> does not leaks SVs. This is a test function using C<Test::Builder>. Note that I<BLOCK> is called more than once. This is because I<BLOCK> might prepare caches which are not memory leaks. =head3 C<< leaks_cmp_ok { BLOCK } $cmp_op, $number, ?$description >> Tests that I<BLOCK> leaks a specific number of SVs. This is a test function using C<Test::Builder>. Note that I<BLOCK> is called more than once. This is because I<BLOCK> might prepare caches which are not memory leaks. =head3 C<< count_sv() >> Counts all the SVs in the arena. =head2 Script interface Like C<Devel::LeakTrace> C<Test::LeakTrace::Script> is provided for whole scripts. The arguments of C<use Test::LeakTrace::Script> directive is the same as C<leaktrace()>. $ TEST_LEAKTRACE=-sv_dump perl -MTest::LeakTrace::Script script.pl $ perl -MTest::LeakTrace::Script=-verbose script.pl #!perl # ... use Test::LeakTrace::Script sub{ my($ref, $file, $line) = @_; # ... }; # ... =head1 EXAMPLES =head2 Testing modules Here is a test script template that checks memory leaks. #!perl -w use strict; use constant HAS_LEAKTRACE => eval{ require Test::LeakTrace }; use Test::More HAS_LEAKTRACE ? (tests => 1) : (skip_all => 'require Test::LeakTrace'); use Test::LeakTrace; use Some::Module; leaks_cmp_ok{ my $o = Some::Module->new(); $o->something(); $o->something_else(); } '<', 1; =head1 DEPENDENCIES Perl 5.8.1 or later, and a C compiler. =head1 CAVEATS C<Test::LeakTrace> does not work with C<Devel::Cover> and modules which install their own C<runops> routines, or the perl executor. So if the test functions of this module detect strange C<runops> routines, they do nothing and report okay. =head1 BUGS No bugs have been reported. Please report any bugs or feature requests to the author. =head1 SEE ALSO L<Devel::LeakTrace>. L<Devel::LeakTrace::Fast>. L<Test::TraceObject>. L<Test::Weak>. For guts: L<perlguts>. L<perlhack>. F<sv.c>. =head1 AUTHOR Goro Fuji(gfx) E<lt>gfuji(at)cpan.orgE<gt>. =head1 LICENSE AND COPYRIGHT Copyright (c) 2009-2010, Goro Fuji(gfx). All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 5.32/auto/HTML/TagParser/.packlist 0000644 00000000134 15125513451 0012352 0 ustar 00 /usr/local/share/man/man3/HTML::TagParser.3pm /usr/local/share/perl5/5.32/HTML/TagParser.pm 5.32/auto/HTML/Form/.packlist 0000644 00000001620 15125513451 0011366 0 ustar 00 /usr/local/share/man/man3/HTML::Form.3pm /usr/local/share/man/man3/HTML::Form::FileInput.3pm /usr/local/share/man/man3/HTML::Form::IgnoreInput.3pm /usr/local/share/man/man3/HTML::Form::ImageInput.3pm /usr/local/share/man/man3/HTML::Form::Input.3pm /usr/local/share/man/man3/HTML::Form::KeygenInput.3pm /usr/local/share/man/man3/HTML::Form::ListInput.3pm /usr/local/share/man/man3/HTML::Form::SubmitInput.3pm /usr/local/share/man/man3/HTML::Form::TextInput.3pm /usr/local/share/perl5/5.32/HTML/Form.pm /usr/local/share/perl5/5.32/HTML/Form/FileInput.pm /usr/local/share/perl5/5.32/HTML/Form/IgnoreInput.pm /usr/local/share/perl5/5.32/HTML/Form/ImageInput.pm /usr/local/share/perl5/5.32/HTML/Form/Input.pm /usr/local/share/perl5/5.32/HTML/Form/KeygenInput.pm /usr/local/share/perl5/5.32/HTML/Form/ListInput.pm /usr/local/share/perl5/5.32/HTML/Form/SubmitInput.pm /usr/local/share/perl5/5.32/HTML/Form/TextInput.pm 5.32/auto/HTML/Tree/.packlist 0000644 00000001632 15125513451 0011365 0 ustar 00 /usr/local/bin/htmltree /usr/local/share/man/man1/htmltree.1 /usr/local/share/man/man3/HTML::AsSubs.3pm /usr/local/share/man/man3/HTML::Element.3pm /usr/local/share/man/man3/HTML::Element::traverse.3pm /usr/local/share/man/man3/HTML::Parse.3pm /usr/local/share/man/man3/HTML::Tree.3pm /usr/local/share/man/man3/HTML::Tree::AboutObjects.3pm /usr/local/share/man/man3/HTML::Tree::AboutTrees.3pm /usr/local/share/man/man3/HTML::Tree::Scanning.3pm /usr/local/share/man/man3/HTML::TreeBuilder.3pm /usr/local/share/perl5/5.32/HTML/AsSubs.pm /usr/local/share/perl5/5.32/HTML/Element.pm /usr/local/share/perl5/5.32/HTML/Element/traverse.pm /usr/local/share/perl5/5.32/HTML/Parse.pm /usr/local/share/perl5/5.32/HTML/Tree.pm /usr/local/share/perl5/5.32/HTML/Tree/AboutObjects.pod /usr/local/share/perl5/5.32/HTML/Tree/AboutTrees.pod /usr/local/share/perl5/5.32/HTML/Tree/Scanning.pod /usr/local/share/perl5/5.32/HTML/TreeBuilder.pm 5.32/auto/local/lib/.packlist 0000644 00000000575 15125513451 0011567 0 ustar 00 /usr/local/share/man/man3/POD2::DE::local::lib.3pm /usr/local/share/man/man3/POD2::PT_BR::local::lib.3pm /usr/local/share/man/man3/lib::core::only.3pm /usr/local/share/man/man3/local::lib.3pm /usr/local/share/perl5/5.32/POD2/DE/local/lib.pod /usr/local/share/perl5/5.32/POD2/PT_BR/local/lib.pod /usr/local/share/perl5/5.32/lib/core/only.pm /usr/local/share/perl5/5.32/local/lib.pm 5.32/auto/version/.packlist 0000644 00000000617 15125513451 0011411 0 ustar 00 /usr/local/lib64/perl5/5.32/auto/version/vxs/vxs.so /usr/local/lib64/perl5/5.32/version.pm /usr/local/lib64/perl5/5.32/version.pod /usr/local/lib64/perl5/5.32/version/Internals.pod /usr/local/lib64/perl5/5.32/version/regex.pm /usr/local/lib64/perl5/5.32/version/vpp.pm /usr/local/lib64/perl5/5.32/version/vxs.pm /usr/local/share/man/man3/version.3pm /usr/local/share/man/man3/version::Internals.3pm 5.32/auto/version/vxs/vxs.so 0000555 00000424300 15125513451 0011601 0 ustar 00 ELF >