diff options
Diffstat (limited to 'lib')
229 files changed, 43 insertions, 97319 deletions
diff --git a/lib/Bundle/Xxv.pm b/lib/Bundle/Xxv.pm index 411e679..a881441 100644 --- a/lib/Bundle/Xxv.pm +++ b/lib/Bundle/Xxv.pm @@ -2,7 +2,7 @@ package Bundle::Xxv; use strict; use warnings; -$VERSION = '0.04'; +$VERSION = '1.0'; 1; @@ -20,55 +20,38 @@ Bundle::Xxv - A bundle to install various xxv related modules =head1 CONTENTS -Test::Simple - Test package to test varios funktion -DBI - Database package for perl -DBD::mysql - Database driver to connect over DBI +CGI +Compress::Zlib Config::Tiny -Event - the great famos Event libary -MIME::Base64 - Code library to encrypt and decrypt Strings -Time::HiRes - High Resolutin timer -Locale::gettext - Localization in perl -Net::Telnet -URI -URI::file -URI::URL -Compress::Zlib - for compressed output -HTML::Tagset -HTML::Parser -HTML::Form -HTTP::Status -HTTP::Daemon -HTTP::Request -LWP::UserAgent -LWP -WWW::Mechanize - for Robot Module -Data::Random -WWW::Mechanize::FormFiller -GD - GD Image library -Digest::SHA1 -Digest::HMAC_MD5 +Data::Dumper +Date::Manip +DBD::mysql +DBI Digest::MD5 -Net::IP -Net::DNS -XML::Parser -XML::RSS - create an rss feed -Math::BigInt::FastCalc -Authen::SASL -XML::Stream -Net::XMPP - create an Jabber message -Proc::Killfam - killall for Perl -Proc::ProcessTable -Term::ReadLine::Gnu - Better Support for telnet interface -Template -SOAP::Lite -MP3::Icecast -MP3::Info -CGI -LWP::Simple -Net::Amazon +Digest::HMAC_MD5 +Event +GD +Getopt::Long +HTML::TextToHTML +HTML::TreeBuilder +JSON +LWP::Simple +LWP::UserAgent +Locale::gettext +MIME::Base64 +MP3::Info +Net::Amazon Net::Amazon::Request::Artist -JSON - Parse and convert to JSON (JavaScript Object Notation) - +Net::Telnet +Net::XMPP +SOAP::Lite +SOAP::Transport::HTTP +Template +Time::Local +Time::HiRes +URI::Escape +XML::RSS +XML::Simple =head1 DESCRIPTION diff --git a/lib/CGI.pm b/lib/CGI.pm deleted file mode 100644 index 148b861..0000000 --- a/lib/CGI.pm +++ /dev/null @@ -1,7318 +0,0 @@ -package CGI; -require 5.004; -use Carp 'croak'; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -# You can run this file through either pod2man or pod2html to produce pretty -# documentation in manual or html file format (these utilities are part of the -# Perl 5 distribution). - -# Copyright 1995-1998 Lincoln D. Stein. All rights reserved. -# It may be used and modified freely, but I do request that this copyright -# notice remain attached to the file. You may modify this module as you -# wish, but if you redistribute a modified version, please attach a note -# listing the modifications you have made. - -# The most recent version and complete docs are available at: -# http://stein.cshl.org/WWW/software/CGI/ - -$CGI::revision = '$Id: CGI.pm,v 1.165 2004/04/12 20:37:26 lstein Exp $'; -$CGI::VERSION=3.05; - -# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. -# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. -# $CGITempFile::TMPDIRECTORY = '/usr/tmp'; -use CGI::Util qw(rearrange make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); - -#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN', -# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd']; - -use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN', - 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd']; - -{ - local $^W = 0; - $TAINTED = substr("$0$^X",0,0); -} - -$MOD_PERL = 0; # no mod_perl by default -@SAVED_SYMBOLS = (); - -# >>>>> Here are some globals that you might want to adjust <<<<<< -sub initialize_globals { - # Set this to 1 to enable copious autoloader debugging messages - $AUTOLOAD_DEBUG = 0; - - # Set this to 1 to generate XTML-compatible output - $XHTML = 1; - - # Change this to the preferred DTD to print in start_html() - # or use default_dtd('text of DTD to use'); - $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN', - 'http://www.w3.org/TR/html4/loose.dtd' ] ; - - # Set this to 1 to enable NOSTICKY scripts - # or: - # 1) use CGI qw(-nosticky) - # 2) $CGI::nosticky(1) - $NOSTICKY = 0; - - # Set this to 1 to enable NPH scripts - # or: - # 1) use CGI qw(-nph) - # 2) CGI::nph(1) - # 3) print header(-nph=>1) - $NPH = 0; - - # Set this to 1 to enable debugging from @ARGV - # Set to 2 to enable debugging from STDIN - $DEBUG = 1; - - # Set this to 1 to make the temporary files created - # during file uploads safe from prying eyes - # or do... - # 1) use CGI qw(:private_tempfiles) - # 2) CGI::private_tempfiles(1); - $PRIVATE_TEMPFILES = 0; - - # Set this to 1 to cause files uploaded in multipart documents - # to be closed, instead of caching the file handle - # or: - # 1) use CGI qw(:close_upload_files) - # 2) $CGI::close_upload_files(1); - # Uploads with many files run out of file handles. - # Also, for performance, since the file is already on disk, - # it can just be renamed, instead of read and written. - $CLOSE_UPLOAD_FILES = 0; - - # Set this to a positive value to limit the size of a POSTing - # to a certain number of bytes: - $POST_MAX = -1; - - # Change this to 1 to disable uploads entirely: - $DISABLE_UPLOADS = 0; - - # Automatically determined -- don't change - $EBCDIC = 0; - - # Change this to 1 to suppress redundant HTTP headers - $HEADERS_ONCE = 0; - - # separate the name=value pairs by semicolons rather than ampersands - $USE_PARAM_SEMICOLONS = 1; - - # Do not include undefined params parsed from query string - # use CGI qw(-no_undef_params); - $NO_UNDEF_PARAMS = 0; - - # Other globals that you shouldn't worry about. - undef $Q; - $BEEN_THERE = 0; - $DTD_PUBLIC_IDENTIFIER = ""; - undef @QUERY_PARAM; - undef %EXPORT; - undef $QUERY_CHARSET; - undef %QUERY_FIELDNAMES; - - # prevent complaints by mod_perl - 1; -} - -# ------------------ START OF THE LIBRARY ------------ - -*end_form = \&endform; - -# make mod_perlhappy -initialize_globals(); - -# FIGURE OUT THE OS WE'RE RUNNING UNDER -# Some systems support the $^O variable. If not -# available then require() the Config library -unless ($OS) { - unless ($OS = $^O) { - require Config; - $OS = $Config::Config{'osname'}; - } -} -if ($OS =~ /^MSWin/i) { - $OS = 'WINDOWS'; -} elsif ($OS =~ /^VMS/i) { - $OS = 'VMS'; -} elsif ($OS =~ /^dos/i) { - $OS = 'DOS'; -} elsif ($OS =~ /^MacOS/i) { - $OS = 'MACINTOSH'; -} elsif ($OS =~ /^os2/i) { - $OS = 'OS2'; -} elsif ($OS =~ /^epoc/i) { - $OS = 'EPOC'; -} elsif ($OS =~ /^cygwin/i) { - $OS = 'CYGWIN'; -} else { - $OS = 'UNIX'; -} - -# Some OS logic. Binary mode enabled on DOS, NT and VMS -$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/; - -# This is the default class for the CGI object to use when all else fails. -$DefaultClass = 'CGI' unless defined $CGI::DefaultClass; - -# This is where to look for autoloaded routines. -$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass; - -# The path separator is a slash, backslash or semicolon, depending -# on the paltform. -$SL = { - UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/', - WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/' - }->{$OS}; - -# This no longer seems to be necessary -# Turn on NPH scripts by default when running under IIS server! -# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; -$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; - -# Turn on special checking for Doug MacEachern's modperl -if (exists $ENV{MOD_PERL}) { - eval "require mod_perl"; - # mod_perl handlers may run system() on scripts using CGI.pm; - # Make sure so we don't get fooled by inherited $ENV{MOD_PERL} - if (defined $mod_perl::VERSION) { - if ($mod_perl::VERSION >= 1.99) { - $MOD_PERL = 2; - require Apache::Response; - require Apache::RequestRec; - require Apache::RequestUtil; - require APR::Pool; - } else { - $MOD_PERL = 1; - require Apache; - } - } -} - -# Turn on special checking for ActiveState's PerlEx -$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; - -# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning -# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF -# and sometimes CR). The most popular VMS web server -# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't -# use ASCII, so \015\012 means something different. I find this all -# really annoying. -$EBCDIC = "\t" ne "\011"; -if ($OS eq 'VMS') { - $CRLF = "\n"; -} elsif ($EBCDIC) { - $CRLF= "\r\n"; -} else { - $CRLF = "\015\012"; -} - -if ($needs_binmode) { - $CGI::DefaultClass->binmode(\*main::STDOUT); - $CGI::DefaultClass->binmode(\*main::STDIN); - $CGI::DefaultClass->binmode(\*main::STDERR); -} - -%EXPORT_TAGS = ( - ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em - tt u i b blockquote pre img a address cite samp dfn html head - base body Link nextid title meta kbd start_html end_html - input Select option comment charset escapeHTML/], - ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param - embed basefont style span layer ilayer font frameset frame script small big Area Map/], - ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe - ins label legend noframes noscript object optgroup Q - thead tbody tfoot/], - ':netscape'=>[qw/blink fontsize center/], - ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group - submit reset defaults radio_group popup_menu button autoEscape - scrolling_list image_button start_form end_form startform endform - start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], - ':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump - raw_cookie request_method query_string Accept user_agent remote_host content_type - remote_addr referer server_name server_software server_port server_protocol virtual_port - virtual_host remote_ident auth_type http append - save_parameters restore_parameters param_fetch - remote_user user_name header redirect import_names put - Delete Delete_all url_param cgi_error/], - ':ssl' => [qw/https/], - ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/], - ':html' => [qw/:html2 :html3 :html4 :netscape/], - ':standard' => [qw/:html2 :html3 :html4 :form :cgi/], - ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/], - ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/] - ); - -# to import symbols into caller -sub import { - my $self = shift; - - # This causes modules to clash. - undef %EXPORT_OK; - undef %EXPORT; - - $self->_setup_symbols(@_); - my ($callpack, $callfile, $callline) = caller; - - # To allow overriding, search through the packages - # Till we find one in which the correct subroutine is defined. - my @packages = ($self,@{"$self\:\:ISA"}); - foreach $sym (keys %EXPORT) { - my $pck; - my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass; - foreach $pck (@packages) { - if (defined(&{"$pck\:\:$sym"})) { - $def = $pck; - last; - } - } - *{"${callpack}::$sym"} = \&{"$def\:\:$sym"}; - } -} - -sub compile { - my $pack = shift; - $pack->_setup_symbols('-compile',@_); -} - -sub expand_tags { - my($tag) = @_; - return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/; - my(@r); - return ($tag) unless $EXPORT_TAGS{$tag}; - foreach (@{$EXPORT_TAGS{$tag}}) { - push(@r,&expand_tags($_)); - } - return @r; -} - -#### Method: new -# The new routine. This will check the current environment -# for an existing query string, and initialize itself, if so. -#### -sub new { - my($class,@initializer) = @_; - my $self = {}; - - bless $self,ref $class || $class || $DefaultClass; - if (ref($initializer[0]) - && (UNIVERSAL::isa($initializer[0],'Apache') - || - UNIVERSAL::isa($initializer[0],'Apache::RequestRec') - )) { - $self->r(shift @initializer); - } - if (ref($initializer[0]) - && (UNIVERSAL::isa($initializer[0],'CODE'))) { - $self->upload_hook(shift @initializer, shift @initializer); - } - if ($MOD_PERL) { - $self->r(Apache->request) unless $self->r; - my $r = $self->r; - if ($MOD_PERL == 1) { - $r->register_cleanup(\&CGI::_reset_globals); - } - else { - # XXX: once we have the new API - # will do a real PerlOptions -SetupEnv check - $r->subprocess_env unless exists $ENV{REQUEST_METHOD}; - $r->pool->cleanup_register(\&CGI::_reset_globals); - } - undef $NPH; - } - $self->_reset_globals if $PERLEX; - $self->init(@initializer); - return $self; -} - -# We provide a DESTROY method so that we can ensure that -# temporary files are closed (via Fh->DESTROY) before they -# are unlinked (via CGITempFile->DESTROY) because it is not -# possible to unlink an open file on Win32. We explicitly -# call DESTROY on each, rather than just undefing them and -# letting Perl DESTROY them by garbage collection, in case the -# user is still holding any reference to them as well. -sub DESTROY { - my $self = shift; - foreach my $href (values %{$self->{'.tmpfiles'}}) { - $href->{hndl}->DESTROY if defined $href->{hndl}; - $href->{name}->DESTROY if defined $href->{name}; - } -} - -sub r { - my $self = shift; - my $r = $self->{'.r'}; - $self->{'.r'} = shift if @_; - $r; -} - -sub upload_hook { - my ($self,$hook,$data) = self_or_default(@_); - $self->{'.upload_hook'} = $hook; - $self->{'.upload_data'} = $data; -} - -#### Method: param -# Returns the value(s)of a named parameter. -# If invoked in a list context, returns the -# entire list. Otherwise returns the first -# member of the list. -# If name is not provided, return a list of all -# the known parameters names available. -# If more than one argument is provided, the -# second and subsequent arguments are used to -# set the value of the parameter. -#### -sub param { - my($self,@p) = self_or_default(@_); - return $self->all_parameters unless @p; - my($name,$value,@other); - - # For compatibility between old calling style and use_named_parameters() style, - # we have to special case for a single parameter present. - if (@p > 1) { - ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p); - my(@values); - - if (substr($p[0],0,1) eq '-') { - @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : (); - } else { - foreach ($value,@other) { - push(@values,$_) if defined($_); - } - } - # If values is provided, then we set it. - if (@values) { - $self->add_parameter($name); - $self->{$name}=[@values]; - } - } else { - $name = $p[0]; - } - - return unless defined($name) && $self->{$name}; - return wantarray ? @{$self->{$name}} : $self->{$name}->[0]; -} - -sub self_or_default { - return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI'); - unless (defined($_[0]) && - (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case - ) { - $Q = $CGI::DefaultClass->new unless defined($Q); - unshift(@_,$Q); - } - return wantarray ? @_ : $Q; -} - -sub self_or_CGI { - local $^W=0; # prevent a warning - if (defined($_[0]) && - (substr(ref($_[0]),0,3) eq 'CGI' - || UNIVERSAL::isa($_[0],'CGI'))) { - return @_; - } else { - return ($DefaultClass,@_); - } -} - -######################################## -# THESE METHODS ARE MORE OR LESS PRIVATE -# GO TO THE __DATA__ SECTION TO SEE MORE -# PUBLIC METHODS -######################################## - -# Initialize the query object from the environment. -# If a parameter list is found, this object will be set -# to an associative array in which parameter names are keys -# and the values are stored as lists -# If a keyword list is found, this method creates a bogus -# parameter list with the single parameter 'keywords'. - -sub init { - my $self = shift; - my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); - - my $initializer = shift; # for backward compatibility - local($/) = "\n"; - - # set autoescaping on by default - $self->{'escape'} = 1; - - # if we get called more than once, we want to initialize - # ourselves from the original query (which may be gone - # if it was read from STDIN originally.) - if (defined(@QUERY_PARAM) && !defined($initializer)) { - foreach (@QUERY_PARAM) { - $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_}); - } - $self->charset($QUERY_CHARSET); - $self->{'.fieldnames'} = {%QUERY_FIELDNAMES}; - return; - } - - $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'}); - $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0; - - $fh = to_filehandle($initializer) if $initializer; - - # set charset to the safe ISO-8859-1 - $self->charset('ISO-8859-1'); - - METHOD: { - - # avoid unreasonably large postings - if (($POST_MAX > 0) && ($content_length > $POST_MAX)) { - # quietly read and discard the post - my $buffer; - my $max = $content_length; - while ($max > 0 && - (my $bytes = $MOD_PERL - ? $self->r->read($buffer,$max < 10000 ? $max : 10000) - : read(STDIN,$buffer,$max < 10000 ? $max : 10000) - )) { - $self->cgi_error("413 Request entity too large"); - last METHOD; - } - } - - # Process multipart postings, but only if the initializer is - # not defined. - if ($meth eq 'POST' - && defined($ENV{'CONTENT_TYPE'}) - && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data| - && !defined($initializer) - ) { - my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/; - $self->read_multipart($boundary,$content_length); - last METHOD; - } - - # If initializer is defined, then read parameters - # from it. - if (defined($initializer)) { - if (UNIVERSAL::isa($initializer,'CGI')) { - $query_string = $initializer->query_string; - last METHOD; - } - if (ref($initializer) && ref($initializer) eq 'HASH') { - foreach (keys %$initializer) { - $self->param('-name'=>$_,'-value'=>$initializer->{$_}); - } - last METHOD; - } - - if (defined($fh) && ($fh ne '')) { - while (<$fh>) { - chomp; - last if /^=/; - push(@lines,$_); - } - # massage back into standard format - if ("@lines" =~ /=/) { - $query_string=join("&",@lines); - } else { - $query_string=join("+",@lines); - } - last METHOD; - } - - if (defined($fh) && ($fh ne '')) { - while (<$fh>) { - chomp; - last if /^=/; - push(@lines,$_); - } - # massage back into standard format - if ("@lines" =~ /=/) { - $query_string=join("&",@lines); - } else { - $query_string=join("+",@lines); - } - last METHOD; - } - - # last chance -- treat it as a string - $initializer = $$initializer if ref($initializer) eq 'SCALAR'; - $query_string = $initializer; - - last METHOD; - } - - # If method is GET or HEAD, fetch the query from - # the environment. - if ($meth=~/^(GET|HEAD)$/) { - if ($MOD_PERL) { - $query_string = $self->r->args; - } else { - $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; - $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'}; - } - last METHOD; - } - - if ($meth eq 'POST') { - $self->read_from_client(\$query_string,$content_length,0) - if $content_length > 0; - # Some people want to have their cake and eat it too! - # Uncomment this line to have the contents of the query string - # APPENDED to the POST data. - # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; - last METHOD; - } - - # If $meth is not of GET, POST or HEAD, assume we're being debugged offline. - # Check the command line and then the standard input for data. - # We use the shellwords package in order to behave the way that - # UN*X programmers expect. - if ($DEBUG) - { - my $cmdline_ret = read_from_cmdline(); - $query_string = $cmdline_ret->{'query_string'}; - if (defined($cmdline_ret->{'subpath'})) - { - $self->path_info($cmdline_ret->{'subpath'}); - } - } - } - -# YL: Begin Change for XML handler 10/19/2001 - if ($meth eq 'POST' - && defined($ENV{'CONTENT_TYPE'}) - && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| - && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) { - my($param) = 'POSTDATA' ; - $self->add_parameter($param) ; - push (@{$self->{$param}},$query_string); - undef $query_string ; - } -# YL: End Change for XML handler 10/19/2001 - - # We now have the query string in hand. We do slightly - # different things for keyword lists and parameter lists. - if (defined $query_string && length $query_string) { - if ($query_string =~ /[&=;]/) { - $self->parse_params($query_string); - } else { - $self->add_parameter('keywords'); - $self->{'keywords'} = [$self->parse_keywordlist($query_string)]; - } - } - - # Special case. Erase everything if there is a field named - # .defaults. - if ($self->param('.defaults')) { - $self->delete_all(); - } - - # Associative array containing our defined fieldnames - $self->{'.fieldnames'} = {}; - foreach ($self->param('.cgifields')) { - $self->{'.fieldnames'}->{$_}++; - } - - # Clear out our default submission button flag if present - $self->delete('.submit'); - $self->delete('.cgifields'); - - $self->save_request unless defined $initializer; -} - -# FUNCTIONS TO OVERRIDE: -# Turn a string into a filehandle -sub to_filehandle { - my $thingy = shift; - return undef unless $thingy; - return $thingy if UNIVERSAL::isa($thingy,'GLOB'); - return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); - if (!ref($thingy)) { - my $caller = 1; - while (my $package = caller($caller++)) { - my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; - return $tmp if defined(fileno($tmp)); - } - } - return undef; -} - -# send output to the browser -sub put { - my($self,@p) = self_or_default(@_); - $self->print(@p); -} - -# print to standard output (for overriding in mod_perl) -sub print { - shift; - CORE::print(@_); -} - -# get/set last cgi_error -sub cgi_error { - my ($self,$err) = self_or_default(@_); - $self->{'.cgi_error'} = $err if defined $err; - return $self->{'.cgi_error'}; -} - -sub save_request { - my($self) = @_; - # We're going to play with the package globals now so that if we get called - # again, we initialize ourselves in exactly the same way. This allows - # us to have several of these objects. - @QUERY_PARAM = $self->param; # save list of parameters - foreach (@QUERY_PARAM) { - next unless defined $_; - $QUERY_PARAM{$_}=$self->{$_}; - } - $QUERY_CHARSET = $self->charset; - %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}}; -} - -sub parse_params { - my($self,$tosplit) = @_; - my(@pairs) = split(/[&;]/,$tosplit); - my($param,$value); - foreach (@pairs) { - ($param,$value) = split('=',$_,2); - next unless defined $param; - next if $NO_UNDEF_PARAMS and not defined $value; - $value = '' unless defined $value; - $param = unescape($param); - $value = unescape($value); - $self->add_parameter($param); - push (@{$self->{$param}},$value); - } -} - -sub add_parameter { - my($self,$param)=@_; - return unless defined $param; - push (@{$self->{'.parameters'}},$param) - unless defined($self->{$param}); -} - -sub all_parameters { - my $self = shift; - return () unless defined($self) && $self->{'.parameters'}; - return () unless @{$self->{'.parameters'}}; - return @{$self->{'.parameters'}}; -} - -# put a filehandle into binary mode (DOS) -sub binmode { - return unless defined($_[1]) && defined fileno($_[1]); - CORE::binmode($_[1]); -} - -sub _make_tag_func { - my ($self,$tagname) = @_; - my $func = qq( - sub $tagname { - my (\$q,\$a,\@rest) = self_or_default(\@_); - my(\$attr) = ''; - if (ref(\$a) && ref(\$a) eq 'HASH') { - my(\@attr) = make_attributes(\$a,\$q->{'escape'}); - \$attr = " \@attr" if \@attr; - } else { - unshift \@rest,\$a if defined \$a; - } - ); - if ($tagname=~/start_(\w+)/i) { - $func .= qq! return "<\L$1\E\$attr>";} !; - } elsif ($tagname=~/end_(\w+)/i) { - $func .= qq! return "<\L/$1\E>"; } !; - } else { - $func .= qq# - return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest; - my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E"); - my \@result = map { "\$tag\$_\$untag" } - (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest"; - return "\@result"; - }#; - } -return $func; -} - -sub AUTOLOAD { - print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG; - my $func = &_compile; - goto &$func; -} - -sub _compile { - my($func) = $AUTOLOAD; - my($pack,$func_name); - { - local($1,$2); # this fixes an obscure variable suicide problem. - $func=~/(.+)::([^:]+)$/; - ($pack,$func_name) = ($1,$2); - $pack=~s/::SUPER$//; # fix another obscure problem - $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass - unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"}); - - my($sub) = \%{"$pack\:\:SUBS"}; - unless (%$sub) { - my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; - eval "package $pack; $$auto"; - croak("$AUTOLOAD: $@") if $@; - $$auto = ''; # Free the unneeded storage (but don't undef it!!!) - } - my($code) = $sub->{$func_name}; - - $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY'); - if (!$code) { - (my $base = $func_name) =~ s/^(start_|end_)//i; - if ($EXPORT{':any'} || - $EXPORT{'-any'} || - $EXPORT{$base} || - (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html'))) - && $EXPORT_OK{$base}) { - $code = $CGI::DefaultClass->_make_tag_func($func_name); - } - } - croak("Undefined subroutine $AUTOLOAD\n") unless $code; - eval "package $pack; $code"; - if ($@) { - $@ =~ s/ at .*\n//; - croak("$AUTOLOAD: $@"); - } - } - CORE::delete($sub->{$func_name}); #free storage - return "$pack\:\:$func_name"; -} - -sub _selected { - my $self = shift; - my $value = shift; - return '' unless $value; - return $XHTML ? qq( selected="selected") : qq( selected); -} - -sub _checked { - my $self = shift; - my $value = shift; - return '' unless $value; - return $XHTML ? qq( checked="checked") : qq( checked); -} - -sub _reset_globals { initialize_globals(); } - -sub _setup_symbols { - my $self = shift; - my $compile = 0; - - # to avoid reexporting unwanted variables - undef %EXPORT; - - foreach (@_) { - $HEADERS_ONCE++, next if /^[:-]unique_headers$/; - $NPH++, next if /^[:-]nph$/; - $NOSTICKY++, next if /^[:-]nosticky$/; - $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/; - $DEBUG=2, next if /^[:-][Dd]ebug$/; - $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; - $XHTML++, next if /^[:-]xhtml$/; - $XHTML=0, next if /^[:-]no_?xhtml$/; - $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/; - $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/; - $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/; - $EXPORT{$_}++, next if /^[:-]any$/; - $compile++, next if /^[:-]compile$/; - $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/; - - # This is probably extremely evil code -- to be deleted some day. - if (/^[-]autoload$/) { - my($pkg) = caller(1); - *{"${pkg}::AUTOLOAD"} = sub { - my($routine) = $AUTOLOAD; - $routine =~ s/^.*::/CGI::/; - &$routine; - }; - next; - } - - foreach (&expand_tags($_)) { - tr/a-zA-Z0-9_//cd; # don't allow weird function names - $EXPORT{$_}++; - } - } - _compile_all(keys %EXPORT) if $compile; - @SAVED_SYMBOLS = @_; -} - -sub charset { - my ($self,$charset) = self_or_default(@_); - $self->{'.charset'} = $charset if defined $charset; - $self->{'.charset'}; -} - -############################################################################### -################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### -############################################################################### -$AUTOLOADED_ROUTINES = ''; # get rid of -w warning -$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; - -%SUBS = ( - -'URL_ENCODED'=> <<'END_OF_FUNC', -sub URL_ENCODED { 'application/x-www-form-urlencoded'; } -END_OF_FUNC - -'MULTIPART' => <<'END_OF_FUNC', -sub MULTIPART { 'multipart/form-data'; } -END_OF_FUNC - -'SERVER_PUSH' => <<'END_OF_FUNC', -sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; } -END_OF_FUNC - -'new_MultipartBuffer' => <<'END_OF_FUNC', -# Create a new multipart buffer -sub new_MultipartBuffer { - my($self,$boundary,$length) = @_; - return MultipartBuffer->new($self,$boundary,$length); -} -END_OF_FUNC - -'read_from_client' => <<'END_OF_FUNC', -# Read data from a file handle -sub read_from_client { - my($self, $buff, $len, $offset) = @_; - local $^W=0; # prevent a warning - return $MOD_PERL - ? $self->r->read($$buff, $len, $offset) - : read(\*STDIN, $$buff, $len, $offset); -} -END_OF_FUNC - -'delete' => <<'END_OF_FUNC', -#### Method: delete -# Deletes the named parameter entirely. -#### -sub delete { - my($self,@p) = self_or_default(@_); - my(@names) = rearrange([NAME],@p); - my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names; - my %to_delete; - foreach my $name (@to_delete) - { - CORE::delete $self->{$name}; - CORE::delete $self->{'.fieldnames'}->{$name}; - $to_delete{$name}++; - } - @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param(); - return; -} -END_OF_FUNC - -#### Method: import_names -# Import all parameters into the given namespace. -# Assumes namespace 'Q' if not specified -#### -'import_names' => <<'END_OF_FUNC', -sub import_names { - my($self,$namespace,$delete) = self_or_default(@_); - $namespace = 'Q' unless defined($namespace); - die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::; - if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) { - # can anyone find an easier way to do this? - foreach (keys %{"${namespace}::"}) { - local *symbol = "${namespace}::${_}"; - undef $symbol; - undef @symbol; - undef %symbol; - } - } - my($param,@value,$var); - foreach $param ($self->param) { - # protect against silly names - ($var = $param)=~tr/a-zA-Z0-9_/_/c; - $var =~ s/^(?=\d)/_/; - local *symbol = "${namespace}::$var"; - @value = $self->param($param); - @symbol = @value; - $symbol = $value[0]; - } -} -END_OF_FUNC - -#### Method: keywords -# Keywords acts a bit differently. Calling it in a list context -# returns the list of keywords. -# Calling it in a scalar context gives you the size of the list. -#### -'keywords' => <<'END_OF_FUNC', -sub keywords { - my($self,@values) = self_or_default(@_); - # If values is provided, then we set it. - $self->{'keywords'}=[@values] if @values; - my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : (); - @result; -} -END_OF_FUNC - -# These are some tie() interfaces for compatibility -# with Steve Brenner's cgi-lib.pl routines -'Vars' => <<'END_OF_FUNC', -sub Vars { - my $q = shift; - my %in; - tie(%in,CGI,$q); - return %in if wantarray; - return \%in; -} -END_OF_FUNC - -# These are some tie() interfaces for compatibility -# with Steve Brenner's cgi-lib.pl routines -'ReadParse' => <<'END_OF_FUNC', -sub ReadParse { - local(*in); - if (@_) { - *in = $_[0]; - } else { - my $pkg = caller(); - *in=*{"${pkg}::in"}; - } - tie(%in,CGI); - return scalar(keys %in); -} -END_OF_FUNC - -'PrintHeader' => <<'END_OF_FUNC', -sub PrintHeader { - my($self) = self_or_default(@_); - return $self->header(); -} -END_OF_FUNC - -'HtmlTop' => <<'END_OF_FUNC', -sub HtmlTop { - my($self,@p) = self_or_default(@_); - return $self->start_html(@p); -} -END_OF_FUNC - -'HtmlBot' => <<'END_OF_FUNC', -sub HtmlBot { - my($self,@p) = self_or_default(@_); - return $self->end_html(@p); -} -END_OF_FUNC - -'SplitParam' => <<'END_OF_FUNC', -sub SplitParam { - my ($param) = @_; - my (@params) = split ("\0", $param); - return (wantarray ? @params : $params[0]); -} -END_OF_FUNC - -'MethGet' => <<'END_OF_FUNC', -sub MethGet { - return request_method() eq 'GET'; -} -END_OF_FUNC - -'MethPost' => <<'END_OF_FUNC', -sub MethPost { - return request_method() eq 'POST'; -} -END_OF_FUNC - -'TIEHASH' => <<'END_OF_FUNC', -sub TIEHASH { - my $class = shift; - my $arg = $_[0]; - if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) { - return $arg; - } - return $Q ||= $class->new(@_); -} -END_OF_FUNC - -'STORE' => <<'END_OF_FUNC', -sub STORE { - my $self = shift; - my $tag = shift; - my $vals = shift; - my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals; - $self->param(-name=>$tag,-value=>\@vals); -} -END_OF_FUNC - -'FETCH' => <<'END_OF_FUNC', -sub FETCH { - return $_[0] if $_[1] eq 'CGI'; - return undef unless defined $_[0]->param($_[1]); - return join("\0",$_[0]->param($_[1])); -} -END_OF_FUNC - -'FIRSTKEY' => <<'END_OF_FUNC', -sub FIRSTKEY { - $_[0]->{'.iterator'}=0; - $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; -} -END_OF_FUNC - -'NEXTKEY' => <<'END_OF_FUNC', -sub NEXTKEY { - $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; -} -END_OF_FUNC - -'EXISTS' => <<'END_OF_FUNC', -sub EXISTS { - exists $_[0]->{$_[1]}; -} -END_OF_FUNC - -'DELETE' => <<'END_OF_FUNC', -sub DELETE { - $_[0]->delete($_[1]); -} -END_OF_FUNC - -'CLEAR' => <<'END_OF_FUNC', -sub CLEAR { - %{$_[0]}=(); -} -#### -END_OF_FUNC - -#### -# Append a new value to an existing query -#### -'append' => <<'EOF', -sub append { - my($self,@p) = @_; - my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p); - my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); - if (@values) { - $self->add_parameter($name); - push(@{$self->{$name}},@values); - } - return $self->param($name); -} -EOF - -#### Method: delete_all -# Delete all parameters -#### -'delete_all' => <<'EOF', -sub delete_all { - my($self) = self_or_default(@_); - my @param = $self->param(); - $self->delete(@param); -} -EOF - -'Delete' => <<'EOF', -sub Delete { - my($self,@p) = self_or_default(@_); - $self->delete(@p); -} -EOF - -'Delete_all' => <<'EOF', -sub Delete_all { - my($self,@p) = self_or_default(@_); - $self->delete_all(@p); -} -EOF - -#### Method: autoescape -# If you want to turn off the autoescaping features, -# call this method with undef as the argument -'autoEscape' => <<'END_OF_FUNC', -sub autoEscape { - my($self,$escape) = self_or_default(@_); - my $d = $self->{'escape'}; - $self->{'escape'} = $escape; - $d; -} -END_OF_FUNC - - -#### Method: version -# Return the current version -#### -'version' => <<'END_OF_FUNC', -sub version { - return $VERSION; -} -END_OF_FUNC - -#### Method: url_param -# Return a parameter in the QUERY_STRING, regardless of -# whether this was a POST or a GET -#### -'url_param' => <<'END_OF_FUNC', -sub url_param { - my ($self,@p) = self_or_default(@_); - my $name = shift(@p); - return undef unless exists($ENV{QUERY_STRING}); - unless (exists($self->{'.url_param'})) { - $self->{'.url_param'}={}; # empty hash - if ($ENV{QUERY_STRING} =~ /=/) { - my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING}); - my($param,$value); - foreach (@pairs) { - ($param,$value) = split('=',$_,2); - $param = unescape($param); - $value = unescape($value); - push(@{$self->{'.url_param'}->{$param}},$value); - } - } else { - $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})]; - } - } - return keys %{$self->{'.url_param'}} unless defined($name); - return () unless $self->{'.url_param'}->{$name}; - return wantarray ? @{$self->{'.url_param'}->{$name}} - : $self->{'.url_param'}->{$name}->[0]; -} -END_OF_FUNC - -#### Method: Dump -# Returns a string in which all the known parameter/value -# pairs are represented as nested lists, mainly for the purposes -# of debugging. -#### -'Dump' => <<'END_OF_FUNC', -sub Dump { - my($self) = self_or_default(@_); - my($param,$value,@result); - return '<ul></ul>' unless $self->param; - push(@result,"<ul>"); - foreach $param ($self->param) { - my($name)=$self->escapeHTML($param); - push(@result,"<li><strong>$param</strong></li>"); - push(@result,"<ul>"); - foreach $value ($self->param($param)) { - $value = $self->escapeHTML($value); - $value =~ s/\n/<br \/>\n/g; - push(@result,"<li>$value</li>"); - } - push(@result,"</ul>"); - } - push(@result,"</ul>"); - return join("\n",@result); -} -END_OF_FUNC - -#### Method as_string -# -# synonym for "dump" -#### -'as_string' => <<'END_OF_FUNC', -sub as_string { - &Dump(@_); -} -END_OF_FUNC - -#### Method: save -# Write values out to a filehandle in such a way that they can -# be reinitialized by the filehandle form of the new() method -#### -'save' => <<'END_OF_FUNC', -sub save { - my($self,$filehandle) = self_or_default(@_); - $filehandle = to_filehandle($filehandle); - my($param); - local($,) = ''; # set print field separator back to a sane value - local($\) = ''; # set output line separator to a sane value - foreach $param ($self->param) { - my($escaped_param) = escape($param); - my($value); - foreach $value ($self->param($param)) { - print $filehandle "$escaped_param=",escape("$value"),"\n"; - } - } - foreach (keys %{$self->{'.fieldnames'}}) { - print $filehandle ".cgifields=",escape("$_"),"\n"; - } - print $filehandle "=\n"; # end of record -} -END_OF_FUNC - - -#### Method: save_parameters -# An alias for save() that is a better name for exportation. -# Only intended to be used with the function (non-OO) interface. -#### -'save_parameters' => <<'END_OF_FUNC', -sub save_parameters { - my $fh = shift; - return save(to_filehandle($fh)); -} -END_OF_FUNC - -#### Method: restore_parameters -# A way to restore CGI parameters from an initializer. -# Only intended to be used with the function (non-OO) interface. -#### -'restore_parameters' => <<'END_OF_FUNC', -sub restore_parameters { - $Q = $CGI::DefaultClass->new(@_); -} -END_OF_FUNC - -#### Method: multipart_init -# Return a Content-Type: style header for server-push -# This has to be NPH on most web servers, and it is advisable to set $| = 1 -# -# Many thanks to Ed Jordan <ed@fidalgo.net> for this -# contribution, updated by Andrew Benham (adsb@bigfoot.com) -#### -'multipart_init' => <<'END_OF_FUNC', -sub multipart_init { - my($self,@p) = self_or_default(@_); - my($boundary,@other) = rearrange([BOUNDARY],@p); - $boundary = $boundary || '------- =_aaaaaaaaaa0'; - $self->{'separator'} = "$CRLF--$boundary$CRLF"; - $self->{'final_separator'} = "$CRLF--$boundary--$CRLF"; - $type = SERVER_PUSH($boundary); - return $self->header( - -nph => 0, - -type => $type, - (map { split "=", $_, 2 } @other), - ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end; -} -END_OF_FUNC - - -#### Method: multipart_start -# Return a Content-Type: style header for server-push, start of section -# -# Many thanks to Ed Jordan <ed@fidalgo.net> for this -# contribution, updated by Andrew Benham (adsb@bigfoot.com) -#### -'multipart_start' => <<'END_OF_FUNC', -sub multipart_start { - my(@header); - my($self,@p) = self_or_default(@_); - my($type,@other) = rearrange([TYPE],@p); - $type = $type || 'text/html'; - push(@header,"Content-Type: $type"); - - # rearrange() was designed for the HTML portion, so we - # need to fix it up a little. - foreach (@other) { - # Don't use \s because of perl bug 21951 - next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/; - ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e; - } - push(@header,@other); - my $header = join($CRLF,@header)."${CRLF}${CRLF}"; - return $header; -} -END_OF_FUNC - - -#### Method: multipart_end -# Return a MIME boundary separator for server-push, end of section -# -# Many thanks to Ed Jordan <ed@fidalgo.net> for this -# contribution -#### -'multipart_end' => <<'END_OF_FUNC', -sub multipart_end { - my($self,@p) = self_or_default(@_); - return $self->{'separator'}; -} -END_OF_FUNC - - -#### Method: multipart_final -# Return a MIME boundary separator for server-push, end of all sections -# -# Contributed by Andrew Benham (adsb@bigfoot.com) -#### -'multipart_final' => <<'END_OF_FUNC', -sub multipart_final { - my($self,@p) = self_or_default(@_); - return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF; -} -END_OF_FUNC - - -#### Method: header -# Return a Content-Type: style header -# -#### -'header' => <<'END_OF_FUNC', -sub header { - my($self,@p) = self_or_default(@_); - my(@header); - - return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE; - - my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) = - rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], - 'STATUS',['COOKIE','COOKIES'],'TARGET', - 'EXPIRES','NPH','CHARSET', - 'ATTACHMENT','P3P'],@p); - - $nph ||= $NPH; - if (defined $charset) { - $self->charset($charset); - } else { - $charset = $self->charset; - } - - # rearrange() was designed for the HTML portion, so we - # need to fix it up a little. - foreach (@other) { - # Don't use \s because of perl bug 21951 - next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/; - ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e; - } - - $type ||= 'text/html' unless defined($type); - $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/ and $charset ne ''; - - # Maybe future compatibility. Maybe not. - my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; - push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph; - push(@header,"Server: " . &server_software()) if $nph; - - push(@header,"Status: $status") if $status; - push(@header,"Window-Target: $target") if $target; - if ($p3p) { - $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY'; - push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p")); - } - # push all the cookies -- there may be several - if ($cookie) { - my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie; - foreach (@cookie) { - my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; - push(@header,"Set-Cookie: $cs") if $cs ne ''; - } - } - # if the user indicates an expiration time, then we need - # both an Expires and a Date header (so that the browser is - # uses OUR clock) - push(@header,"Expires: " . expires($expires,'http')) - if $expires; - push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph; - push(@header,"Pragma: no-cache") if $self->cache(); - push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment; - push(@header,map {ucfirst $_} @other); - push(@header,"Content-Type: $type") if $type ne ''; - my $header = join($CRLF,@header)."${CRLF}${CRLF}"; - if ($MOD_PERL and not $nph) { - $self->r->send_cgi_header($header); - return ''; - } - return $header; -} -END_OF_FUNC - - -#### Method: cache -# Control whether header() will produce the no-cache -# Pragma directive. -#### -'cache' => <<'END_OF_FUNC', -sub cache { - my($self,$new_value) = self_or_default(@_); - $new_value = '' unless $new_value; - if ($new_value ne '') { - $self->{'cache'} = $new_value; - } - return $self->{'cache'}; -} -END_OF_FUNC - - -#### Method: redirect -# Return a Location: style header -# -#### -'redirect' => <<'END_OF_FUNC', -sub redirect { - my($self,@p) = self_or_default(@_); - my($url,$target,$status,$cookie,$nph,@other) = - rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p); - $status = '302 Moved' unless defined $status; - $url ||= $self->self_url; - my(@o); - foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); } - unshift(@o, - '-Status' => $status, - '-Location'=> $url, - '-nph' => $nph); - unshift(@o,'-Target'=>$target) if $target; - unshift(@o,'-Type'=>''); - my @unescaped; - unshift(@unescaped,'-Cookie'=>$cookie) if $cookie; - return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped); -} -END_OF_FUNC - - -#### Method: start_html -# Canned HTML header -# -# Parameters: -# $title -> (optional) The title for this HTML document (-title) -# $author -> (optional) e-mail address of the author (-author) -# $base -> (optional) if set to true, will enter the BASE address of this document -# for resolving relative references (-base) -# $xbase -> (optional) alternative base at some remote location (-xbase) -# $target -> (optional) target window to load all links into (-target) -# $script -> (option) Javascript code (-script) -# $no_script -> (option) Javascript <noscript> tag (-noscript) -# $meta -> (optional) Meta information tags -# $head -> (optional) any other elements you'd like to incorporate into the <head> tag -# (a scalar or array ref) -# $style -> (optional) reference to an external style sheet -# @other -> (optional) any other named parameters you'd like to incorporate into -# the <body> tag. -#### -'start_html' => <<'END_OF_FUNC', -sub start_html { - my($self,@p) = &self_or_default(@_); - my($title,$author,$base,$xbase,$script,$noscript, - $target,$meta,$head,$style,$dtd,$lang,$encoding,@other) = - rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD,LANG,ENCODING],@p); - - $encoding = 'iso-8859-1' unless defined $encoding; - - # Need to sort out the DTD before it's okay to call escapeHTML(). - my(@result,$xml_dtd); - if ($dtd) { - if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) { - $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|; - } else { - $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|; - } - } else { - $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD; - } - - $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i; - $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i; - push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd; - - if (ref($dtd) && ref($dtd) eq 'ARRAY') { - push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">)); - $DTD_PUBLIC_IDENTIFIER = $dtd->[0]; - } else { - push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">)); - $DTD_PUBLIC_IDENTIFIER = $dtd; - } - - # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to - # call escapeHTML(). Strangely enough, the title needs to be escaped as - # HTML while the author needs to be escaped as a URL. - $title = $self->escapeHTML($title || 'Untitled Document'); - $author = $self->escape($author); - - if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2)/i) { - $lang = "" unless defined $lang; - $XHTML = 0; - } - else { - $lang = 'en-US' unless defined $lang; - } - - push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml" lang="$lang" xml:lang="$lang"><head><title>$title</title>) - : ($lang ? qq(<html lang="$lang">) : "<html>") - . "<head><title>$title</title>"); - if (defined $author) { - push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />" - : "<link rev=\"made\" href=\"mailto:$author\">"); - } - - if ($base || $xbase || $target) { - my $href = $xbase || $self->url('-path'=>1); - my $t = $target ? qq/ target="$target"/ : ''; - push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>)); - } - - if ($meta && ref($meta) && (ref($meta) eq 'HASH')) { - foreach (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />) - : qq(<meta name="$_" content="$meta->{$_}">)); } - } - - push(@result,ref($head) ? @$head : $head) if $head; - - # handle the infrequently-used -style and -script parameters - push(@result,$self->_style($style)) if defined $style; - push(@result,$self->_script($script)) if defined $script; - - # handle -noscript parameter - push(@result,<<END) if $noscript; -<noscript> -$noscript -</noscript> -END - ; - my($other) = @other ? " @other" : ''; - push(@result,"</head><body$other>"); - return join("\n",@result); -} -END_OF_FUNC - -### Method: _style -# internal method for generating a CSS style section -#### -'_style' => <<'END_OF_FUNC', -sub _style { - my ($self,$style) = @_; - my (@result); - my $type = 'text/css'; - - my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- "; - my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n"; - - my @s = ref($style) eq 'ARRAY' ? @$style : $style; - - for my $s (@s) { - if (ref($s)) { - my($src,$code,$verbatim,$stype,$foo,@other) = - rearrange([qw(SRC CODE VERBATIM TYPE FOO)], - ('-foo'=>'bar', - ref($s) eq 'ARRAY' ? @$s : %$s)); - $type = $stype if $stype; - my $other = @other ? join ' ',@other : ''; - - if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference - { # If it is, push a LINK tag for each one - foreach $src (@$src) - { - push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>) - : qq(<link rel="stylesheet" type="$type" href="$src"$other>)) if $src; - } - } - else - { # Otherwise, push the single -src, if it exists. - push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>) - : qq(<link rel="stylesheet" type="$type" href="$src"$other>) - ) if $src; - } - if ($verbatim) { - my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim; - push(@result, "<style type=\"text/css\">\n$_\n</style>") foreach @v; - } - my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code; - push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) foreach @c; - - } else { - my $src = $s; - push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" $other/>) - : qq(<link rel="stylesheet" type="$type" href="$src"$other>)); - } - } - @result; -} -END_OF_FUNC - -'_script' => <<'END_OF_FUNC', -sub _script { - my ($self,$script) = @_; - my (@result); - - my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script); - foreach $script (@scripts) { - my($src,$code,$language); - if (ref($script)) { # script is a hash - ($src,$code,$language, $type) = - rearrange([SRC,CODE,LANGUAGE,TYPE], - '-foo'=>'bar', # a trick to allow the '-' to be omitted - ref($script) eq 'ARRAY' ? @$script : %$script); - # User may not have specified language - $language ||= 'JavaScript'; - unless (defined $type) { - $type = lc $language; - # strip '1.2' from 'javascript1.2' - $type =~ s/^(\D+).*$/text\/$1/; - } - } else { - ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript'); - } - - my $comment = '//'; # javascript by default - $comment = '#' if $type=~/perl|tcl/i; - $comment = "'" if $type=~/vbscript/i; - - my ($cdata_start,$cdata_end); - if ($XHTML) { - $cdata_start = "$comment<![CDATA[\n"; - $cdata_end .= "\n$comment]]>"; - } else { - $cdata_start = "\n<!-- Hide script\n"; - $cdata_end = $comment; - $cdata_end .= " End script hiding -->\n"; - } - my(@satts); - push(@satts,'src'=>$src) if $src; - push(@satts,'language'=>$language) unless defined $type; - push(@satts,'type'=>$type); - $code = "$cdata_start$code$cdata_end" if defined $code; - push(@result,script({@satts},$code || '')); - } - @result; -} -END_OF_FUNC - -#### Method: end_html -# End an HTML document. -# Trivial method for completeness. Just returns "</body>" -#### -'end_html' => <<'END_OF_FUNC', -sub end_html { - return "</body></html>"; -} -END_OF_FUNC - - -################################ -# METHODS USED IN BUILDING FORMS -################################ - -#### Method: isindex -# Just prints out the isindex tag. -# Parameters: -# $action -> optional URL of script to run -# Returns: -# A string containing a <isindex> tag -'isindex' => <<'END_OF_FUNC', -sub isindex { - my($self,@p) = self_or_default(@_); - my($action,@other) = rearrange([ACTION],@p); - $action = qq/ action="$action"/ if $action; - my($other) = @other ? " @other" : ''; - return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>"; -} -END_OF_FUNC - - -#### Method: startform -# Start a form -# Parameters: -# $method -> optional submission method to use (GET or POST) -# $action -> optional URL of script to run -# $enctype ->encoding to use (URL_ENCODED or MULTIPART) -'startform' => <<'END_OF_FUNC', -sub startform { - my($self,@p) = self_or_default(@_); - - my($method,$action,$enctype,@other) = - rearrange([METHOD,ACTION,ENCTYPE],@p); - - $method = $self->escapeHTML(lc($method) || 'post'); - $enctype = $self->escapeHTML($enctype || &URL_ENCODED); - if (defined $action) { - $action = $self->escapeHTML($action); - } - else { - $action = $self->escapeHTML($self->url(-absolute=>1,-path=>1)); - if (exists $ENV{QUERY_STRING} && length($ENV{QUERY_STRING})>0) { - $action .= "?".$self->escapeHTML($ENV{QUERY_STRING},1); - } - } - $action = qq(action="$action"); - my($other) = @other ? " @other" : ''; - $self->{'.parametersToAdd'}={}; - return qq/<form method="$method" $action enctype="$enctype"$other>\n/; -} -END_OF_FUNC - - -#### Method: start_form -# synonym for startform -'start_form' => <<'END_OF_FUNC', -sub start_form { - &startform; -} -END_OF_FUNC - -'end_multipart_form' => <<'END_OF_FUNC', -sub end_multipart_form { - &endform; -} -END_OF_FUNC - -#### Method: start_multipart_form -# synonym for startform -'start_multipart_form' => <<'END_OF_FUNC', -sub start_multipart_form { - my($self,@p) = self_or_default(@_); - if (defined($param[0]) && substr($param[0],0,1) eq '-') { - my(%p) = @p; - $p{'-enctype'}=&MULTIPART; - return $self->startform(%p); - } else { - my($method,$action,@other) = - rearrange([METHOD,ACTION],@p); - return $self->startform($method,$action,&MULTIPART,@other); - } -} -END_OF_FUNC - - -#### Method: endform -# End a form -'endform' => <<'END_OF_FUNC', -sub endform { - my($self,@p) = self_or_default(@_); - if ( $NOSTICKY ) { - return wantarray ? ("</form>") : "\n</form>"; - } else { - return wantarray ? ("<div>",$self->get_fields,"</div>","</form>") : - "<div>".$self->get_fields ."</div>\n</form>"; - } -} -END_OF_FUNC - - -'_textfield' => <<'END_OF_FUNC', -sub _textfield { - my($self,$tag,@p) = self_or_default(@_); - my($name,$default,$size,$maxlength,$override,@other) = - rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); - - my $current = $override ? $default : - (defined($self->param($name)) ? $self->param($name) : $default); - - $current = defined($current) ? $self->escapeHTML($current,1) : ''; - $name = defined($name) ? $self->escapeHTML($name) : ''; - my($s) = defined($size) ? qq/ size="$size"/ : ''; - my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : ''; - my($other) = @other ? " @other" : ''; - # this entered at cristy's request to fix problems with file upload fields - # and WebTV -- not sure it won't break stuff - my($value) = $current ne '' ? qq(value="$current") : ''; - return $XHTML ? qq(<input type="$tag" name="$name" $value$s$m$other />) - : qq(<input type="$tag" name="$name" $value$s$m$other>); -} -END_OF_FUNC - -#### Method: textfield -# Parameters: -# $name -> Name of the text field -# $default -> Optional default value of the field if not -# already defined. -# $size -> Optional width of field in characaters. -# $maxlength -> Optional maximum number of characters. -# Returns: -# A string containing a <input type="text"> field -# -'textfield' => <<'END_OF_FUNC', -sub textfield { - my($self,@p) = self_or_default(@_); - $self->_textfield('text',@p); -} -END_OF_FUNC - - -#### Method: filefield -# Parameters: -# $name -> Name of the file upload field -# $size -> Optional width of field in characaters. -# $maxlength -> Optional maximum number of characters. -# Returns: -# A string containing a <input type="file"> field -# -'filefield' => <<'END_OF_FUNC', -sub filefield { - my($self,@p) = self_or_default(@_); - $self->_textfield('file',@p); -} -END_OF_FUNC - - -#### Method: password -# Create a "secret password" entry field -# Parameters: -# $name -> Name of the field -# $default -> Optional default value of the field if not -# already defined. -# $size -> Optional width of field in characters. -# $maxlength -> Optional maximum characters that can be entered. -# Returns: -# A string containing a <input type="password"> field -# -'password_field' => <<'END_OF_FUNC', -sub password_field { - my ($self,@p) = self_or_default(@_); - $self->_textfield('password',@p); -} -END_OF_FUNC - -#### Method: textarea -# Parameters: -# $name -> Name of the text field -# $default -> Optional default value of the field if not -# already defined. -# $rows -> Optional number of rows in text area -# $columns -> Optional number of columns in text area -# Returns: -# A string containing a <textarea></textarea> tag -# -'textarea' => <<'END_OF_FUNC', -sub textarea { - my($self,@p) = self_or_default(@_); - - my($name,$default,$rows,$cols,$override,@other) = - rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p); - - my($current)= $override ? $default : - (defined($self->param($name)) ? $self->param($name) : $default); - - $name = defined($name) ? $self->escapeHTML($name) : ''; - $current = defined($current) ? $self->escapeHTML($current) : ''; - my($r) = $rows ? qq/ rows="$rows"/ : ''; - my($c) = $cols ? qq/ cols="$cols"/ : ''; - my($other) = @other ? " @other" : ''; - return qq{<textarea name="$name"$r$c$other>$current</textarea>}; -} -END_OF_FUNC - - -#### Method: button -# Create a javascript button. -# Parameters: -# $name -> (optional) Name for the button. (-name) -# $value -> (optional) Value of the button when selected (and visible name) (-value) -# $onclick -> (optional) Text of the JavaScript to run when the button is -# clicked. -# Returns: -# A string containing a <input type="button"> tag -#### -'button' => <<'END_OF_FUNC', -sub button { - my($self,@p) = self_or_default(@_); - - my($label,$value,$script,@other) = rearrange([NAME,[VALUE,LABEL], - [ONCLICK,SCRIPT]],@p); - - $label=$self->escapeHTML($label); - $value=$self->escapeHTML($value,1); - $script=$self->escapeHTML($script); - - my($name) = ''; - $name = qq/ name="$label"/ if $label; - $value = $value || $label; - my($val) = ''; - $val = qq/ value="$value"/ if $value; - $script = qq/ onclick="$script"/ if $script; - my($other) = @other ? " @other" : ''; - return $XHTML ? qq(<input type="button"$name$val$script$other />) - : qq(<input type="button"$name$val$script$other>); -} -END_OF_FUNC - - -#### Method: submit -# Create a "submit query" button. -# Parameters: -# $name -> (optional) Name for the button. -# $value -> (optional) Value of the button when selected (also doubles as label). -# $label -> (optional) Label printed on the button(also doubles as the value). -# Returns: -# A string containing a <input type="submit"> tag -#### -'submit' => <<'END_OF_FUNC', -sub submit { - my($self,@p) = self_or_default(@_); - - my($label,$value,@other) = rearrange([NAME,[VALUE,LABEL]],@p); - - $label=$self->escapeHTML($label); - $value=$self->escapeHTML($value,1); - - my $name = $NOSTICKY ? '' : ' name=".submit"'; - $name = qq/ name="$label"/ if defined($label); - $value = defined($value) ? $value : $label; - my $val = ''; - $val = qq/ value="$value"/ if defined($value); - my($other) = @other ? " @other" : ''; - return $XHTML ? qq(<input type="submit"$name$val$other />) - : qq(<input type="submit"$name$val$other>); -} -END_OF_FUNC - - -#### Method: reset -# Create a "reset" button. -# Parameters: -# $name -> (optional) Name for the button. -# Returns: -# A string containing a <input type="reset"> tag -#### -'reset' => <<'END_OF_FUNC', -sub reset { - my($self,@p) = self_or_default(@_); - my($label,$value,@other) = rearrange(['NAME',['VALUE','LABEL']],@p); - $label=$self->escapeHTML($label); - $value=$self->escapeHTML($value,1); - my ($name) = ' name=".reset"'; - $name = qq/ name="$label"/ if defined($label); - $value = defined($value) ? $value : $label; - my($val) = ''; - $val = qq/ value="$value"/ if defined($value); - my($other) = @other ? " @other" : ''; - return $XHTML ? qq(<input type="reset"$name$val$other />) - : qq(<input type="reset"$name$val$other>); -} -END_OF_FUNC - - -#### Method: defaults -# Create a "defaults" button. -# Parameters: -# $name -> (optional) Name for the button. -# Returns: -# A string containing a <input type="submit" name=".defaults"> tag -# -# Note: this button has a special meaning to the initialization script, -# and tells it to ERASE the current query string so that your defaults -# are used again! -#### -'defaults' => <<'END_OF_FUNC', -sub defaults { - my($self,@p) = self_or_default(@_); - - my($label,@other) = rearrange([[NAME,VALUE]],@p); - - $label=$self->escapeHTML($label,1); - $label = $label || "Defaults"; - my($value) = qq/ value="$label"/; - my($other) = @other ? " @other" : ''; - return $XHTML ? qq(<input type="submit" name=".defaults"$value$other />) - : qq/<input type="submit" NAME=".defaults"$value$other>/; -} -END_OF_FUNC - - -#### Method: comment -# Create an HTML <!-- comment --> -# Parameters: a string -'comment' => <<'END_OF_FUNC', -sub comment { - my($self,@p) = self_or_CGI(@_); - return "<!-- @p -->"; -} -END_OF_FUNC - -#### Method: checkbox -# Create a checkbox that is not logically linked to any others. -# The field value is "on" when the button is checked. -# Parameters: -# $name -> Name of the checkbox -# $checked -> (optional) turned on by default if true -# $value -> (optional) value of the checkbox, 'on' by default -# $label -> (optional) a user-readable label printed next to the box. -# Otherwise the checkbox name is used. -# Returns: -# A string containing a <input type="checkbox"> field -#### -'checkbox' => <<'END_OF_FUNC', -sub checkbox { - my($self,@p) = self_or_default(@_); - - my($name,$checked,$value,$label,$override,@other) = - rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p); - - $value = defined $value ? $value : 'on'; - - if (!$override && ($self->{'.fieldnames'}->{$name} || - defined $self->param($name))) { - $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : ''; - } else { - $checked = $self->_checked($checked); - } - my($the_label) = defined $label ? $label : $name; - $name = $self->escapeHTML($name); - $value = $self->escapeHTML($value,1); - $the_label = $self->escapeHTML($the_label); - my($other) = @other ? " @other" : ''; - $self->register_parameter($name); - return $XHTML ? qq{<input type="checkbox" name="$name" value="$value"$checked$other />$the_label} - : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label}; -} -END_OF_FUNC - - -#### Method: checkbox_group -# Create a list of logically-linked checkboxes. -# Parameters: -# $name -> Common name for all the check boxes -# $values -> A pointer to a regular array containing the -# values for each checkbox in the group. -# $defaults -> (optional) -# 1. If a pointer to a regular array of checkbox values, -# then this will be used to decide which -# checkboxes to turn on by default. -# 2. If a scalar, will be assumed to hold the -# value of a single checkbox in the group to turn on. -# $linebreak -> (optional) Set to true to place linebreaks -# between the buttons. -# $labels -> (optional) -# A pointer to an associative array of labels to print next to each checkbox -# in the form $label{'value'}="Long explanatory label". -# Otherwise the provided values are used as the labels. -# Returns: -# An ARRAY containing a series of <input type="checkbox"> fields -#### -'checkbox_group' => <<'END_OF_FUNC', -sub checkbox_group { - my($self,@p) = self_or_default(@_); - - my($name,$values,$defaults,$linebreak,$labels,$attributes,$rows,$columns, - $rowheaders,$colheaders,$override,$nolabels,@other) = - rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], - LINEBREAK,LABELS,ATTRIBUTES,ROWS,[COLUMNS,COLS], - ROWHEADERS,COLHEADERS, - [OVERRIDE,FORCE],NOLABELS],@p); - - my($checked,$break,$result,$label); - - my(%checked) = $self->previous_or_default($name,$defaults,$override); - - if ($linebreak) { - $break = $XHTML ? "<br />" : "<br>"; - } - else { - $break = ''; - } - $name=$self->escapeHTML($name); - - # Create the elements - my(@elements,@values); - - @values = $self->_set_values_and_labels($values,\$labels,$name); - - my($other) = @other ? " @other" : ''; - foreach (@values) { - $checked = $self->_checked($checked{$_}); - $label = ''; - unless (defined($nolabels) && $nolabels) { - $label = $_; - $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); - $label = $self->escapeHTML($label); - } - my $attribs = $self->_set_attributes($_, $attributes); - $_ = $self->escapeHTML($_,1); - push(@elements,$XHTML ? qq(<input type="checkbox" name="$name" value="$_"$checked$other$attribs />${label}${break}) - : qq/<input type="checkbox" name="$name" value="$_"$checked$other$attribs>${label}${break}/); - } - $self->register_parameter($name); - return wantarray ? @elements : join(' ',@elements) - unless defined($columns) || defined($rows); - $rows = 1 if $rows && $rows < 1; - $cols = 1 if $cols && $cols < 1; - return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); -} -END_OF_FUNC - -# Escape HTML -- used internally -'escapeHTML' => <<'END_OF_FUNC', -sub escapeHTML { - # hack to work around earlier hacks - push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; - my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_); - return undef unless defined($toencode); - return $toencode if ref($self) && !$self->{'escape'}; - $toencode =~ s{&}{&}gso; - $toencode =~ s{<}{<}gso; - $toencode =~ s{>}{>}gso; - if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) { - # $quot; was accidentally omitted from the HTML 3.2 DTD -- see - # <http://validator.w3.org/docs/errors.html#bad-entity> / - # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>. - $toencode =~ s{"}{"}gso; - } - else { - $toencode =~ s{"}{"}gso; - } - my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' || - uc $self->{'.charset'} eq 'WINDOWS-1252'; - if ($latin) { # bug in some browsers - $toencode =~ s{'}{'}gso; - $toencode =~ s{\x8b}{‹}gso; - $toencode =~ s{\x9b}{›}gso; - if (defined $newlinestoo && $newlinestoo) { - $toencode =~ s{\012}{ }gso; - $toencode =~ s{\015}{ }gso; - } - } - return $toencode; -} -END_OF_FUNC - -# unescape HTML -- used internally -'unescapeHTML' => <<'END_OF_FUNC', -sub unescapeHTML { - # hack to work around earlier hacks - push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; - my ($self,$string) = CGI::self_or_default(@_); - return undef unless defined($string); - my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i - : 1; - # thanks to Randal Schwartz for the correct solution to this one - $string=~ s[&(.*?);]{ - local $_ = $1; - /^amp$/i ? "&" : - /^quot$/i ? '"' : - /^gt$/i ? ">" : - /^lt$/i ? "<" : - /^#(\d+)$/ && $latin ? chr($1) : - /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) : - $_ - }gex; - return $string; -} -END_OF_FUNC - -# Internal procedure - don't use -'_tableize' => <<'END_OF_FUNC', -sub _tableize { - my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; - $rowheaders = [] unless defined $rowheaders; - $colheaders = [] unless defined $colheaders; - my($result); - - if (defined($columns)) { - $rows = int(0.99 + @elements/$columns) unless defined($rows); - } - if (defined($rows)) { - $columns = int(0.99 + @elements/$rows) unless defined($columns); - } - - # rearrange into a pretty table - $result = "<table>"; - my($row,$column); - unshift(@$colheaders,'') if @$colheaders && @$rowheaders; - $result .= "<tr>" if @{$colheaders}; - foreach (@{$colheaders}) { - $result .= "<th>$_</th>"; - } - for ($row=0;$row<$rows;$row++) { - $result .= "<tr>"; - $result .= "<th>$rowheaders->[$row]</th>" if @$rowheaders; - for ($column=0;$column<$columns;$column++) { - $result .= "<td>" . $elements[$column*$rows + $row] . "</td>" - if defined($elements[$column*$rows + $row]); - } - $result .= "</tr>"; - } - $result .= "</table>"; - return $result; -} -END_OF_FUNC - - -#### Method: radio_group -# Create a list of logically-linked radio buttons. -# Parameters: -# $name -> Common name for all the buttons. -# $values -> A pointer to a regular array containing the -# values for each button in the group. -# $default -> (optional) Value of the button to turn on by default. Pass '-' -# to turn _nothing_ on. -# $linebreak -> (optional) Set to true to place linebreaks -# between the buttons. -# $labels -> (optional) -# A pointer to an associative array of labels to print next to each checkbox -# in the form $label{'value'}="Long explanatory label". -# Otherwise the provided values are used as the labels. -# Returns: -# An ARRAY containing a series of <input type="radio"> fields -#### -'radio_group' => <<'END_OF_FUNC', -sub radio_group { - my($self,@p) = self_or_default(@_); - - my($name,$values,$default,$linebreak,$labels,$attributes, - $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) = - rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,ATTRIBUTES, - ROWS,[COLUMNS,COLS], - ROWHEADERS,COLHEADERS, - [OVERRIDE,FORCE],NOLABELS],@p); - my($result,$checked); - - if (!$override && defined($self->param($name))) { - $checked = $self->param($name); - } else { - $checked = $default; - } - my(@elements,@values); - @values = $self->_set_values_and_labels($values,\$labels,$name); - - # If no check array is specified, check the first by default - $checked = $values[0] unless defined($checked) && $checked ne ''; - $name=$self->escapeHTML($name); - - my($other) = @other ? " @other" : ''; - foreach (@values) { - my($checkit) = $checked eq $_ ? qq/ checked="checked"/ : ''; - my($break); - if ($linebreak) { - $break = $XHTML ? "<br />" : "<br>"; - } - else { - $break = ''; - } - my($label)=''; - unless (defined($nolabels) && $nolabels) { - $label = $_; - $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); - $label = $self->escapeHTML($label,1); - } - my $attribs = $self->_set_attributes($_, $attributes); - $_=$self->escapeHTML($_); - push(@elements,$XHTML ? qq(<input type="radio" name="$name" value="$_"$checkit$other$attribs />${label}${break}) - : qq/<input type="radio" name="$name" value="$_"$checkit$other$attribs>${label}${break}/); - } - $self->register_parameter($name); - return wantarray ? @elements : join(' ',@elements) - unless defined($columns) || defined($rows); - return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); -} -END_OF_FUNC - - -#### Method: popup_menu -# Create a popup menu. -# Parameters: -# $name -> Name for all the menu -# $values -> A pointer to a regular array containing the -# text of each menu item. -# $default -> (optional) Default item to display -# $labels -> (optional) -# A pointer to an associative array of labels to print next to each checkbox -# in the form $label{'value'}="Long explanatory label". -# Otherwise the provided values are used as the labels. -# Returns: -# A string containing the definition of a popup menu. -#### -'popup_menu' => <<'END_OF_FUNC', -sub popup_menu { - my($self,@p) = self_or_default(@_); - - my($name,$values,$default,$labels,$attributes,$override,@other) = - rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS, - ATTRIBUTES,[OVERRIDE,FORCE]],@p); - my($result,$selected); - - if (!$override && defined($self->param($name))) { - $selected = $self->param($name); - } else { - $selected = $default; - } - $name=$self->escapeHTML($name); - my($other) = @other ? " @other" : ''; - - my(@values); - @values = $self->_set_values_and_labels($values,\$labels,$name); - - $result = qq/<select name="$name"$other>\n/; - foreach (@values) { - if (/<optgroup/) { - foreach (split(/\n/)) { - my $selectit = $XHTML ? 'selected="selected"' : 'selected'; - s/(value="$selected")/$selectit $1/ if defined $selected; - $result .= "$_\n"; - } - } - else { - my $attribs = $self->_set_attributes($_, $attributes); - my($selectit) = defined($selected) ? $self->_selected($selected eq $_) : ''; - my($label) = $_; - $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); - my($value) = $self->escapeHTML($_); - $label=$self->escapeHTML($label,1); - $result .= "<option$selectit$attribs value=\"$value\">$label</option>\n"; - } - } - - $result .= "</select>"; - return $result; -} -END_OF_FUNC - - -#### Method: optgroup -# Create a optgroup. -# Parameters: -# $name -> Label for the group -# $values -> A pointer to a regular array containing the -# values for each option line in the group. -# $labels -> (optional) -# A pointer to an associative array of labels to print next to each item -# in the form $label{'value'}="Long explanatory label". -# Otherwise the provided values are used as the labels. -# $labeled -> (optional) -# A true value indicates the value should be used as the label attribute -# in the option elements. -# The label attribute specifies the option label presented to the user. -# This defaults to the content of the <option> element, but the label -# attribute allows authors to more easily use optgroup without sacrificing -# compatibility with browsers that do not support option groups. -# $novals -> (optional) -# A true value indicates to suppress the val attribute in the option elements -# Returns: -# A string containing the definition of an option group. -#### -'optgroup' => <<'END_OF_FUNC', -sub optgroup { - my($self,@p) = self_or_default(@_); - my($name,$values,$attributes,$labeled,$noval,$labels,@other) - = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p); - - my($result,@values); - @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals); - my($other) = @other ? " @other" : ''; - - $name=$self->escapeHTML($name); - $result = qq/<optgroup label="$name"$other>\n/; - foreach (@values) { - if (/<optgroup/) { - foreach (split(/\n/)) { - my $selectit = $XHTML ? 'selected="selected"' : 'selected'; - s/(value="$selected")/$selectit $1/ if defined $selected; - $result .= "$_\n"; - } - } - else { - my $attribs = $self->_set_attributes($_, $attributes); - my($label) = $_; - $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); - $label=$self->escapeHTML($label); - my($value)=$self->escapeHTML($_,1); - $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n" - : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n" - : $novals ? "<option$attribs>$label</option>\n" - : "<option$attribs value=\"$value\">$label</option>\n"; - } - } - $result .= "</optgroup>"; - return $result; -} -END_OF_FUNC - - -#### Method: scrolling_list -# Create a scrolling list. -# Parameters: -# $name -> name for the list -# $values -> A pointer to a regular array containing the -# values for each option line in the list. -# $defaults -> (optional) -# 1. If a pointer to a regular array of options, -# then this will be used to decide which -# lines to turn on by default. -# 2. Otherwise holds the value of the single line to turn on. -# $size -> (optional) Size of the list. -# $multiple -> (optional) If set, allow multiple selections. -# $labels -> (optional) -# A pointer to an associative array of labels to print next to each checkbox -# in the form $label{'value'}="Long explanatory label". -# Otherwise the provided values are used as the labels. -# Returns: -# A string containing the definition of a scrolling list. -#### -'scrolling_list' => <<'END_OF_FUNC', -sub scrolling_list { - my($self,@p) = self_or_default(@_); - my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,@other) - = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], - SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE]],@p); - - my($result,@values); - @values = $self->_set_values_and_labels($values,\$labels,$name); - - $size = $size || scalar(@values); - - my(%selected) = $self->previous_or_default($name,$defaults,$override); - my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : ''; - my($has_size) = $size ? qq/ size="$size"/: ''; - my($other) = @other ? " @other" : ''; - - $name=$self->escapeHTML($name); - $result = qq/<select name="$name"$has_size$is_multiple$other>\n/; - foreach (@values) { - my($selectit) = $self->_selected($selected{$_}); - my($label) = $_; - $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); - $label=$self->escapeHTML($label); - my($value)=$self->escapeHTML($_,1); - my $attribs = $self->_set_attributes($_, $attributes); - $result .= "<option$selectit$attribs value=\"$value\">$label</option>\n"; - } - $result .= "</select>"; - $self->register_parameter($name); - return $result; -} -END_OF_FUNC - - -#### Method: hidden -# Parameters: -# $name -> Name of the hidden field -# @default -> (optional) Initial values of field (may be an array) -# or -# $default->[initial values of field] -# Returns: -# A string containing a <input type="hidden" name="name" value="value"> -#### -'hidden' => <<'END_OF_FUNC', -sub hidden { - my($self,@p) = self_or_default(@_); - - # this is the one place where we departed from our standard - # calling scheme, so we have to special-case (darn) - my(@result,@value); - my($name,$default,$override,@other) = - rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); - - my $do_override = 0; - if ( ref($p[0]) || substr($p[0],0,1) eq '-') { - @value = ref($default) ? @{$default} : $default; - $do_override = $override; - } else { - foreach ($default,$override,@other) { - push(@value,$_) if defined($_); - } - } - - # use previous values if override is not set - my @prev = $self->param($name); - @value = @prev if !$do_override && @prev; - - $name=$self->escapeHTML($name); - foreach (@value) { - $_ = defined($_) ? $self->escapeHTML($_,1) : ''; - push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />) - : qq(<input type="hidden" name="$name" value="$_" @other>); - } - return wantarray ? @result : join('',@result); -} -END_OF_FUNC - - -#### Method: image_button -# Parameters: -# $name -> Name of the button -# $src -> URL of the image source -# $align -> Alignment style (TOP, BOTTOM or MIDDLE) -# Returns: -# A string containing a <input type="image" name="name" src="url" align="alignment"> -#### -'image_button' => <<'END_OF_FUNC', -sub image_button { - my($self,@p) = self_or_default(@_); - - my($name,$src,$alignment,@other) = - rearrange([NAME,SRC,ALIGN],@p); - - my($align) = $alignment ? " align=\U\"$alignment\"" : ''; - my($other) = @other ? " @other" : ''; - $name=$self->escapeHTML($name); - return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />) - : qq/<input type="image" name="$name" src="$src"$align$other>/; -} -END_OF_FUNC - - -#### Method: self_url -# Returns a URL containing the current script and all its -# param/value pairs arranged as a query. You can use this -# to create a link that, when selected, will reinvoke the -# script with all its state information preserved. -#### -'self_url' => <<'END_OF_FUNC', -sub self_url { - my($self,@p) = self_or_default(@_); - return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p); -} -END_OF_FUNC - - -# This is provided as a synonym to self_url() for people unfortunate -# enough to have incorporated it into their programs already! -'state' => <<'END_OF_FUNC', -sub state { - &self_url; -} -END_OF_FUNC - - -#### Method: url -# Like self_url, but doesn't return the query string part of -# the URL. -#### -'url' => <<'END_OF_FUNC', -sub url { - my($self,@p) = self_or_default(@_); - my ($relative,$absolute,$full,$path_info,$query,$base) = - rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p); - my $url; - $full++ if $base || !($relative || $absolute); - - my $path = $self->path_info; - my $script_name = $self->script_name; - - # for compatibility with Apache's MultiViews - if (exists($ENV{REQUEST_URI})) { - my $index; - $script_name = unescape($ENV{REQUEST_URI}); - $script_name =~ s/\?.+$//s; # strip query string - # and path - if (exists($ENV{PATH_INFO})) { - my $encoded_path = unescape($ENV{PATH_INFO}); - $script_name =~ s/\Q$encoded_path\E$//i; - } - } - - if ($full) { - my $protocol = $self->protocol(); - $url = "$protocol://"; - my $vh = http('x_forwarded_host') || http('host'); - if ($vh) { - $url .= $vh; - } else { - $url .= server_name(); - my $port = $self->server_port; - $url .= ":" . $port - unless (lc($protocol) eq 'http' && $port == 80) - || (lc($protocol) eq 'https' && $port == 443); - } - return $url if $base; - $url .= $script_name; - } elsif ($relative) { - ($url) = $script_name =~ m!([^/]+)$!; - } elsif ($absolute) { - $url = $script_name; - } - - $url .= $path if $path_info and defined $path; - $url .= "?" . $self->query_string if $query and $self->query_string; - $url = '' unless defined $url; - $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg; - return $url; -} - -END_OF_FUNC - -#### Method: cookie -# Set or read a cookie from the specified name. -# Cookie can then be passed to header(). -# Usual rules apply to the stickiness of -value. -# Parameters: -# -name -> name for this cookie (optional) -# -value -> value of this cookie (scalar, array or hash) -# -path -> paths for which this cookie is valid (optional) -# -domain -> internet domain in which this cookie is valid (optional) -# -secure -> if true, cookie only passed through secure channel (optional) -# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional) -#### -'cookie' => <<'END_OF_FUNC', -sub cookie { - my($self,@p) = self_or_default(@_); - my($name,$value,$path,$domain,$secure,$expires) = - rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p); - - require CGI::Cookie; - - # if no value is supplied, then we retrieve the - # value of the cookie, if any. For efficiency, we cache the parsed - # cookies in our state variables. - unless ( defined($value) ) { - $self->{'.cookies'} = CGI::Cookie->fetch - unless $self->{'.cookies'}; - - # If no name is supplied, then retrieve the names of all our cookies. - return () unless $self->{'.cookies'}; - return keys %{$self->{'.cookies'}} unless $name; - return () unless $self->{'.cookies'}->{$name}; - return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne ''; - } - - # If we get here, we're creating a new cookie - return undef unless defined($name) && $name ne ''; # this is an error - - my @param; - push(@param,'-name'=>$name); - push(@param,'-value'=>$value); - push(@param,'-domain'=>$domain) if $domain; - push(@param,'-path'=>$path) if $path; - push(@param,'-expires'=>$expires) if $expires; - push(@param,'-secure'=>$secure) if $secure; - - return new CGI::Cookie(@param); -} -END_OF_FUNC - -'parse_keywordlist' => <<'END_OF_FUNC', -sub parse_keywordlist { - my($self,$tosplit) = @_; - $tosplit = unescape($tosplit); # unescape the keywords - $tosplit=~tr/+/ /; # pluses to spaces - my(@keywords) = split(/\s+/,$tosplit); - return @keywords; -} -END_OF_FUNC - -'param_fetch' => <<'END_OF_FUNC', -sub param_fetch { - my($self,@p) = self_or_default(@_); - my($name) = rearrange([NAME],@p); - unless (exists($self->{$name})) { - $self->add_parameter($name); - $self->{$name} = []; - } - - return $self->{$name}; -} -END_OF_FUNC - -############################################### -# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT -############################################### - -#### Method: path_info -# Return the extra virtual path information provided -# after the URL (if any) -#### -'path_info' => <<'END_OF_FUNC', -sub path_info { - my ($self,$info) = self_or_default(@_); - if (defined($info)) { - $info = "/$info" if $info ne '' && substr($info,0,1) ne '/'; - $self->{'.path_info'} = $info; - } elsif (! defined($self->{'.path_info'}) ) { - $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ? - $ENV{'PATH_INFO'} : ''; - - # hack to fix broken path info in IIS - $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS; - - } - return $self->{'.path_info'}; -} -END_OF_FUNC - - -#### Method: request_method -# Returns 'POST', 'GET', 'PUT' or 'HEAD' -#### -'request_method' => <<'END_OF_FUNC', -sub request_method { - return $ENV{'REQUEST_METHOD'}; -} -END_OF_FUNC - -#### Method: content_type -# Returns the content_type string -#### -'content_type' => <<'END_OF_FUNC', -sub content_type { - return $ENV{'CONTENT_TYPE'}; -} -END_OF_FUNC - -#### Method: path_translated -# Return the physical path information provided -# by the URL (if any) -#### -'path_translated' => <<'END_OF_FUNC', -sub path_translated { - return $ENV{'PATH_TRANSLATED'}; -} -END_OF_FUNC - - -#### Method: query_string -# Synthesize a query string from our current -# parameters -#### -'query_string' => <<'END_OF_FUNC', -sub query_string { - my($self) = self_or_default(@_); - my($param,$value,@pairs); - foreach $param ($self->param) { - my($eparam) = escape($param); - foreach $value ($self->param($param)) { - $value = escape($value); - next unless defined $value; - push(@pairs,"$eparam=$value"); - } - } - foreach (keys %{$self->{'.fieldnames'}}) { - push(@pairs,".cgifields=".escape("$_")); - } - return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs); -} -END_OF_FUNC - - -#### Method: accept -# Without parameters, returns an array of the -# MIME types the browser accepts. -# With a single parameter equal to a MIME -# type, will return undef if the browser won't -# accept it, 1 if the browser accepts it but -# doesn't give a preference, or a floating point -# value between 0.0 and 1.0 if the browser -# declares a quantitative score for it. -# This handles MIME type globs correctly. -#### -'Accept' => <<'END_OF_FUNC', -sub Accept { - my($self,$search) = self_or_CGI(@_); - my(%prefs,$type,$pref,$pat); - - my(@accept) = split(',',$self->http('accept')); - - foreach (@accept) { - ($pref) = /q=(\d\.\d+|\d+)/; - ($type) = m#(\S+/[^;]+)#; - next unless $type; - $prefs{$type}=$pref || 1; - } - - return keys %prefs unless $search; - - # if a search type is provided, we may need to - # perform a pattern matching operation. - # The MIME types use a glob mechanism, which - # is easily translated into a perl pattern match - - # First return the preference for directly supported - # types: - return $prefs{$search} if $prefs{$search}; - - # Didn't get it, so try pattern matching. - foreach (keys %prefs) { - next unless /\*/; # not a pattern match - ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters - $pat =~ s/\*/.*/g; # turn it into a pattern - return $prefs{$_} if $search=~/$pat/; - } -} -END_OF_FUNC - - -#### Method: user_agent -# If called with no parameters, returns the user agent. -# If called with one parameter, does a pattern match (case -# insensitive) on the user agent. -#### -'user_agent' => <<'END_OF_FUNC', -sub user_agent { - my($self,$match)=self_or_CGI(@_); - return $self->http('user_agent') unless $match; - return $self->http('user_agent') =~ /$match/i; -} -END_OF_FUNC - - -#### Method: raw_cookie -# Returns the magic cookies for the session. -# The cookies are not parsed or altered in any way, i.e. -# cookies are returned exactly as given in the HTTP -# headers. If a cookie name is given, only that cookie's -# value is returned, otherwise the entire raw cookie -# is returned. -#### -'raw_cookie' => <<'END_OF_FUNC', -sub raw_cookie { - my($self,$key) = self_or_CGI(@_); - - require CGI::Cookie; - - if (defined($key)) { - $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch - unless $self->{'.raw_cookies'}; - - return () unless $self->{'.raw_cookies'}; - return () unless $self->{'.raw_cookies'}->{$key}; - return $self->{'.raw_cookies'}->{$key}; - } - return $self->http('cookie') || $ENV{'COOKIE'} || ''; -} -END_OF_FUNC - -#### Method: virtual_host -# Return the name of the virtual_host, which -# is not always the same as the server -###### -'virtual_host' => <<'END_OF_FUNC', -sub virtual_host { - my $vh = http('x_forwarded_host') || http('host') || server_name(); - $vh =~ s/:\d+$//; # get rid of port number - return $vh; -} -END_OF_FUNC - -#### Method: remote_host -# Return the name of the remote host, or its IP -# address if unavailable. If this variable isn't -# defined, it returns "localhost" for debugging -# purposes. -#### -'remote_host' => <<'END_OF_FUNC', -sub remote_host { - return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} - || 'localhost'; -} -END_OF_FUNC - - -#### Method: remote_addr -# Return the IP addr of the remote host. -#### -'remote_addr' => <<'END_OF_FUNC', -sub remote_addr { - return $ENV{'REMOTE_ADDR'} || '127.0.0.1'; -} -END_OF_FUNC - - -#### Method: script_name -# Return the partial URL to this script for -# self-referencing scripts. Also see -# self_url(), which returns a URL with all state information -# preserved. -#### -'script_name' => <<'END_OF_FUNC', -sub script_name { - return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'}); - # These are for debugging - return "/$0" unless $0=~/^\//; - return $0; -} -END_OF_FUNC - - -#### Method: referer -# Return the HTTP_REFERER: useful for generating -# a GO BACK button. -#### -'referer' => <<'END_OF_FUNC', -sub referer { - my($self) = self_or_CGI(@_); - return $self->http('referer'); -} -END_OF_FUNC - - -#### Method: server_name -# Return the name of the server -#### -'server_name' => <<'END_OF_FUNC', -sub server_name { - return $ENV{'SERVER_NAME'} || 'localhost'; -} -END_OF_FUNC - -#### Method: server_software -# Return the name of the server software -#### -'server_software' => <<'END_OF_FUNC', -sub server_software { - return $ENV{'SERVER_SOFTWARE'} || 'cmdline'; -} -END_OF_FUNC - -#### Method: virtual_port -# Return the server port, taking virtual hosts into account -#### -'virtual_port' => <<'END_OF_FUNC', -sub virtual_port { - my($self) = self_or_default(@_); - my $vh = $self->http('x_forwarded_host') || $self->http('host'); - if ($vh) { - return ($vh =~ /:(\d+)$/)[0] || '80'; - } else { - return $self->server_port(); - } -} -END_OF_FUNC - -#### Method: server_port -# Return the tcp/ip port the server is running on -#### -'server_port' => <<'END_OF_FUNC', -sub server_port { - return $ENV{'SERVER_PORT'} || 80; # for debugging -} -END_OF_FUNC - -#### Method: server_protocol -# Return the protocol (usually HTTP/1.0) -#### -'server_protocol' => <<'END_OF_FUNC', -sub server_protocol { - return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging -} -END_OF_FUNC - -#### Method: http -# Return the value of an HTTP variable, or -# the list of variables if none provided -#### -'http' => <<'END_OF_FUNC', -sub http { - my ($self,$parameter) = self_or_CGI(@_); - return $ENV{$parameter} if $parameter=~/^HTTP/; - $parameter =~ tr/-/_/; - return $ENV{"HTTP_\U$parameter\E"} if $parameter; - my(@p); - foreach (keys %ENV) { - push(@p,$_) if /^HTTP/; - } - return @p; -} -END_OF_FUNC - -#### Method: https -# Return the value of HTTPS -#### -'https' => <<'END_OF_FUNC', -sub https { - local($^W)=0; - my ($self,$parameter) = self_or_CGI(@_); - return $ENV{HTTPS} unless $parameter; - return $ENV{$parameter} if $parameter=~/^HTTPS/; - $parameter =~ tr/-/_/; - return $ENV{"HTTPS_\U$parameter\E"} if $parameter; - my(@p); - foreach (keys %ENV) { - push(@p,$_) if /^HTTPS/; - } - return @p; -} -END_OF_FUNC - -#### Method: protocol -# Return the protocol (http or https currently) -#### -'protocol' => <<'END_OF_FUNC', -sub protocol { - local($^W)=0; - my $self = shift; - return 'https' if uc($self->https()) eq 'ON'; - return 'https' if $self->server_port == 443; - my $prot = $self->server_protocol; - my($protocol,$version) = split('/',$prot); - return "\L$protocol\E"; -} -END_OF_FUNC - -#### Method: remote_ident -# Return the identity of the remote user -# (but only if his host is running identd) -#### -'remote_ident' => <<'END_OF_FUNC', -sub remote_ident { - return $ENV{'REMOTE_IDENT'}; -} -END_OF_FUNC - - -#### Method: auth_type -# Return the type of use verification/authorization in use, if any. -#### -'auth_type' => <<'END_OF_FUNC', -sub auth_type { - return $ENV{'AUTH_TYPE'}; -} -END_OF_FUNC - - -#### Method: remote_user -# Return the authorization name used for user -# verification. -#### -'remote_user' => <<'END_OF_FUNC', -sub remote_user { - return $ENV{'REMOTE_USER'}; -} -END_OF_FUNC - - -#### Method: user_name -# Try to return the remote user's name by hook or by -# crook -#### -'user_name' => <<'END_OF_FUNC', -sub user_name { - my ($self) = self_or_CGI(@_); - return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'}; -} -END_OF_FUNC - -#### Method: nosticky -# Set or return the NOSTICKY global flag -#### -'nosticky' => <<'END_OF_FUNC', -sub nosticky { - my ($self,$param) = self_or_CGI(@_); - $CGI::NOSTICKY = $param if defined($param); - return $CGI::NOSTICKY; -} -END_OF_FUNC - -#### Method: nph -# Set or return the NPH global flag -#### -'nph' => <<'END_OF_FUNC', -sub nph { - my ($self,$param) = self_or_CGI(@_); - $CGI::NPH = $param if defined($param); - return $CGI::NPH; -} -END_OF_FUNC - -#### Method: private_tempfiles -# Set or return the private_tempfiles global flag -#### -'private_tempfiles' => <<'END_OF_FUNC', -sub private_tempfiles { - my ($self,$param) = self_or_CGI(@_); - $CGI::PRIVATE_TEMPFILES = $param if defined($param); - return $CGI::PRIVATE_TEMPFILES; -} -END_OF_FUNC -#### Method: close_upload_files -# Set or return the close_upload_files global flag -#### -'close_upload_files' => <<'END_OF_FUNC', -sub close_upload_files { - my ($self,$param) = self_or_CGI(@_); - $CGI::CLOSE_UPLOAD_FILES = $param if defined($param); - return $CGI::CLOSE_UPLOAD_FILES; -} -END_OF_FUNC - - -#### Method: default_dtd -# Set or return the default_dtd global -#### -'default_dtd' => <<'END_OF_FUNC', -sub default_dtd { - my ($self,$param,$param2) = self_or_CGI(@_); - if (defined $param2 && defined $param) { - $CGI::DEFAULT_DTD = [ $param, $param2 ]; - } elsif (defined $param) { - $CGI::DEFAULT_DTD = $param; - } - return $CGI::DEFAULT_DTD; -} -END_OF_FUNC - -# -------------- really private subroutines ----------------- -'previous_or_default' => <<'END_OF_FUNC', -sub previous_or_default { - my($self,$name,$defaults,$override) = @_; - my(%selected); - - if (!$override && ($self->{'.fieldnames'}->{$name} || - defined($self->param($name)) ) ) { - grep($selected{$_}++,$self->param($name)); - } elsif (defined($defaults) && ref($defaults) && - (ref($defaults) eq 'ARRAY')) { - grep($selected{$_}++,@{$defaults}); - } else { - $selected{$defaults}++ if defined($defaults); - } - - return %selected; -} -END_OF_FUNC - -'register_parameter' => <<'END_OF_FUNC', -sub register_parameter { - my($self,$param) = @_; - $self->{'.parametersToAdd'}->{$param}++; -} -END_OF_FUNC - -'get_fields' => <<'END_OF_FUNC', -sub get_fields { - my($self) = @_; - return $self->CGI::hidden('-name'=>'.cgifields', - '-values'=>[keys %{$self->{'.parametersToAdd'}}], - '-override'=>1); -} -END_OF_FUNC - -'read_from_cmdline' => <<'END_OF_FUNC', -sub read_from_cmdline { - my($input,@words); - my($query_string); - my($subpath); - if ($DEBUG && @ARGV) { - @words = @ARGV; - } elsif ($DEBUG > 1) { - require "shellwords.pl"; - print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n"; - chomp(@lines = <STDIN>); # remove newlines - $input = join(" ",@lines); - @words = &shellwords($input); - } - foreach (@words) { - s/\\=/%3D/g; - s/\\&/%26/g; - } - - if ("@words"=~/=/) { - $query_string = join('&',@words); - } else { - $query_string = join('+',@words); - } - if ($query_string =~ /^(.*?)\?(.*)$/) - { - $query_string = $2; - $subpath = $1; - } - return { 'query_string' => $query_string, 'subpath' => $subpath }; -} -END_OF_FUNC - -##### -# subroutine: read_multipart -# -# Read multipart data and store it into our parameters. -# An interesting feature is that if any of the parts is a file, we -# create a temporary file and open up a filehandle on it so that the -# caller can read from it if necessary. -##### -'read_multipart' => <<'END_OF_FUNC', -sub read_multipart { - my($self,$boundary,$length) = @_; - my($buffer) = $self->new_MultipartBuffer($boundary,$length); - return unless $buffer; - my(%header,$body); - my $filenumber = 0; - while (!$buffer->eof) { - %header = $buffer->readHeader; - - unless (%header) { - $self->cgi_error("400 Bad request (malformed multipart POST)"); - return; - } - - my($param)= $header{'Content-Disposition'}=~/ name="([^;]*)"/; - $param .= $TAINTED; - - # Bug: Netscape doesn't escape quotation marks in file names!!! - my($filename) = $header{'Content-Disposition'}=~/ filename="([^;]*)"/; - # Test for Opera's multiple upload feature - my($multipart) = ( defined( $header{'Content-Type'} ) && - $header{'Content-Type'} =~ /multipart\/mixed/ ) ? - 1 : 0; - - # add this parameter to our list - $self->add_parameter($param); - - # If no filename specified, then just read the data and assign it - # to our parameter list. - if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) { - my($value) = $buffer->readBody; - $value .= $TAINTED; - push(@{$self->{$param}},$value); - next; - } - - my ($tmpfile,$tmp,$filehandle); - UPLOADS: { - # If we get here, then we are dealing with a potentially large - # uploaded form. Save the data to a temporary file, then open - # the file for reading. - - # skip the file if uploads disabled - if ($DISABLE_UPLOADS) { - while (defined($data = $buffer->read)) { } - last UPLOADS; - } - - # set the filename to some recognizable value - if ( ( !defined($filename) || $filename eq '' ) && $multipart ) { - $filename = "multipart/mixed"; - } - - # choose a relatively unpredictable tmpfile sequence number - my $seqno = unpack("%16C*",join('',localtime,values %ENV)); - for (my $cnt=10;$cnt>0;$cnt--) { - next unless $tmpfile = new CGITempFile($seqno); - $tmp = $tmpfile->as_string; - last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES)); - $seqno += int rand(100); - } - die "CGI open of tmpfile: $!\n" unless defined $filehandle; - $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode - && defined fileno($filehandle); - - # if this is an multipart/mixed attachment, save the header - # together with the body for later parsing with an external - # MIME parser module - if ( $multipart ) { - foreach ( keys %header ) { - print $filehandle "$_: $header{$_}${CRLF}"; - } - print $filehandle "${CRLF}"; - } - - my ($data); - local($\) = ''; - my $totalbytes; - while (defined($data = $buffer->read)) { - if (defined $self->{'.upload_hook'}) - { - $totalbytes += length($data); - &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'}); - } - print $filehandle $data; - } - - # back up to beginning of file - seek($filehandle,0,0); - - ## Close the filehandle if requested this allows a multipart MIME - ## upload to contain many files, and we won't die due to too many - ## open file handles. The user can access the files using the hash - ## below. - close $filehandle if $CLOSE_UPLOAD_FILES; - $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; - - # Save some information about the uploaded file where we can get - # at it later. - $self->{'.tmpfiles'}->{fileno($filehandle)}= { - hndl => $filehandle, - name => $tmpfile, - info => {%header}, - }; - push(@{$self->{$param}},$filehandle); - } - } -} -END_OF_FUNC - -'upload' =><<'END_OF_FUNC', -sub upload { - my($self,$param_name) = self_or_default(@_); - my @param = grep(ref && fileno($_), $self->param($param_name)); - return unless @param; - return wantarray ? @param : $param[0]; -} -END_OF_FUNC - -'tmpFileName' => <<'END_OF_FUNC', -sub tmpFileName { - my($self,$filename) = self_or_default(@_); - return $self->{'.tmpfiles'}->{fileno($filename)}->{name} ? - $self->{'.tmpfiles'}->{fileno($filename)}->{name}->as_string - : ''; -} -END_OF_FUNC - -'uploadInfo' => <<'END_OF_FUNC', -sub uploadInfo { - my($self,$filename) = self_or_default(@_); - return $self->{'.tmpfiles'}->{fileno($filename)}->{info}; -} -END_OF_FUNC - -# internal routine, don't use -'_set_values_and_labels' => <<'END_OF_FUNC', -sub _set_values_and_labels { - my $self = shift; - my ($v,$l,$n) = @_; - $$l = $v if ref($v) eq 'HASH' && !ref($$l); - return $self->param($n) if !defined($v); - return $v if !ref($v); - return ref($v) eq 'HASH' ? keys %$v : @$v; -} -END_OF_FUNC - -# internal routine, don't use -'_set_attributes' => <<'END_OF_FUNC', -sub _set_attributes { - my $self = shift; - my($element, $attributes) = @_; - return '' unless defined($attributes->{$element}); - $attribs = ' '; - foreach my $attrib (keys %{$attributes->{$element}}) { - (my $clean_attrib = $attrib) =~ s/^-//; - $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" "; - } - $attribs =~ s/ $//; - return $attribs; -} -END_OF_FUNC - -'_compile_all' => <<'END_OF_FUNC', -sub _compile_all { - foreach (@_) { - next if defined(&$_); - $AUTOLOAD = "CGI::$_"; - _compile(); - } -} -END_OF_FUNC - -); -END_OF_AUTOLOAD -; - -######################################################### -# Globals and stubs for other packages that we use. -######################################################### - -################### Fh -- lightweight filehandle ############### -package Fh; -use overload - '""' => \&asString, - 'cmp' => \&compare, - 'fallback'=>1; - -$FH='fh00000'; - -*Fh::AUTOLOAD = \&CGI::AUTOLOAD; - -$AUTOLOADED_ROUTINES = ''; # prevent -w error -$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; -%SUBS = ( -'asString' => <<'END_OF_FUNC', -sub asString { - my $self = shift; - # get rid of package name - (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//; - $i =~ s/%(..)/ chr(hex($1)) /eg; - return $i.$CGI::TAINTED; -# BEGIN DEAD CODE -# This was an extremely clever patch that allowed "use strict refs". -# Unfortunately it relied on another bug that caused leaky file descriptors. -# The underlying bug has been fixed, so this no longer works. However -# "strict refs" still works for some reason. -# my $self = shift; -# return ${*{$self}{SCALAR}}; -# END DEAD CODE -} -END_OF_FUNC - -'compare' => <<'END_OF_FUNC', -sub compare { - my $self = shift; - my $value = shift; - return "$self" cmp $value; -} -END_OF_FUNC - -'new' => <<'END_OF_FUNC', -sub new { - my($pack,$name,$file,$delete) = @_; - _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; - require Fcntl unless defined &Fcntl::O_RDWR; - (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg; - my $fv = ++$FH . $safename; - my $ref = \*{"Fh::$fv"}; - $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return; - my $safe = $1; - sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return; - unlink($safe) if $delete; - CORE::delete $Fh::{$fv}; - return bless $ref,$pack; -} -END_OF_FUNC - -'DESTROY' => <<'END_OF_FUNC', -sub DESTROY { - my $self = shift; - close $self; -} -END_OF_FUNC - -); -END_OF_AUTOLOAD - -######################## MultipartBuffer #################### -package MultipartBuffer; - -use constant DEBUG => 0; - -# how many bytes to read at a time. We use -# a 4K buffer by default. -$INITIAL_FILLUNIT = 1024 * 4; -$TIMEOUT = 240*60; # 4 hour timeout for big files -$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers -$CRLF=$CGI::CRLF; - -#reuse the autoload function -*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD; - -# avoid autoloader warnings -sub DESTROY {} - -############################################################################### -################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### -############################################################################### -$AUTOLOADED_ROUTINES = ''; # prevent -w error -$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; -%SUBS = ( - -'new' => <<'END_OF_FUNC', -sub new { - my($package,$interface,$boundary,$length) = @_; - $FILLUNIT = $INITIAL_FILLUNIT; - $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always - - # If the user types garbage into the file upload field, - # then Netscape passes NOTHING to the server (not good). - # We may hang on this read in that case. So we implement - # a read timeout. If nothing is ready to read - # by then, we return. - - # Netscape seems to be a little bit unreliable - # about providing boundary strings. - my $boundary_read = 0; - if ($boundary) { - - # Under the MIME spec, the boundary consists of the - # characters "--" PLUS the Boundary string - - # BUG: IE 3.01 on the Macintosh uses just the boundary -- not - # the two extra hyphens. We do a special case here on the user-agent!!!! - $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport'); - - } else { # otherwise we find it ourselves - my($old); - ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line - $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl - $length -= length($boundary); - chomp($boundary); # remove the CRLF - $/ = $old; # restore old line separator - $boundary_read++; - } - - my $self = {LENGTH=>$length, - BOUNDARY=>$boundary, - INTERFACE=>$interface, - BUFFER=>'', - }; - - $FILLUNIT = length($boundary) - if length($boundary) > $FILLUNIT; - - my $retval = bless $self,ref $package || $package; - - # Read the preamble and the topmost (boundary) line plus the CRLF. - unless ($boundary_read) { - while ($self->read(0)) { } - } - die "Malformed multipart POST: data truncated\n" if $self->eof; - - return $retval; -} -END_OF_FUNC - -'readHeader' => <<'END_OF_FUNC', -sub readHeader { - my($self) = @_; - my($end); - my($ok) = 0; - my($bad) = 0; - - local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC; - - do { - $self->fillBuffer($FILLUNIT); - $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0; - $ok++ if $self->{BUFFER} eq ''; - $bad++ if !$ok && $self->{LENGTH} <= 0; - # this was a bad idea - # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; - } until $ok || $bad; - return () if $bad; - - #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines! - - my($header) = substr($self->{BUFFER},0,$end+2); - substr($self->{BUFFER},0,$end+4) = ''; - my %return; - - if ($CGI::EBCDIC) { - warn "untranslated header=$header\n" if DEBUG; - $header = CGI::Util::ascii2ebcdic($header); - warn "translated header=$header\n" if DEBUG; - } - - # See RFC 2045 Appendix A and RFC 822 sections 3.4.8 - # (Folding Long Header Fields), 3.4.3 (Comments) - # and 3.4.5 (Quoted-Strings). - - my $token = '[-\w!\#$%&\'*+.^_\`|{}~]'; - $header=~s/$CRLF\s+/ /og; # merge continuation lines - - while ($header=~/($token+):\s+([^$CRLF]*)/mgox) { - my ($field_name,$field_value) = ($1,$2); - $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize - $return{$field_name}=$field_value; - } - return %return; -} -END_OF_FUNC - -# This reads and returns the body as a single scalar value. -'readBody' => <<'END_OF_FUNC', -sub readBody { - my($self) = @_; - my($data); - my($returnval)=''; - - #EBCDIC NOTE: want to translate returnval into EBCDIC HERE - - while (defined($data = $self->read)) { - $returnval .= $data; - } - - if ($CGI::EBCDIC) { - warn "untranslated body=$returnval\n" if DEBUG; - $returnval = CGI::Util::ascii2ebcdic($returnval); - warn "translated body=$returnval\n" if DEBUG; - } - return $returnval; -} -END_OF_FUNC - -# This will read $bytes or until the boundary is hit, whichever happens -# first. After the boundary is hit, we return undef. The next read will -# skip over the boundary and begin reading again; -'read' => <<'END_OF_FUNC', -sub read { - my($self,$bytes) = @_; - - # default number of bytes to read - $bytes = $bytes || $FILLUNIT; - - # Fill up our internal buffer in such a way that the boundary - # is never split between reads. - $self->fillBuffer($bytes); - - my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY}; - my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--'; - - # Find the boundary in the buffer (it may not be there). - my $start = index($self->{BUFFER},$boundary_start); - - warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG; - # protect against malformed multipart POST operations - die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0); - - - #EBCDIC NOTE: want to translate boundary search into ASCII here. - - # If the boundary begins the data, then skip past it - # and return undef. - if ($start == 0) { - - # clear us out completely if we've hit the last boundary. - if (index($self->{BUFFER},$boundary_end)==0) { - $self->{BUFFER}=''; - $self->{LENGTH}=0; - return undef; - } - - # just remove the boundary. - substr($self->{BUFFER},0,length($boundary_start))=''; - $self->{BUFFER} =~ s/^\012\015?//; - return undef; - } - - my $bytesToReturn; - if ($start > 0) { # read up to the boundary - $bytesToReturn = $start-2 > $bytes ? $bytes : $start; - } else { # read the requested number of bytes - # leave enough bytes in the buffer to allow us to read - # the boundary. Thanks to Kevin Hendrick for finding - # this one. - $bytesToReturn = $bytes - (length($boundary_start)+1); - } - - my $returnval=substr($self->{BUFFER},0,$bytesToReturn); - substr($self->{BUFFER},0,$bytesToReturn)=''; - - # If we hit the boundary, remove the CRLF from the end. - return ($bytesToReturn==$start) - ? substr($returnval,0,-2) : $returnval; -} -END_OF_FUNC - - -# This fills up our internal buffer in such a way that the -# boundary is never split between reads -'fillBuffer' => <<'END_OF_FUNC', -sub fillBuffer { - my($self,$bytes) = @_; - return unless $self->{LENGTH}; - - my($boundaryLength) = length($self->{BOUNDARY}); - my($bufferLength) = length($self->{BUFFER}); - my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2; - $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead; - - # Try to read some data. We may hang here if the browser is screwed up. - my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER}, - $bytesToRead, - $bufferLength); - warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG; - $self->{BUFFER} = '' unless defined $self->{BUFFER}; - - # An apparent bug in the Apache server causes the read() - # to return zero bytes repeatedly without blocking if the - # remote user aborts during a file transfer. I don't know how - # they manage this, but the workaround is to abort if we get - # more than SPIN_LOOP_MAX consecutive zero reads. - if ($bytesRead == 0) { - die "CGI.pm: Server closed socket during multipart read (client aborted?).\n" - if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX); - } else { - $self->{ZERO_LOOP_COUNTER}=0; - } - - $self->{LENGTH} -= $bytesRead; -} -END_OF_FUNC - - -# Return true when we've finished reading -'eof' => <<'END_OF_FUNC' -sub eof { - my($self) = @_; - return 1 if (length($self->{BUFFER}) == 0) - && ($self->{LENGTH} <= 0); - undef; -} -END_OF_FUNC - -); -END_OF_AUTOLOAD - -#################################################################################### -################################## TEMPORARY FILES ################################# -#################################################################################### -package CGITempFile; - -sub find_tempdir { - undef $TMPDIRECTORY; - $SL = $CGI::SL; - $MAC = $CGI::OS eq 'MACINTOSH'; - my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : ""; - unless ($TMPDIRECTORY) { - @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp", - "C:${SL}temp","${SL}tmp","${SL}temp", - "${vol}${SL}Temporary Items", - "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH", - "C:${SL}system${SL}temp"); - unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'}; - - # this feature was supposed to provide per-user tmpfiles, but - # it is problematic. - # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX'; - # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this - # : can generate a 'getpwuid() not implemented' exception, even though - # : it's never called. Found under DOS/Win with the DJGPP perl port. - # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX. - # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0; - - foreach (@TEMP) { - do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; - } - } - $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY; -} - -find_tempdir(); - -$MAXTRIES = 5000; - -# cute feature, but overload implementation broke it -# %OVERLOAD = ('""'=>'as_string'); -*CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD; - -sub DESTROY { - my($self) = @_; - $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$! || return; - my $safe = $1; # untaint operation - unlink $safe; # get rid of the file -} - -############################################################################### -################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### -############################################################################### -$AUTOLOADED_ROUTINES = ''; # prevent -w error -$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; -%SUBS = ( - -'new' => <<'END_OF_FUNC', -sub new { - my($package,$sequence) = @_; - my $filename; - find_tempdir() unless -w $TMPDIRECTORY; - for (my $i = 0; $i < $MAXTRIES; $i++) { - last if ! -f ($filename = sprintf("${TMPDIRECTORY}${SL}CGItemp%d",$sequence++)); - } - # check that it is a more-or-less valid filename - return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\-]+)$!; - # this used to untaint, now it doesn't - # $filename = $1; - return bless \$filename; -} -END_OF_FUNC - -'as_string' => <<'END_OF_FUNC' -sub as_string { - my($self) = @_; - return $$self; -} -END_OF_FUNC - -); -END_OF_AUTOLOAD - -package CGI; - -# We get a whole bunch of warnings about "possibly uninitialized variables" -# when running with the -w switch. Touch them all once to get rid of the -# warnings. This is ugly and I hate it. -if ($^W) { - $CGI::CGI = ''; - $CGI::CGI=<<EOF; - $CGI::VERSION; - $MultipartBuffer::SPIN_LOOP_MAX; - $MultipartBuffer::CRLF; - $MultipartBuffer::TIMEOUT; - $MultipartBuffer::INITIAL_FILLUNIT; -EOF - ; -} - -1; - -__END__ - -=head1 NAME - -CGI - Simple Common Gateway Interface Class - -=head1 SYNOPSIS - - # CGI script that creates a fill-out form - # and echoes back its values. - - use CGI qw/:standard/; - print header, - start_html('A Simple Example'), - h1('A Simple Example'), - start_form, - "What's your name? ",textfield('name'),p, - "What's the combination?", p, - checkbox_group(-name=>'words', - -values=>['eenie','meenie','minie','moe'], - -defaults=>['eenie','minie']), p, - "What's your favorite color? ", - popup_menu(-name=>'color', - -values=>['red','green','blue','chartreuse']),p, - submit, - end_form, - hr; - - if (param()) { - print "Your name is",em(param('name')),p, - "The keywords are: ",em(join(", ",param('words'))),p, - "Your favorite color is ",em(param('color')), - hr; - } - -=head1 ABSTRACT - -This perl library uses perl5 objects to make it easy to create Web -fill-out forms and parse their contents. This package defines CGI -objects, entities that contain the values of the current query string -and other state variables. Using a CGI object's methods, you can -examine keywords and parameters passed to your script, and create -forms whose initial values are taken from the current query (thereby -preserving state information). The module provides shortcut functions -that produce boilerplate HTML, reducing typing and coding errors. It -also provides functionality for some of the more advanced features of -CGI scripting, including support for file uploads, cookies, cascading -style sheets, server push, and frames. - -CGI.pm also provides a simple function-oriented programming style for -those who don't need its object-oriented features. - -The current version of CGI.pm is available at - - http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html - ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ - -=head1 DESCRIPTION - -=head2 PROGRAMMING STYLE - -There are two styles of programming with CGI.pm, an object-oriented -style and a function-oriented style. In the object-oriented style you -create one or more CGI objects and then use object methods to create -the various elements of the page. Each CGI object starts out with the -list of named parameters that were passed to your CGI script by the -server. You can modify the objects, save them to a file or database -and recreate them. Because each object corresponds to the "state" of -the CGI script, and because each object's parameter list is -independent of the others, this allows you to save the state of the -script and restore it later. - -For example, using the object oriented style, here is how you create -a simple "Hello World" HTML page: - - #!/usr/local/bin/perl -w - use CGI; # load CGI routines - $q = new CGI; # create new CGI object - print $q->header, # create the HTTP header - $q->start_html('hello world'), # start the HTML - $q->h1('hello world'), # level 1 header - $q->end_html; # end the HTML - -In the function-oriented style, there is one default CGI object that -you rarely deal with directly. Instead you just call functions to -retrieve CGI parameters, create HTML tags, manage cookies, and so -on. This provides you with a cleaner programming interface, but -limits you to using one CGI object at a time. The following example -prints the same page, but uses the function-oriented interface. -The main differences are that we now need to import a set of functions -into our name space (usually the "standard" functions), and we don't -need to create the CGI object. - - #!/usr/local/bin/perl - use CGI qw/:standard/; # load standard CGI routines - print header, # create the HTTP header - start_html('hello world'), # start the HTML - h1('hello world'), # level 1 header - end_html; # end the HTML - -The examples in this document mainly use the object-oriented style. -See HOW TO IMPORT FUNCTIONS for important information on -function-oriented programming in CGI.pm - -=head2 CALLING CGI.PM ROUTINES - -Most CGI.pm routines accept several arguments, sometimes as many as 20 -optional ones! To simplify this interface, all routines use a named -argument calling style that looks like this: - - print $q->header(-type=>'image/gif',-expires=>'+3d'); - -Each argument name is preceded by a dash. Neither case nor order -matters in the argument list. -type, -Type, and -TYPE are all -acceptable. In fact, only the first argument needs to begin with a -dash. If a dash is present in the first argument, CGI.pm assumes -dashes for the subsequent ones. - -Several routines are commonly called with just one argument. In the -case of these routines you can provide the single argument without an -argument name. header() happens to be one of these routines. In this -case, the single argument is the document type. - - print $q->header('text/html'); - -Other such routines are documented below. - -Sometimes named arguments expect a scalar, sometimes a reference to an -array, and sometimes a reference to a hash. Often, you can pass any -type of argument and the routine will do whatever is most appropriate. -For example, the param() routine is used to set a CGI parameter to a -single or a multi-valued value. The two cases are shown below: - - $q->param(-name=>'veggie',-value=>'tomato'); - $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']); - -A large number of routines in CGI.pm actually aren't specifically -defined in the module, but are generated automatically as needed. -These are the "HTML shortcuts," routines that generate HTML tags for -use in dynamically-generated pages. HTML tags have both attributes -(the attribute="value" pairs within the tag itself) and contents (the -part between the opening and closing pairs.) To distinguish between -attributes and contents, CGI.pm uses the convention of passing HTML -attributes as a hash reference as the first argument, and the -contents, if any, as any subsequent arguments. It works out like -this: - - Code Generated HTML - ---- -------------- - h1() <h1> - h1('some','contents'); <h1>some contents</h1> - h1({-align=>left}); <h1 align="LEFT"> - h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1> - -HTML tags are described in more detail later. - -Many newcomers to CGI.pm are puzzled by the difference between the -calling conventions for the HTML shortcuts, which require curly braces -around the HTML tag attributes, and the calling conventions for other -routines, which manage to generate attributes without the curly -brackets. Don't be confused. As a convenience the curly braces are -optional in all but the HTML shortcuts. If you like, you can use -curly braces when calling any routine that takes named arguments. For -example: - - print $q->header( {-type=>'image/gif',-expires=>'+3d'} ); - -If you use the B<-w> switch, you will be warned that some CGI.pm argument -names conflict with built-in Perl functions. The most frequent of -these is the -values argument, used to create multi-valued menus, -radio button clusters and the like. To get around this warning, you -have several choices: - -=over 4 - -=item 1. - -Use another name for the argument, if one is available. -For example, -value is an alias for -values. - -=item 2. - -Change the capitalization, e.g. -Values - -=item 3. - -Put quotes around the argument name, e.g. '-values' - -=back - -Many routines will do something useful with a named argument that it -doesn't recognize. For example, you can produce non-standard HTTP -header fields by providing them as named arguments: - - print $q->header(-type => 'text/html', - -cost => 'Three smackers', - -annoyance_level => 'high', - -complaints_to => 'bit bucket'); - -This will produce the following nonstandard HTTP header: - - HTTP/1.0 200 OK - Cost: Three smackers - Annoyance-level: high - Complaints-to: bit bucket - Content-type: text/html - -Notice the way that underscores are translated automatically into -hyphens. HTML-generating routines perform a different type of -translation. - -This feature allows you to keep up with the rapidly changing HTTP and -HTML "standards". - -=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE): - - $query = new CGI; - -This will parse the input (from both POST and GET methods) and store -it into a perl5 object called $query. - -=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE - - $query = new CGI(INPUTFILE); - -If you provide a file handle to the new() method, it will read -parameters from the file (or STDIN, or whatever). The file can be in -any of the forms describing below under debugging (i.e. a series of -newline delimited TAG=VALUE pairs will work). Conveniently, this type -of file is created by the save() method (see below). Multiple records -can be saved and restored. - -Perl purists will be pleased to know that this syntax accepts -references to file handles, or even references to filehandle globs, -which is the "official" way to pass a filehandle: - - $query = new CGI(\*STDIN); - -You can also initialize the CGI object with a FileHandle or IO::File -object. - -If you are using the function-oriented interface and want to -initialize CGI state from a file handle, the way to do this is with -B<restore_parameters()>. This will (re)initialize the -default CGI object from the indicated file handle. - - open (IN,"test.in") || die; - restore_parameters(IN); - close IN; - -You can also initialize the query object from an associative array -reference: - - $query = new CGI( {'dinosaur'=>'barney', - 'song'=>'I love you', - 'friends'=>[qw/Jessica George Nancy/]} - ); - -or from a properly formatted, URL-escaped query string: - - $query = new CGI('dinosaur=barney&color=purple'); - -or from a previously existing CGI object (currently this clones the -parameter list, but none of the other object-specific fields, such as -autoescaping): - - $old_query = new CGI; - $new_query = new CGI($old_query); - -To create an empty query, initialize it from an empty string or hash: - - $empty_query = new CGI(""); - - -or- - - $empty_query = new CGI({}); - -=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY: - - @keywords = $query->keywords - -If the script was invoked as the result of an <ISINDEX> search, the -parsed keywords can be obtained as an array using the keywords() method. - -=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT: - - @names = $query->param - -If the script was invoked with a parameter list -(e.g. "name1=value1&name2=value2&name3=value3"), the param() method -will return the parameter names as a list. If the script was invoked -as an <ISINDEX> script and contains a string without ampersands -(e.g. "value1+value2+value3") , there will be a single parameter named -"keywords" containing the "+"-delimited keywords. - -NOTE: As of version 1.5, the array of parameter names returned will -be in the same order as they were submitted by the browser. -Usually this order is the same as the order in which the -parameters are defined in the form (however, this isn't part -of the spec, and so isn't guaranteed). - -=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER: - - @values = $query->param('foo'); - - -or- - - $value = $query->param('foo'); - -Pass the param() method a single argument to fetch the value of the -named parameter. If the parameter is multivalued (e.g. from multiple -selections in a scrolling list), you can ask to receive an array. Otherwise -the method will return a single value. - -If a value is not given in the query string, as in the queries -"name1=&name2=" or "name1&name2", it will be returned as an empty -string. This feature is new in 2.63. - - -If the parameter does not exist at all, then param() will return undef -in a scalar context, and the empty list in a list context. - - -=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER: - - $query->param('foo','an','array','of','values'); - -This sets the value for the named parameter 'foo' to an array of -values. This is one way to change the value of a field AFTER -the script has been invoked once before. (Another way is with -the -override parameter accepted by all methods that generate -form elements.) - -param() also recognizes a named parameter style of calling described -in more detail later: - - $query->param(-name=>'foo',-values=>['an','array','of','values']); - - -or- - - $query->param(-name=>'foo',-value=>'the value'); - -=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER: - - $query->append(-name=>'foo',-values=>['yet','more','values']); - -This adds a value or list of values to the named parameter. The -values are appended to the end of the parameter if it already exists. -Otherwise the parameter is created. Note that this method only -recognizes the named argument calling syntax. - -=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE: - - $query->import_names('R'); - -This creates a series of variables in the 'R' namespace. For example, -$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear. -If no namespace is given, this method will assume 'Q'. -WARNING: don't import anything into 'main'; this is a major security -risk!!!! - -NOTE 1: Variable names are transformed as necessary into legal Perl -variable names. All non-legal characters are transformed into -underscores. If you need to keep the original names, you should use -the param() method instead to access CGI variables by name. - -NOTE 2: In older versions, this method was called B<import()>. As of version 2.20, -this name has been removed completely to avoid conflict with the built-in -Perl module B<import> operator. - -=head2 DELETING A PARAMETER COMPLETELY: - - $query->delete('foo','bar','baz'); - -This completely clears a list of parameters. It sometimes useful for -resetting parameters that you don't want passed down between script -invocations. - -If you are using the function call interface, use "Delete()" instead -to avoid conflicts with Perl's built-in delete operator. - -=head2 DELETING ALL PARAMETERS: - - $query->delete_all(); - -This clears the CGI object completely. It might be useful to ensure -that all the defaults are taken when you create a fill-out form. - -Use Delete_all() instead if you are using the function call interface. - -=head2 DIRECT ACCESS TO THE PARAMETER LIST: - - $q->param_fetch('address')->[1] = '1313 Mockingbird Lane'; - unshift @{$q->param_fetch(-name=>'address')},'George Munster'; - -If you need access to the parameter list in a way that isn't covered -by the methods above, you can obtain a direct reference to it by -calling the B<param_fetch()> method with the name of the . This -will return an array reference to the named parameters, which you then -can manipulate in any way you like. - -You can also use a named argument style using the B<-name> argument. - -=head2 FETCHING THE PARAMETER LIST AS A HASH: - - $params = $q->Vars; - print $params->{'address'}; - @foo = split("\0",$params->{'foo'}); - %params = $q->Vars; - - use CGI ':cgi-lib'; - $params = Vars; - -Many people want to fetch the entire parameter list as a hash in which -the keys are the names of the CGI parameters, and the values are the -parameters' values. The Vars() method does this. Called in a scalar -context, it returns the parameter list as a tied hash reference. -Changing a key changes the value of the parameter in the underlying -CGI parameter list. Called in a list context, it returns the -parameter list as an ordinary hash. This allows you to read the -contents of the parameter list, but not to change it. - -When using this, the thing you must watch out for are multivalued CGI -parameters. Because a hash cannot distinguish between scalar and -list context, multivalued parameters will be returned as a packed -string, separated by the "\0" (null) character. You must split this -packed string in order to get at the individual values. This is the -convention introduced long ago by Steve Brenner in his cgi-lib.pl -module for Perl version 4. - -If you wish to use Vars() as a function, import the I<:cgi-lib> set of -function calls (also see the section on CGI-LIB compatibility). - -=head2 SAVING THE STATE OF THE SCRIPT TO A FILE: - - $query->save(FILEHANDLE) - -This will write the current state of the form to the provided -filehandle. You can read it back in by providing a filehandle -to the new() method. Note that the filehandle can be a file, a pipe, -or whatever! - -The format of the saved file is: - - NAME1=VALUE1 - NAME1=VALUE1' - NAME2=VALUE2 - NAME3=VALUE3 - = - -Both name and value are URL escaped. Multi-valued CGI parameters are -represented as repeated names. A session record is delimited by a -single = symbol. You can write out multiple records and read them -back in with several calls to B<new>. You can do this across several -sessions by opening the file in append mode, allowing you to create -primitive guest books, or to keep a history of users' queries. Here's -a short example of creating multiple session records: - - use CGI; - - open (OUT,">>test.out") || die; - $records = 5; - foreach (0..$records) { - my $q = new CGI; - $q->param(-name=>'counter',-value=>$_); - $q->save(OUT); - } - close OUT; - - # reopen for reading - open (IN,"test.out") || die; - while (!eof(IN)) { - my $q = new CGI(IN); - print $q->param('counter'),"\n"; - } - -The file format used for save/restore is identical to that used by the -Whitehead Genome Center's data exchange format "Boulderio", and can be -manipulated and even databased using Boulderio utilities. See - - http://stein.cshl.org/boulder/ - -for further details. - -If you wish to use this method from the function-oriented (non-OO) -interface, the exported name for this method is B<save_parameters()>. - -=head2 RETRIEVING CGI ERRORS - -Errors can occur while processing user input, particularly when -processing uploaded files. When these errors occur, CGI will stop -processing and return an empty parameter list. You can test for -the existence and nature of errors using the I<cgi_error()> function. -The error messages are formatted as HTTP status codes. You can either -incorporate the error text into an HTML page, or use it as the value -of the HTTP status: - - my $error = $q->cgi_error; - if ($error) { - print $q->header(-status=>$error), - $q->start_html('Problems'), - $q->h2('Request not processed'), - $q->strong($error); - exit 0; - } - -When using the function-oriented interface (see the next section), -errors may only occur the first time you call I<param()>. Be ready -for this! - -=head2 USING THE FUNCTION-ORIENTED INTERFACE - -To use the function-oriented interface, you must specify which CGI.pm -routines or sets of routines to import into your script's namespace. -There is a small overhead associated with this importation, but it -isn't much. - - use CGI <list of methods>; - -The listed methods will be imported into the current package; you can -call them directly without creating a CGI object first. This example -shows how to import the B<param()> and B<header()> -methods, and then use them directly: - - use CGI 'param','header'; - print header('text/plain'); - $zipcode = param('zipcode'); - -More frequently, you'll import common sets of functions by referring -to the groups by name. All function sets are preceded with a ":" -character as in ":html3" (for tags defined in the HTML 3 standard). - -Here is a list of the function sets you can import: - -=over 4 - -=item B<:cgi> - -Import all CGI-handling methods, such as B<param()>, B<path_info()> -and the like. - -=item B<:form> - -Import all fill-out form generating methods, such as B<textfield()>. - -=item B<:html2> - -Import all methods that generate HTML 2.0 standard elements. - -=item B<:html3> - -Import all methods that generate HTML 3.0 elements (such as -<table>, <super> and <sub>). - -=item B<:html4> - -Import all methods that generate HTML 4 elements (such as -<abbrev>, <acronym> and <thead>). - -=item B<:netscape> - -Import all methods that generate Netscape-specific HTML extensions. - -=item B<:html> - -Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' + -'netscape')... - -=item B<:standard> - -Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'. - -=item B<:all> - -Import all the available methods. For the full list, see the CGI.pm -code, where the variable %EXPORT_TAGS is defined. - -=back - -If you import a function name that is not part of CGI.pm, the module -will treat it as a new HTML tag and generate the appropriate -subroutine. You can then use it like any other HTML tag. This is to -provide for the rapidly-evolving HTML "standard." For example, say -Microsoft comes out with a new tag called <gradient> (which causes the -user's desktop to be flooded with a rotating gradient fill until his -machine reboots). You don't need to wait for a new version of CGI.pm -to start using it immediately: - - use CGI qw/:standard :html3 gradient/; - print gradient({-start=>'red',-end=>'blue'}); - -Note that in the interests of execution speed CGI.pm does B<not> use -the standard L<Exporter> syntax for specifying load symbols. This may -change in the future. - -If you import any of the state-maintaining CGI or form-generating -methods, a default CGI object will be created and initialized -automatically the first time you use any of the methods that require -one to be present. This includes B<param()>, B<textfield()>, -B<submit()> and the like. (If you need direct access to the CGI -object, you can find it in the global variable B<$CGI::Q>). By -importing CGI.pm methods, you can create visually elegant scripts: - - use CGI qw/:standard/; - print - header, - start_html('Simple Script'), - h1('Simple Script'), - start_form, - "What's your name? ",textfield('name'),p, - "What's the combination?", - checkbox_group(-name=>'words', - -values=>['eenie','meenie','minie','moe'], - -defaults=>['eenie','moe']),p, - "What's your favorite color?", - popup_menu(-name=>'color', - -values=>['red','green','blue','chartreuse']),p, - submit, - end_form, - hr,"\n"; - - if (param) { - print - "Your name is ",em(param('name')),p, - "The keywords are: ",em(join(", ",param('words'))),p, - "Your favorite color is ",em(param('color')),".\n"; - } - print end_html; - -=head2 PRAGMAS - -In addition to the function sets, there are a number of pragmas that -you can import. Pragmas, which are always preceded by a hyphen, -change the way that CGI.pm functions in various ways. Pragmas, -function sets, and individual functions can all be imported in the -same use() line. For example, the following use statement imports the -standard set of functions and enables debugging mode (pragma --debug): - - use CGI qw/:standard -debug/; - -The current list of pragmas is as follows: - -=over 4 - -=item -any - -When you I<use CGI -any>, then any method that the query object -doesn't recognize will be interpreted as a new HTML tag. This allows -you to support the next I<ad hoc> Netscape or Microsoft HTML -extension. This lets you go wild with new and unsupported tags: - - use CGI qw(-any); - $q=new CGI; - print $q->gradient({speed=>'fast',start=>'red',end=>'blue'}); - -Since using <cite>any</cite> causes any mistyped method name -to be interpreted as an HTML tag, use it with care or not at -all. - -=item -compile - -This causes the indicated autoloaded methods to be compiled up front, -rather than deferred to later. This is useful for scripts that run -for an extended period of time under FastCGI or mod_perl, and for -those destined to be crunched by Malcom Beattie's Perl compiler. Use -it in conjunction with the methods or method families you plan to use. - - use CGI qw(-compile :standard :html3); - -or even - - use CGI qw(-compile :all); - -Note that using the -compile pragma in this way will always have -the effect of importing the compiled functions into the current -namespace. If you want to compile without importing use the -compile() method instead: - - use CGI(); - CGI->compile(); - -This is particularly useful in a mod_perl environment, in which you -might want to precompile all CGI routines in a startup script, and -then import the functions individually in each mod_perl script. - -=item -nosticky - -This makes CGI.pm not generating the hidden fields .submit -and .cgifields. It is very useful if you don't want to -have the hidden fields appear in the querystring in a GET method. -For example, a search script generated this way will have -a very nice url with search parameters for bookmarking. - -=item -no_undef_params - -This keeps CGI.pm from including undef params in the parameter list. - -=item -no_xhtml - -By default, CGI.pm versions 2.69 and higher emit XHTML -(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this -feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this -feature. - -If start_html()'s -dtd parameter specifies an HTML 2.0 or 3.2 DTD, -XHTML will automatically be disabled without needing to use this -pragma. - -=item -nph - -This makes CGI.pm produce a header appropriate for an NPH (no -parsed header) script. You may need to do other things as well -to tell the server that the script is NPH. See the discussion -of NPH scripts below. - -=item -newstyle_urls - -Separate the name=value pairs in CGI parameter query strings with -semicolons rather than ampersands. For example: - - ?name=fred;age=24;favorite_color=3 - -Semicolon-delimited query strings are always accepted, but will not be -emitted by self_url() and query_string() unless the -newstyle_urls -pragma is specified. - -This became the default in version 2.64. - -=item -oldstyle_urls - -Separate the name=value pairs in CGI parameter query strings with -ampersands rather than semicolons. This is no longer the default. - -=item -autoload - -This overrides the autoloader so that any function in your program -that is not recognized is referred to CGI.pm for possible evaluation. -This allows you to use all the CGI.pm functions without adding them to -your symbol table, which is of concern for mod_perl users who are -worried about memory consumption. I<Warning:> when -I<-autoload> is in effect, you cannot use "poetry mode" -(functions without the parenthesis). Use I<hr()> rather -than I<hr>, or add something like I<use subs qw/hr p header/> -to the top of your script. - -=item -no_debug - -This turns off the command-line processing features. If you want to -run a CGI.pm script from the command line to produce HTML, and you -don't want it to read CGI parameters from the command line or STDIN, -then use this pragma: - - use CGI qw(-no_debug :standard); - -=item -debug - -This turns on full debugging. In addition to reading CGI arguments -from the command-line processing, CGI.pm will pause and try to read -arguments from STDIN, producing the message "(offline mode: enter -name=value pairs on standard input)" features. - -See the section on debugging for more details. - -=item -private_tempfiles - -CGI.pm can process uploaded file. Ordinarily it spools the uploaded -file to a temporary directory, then deletes the file when done. -However, this opens the risk of eavesdropping as described in the file -upload section. Another CGI script author could peek at this data -during the upload, even if it is confidential information. On Unix -systems, the -private_tempfiles pragma will cause the temporary file -to be unlinked as soon as it is opened and before any data is written -into it, reducing, but not eliminating the risk of eavesdropping -(there is still a potential race condition). To make life harder for -the attacker, the program chooses tempfile names by calculating a 32 -bit checksum of the incoming HTTP headers. - -To ensure that the temporary file cannot be read by other CGI scripts, -use suEXEC or a CGI wrapper program to run your script. The temporary -file is created with mode 0600 (neither world nor group readable). - -The temporary directory is selected using the following algorithm: - - 1. if the current user (e.g. "nobody") has a directory named - "tmp" in its home directory, use that (Unix systems only). - - 2. if the environment variable TMPDIR exists, use the location - indicated. - - 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp, - /tmp, /temp, ::Temporary Items, and \WWW_ROOT. - -Each of these locations is checked that it is a directory and is -writable. If not, the algorithm tries the next choice. - -=back - -=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS - -Many of the methods generate HTML tags. As described below, tag -functions automatically generate both the opening and closing tags. -For example: - - print h1('Level 1 Header'); - -produces - - <h1>Level 1 Header</h1> - -There will be some times when you want to produce the start and end -tags yourself. In this case, you can use the form start_I<tag_name> -and end_I<tag_name>, as in: - - print start_h1,'Level 1 Header',end_h1; - -With a few exceptions (described below), start_I<tag_name> and -end_I<tag_name> functions are not generated automatically when you -I<use CGI>. However, you can specify the tags you want to generate -I<start/end> functions for by putting an asterisk in front of their -name, or, alternatively, requesting either "start_I<tag_name>" or -"end_I<tag_name>" in the import list. - -Example: - - use CGI qw/:standard *table start_ul/; - -In this example, the following functions are generated in addition to -the standard ones: - -=over 4 - -=item 1. start_table() (generates a <table> tag) - -=item 2. end_table() (generates a </table> tag) - -=item 3. start_ul() (generates a <ul> tag) - -=item 4. end_ul() (generates a </ul> tag) - -=back - -=head1 GENERATING DYNAMIC DOCUMENTS - -Most of CGI.pm's functions deal with creating documents on the fly. -Generally you will produce the HTTP header first, followed by the -document itself. CGI.pm provides functions for generating HTTP -headers of various types as well as for generating HTML. For creating -GIF images, see the GD.pm module. - -Each of these functions produces a fragment of HTML or HTTP which you -can print out directly so that it displays in the browser window, -append to a string, or save to a file for later use. - -=head2 CREATING A STANDARD HTTP HEADER: - -Normally the first thing you will do in any CGI script is print out an -HTTP header. This tells the browser what type of document to expect, -and gives other optional information, such as the language, expiration -date, and whether to cache the document. The header can also be -manipulated for special purposes, such as server push and pay per view -pages. - - print $query->header; - - -or- - - print $query->header('image/gif'); - - -or- - - print $query->header('text/html','204 No response'); - - -or- - - print $query->header(-type=>'image/gif', - -nph=>1, - -status=>'402 Payment required', - -expires=>'+3d', - -cookie=>$cookie, - -charset=>'utf-7', - -attachment=>'foo.gif', - -Cost=>'$2.00'); - -header() returns the Content-type: header. You can provide your own -MIME type if you choose, otherwise it defaults to text/html. An -optional second parameter specifies the status code and a human-readable -message. For example, you can specify 204, "No response" to create a -script that tells the browser to do nothing at all. - -The last example shows the named argument style for passing arguments -to the CGI methods using named parameters. Recognized parameters are -B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named -parameters will be stripped of their initial hyphens and turned into -header fields, allowing you to specify any HTTP header you desire. -Internal underscores will be turned into hyphens: - - print $query->header(-Content_length=>3002); - -Most browsers will not cache the output from CGI scripts. Every time -the browser reloads the page, the script is invoked anew. You can -change this behavior with the B<-expires> parameter. When you specify -an absolute or relative expiration interval with this parameter, some -browsers and proxy servers will cache the script's output until the -indicated expiration date. The following forms are all valid for the --expires field: - - +30s 30 seconds from now - +10m ten minutes from now - +1h one hour from now - -1d yesterday (i.e. "ASAP!") - now immediately - +3M in three months - +10y in ten years time - Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date - -The B<-cookie> parameter generates a header that tells the browser to provide -a "magic cookie" during all subsequent transactions with your script. -Netscape cookies have a special format that includes interesting attributes -such as expiration time. Use the cookie() method to create and retrieve -session cookies. - -The B<-nph> parameter, if set to a true value, will issue the correct -headers to work with a NPH (no-parse-header) script. This is important -to use with certain servers that expect all their scripts to be NPH. - -The B<-charset> parameter can be used to control the character set -sent to the browser. If not provided, defaults to ISO-8859-1. As a -side effect, this sets the charset() method as well. - -The B<-attachment> parameter can be used to turn the page into an -attachment. Instead of displaying the page, some browsers will prompt -the user to save it to disk. The value of the argument is the -suggested name for the saved file. In order for this to work, you may -have to set the B<-type> to "application/octet-stream". - -The B<-p3p> parameter will add a P3P tag to the outgoing header. The -parameter can be an arrayref or a space-delimited string of P3P tags. -For example: - - print header(-p3p=>[qw(CAO DSP LAW CURa)]); - print header(-p3p=>'CAO DSP LAW CURa'); - -In either case, the outgoing header will be formatted as: - - P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa" - -=head2 GENERATING A REDIRECTION HEADER - - print $query->redirect('http://somewhere.else/in/movie/land'); - -Sometimes you don't want to produce a document yourself, but simply -redirect the browser elsewhere, perhaps choosing a URL based on the -time of day or the identity of the user. - -The redirect() function redirects the browser to a different URL. If -you use redirection like this, you should B<not> print out a header as -well. - -You should always use full URLs (including the http: or ftp: part) in -redirection requests. Relative URLs will not work correctly. - -You can also use named arguments: - - print $query->redirect(-uri=>'http://somewhere.else/in/movie/land', - -nph=>1, - -status=>301); - -The B<-nph> parameter, if set to a true value, will issue the correct -headers to work with a NPH (no-parse-header) script. This is important -to use with certain servers, such as Microsoft IIS, which -expect all their scripts to be NPH. - -The B<-status> parameter will set the status of the redirect. HTTP -defines three different possible redirection status codes: - - 301 Moved Permanently - 302 Found - 303 See Other - -The default if not specified is 302, which means "moved temporarily." -You may change the status to another status code if you wish. Be -advised that changing the status to anything other than 301, 302 or -303 will probably break redirection. - -=head2 CREATING THE HTML DOCUMENT HEADER - - print $query->start_html(-title=>'Secrets of the Pyramids', - -author=>'fred@capricorn.org', - -base=>'true', - -target=>'_blank', - -meta=>{'keywords'=>'pharaoh secret mummy', - 'copyright'=>'copyright 1996 King Tut'}, - -style=>{'src'=>'/styles/style1.css'}, - -BGCOLOR=>'blue'); - -After creating the HTTP header, most CGI scripts will start writing -out an HTML document. The start_html() routine creates the top of the -page, along with a lot of optional information that controls the -page's appearance and behavior. - -This method returns a canned HTML header and the opening <body> tag. -All parameters are optional. In the named parameter form, recognized -parameters are -title, -author, -base, -xbase, -dtd, -lang and -target -(see below for the explanation). Any additional parameters you -provide, such as the Netscape unofficial BGCOLOR attribute, are added -to the <body> tag. Additional parameters must be proceeded by a -hyphen. - -The argument B<-xbase> allows you to provide an HREF for the <base> tag -different from the current location, as in - - -xbase=>"http://home.mcom.com/" - -All relative links will be interpreted relative to this tag. - -The argument B<-target> allows you to provide a default target frame -for all the links and fill-out forms on the page. B<This is a -non-standard HTTP feature which only works with Netscape browsers!> -See the Netscape documentation on frames for details of how to -manipulate this. - - -target=>"answer_window" - -All relative links will be interpreted relative to this tag. -You add arbitrary meta information to the header with the B<-meta> -argument. This argument expects a reference to an associative array -containing name/value pairs of meta information. These will be turned -into a series of header <meta> tags that look something like this: - - <meta name="keywords" content="pharaoh secret mummy"> - <meta name="description" content="copyright 1996 King Tut"> - -To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described -below. - -The B<-style> argument is used to incorporate cascading stylesheets -into your code. See the section on CASCADING STYLESHEETS for more -information. - -The B<-lang> argument is used to incorporate a language attribute into -the <html> tag. For example: - - print $q->start_html(-lang=>'fr-CA'); - -The default if not specified is "en-US" for US English, unless the --dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the -lang attribute is left off. You can force the lang attribute to left -off in other cases by passing an empty string (-lang=>''). - -The B<-encoding> argument can be used to specify the character set for -XHTML. It defaults to iso-8859-1 if not specified. - -You can place other arbitrary HTML elements to the <head> section with the -B<-head> tag. For example, to place the rarely-used <link> element in the -head section, use this: - - print start_html(-head=>Link({-rel=>'next', - -href=>'http://www.capricorn.com/s2.html'})); - -To incorporate multiple HTML elements into the <head> section, just pass an -array reference: - - print start_html(-head=>[ - Link({-rel=>'next', - -href=>'http://www.capricorn.com/s2.html'}), - Link({-rel=>'previous', - -href=>'http://www.capricorn.com/s1.html'}) - ] - ); - -And here's how to create an HTTP-EQUIV <meta> tag: - - print start_html(-head=>meta({-http_equiv => 'Content-Type', - -content => 'text/html'})) - - -JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>, -B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used -to add Netscape JavaScript calls to your pages. B<-script> should -point to a block of text containing JavaScript function definitions. -This block will be placed within a <script> block inside the HTML (not -HTTP) header. The block is placed in the header in order to give your -page a fighting chance of having all its JavaScript functions in place -even if the user presses the stop button before the page has loaded -completely. CGI.pm attempts to format the script in such a way that -JavaScript-naive browsers will not choke on the code: unfortunately -there are some browsers, such as Chimera for Unix, that get confused -by it nevertheless. - -The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript -code to execute when the page is respectively opened and closed by the -browser. Usually these parameters are calls to functions defined in the -B<-script> field: - - $query = new CGI; - print $query->header; - $JSCRIPT=<<END; - // Ask a silly question - function riddle_me_this() { - var r = prompt("What walks on four legs in the morning, " + - "two legs in the afternoon, " + - "and three legs in the evening?"); - response(r); - } - // Get a silly answer - function response(answer) { - if (answer == "man") - alert("Right you are!"); - else - alert("Wrong! Guess again."); - } - END - print $query->start_html(-title=>'The Riddle of the Sphinx', - -script=>$JSCRIPT); - -Use the B<-noScript> parameter to pass some HTML text that will be displayed on -browsers that do not have JavaScript (or browsers where JavaScript is turned -off). - -Netscape 3.0 recognizes several attributes of the <script> tag, -including LANGUAGE and SRC. The latter is particularly interesting, -as it allows you to keep the JavaScript code in a file or CGI script -rather than cluttering up each page with the source. To use these -attributes pass a HASH reference in the B<-script> parameter containing -one or more of -language, -src, or -code: - - print $q->start_html(-title=>'The Riddle of the Sphinx', - -script=>{-language=>'JAVASCRIPT', - -src=>'/javascript/sphinx.js'} - ); - - print $q->(-title=>'The Riddle of the Sphinx', - -script=>{-language=>'PERLSCRIPT', - -code=>'print "hello world!\n;"'} - ); - - -A final feature allows you to incorporate multiple <script> sections into the -header. Just pass the list of script sections as an array reference. -this allows you to specify different source files for different dialects -of JavaScript. Example: - - print $q->start_html(-title=>'The Riddle of the Sphinx', - -script=>[ - { -language => 'JavaScript1.0', - -src => '/javascript/utilities10.js' - }, - { -language => 'JavaScript1.1', - -src => '/javascript/utilities11.js' - }, - { -language => 'JavaScript1.2', - -src => '/javascript/utilities12.js' - }, - { -language => 'JavaScript28.2', - -src => '/javascript/utilities219.js' - } - ] - ); - -If this looks a bit extreme, take my advice and stick with straight CGI scripting. - -See - - http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/ - -for more information about JavaScript. - -The old-style positional parameters are as follows: - -=over 4 - -=item B<Parameters:> - -=item 1. - -The title - -=item 2. - -The author's e-mail address (will create a <link rev="MADE"> tag if present - -=item 3. - -A 'true' flag if you want to include a <base> tag in the header. This -helps resolve relative addresses to absolute ones when the document is moved, -but makes the document hierarchy non-portable. Use with care! - -=item 4, 5, 6... - -Any other parameters you want to include in the <body> tag. This is a good -place to put Netscape extensions, such as colors and wallpaper patterns. - -=back - -=head2 ENDING THE HTML DOCUMENT: - - print $query->end_html - -This ends an HTML document by printing the </body></html> tags. - -=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION: - - $myself = $query->self_url; - print q(<a href="$myself">I'm talking to myself.</a>); - -self_url() will return a URL, that, when selected, will reinvoke -this script with all its state information intact. This is most -useful when you want to jump around within the document using -internal anchors but you don't want to disrupt the current contents -of the form(s). Something like this will do the trick. - - $myself = $query->self_url; - print "<a href=\"$myself#table1\">See table 1</a>"; - print "<a href=\"$myself#table2\">See table 2</a>"; - print "<a href=\"$myself#yourself\">See for yourself</a>"; - -If you want more control over what's returned, using the B<url()> -method instead. - -You can also retrieve the unprocessed query string with query_string(): - - $the_string = $query->query_string; - -=head2 OBTAINING THE SCRIPT'S URL - - $full_url = $query->url(); - $full_url = $query->url(-full=>1); #alternative syntax - $relative_url = $query->url(-relative=>1); - $absolute_url = $query->url(-absolute=>1); - $url_with_path = $query->url(-path_info=>1); - $url_with_path_and_query = $query->url(-path_info=>1,-query=>1); - $netloc = $query->url(-base => 1); - -B<url()> returns the script's URL in a variety of formats. Called -without any arguments, it returns the full form of the URL, including -host name and port number - - http://your.host.com/path/to/script.cgi - -You can modify this format with the following named arguments: - -=over 4 - -=item B<-absolute> - -If true, produce an absolute URL, e.g. - - /path/to/script.cgi - -=item B<-relative> - -Produce a relative URL. This is useful if you want to reinvoke your -script with different parameters. For example: - - script.cgi - -=item B<-full> - -Produce the full URL, exactly as if called without any arguments. -This overrides the -relative and -absolute arguments. - -=item B<-path> (B<-path_info>) - -Append the additional path information to the URL. This can be -combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info> -is provided as a synonym. - -=item B<-query> (B<-query_string>) - -Append the query string to the URL. This can be combined with -B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided -as a synonym. - -=item B<-base> - -Generate just the protocol and net location, as in http://www.foo.com:8000 - -=back - -=head2 MIXING POST AND URL PARAMETERS - - $color = $query->url_param('color'); - -It is possible for a script to receive CGI parameters in the URL as -well as in the fill-out form by creating a form that POSTs to a URL -containing a query string (a "?" mark followed by arguments). The -B<param()> method will always return the contents of the POSTed -fill-out form, ignoring the URL's query string. To retrieve URL -parameters, call the B<url_param()> method. Use it in the same way as -B<param()>. The main difference is that it allows you to read the -parameters, but not set them. - - -Under no circumstances will the contents of the URL query string -interfere with similarly-named CGI parameters in POSTed forms. If you -try to mix a URL query string with a form submitted with the GET -method, the results will not be what you expect. - -=head1 CREATING STANDARD HTML ELEMENTS: - -CGI.pm defines general HTML shortcut methods for most, if not all of -the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single -HTML element and return a fragment of HTML text that you can then -print or manipulate as you like. Each shortcut returns a fragment of -HTML code that you can append to a string, save to a file, or, most -commonly, print out so that it displays in the browser window. - -This example shows how to use the HTML methods: - - $q = new CGI; - print $q->blockquote( - "Many years ago on the island of", - $q->a({href=>"http://crete.org/"},"Crete"), - "there lived a Minotaur named", - $q->strong("Fred."), - ), - $q->hr; - -This results in the following HTML code (extra newlines have been -added for readability): - - <blockquote> - Many years ago on the island of - <a href="http://crete.org/">Crete</a> there lived - a minotaur named <strong>Fred.</strong> - </blockquote> - <hr> - -If you find the syntax for calling the HTML shortcuts awkward, you can -import them into your namespace and dispense with the object syntax -completely (see the next section for more details): - - use CGI ':standard'; - print blockquote( - "Many years ago on the island of", - a({href=>"http://crete.org/"},"Crete"), - "there lived a minotaur named", - strong("Fred."), - ), - hr; - -=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS - -The HTML methods will accept zero, one or multiple arguments. If you -provide no arguments, you get a single tag: - - print hr; # <hr> - -If you provide one or more string arguments, they are concatenated -together with spaces and placed between opening and closing tags: - - print h1("Chapter","1"); # <h1>Chapter 1</h1>" - -If the first argument is an associative array reference, then the keys -and values of the associative array become the HTML tag's attributes: - - print a({-href=>'fred.html',-target=>'_new'}, - "Open a new frame"); - - <a href="fred.html",target="_new">Open a new frame</a> - -You may dispense with the dashes in front of the attribute names if -you prefer: - - print img {src=>'fred.gif',align=>'LEFT'}; - - <img align="LEFT" src="fred.gif"> - -Sometimes an HTML tag attribute has no argument. For example, ordered -lists can be marked as COMPACT. The syntax for this is an argument that -that points to an undef string: - - print ol({compact=>undef},li('one'),li('two'),li('three')); - -Prior to CGI.pm version 2.41, providing an empty ('') string as an -attribute argument was the same as providing undef. However, this has -changed in order to accommodate those who want to create tags of the form -<img alt="">. The difference is shown in these two pieces of code: - - CODE RESULT - img({alt=>undef}) <img alt> - img({alt=>''}) <img alt=""> - -=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS - -One of the cool features of the HTML shortcuts is that they are -distributive. If you give them an argument consisting of a -B<reference> to a list, the tag will be distributed across each -element of the list. For example, here's one way to make an ordered -list: - - print ul( - li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']) - ); - -This example will result in HTML output that looks like this: - - <ul> - <li type="disc">Sneezy</li> - <li type="disc">Doc</li> - <li type="disc">Sleepy</li> - <li type="disc">Happy</li> - </ul> - -This is extremely useful for creating tables. For example: - - print table({-border=>undef}, - caption('When Should You Eat Your Vegetables?'), - Tr({-align=>CENTER,-valign=>TOP}, - [ - th(['Vegetable', 'Breakfast','Lunch','Dinner']), - td(['Tomatoes' , 'no', 'yes', 'yes']), - td(['Broccoli' , 'no', 'no', 'yes']), - td(['Onions' , 'yes','yes', 'yes']) - ] - ) - ); - -=head2 HTML SHORTCUTS AND LIST INTERPOLATION - -Consider this bit of code: - - print blockquote(em('Hi'),'mom!')); - -It will ordinarily return the string that you probably expect, namely: - - <blockquote><em>Hi</em> mom!</blockquote> - -Note the space between the element "Hi" and the element "mom!". -CGI.pm puts the extra space there using array interpolation, which is -controlled by the magic $" variable. Sometimes this extra space is -not what you want, for example, when you are trying to align a series -of images. In this case, you can simply change the value of $" to an -empty string. - - { - local($") = ''; - print blockquote(em('Hi'),'mom!')); - } - -I suggest you put the code in a block as shown here. Otherwise the -change to $" will affect all subsequent code until you explicitly -reset it. - -=head2 NON-STANDARD HTML SHORTCUTS - -A few HTML tags don't follow the standard pattern for various -reasons. - -B<comment()> generates an HTML comment (<!-- comment -->). Call it -like - - print comment('here is my comment'); - -Because of conflicts with built-in Perl functions, the following functions -begin with initial caps: - - Select - Tr - Link - Delete - Accept - Sub - -In addition, start_html(), end_html(), start_form(), end_form(), -start_multipart_form() and all the fill-out form tags are special. -See their respective sections. - -=head2 AUTOESCAPING HTML - -By default, all HTML that is emitted by the form-generating functions -is passed through a function called escapeHTML(): - -=over 4 - -=item $escaped_string = escapeHTML("unescaped string"); - -Escape HTML formatting characters in a string. - -=back - -Provided that you have specified a character set of ISO-8859-1 (the -default), the standard HTML escaping rules will be used. The "<" -character becomes "<", ">" becomes ">", "&" becomes "&", and -the quote character becomes """. In addition, the hexadecimal -0x8b and 0x9b characters, which some browsers incorrectly interpret -as the left and right angle-bracket characters, are replaced by their -numeric character entities ("‹" and "›"). If you manually change -the charset, either by calling the charset() method explicitly or by -passing a -charset argument to header(), then B<all> characters will -be replaced by their numeric entities, since CGI.pm has no lookup -table for all the possible encodings. - -The automatic escaping does not apply to other shortcuts, such as -h1(). You should call escapeHTML() yourself on untrusted data in -order to protect your pages against nasty tricks that people may enter -into guestbooks, etc.. To change the character set, use charset(). -To turn autoescaping off completely, use autoEscape(0): - -=over 4 - -=item $charset = charset([$charset]); - -Get or set the current character set. - -=item $flag = autoEscape([$flag]); - -Get or set the value of the autoescape flag. - -=back - -=head2 PRETTY-PRINTING HTML - -By default, all the HTML produced by these functions comes out as one -long line without carriage returns or indentation. This is yuck, but -it does reduce the size of the documents by 10-20%. To get -pretty-printed output, please use L<CGI::Pretty>, a subclass -contributed by Brian Paulsen. - -=head1 CREATING FILL-OUT FORMS: - -I<General note> The various form-creating methods all return strings -to the caller, containing the tag or tags that will create the requested -form element. You are responsible for actually printing out these strings. -It's set up this way so that you can place formatting tags -around the form elements. - -I<Another note> The default values that you specify for the forms are only -used the B<first> time the script is invoked (when there is no query -string). On subsequent invocations of the script (when there is a query -string), the former values are used even if they are blank. - -If you want to change the value of a field from its previous value, you have two -choices: - -(1) call the param() method to set it. - -(2) use the -override (alias -force) parameter (a new feature in version 2.15). -This forces the default value to be used, regardless of the previous value: - - print $query->textfield(-name=>'field_name', - -default=>'starting value', - -override=>1, - -size=>50, - -maxlength=>80); - -I<Yet another note> By default, the text and labels of form elements are -escaped according to HTML rules. This means that you can safely use -"<CLICK ME>" as the label for a button. However, it also interferes with -your ability to incorporate special HTML character sequences, such as Á, -into your fields. If you wish to turn off automatic escaping, call the -autoEscape() method with a false value immediately after creating the CGI object: - - $query = new CGI; - $query->autoEscape(undef); - -I<A Lurking Trap!> Some of the form-element generating methods return -multiple tags. In a scalar context, the tags will be concatenated -together with spaces, or whatever is the current value of the $" -global. In a list context, the methods will return a list of -elements, allowing you to modify them if you wish. Usually you will -not notice this behavior, but beware of this: - - printf("%s\n",$query->end_form()) - -end_form() produces several tags, and only the first of them will be -printed because the format only expects one value. - -<p> - - -=head2 CREATING AN ISINDEX TAG - - print $query->isindex(-action=>$action); - - -or- - - print $query->isindex($action); - -Prints out an <isindex> tag. Not very exciting. The parameter --action specifies the URL of the script to process the query. The -default is to process the query with the current script. - -=head2 STARTING AND ENDING A FORM - - print $query->start_form(-method=>$method, - -action=>$action, - -enctype=>$encoding); - <... various form stuff ...> - print $query->endform; - - -or- - - print $query->start_form($method,$action,$encoding); - <... various form stuff ...> - print $query->endform; - -start_form() will return a <form> tag with the optional method, -action and form encoding that you specify. The defaults are: - - method: POST - action: this script - enctype: application/x-www-form-urlencoded - -endform() returns the closing </form> tag. - -Start_form()'s enctype argument tells the browser how to package the various -fields of the form before sending the form to the server. Two -values are possible: - -B<Note:> This method was previously named startform(), and startform() -is still recognized as an alias. - -=over 4 - -=item B<application/x-www-form-urlencoded> - -This is the older type of encoding used by all browsers prior to -Netscape 2.0. It is compatible with many CGI scripts and is -suitable for short fields containing text data. For your -convenience, CGI.pm stores the name of this encoding -type in B<&CGI::URL_ENCODED>. - -=item B<multipart/form-data> - -This is the newer type of encoding introduced by Netscape 2.0. -It is suitable for forms that contain very large fields or that -are intended for transferring binary data. Most importantly, -it enables the "file upload" feature of Netscape 2.0 forms. For -your convenience, CGI.pm stores the name of this encoding type -in B<&CGI::MULTIPART> - -Forms that use this type of encoding are not easily interpreted -by CGI scripts unless they use CGI.pm or another library designed -to handle them. - -=back - -For compatibility, the start_form() method uses the older form of -encoding by default. If you want to use the newer form of encoding -by default, you can call B<start_multipart_form()> instead of -B<start_form()>. - -JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided -for use with JavaScript. The -name parameter gives the -form a name so that it can be identified and manipulated by -JavaScript functions. -onSubmit should point to a JavaScript -function that will be executed just before the form is submitted to your -server. You can use this opportunity to check the contents of the form -for consistency and completeness. If you find something wrong, you -can put up an alert box or maybe fix things up yourself. You can -abort the submission by returning false from this function. - -Usually the bulk of JavaScript functions are defined in a <script> -block in the HTML header and -onSubmit points to one of these function -call. See start_html() for details. - -=head2 CREATING A TEXT FIELD - - print $query->textfield(-name=>'field_name', - -default=>'starting value', - -size=>50, - -maxlength=>80); - -or- - - print $query->textfield('field_name','starting value',50,80); - -textfield() will return a text input field. - -=over 4 - -=item B<Parameters> - -=item 1. - -The first parameter is the required name for the field (-name). - -=item 2. - -The optional second parameter is the default starting value for the field -contents (-default). - -=item 3. - -The optional third parameter is the size of the field in - characters (-size). - -=item 4. - -The optional fourth parameter is the maximum number of characters the - field will accept (-maxlength). - -=back - -As with all these methods, the field will be initialized with its -previous contents from earlier invocations of the script. -When the form is processed, the value of the text field can be -retrieved with: - - $value = $query->param('foo'); - -If you want to reset it from its initial value after the script has been -called once, you can do so like this: - - $query->param('foo',"I'm taking over this value!"); - -NEW AS OF VERSION 2.15: If you don't want the field to take on its previous -value, you can force its current value by using the -override (alias -force) -parameter: - - print $query->textfield(-name=>'field_name', - -default=>'starting value', - -override=>1, - -size=>50, - -maxlength=>80); - -JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>, -B<-onBlur>, B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> -parameters to register JavaScript event handlers. The onChange -handler will be called whenever the user changes the contents of the -text field. You can do text validation if you like. onFocus and -onBlur are called respectively when the insertion point moves into and -out of the text field. onSelect is called when the user changes the -portion of the text that is selected. - -=head2 CREATING A BIG TEXT FIELD - - print $query->textarea(-name=>'foo', - -default=>'starting value', - -rows=>10, - -columns=>50); - - -or - - print $query->textarea('foo','starting value',10,50); - -textarea() is just like textfield, but it allows you to specify -rows and columns for a multiline text entry box. You can provide -a starting value for the field, which can be long and contain -multiple lines. - -JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> , -B<-onMouseOver>, B<-onMouseOut>, and B<-onSelect> parameters are -recognized. See textfield(). - -=head2 CREATING A PASSWORD FIELD - - print $query->password_field(-name=>'secret', - -value=>'starting value', - -size=>50, - -maxlength=>80); - -or- - - print $query->password_field('secret','starting value',50,80); - -password_field() is identical to textfield(), except that its contents -will be starred out on the web page. - -JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>, -B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are -recognized. See textfield(). - -=head2 CREATING A FILE UPLOAD FIELD - - print $query->filefield(-name=>'uploaded_file', - -default=>'starting value', - -size=>50, - -maxlength=>80); - -or- - - print $query->filefield('uploaded_file','starting value',50,80); - -filefield() will return a file upload field for Netscape 2.0 browsers. -In order to take full advantage of this I<you must use the new -multipart encoding scheme> for the form. You can do this either -by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>, -or by calling the new method B<start_multipart_form()> instead of -vanilla B<start_form()>. - -=over 4 - -=item B<Parameters> - -=item 1. - -The first parameter is the required name for the field (-name). - -=item 2. - -The optional second parameter is the starting value for the field contents -to be used as the default file name (-default). - -For security reasons, browsers don't pay any attention to this field, -and so the starting value will always be blank. Worse, the field -loses its "sticky" behavior and forgets its previous contents. The -starting value field is called for in the HTML specification, however, -and possibly some browser will eventually provide support for it. - -=item 3. - -The optional third parameter is the size of the field in -characters (-size). - -=item 4. - -The optional fourth parameter is the maximum number of characters the -field will accept (-maxlength). - -=back - -When the form is processed, you can retrieve the entered filename -by calling param(): - - $filename = $query->param('uploaded_file'); - -Different browsers will return slightly different things for the -name. Some browsers return the filename only. Others return the full -path to the file, using the path conventions of the user's machine. -Regardless, the name returned is always the name of the file on the -I<user's> machine, and is unrelated to the name of the temporary file -that CGI.pm creates during upload spooling (see below). - -The filename returned is also a file handle. You can read the contents -of the file using standard Perl file reading calls: - - # Read a text file and print it out - while (<$filename>) { - print; - } - - # Copy a binary file to somewhere safe - open (OUTFILE,">>/usr/local/web/users/feedback"); - while ($bytesread=read($filename,$buffer,1024)) { - print OUTFILE $buffer; - } - -However, there are problems with the dual nature of the upload fields. -If you C<use strict>, then Perl will complain when you try to use a -string as a filehandle. You can get around this by placing the file -reading code in a block containing the C<no strict> pragma. More -seriously, it is possible for the remote user to type garbage into the -upload field, in which case what you get from param() is not a -filehandle at all, but a string. - -To be safe, use the I<upload()> function (new in version 2.47). When -called with the name of an upload field, I<upload()> returns a -filehandle, or undef if the parameter is not a valid filehandle. - - $fh = $query->upload('uploaded_file'); - while (<$fh>) { - print; - } - -In an list context, upload() will return an array of filehandles. -This makes it possible to create forms that use the same name for -multiple upload fields. - -This is the recommended idiom. - -When a file is uploaded the browser usually sends along some -information along with it in the format of headers. The information -usually includes the MIME content type. Future browsers may send -other information as well (such as modification date and size). To -retrieve this information, call uploadInfo(). It returns a reference to -an associative array containing all the document headers. - - $filename = $query->param('uploaded_file'); - $type = $query->uploadInfo($filename)->{'Content-Type'}; - unless ($type eq 'text/html') { - die "HTML FILES ONLY!"; - } - -If you are using a machine that recognizes "text" and "binary" data -modes, be sure to understand when and how to use them (see the Camel book). -Otherwise you may find that binary files are corrupted during file -uploads. - -There are occasionally problems involving parsing the uploaded file. -This usually happens when the user presses "Stop" before the upload is -finished. In this case, CGI.pm will return undef for the name of the -uploaded file and set I<cgi_error()> to the string "400 Bad request -(malformed multipart POST)". This error message is designed so that -you can incorporate it into a status code to be sent to the browser. -Example: - - $file = $query->upload('uploaded_file'); - if (!$file && $query->cgi_error) { - print $query->header(-status=>$query->cgi_error); - exit 0; - } - -You are free to create a custom HTML page to complain about the error, -if you wish. - -You can set up a callback that will be called whenever a file upload -is being read during the form processing. This is much like the -UPLOAD_HOOK facility available in Apache::Request, with the exception -that the first argument to the callback is an Apache::Upload object, -here it's the remote filename. - - $q = CGI->new(); - $q->upload_hook(\&hook,$data); - - sub hook - { - my ($filename, $buffer, $bytes_read, $data) = @_; - print "Read $bytes_read bytes of $filename\n"; - } - -If using the function-oriented interface, call the CGI::upload_hook() -method before calling param() or any other CGI functions: - - CGI::upload_hook(\&hook,$data); - -This method is not exported by default. You will have to import it -explicitly if you wish to use it without the CGI:: prefix. - -If you are using CGI.pm on a Windows platform and find that binary -files get slightly larger when uploaded but that text files remain the -same, then you have forgotten to activate binary mode on the output -filehandle. Be sure to call binmode() on any handle that you create -to write the uploaded file to disk. - -JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>, -B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are -recognized. See textfield() for details. - -=head2 CREATING A POPUP MENU - - print $query->popup_menu('menu_name', - ['eenie','meenie','minie'], - 'meenie'); - - -or- - - %labels = ('eenie'=>'your first choice', - 'meenie'=>'your second choice', - 'minie'=>'your third choice'); - %attributes = ('eenie'=>{'class'=>'class of first choice'}); - print $query->popup_menu('menu_name', - ['eenie','meenie','minie'], - 'meenie',\%labels,\%attributes); - - -or (named parameter style)- - - print $query->popup_menu(-name=>'menu_name', - -values=>['eenie','meenie','minie'], - -default=>'meenie', - -labels=>\%labels, - -attributes=>\%attributes); - -popup_menu() creates a menu. - -=over 4 - -=item 1. - -The required first argument is the menu's name (-name). - -=item 2. - -The required second argument (-values) is an array B<reference> -containing the list of menu items in the menu. You can pass the -method an anonymous array, as shown in the example, or a reference to -a named array, such as "\@foo". - -=item 3. - -The optional third parameter (-default) is the name of the default -menu choice. If not specified, the first item will be the default. -The values of the previous choice will be maintained across queries. - -=item 4. - -The optional fourth parameter (-labels) is provided for people who -want to use different values for the user-visible label inside the -popup menu and the value returned to your script. It's a pointer to an -associative array relating menu values to user-visible labels. If you -leave this parameter blank, the menu values will be displayed by -default. (You can also leave a label undefined if you want to). - -=item 5. - -The optional fifth parameter (-attributes) is provided to assign -any of the common HTML attributes to an individual menu item. It's -a pointer to an associative array relating menu values to another -associative array with the attribute's name as the key and the -attribute's value as the value. - -=back - -When the form is processed, the selected value of the popup menu can -be retrieved using: - - $popup_menu_value = $query->param('menu_name'); - -JAVASCRIPTING: popup_menu() recognizes the following event handlers: -B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>, and -B<-onBlur>. See the textfield() section for details on when these -handlers are called. - -=head2 CREATING AN OPTION GROUP - -Named parameter style - - print $query->popup_menu(-name=>'menu_name', - -values=>[qw/eenie meenie minie/, - $q->optgroup(-name=>'optgroup_name', - -values ['moe','catch'], - -attributes=>{'catch'=>{'class'=>'red'}}), - -labels=>{'eenie'=>'one', - 'meenie'=>'two', - 'minie'=>'three'}, - -default=>'meenie'); - - Old style - print $query->popup_menu('menu_name', - ['eenie','meenie','minie', - $q->optgroup('optgroup_name', ['moe', 'catch'], - {'catch'=>{'class'=>'red'}})],'meenie', - {'eenie'=>'one','meenie'=>'two','minie'=>'three'}); - -optgroup creates an option group within a popup menu. - -=over 4 - -=item 1. - -The required first argument (B<-name>) is the label attribute of the -optgroup and is B<not> inserted in the parameter list of the query. - -=item 2. - -The required second argument (B<-values>) is an array reference -containing the list of menu items in the menu. You can pass the -method an anonymous array, as shown in the example, or a reference -to a named array, such as \@foo. If you pass a HASH reference, -the keys will be used for the menu values, and the values will be -used for the menu labels (see -labels below). - -=item 3. - -The optional third parameter (B<-labels>) allows you to pass a reference -to an associative array containing user-visible labels for one or more -of the menu items. You can use this when you want the user to see one -menu string, but have the browser return your program a different one. -If you don't specify this, the value string will be used instead -("eenie", "meenie" and "minie" in this example). This is equivalent -to using a hash reference for the -values parameter. - -=item 4. - -An optional fourth parameter (B<-labeled>) can be set to a true value -and indicates that the values should be used as the label attribute -for each option element within the optgroup. - -=item 5. - -An optional fifth parameter (-novals) can be set to a true value and -indicates to suppress the val attribut in each option element within -the optgroup. - -See the discussion on optgroup at W3C -(http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP) -for details. - -=item 6. - -An optional sixth parameter (-attributes) is provided to assign -any of the common HTML attributes to an individual menu item. It's -a pointer to an associative array relating menu values to another -associative array with the attribute's name as the key and the -attribute's value as the value. - -=back - -=head2 CREATING A SCROLLING LIST - - print $query->scrolling_list('list_name', - ['eenie','meenie','minie','moe'], - ['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}}); - -or- - - print $query->scrolling_list('list_name', - ['eenie','meenie','minie','moe'], - ['eenie','moe'],5,'true', - \%labels,%attributes); - - -or- - - print $query->scrolling_list(-name=>'list_name', - -values=>['eenie','meenie','minie','moe'], - -default=>['eenie','moe'], - -size=>5, - -multiple=>'true', - -labels=>\%labels, - -attributes=>\%attributes); - -scrolling_list() creates a scrolling list. - -=over 4 - -=item B<Parameters:> - -=item 1. - -The first and second arguments are the list name (-name) and values -(-values). As in the popup menu, the second argument should be an -array reference. - -=item 2. - -The optional third argument (-default) can be either a reference to a -list containing the values to be selected by default, or can be a -single value to select. If this argument is missing or undefined, -then nothing is selected when the list first appears. In the named -parameter version, you can use the synonym "-defaults" for this -parameter. - -=item 3. - -The optional fourth argument is the size of the list (-size). - -=item 4. - -The optional fifth argument can be set to true to allow multiple -simultaneous selections (-multiple). Otherwise only one selection -will be allowed at a time. - -=item 5. - -The optional sixth argument is a pointer to an associative array -containing long user-visible labels for the list items (-labels). -If not provided, the values will be displayed. - -=item 6. - -The optional sixth parameter (-attributes) is provided to assign -any of the common HTML attributes to an individual menu item. It's -a pointer to an associative array relating menu values to another -associative array with the attribute's name as the key and the -attribute's value as the value. - -When this form is processed, all selected list items will be returned as -a list under the parameter name 'list_name'. The values of the -selected items can be retrieved with: - - @selected = $query->param('list_name'); - -=back - -JAVASCRIPTING: scrolling_list() recognizes the following event -handlers: B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut> -and B<-onBlur>. See textfield() for the description of when these -handlers are called. - -=head2 CREATING A GROUP OF RELATED CHECKBOXES - - print $query->checkbox_group(-name=>'group_name', - -values=>['eenie','meenie','minie','moe'], - -default=>['eenie','moe'], - -linebreak=>'true', - -labels=>\%labels, - -attributes=>\%attributes); - - print $query->checkbox_group('group_name', - ['eenie','meenie','minie','moe'], - ['eenie','moe'],'true',\%labels, - {'moe'=>{'class'=>'red'}}); - - HTML3-COMPATIBLE BROWSERS ONLY: - - print $query->checkbox_group(-name=>'group_name', - -values=>['eenie','meenie','minie','moe'], - -rows=2,-columns=>2); - - -checkbox_group() creates a list of checkboxes that are related -by the same name. - -=over 4 - -=item B<Parameters:> - -=item 1. - -The first and second arguments are the checkbox name and values, -respectively (-name and -values). As in the popup menu, the second -argument should be an array reference. These values are used for the -user-readable labels printed next to the checkboxes as well as for the -values passed to your script in the query string. - -=item 2. - -The optional third argument (-default) can be either a reference to a -list containing the values to be checked by default, or can be a -single value to checked. If this argument is missing or undefined, -then nothing is selected when the list first appears. - -=item 3. - -The optional fourth argument (-linebreak) can be set to true to place -line breaks between the checkboxes so that they appear as a vertical -list. Otherwise, they will be strung together on a horizontal line. - -=item 4. - -The optional fifth argument is a pointer to an associative array -relating the checkbox values to the user-visible labels that will -be printed next to them (-labels). If not provided, the values will -be used as the default. - -=item 5. - -B<HTML3-compatible browsers> (such as Netscape) can take advantage of -the optional parameters B<-rows>, and B<-columns>. These parameters -cause checkbox_group() to return an HTML3 compatible table containing -the checkbox group formatted with the specified number of rows and -columns. You can provide just the -columns parameter if you wish; -checkbox_group will calculate the correct number of rows for you. - -=item 6. - -The optional sixth parameter (-attributes) is provided to assign -any of the common HTML attributes to an individual menu item. It's -a pointer to an associative array relating menu values to another -associative array with the attribute's name as the key and the -attribute's value as the value. - -To include row and column headings in the returned table, you -can use the B<-rowheaders> and B<-colheaders> parameters. Both -of these accept a pointer to an array of headings to use. -The headings are just decorative. They don't reorganize the -interpretation of the checkboxes -- they're still a single named -unit. - -=back - -When the form is processed, all checked boxes will be returned as -a list under the parameter name 'group_name'. The values of the -"on" checkboxes can be retrieved with: - - @turned_on = $query->param('group_name'); - -The value returned by checkbox_group() is actually an array of button -elements. You can capture them and use them within tables, lists, -or in other creative ways: - - @h = $query->checkbox_group(-name=>'group_name',-values=>\@values); - &use_in_creative_way(@h); - -JAVASCRIPTING: checkbox_group() recognizes the B<-onClick> -parameter. This specifies a JavaScript code fragment or -function call to be executed every time the user clicks on -any of the buttons in the group. You can retrieve the identity -of the particular button clicked on using the "this" variable. - -=head2 CREATING A STANDALONE CHECKBOX - - print $query->checkbox(-name=>'checkbox_name', - -checked=>1, - -value=>'ON', - -label=>'CLICK ME'); - - -or- - - print $query->checkbox('checkbox_name','checked','ON','CLICK ME'); - -checkbox() is used to create an isolated checkbox that isn't logically -related to any others. - -=over 4 - -=item B<Parameters:> - -=item 1. - -The first parameter is the required name for the checkbox (-name). It -will also be used for the user-readable label printed next to the -checkbox. - -=item 2. - -The optional second parameter (-checked) specifies that the checkbox -is turned on by default. Synonyms are -selected and -on. - -=item 3. - -The optional third parameter (-value) specifies the value of the -checkbox when it is checked. If not provided, the word "on" is -assumed. - -=item 4. - -The optional fourth parameter (-label) is the user-readable label to -be attached to the checkbox. If not provided, the checkbox name is -used. - -=back - -The value of the checkbox can be retrieved using: - - $turned_on = $query->param('checkbox_name'); - -JAVASCRIPTING: checkbox() recognizes the B<-onClick> -parameter. See checkbox_group() for further details. - -=head2 CREATING A RADIO BUTTON GROUP - - print $query->radio_group(-name=>'group_name', - -values=>['eenie','meenie','minie'], - -default=>'meenie', - -linebreak=>'true', - -labels=>\%labels, - -attributes=>\%attributes); - - -or- - - print $query->radio_group('group_name',['eenie','meenie','minie'], - 'meenie','true',\%labels,\%attributes); - - - HTML3-COMPATIBLE BROWSERS ONLY: - - print $query->radio_group(-name=>'group_name', - -values=>['eenie','meenie','minie','moe'], - -rows=2,-columns=>2); - -radio_group() creates a set of logically-related radio buttons -(turning one member of the group on turns the others off) - -=over 4 - -=item B<Parameters:> - -=item 1. - -The first argument is the name of the group and is required (-name). - -=item 2. - -The second argument (-values) is the list of values for the radio -buttons. The values and the labels that appear on the page are -identical. Pass an array I<reference> in the second argument, either -using an anonymous array, as shown, or by referencing a named array as -in "\@foo". - -=item 3. - -The optional third parameter (-default) is the name of the default -button to turn on. If not specified, the first item will be the -default. You can provide a nonexistent button name, such as "-" to -start up with no buttons selected. - -=item 4. - -The optional fourth parameter (-linebreak) can be set to 'true' to put -line breaks between the buttons, creating a vertical list. - -=item 5. - -The optional fifth parameter (-labels) is a pointer to an associative -array relating the radio button values to user-visible labels to be -used in the display. If not provided, the values themselves are -displayed. - -=item 6. - -B<HTML3-compatible browsers> (such as Netscape) can take advantage -of the optional -parameters B<-rows>, and B<-columns>. These parameters cause -radio_group() to return an HTML3 compatible table containing -the radio group formatted with the specified number of rows -and columns. You can provide just the -columns parameter if you -wish; radio_group will calculate the correct number of rows -for you. - -=item 6. - -The optional sixth parameter (-attributes) is provided to assign -any of the common HTML attributes to an individual menu item. It's -a pointer to an associative array relating menu values to another -associative array with the attribute's name as the key and the -attribute's value as the value. - -To include row and column headings in the returned table, you -can use the B<-rowheader> and B<-colheader> parameters. Both -of these accept a pointer to an array of headings to use. -The headings are just decorative. They don't reorganize the -interpretation of the radio buttons -- they're still a single named -unit. - -=back - -When the form is processed, the selected radio button can -be retrieved using: - - $which_radio_button = $query->param('group_name'); - -The value returned by radio_group() is actually an array of button -elements. You can capture them and use them within tables, lists, -or in other creative ways: - - @h = $query->radio_group(-name=>'group_name',-values=>\@values); - &use_in_creative_way(@h); - -=head2 CREATING A SUBMIT BUTTON - - print $query->submit(-name=>'button_name', - -value=>'value'); - - -or- - - print $query->submit('button_name','value'); - -submit() will create the query submission button. Every form -should have one of these. - -=over 4 - -=item B<Parameters:> - -=item 1. - -The first argument (-name) is optional. You can give the button a -name if you have several submission buttons in your form and you want -to distinguish between them. - -=item 2. - -The second argument (-value) is also optional. This gives the button -a value that will be passed to your script in the query string. The -name will also be used as the user-visible label. - -=item 3. - -You can use -label as an alias for -value. I always get confused -about which of -name and -value changes the user-visible label on the -button. - -=back - -You can figure out which button was pressed by using different -values for each one: - - $which_one = $query->param('button_name'); - -JAVASCRIPTING: radio_group() recognizes the B<-onClick> -parameter. See checkbox_group() for further details. - -=head2 CREATING A RESET BUTTON - - print $query->reset - -reset() creates the "reset" button. Note that it restores the -form to its value from the last time the script was called, -NOT necessarily to the defaults. - -Note that this conflicts with the Perl reset() built-in. Use -CORE::reset() to get the original reset function. - -=head2 CREATING A DEFAULT BUTTON - - print $query->defaults('button_label') - -defaults() creates a button that, when invoked, will cause the -form to be completely reset to its defaults, wiping out all the -changes the user ever made. - -=head2 CREATING A HIDDEN FIELD - - print $query->hidden(-name=>'hidden_name', - -default=>['value1','value2'...]); - - -or- - - print $query->hidden('hidden_name','value1','value2'...); - -hidden() produces a text field that can't be seen by the user. It -is useful for passing state variable information from one invocation -of the script to the next. - -=over 4 - -=item B<Parameters:> - -=item 1. - -The first argument is required and specifies the name of this -field (-name). - -=item 2. - -The second argument is also required and specifies its value -(-default). In the named parameter style of calling, you can provide -a single value here or a reference to a whole list - -=back - -Fetch the value of a hidden field this way: - - $hidden_value = $query->param('hidden_name'); - -Note, that just like all the other form elements, the value of a -hidden field is "sticky". If you want to replace a hidden field with -some other values after the script has been called once you'll have to -do it manually: - - $query->param('hidden_name','new','values','here'); - -=head2 CREATING A CLICKABLE IMAGE BUTTON - - print $query->image_button(-name=>'button_name', - -src=>'/source/URL', - -align=>'MIDDLE'); - - -or- - - print $query->image_button('button_name','/source/URL','MIDDLE'); - -image_button() produces a clickable image. When it's clicked on the -position of the click is returned to your script as "button_name.x" -and "button_name.y", where "button_name" is the name you've assigned -to it. - -JAVASCRIPTING: image_button() recognizes the B<-onClick> -parameter. See checkbox_group() for further details. - -=over 4 - -=item B<Parameters:> - -=item 1. - -The first argument (-name) is required and specifies the name of this -field. - -=item 2. - -The second argument (-src) is also required and specifies the URL - -=item 3. -The third option (-align, optional) is an alignment type, and may be -TOP, BOTTOM or MIDDLE - -=back - -Fetch the value of the button this way: - $x = $query->param('button_name.x'); - $y = $query->param('button_name.y'); - -=head2 CREATING A JAVASCRIPT ACTION BUTTON - - print $query->button(-name=>'button_name', - -value=>'user visible label', - -onClick=>"do_something()"); - - -or- - - print $query->button('button_name',"do_something()"); - -button() produces a button that is compatible with Netscape 2.0's -JavaScript. When it's pressed the fragment of JavaScript code -pointed to by the B<-onClick> parameter will be executed. On -non-Netscape browsers this form element will probably not even -display. - -=head1 HTTP COOKIES - -Netscape browsers versions 1.1 and higher, and all versions of -Internet Explorer, support a so-called "cookie" designed to help -maintain state within a browser session. CGI.pm has several methods -that support cookies. - -A cookie is a name=value pair much like the named parameters in a CGI -query string. CGI scripts create one or more cookies and send -them to the browser in the HTTP header. The browser maintains a list -of cookies that belong to a particular Web server, and returns them -to the CGI script during subsequent interactions. - -In addition to the required name=value pair, each cookie has several -optional attributes: - -=over 4 - -=item 1. an expiration time - -This is a time/date string (in a special GMT format) that indicates -when a cookie expires. The cookie will be saved and returned to your -script until this expiration date is reached if the user exits -the browser and restarts it. If an expiration date isn't specified, the cookie -will remain active until the user quits the browser. - -=item 2. a domain - -This is a partial or complete domain name for which the cookie is -valid. The browser will return the cookie to any host that matches -the partial domain name. For example, if you specify a domain name -of ".capricorn.com", then the browser will return the cookie to -Web servers running on any of the machines "www.capricorn.com", -"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names -must contain at least two periods to prevent attempts to match -on top level domains like ".edu". If no domain is specified, then -the browser will only return the cookie to servers on the host the -cookie originated from. - -=item 3. a path - -If you provide a cookie path attribute, the browser will check it -against your script's URL before returning the cookie. For example, -if you specify the path "/cgi-bin", then the cookie will be returned -to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", -and "/cgi-bin/customer_service/complain.pl", but not to the script -"/cgi-private/site_admin.pl". By default, path is set to "/", which -causes the cookie to be sent to any CGI script on your site. - -=item 4. a "secure" flag - -If the "secure" attribute is set, the cookie will only be sent to your -script if the CGI request is occurring on a secure channel, such as SSL. - -=back - -The interface to HTTP cookies is the B<cookie()> method: - - $cookie = $query->cookie(-name=>'sessionID', - -value=>'xyzzy', - -expires=>'+1h', - -path=>'/cgi-bin/database', - -domain=>'.capricorn.org', - -secure=>1); - print $query->header(-cookie=>$cookie); - -B<cookie()> creates a new cookie. Its parameters include: - -=over 4 - -=item B<-name> - -The name of the cookie (required). This can be any string at all. -Although browsers limit their cookie names to non-whitespace -alphanumeric characters, CGI.pm removes this restriction by escaping -and unescaping cookies behind the scenes. - -=item B<-value> - -The value of the cookie. This can be any scalar value, -array reference, or even associative array reference. For example, -you can store an entire associative array into a cookie this way: - - $cookie=$query->cookie(-name=>'family information', - -value=>\%childrens_ages); - -=item B<-path> - -The optional partial path for which this cookie will be valid, as described -above. - -=item B<-domain> - -The optional partial domain for which this cookie will be valid, as described -above. - -=item B<-expires> - -The optional expiration date for this cookie. The format is as described -in the section on the B<header()> method: - - "+1h" one hour from now - -=item B<-secure> - -If set to true, this cookie will only be used within a secure -SSL session. - -=back - -The cookie created by cookie() must be incorporated into the HTTP -header within the string returned by the header() method: - - print $query->header(-cookie=>$my_cookie); - -To create multiple cookies, give header() an array reference: - - $cookie1 = $query->cookie(-name=>'riddle_name', - -value=>"The Sphynx's Question"); - $cookie2 = $query->cookie(-name=>'answers', - -value=>\%answers); - print $query->header(-cookie=>[$cookie1,$cookie2]); - -To retrieve a cookie, request it by name by calling cookie() method -without the B<-value> parameter: - - use CGI; - $query = new CGI; - $riddle = $query->cookie('riddle_name'); - %answers = $query->cookie('answers'); - -Cookies created with a single scalar value, such as the "riddle_name" -cookie, will be returned in that form. Cookies with array and hash -values can also be retrieved. - -The cookie and CGI namespaces are separate. If you have a parameter -named 'answers' and a cookie named 'answers', the values retrieved by -param() and cookie() are independent of each other. However, it's -simple to turn a CGI parameter into a cookie, and vice-versa: - - # turn a CGI parameter into a cookie - $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]); - # vice-versa - $q->param(-name=>'answers',-value=>[$q->cookie('answers')]); - -See the B<cookie.cgi> example script for some ideas on how to use -cookies effectively. - -=head1 WORKING WITH FRAMES - -It's possible for CGI.pm scripts to write into several browser panels -and windows using the HTML 4 frame mechanism. There are three -techniques for defining new frames programmatically: - -=over 4 - -=item 1. Create a <Frameset> document - -After writing out the HTTP header, instead of creating a standard -HTML document using the start_html() call, create a <frameset> -document that defines the frames on the page. Specify your script(s) -(with appropriate parameters) as the SRC for each of the frames. - -There is no specific support for creating <frameset> sections -in CGI.pm, but the HTML is very simple to write. See the frame -documentation in Netscape's home pages for details - - http://home.netscape.com/assist/net_sites/frames.html - -=item 2. Specify the destination for the document in the HTTP header - -You may provide a B<-target> parameter to the header() method: - - print $q->header(-target=>'ResultsWindow'); - -This will tell the browser to load the output of your script into the -frame named "ResultsWindow". If a frame of that name doesn't already -exist, the browser will pop up a new window and load your script's -document into that. There are a number of magic names that you can -use for targets. See the frame documents on Netscape's home pages for -details. - -=item 3. Specify the destination for the document in the <form> tag - -You can specify the frame to load in the FORM tag itself. With -CGI.pm it looks like this: - - print $q->start_form(-target=>'ResultsWindow'); - -When your script is reinvoked by the form, its output will be loaded -into the frame named "ResultsWindow". If one doesn't already exist -a new window will be created. - -=back - -The script "frameset.cgi" in the examples directory shows one way to -create pages in which the fill-out form and the response live in -side-by-side frames. - -=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS - -CGI.pm has limited support for HTML3's cascading style sheets (css). -To incorporate a stylesheet into your document, pass the -start_html() method a B<-style> parameter. The value of this -parameter may be a scalar, in which case it is treated as the source -URL for the stylesheet, or it may be a hash reference. In the latter -case you should provide the hash with one or more of B<-src> or -B<-code>. B<-src> points to a URL where an externally-defined -stylesheet can be found. B<-code> points to a scalar value to be -incorporated into a <style> section. Style definitions in B<-code> -override similarly-named ones in B<-src>, hence the name "cascading." - -You may also specify the type of the stylesheet by adding the optional -B<-type> parameter to the hash pointed to by B<-style>. If not -specified, the style defaults to 'text/css'. - -To refer to a style within the body of your document, add the -B<-class> parameter to any HTML element: - - print h1({-class=>'Fancy'},'Welcome to the Party'); - -Or define styles on the fly with the B<-style> parameter: - - print h1({-style=>'Color: red;'},'Welcome to Hell'); - -You may also use the new B<span()> element to apply a style to a -section of text: - - print span({-style=>'Color: red;'}, - h1('Welcome to Hell'), - "Where did that handbasket get to?" - ); - -Note that you must import the ":html3" definitions to have the -B<span()> method available. Here's a quick and dirty example of using -CSS's. See the CSS specification at -http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information. - - use CGI qw/:standard :html3/; - - #here's a stylesheet incorporated directly into the page - $newStyle=<<END; - <!-- - P.Tip { - margin-right: 50pt; - margin-left: 50pt; - color: red; - } - P.Alert { - font-size: 30pt; - font-family: sans-serif; - color: red; - } - --> - END - print header(); - print start_html( -title=>'CGI with Style', - -style=>{-src=>'http://www.capricorn.com/style/st1.css', - -code=>$newStyle} - ); - print h1('CGI with Style'), - p({-class=>'Tip'}, - "Better read the cascading style sheet spec before playing with this!"), - span({-style=>'color: magenta'}, - "Look Mom, no hands!", - p(), - "Whooo wee!" - ); - print end_html; - -Pass an array reference to B<-code> or B<-src> in order to incorporate -multiple stylesheets into your document. - -Should you wish to incorporate a verbatim stylesheet that includes -arbitrary formatting in the header, you may pass a -verbatim tag to -the -style hash, as follows: - -print $q->start_html (-STYLE => {-verbatim => '@import -url("/server-common/css/'.$cssFile.'");', - -src => '/server-common/css/core.css'}); -</blockquote></pre> - - -This will generate an HTML header that contains this: - - <link rel="stylesheet" type="text/css" href="/server-common/css/core.css"> - <style type="text/css"> - @import url("/server-common/css/main.css"); - </style> - -Any additional arguments passed in the -style value will be -incorporated into the <link> tag. For example: - - start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'], - -media => 'all'}); - -This will give: - - <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/> - <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/> - -<p> - -To make more complicated <link> tags, use the Link() function -and pass it to start_html() in the -head argument, as in: - - @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}), - Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'})); - print start_html({-head=>\@h}) - -=head1 DEBUGGING - -If you are running the script from the command line or in the perl -debugger, you can pass the script a list of keywords or -parameter=value pairs on the command line or from standard input (you -don't have to worry about tricking your script into reading from -environment variables). You can pass keywords like this: - - your_script.pl keyword1 keyword2 keyword3 - -or this: - - your_script.pl keyword1+keyword2+keyword3 - -or this: - - your_script.pl name1=value1 name2=value2 - -or this: - - your_script.pl name1=value1&name2=value2 - -To turn off this feature, use the -no_debug pragma. - -To test the POST method, you may enable full debugging with the -debug -pragma. This will allow you to feed newline-delimited name=value -pairs to the script on standard input. - -When debugging, you can use quotes and backslashes to escape -characters in the familiar shell manner, letting you place -spaces and other funny characters in your parameter=value -pairs: - - your_script.pl "name1='I am a long value'" "name2=two\ words" - -Finally, you can set the path info for the script by prefixing the first -name/value parameter with the path followed by a question mark (?): - - your_script.pl /your/path/here?name1=value1&name2=value2 - -=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS - -The Dump() method produces a string consisting of all the query's -name/value pairs formatted nicely as a nested list. This is useful -for debugging purposes: - - print $query->Dump - - -Produces something that looks like: - - <ul> - <li>name1 - <ul> - <li>value1 - <li>value2 - </ul> - <li>name2 - <ul> - <li>value1 - </ul> - </ul> - -As a shortcut, you can interpolate the entire CGI object into a string -and it will be replaced with the a nice HTML dump shown above: - - $query=new CGI; - print "<h2>Current Values</h2> $query\n"; - -=head1 FETCHING ENVIRONMENT VARIABLES - -Some of the more useful environment variables can be fetched -through this interface. The methods are as follows: - -=over 4 - -=item B<Accept()> - -Return a list of MIME types that the remote browser accepts. If you -give this method a single argument corresponding to a MIME type, as in -$query->Accept('text/html'), it will return a floating point value -corresponding to the browser's preference for this type from 0.0 -(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept -list are handled correctly. - -Note that the capitalization changed between version 2.43 and 2.44 in -order to avoid conflict with Perl's accept() function. - -=item B<raw_cookie()> - -Returns the HTTP_COOKIE variable, an HTTP extension implemented by -Netscape browsers version 1.1 and higher, and all versions of Internet -Explorer. Cookies have a special format, and this method call just -returns the raw form (?cookie dough). See cookie() for ways of -setting and retrieving cooked cookies. - -Called with no parameters, raw_cookie() returns the packed cookie -structure. You can separate it into individual cookies by splitting -on the character sequence "; ". Called with the name of a cookie, -retrieves the B<unescaped> form of the cookie. You can use the -regular cookie() method to get the names, or use the raw_fetch() -method from the CGI::Cookie module. - -=item B<user_agent()> - -Returns the HTTP_USER_AGENT variable. If you give -this method a single argument, it will attempt to -pattern match on it, allowing you to do something -like $query->user_agent(netscape); - -=item B<path_info()> - -Returns additional path information from the script URL. -E.G. fetching /cgi-bin/your_script/additional/stuff will result in -$query->path_info() returning "/additional/stuff". - -NOTE: The Microsoft Internet Information Server -is broken with respect to additional path information. If -you use the Perl DLL library, the IIS server will attempt to -execute the additional path information as a Perl script. -If you use the ordinary file associations mapping, the -path information will be present in the environment, -but incorrect. The best thing to do is to avoid using additional -path information in CGI scripts destined for use with IIS. - -=item B<path_translated()> - -As per path_info() but returns the additional -path information translated into a physical path, e.g. -"/usr/local/etc/httpd/htdocs/additional/stuff". - -The Microsoft IIS is broken with respect to the translated -path as well. - -=item B<remote_host()> - -Returns either the remote host name or IP address. -if the former is unavailable. - -=item B<script_name()> -Return the script name as a partial URL, for self-refering -scripts. - -=item B<referer()> - -Return the URL of the page the browser was viewing -prior to fetching your script. Not available for all -browsers. - -=item B<auth_type ()> - -Return the authorization/verification method in use for this -script, if any. - -=item B<server_name ()> - -Returns the name of the server, usually the machine's host -name. - -=item B<virtual_host ()> - -When using virtual hosts, returns the name of the host that -the browser attempted to contact - -=item B<server_port ()> - -Return the port that the server is listening on. - -=item B<virtual_port ()> - -Like server_port() except that it takes virtual hosts into account. -Use this when running with virtual hosts. - -=item B<server_software ()> - -Returns the server software and version number. - -=item B<remote_user ()> - -Return the authorization/verification name used for user -verification, if this script is protected. - -=item B<user_name ()> - -Attempt to obtain the remote user's name, using a variety of different -techniques. This only works with older browsers such as Mosaic. -Newer browsers do not report the user name for privacy reasons! - -=item B<request_method()> - -Returns the method used to access your script, usually -one of 'POST', 'GET' or 'HEAD'. - -=item B<content_type()> - -Returns the content_type of data submitted in a POST, generally -multipart/form-data or application/x-www-form-urlencoded - -=item B<http()> - -Called with no arguments returns the list of HTTP environment -variables, including such things as HTTP_USER_AGENT, -HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the -like-named HTTP header fields in the request. Called with the name of -an HTTP header field, returns its value. Capitalization and the use -of hyphens versus underscores are not significant. - -For example, all three of these examples are equivalent: - - $requested_language = $q->http('Accept-language'); - $requested_language = $q->http('Accept_language'); - $requested_language = $q->http('HTTP_ACCEPT_LANGUAGE'); - -=item B<https()> - -The same as I<http()>, but operates on the HTTPS environment variables -present when the SSL protocol is in effect. Can be used to determine -whether SSL is turned on. - -=back - -=head1 USING NPH SCRIPTS - -NPH, or "no-parsed-header", scripts bypass the server completely by -sending the complete HTTP header directly to the browser. This has -slight performance benefits, but is of most use for taking advantage -of HTTP extensions that are not directly supported by your server, -such as server push and PICS headers. - -Servers use a variety of conventions for designating CGI scripts as -NPH. Many Unix servers look at the beginning of the script's name for -the prefix "nph-". The Macintosh WebSTAR server and Microsoft's -Internet Information Server, in contrast, try to decide whether a -program is an NPH script by examining the first line of script output. - - -CGI.pm supports NPH scripts with a special NPH mode. When in this -mode, CGI.pm will output the necessary extra header information when -the header() and redirect() methods are -called. - -The Microsoft Internet Information Server requires NPH mode. As of -version 2.30, CGI.pm will automatically detect when the script is -running under IIS and put itself into this mode. You do not need to -do this manually, although it won't hurt anything if you do. However, -note that if you have applied Service Pack 6, much of the -functionality of NPH scripts, including the ability to redirect while -setting a cookie, b<do not work at all> on IIS without a special patch -from Microsoft. See -http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP: -Non-Parsed Headers Stripped From CGI Applications That Have nph- -Prefix in Name. - -=over 4 - -=item In the B<use> statement - -Simply add the "-nph" pragmato the list of symbols to be imported into -your script: - - use CGI qw(:standard -nph) - -=item By calling the B<nph()> method: - -Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program. - - CGI->nph(1) - -=item By using B<-nph> parameters - -in the B<header()> and B<redirect()> statements: - - print $q->header(-nph=>1); - -=back - -=head1 Server Push - -CGI.pm provides four simple functions for producing multipart -documents of the type needed to implement server push. These -functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To -import these into your namespace, you must import the ":push" set. -You are also advised to put the script into NPH mode and to set $| to -1 to avoid buffering problems. - -Here is a simple script that demonstrates server push: - - #!/usr/local/bin/perl - use CGI qw/:push -nph/; - $| = 1; - print multipart_init(-boundary=>'----here we go!'); - foreach (0 .. 4) { - print multipart_start(-type=>'text/plain'), - "The current time is ",scalar(localtime),"\n"; - if ($_ < 4) { - print multipart_end; - } else { - print multipart_final; - } - sleep 1; - } - -This script initializes server push by calling B<multipart_init()>. -It then enters a loop in which it begins a new multipart section by -calling B<multipart_start()>, prints the current local time, -and ends a multipart section with B<multipart_end()>. It then sleeps -a second, and begins again. On the final iteration, it ends the -multipart section with B<multipart_final()> rather than with -B<multipart_end()>. - -=over 4 - -=item multipart_init() - - multipart_init(-boundary=>$boundary); - -Initialize the multipart system. The -boundary argument specifies -what MIME boundary string to use to separate parts of the document. -If not provided, CGI.pm chooses a reasonable boundary for you. - -=item multipart_start() - - multipart_start(-type=>$type) - -Start a new part of the multipart document using the specified MIME -type. If not specified, text/html is assumed. - -=item multipart_end() - - multipart_end() - -End a part. You must remember to call multipart_end() once for each -multipart_start(), except at the end of the last part of the multipart -document when multipart_final() should be called instead of multipart_end(). - -=item multipart_final() - - multipart_final() - -End all parts. You should call multipart_final() rather than -multipart_end() at the end of the last part of the multipart document. - -=back - -Users interested in server push applications should also have a look -at the CGI::Push module. - -Only Netscape Navigator supports server push. Internet Explorer -browsers do not. - -=head1 Avoiding Denial of Service Attacks - -A potential problem with CGI.pm is that, by default, it attempts to -process form POSTings no matter how large they are. A wily hacker -could attack your site by sending a CGI script a huge POST of many -megabytes. CGI.pm will attempt to read the entire POST into a -variable, growing hugely in size until it runs out of memory. While -the script attempts to allocate the memory the system may slow down -dramatically. This is a form of denial of service attack. - -Another possible attack is for the remote user to force CGI.pm to -accept a huge file upload. CGI.pm will accept the upload and store it -in a temporary directory even if your script doesn't expect to receive -an uploaded file. CGI.pm will delete the file automatically when it -terminates, but in the meantime the remote user may have filled up the -server's disk space, causing problems for other programs. - -The best way to avoid denial of service attacks is to limit the amount -of memory, CPU time and disk space that CGI scripts can use. Some Web -servers come with built-in facilities to accomplish this. In other -cases, you can use the shell I<limit> or I<ulimit> -commands to put ceilings on CGI resource usage. - - -CGI.pm also has some simple built-in protections against denial of -service attacks, but you must activate them before you can use them. -These take the form of two global variables in the CGI name space: - -=over 4 - -=item B<$CGI::POST_MAX> - -If set to a non-negative integer, this variable puts a ceiling -on the size of POSTings, in bytes. If CGI.pm detects a POST -that is greater than the ceiling, it will immediately exit with an error -message. This value will affect both ordinary POSTs and -multipart POSTs, meaning that it limits the maximum size of file -uploads as well. You should set this to a reasonably high -value, such as 1 megabyte. - -=item B<$CGI::DISABLE_UPLOADS> - -If set to a non-zero value, this will disable file uploads -completely. Other fill-out form values will work as usual. - -=back - -You can use these variables in either of two ways. - -=over 4 - -=item B<1. On a script-by-script basis> - -Set the variable at the top of the script, right after the "use" statement: - - use CGI qw/:standard/; - use CGI::Carp 'fatalsToBrowser'; - $CGI::POST_MAX=1024 * 100; # max 100K posts - $CGI::DISABLE_UPLOADS = 1; # no uploads - -=item B<2. Globally for all scripts> - -Open up CGI.pm, find the definitions for $POST_MAX and -$DISABLE_UPLOADS, and set them to the desired values. You'll -find them towards the top of the file in a subroutine named -initialize_globals(). - -=back - -An attempt to send a POST larger than $POST_MAX bytes will cause -I<param()> to return an empty CGI parameter list. You can test for -this event by checking I<cgi_error()>, either after you create the CGI -object or, if you are using the function-oriented interface, call -<param()> for the first time. If the POST was intercepted, then -cgi_error() will return the message "413 POST too large". - -This error message is actually defined by the HTTP protocol, and is -designed to be returned to the browser as the CGI script's status - code. For example: - - $uploaded_file = param('upload'); - if (!$uploaded_file && cgi_error()) { - print header(-status=>cgi_error()); - exit 0; - } - -However it isn't clear that any browser currently knows what to do -with this status code. It might be better just to create an -HTML page that warns the user of the problem. - -=head1 COMPATIBILITY WITH CGI-LIB.PL - -To make it easier to port existing programs that use cgi-lib.pl the -compatibility routine "ReadParse" is provided. Porting is simple: - -OLD VERSION - require "cgi-lib.pl"; - &ReadParse; - print "The value of the antique is $in{antique}.\n"; - -NEW VERSION - use CGI; - CGI::ReadParse; - print "The value of the antique is $in{antique}.\n"; - -CGI.pm's ReadParse() routine creates a tied variable named %in, -which can be accessed to obtain the query variables. Like -ReadParse, you can also provide your own variable. Infrequently -used features of ReadParse, such as the creation of @in and $in -variables, are not supported. - -Once you use ReadParse, you can retrieve the query object itself -this way: - - $q = $in{CGI}; - print $q->textfield(-name=>'wow', - -value=>'does this really work?'); - -This allows you to start using the more interesting features -of CGI.pm without rewriting your old scripts from scratch. - -=head1 AUTHOR INFORMATION - -Copyright 1995-1998, Lincoln D. Stein. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -Address bug reports and comments to: lstein@cshl.org. When sending -bug reports, please provide the version of CGI.pm, the version of -Perl, the name and version of your Web server, and the name and -version of the operating system you are using. If the problem is even -remotely browser dependent, please provide information about the -affected browers as well. - -=head1 CREDITS - -Thanks very much to: - -=over 4 - -=item Matt Heffron (heffron@falstaff.css.beckman.com) - -=item James Taylor (james.taylor@srs.gov) - -=item Scott Anguish <sanguish@digifix.com> - -=item Mike Jewell (mlj3u@virginia.edu) - -=item Timothy Shimmin (tes@kbs.citri.edu.au) - -=item Joergen Haegg (jh@axis.se) - -=item Laurent Delfosse (delfosse@delfosse.com) - -=item Richard Resnick (applepi1@aol.com) - -=item Craig Bishop (csb@barwonwater.vic.gov.au) - -=item Tony Curtis (tc@vcpc.univie.ac.at) - -=item Tim Bunce (Tim.Bunce@ig.co.uk) - -=item Tom Christiansen (tchrist@convex.com) - -=item Andreas Koenig (k@franz.ww.TU-Berlin.DE) - -=item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au) - -=item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu) - -=item Stephen Dahmen (joyfire@inxpress.net) - -=item Ed Jordan (ed@fidalgo.net) - -=item David Alan Pisoni (david@cnation.com) - -=item Doug MacEachern (dougm@opengroup.org) - -=item Robin Houston (robin@oneworld.org) - -=item ...and many many more... - -for suggestions and bug fixes. - -=back - -=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT - - - #!/usr/local/bin/perl - - use CGI; - - $query = new CGI; - - print $query->header; - print $query->start_html("Example CGI.pm Form"); - print "<h1> Example CGI.pm Form</h1>\n"; - &print_prompt($query); - &do_work($query); - &print_tail; - print $query->end_html; - - sub print_prompt { - my($query) = @_; - - print $query->start_form; - print "<em>What's your name?</em><br>"; - print $query->textfield('name'); - print $query->checkbox('Not my real name'); - - print "<p><em>Where can you find English Sparrows?</em><br>"; - print $query->checkbox_group( - -name=>'Sparrow locations', - -values=>[England,France,Spain,Asia,Hoboken], - -linebreak=>'yes', - -defaults=>[England,Asia]); - - print "<p><em>How far can they fly?</em><br>", - $query->radio_group( - -name=>'how far', - -values=>['10 ft','1 mile','10 miles','real far'], - -default=>'1 mile'); - - print "<p><em>What's your favorite color?</em> "; - print $query->popup_menu(-name=>'Color', - -values=>['black','brown','red','yellow'], - -default=>'red'); - - print $query->hidden('Reference','Monty Python and the Holy Grail'); - - print "<p><em>What have you got there?</em><br>"; - print $query->scrolling_list( - -name=>'possessions', - -values=>['A Coconut','A Grail','An Icon', - 'A Sword','A Ticket'], - -size=>5, - -multiple=>'true'); - - print "<p><em>Any parting comments?</em><br>"; - print $query->textarea(-name=>'Comments', - -rows=>10, - -columns=>50); - - print "<p>",$query->reset; - print $query->submit('Action','Shout'); - print $query->submit('Action','Scream'); - print $query->endform; - print "<hr>\n"; - } - - sub do_work { - my($query) = @_; - my(@values,$key); - - print "<h2>Here are the current settings in this form</h2>"; - - foreach $key ($query->param) { - print "<strong>$key</strong> -> "; - @values = $query->param($key); - print join(", ",@values),"<br>\n"; - } - } - - sub print_tail { - print <<END; - <hr> - <address>Lincoln D. Stein</address><br> - <a href="/">Home Page</a> - END - } - -=head1 BUGS - -Please report them. - -=head1 SEE ALSO - -L<CGI::Carp>, L<CGI::Fast>, L<CGI::Pretty> - -=cut - diff --git a/lib/CGI/Apache.pm b/lib/CGI/Apache.pm deleted file mode 100644 index c711a48..0000000 --- a/lib/CGI/Apache.pm +++ /dev/null @@ -1,26 +0,0 @@ -use CGI; - -$VERSION = '1.00'; - -1; -__END__ - -=head1 NAME - -CGI::Apache - Backward compatibility module for CGI.pm - -=head1 SYNOPSIS - -Do not use this module. It is deprecated. - -=head1 ABSTRACT - -=head1 DESCRIPTION - -=head1 AUTHOR INFORMATION - -=head1 BUGS - -=head1 SEE ALSO - -=cut diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm deleted file mode 100644 index e25cd7f..0000000 --- a/lib/CGI/Carp.pm +++ /dev/null @@ -1,524 +0,0 @@ -package CGI::Carp; - -=head1 NAME - -B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log - -=head1 SYNOPSIS - - use CGI::Carp; - - croak "We're outta here!"; - confess "It was my fault: $!"; - carp "It was your fault!"; - warn "I'm confused"; - die "I'm dying.\n"; - - use CGI::Carp qw(cluck); - cluck "I wouldn't do that if I were you"; - - use CGI::Carp qw(fatalsToBrowser); - die "Fatal error messages are now sent to browser"; - -=head1 DESCRIPTION - -CGI scripts have a nasty habit of leaving warning messages in the error -logs that are neither time stamped nor fully identified. Tracking down -the script that caused the error is a pain. This fixes that. Replace -the usual - - use Carp; - -with - - use CGI::Carp - -And the standard warn(), die (), croak(), confess() and carp() calls -will automagically be replaced with functions that write out nicely -time-stamped messages to the HTTP server error log. - -For example: - - [Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3. - [Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied. - [Fri Nov 17 21:40:43 1995] test.pl: I'm dying. - -=head1 REDIRECTING ERROR MESSAGES - -By default, error messages are sent to STDERR. Most HTTPD servers -direct STDERR to the server's error log. Some applications may wish -to keep private error logs, distinct from the server's error log, or -they may wish to direct error messages to STDOUT so that the browser -will receive them. - -The C<carpout()> function is provided for this purpose. Since -carpout() is not exported by default, you must import it explicitly by -saying - - use CGI::Carp qw(carpout); - -The carpout() function requires one argument, which should be a -reference to an open filehandle for writing errors. It should be -called in a C<BEGIN> block at the top of the CGI application so that -compiler errors will be caught. Example: - - BEGIN { - use CGI::Carp qw(carpout); - open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or - die("Unable to open mycgi-log: $!\n"); - carpout(LOG); - } - -carpout() does not handle file locking on the log for you at this point. - -The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR. Some -servers, when dealing with CGI scripts, close their connection to the -browser when the script closes STDOUT and STDERR. CGI::Carp::SAVEERR is there to -prevent this from happening prematurely. - -You can pass filehandles to carpout() in a variety of ways. The "correct" -way according to Tom Christiansen is to pass a reference to a filehandle -GLOB: - - carpout(\*LOG); - -This looks weird to mere mortals however, so the following syntaxes are -accepted as well: - - carpout(LOG); - carpout(main::LOG); - carpout(main'LOG); - carpout(\LOG); - carpout(\'main::LOG'); - - ... and so on - -FileHandle and other objects work as well. - -Use of carpout() is not great for performance, so it is recommended -for debugging purposes or for moderate-use applications. A future -version of this module may delay redirecting STDERR until one of the -CGI::Carp methods is called to prevent the performance hit. - -=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW - -If you want to send fatal (die, confess) errors to the browser, ask to -import the special "fatalsToBrowser" subroutine: - - use CGI::Carp qw(fatalsToBrowser); - die "Bad error here"; - -Fatal errors will now be echoed to the browser as well as to the log. CGI::Carp -arranges to send a minimal HTTP header to the browser so that even errors that -occur in the early compile phase will be seen. -Nonfatal errors will still be directed to the log file only (unless redirected -with carpout). - -=head2 Changing the default message - -By default, the software error message is followed by a note to -contact the Webmaster by e-mail with the time and date of the error. -If this message is not to your liking, you can change it using the -set_message() routine. This is not imported by default; you should -import it on the use() line: - - use CGI::Carp qw(fatalsToBrowser set_message); - set_message("It's not a bug, it's a feature!"); - -You may also pass in a code reference in order to create a custom -error message. At run time, your code will be called with the text -of the error message that caused the script to die. Example: - - use CGI::Carp qw(fatalsToBrowser set_message); - BEGIN { - sub handle_errors { - my $msg = shift; - print "<h1>Oh gosh</h1>"; - print "<p>Got an error: $msg</p>"; - } - set_message(\&handle_errors); - } - -In order to correctly intercept compile-time errors, you should call -set_message() from within a BEGIN{} block. - -=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS - -It is now also possible to make non-fatal errors appear as HTML -comments embedded in the output of your program. To enable this -feature, export the new "warningsToBrowser" subroutine. Since sending -warnings to the browser before the HTTP headers have been sent would -cause an error, any warnings are stored in an internal buffer until -you call the warningsToBrowser() subroutine with a true argument: - - use CGI::Carp qw(fatalsToBrowser warningsToBrowser); - use CGI qw(:standard); - print header(); - warningsToBrowser(1); - -You may also give a false argument to warningsToBrowser() to prevent -warnings from being sent to the browser while you are printing some -content where HTML comments are not allowed: - - warningsToBrowser(0); # disable warnings - print "<script type=\"text/javascript\"><!--\n"; - print_some_javascript_code(); - print "//--></script>\n"; - warningsToBrowser(1); # re-enable warnings - -Note: In this respect warningsToBrowser() differs fundamentally from -fatalsToBrowser(), which you should never call yourself! - -=head1 OVERRIDING THE NAME OF THE PROGRAM - -CGI::Carp includes the name of the program that generated the error or -warning in the messages written to the log and the browser window. -Sometimes, Perl can get confused about what the actual name of the -executed program was. In these cases, you can override the program -name that CGI::Carp will use for all messages. - -The quick way to do that is to tell CGI::Carp the name of the program -in its use statement. You can do that by adding -"name=cgi_carp_log_name" to your "use" statement. For example: - - use CGI::Carp qw(name=cgi_carp_log_name); - -. If you want to change the program name partway through the program, -you can use the C<set_progname()> function instead. It is not -exported by default, you must import it explicitly by saying - - use CGI::Carp qw(set_progname); - -Once you've done that, you can change the logged name of the program -at any time by calling - - set_progname(new_program_name); - -You can set the program back to the default by calling - - set_progname(undef); - -Note that this override doesn't happen until after the program has -compiled, so any compile-time errors will still show up with the -non-overridden program name - -=head1 CHANGE LOG - -1.05 carpout() added and minor corrections by Marc Hedlund - <hedlund@best.com> on 11/26/95. - -1.06 fatalsToBrowser() no longer aborts for fatal errors within - eval() statements. - -1.08 set_message() added and carpout() expanded to allow for FileHandle - objects. - -1.09 set_message() now allows users to pass a code REFERENCE for - really custom error messages. croak and carp are now - exported by default. Thanks to Gunther Birznieks for the - patches. - -1.10 Patch from Chris Dean (ctdean@cogit.com) to allow - module to run correctly under mod_perl. - -1.11 Changed order of > and < escapes. - -1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning. - -1.13 Added cluck() to make the module orthogonal with Carp. - More mod_perl related fixes. - -1.20 Patch from Ilmari Karonen (perl@itz.pp.sci.fi): Added - warningsToBrowser(). Replaced <CODE> tags with <PRE> in - fatalsToBrowser() output. - -1.23 ineval() now checks both $^S and inspects the message for the "eval" pattern - (hack alert!) in order to accomodate various combinations of Perl and - mod_perl. - -1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support - for overriding program name. - -1.26 Replaced CORE::GLOBAL::die with the evil $SIG{__DIE__} because the - former isn't working in some people's hands. There is no such thing - as reliable exception handling in Perl. - -1.27 Replaced tell STDOUT with bytes=tell STDOUT. - -=head1 AUTHORS - -Copyright 1995-2002, Lincoln D. Stein. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -Address bug reports and comments to: lstein@cshl.org - -=head1 SEE ALSO - -Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form, -CGI::Response - if (defined($CGI::Carp::PROGNAME)) - { - $file = $CGI::Carp::PROGNAME; - } - -=cut - -require 5.000; -use Exporter; -#use Carp; -BEGIN { - require Carp; - *CORE::GLOBAL::die = \&CGI::Carp::die; -} - -use File::Spec; - -@ISA = qw(Exporter); -@EXPORT = qw(confess croak carp); -@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_progname cluck ^name= die); - -$main::SIG{__WARN__}=\&CGI::Carp::warn; - -$CGI::Carp::VERSION = '1.28'; -$CGI::Carp::CUSTOM_MSG = undef; - - -# fancy import routine detects and handles 'errorWrap' specially. -sub import { - my $pkg = shift; - my(%routines); - my(@name); - - if (@name=grep(/^name=/,@_)) - { - my($n) = (split(/=/,$name[0]))[1]; - set_progname($n); - @_=grep(!/^name=/,@_); - } - - grep($routines{$_}++,@_,@EXPORT); - $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'}; - $WARN++ if $routines{'warningsToBrowser'}; - my($oldlevel) = $Exporter::ExportLevel; - $Exporter::ExportLevel = 1; - Exporter::import($pkg,keys %routines); - $Exporter::ExportLevel = $oldlevel; - $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'}; -# $pkg->export('CORE::GLOBAL','die'); -} - -# These are the originals -sub realwarn { CORE::warn(@_); } -sub realdie { CORE::die(@_); } - -sub id { - my $level = shift; - my($pack,$file,$line,$sub) = caller($level); - my($dev,$dirs,$id) = File::Spec->splitpath($file); - return ($file,$line,$id); -} - -sub stamp { - my $time = scalar(localtime); - my $frame = 0; - my ($id,$pack,$file,$dev,$dirs); - if (defined($CGI::Carp::PROGNAME)) { - $id = $CGI::Carp::PROGNAME; - } else { - do { - $id = $file; - ($pack,$file) = caller($frame++); - } until !$file; - } - ($dev,$dirs,$id) = File::Spec->splitpath($id); - return "[$time] $id: "; -} - -sub set_progname { - $CGI::Carp::PROGNAME = shift; - return $CGI::Carp::PROGNAME; -} - - -sub warn { - my $message = shift; - my($file,$line,$id) = id(1); - $message .= " at $file line $line.\n" unless $message=~/\n$/; - _warn($message) if $WARN; - my $stamp = stamp; - $message=~s/^/$stamp/gm; - realwarn $message; -} - -sub _warn { - my $msg = shift; - if ($EMIT_WARNINGS) { - # We need to mangle the message a bit to make it a valid HTML - # comment. This is done by substituting similar-looking ISO - # 8859-1 characters for <, > and -. This is a hack. - $msg =~ tr/<>-/\253\273\255/; - chomp $msg; - print STDOUT "<!-- warning: $msg -->\n"; - } else { - push @WARNINGS, $msg; - } -} - - -# The mod_perl package Apache::Registry loads CGI programs by calling -# eval. These evals don't count when looking at the stack backtrace. -sub _longmess { - my $message = Carp::longmess(); - $message =~ s,eval[^\n]+(ModPerl|Apache)/Registry\w*\.pm.*,,s - if exists $ENV{MOD_PERL}; - return $message; -} - -sub ineval { - (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m -} - -sub die { - my ($arg,@rest) = @_; - realdie ($arg,@rest) if ineval(); - - if (!ref($arg)) { - $arg = join("", ($arg,@rest)); - my($file,$line,$id) = id(1); - $arg .= " at $file line $line." unless $arg=~/\n$/; - &fatalsToBrowser($arg) if $WRAP; - if (($arg =~ /\n$/) || !exists($ENV{MOD_PERL})) { - my $stamp = stamp; - $arg=~s/^/$stamp/gm; - } - if ($arg !~ /\n$/) { - $arg .= "\n"; - } - } - realdie $arg; -} - -sub set_message { - $CGI::Carp::CUSTOM_MSG = shift; - return $CGI::Carp::CUSTOM_MSG; -} - -sub confess { CGI::Carp::die Carp::longmess @_; } -sub croak { CGI::Carp::die Carp::shortmess @_; } -sub carp { CGI::Carp::warn Carp::shortmess @_; } -sub cluck { CGI::Carp::warn Carp::longmess @_; } - -# We have to be ready to accept a filehandle as a reference -# or a string. -sub carpout { - my($in) = @_; - my($no) = fileno(to_filehandle($in)); - realdie("Invalid filehandle $in\n") unless defined $no; - - open(SAVEERR, ">&STDERR"); - open(STDERR, ">&$no") or - ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); -} - -sub warningsToBrowser { - $EMIT_WARNINGS = @_ ? shift : 1; - _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS; -} - -# headers -sub fatalsToBrowser { - my($msg) = @_; - $msg=~s/&/&/g; - $msg=~s/>/>/g; - $msg=~s/</</g; - $msg=~s/\"/"/g; - my($wm) = $ENV{SERVER_ADMIN} ? - qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] : - "this site's webmaster"; - my ($outer_message) = <<END; -For help, please send mail to $wm, giving this error message -and the time and date of the error. -END - ; - my $mod_perl = exists $ENV{MOD_PERL}; - - if ($CUSTOM_MSG) { - if (ref($CUSTOM_MSG) eq 'CODE') { - print STDOUT "Content-type: text/html\n\n" - unless $mod_perl; - &$CUSTOM_MSG($msg); # nicer to perl 5.003 users - return; - } else { - $outer_message = $CUSTOM_MSG; - } - } - - my $mess = <<END; -<h1>Software error:</h1> -<pre>$msg</pre> -<p> -$outer_message -</p> -END - ; - - if ($mod_perl) { - require mod_perl; - if ($mod_perl::VERSION >= 1.99) { - $mod_perl = 2; - require Apache::RequestRec; - require Apache::RequestIO; - require Apache::RequestUtil; - require APR::Pool; - require ModPerl::Util; - require Apache::Response; - } - my $r = Apache->request; - # If bytes have already been sent, then - # we print the message out directly. - # Otherwise we make a custom error - # handler to produce the doc for us. - if ($r->bytes_sent) { - $r->print($mess); - $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit; - } else { - # MSIE won't display a custom 500 response unless it is >512 bytes! - if ($ENV{HTTP_USER_AGENT} =~ /MSIE/) { - $mess = "<!-- " . (' ' x 513) . " -->\n$mess"; - } - $r->custom_response(500,$mess); - } - } else { - my $bytes_written = eval{tell STDOUT}; - if (defined $bytes_written && $bytes_written > 0) { - print STDOUT $mess; - } - else { - print STDOUT "Content-type: text/html\n\n"; - print STDOUT $mess; - } - } - - warningsToBrowser(1); # emit warnings before dying -} - -# Cut and paste from CGI.pm so that we don't have the overhead of -# always loading the entire CGI module. -sub to_filehandle { - my $thingy = shift; - return undef unless $thingy; - return $thingy if UNIVERSAL::isa($thingy,'GLOB'); - return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); - if (!ref($thingy)) { - my $caller = 1; - while (my $package = caller($caller++)) { - my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; - return $tmp if defined(fileno($tmp)); - } - } - return undef; -} - -1; diff --git a/lib/CGI/Cookie.pm b/lib/CGI/Cookie.pm deleted file mode 100644 index 27a93c5..0000000 --- a/lib/CGI/Cookie.pm +++ /dev/null @@ -1,478 +0,0 @@ -package CGI::Cookie; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -# You can run this file through either pod2man or pod2html to produce pretty -# documentation in manual or html file format (these utilities are part of the -# Perl 5 distribution). - -# Copyright 1995-1999, Lincoln D. Stein. All rights reserved. -# It may be used and modified freely, but I do request that this copyright -# notice remain attached to the file. You may modify this module as you -# wish, but if you redistribute a modified version, please attach a note -# listing the modifications you have made. - -$CGI::Cookie::VERSION='1.24'; - -use CGI::Util qw(rearrange unescape escape); -use overload '""' => \&as_string, - 'cmp' => \&compare, - 'fallback'=>1; - -# Turn on special checking for Doug MacEachern's modperl -my $MOD_PERL = 0; -if (exists $ENV{MOD_PERL}) { - eval "require mod_perl"; - if (defined $mod_perl::VERSION) { - if ($mod_perl::VERSION >= 1.99) { - $MOD_PERL = 2; - require Apache::RequestUtil; - } else { - $MOD_PERL = 1; - require Apache; - } - } -} - -# fetch a list of cookies from the environment and -# return as a hash. the cookies are parsed as normal -# escaped URL data. -sub fetch { - my $class = shift; - my $raw_cookie = get_raw_cookie(@_) or return; - return $class->parse($raw_cookie); -} - -# Fetch a list of cookies from the environment or the incoming headers and -# return as a hash. The cookie values are not unescaped or altered in any way. - sub raw_fetch { - my $class = shift; - my $raw_cookie = get_raw_cookie(@_) or return; - my %results; - my($key,$value); - - my(@pairs) = split("; ?",$raw_cookie); - foreach (@pairs) { - s/\s*(.*?)\s*/$1/; - if (/^([^=]+)=(.*)/) { - $key = $1; - $value = $2; - } - else { - $key = $_; - $value = ''; - } - $results{$key} = $value; - } - return \%results unless wantarray; - return %results; -} - -sub get_raw_cookie { - my $r = shift; - $r ||= eval { Apache->request() } if $MOD_PERL; - if ($r) { - $raw_cookie = $r->headers_in->{'Cookie'}; - } else { - if ($MOD_PERL && !exists $ENV{REQUEST_METHOD}) { - die "Run $r->subprocess_env; before calling fetch()"; - } - $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE}; - } -} - - -sub parse { - my ($self,$raw_cookie) = @_; - my %results; - - my(@pairs) = split("; ?",$raw_cookie); - foreach (@pairs) { - s/\s*(.*?)\s*/$1/; - my($key,$value) = split("=",$_,2); - - # Some foreign cookies are not in name=value format, so ignore - # them. - next if !defined($value); - my @values = (); - if ($value ne '') { - @values = map unescape($_),split(/[&;]/,$value.'&dmy'); - pop @values; - } - $key = unescape($key); - # A bug in Netscape can cause several cookies with same name to - # appear. The FIRST one in HTTP_COOKIE is the most recent version. - $results{$key} ||= $self->new(-name=>$key,-value=>\@values); - } - return \%results unless wantarray; - return %results; -} - -sub new { - my $class = shift; - $class = ref($class) if ref($class); - my($name,$value,$path,$domain,$secure,$expires) = - rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_); - - # Pull out our parameters. - my @values; - if (ref($value)) { - if (ref($value) eq 'ARRAY') { - @values = @$value; - } elsif (ref($value) eq 'HASH') { - @values = %$value; - } - } else { - @values = ($value); - } - - bless my $self = { - 'name'=>$name, - 'value'=>[@values], - },$class; - - # IE requires the path and domain to be present for some reason. - $path ||= "/"; - # however, this breaks networks which use host tables without fully qualified - # names, so we comment it out. - # $domain = CGI::virtual_host() unless defined $domain; - - $self->path($path) if defined $path; - $self->domain($domain) if defined $domain; - $self->secure($secure) if defined $secure; - $self->expires($expires) if defined $expires; -# $self->max_age($expires) if defined $expires; - return $self; -} - -sub as_string { - my $self = shift; - return "" unless $self->name; - - my(@constant_values,$domain,$path,$expires,$max_age,$secure); - - push(@constant_values,"domain=$domain") if $domain = $self->domain; - push(@constant_values,"path=$path") if $path = $self->path; - push(@constant_values,"expires=$expires") if $expires = $self->expires; - push(@constant_values,"max-age=$max_age") if $max_age = $self->max_age; - push(@constant_values,"secure") if $secure = $self->secure; - - my($key) = escape($self->name); - my($cookie) = join("=",$key,join("&",map escape($_),$self->value)); - return join("; ",$cookie,@constant_values); -} - -sub compare { - my $self = shift; - my $value = shift; - return "$self" cmp $value; -} - -# accessors -sub name { - my $self = shift; - my $name = shift; - $self->{'name'} = $name if defined $name; - return $self->{'name'}; -} - -sub value { - my $self = shift; - my $value = shift; - if (defined $value) { - my @values; - if (ref($value)) { - if (ref($value) eq 'ARRAY') { - @values = @$value; - } elsif (ref($value) eq 'HASH') { - @values = %$value; - } - } else { - @values = ($value); - } - $self->{'value'} = [@values]; - } - return wantarray ? @{$self->{'value'}} : $self->{'value'}->[0] -} - -sub domain { - my $self = shift; - my $domain = shift; - $self->{'domain'} = $domain if defined $domain; - return $self->{'domain'}; -} - -sub secure { - my $self = shift; - my $secure = shift; - $self->{'secure'} = $secure if defined $secure; - return $self->{'secure'}; -} - -sub expires { - my $self = shift; - my $expires = shift; - $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires; - return $self->{'expires'}; -} - -sub max_age { - my $self = shift; - my $expires = shift; - $self->{'max-age'} = CGI::Util::expire_calc($expires)-time() if defined $expires; - return $self->{'max-age'}; -} - -sub path { - my $self = shift; - my $path = shift; - $self->{'path'} = $path if defined $path; - return $self->{'path'}; -} - -1; - -=head1 NAME - -CGI::Cookie - Interface to Netscape Cookies - -=head1 SYNOPSIS - - use CGI qw/:standard/; - use CGI::Cookie; - - # Create new cookies and send them - $cookie1 = new CGI::Cookie(-name=>'ID',-value=>123456); - $cookie2 = new CGI::Cookie(-name=>'preferences', - -value=>{ font => Helvetica, - size => 12 } - ); - print header(-cookie=>[$cookie1,$cookie2]); - - # fetch existing cookies - %cookies = fetch CGI::Cookie; - $id = $cookies{'ID'}->value; - - # create cookies returned from an external source - %cookies = parse CGI::Cookie($ENV{COOKIE}); - -=head1 DESCRIPTION - -CGI::Cookie is an interface to Netscape (HTTP/1.1) cookies, an -innovation that allows Web servers to store persistent information on -the browser's side of the connection. Although CGI::Cookie is -intended to be used in conjunction with CGI.pm (and is in fact used by -it internally), you can use this module independently. - -For full information on cookies see - - http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt - -=head1 USING CGI::Cookie - -CGI::Cookie is object oriented. Each cookie object has a name and a -value. The name is any scalar value. The value is any scalar or -array value (associative arrays are also allowed). Cookies also have -several optional attributes, including: - -=over 4 - -=item B<1. expiration date> - -The expiration date tells the browser how long to hang on to the -cookie. If the cookie specifies an expiration date in the future, the -browser will store the cookie information in a disk file and return it -to the server every time the user reconnects (until the expiration -date is reached). If the cookie species an expiration date in the -past, the browser will remove the cookie from the disk file. If the -expiration date is not specified, the cookie will persist only until -the user quits the browser. - -=item B<2. domain> - -This is a partial or complete domain name for which the cookie is -valid. The browser will return the cookie to any host that matches -the partial domain name. For example, if you specify a domain name -of ".capricorn.com", then Netscape will return the cookie to -Web servers running on any of the machines "www.capricorn.com", -"ftp.capricorn.com", "feckless.capricorn.com", etc. Domain names -must contain at least two periods to prevent attempts to match -on top level domains like ".edu". If no domain is specified, then -the browser will only return the cookie to servers on the host the -cookie originated from. - -=item B<3. path> - -If you provide a cookie path attribute, the browser will check it -against your script's URL before returning the cookie. For example, -if you specify the path "/cgi-bin", then the cookie will be returned -to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and -"/cgi-bin/customer_service/complain.pl", but not to the script -"/cgi-private/site_admin.pl". By default, the path is set to "/", so -that all scripts at your site will receive the cookie. - -=item B<4. secure flag> - -If the "secure" attribute is set, the cookie will only be sent to your -script if the CGI request is occurring on a secure channel, such as SSL. - -=back - -=head2 Creating New Cookies - - $c = new CGI::Cookie(-name => 'foo', - -value => 'bar', - -expires => '+3M', - -domain => '.capricorn.com', - -path => '/cgi-bin/database', - -secure => 1 - ); - -Create cookies from scratch with the B<new> method. The B<-name> and -B<-value> parameters are required. The name must be a scalar value. -The value can be a scalar, an array reference, or a hash reference. -(At some point in the future cookies will support one of the Perl -object serialization protocols for full generality). - -B<-expires> accepts any of the relative or absolute date formats -recognized by CGI.pm, for example "+3M" for three months in the -future. See CGI.pm's documentation for details. - -B<-domain> points to a domain name or to a fully qualified host name. -If not specified, the cookie will be returned only to the Web server -that created it. - -B<-path> points to a partial URL on the current server. The cookie -will be returned to all URLs beginning with the specified path. If -not specified, it defaults to '/', which returns the cookie to all -pages at your site. - -B<-secure> if set to a true value instructs the browser to return the -cookie only when a cryptographic protocol is in use. - -=head2 Sending the Cookie to the Browser - -Within a CGI script you can send a cookie to the browser by creating -one or more Set-Cookie: fields in the HTTP header. Here is a typical -sequence: - - my $c = new CGI::Cookie(-name => 'foo', - -value => ['bar','baz'], - -expires => '+3M'); - - print "Set-Cookie: $c\n"; - print "Content-Type: text/html\n\n"; - -To send more than one cookie, create several Set-Cookie: fields. - -If you are using CGI.pm, you send cookies by providing a -cookie -argument to the header() method: - - print header(-cookie=>$c); - -Mod_perl users can set cookies using the request object's header_out() -method: - - $r->headers_out->set('Set-Cookie' => $c); - -Internally, Cookie overloads the "" operator to call its as_string() -method when incorporated into the HTTP header. as_string() turns the -Cookie's internal representation into an RFC-compliant text -representation. You may call as_string() yourself if you prefer: - - print "Set-Cookie: ",$c->as_string,"\n"; - -=head2 Recovering Previous Cookies - - %cookies = fetch CGI::Cookie; - -B<fetch> returns an associative array consisting of all cookies -returned by the browser. The keys of the array are the cookie names. You -can iterate through the cookies this way: - - %cookies = fetch CGI::Cookie; - foreach (keys %cookies) { - do_something($cookies{$_}); - } - -In a scalar context, fetch() returns a hash reference, which may be more -efficient if you are manipulating multiple cookies. - -CGI.pm uses the URL escaping methods to save and restore reserved characters -in its cookies. If you are trying to retrieve a cookie set by a foreign server, -this escaping method may trip you up. Use raw_fetch() instead, which has the -same semantics as fetch(), but performs no unescaping. - -You may also retrieve cookies that were stored in some external -form using the parse() class method: - - $COOKIES = `cat /usr/tmp/Cookie_stash`; - %cookies = parse CGI::Cookie($COOKIES); - -If you are in a mod_perl environment, you can save some overhead by -passing the request object to fetch() like this: - - CGI::Cookie->fetch($r); - -=head2 Manipulating Cookies - -Cookie objects have a series of accessor methods to get and set cookie -attributes. Each accessor has a similar syntax. Called without -arguments, the accessor returns the current value of the attribute. -Called with an argument, the accessor changes the attribute and -returns its new value. - -=over 4 - -=item B<name()> - -Get or set the cookie's name. Example: - - $name = $c->name; - $new_name = $c->name('fred'); - -=item B<value()> - -Get or set the cookie's value. Example: - - $value = $c->value; - @new_value = $c->value(['a','b','c','d']); - -B<value()> is context sensitive. In a list context it will return -the current value of the cookie as an array. In a scalar context it -will return the B<first> value of a multivalued cookie. - -=item B<domain()> - -Get or set the cookie's domain. - -=item B<path()> - -Get or set the cookie's path. - -=item B<expires()> - -Get or set the cookie's expiration time. - -=back - - -=head1 AUTHOR INFORMATION - -Copyright 1997-1998, Lincoln D. Stein. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -Address bug reports and comments to: lstein@cshl.org - -=head1 BUGS - -This section intentionally left blank. - -=head1 SEE ALSO - -L<CGI::Carp>, L<CGI> - -=cut diff --git a/lib/CGI/Fast.pm b/lib/CGI/Fast.pm deleted file mode 100644 index 43b8709..0000000 --- a/lib/CGI/Fast.pm +++ /dev/null @@ -1,230 +0,0 @@ -package CGI::Fast; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -# You can run this file through either pod2man or pod2html to produce pretty -# documentation in manual or html file format (these utilities are part of the -# Perl 5 distribution). - -# Copyright 1995,1996, Lincoln D. Stein. All rights reserved. -# It may be used and modified freely, but I do request that this copyright -# notice remain attached to the file. You may modify this module as you -# wish, but if you redistribute a modified version, please attach a note -# listing the modifications you have made. - -# The most recent version and complete docs are available at: -# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html -# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ -$CGI::Fast::VERSION='1.05'; - -use CGI; -use FCGI; -@ISA = ('CGI'); - -# workaround for known bug in libfcgi -while (($ignore) = each %ENV) { } - -# override the initialization behavior so that -# state is NOT maintained between invocations -sub save_request { - # no-op -} - -# If ENV{FCGI_SOCKET_PATH} is specified, we maintain a FCGI Request handle -# in this package variable. -use vars qw($Ext_Request); -BEGIN { - # If ENV{FCGI_SOCKET_PATH} is given, explicitly open the socket, - # and keep the request handle around from which to call Accept(). - if ($ENV{FCGI_SOCKET_PATH}) { - my $path = $ENV{FCGI_SOCKET_PATH}; - my $backlog = $ENV{FCGI_LISTEN_QUEUE} || 100; - my $socket = FCGI::OpenSocket( $path, $backlog ); - $Ext_Request = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR, - \%ENV, $socket, 1 ); - } -} - -# New is slightly different in that it calls FCGI's -# accept() method. -sub new { - my ($self, $initializer, @param) = @_; - unless (defined $initializer) { - if ($Ext_Request) { - return undef unless $Ext_Request->Accept() >= 0; - } else { - return undef unless FCGI::accept() >= 0; - } - } - return $CGI::Q = $self->SUPER::new($initializer, @param); -} - -1; - -=head1 NAME - -CGI::Fast - CGI Interface for Fast CGI - -=head1 SYNOPSIS - - use CGI::Fast qw(:standard); - $COUNTER = 0; - while (new CGI::Fast) { - print header; - print start_html("Fast CGI Rocks"); - print - h1("Fast CGI Rocks"), - "Invocation number ",b($COUNTER++), - " PID ",b($$),".", - hr; - print end_html; - } - -=head1 DESCRIPTION - -CGI::Fast is a subclass of the CGI object created by -CGI.pm. It is specialized to work well with the Open Market -FastCGI standard, which greatly speeds up CGI scripts by -turning them into persistently running server processes. Scripts -that perform time-consuming initialization processes, such as -loading large modules or opening persistent database connections, -will see large performance improvements. - -=head1 OTHER PIECES OF THE PUZZLE - -In order to use CGI::Fast you'll need a FastCGI-enabled Web -server. Open Market's server is FastCGI-savvy. There are also -freely redistributable FastCGI modules for NCSA httpd 1.5 and Apache. -FastCGI-enabling modules for Microsoft Internet Information Server and -Netscape Communications Server have been announced. - -In addition, you'll need a version of the Perl interpreter that has -been linked with the FastCGI I/O library. Precompiled binaries are -available for several platforms, including DEC Alpha, HP-UX and -SPARC/Solaris, or you can rebuild Perl from source with patches -provided in the FastCGI developer's kit. The FastCGI Perl interpreter -can be used in place of your normal Perl without ill consequences. - -You can find FastCGI modules for Apache and NCSA httpd, precompiled -Perl interpreters, and the FastCGI developer's kit all at URL: - - http://www.fastcgi.com/ - -=head1 WRITING FASTCGI PERL SCRIPTS - -FastCGI scripts are persistent: one or more copies of the script -are started up when the server initializes, and stay around until -the server exits or they die a natural death. After performing -whatever one-time initialization it needs, the script enters a -loop waiting for incoming connections, processing the request, and -waiting some more. - -A typical FastCGI script will look like this: - - #!/usr/local/bin/perl # must be a FastCGI version of perl! - use CGI::Fast; - &do_some_initialization(); - while ($q = new CGI::Fast) { - &process_request($q); - } - -Each time there's a new request, CGI::Fast returns a -CGI object to your loop. The rest of the time your script -waits in the call to new(). When the server requests that -your script be terminated, new() will return undef. You can -of course exit earlier if you choose. A new version of the -script will be respawned to take its place (this may be -necessary in order to avoid Perl memory leaks in long-running -scripts). - -CGI.pm's default CGI object mode also works. Just modify the loop -this way: - - while (new CGI::Fast) { - &process_request; - } - -Calls to header(), start_form(), etc. will all operate on the -current request. - -=head1 INSTALLING FASTCGI SCRIPTS - -See the FastCGI developer's kit documentation for full details. On -the Apache server, the following line must be added to srm.conf: - - AddType application/x-httpd-fcgi .fcgi - -FastCGI scripts must end in the extension .fcgi. For each script you -install, you must add something like the following to srm.conf: - - FastCgiServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -processes 2 - -This instructs Apache to launch two copies of file_upload.fcgi at -startup time. - -=head1 USING FASTCGI SCRIPTS AS CGI SCRIPTS - -Any script that works correctly as a FastCGI script will also work -correctly when installed as a vanilla CGI script. However it will -not see any performance benefit. - -=head1 EXTERNAL FASTCGI SERVER INVOCATION - -FastCGI supports a TCP/IP transport mechanism which allows FastCGI scripts to run -external to the webserver, perhaps on a remote machine. To configure the -webserver to connect to an external FastCGI server, you would add the following -to your srm.conf: - - FastCgiExternalServer /usr/etc/httpd/fcgi-bin/file_upload.fcgi -host sputnik:8888 - -Two environment variables affect how the C<CGI::Fast> object is created, -allowing C<CGI::Fast> to be used as an external FastCGI server. (See C<FCGI> -documentation for C<FCGI::OpenSocket> for more information.) - -=over - -=item FCGI_SOCKET_PATH - -The address (TCP/IP) or path (UNIX Domain) of the socket the external FastCGI -script to which bind an listen for incoming connections from the web server. - -=item FCGI_LISTEN_QUEUE - -Maximum length of the queue of pending connections. - -=back - -For example: - - #!/usr/local/bin/perl # must be a FastCGI version of perl! - use CGI::Fast; - &do_some_initialization(); - $ENV{FCGI_SOCKET_PATH} = "sputnik:8888"; - $ENV{FCGI_LISTEN_QUEUE} = 100; - while ($q = new CGI::Fast) { - &process_request($q); - } - -=head1 CAVEATS - -I haven't tested this very much. - -=head1 AUTHOR INFORMATION - -Copyright 1996-1998, Lincoln D. Stein. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -Address bug reports and comments to: lstein@cshl.org - -=head1 BUGS - -This section intentionally left blank. - -=head1 SEE ALSO - -L<CGI::Carp>, L<CGI> - -=cut diff --git a/lib/CGI/Pretty.pm b/lib/CGI/Pretty.pm deleted file mode 100644 index d824a02..0000000 --- a/lib/CGI/Pretty.pm +++ /dev/null @@ -1,275 +0,0 @@ -package CGI::Pretty; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -# You can run this file through either pod2man or pod2html to produce pretty -# documentation in manual or html file format (these utilities are part of the -# Perl 5 distribution). - -use strict; -use CGI (); - -$CGI::Pretty::VERSION = '1.08'; -$CGI::DefaultClass = __PACKAGE__; -$CGI::Pretty::AutoloadClass = 'CGI'; -@CGI::Pretty::ISA = qw( CGI ); - -initialize_globals(); - -sub _prettyPrint { - my $input = shift; - return if !$$input; - return if !$CGI::Pretty::LINEBREAK || !$CGI::Pretty::INDENT; - -# print STDERR "'", $$input, "'\n"; - - foreach my $i ( @CGI::Pretty::AS_IS ) { - if ( $$input =~ m{</$i>}si ) { - my ( $a, $b, $c ) = $$input =~ m{(.*)(<$i[\s/>].*?</$i>)(.*)}si; - next if !$b; - $a ||= ""; - $c ||= ""; - - _prettyPrint( \$a ) if $a; - _prettyPrint( \$c ) if $c; - - $b ||= ""; - $$input = "$a$b$c"; - return; - } - } - $$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g; -} - -sub comment { - my($self,@p) = CGI::self_or_CGI(@_); - - my $s = "@p"; - $s =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g if $CGI::Pretty::LINEBREAK; - - return $self->SUPER::comment( "$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT$s$CGI::Pretty::LINEBREAK" ) . $CGI::Pretty::LINEBREAK; -} - -sub _make_tag_func { - my ($self,$tagname) = @_; - - # As Lincoln as noted, the last else clause is VERY hairy, and it - # took me a while to figure out what I was trying to do. - # What it does is look for tags that shouldn't be indented (e.g. PRE) - # and makes sure that when we nest tags, those tags don't get - # indented. - # For an example, try print td( pre( "hello\nworld" ) ); - # If we didn't care about stuff like that, the code would be - # MUCH simpler. BTW: I won't claim to be a regular expression - # guru, so if anybody wants to contribute something that would - # be quicker, easier to read, etc, I would be more than - # willing to put it in - Brian - - my $func = qq" - sub $tagname {"; - - $func .= q' - shift if $_[0] && - (ref($_[0]) && - (substr(ref($_[0]),0,3) eq "CGI" || - UNIVERSAL::isa($_[0],"CGI"))); - my($attr) = ""; - if (ref($_[0]) && ref($_[0]) eq "HASH") { - my(@attr) = make_attributes(shift()||undef,1); - $attr = " @attr" if @attr; - }'; - - if ($tagname=~/start_(\w+)/i) { - $func .= qq! - return "<\L$1\E\$attr>\$CGI::Pretty::LINEBREAK";} !; - } elsif ($tagname=~/end_(\w+)/i) { - $func .= qq! - return "<\L/$1\E>\$CGI::Pretty::LINEBREAK"; } !; - } else { - $func .= qq# - return ( \$CGI::XHTML ? "<\L$tagname\E\$attr />" : "<\L$tagname\E\$attr>" ) . - \$CGI::Pretty::LINEBREAK unless \@_; - my(\$tag,\$untag) = ("<\L$tagname\E\$attr>","</\L$tagname>\E"); - - my \%ASIS = map { lc("\$_") => 1 } \@CGI::Pretty::AS_IS; - my \@args; - if ( \$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT ) { - if(ref(\$_[0]) eq 'ARRAY') { - \@args = \@{\$_[0]} - } else { - foreach (\@_) { - \$args[0] .= \$_; - \$args[0] .= \$CGI::Pretty::LINEBREAK if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 0; - chomp \$args[0] if exists \$ASIS{ "\L$tagname\E" }; - - \$args[0] .= \$" if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 1; - } - chop \$args[0]; - } - } - else { - \@args = ref(\$_[0]) eq 'ARRAY' ? \@{\$_[0]} : "\@_"; - } - - my \@result; - if ( exists \$ASIS{ "\L$tagname\E" } ) { - \@result = map { "\$tag\$_\$untag\$CGI::Pretty::LINEBREAK" } - \@args; - } - else { - \@result = map { - chomp; - my \$tmp = \$_; - CGI::Pretty::_prettyPrint( \\\$tmp ); - \$tag . \$CGI::Pretty::LINEBREAK . - \$CGI::Pretty::INDENT . \$tmp . \$CGI::Pretty::LINEBREAK . - \$untag . \$CGI::Pretty::LINEBREAK - } \@args; - } - local \$" = "" if \$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT; - return "\@result"; - }#; - } - - return $func; -} - -sub start_html { - return CGI::start_html( @_ ) . $CGI::Pretty::LINEBREAK; -} - -sub end_html { - return CGI::end_html( @_ ) . $CGI::Pretty::LINEBREAK; -} - -sub new { - my $class = shift; - my $this = $class->SUPER::new( @_ ); - - if ($CGI::MOD_PERL) { - my $r = Apache->request; - if ($CGI::MOD_PERL == 1) { - $r->register_cleanup(\&CGI::Pretty::_reset_globals); - } - else { - $r->pool->cleanup_register(\&CGI::Pretty::_reset_globals); - } - } - $class->_reset_globals if $CGI::PERLEX; - - return bless $this, $class; -} - -sub initialize_globals { - # This is the string used for indentation of tags - $CGI::Pretty::INDENT = "\t"; - - # This is the string used for seperation between tags - $CGI::Pretty::LINEBREAK = $/; - - # These tags are not prettify'd. - @CGI::Pretty::AS_IS = qw( a pre code script textarea td ); - - 1; -} -sub _reset_globals { initialize_globals(); } - -1; - -=head1 NAME - -CGI::Pretty - module to produce nicely formatted HTML code - -=head1 SYNOPSIS - - use CGI::Pretty qw( :html3 ); - - # Print a table with a single data element - print table( TR( td( "foo" ) ) ); - -=head1 DESCRIPTION - -CGI::Pretty is a module that derives from CGI. It's sole function is to -allow users of CGI to output nicely formatted HTML code. - -When using the CGI module, the following code: - print table( TR( td( "foo" ) ) ); - -produces the following output: - <TABLE><TR><TD>foo</TD></TR></TABLE> - -If a user were to create a table consisting of many rows and many columns, -the resultant HTML code would be quite difficult to read since it has no -carriage returns or indentation. - -CGI::Pretty fixes this problem. What it does is add a carriage -return and indentation to the HTML code so that one can easily read -it. - - print table( TR( td( "foo" ) ) ); - -now produces the following output: - <TABLE> - <TR> - <TD> - foo - </TD> - </TR> - </TABLE> - - -=head2 Tags that won't be formatted - -The <A> and <PRE> tags are not formatted. If these tags were formatted, the -user would see the extra indentation on the web browser causing the page to -look different than what would be expected. If you wish to add more tags to -the list of tags that are not to be touched, push them onto the C<@AS_IS> array: - - push @CGI::Pretty::AS_IS,qw(CODE XMP); - -=head2 Customizing the Indenting - -If you wish to have your own personal style of indenting, you can change the -C<$INDENT> variable: - - $CGI::Pretty::INDENT = "\t\t"; - -would cause the indents to be two tabs. - -Similarly, if you wish to have more space between lines, you may change the -C<$LINEBREAK> variable: - - $CGI::Pretty::LINEBREAK = "\n\n"; - -would create two carriage returns between lines. - -If you decide you want to use the regular CGI indenting, you can easily do -the following: - - $CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = ""; - -=head1 BUGS - -This section intentionally left blank. - -=head1 AUTHOR - -Brian Paulsen <Brian@ThePaulsens.com>, with minor modifications by -Lincoln Stein <lstein@cshl.org> for incorporation into the CGI.pm -distribution. - -Copyright 1999, Brian Paulsen. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -Bug reports and comments to Brian@ThePaulsens.com. You can also write -to lstein@cshl.org, but this code looks pretty hairy to me and I'm not -sure I understand it! - -=head1 SEE ALSO - -L<CGI> - -=cut diff --git a/lib/CGI/Push.pm b/lib/CGI/Push.pm deleted file mode 100644 index 8356c60..0000000 --- a/lib/CGI/Push.pm +++ /dev/null @@ -1,328 +0,0 @@ -package CGI::Push; - -# See the bottom of this file for the POD documentation. Search for the -# string '=head'. - -# You can run this file through either pod2man or pod2html to produce pretty -# documentation in manual or html file format (these utilities are part of the -# Perl 5 distribution). - -# Copyright 1995-2000, Lincoln D. Stein. All rights reserved. -# It may be used and modified freely, but I do request that this copyright -# notice remain attached to the file. You may modify this module as you -# wish, but if you redistribute a modified version, please attach a note -# listing the modifications you have made. - -# The most recent version and complete docs are available at: -# http://stein.cshl.org/WWW/software/CGI/ - -$CGI::Push::VERSION='1.04'; -use CGI; -use CGI::Util 'rearrange'; -@ISA = ('CGI'); - -$CGI::DefaultClass = 'CGI::Push'; -$CGI::Push::AutoloadClass = 'CGI'; - -# add do_push() and push_delay() to exported tags -push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push','push_delay'); - -sub do_push { - my ($self,@p) = CGI::self_or_default(@_); - - # unbuffer output - $| = 1; - srand; - my ($random) = sprintf("%08.0f",rand()*1E8); - my ($boundary) = "----=_NeXtPaRt$random"; - - my (@header); - my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,$nph,$handle,@other) = rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES,NPH,HANDLE],@p); - $type = 'text/html' unless $type; - $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE'; - $delay = 1 unless defined($delay); - $self->push_delay($delay); - $nph = 1 unless defined($nph); - $handle = \*STDOUT unless defined($handle); - -sdf;kjsdlfsdfkl - - my(@o); - foreach (@other) { push(@o,split("=")); } - push(@o,'-Target'=>$target) if defined($target); - push(@o,'-Cookie'=>$cookie) if defined($cookie); - push(@o,'-Type'=>"multipart/x-mixed-replace;boundary=\"$boundary\""); - push(@o,'-Server'=>"CGI.pm Push Module") if $nph; - push(@o,'-Status'=>'200 OK'); - push(@o,'-nph'=>1) if $nph; - $handle->print($self->header(@o)); - - $boundary = "$CGI::CRLF--$boundary"; - - $handle->print("WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.${boundary}$CGI::CRLF"); - - my (@contents) = &$callback($self,++$COUNTER); - - # now we enter a little loop - while (1) { - $handle->print("Content-type: ${type}$CGI::CRLF$CGI::CRLF") unless $type =~ /^dynamic|heterogeneous$/i; - $handle->print(@contents); - @contents = &$callback($self,++$COUNTER); - if ((@contents) && defined($contents[0])) { - $handle->print("${boundary}$CGI::CRLF"); - do_sleep($self->push_delay()) if $self->push_delay(); - } else { - if ($last_page && ref($last_page) eq 'CODE') { - $handle->print("${boundary}$CGI::CRLF"); - do_sleep($self->push_delay()) if $self->push_delay(); - $handle->print("Content-type: ${type}$CGI::CRLF$CGI::CRLF") unless $type =~ /^dynamic|heterogeneous$/i; - $handle->print(&$last_page($self,$COUNTER)); - } - $handle->print("${boundary}--$CGI::CRLF"); - last; - } - } - $handle->print("WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY.${boundary}$CGI::CRLF"); -} - -sub simple_counter { - my ($self,$count) = @_; - return $self->start_html("CGI::Push Default Counter"), - $self->h1("CGI::Push Default Counter"), - "This page has been updated ",$self->strong($count)," times.", - $self->hr(), - $self->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'), - $self->end_html; -} - -sub do_sleep { - my $delay = shift; - if ( ($delay >= 1) && ($delay!~/\./) ){ - sleep($delay); - } else { - select(undef,undef,undef,$delay); - } -} - -sub push_delay { - my ($self,$delay) = CGI::self_or_default(@_); - return defined($delay) ? $self->{'.delay'} = - $delay : $self->{'.delay'}; -} - -1; - -=head1 NAME - -CGI::Push - Simple Interface to Server Push - -=head1 SYNOPSIS - - use CGI::Push qw(:standard); - - do_push(-next_page=>\&next_page, - -last_page=>\&last_page, - -delay=>0.5); - - sub next_page { - my($q,$counter) = @_; - return undef if $counter >= 10; - return start_html('Test'), - h1('Visible'),"\n", - "This page has been called ", strong($counter)," times", - end_html(); - } - - sub last_page { - my($q,$counter) = @_; - return start_html('Done'), - h1('Finished'), - strong($counter - 1),' iterations.', - end_html; - } - -=head1 DESCRIPTION - -CGI::Push is a subclass of the CGI object created by CGI.pm. It is -specialized for server push operations, which allow you to create -animated pages whose content changes at regular intervals. - -You provide CGI::Push with a pointer to a subroutine that will draw -one page. Every time your subroutine is called, it generates a new -page. The contents of the page will be transmitted to the browser -in such a way that it will replace what was there beforehand. The -technique will work with HTML pages as well as with graphics files, -allowing you to create animated GIFs. - -Only Netscape Navigator supports server push. Internet Explorer -browsers do not. - -=head1 USING CGI::Push - -CGI::Push adds one new method to the standard CGI suite, do_push(). -When you call this method, you pass it a reference to a subroutine -that is responsible for drawing each new page, an interval delay, and -an optional subroutine for drawing the last page. Other optional -parameters include most of those recognized by the CGI header() -method. - -You may call do_push() in the object oriented manner or not, as you -prefer: - - use CGI::Push; - $q = new CGI::Push; - $q->do_push(-next_page=>\&draw_a_page); - - -or- - - use CGI::Push qw(:standard); - do_push(-next_page=>\&draw_a_page); - -Parameters are as follows: - -=over 4 - -=item -next_page - - do_push(-next_page=>\&my_draw_routine); - -This required parameter points to a reference to a subroutine responsible for -drawing each new page. The subroutine should expect two parameters -consisting of the CGI object and a counter indicating the number -of times the subroutine has been called. It should return the -contents of the page as an B<array> of one or more items to print. -It can return a false value (or an empty array) in order to abort the -redrawing loop and print out the final page (if any) - - sub my_draw_routine { - my($q,$counter) = @_; - return undef if $counter > 100; - return start_html('testing'), - h1('testing'), - "This page called $counter times"; - } - -You are of course free to refer to create and use global variables -within your draw routine in order to achieve special effects. - -=item -last_page - -This optional parameter points to a reference to the subroutine -responsible for drawing the last page of the series. It is called -after the -next_page routine returns a false value. The subroutine -itself should have exactly the same calling conventions as the --next_page routine. - -=item -type - -This optional parameter indicates the content type of each page. It -defaults to "text/html". Normally the module assumes that each page -is of a homogenous MIME type. However if you provide either of the -magic values "heterogeneous" or "dynamic" (the latter provided for the -convenience of those who hate long parameter names), you can specify -the MIME type -- and other header fields -- on a per-page basis. See -"heterogeneous pages" for more details. - -=item -delay - -This indicates the delay, in seconds, between frames. Smaller delays -refresh the page faster. Fractional values are allowed. - -B<If not specified, -delay will default to 1 second> - -=item -cookie, -target, -expires, -nph - -These have the same meaning as the like-named parameters in -CGI::header(). - -If not specified, -nph will default to 1 (as needed for many servers, see below). - -=back - -=head2 Heterogeneous Pages - -Ordinarily all pages displayed by CGI::Push share a common MIME type. -However by providing a value of "heterogeneous" or "dynamic" in the -do_push() -type parameter, you can specify the MIME type of each page -on a case-by-case basis. - -If you use this option, you will be responsible for producing the -HTTP header for each page. Simply modify your draw routine to -look like this: - - sub my_draw_routine { - my($q,$counter) = @_; - return header('text/html'), # note we're producing the header here - start_html('testing'), - h1('testing'), - "This page called $counter times"; - } - -You can add any header fields that you like, but some (cookies and -status fields included) may not be interpreted by the browser. One -interesting effect is to display a series of pages, then, after the -last page, to redirect the browser to a new URL. Because redirect() -does b<not> work, the easiest way is with a -refresh header field, -as shown below: - - sub my_draw_routine { - my($q,$counter) = @_; - return undef if $counter > 10; - return header('text/html'), # note we're producing the header here - start_html('testing'), - h1('testing'), - "This page called $counter times"; - } - - sub my_last_page { - return header(-refresh=>'5; URL=http://somewhere.else/finished.html', - -type=>'text/html'), - start_html('Moved'), - h1('This is the last page'), - 'Goodbye!' - hr, - end_html; - } - -=head2 Changing the Page Delay on the Fly - -If you would like to control the delay between pages on a page-by-page -basis, call push_delay() from within your draw routine. push_delay() -takes a single numeric argument representing the number of seconds you -wish to delay after the current page is displayed and before -displaying the next one. The delay may be fractional. Without -parameters, push_delay() just returns the current delay. - -=head1 INSTALLING CGI::Push SCRIPTS - -Server push scripts must be installed as no-parsed-header (NPH) -scripts in order to work correctly on many servers. On Unix systems, -this is most often accomplished by prefixing the script's name with "nph-". -Recognition of NPH scripts happens automatically with WebSTAR and -Microsoft IIS. Users of other servers should see their documentation -for help. - -Apache web server from version 1.3b2 on does not need server -push scripts installed as NPH scripts: the -nph parameter to do_push() -may be set to a false value to disable the extra headers needed by an -NPH script. - -=head1 AUTHOR INFORMATION - -Copyright 1995-1998, Lincoln D. Stein. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -Address bug reports and comments to: lstein@cshl.org - -=head1 BUGS - -This section intentionally left blank. - -=head1 SEE ALSO - -L<CGI::Carp>, L<CGI> - -=cut - diff --git a/lib/CGI/Switch.pm b/lib/CGI/Switch.pm deleted file mode 100644 index b8cc9ef..0000000 --- a/lib/CGI/Switch.pm +++ /dev/null @@ -1,27 +0,0 @@ -use CGI; - -$VERSION = '1.00'; - -1; - -__END__ - -=head1 NAME - -CGI::Switch - Backward compatibility module for defunct CGI::Switch - -=head1 SYNOPSIS - -Do not use this module. It is deprecated. - -=head1 ABSTRACT - -=head1 DESCRIPTION - -=head1 AUTHOR INFORMATION - -=head1 BUGS - -=head1 SEE ALSO - -=cut diff --git a/lib/CGI/Util.pm b/lib/CGI/Util.pm deleted file mode 100644 index 6af42de..0000000 --- a/lib/CGI/Util.pm +++ /dev/null @@ -1,317 +0,0 @@ -package CGI::Util; - -use strict; -use vars qw($VERSION @EXPORT_OK @ISA $EBCDIC @A2E @E2A); -require Exporter; -@ISA = qw(Exporter); -@EXPORT_OK = qw(rearrange make_attributes unescape escape - expires ebcdic2ascii ascii2ebcdic); - -$VERSION = '1.5'; - -$EBCDIC = "\t" ne "\011"; -# (ord('^') == 95) for codepage 1047 as on os390, vmesa -@A2E = ( - 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, - 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31, - 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97, - 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111, - 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214, - 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109, - 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150, - 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7, - 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27, - 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255, - 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188, - 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171, - 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119, - 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89, - 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87, - 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223 - ); -@E2A = ( - 0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15, - 16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31, - 128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7, - 144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26, - 32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124, - 38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94, - 45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63, - 248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34, - 216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177, - 176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164, - 181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174, - 172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215, - 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245, - 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255, - 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213, - 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159 - ); - -if ($EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set - $A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74; - $A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95; - $A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186; - $A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173; - $A2E[249] = 192; - - $E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168; - $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172; - $E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166; - $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125; - $E2A[255] = 126; - } -elsif ($EBCDIC && ord('^') == 176) { # as in codepage 037 on os400 - $A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176; - $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173; - - $E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221; - $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168; -} - -# Smart rearrangement of parameters to allow named parameter -# calling. We do the rearangement if: -# the first parameter begins with a - -sub rearrange { - my($order,@param) = @_; - return () unless @param; - - if (ref($param[0]) eq 'HASH') { - @param = %{$param[0]}; - } else { - return @param - unless (defined($param[0]) && substr($param[0],0,1) eq '-'); - } - - # map parameters into positional indices - my ($i,%pos); - $i = 0; - foreach (@$order) { - foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; } - $i++; - } - - my (@result,%leftover); - $#result = $#$order; # preextend - while (@param) { - my $key = lc(shift(@param)); - $key =~ s/^\-//; - if (exists $pos{$key}) { - $result[$pos{$key}] = shift(@param); - } else { - $leftover{$key} = shift(@param); - } - } - - push (@result,make_attributes(\%leftover,1)) if %leftover; - @result; -} - -sub make_attributes { - my $attr = shift; - return () unless $attr && ref($attr) && ref($attr) eq 'HASH'; - my $escape = shift || 0; - my(@att); - foreach (keys %{$attr}) { - my($key) = $_; - $key=~s/^\-//; # get rid of initial - if present - - # old way: breaks EBCDIC! - # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes - - ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes - - my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_}; - push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/); - } - return @att; -} - -sub simple_escape { - return unless defined(my $toencode = shift); - $toencode =~ s{&}{&}gso; - $toencode =~ s{<}{<}gso; - $toencode =~ s{>}{>}gso; - $toencode =~ s{\"}{"}gso; -# Doesn't work. Can't work. forget it. -# $toencode =~ s{\x8b}{‹}gso; -# $toencode =~ s{\x9b}{›}gso; - $toencode; -} - -sub utf8_chr { - my $c = shift(@_); - - if ($c < 0x80) { - return sprintf("%c", $c); - } elsif ($c < 0x800) { - return sprintf("%c%c", 0xc0 | ($c >> 6), 0x80 | ($c & 0x3f)); - } elsif ($c < 0x10000) { - return sprintf("%c%c%c", - 0xe0 | ($c >> 12), - 0x80 | (($c >> 6) & 0x3f), - 0x80 | ( $c & 0x3f)); - } elsif ($c < 0x200000) { - return sprintf("%c%c%c%c", - 0xf0 | ($c >> 18), - 0x80 | (($c >> 12) & 0x3f), - 0x80 | (($c >> 6) & 0x3f), - 0x80 | ( $c & 0x3f)); - } elsif ($c < 0x4000000) { - return sprintf("%c%c%c%c%c", - 0xf8 | ($c >> 24), - 0x80 | (($c >> 18) & 0x3f), - 0x80 | (($c >> 12) & 0x3f), - 0x80 | (($c >> 6) & 0x3f), - 0x80 | ( $c & 0x3f)); - - } elsif ($c < 0x80000000) { - return sprintf("%c%c%c%c%c%c", - 0xfc | ($c >> 30), - 0x80 | (($c >> 24) & 0x3f), - 0x80 | (($c >> 18) & 0x3f), - 0x80 | (($c >> 12) & 0x3f), - 0x80 | (($c >> 6) & 0x3f), - 0x80 | ( $c & 0x3f)); - } else { - return utf8_chr(0xfffd); - } -} - -# unescape URL-encoded data -sub unescape { - shift() if @_ > 1 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass)); - my $todecode = shift; - return undef unless defined($todecode); - $todecode =~ tr/+/ /; # pluses become spaces - $EBCDIC = "\t" ne "\011"; - if ($EBCDIC) { - $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge; - } else { - $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/ - defined($1)? chr hex($1) : utf8_chr(hex($2))/ge; - } - return $todecode; -} - -# URL-encode data -sub escape { - shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass)); - my $toencode = shift; - return undef unless defined($toencode); - # force bytes while preserving backward compatibility -- dankogai - $toencode = pack("C*", unpack("C*", $toencode)); - if ($EBCDIC) { - $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg; - } else { - $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg; - } - return $toencode; -} - -# This internal routine creates date strings suitable for use in -# cookies and HTTP headers. (They differ, unfortunately.) -# Thanks to Mark Fisher for this. -sub expires { - my($time,$format) = @_; - $format ||= 'http'; - - my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; - my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; - - # pass through preformatted dates for the sake of expire_calc() - $time = expire_calc($time); - return $time unless $time =~ /^\d+$/; - - # make HTTP/cookie date string from GMT'ed time - # (cookies use '-' as date separator, HTTP uses ' ') - my($sc) = ' '; - $sc = '-' if $format eq "cookie"; - my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time); - $year += 1900; - return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT", - $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); -} - -# This internal routine creates an expires time exactly some number of -# hours from the current time. It incorporates modifications from -# Mark Fisher. -sub expire_calc { - my($time) = @_; - my(%mult) = ('s'=>1, - 'm'=>60, - 'h'=>60*60, - 'd'=>60*60*24, - 'M'=>60*60*24*30, - 'y'=>60*60*24*365); - # format for time can be in any of the forms... - # "now" -- expire immediately - # "+180s" -- in 180 seconds - # "+2m" -- in 2 minutes - # "+12h" -- in 12 hours - # "+1d" -- in 1 day - # "+3M" -- in 3 months - # "+2y" -- in 2 years - # "-3m" -- 3 minutes ago(!) - # If you don't supply one of these forms, we assume you are - # specifying the date yourself - my($offset); - if (!$time || (lc($time) eq 'now')) { - $offset = 0; - } elsif ($time=~/^\d+/) { - return $time; - } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) { - $offset = ($mult{$2} || 1)*$1; - } else { - return $time; - } - return (time+$offset); -} - -sub ebcdic2ascii { - my $data = shift; - $data =~ s/(.)/chr $E2A[ord($1)]/ge; - $data; -} - -sub ascii2ebcdic { - my $data = shift; - $data =~ s/(.)/chr $A2E[ord($1)]/ge; - $data; -} - -1; - -__END__ - -=head1 NAME - -CGI::Util - Internal utilities used by CGI module - -=head1 SYNOPSIS - -none - -=head1 DESCRIPTION - -no public subroutines - -=head1 AUTHOR INFORMATION - -Copyright 1995-1998, Lincoln D. Stein. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -Address bug reports and comments to: lstein@cshl.org. When sending -bug reports, please provide the version of CGI.pm, the version of -Perl, the name and version of your Web server, and the name and -version of the operating system you are using. If the problem is even -remotely browser dependent, please provide information about the -affected browers as well. - -=head1 SEE ALSO - -L<CGI> - -=cut diff --git a/lib/Config/Tiny.pm b/lib/Config/Tiny.pm deleted file mode 100644 index c543756..0000000 --- a/lib/Config/Tiny.pm +++ /dev/null @@ -1,248 +0,0 @@ -package Config::Tiny;
-
-# If you thought Config::Simple was small...
-
-use 5.004;
-use strict;
-
-use vars qw{$VERSION $errstr};
-BEGIN {
- $VERSION = '2.00';
- $errstr = '';
-}
-
-# Create an empty object
-sub new { bless {}, shift }
-
-# Create an object from a file
-sub read {
- my $class = ref $_[0] ? ref shift : shift;
-
- # Check the file
- my $file = shift or return $class->_error( 'You did not specify a file name' );
- return $class->_error( "File '$file' does not exist" ) unless -e $file;
- return $class->_error( "'$file' is a directory, not a file" ) unless -f _;
- return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;
-
- # Slurp in the file
- local $/ = undef;
- open CFG, $file or return $class->_error( "Failed to open file '$file': $!" );
- my $contents = <CFG>;
- close CFG;
-
- $class->read_string( $contents );
-}
-
-# Create an object from a string
-sub read_string {
- my $class = ref $_[0] ? ref shift : shift;
- my $self = bless {}, $class;
- return undef unless defined $_[0];
-
- # Parse the file
- my $ns = '_';
- my $counter = 0;
- foreach ( split /(?:\015{1,2}\012|\015|\012)/, shift ) {
- $counter++;
-
- # Skip comments and empty lines
- next if /^\s*(?:\#|\;|$)/;
-
- # Handle section headers
- if ( /^\s*\[(.+?)\]\s*$/ ) {
- # Create the sub-hash if it doesn't exist.
- # Without this sections without keys will not
- # appear at all in the completed struct.
- $ns = $1;
- $self->{$ns} = {};
- next;
- }
-
- # Handle properties
- if ( /^\s*([^=]+?)\s*=\s*(.*?)\s*$/ ) {
- $self->{$ns}->{$1} = $2;
- next;
- }
-
- return $self->_error( "Syntax error at line $counter: '$_'" );
- }
-
- $self;
-}
-
-# Save an object to a file
-sub write {
- my $self = shift;
- my $file = shift or return $self->_error( 'No file name provided' );
-
- # Write it to the file
- open( CFG, '>', $file )
- or return $self->_error( "Failed to open file '$file' for writing: $!" );
- print CFG $self->write_string;
- close CFG;
-}
-
-# Save an object to a string
-sub write_string {
- my $self = shift;
-
- my $contents = '';
- foreach my $section ( sort { (($b eq '_') <=> ($a eq '_')) || ($a cmp $b) } keys %$self ) {
- my $block = $self->{$section};
- $contents .= "\n" if length $contents;
- $contents .= "[$section]\n" unless $section eq '_';
- foreach my $property ( sort keys %$block ) {
- $contents .= "$property=$block->{$property}\n";
- }
- }
-
- $contents;
-}
-
-# Error handling
-sub errstr { $errstr }
-sub _error { $errstr = $_[1]; undef }
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-Config::Tiny - Read/Write .ini style files with as little code as possible
-
-=head1 SYNOPSIS
-
- # In your configuration file
- rootproperty=blah
-
- [section]
- one=twp
- three= four
- Foo =Bar
- empty=
-
- # In your program
- use Config::Tiny;
-
- # Create a config
- my $Config = Config::Tiny->new();
-
- # Open the config
- $Config = Config::Tiny->read( 'file.conf' );
-
- # Reading properties
- my $rootproperty = $Config->{_}->{rootproperty};
- my $one = $Config->{section}->{one};
- my $Foo = $Config->{section}->{Foo};
-
- # Changing data
- $Config->{newsection} = { this => 'that' }; # Add a section
- $Config->{section}->{Foo} = 'Not Bar!'; # Change a value
- delete $Config->{_}; # Delete a value or section
-
- # Save a config
- $Config->write( 'file.conf' );
-
-=head1 DESCRIPTION
-
-Config::Tiny is a perl class to read and write .ini style configuration files
-with as little code as possible, reducing load time and memory overhead.
-Memory usage is normally scoffed at in Perl, but in my opinion should be
-at least kept in mind.
-
-This module is primarily for reading human written files, and anything we
-write shouldn't need to have documentation/comments. If you need something
-with more power, move up to Config::Simple, Config::General or one of the
-many other Config:: modules. To rephrase, Config::Tiny does not preserve
-your comments, whitespace, or the order of your config file.
-
-=head1 CONFIGURATION FILE SYNTAX
-
-Files are the same as windows .ini files, for example.
-
- [section]
- var1=value1
- var2=value2
-
-If a property is outside of a section, it will be assigned to the root
-section, available at C<$Config-E<gt>{_}>.
-
-Lines starting with '#' or ';' are comments, and blank lines are ignored.
-
-When writing back to the config file, any comments are discarded.
-
-=head1 METHODS
-
-=head2 new
-
-The constructor C<new> creates and returns an empty Config::Tiny object.
-
-=head2 read $filename
-
-The C<read> constructor reads a config file, and returns a new Config::Tiny
-object containing the properties in the file.
-
-Returns the object on success, or C<undef> on error.
-
-=head2 read_string $string;
-
-The C<read_string> method takes as argument the contents of a config file as a string
-and returns the Config::Tiny object for it.
-
-=head2 write
-
-The C<write $filename> generates the file for the properties, and writes it
-to disk.
-
-Returns true on success or C<undef> on error.
-
-=head2 write_string
-
-Generates the file for the object and returns it as a string.
-
-=head2 errstr
-
-When an error occurs, you can retrieve the error message either from the
-C<$Config::Tiny::errstr> variable, or using the C<errstr()> method.
-
-=head1 SUPPORT
-
-Bugs should be reported via the CPAN bug tracker at
-
- http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Config%3A%3ATiny
-
-For other issues, contact the author
-
-=head1 TO DO
-
-I'm debating adding a get and set method to get or set a section.key based
-value...
-
-Implementation is left as an exercise for the reader.
-
-=head1 AUTHOR
-
- Adam Kennedy ( maintainer )
- cpan@ali.as
- http://ali.as/
-
-Thanks to Sherzod Ruzmetov <sherzodr@cpan.org> for Config::Simple,
-which inspired this module by being not quite "simple" enough for me :)
-
-=head1 SEE ALSO
-
-L<Config::Simple>, L<Config::General>
-
-=head1 COPYRIGHT
-
-Copyright 2002-2004 Adam Kennedy. All rights reserved.
-This program is free software; you can redistribute
-it and/or modify it under the same terms as Perl itself.
-
-The full text of the license can be found in the
-LICENSE file included with this module.
-
-=cut
diff --git a/lib/Date/Manip.pm b/lib/Date/Manip.pm deleted file mode 100644 index 7a3f810..0000000 --- a/lib/Date/Manip.pm +++ /dev/null @@ -1,7362 +0,0 @@ -package Date::Manip; -# Copyright (c) 1995-2003 Sullivan Beck. All rights reserved. -# This program is free software; you can redistribute it and/or modify it -# under the same terms as Perl itself. - -########################################################################### -########################################################################### - -use vars qw($OS %Lang %Holiday %Events %Curr %Cnf %Zone $VERSION @ISA @EXPORT); - -# Determine the type of OS... -$OS="Unix"; -$OS="Windows" if ((defined $^O and - $^O =~ /MSWin32/i || - $^O =~ /Windows_95/i || - $^O =~ /Windows_NT/i) || - (defined $ENV{OS} and - $ENV{OS} =~ /MSWin32/i || - $ENV{OS} =~ /Windows_95/i || - $ENV{OS} =~ /Windows_NT/i)); -$OS="Netware" if (defined $^O and - $^O =~ /NetWare/i); -$OS="Mac" if ((defined $^O and - $^O =~ /MacOS/i) || - (defined $ENV{OS} and - $ENV{OS} =~ /MacOS/i)); -$OS="MPE" if (defined $^O and - $^O =~ /MPE/i); -$OS="OS2" if (defined $^O and - $^O =~ /os2/i); -$OS="VMS" if (defined $^O and - $^O =~ /VMS/i); - -# Determine if we're doing taint checking -$Date::Manip::NoTaint = eval { local $^W; unlink "$^X$^T"; 1 }; - -########################################################################### -# CUSTOMIZATION -########################################################################### -# -# See the section of the POD documentation section CUSTOMIZING DATE::MANIP -# below for a complete description of each of these variables. - - -# Location of a the global config file. Tilde (~) expansions are allowed. -# This should be set in Date_Init arguments. -$Cnf{"GlobalCnf"}=""; -$Cnf{"IgnoreGlobalCnf"}=""; - -# Name of a personal config file and the path to search for it. Tilde (~) -# expansions are allowed. This should be set in Date_Init arguments or in -# the global config file. - -@Date::Manip::DatePath=(); -if ($OS eq "Windows") { - $Cnf{"PathSep"} = ";"; - $Cnf{"PersonalCnf"} = "Manip.cnf"; - $Cnf{"PersonalCnfPath"} = "."; - -} elsif ($OS eq "Netware") { - $Cnf{"PathSep"} = ";"; - $Cnf{"PersonalCnf"} = "Manip.cnf"; - $Cnf{"PersonalCnfPath"} = "."; - -} elsif ($OS eq "MPE") { - $Cnf{"PathSep"} = ":"; - $Cnf{"PersonalCnf"} = "Manip.cnf"; - $Cnf{"PersonalCnfPath"} = "."; - -} elsif ($OS eq "OS2") { - $Cnf{"PathSep"} = ":"; - $Cnf{"PersonalCnf"} = "Manip.cnf"; - $Cnf{"PersonalCnfPath"} = "."; - -} elsif ($OS eq "Mac") { - $Cnf{"PathSep"} = ":"; - $Cnf{"PersonalCnf"} = "Manip.cnf"; - $Cnf{"PersonalCnfPath"} = "."; - -} elsif ($OS eq "VMS") { - # VMS doesn't like files starting with "." - $Cnf{"PathSep"} = "\n"; - $Cnf{"PersonalCnf"} = "Manip.cnf"; - $Cnf{"PersonalCnfPath"} = ".\n~"; - -} else { - # Unix - $Cnf{"PathSep"} = ":"; - $Cnf{"PersonalCnf"} = ".DateManip.cnf"; - $Cnf{"PersonalCnfPath"} = ".:~"; - @Date::Manip::DatePath=qw(/bin /usr/bin /usr/local/bin); -} - -### Date::Manip variables set in the global or personal config file - -# Which language to use when parsing dates. -$Cnf{"Language"}="English"; - -# 12/10 = Dec 10 (US) or Oct 12 (anything else) -$Cnf{"DateFormat"}="US"; - -# Local timezone -$Cnf{"TZ"}=""; - -# Timezone to work in (""=local, "IGNORE", or a timezone) -$Cnf{"ConvTZ"}=""; - -# Date::Manip internal format (0=YYYYMMDDHH:MN:SS, 1=YYYYHHMMDDHHMNSS) -$Cnf{"Internal"}=0; - -# First day of the week (1=monday, 7=sunday). ISO 8601 says monday. -$Cnf{"FirstDay"}=1; - -# First and last day of the work week (1=monday, 7=sunday) -$Cnf{"WorkWeekBeg"}=1; -$Cnf{"WorkWeekEnd"}=5; - -# If non-nil, a work day is treated as 24 hours long (WorkDayBeg/WorkDayEnd -# ignored) -$Cnf{"WorkDay24Hr"}=0; - -# Start and end time of the work day (any time format allowed, seconds -# ignored) -$Cnf{"WorkDayBeg"}="08:00"; -$Cnf{"WorkDayEnd"}="17:00"; - -# If "today" is a holiday, we look either to "tomorrow" or "yesterday" for -# the nearest business day. By default, we'll always look "tomorrow" -# first. -$Cnf{"TomorrowFirst"}=1; - -# Erase the old holidays -$Cnf{"EraseHolidays"}=""; - -# Set this to non-zero to be produce completely backwards compatible deltas -$Cnf{"DeltaSigns"}=0; - -# If this is 0, use the ISO 8601 standard that Jan 4 is in week 1. If 1, -# make week 1 contain Jan 1. -$Cnf{"Jan1Week1"}=0; - -# 2 digit years fall into the 100 year period given by [ CURR-N, -# CURR+(99-N) ] where N is 0-99. Default behavior is 89, but other useful -# numbers might be 0 (forced to be this year or later) and 99 (forced to be -# this year or earlier). It can also be set to "c" (current century) or -# "cNN" (i.e. c18 forces the year to bet 1800-1899). Also accepts the -# form cNNNN to give the 100 year period NNNN to NNNN+99. -$Cnf{"YYtoYYYY"}=89; - -# Set this to 1 if you want a long-running script to always update the -# timezone. This will slow Date::Manip down. Read the POD documentation. -$Cnf{"UpdateCurrTZ"}=0; - -# Use an international character set. -$Cnf{"IntCharSet"}=0; - -# Use this to force the current date to be set to this: -$Cnf{"ForceDate"}=""; - -########################################################################### - -require 5.000; -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw( - DateManipVersion - Date_Init - ParseDateString - ParseDate - ParseRecur - Date_Cmp - DateCalc - ParseDateDelta - UnixDate - Delta_Format - Date_GetPrev - Date_GetNext - Date_SetTime - Date_SetDateField - Date_IsHoliday - Events_List - - Date_DaysInMonth - Date_DayOfWeek - Date_SecsSince1970 - Date_SecsSince1970GMT - Date_DaysSince1BC - Date_DayOfYear - Date_DaysInYear - Date_WeekOfYear - Date_LeapYear - Date_DaySuffix - Date_ConvTZ - Date_TimeZone - Date_IsWorkDay - Date_NextWorkDay - Date_PrevWorkDay - Date_NearestWorkDay - Date_NthDayOfYear -); -use strict; -use integer; -use Carp; - -use IO::File; - -$VERSION="5.42"; - -######################################################################## -######################################################################## - -$Curr{"InitLang"} = 1; # Whether a language is being init'ed -$Curr{"InitDone"} = 0; # Whether Init_Date has been called -$Curr{"InitFilesRead"} = 0; -$Curr{"ResetWorkDay"} = 1; -$Curr{"Debug"} = ""; -$Curr{"DebugVal"} = ""; - -$Holiday{"year"} = 0; -$Holiday{"dates"} = {}; -$Holiday{"desc"} = {}; - -$Events{"raw"} = []; -$Events{"parsed"} = 0; -$Events{"dates"} = []; -$Events{"recur"} = []; - -######################################################################## -######################################################################## -# THESE ARE THE MAIN ROUTINES -######################################################################## -######################################################################## - -# Get rid of a problem with old versions of perl -no strict "vars"; -# This sorts from longest to shortest element -sub sortByLength { - return (length $b <=> length $a); -} -use strict "vars"; - -sub DateManipVersion { - print "DEBUG: DateManipVersion\n" if ($Curr{"Debug"} =~ /trace/); - return $VERSION; -} - -sub Date_Init { - print "DEBUG: Date_Init\n" if ($Curr{"Debug"} =~ /trace/); - $Curr{"Debug"}=""; - - my(@args)=@_; - $Curr{"InitDone"}=1; - local($_)=(); - my($internal,$firstday)=(); - my($var,$val,$file,@tmp)=(); - - # InitFilesRead = 0 : no conf files read yet - # 1 : global read, no personal read - # 2 : personal read - - $Cnf{"EraseHolidays"}=0; - foreach (@args) { - s/\s*$//; - s/^\s*//; - /^(\S+) \s* = \s* (.+)$/x; - ($var,$val)=($1,$2); - if ($var =~ /^GlobalCnf$/i) { - $Cnf{"GlobalCnf"}=$val; - if ($val) { - $Curr{"InitFilesRead"}=0; - &EraseHolidays(); - } - } elsif ($var =~ /^PathSep$/i) { - $Cnf{"PathSep"}=$val; - } elsif ($var =~ /^PersonalCnf$/i) { - $Cnf{"PersonalCnf"}=$val; - $Curr{"InitFilesRead"}=1 if ($Curr{"InitFilesRead"}==2); - } elsif ($var =~ /^PersonalCnfPath$/i) { - $Cnf{"PersonalCnfPath"}=$val; - $Curr{"InitFilesRead"}=1 if ($Curr{"InitFilesRead"}==2); - } elsif ($var =~ /^IgnoreGlobalCnf$/i) { - $Curr{"InitFilesRead"}=1 if ($Curr{"InitFilesRead"}==0); - $Cnf{"IgnoreGlobalCnf"}=1; - } elsif ($var =~ /^EraseHolidays$/i) { - &EraseHolidays(); - } else { - push(@tmp,$_); - } - } - @args=@tmp; - - # Read global config file - if ($Curr{"InitFilesRead"}<1 && ! $Cnf{"IgnoreGlobalCnf"}) { - $Curr{"InitFilesRead"}=1; - - if ($Cnf{"GlobalCnf"}) { - $file=&ExpandTilde($Cnf{"GlobalCnf"}); - &Date_InitFile($file) if ($file); - } - } - - # Read personal config file - if ($Curr{"InitFilesRead"}<2) { - $Curr{"InitFilesRead"}=2; - - if ($Cnf{"PersonalCnf"} and $Cnf{"PersonalCnfPath"}) { - $file=&SearchPath($Cnf{"PersonalCnf"},$Cnf{"PersonalCnfPath"},"r"); - &Date_InitFile($file) if ($file); - } - } - - foreach (@args) { - s/\s*$//; - s/^\s*//; - /^(\S+) \s* = \s* (.*)$/x; - ($var,$val)=($1,$2); - $val="" if (! defined $val); - &Date_SetConfigVariable($var,$val); - } - - confess "ERROR: Unknown FirstDay in Date::Manip.\n" - if (! &IsInt($Cnf{"FirstDay"},1,7)); - confess "ERROR: Unknown WorkWeekBeg in Date::Manip.\n" - if (! &IsInt($Cnf{"WorkWeekBeg"},1,7)); - confess "ERROR: Unknown WorkWeekEnd in Date::Manip.\n" - if (! &IsInt($Cnf{"WorkWeekEnd"},1,7)); - confess "ERROR: Invalid WorkWeek in Date::Manip.\n" - if ($Cnf{"WorkWeekEnd"} <= $Cnf{"WorkWeekBeg"}); - - my(%lang, - $tmp,%tmp,$tmp2,@tmp2, - $i,$j,@tmp3, - $zonesrfc,@zones)=(); - - my($L)=$Cnf{"Language"}; - - if ($Curr{"InitLang"}) { - $Curr{"InitLang"}=0; - - if ($L eq "English") { - &Date_Init_English(\%lang); - - } elsif ($L eq "French") { - &Date_Init_French(\%lang); - - } elsif ($L eq "Swedish") { - &Date_Init_Swedish(\%lang); - - } elsif ($L eq "German") { - &Date_Init_German(\%lang); - - } elsif ($L eq "Polish") { - &Date_Init_Polish(\%lang); - - } elsif ($L eq "Dutch" || - $L eq "Nederlands") { - &Date_Init_Dutch(\%lang); - - } elsif ($L eq "Spanish") { - &Date_Init_Spanish(\%lang); - - } elsif ($L eq "Portuguese") { - &Date_Init_Portuguese(\%lang); - - } elsif ($L eq "Romanian") { - &Date_Init_Romanian(\%lang); - - } elsif ($L eq "Italian") { - &Date_Init_Italian(\%lang); - - } elsif ($L eq "Russian") { - &Date_Init_Russian(\%lang); - - } elsif ($L eq "Turkish") { - &Date_Init_Turkish(\%lang); - - } elsif ($L eq "Danish") { - &Date_Init_Danish(\%lang); - - } else { - confess "ERROR: Unknown language in Date::Manip.\n"; - } - - # variables for months - # Month = "(jan|january|feb|february ... )" - # MonL = [ "Jan","Feb",... ] - # MonthL = [ "January","February", ... ] - # MonthH = { "january"=>1, "jan"=>1, ... } - - $Lang{$L}{"MonthH"}={}; - $Lang{$L}{"MonthL"}=[]; - $Lang{$L}{"MonL"}=[]; - &Date_InitLists([$lang{"month_name"}, - $lang{"month_abb"}], - \$Lang{$L}{"Month"},"lc,sort,back", - [$Lang{$L}{"MonthL"}, - $Lang{$L}{"MonL"}], - [$Lang{$L}{"MonthH"},1]); - - # variables for day of week - # Week = "(mon|monday|tue|tuesday ... )" - # WL = [ "M","T",... ] - # WkL = [ "Mon","Tue",... ] - # WeekL = [ "Monday","Tudesday",... ] - # WeekH = { "monday"=>1,"mon"=>1,"m"=>1,... } - - $Lang{$L}{"WeekH"}={}; - $Lang{$L}{"WeekL"}=[]; - $Lang{$L}{"WkL"}=[]; - $Lang{$L}{"WL"}=[]; - &Date_InitLists([$lang{"day_name"}, - $lang{"day_abb"}], - \$Lang{$L}{"Week"},"lc,sort,back", - [$Lang{$L}{"WeekL"}, - $Lang{$L}{"WkL"}], - [$Lang{$L}{"WeekH"},1]); - &Date_InitLists([$lang{"day_char"}], - "","lc", - [$Lang{$L}{"WL"}], - [\%tmp,1]); - %{ $Lang{$L}{"WeekH"} } = - (%{ $Lang{$L}{"WeekH"} },%tmp); - - # variables for last - # Last = "(last)" - # LastL = [ "last" ] - # Each = "(each)" - # EachL = [ "each" ] - # variables for day of month - # DoM = "(1st|first ... 31st)" - # DoML = [ "1st","2nd",... "31st" ] - # DoMH = { "1st"=>1,"first"=>1, ... "31st"=>31 } - # variables for week of month - # WoM = "(1st|first| ... 5th|last)" - # WoMH = { "1st"=>1, ... "5th"=>5,"last"=>-1 } - - $Lang{$L}{"LastL"}=$lang{"last"}; - &Date_InitStrings($lang{"last"}, - \$Lang{$L}{"Last"},"lc,sort"); - - $Lang{$L}{"EachL"}=$lang{"each"}; - &Date_InitStrings($lang{"each"}, - \$Lang{$L}{"Each"},"lc,sort"); - - $Lang{$L}{"DoMH"}={}; - $Lang{$L}{"DoML"}=[]; - &Date_InitLists([$lang{"num_suff"}, - $lang{"num_word"}], - \$Lang{$L}{"DoM"},"lc,sort,back,escape", - [$Lang{$L}{"DoML"}, - \@tmp], - [$Lang{$L}{"DoMH"},1]); - - @tmp=(); - foreach $tmp (keys %{ $Lang{$L}{"DoMH"} }) { - $tmp2=$Lang{$L}{"DoMH"}{$tmp}; - if ($tmp2<6) { - $Lang{$L}{"WoMH"}{$tmp} = $tmp2; - push(@tmp,$tmp); - } - } - foreach $tmp (@{ $Lang{$L}{"LastL"} }) { - $Lang{$L}{"WoMH"}{$tmp} = -1; - push(@tmp,$tmp); - } - &Date_InitStrings(\@tmp,\$Lang{$L}{"WoM"}, - "lc,sort,back,escape"); - - # variables for AM or PM - # AM = "(am)" - # PM = "(pm)" - # AmPm = "(am|pm)" - # AMstr = "AM" - # PMstr = "PM" - - &Date_InitStrings($lang{"am"},\$Lang{$L}{"AM"},"lc,sort,escape"); - &Date_InitStrings($lang{"pm"},\$Lang{$L}{"PM"},"lc,sort,escape"); - &Date_InitStrings([ @{$lang{"am"}},@{$lang{"pm"}} ],\$Lang{$L}{"AmPm"}, - "lc,back,sort,escape"); - $Lang{$L}{"AMstr"}=$lang{"am"}[0]; - $Lang{$L}{"PMstr"}=$lang{"pm"}[0]; - - # variables for expressions used in parsing deltas - # Yabb = "(?:y|yr|year|years)" - # Mabb = similar for months - # Wabb = similar for weeks - # Dabb = similar for days - # Habb = similar for hours - # MNabb = similar for minutes - # Sabb = similar for seconds - # Repl = { "abb"=>"replacement" } - # Whenever an abbreviation could potentially refer to two different - # strings (M standing for Minutes or Months), the abbreviation must - # be listed in Repl instead of in the appropriate Xabb values. This - # only applies to abbreviations which are substrings of other values - # (so there is no confusion between Mn and Month). - - &Date_InitStrings($lang{"years"} ,\$Lang{$L}{"Yabb"}, "lc,sort"); - &Date_InitStrings($lang{"months"} ,\$Lang{$L}{"Mabb"}, "lc,sort"); - &Date_InitStrings($lang{"weeks"} ,\$Lang{$L}{"Wabb"}, "lc,sort"); - &Date_InitStrings($lang{"days"} ,\$Lang{$L}{"Dabb"}, "lc,sort"); - &Date_InitStrings($lang{"hours"} ,\$Lang{$L}{"Habb"}, "lc,sort"); - &Date_InitStrings($lang{"minutes"},\$Lang{$L}{"MNabb"},"lc,sort"); - &Date_InitStrings($lang{"seconds"},\$Lang{$L}{"Sabb"}, "lc,sort"); - $Lang{$L}{"Repl"}={}; - &Date_InitHash($lang{"replace"},undef,"lc",$Lang{$L}{"Repl"}); - - # variables for special dates that are offsets from now - # Now = "(now|today)" - # Offset = "(yesterday|tomorrow)" - # OffsetH = { "yesterday"=>"-0:0:0:1:0:0:0",... ] - # Times = "(noon|midnight)" - # TimesH = { "noon"=>"12:00:00","midnight"=>"00:00:00" } - # SepHM = hour/minute separator - # SepMS = minute/second separator - # SepSS = second/fraction separator - - $Lang{$L}{"TimesH"}={}; - &Date_InitHash($lang{"times"}, - \$Lang{$L}{"Times"},"lc,sort,back", - $Lang{$L}{"TimesH"}); - &Date_InitStrings($lang{"now"},\$Lang{$L}{"Now"},"lc,sort"); - $Lang{$L}{"OffsetH"}={}; - &Date_InitHash($lang{"offset"}, - \$Lang{$L}{"Offset"},"lc,sort,back", - $Lang{$L}{"OffsetH"}); - $Lang{$L}{"SepHM"}=$lang{"sephm"}; - $Lang{$L}{"SepMS"}=$lang{"sepms"}; - $Lang{$L}{"SepSS"}=$lang{"sepss"}; - - # variables for time zones - # zones = regular expression with all zone names (EST) - # n2o = a hash of all parsable zone names with their offsets - # tzones = reguar expression with all tzdata timezones (US/Eastern) - # tz2z = hash of all tzdata timezones to full timezone (EST#EDT) - - $zonesrfc= - "idlw -1200 ". # International Date Line West - "nt -1100 ". # Nome - "hst -1000 ". # Hawaii Standard - "cat -1000 ". # Central Alaska - "ahst -1000 ". # Alaska-Hawaii Standard - "akst -0900 ". # Alaska Standard - "yst -0900 ". # Yukon Standard - "hdt -0900 ". # Hawaii Daylight - "akdt -0800 ". # Alaska Daylight - "ydt -0800 ". # Yukon Daylight - "pst -0800 ". # Pacific Standard - "pdt -0700 ". # Pacific Daylight - "mst -0700 ". # Mountain Standard - "mdt -0600 ". # Mountain Daylight - "cst -0600 ". # Central Standard - "cdt -0500 ". # Central Daylight - "est -0500 ". # Eastern Standard - "act -0500 ". # Brazil, Acre - "sat -0400 ". # Chile - "bot -0400 ". # Bolivia - "amt -0400 ". # Brazil, Amazon - "acst -0400 ". # Brazil, Acre Daylight - "edt -0400 ". # Eastern Daylight - "ast -0400 ". # Atlantic Standard - #"nst -0330 ". # Newfoundland Standard nst=North Sumatra +0630 - "nft -0330 ". # Newfoundland - #"gst -0300 ". # Greenland Standard gst=Guam Standard +1000 - #"bst -0300 ". # Brazil Standard bst=British Summer +0100 - "brt -0300 ". # Brazil Standard (official time) - "brst -0300 ". # Brazil Standard - "adt -0300 ". # Atlantic Daylight - "art -0300 ". # Argentina - "amst -0300 ". # Brazil, Amazon Daylight - "ndt -0230 ". # Newfoundland Daylight - "brst -0200 ". # Brazil Daylight (official time) - "fnt -0200 ". # Brazil, Fernando de Noronha - "at -0200 ". # Azores - "wat -0100 ". # West Africa - "fnst -0100 ". # Brazil, Fernando de Noronha Daylight - "gmt +0000 ". # Greenwich Mean - "ut +0000 ". # Universal - "utc +0000 ". # Universal (Coordinated) - "wet +0000 ". # Western European - "cet +0100 ". # Central European - "fwt +0100 ". # French Winter - "met +0100 ". # Middle European - "mez +0100 ". # Middle European - "mewt +0100 ". # Middle European Winter - "swt +0100 ". # Swedish Winter - "bst +0100 ". # British Summer bst=Brazil standard -0300 - "gb +0100 ". # GMT with daylight savings - "west +0000 ". # Western European Daylight - "eet +0200 ". # Eastern Europe, USSR Zone 1 - "cest +0200 ". # Central European Summer - "fst +0200 ". # French Summer - "ist +0200 ". # Israel standard - "mest +0200 ". # Middle European Summer - "mesz +0200 ". # Middle European Summer - "metdst +0200 ". # An alias for mest used by HP-UX - "sast +0200 ". # South African Standard - "sst +0200 ". # Swedish Summer sst=South Sumatra +0700 - "bt +0300 ". # Baghdad, USSR Zone 2 - "eest +0300 ". # Eastern Europe Summer - "eetedt +0300 ". # Eastern Europe, USSR Zone 1 - "idt +0300 ". # Israel Daylight - "msk +0300 ". # Moscow - "eat +0300 ". # East Africa - "it +0330 ". # Iran - "zp4 +0400 ". # USSR Zone 3 - "msd +0400 ". # Moscow Daylight - "zp5 +0500 ". # USSR Zone 4 - "ist +0530 ". # Indian Standard - "zp6 +0600 ". # USSR Zone 5 - "novst +0600 ". # Novosibirsk time zone, Russia - "nst +0630 ". # North Sumatra nst=Newfoundland Std -0330 - #"sst +0700 ". # South Sumatra, USSR Zone 6 sst=Swedish Summer +0200 - "javt +0700 ". # Java - "hkt +0800 ". # Hong Kong - "sgt +0800 ". # Singapore - "cct +0800 ". # China Coast, USSR Zone 7 - "awst +0800 ". # Australian Western Standard - "wst +0800 ". # West Australian Standard - "pht +0800 ". # Asia Manila - "kst +0900 ". # Republic of Korea - "jst +0900 ". # Japan Standard, USSR Zone 8 - "rok +0900 ". # Republic of Korea - "acst +0930 ". # Australian Central Standard - "cast +0930 ". # Central Australian Standard - "aest +1000 ". # Australian Eastern Standard - "east +1000 ". # Eastern Australian Standard - "gst +1000 ". # Guam Standard, USSR Zone 9 gst=Greenland Std -0300 - "acdt +1030 ". # Australian Central Daylight - "cadt +1030 ". # Central Australian Daylight - "aedt +1100 ". # Australian Eastern Daylight - "eadt +1100 ". # Eastern Australian Daylight - "idle +1200 ". # International Date Line East - "nzst +1200 ". # New Zealand Standard - "nzt +1200 ". # New Zealand - "nzdt +1300 ". # New Zealand Daylight - "z +0000 ". - "a +0100 b +0200 c +0300 d +0400 e +0500 f +0600 g +0700 h +0800 ". - "i +0900 k +1000 l +1100 m +1200 ". - "n -0100 o -0200 p -0300 q -0400 r -0500 s -0600 t -0700 u -0800 ". - "v -0900 w -1000 x -1100 y -1200"; - - $Zone{"n2o"} = {}; - ($Zone{"zones"},%{ $Zone{"n2o"} })= - &Date_Regexp($zonesrfc,"sort,lc,under,back", - "keys"); - - $tmp= - "US/Pacific PST8PDT ". - "US/Mountain MST7MDT ". - "US/Central CST6CDT ". - "US/Eastern EST5EDT ". - "Canada/Pacific PST8PDT ". - "Canada/Mountain MST7MDT ". - "Canada/Central CST6CDT ". - "Canada/Eastern EST5EDT"; - - $Zone{"tz2z"} = {}; - ($Zone{"tzones"},%{ $Zone{"tz2z"} })= - &Date_Regexp($tmp,"lc,under,back","keys"); - $Cnf{"TZ"}=&Date_TimeZone; - - # misc. variables - # At = "(?:at)" - # Of = "(?:in|of)" - # On = "(?:on)" - # Future = "(?:in)" - # Later = "(?:later)" - # Past = "(?:ago)" - # Next = "(?:next)" - # Prev = "(?:last|previous)" - - &Date_InitStrings($lang{"at"}, \$Lang{$L}{"At"}, "lc,sort"); - &Date_InitStrings($lang{"on"}, \$Lang{$L}{"On"}, "lc,sort"); - &Date_InitStrings($lang{"future"},\$Lang{$L}{"Future"}, "lc,sort"); - &Date_InitStrings($lang{"later"}, \$Lang{$L}{"Later"}, "lc,sort"); - &Date_InitStrings($lang{"past"}, \$Lang{$L}{"Past"}, "lc,sort"); - &Date_InitStrings($lang{"next"}, \$Lang{$L}{"Next"}, "lc,sort"); - &Date_InitStrings($lang{"prev"}, \$Lang{$L}{"Prev"}, "lc,sort"); - &Date_InitStrings($lang{"of"}, \$Lang{$L}{"Of"}, "lc,sort"); - - # calc mode variables - # Approx = "(?:approximately)" - # Exact = "(?:exactly)" - # Business = "(?:business)" - - &Date_InitStrings($lang{"exact"}, \$Lang{$L}{"Exact"}, "lc,sort"); - &Date_InitStrings($lang{"approx"}, \$Lang{$L}{"Approx"}, "lc,sort"); - &Date_InitStrings($lang{"business"},\$Lang{$L}{"Business"},"lc,sort"); - - ############### END OF LANGUAGE INITIALIZATION - } - - if ($Curr{"ResetWorkDay"}) { - my($h1,$m1,$h2,$m2)=(); - if ($Cnf{"WorkDay24Hr"}) { - ($Curr{"WDBh"},$Curr{"WDBm"})=(0,0); - ($Curr{"WDEh"},$Curr{"WDEm"})=(24,0); - $Curr{"WDlen"}=24*60; - $Cnf{"WorkDayBeg"}="00:00"; - $Cnf{"WorkDayEnd"}="23:59"; - - } else { - confess "ERROR: Invalid WorkDayBeg in Date::Manip.\n" - if (! (($h1,$m1)=&CheckTime($Cnf{"WorkDayBeg"}))); - $Cnf{"WorkDayBeg"}="$h1:$m1"; - confess "ERROR: Invalid WorkDayEnd in Date::Manip.\n" - if (! (($h2,$m2)=&CheckTime($Cnf{"WorkDayEnd"}))); - $Cnf{"WorkDayEnd"}="$h2:$m2"; - - ($Curr{"WDBh"},$Curr{"WDBm"})=($h1,$m1); - ($Curr{"WDEh"},$Curr{"WDEm"})=($h2,$m2); - - # Work day length = h1:m1 or 0:len (len minutes) - $h1=$h2-$h1; - $m1=$m2-$m1; - if ($m1<0) { - $h1--; - $m1+=60; - } - $Curr{"WDlen"}=$h1*60+$m1; - } - $Curr{"ResetWorkDay"}=0; - } - - # current time - my($s,$mn,$h,$d,$m,$y,$wday,$yday,$isdst,$ampm,$wk)=(); - if ($Cnf{"ForceDate"}=~ - /^(\d{4})-(\d{2})-(\d{2})-(\d{2}):(\d{2}):(\d{2})$/) { - ($y,$m,$d,$h,$mn,$s)=($1,$2,$3,$4,$5,$6); - } else { - ($s,$mn,$h,$d,$m,$y,$wday,$yday,$isdst)=localtime(time); - $y+=1900; - $m++; - } - &Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk); - $Curr{"Y"}=$y; - $Curr{"M"}=$m; - $Curr{"D"}=$d; - $Curr{"H"}=$h; - $Curr{"Mn"}=$mn; - $Curr{"S"}=$s; - $Curr{"AmPm"}=$ampm; - $Curr{"Now"}=&Date_Join($y,$m,$d,$h,$mn,$s); - - $Curr{"Debug"}=$Curr{"DebugVal"}; - - # If we're in array context, let's return a list of config variables - # that could be passed to Date_Init to get the same state as we're - # currently in. - if (wantarray) { - # Some special variables that have to be in a specific order - my(@special)=qw(IgnoreGlobalCnf GlobalCnf PersonalCnf PersonalCnfPath); - my(%tmp)=map { $_,1 } @special; - my(@tmp,$key,$val); - foreach $key (@special) { - $val=$Cnf{$key}; - push(@tmp,"$key=$val"); - } - foreach $key (keys %Cnf) { - next if (exists $tmp{$key}); - $val=$Cnf{$key}; - push(@tmp,"$key=$val"); - } - return @tmp; - } - return (); -} - -sub ParseDateString { - print "DEBUG: ParseDateString\n" if ($Curr{"Debug"} =~ /trace/); - local($_)=@_; - return "" if (! $_); - - my($y,$m,$d,$h,$mn,$s,$i,$wofm,$dofw,$wk,$tmp,$z,$num,$err,$iso,$ampm)=(); - my($date,$z2,$delta,$from,$falsefrom,$to,$which,$midnight)=(); - - # We only need to reinitialize if we have to determine what NOW is. - &Date_Init() if (! $Curr{"InitDone"} or $Cnf{"UpdateCurrTZ"}); - - my($L)=$Cnf{"Language"}; - my($type)=$Cnf{"DateFormat"}; - - # Mode is set in DateCalc. ParseDate only overrides it if the string - # contains a mode. - if ($Lang{$L}{"Exact"} && - s/$Lang{$L}{"Exact"}//) { - $Curr{"Mode"}=0; - } elsif ($Lang{$L}{"Approx"} && - s/$Lang{$L}{"Approx"}//) { - $Curr{"Mode"}=1; - } elsif ($Lang{$L}{"Business"} && - s/$Lang{$L}{"Business"}//) { - $Curr{"Mode"}=2; - } elsif (! exists $Curr{"Mode"}) { - $Curr{"Mode"}=0; - } - - # Unfortunately, some deltas can be parsed as dates. An example is - # 1 second == 1 2nd == 1 2 - # But, some dates can be parsed as deltas. The most important being: - # 1998010101:00:00 - # We'll check to see if a "date" can be parsed as a delta. If so, we'll - # assume that it is a delta (since they are much simpler, it is much - # less likely that we'll mistake a delta for a date than vice versa) - # unless it is an ISO-8601 date. - # - # This is important because we are using DateCalc to test whether a - # string is a date or a delta. Dates are tested first, so we need to - # be able to pass a delta into this routine and have it correctly NOT - # interpreted as a date. - # - # We will insist that the string contain something other than digits and - # colons so that the following will get correctly interpreted as a date - # rather than a delta: - # 12:30 - # 19980101 - - $delta=""; - $delta=&ParseDateDelta($_) if (/[^:0-9]/); - - # Put parse in a simple loop for an easy exit. - PARSE: { - my(@tmp)=&Date_Split($_); - if (@tmp) { - ($y,$m,$d,$h,$mn,$s)=@tmp; - last PARSE; - } - - # Fundamental regular expressions - - my($month)=$Lang{$L}{"Month"}; # (jan|january|...) - my(%month)=%{ $Lang{$L}{"MonthH"} }; # { jan=>1, ... } - my($week)=$Lang{$L}{"Week"}; # (mon|monday|...) - my(%week)=%{ $Lang{$L}{"WeekH"} }; # { mon=>1, monday=>1, ... } - my($wom)=$Lang{$L}{"WoM"}; # (1st|...|fifth|last) - my(%wom)=%{ $Lang{$L}{"WoMH"} }; # { 1st=>1,... fifth=>5,last=>-1 } - my($dom)=$Lang{$L}{"DoM"}; # (1st|first|...31st) - my(%dom)=%{ $Lang{$L}{"DoMH"} }; # { 1st=>1, first=>1, ... } - my($ampmexp)=$Lang{$L}{"AmPm"}; # (am|pm) - my($timeexp)=$Lang{$L}{"Times"}; # (noon|midnight) - my($now)=$Lang{$L}{"Now"}; # (now|today) - my($offset)=$Lang{$L}{"Offset"}; # (yesterday|tomorrow) - my($zone)=$Zone{"zones"} . '(?:\s+|$)'; # (edt|est|...)\s+ - my($day)='\s*'.$Lang{$L}{"Dabb"}; # \s*(?:d|day|days) - my($mabb)='\s*'.$Lang{$L}{"Mabb"}; # \s*(?:mon|month|months) - my($wkabb)='\s*'.$Lang{$L}{"Wabb"}; # \s*(?:w|wk|week|weeks) - my($next)='\s*'.$Lang{$L}{"Next"}; # \s*(?:next) - my($prev)='\s*'.$Lang{$L}{"Prev"}; # \s*(?:last|previous) - my($past)='\s*'.$Lang{$L}{"Past"}; # \s*(?:ago) - my($future)='\s*'.$Lang{$L}{"Future"}; # \s*(?:in) - my($later)='\s*'.$Lang{$L}{"Later"}; # \s*(?:later) - my($at)=$Lang{$L}{"At"}; # (?:at) - my($of)='\s*'.$Lang{$L}{"Of"}; # \s*(?:in|of) - my($on)='(?:\s*'.$Lang{$L}{"On"}.'\s*|\s+)'; - # \s*(?:on)\s* or \s+ - my($last)='\s*'.$Lang{$L}{"Last"}; # \s*(?:last) - my($hm)=$Lang{$L}{"SepHM"}; # : - my($ms)=$Lang{$L}{"SepMS"}; # : - my($ss)=$Lang{$L}{"SepSS"}; # . - - # Other regular expressions - - my($D4)='(\d{4})'; # 4 digits (yr) - my($YY)='(\d{4}|\d{2})'; # 2 or 4 digits (yr) - my($DD)='(\d{2})'; # 2 digits (mon/day/hr/min/sec) - my($D) ='(\d{1,2})'; # 1 or 2 digit (mon/day/hr) - my($FS)="(?:$ss\\d+)?"; # fractional secs - my($sep)='[\/.-]'; # non-ISO8601 m/d/yy separators - # absolute time zone +0700 (GMT) - my($hzone)='(?:[0-1][0-9]|2[0-3])'; # 00 - 23 - my($mzone)='(?:[0-5][0-9])'; # 00 - 59 - my($zone2)='(?:\s*([+-](?:'."$hzone$mzone|$hzone:$mzone|$hzone))". - # +0700 +07:00 -07 - '(?:\s*\([^)]+\))?)'; # (GMT) - - # A regular expression for the time EXCEPT for the hour part - my($mnsec)="$hm$DD(?:$ms$DD$FS)?(?:\\s*$ampmexp)?"; - - # A special regular expression for /YYYY:HH:MN:SS used by Apache - my($apachetime)='(/\d{4}):' . "$DD$hm$DD$ms$DD"; - - my($time)=""; - $ampm=""; - $date=""; - - # Substitute all special time expressions. - if (/(^|[^a-z])$timeexp($|[^a-z])/i) { - $tmp=$2; - $tmp=$Lang{$L}{"TimesH"}{lc($tmp)}; - s/(^|[^a-z])$timeexp($|[^a-z])/$1 $tmp $3/i; - } - - # Remove some punctuation - s/[,]/ /g; - - # Make sure that ...7EST works (i.e. a timezone immediately following - # a digit. - s/(\d)$zone(\s+|$|[0-9])/$1 $2$3/i; - $zone = '\s+'.$zone; - - # Remove the time - $iso=1; - $midnight=0; - $from="24${hm}00(?:${ms}00)?"; - $falsefrom="${hm}24${ms}00"; # Don't trap XX:24:00 - $to="00${hm}00${ms}00"; - $midnight=1 if (!/$falsefrom/ && s/$from/$to/); - - $h=$mn=$s=0; - if (/$D$mnsec/i || /$ampmexp/i) { - $iso=0; - $tmp=0; - $tmp=1 if (/$mnsec$zone2?\s*$/i); # or /$mnsec$zone/ ?? - $tmp=0 if (/$ampmexp/i); - if (s/$apachetime$zone()/$1 /i || - s/$apachetime$zone2?/$1 /i || - s/(^|[^a-z])$at\s*$D$mnsec$zone()/$1 /i || - s/(^|[^a-z])$at\s*$D$mnsec$zone2?/$1 /i || - s/(^|[^0-9])(\d)$mnsec$zone()/$1 /i || - s/(^|[^0-9])(\d)$mnsec$zone2?/$1 /i || - (s/(t)$D$mnsec$zone()/$1 /i and (($iso=-$tmp) || 1)) || - (s/(t)$D$mnsec$zone2?/$1 /i and (($iso=-$tmp) || 1)) || - (s/()$DD$mnsec$zone()/ /i and (($iso=$tmp) || 1)) || - (s/()$DD$mnsec$zone2?/ /i and (($iso=$tmp) || 1)) || - s/(^|$at\s*|\s+)$D()()\s*$ampmexp$zone()/ /i || - s/(^|$at\s*|\s+)$D()()\s*$ampmexp$zone2?/ /i || - 0 - ) { - ($h,$mn,$s,$ampm,$z,$z2)=($2,$3,$4,$5,$6,$7); - if (defined ($z)) { - if ($z =~ /^[+-]\d{2}:\d{2}$/) { - $z=~ s/://; - } elsif ($z =~ /^[+-]\d{2}$/) { - $z .= "00"; - } - } - $time=1; - &Date_TimeCheck(\$h,\$mn,\$s,\$ampm); - $y=$m=$d=""; - # We're going to be calling TimeCheck again below (when we check the - # final date), so get rid of $ampm so that we don't have an error - # due to "15:30:00 PM". It'll get reset below. - $ampm=""; - if (/^\s*$/) { - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - last PARSE; - } - } - } - $time=0 if ($time ne "1"); - s/\s+$//; - s/^\s+//; - - # dateTtime ISO 8601 formats - my($orig)=$_; - s/t$//i if ($iso<0); - - # Parse ISO 8601 dates now (which may still have a zone stuck to it). - if ( ($iso && /^([0-9-]+(?:W[0-9-]+)?)$zone?$/i) || - ($iso && /^([0-9-]+(?:W[0-9-]+)?)$zone2?$/i) || - ($iso && /^([0-9-]+(?:T[0-9-]+)?)$zone?$/i) || - ($iso && /^([0-9-]+(?:T[0-9-]+)?)$zone2?$/i) || - 0) { - - # ISO 8601 dates - ($_,$z,$z2) = ($1,$2); - s,-, ,g; # Change all ISO8601 seps to spaces - s/^\s+//; - s/\s+$//; - - if (/^$D4\s*$DD\s*$DD\s*t?$DD(?:$DD(?:$DD(\d*))?)?$/i || - /^$DD\s+$DD\s*$DD\s*t?$DD(?:$DD(?:$DD(\d*))?)?$/i || - 0 - ) { - # ISO 8601 Dates with times - # YYYYMMDDHHMNSSFFFF... - # YYYYMMDDHHMNSS - # YYYYMMDDHHMN - # YYYYMMDDHH - # YY MMDDHHMNSSFFFF... - # YY MMDDHHMNSS - # YY MMDDHHMN - # YY MMDDHH - ($y,$m,$d,$h,$mn,$s,$tmp)=($1,$2,$3,$4,$5,$6,$7); - if ($h==24 && (! defined $mn || $mn==0) && (! defined $s || $s==0)) { - $h=0; - $midnight=1; - } - $z = "" if (! defined $h); - return "" if ($time && defined $h); - last PARSE; - - } elsif (/^$D4(?:\s*$DD(?:\s*$DD)?)?$/ || - /^$DD(?:\s+$DD(?:\s*$DD)?)?$/) { - # ISO 8601 Dates - # YYYYMMDD - # YYYYMM - # YYYY - # YY MMDD - # YY MM - # YY - ($y,$m,$d)=($1,$2,$3); - last PARSE; - - } elsif (/^$YY\s+$D\s+$D/) { - # YY-M-D - ($y,$m,$d)=($1,$2,$3); - last PARSE; - - } elsif (/^$YY\s*W$DD\s*(\d)?$/i) { - # YY-W##-D - ($y,$wofm,$dofw)=($1,$2,$3); - ($y,$m,$d)=&Date_NthWeekOfYear($y,$wofm,$dofw); - last PARSE; - - } elsif (/^$D4\s*(\d{3})$/ || - /^$DD\s*(\d{3})$/) { - # YYDOY - ($y,$which)=($1,$2); - ($y,$m,$d)=&Date_NthDayOfYear($y,$which); - last PARSE; - - } elsif ($iso<0) { - # We confused something like 1999/August12:00:00 - # with a dateTtime format - $_=$orig; - - } else { - return ""; - } - } - - # All deltas that are not ISO-8601 dates are NOT dates. - return "" if ($Curr{"InCalc"} && $delta); - if ($delta) { - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - return &DateCalc_DateDelta($Curr{"Now"},$delta); - } - - # Check for some special types of dates (next, prev) - foreach $from (keys %{ $Lang{$L}{"Repl"} }) { - $to=$Lang{$L}{"Repl"}{$from}; - s/(^|[^a-z])$from($|[^a-z])/$1$to$2/i; - } - if (/$wom/i || /$future/i || /$later/i || /$past/i || - /$next/i || /$prev/i || /^$week$/i || /$wkabb/i) { - $tmp=0; - - if (/^$wom\s*$week$of\s*$month\s*$YY?$/i) { - # last friday in October 95 - ($wofm,$dofw,$m,$y)=($1,$2,$3,$4); - # fix $m, $y - return "" if (&Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk)); - $dofw=$week{lc($dofw)}; - $wofm=$wom{lc($wofm)}; - # Get the first day of the month - $date=&Date_Join($y,$m,1,$h,$mn,$s); - if ($wofm==-1) { - $date=&DateCalc_DateDelta($date,"+0:1:0:0:0:0:0",\$err,0); - $date=&Date_GetPrev($date,$dofw,0); - } else { - for ($i=0; $i<$wofm; $i++) { - if ($i==0) { - $date=&Date_GetNext($date,$dofw,1); - } else { - $date=&Date_GetNext($date,$dofw,0); - } - } - } - last PARSE; - - } elsif (/^$last$day$of\s*$month(?:$of?\s*$YY)?/i) { - # last day in month - ($m,$y)=($1,$2); - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $y=&Date_FixYear($y) if (! defined $y or length($y)<4); - $m=$month{lc($m)}; - $d=&Date_DaysInMonth($m,$y); - last PARSE; - - } elsif (/^$week$/i) { - # friday - ($dofw)=($1); - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&Date_GetPrev($Curr{"Now"},$Cnf{"FirstDay"},1); - $date=&Date_GetNext($date,$dofw,1,$h,$mn,$s); - last PARSE; - - } elsif (/^$next\s*$week$/i) { - # next friday - ($dofw)=($1); - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&Date_GetNext($Curr{"Now"},$dofw,0,$h,$mn,$s); - last PARSE; - - } elsif (/^$prev\s*$week$/i) { - # last friday - ($dofw)=($1); - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&Date_GetPrev($Curr{"Now"},$dofw,0,$h,$mn,$s); - last PARSE; - - } elsif (/^$next$wkabb$/i) { - # next week - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&DateCalc_DateDelta($Curr{"Now"},"+0:0:1:0:0:0:0",\$err,0); - $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); - last PARSE; - } elsif (/^$prev$wkabb$/i) { - # last week - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&DateCalc_DateDelta($Curr{"Now"},"-0:0:1:0:0:0:0",\$err,0); - $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); - last PARSE; - - } elsif (/^$next$mabb$/i) { - # next month - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&DateCalc_DateDelta($Curr{"Now"},"+0:1:0:0:0:0:0",\$err,0); - $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); - last PARSE; - } elsif (/^$prev$mabb$/i) { - # last month - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&DateCalc_DateDelta($Curr{"Now"},"-0:1:0:0:0:0:0",\$err,0); - $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); - last PARSE; - - } elsif (/^$future\s*(\d+)$day$/i || - /^(\d+)$day$later$/i) { - # in 2 days - # 2 days later - ($num)=($1); - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&DateCalc_DateDelta($Curr{"Now"},"+0:0:0:$num:0:0:0", - \$err,0); - $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); - last PARSE; - } elsif (/^(\d+)$day$past$/i) { - # 2 days ago - ($num)=($1); - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&DateCalc_DateDelta($Curr{"Now"},"-0:0:0:$num:0:0:0", - \$err,0); - $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); - last PARSE; - - } elsif (/^$future\s*(\d+)$wkabb$/i || - /^(\d+)$wkabb$later$/i) { - # in 2 weeks - # 2 weeks later - ($num)=($1); - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&DateCalc_DateDelta($Curr{"Now"},"+0:0:$num:0:0:0:0", - \$err,0); - $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); - last PARSE; - } elsif (/^(\d+)$wkabb$past$/i) { - # 2 weeks ago - ($num)=($1); - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&DateCalc_DateDelta($Curr{"Now"},"-0:0:$num:0:0:0:0", - \$err,0); - $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); - last PARSE; - - } elsif (/^$future\s*(\d+)$mabb$/i || - /^(\d+)$mabb$later$/i) { - # in 2 months - # 2 months later - ($num)=($1); - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&DateCalc_DateDelta($Curr{"Now"},"+0:$num:0:0:0:0:0", - \$err,0); - $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); - last PARSE; - } elsif (/^(\d+)$mabb$past$/i) { - # 2 months ago - ($num)=($1); - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&DateCalc_DateDelta($Curr{"Now"},"-0:$num:0:0:0:0:0", - \$err,0); - $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); - last PARSE; - - } elsif (/^$week$future\s*(\d+)$wkabb$/i || - /^$week\s*(\d+)$wkabb$later$/i) { - # friday in 2 weeks - # friday 2 weeks later - ($dofw,$num)=($1,$2); - $tmp="+"; - } elsif (/^$week\s*(\d+)$wkabb$past$/i) { - # friday 2 weeks ago - ($dofw,$num)=($1,$2); - $tmp="-"; - } elsif (/^$future\s*(\d+)$wkabb$on$week$/i || - /^(\d+)$wkabb$later$on$week$/i) { - # in 2 weeks on friday - # 2 weeks later on friday - ($num,$dofw)=($1,$2); - $tmp="+" - } elsif (/^(\d+)$wkabb$past$on$week$/i) { - # 2 weeks ago on friday - ($num,$dofw)=($1,$2); - $tmp="-"; - } elsif (/^$week\s*$wkabb$/i) { - # monday week (British date: in 1 week on monday) - $dofw=$1; - $num=1; - $tmp="+"; - } elsif (/^$now\s*$wkabb$/i) { - # today week (British date: 1 week from today) - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&DateCalc_DateDelta($Curr{"Now"},"+0:0:1:0:0:0:0",\$err,0); - $date=&Date_SetTime($date,$h,$mn,$s) if (defined $h); - last PARSE; - } elsif (/^$offset\s*$wkabb$/i) { - # tomorrow week (British date: 1 week from tomorrow) - ($offset)=($1); - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $offset=$Lang{$L}{"OffsetH"}{lc($offset)}; - $date=&DateCalc_DateDelta($Curr{"Now"},$offset,\$err,0); - $date=&DateCalc_DateDelta($date,"+0:0:1:0:0:0:0",\$err,0); - if ($time) { - return "" - if (&Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk)); - $date=&Date_SetTime($date,$h,$mn,$s); - } - last PARSE; - } - - if ($tmp) { - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=&DateCalc_DateDelta($Curr{"Now"}, - $tmp . "0:0:$num:0:0:0:0",\$err,0); - $date=&Date_GetPrev($date,$Cnf{"FirstDay"},1); - $date=&Date_GetNext($date,$dofw,1,$h,$mn,$s); - last PARSE; - } - } - - # Change (2nd, second) to 2 - $tmp=0; - if (/(^|[^a-z0-9])$dom($|[^a-z0-9])/i) { - if (/^\s*$dom\s*$/) { - ($d)=($1); - $d=$dom{lc($d)}; - $m=$Curr{"M"}; - last PARSE; - } - my $from = $2; - my $to = $dom{ lc($from) }; - s/(^|[^a-z])$from($|[^a-z])/$1 $to $2/i; - s/^\s+//; - s/\s+$//; - } - - # Another set of special dates (Nth week) - if (/^$D\s*$week(?:$of?\s*$YY)?$/i) { - # 22nd sunday in 1996 - ($which,$dofw,$y)=($1,$2,$3); - $y=$Curr{"Y"} if (! $y); - $y--; # previous year - $tmp=&Date_GetNext("$y-12-31",$dofw,0); - if ($which>1) { - $tmp=&DateCalc_DateDelta($tmp,"+0:0:".($which-1).":0:0:0:0",\$err,0); - } - ($y,$m,$d)=(&Date_Split($tmp, 1))[0..2]; - last PARSE; - } elsif (/^$week$wkabb\s*$D(?:$of?\s*$YY)?$/i || - /^$week\s*$D$wkabb(?:$of?\s*$YY)?$/i) { - # sunday week 22 in 1996 - # sunday 22nd week in 1996 - ($dofw,$which,$y)=($1,$2,$3); - ($y,$m,$d)=&Date_NthWeekOfYear($y,$which,$dofw); - last PARSE; - } - - # Get rid of day of week - if (/(^|[^a-z])$week($|[^a-z])/i) { - $wk=$2; - (s/(^|[^a-z])$week,/$1 /i) || - s/(^|[^a-z])$week($|[^a-z])/$1 $3/i; - s/^\s+//; - s/\s+$//; - } - - { - # So that we can handle negative epoch times, let's convert - # things like "epoch -" to "epochNEGATIVE " before we strip out - # the $sep chars, which include '-'. - s,epoch\s*-,epochNEGATIVE ,g; - - # Non-ISO8601 dates - s,\s*$sep\s*, ,g; # change all non-ISO8601 seps to spaces - s,^\s*,,; # remove leading/trailing space - s,\s*$,,; - - if (/^$D\s+$D(?:\s+$YY)?$/) { - # MM DD YY (DD MM YY non-US) - ($m,$d,$y)=($1,$2,$3); - ($m,$d)=($d,$m) if ($type ne "US"); - last PARSE; - - } elsif (/^$D4\s*$D\s*$D$/) { - # YYYY MM DD - ($y,$m,$d)=($1,$2,$3); - last PARSE; - - } elsif (s/(^|[^a-z])$month($|[^a-z])/$1 $3/i) { - ($m)=($2); - - if (/^\s*$D(?:\s+$YY)?\s*$/) { - # mmm DD YY - # DD mmm YY - # DD YY mmm - ($d,$y)=($1,$2); - last PARSE; - - } elsif (/^\s*$D$D4\s*$/) { - # mmm DD YYYY - # DD mmm YYYY - # DD YYYY mmm - ($d,$y)=($1,$2); - last PARSE; - - } elsif (/^\s*$D4\s*$D\s*$/) { - # mmm YYYY DD - # YYYY mmm DD - # YYYY DD mmm - ($y,$d)=($1,$2); - last PARSE; - - } elsif (/^\s*$D4\s*$/) { - # mmm YYYY - # YYYY mmm - ($y,$d)=($1,1); - last PARSE; - - } else { - return ""; - } - - } elsif (/^epochNEGATIVE (\d+)$/) { - $s=$1; - $date=&DateCalc("1970-01-01 00:00 GMT","-0:0:$s"); - } elsif (/^epoch\s*(\d+)$/i) { - $s=$1; - $date=&DateCalc("1970-01-01 00:00 GMT","+0:0:$s"); - - } elsif (/^$now$/i) { - # now, today - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $date=$Curr{"Now"}; - if ($time) { - return "" - if (&Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk)); - $date=&Date_SetTime($date,$h,$mn,$s); - } - last PARSE; - - } elsif (/^$offset$/i) { - # yesterday, tomorrow - ($offset)=($1); - &Date_Init() if (! $Cnf{"UpdateCurrTZ"}); - $offset=$Lang{$L}{"OffsetH"}{lc($offset)}; - $date=&DateCalc_DateDelta($Curr{"Now"},$offset,\$err,0); - if ($time) { - return "" - if (&Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk)); - $date=&Date_SetTime($date,$h,$mn,$s); - } - last PARSE; - - } else { - return ""; - } - } - } - - if (! $date) { - return "" if (&Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk)); - $date=&Date_Join($y,$m,$d,$h,$mn,$s); - } - $date=&Date_ConvTZ($date,$z); - if ($midnight) { - $date=&DateCalc_DateDelta($date,"+0:0:0:1:0:0:0"); - } - return $date; -} - -sub ParseDate { - print "DEBUG: ParseDate\n" if ($Curr{"Debug"} =~ /trace/); - &Date_Init() if (! $Curr{"InitDone"}); - my($args,@args,@a,$ref,$date)=(); - @a=@_; - - # @a : is the list of args to ParseDate. Currently, only one argument - # is allowed and it must be a scalar (or a reference to a scalar) - # or a reference to an array. - - if ($#a!=0) { - print "ERROR: Invalid number of arguments to ParseDate.\n"; - return ""; - } - $args=$a[0]; - $ref=ref $args; - if (! $ref) { - return $args if (&Date_Split($args)); - @args=($args); - } elsif ($ref eq "ARRAY") { - @args=@$args; - } elsif ($ref eq "SCALAR") { - return $$args if (&Date_Split($$args)); - @args=($$args); - } else { - print "ERROR: Invalid arguments to ParseDate.\n"; - return ""; - } - @a=@args; - - # @args : a list containing all the arguments (dereferenced if appropriate) - # @a : a list containing all the arguments currently being examined - # $ref : nil, "SCALAR", or "ARRAY" depending on whether a scalar, a - # reference to a scalar, or a reference to an array was passed in - # $args : the scalar or refererence passed in - - PARSE: while($#a>=0) { - $date=join(" ",@a); - $date=&ParseDateString($date); - last if ($date); - pop(@a); - } # PARSE - - splice(@args,0,$#a + 1); - @$args= @args if (defined $ref and $ref eq "ARRAY"); - $date; -} - -sub Date_Cmp { - my($D1,$D2)=@_; - my($date1)=&ParseDateString($D1); - my($date2)=&ParseDateString($D2); - return $date1 cmp $date2; -} - -# **NOTE** -# The calc routines all call parse routines, so it is never necessary to -# call Date_Init in the calc routines. -sub DateCalc { - print "DEBUG: DateCalc\n" if ($Curr{"Debug"} =~ /trace/); - my($D1,$D2,@arg)=@_; - my($ref,$err,$errref,$mode)=(); - - $errref=shift(@arg); - $ref=0; - if (defined $errref) { - if (ref $errref) { - $mode=shift(@arg); - $ref=1; - } else { - $mode=$errref; - $errref=""; - } - } - - my(@date,@delta,$ret,$tmp,$old)=(); - - if (defined $mode and $mode>=0 and $mode<=3) { - $Curr{"Mode"}=$mode; - } else { - $Curr{"Mode"}=0; - } - - $old=$Curr{"InCalc"}; - $Curr{"InCalc"}=1; - - if ($tmp=&ParseDateString($D1)) { - # If we've already parsed the date, we don't want to do it a second - # time (so we don't convert timezones twice). - if (&Date_Split($D1)) { - push(@date,$D1); - } else { - push(@date,$tmp); - } - } elsif ($tmp=&ParseDateDelta($D1)) { - push(@delta,$tmp); - } else { - $$errref=1 if ($ref); - return; - } - - if ($tmp=&ParseDateString($D2)) { - if (&Date_Split($D2)) { - push(@date,$D2); - } else { - push(@date,$tmp); - } - } elsif ($tmp=&ParseDateDelta($D2)) { - push(@delta,$tmp); - } else { - $$errref=2 if ($ref); - return; - } - $mode=$Curr{"Mode"}; - $Curr{"InCalc"}=$old; - - if ($#date==1) { - $ret=&DateCalc_DateDate(@date,$mode); - } elsif ($#date==0) { - $ret=&DateCalc_DateDelta(@date,@delta,\$err,$mode); - $$errref=$err if ($ref); - } else { - $ret=&DateCalc_DeltaDelta(@delta,$mode); - } - $ret; -} - -sub ParseDateDelta { - print "DEBUG: ParseDateDelta\n" if ($Curr{"Debug"} =~ /trace/); - my($args,@args,@a,$ref)=(); - local($_)=(); - @a=@_; - - # @a : is the list of args to ParseDateDelta. Currently, only one argument - # is allowed and it must be a scalar (or a reference to a scalar) - # or a reference to an array. - - if ($#a!=0) { - print "ERROR: Invalid number of arguments to ParseDateDelta.\n"; - return ""; - } - $args=$a[0]; - $ref=ref $args; - if (! $ref) { - @args=($args); - } elsif ($ref eq "ARRAY") { - @args=@$args; - } elsif ($ref eq "SCALAR") { - @args=($$args); - } else { - print "ERROR: Invalid arguments to ParseDateDelta.\n"; - return ""; - } - @a=@args; - - # @args : a list containing all the arguments (dereferenced if appropriate) - # @a : a list containing all the arguments currently being examined - # $ref : nil, "SCALAR", or "ARRAY" depending on whether a scalar, a - # reference to a scalar, or a reference to an array was passed in - # $args : the scalar or refererence passed in - - my(@colon,@delta,$delta,$dir,$colon,$sign,$val)=(); - my($len,$tmp,$tmp2,$tmpl)=(); - my($from,$to)=(); - my($workweek)=$Cnf{"WorkWeekEnd"}-$Cnf{"WorkWeekBeg"}+1; - - &Date_Init() if (! $Curr{"InitDone"}); - # A sign can be a sequence of zero or more + and - signs, this - # allows for deltas like '+ -2 days'. - my($signexp)='((?:[+-]\s*)*)'; - my($numexp)='(\d+)'; - my($exp1)="(?: \\s* $signexp \\s* $numexp \\s*)"; - my($yexp,$mexp,$wexp,$dexp,$hexp,$mnexp,$sexp,$i)=(); - $yexp=$mexp=$wexp=$dexp=$hexp=$mnexp=$sexp="()()"; - $yexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Yabb"} .")?"; - $mexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Mabb"} .")?"; - $wexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Wabb"} .")?"; - $dexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Dabb"} .")?"; - $hexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Habb"} .")?"; - $mnexp="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"MNabb"}.")?"; - $sexp ="(?: $exp1 ". $Lang{$Cnf{"Language"}}{"Sabb"} ."?)?"; - my($future)=$Lang{$Cnf{"Language"}}{"Future"}; - my($later)=$Lang{$Cnf{"Language"}}{"Later"}; - my($past)=$Lang{$Cnf{"Language"}}{"Past"}; - - $delta=""; - PARSE: while (@a) { - $_ = join(" ", grep {defined;} @a); - s/\s+$//; - last if ($_ eq ""); - - # Mode is set in DateCalc. ParseDateDelta only overrides it if the - # string contains a mode. - if ($Lang{$Cnf{"Language"}}{"Exact"} && - s/$Lang{$Cnf{"Language"}}{"Exact"}//) { - $Curr{"Mode"}=0; - } elsif ($Lang{$Cnf{"Language"}}{"Approx"} && - s/$Lang{$Cnf{"Language"}}{"Approx"}//) { - $Curr{"Mode"}=1; - } elsif ($Lang{$Cnf{"Language"}}{"Business"} && - s/$Lang{$Cnf{"Language"}}{"Business"}//) { - $Curr{"Mode"}=2; - } elsif (! exists $Curr{"Mode"}) { - $Curr{"Mode"}=0; - } - $workweek=7 if ($Curr{"Mode"} != 2); - - foreach $from (keys %{ $Lang{$Cnf{"Language"}}{"Repl"} }) { - $to=$Lang{$Cnf{"Language"}}{"Repl"}{$from}; - s/(^|[^a-z])$from($|[^a-z])/$1$to$2/i; - } - - # in or ago - # - # We need to make sure that $later, $future, and $past don't contain each - # other... Romanian pointed this out where $past is "in urma" and $future - # is "in". When they do, we have to take this into account. - # $len length of best match (greatest wins) - # $tmp string after best match - # $dir direction (prior, after) of best match - # - # $tmp2 string before/after current match - # $tmpl length of current match - - $len=0; - $tmp=$_; - $dir=1; - - $tmp2=$_; - if ($tmp2 =~ s/(^|[^a-z])($future)($|[^a-z])/$1 $3/i) { - $tmpl=length($2); - if ($tmpl>$len) { - $tmp=$tmp2; - $dir=1; - $len=$tmpl; - } - } - - $tmp2=$_; - if ($tmp2 =~ s/(^|[^a-z])($later)($|[^a-z])/$1 $3/i) { - $tmpl=length($2); - if ($tmpl>$len) { - $tmp=$tmp2; - $dir=1; - $len=$tmpl; - } - } - - $tmp2=$_; - if ($tmp2 =~ s/(^|[^a-z])($past)($|[^a-z])/$1 $3/i) { - $tmpl=length($2); - if ($tmpl>$len) { - $tmp=$tmp2; - $dir=-1; - $len=$tmpl; - } - } - - $_ = $tmp; - s/\s*$//; - - # the colon part of the delta - $colon=""; - if (s/($signexp?$numexp?(:($signexp?$numexp)?){1,6})$//) { - $colon=$1; - s/\s+$//; - } - @colon=split(/:/,$colon); - - # the non-colon part of the delta - $sign="+"; - @delta=(); - $i=6; - foreach $exp1 ($yexp,$mexp,$wexp,$dexp,$hexp,$mnexp,$sexp) { - last if ($#colon>=$i--); - $val=0; - if (s/^$exp1//ix) { - $val=$2 if ($2); - $sign=$1 if ($1); - } - - # Collapse a sign like '+ -' into a single character like '-', - # by counting the occurrences of '-'. - # - $sign =~ s/\s+//g; - $sign =~ tr/+//d; - my $count = ($sign =~ tr/-//d); - die "bad characters in sign: $sign" if length $sign; - $sign = $count % 2 ? '-' : '+'; - - push(@delta,"$sign$val"); - } - if (! /^\s*$/) { - pop(@a); - next PARSE; - } - - # make sure that the colon part has a sign - for ($i=0; $i<=$#colon; $i++) { - $val=0; - if ($colon[$i] =~ /^$signexp$numexp?/) { - $val=$2 if ($2); - $sign=$1 if ($1); - } - $colon[$i] = "$sign$val"; - } - - # combine the two - push(@delta,@colon); - if ($dir<0) { - for ($i=0; $i<=$#delta; $i++) { - $delta[$i] =~ tr/-+/+-/; - } - } - - # form the delta and shift off the valid part - $delta=join(":",@delta); - splice(@args,0,$#a+1); - @$args=@args if (defined $ref and $ref eq "ARRAY"); - last PARSE; - } - - $delta=&Delta_Normalize($delta,$Curr{"Mode"}); - return $delta; -} - -sub UnixDate { - print "DEBUG: UnixDate\n" if ($Curr{"Debug"} =~ /trace/); - my($date,@format)=@_; - local($_)=(); - my($format,%f,$out,@out,$c,$date1,$date2,$tmp)=(); - my($scalar)=(); - $date=&ParseDateString($date); - return if (! $date); - - my($y,$m,$d,$h,$mn,$s)=($f{"Y"},$f{"m"},$f{"d"},$f{"H"},$f{"M"},$f{"S"})= - &Date_Split($date, 1); - $f{"y"}=substr $f{"Y"},2; - &Date_Init() if (! $Curr{"InitDone"}); - - if (! wantarray) { - $format=join(" ",@format); - @format=($format); - $scalar=1; - } - - # month, week - $_=$m; - s/^0//; - $f{"b"}=$f{"h"}=$Lang{$Cnf{"Language"}}{"MonL"}[$_-1]; - $f{"B"}=$Lang{$Cnf{"Language"}}{"MonthL"}[$_-1]; - $_=$m; - s/^0/ /; - $f{"f"}=$_; - $f{"U"}=&Date_WeekOfYear($m,$d,$y,7); - $f{"W"}=&Date_WeekOfYear($m,$d,$y,1); - - # check week 52,53 and 0 - $f{"G"}=$f{"L"}=$y; - if ($f{"W"}>=52 || $f{"U"}>=52) { - my($dd,$mm,$yy)=($d,$m,$y); - $dd+=7; - if ($dd>31) { - $dd-=31; - $mm=1; - $yy++; - if (&Date_WeekOfYear($mm,$dd,$yy,1)==2) { - $f{"G"}=$yy; - $f{"W"}=1; - } - if (&Date_WeekOfYear($mm,$dd,$yy,7)==2) { - $f{"L"}=$yy; - $f{"U"}=1; - } - } - } - if ($f{"W"}==0) { - my($dd,$mm,$yy)=($d,$m,$y); - $dd-=7; - $dd+=31 if ($dd<1); - $yy--; - $mm=12; - $f{"G"}=$yy; - $f{"W"}=&Date_WeekOfYear($mm,$dd,$yy,1)+1; - } - if ($f{"U"}==0) { - my($dd,$mm,$yy)=($d,$m,$y); - $dd-=7; - $dd+=31 if ($dd<1); - $yy--; - $mm=12; - $f{"L"}=$yy; - $f{"U"}=&Date_WeekOfYear($mm,$dd,$yy,7)+1; - } - - $f{"U"}="0".$f{"U"} if (length $f{"U"} < 2); - $f{"W"}="0".$f{"W"} if (length $f{"W"} < 2); - - # day - $f{"j"}=&Date_DayOfYear($m,$d,$y); - $f{"j"} = "0" . $f{"j"} while (length($f{"j"})<3); - $_=$d; - s/^0/ /; - $f{"e"}=$_; - $f{"w"}=&Date_DayOfWeek($m,$d,$y); - $f{"v"}=$Lang{$Cnf{"Language"}}{"WL"}[$f{"w"}-1]; - $f{"v"}=" ".$f{"v"} if (length $f{"v"} < 2); - $f{"a"}=$Lang{$Cnf{"Language"}}{"WkL"}[$f{"w"}-1]; - $f{"A"}=$Lang{$Cnf{"Language"}}{"WeekL"}[$f{"w"}-1]; - $f{"E"}=&Date_DaySuffix($f{"e"}); - - # hour - $_=$h; - s/^0/ /; - $f{"k"}=$_; - $f{"i"}=$f{"k"}+1; - $f{"i"}=$f{"k"}; - $f{"i"}=12 if ($f{"k"}==0); - $f{"i"}=$f{"k"}-12 if ($f{"k"}>12); - $f{"i"}=$f{"i"}-12 if ($f{"i"}>12); - $f{"i"}=" ".$f{"i"} if (length($f{"i"})<2); - $f{"I"}=$f{"i"}; - $f{"I"}=~ s/^ /0/; - $f{"p"}=$Lang{$Cnf{"Language"}}{"AMstr"}; - $f{"p"}=$Lang{$Cnf{"Language"}}{"PMstr"} if ($f{"k"}>11); - - # minute, second, timezone - $f{"o"}=&Date_SecsSince1970($m,$d,$y,$h,$mn,$s); - $f{"s"}=&Date_SecsSince1970GMT($m,$d,$y,$h,$mn,$s); - $f{"Z"}=($Cnf{"ConvTZ"} eq "IGNORE" or $Cnf{"ConvTZ"} eq "") ? - $Cnf{"TZ"} : $Cnf{"ConvTZ"}; - $f{"z"}=($f{"Z"}=~/^[+-]\d{4}/) ? $f{"Z"} : ($Zone{"n2o"}{lc $f{"Z"}} || ""); - - # date, time - $f{"c"}=qq|$f{"a"} $f{"b"} $f{"e"} $h:$mn:$s $y|; - $f{"C"}=$f{"u"}= - qq|$f{"a"} $f{"b"} $f{"e"} $h:$mn:$s $f{"z"} $y|; - $f{"g"}=qq|$f{"a"}, $d $f{"b"} $y $h:$mn:$s $f{"z"}|; - $f{"D"}=$f{"x"}=qq|$m/$d/$f{"y"}|; - $f{"r"}=qq|$f{"I"}:$mn:$s $f{"p"}|; - $f{"R"}=qq|$h:$mn|; - $f{"T"}=$f{"X"}=qq|$h:$mn:$s|; - $f{"V"}=qq|$m$d$h$mn$f{"y"}|; - $f{"Q"}="$y$m$d"; - $f{"q"}=qq|$y$m$d$h$mn$s|; - $f{"P"}=qq|$y$m$d$h:$mn:$s|; - $f{"F"}=qq|$f{"A"}, $f{"B"} $f{"e"}, $f{"Y"}|; - if ($f{"W"}==0) { - $y--; - $tmp=&Date_WeekOfYear(12,31,$y,1); - $tmp="0$tmp" if (length($tmp) < 2); - $f{"J"}=qq|$y-W$tmp-$f{"w"}|; - } else { - $f{"J"}=qq|$f{"G"}-W$f{"W"}-$f{"w"}|; - } - $f{"K"}=qq|$y-$f{"j"}|; - # %l is a special case. Since it requires the use of the calculator - # which requires this routine, an infinite recursion results. To get - # around this, %l is NOT determined every time this is called so the - # recursion breaks. - - # other formats - $f{"n"}="\n"; - $f{"t"}="\t"; - $f{"%"}="%"; - $f{"+"}="+"; - - foreach $format (@format) { - $format=reverse($format); - $out=""; - while ($format ne "") { - $c=chop($format); - if ($c eq "%") { - $c=chop($format); - if ($c eq "l") { - &Date_Init(); - $date1=&DateCalc_DateDelta($Curr{"Now"},"-0:6:0:0:0:0:0"); - $date2=&DateCalc_DateDelta($Curr{"Now"},"+0:6:0:0:0:0:0"); - if (&Date_Cmp($date,$date1)>=0 && &Date_Cmp($date,$date2)<=0) { - $f{"l"}=qq|$f{"b"} $f{"e"} $h:$mn|; - } else { - $f{"l"}=qq|$f{"b"} $f{"e"} $f{"Y"}|; - } - $out .= $f{"$c"}; - } elsif (exists $f{"$c"}) { - $out .= $f{"$c"}; - } else { - $out .= $c; - } - } else { - $out .= $c; - } - } - push(@out,$out); - } - if ($scalar) { - return $out[0]; - } else { - return (@out); - } -} - -# Can't be in "use integer" because we're doing decimal arithmatic -no integer; -sub Delta_Format { - print "DEBUG: Delta_Format\n" if ($Curr{"Debug"} =~ /trace/); - my($delta,$dec,@format)=@_; - $delta=&ParseDateDelta($delta); - return "" if (! $delta); - my(@out,%f,$out,$c1,$c2,$scalar,$format)=(); - local($_)=$delta; - my($y,$M,$w,$d,$h,$m,$s)=&Delta_Split($delta); - # Get rid of positive signs. - ($y,$M,$w,$d,$h,$m,$s)=map { 1*$_; }($y,$M,$w,$d,$h,$m,$s); - - if (defined $dec && $dec>0) { - $dec="%." . ($dec*1) . "f"; - } else { - $dec="%f"; - } - - if (! wantarray) { - $format=join(" ",@format); - @format=($format); - $scalar=1; - } - - # Length of each unit in seconds - my($sl,$ml,$hl,$dl,$wl,$yl)=(); - $sl = 1; - $ml = $sl*60; - $hl = $ml*60; - $dl = $hl*24; - $wl = $dl*7; - $yl = $dl*365.25; - - # The decimal amount of each unit contained in all smaller units - my($yd,$Md,$sd,$md,$hd,$dd,$wd)=(); - if ($M) { - $yd = $M/12; - $Md = 0; - } else { - $yd = ($w*$wl + $d*$dl + $h*$hl + $m*$ml + $s*$sl)/$yl; - $Md = 0; - } - - $wd = ($d*$dl + $h*$hl + $m*$ml + $s*$sl)/$wl; - $dd = ($h*$hl + $m*$ml + $s*$sl)/$dl; - $hd = ($m*$ml + $s*$sl)/$hl; - $md = ($s*$sl)/$ml; - $sd = 0; - - # The amount of each unit contained in higher units. - my($yh,$Mh,$sh,$mh,$hh,$dh,$wh)=(); - $yh = 0; - - if ($M) { - $Mh = ($yh+$y)*12; - $wh = 0; - $dh = ($wh+$w)*7; - } else { - $Mh = 0; - $wh = ($yh+$y)*365.25/7; - $dh = ($yh+$y)*365.25 + $w*7; - } - - $hh = ($dh+$d)*24; - $mh = ($hh+$h)*60; - $sh = ($mh+$m)*60; - - # Set up the formats - - $f{"yv"} = $y; - $f{"Mv"} = $M; - $f{"wv"} = $w; - $f{"dv"} = $d; - $f{"hv"} = $h; - $f{"mv"} = $m; - $f{"sv"} = $s; - - $f{"yh"} = $y+$yh; - $f{"Mh"} = $M+$Mh; - $f{"wh"} = $w+$wh; - $f{"dh"} = $d+$dh; - $f{"hh"} = $h+$hh; - $f{"mh"} = $m+$mh; - $f{"sh"} = $s+$sh; - - $f{"yd"} = sprintf($dec,$y+$yd); - $f{"Md"} = sprintf($dec,$M+$Md); - $f{"wd"} = sprintf($dec,$w+$wd); - $f{"dd"} = sprintf($dec,$d+$dd); - $f{"hd"} = sprintf($dec,$h+$hd); - $f{"md"} = sprintf($dec,$m+$md); - $f{"sd"} = sprintf($dec,$s+$sd); - - $f{"yt"} = sprintf($dec,$yh+$y+$yd); - $f{"Mt"} = sprintf($dec,$Mh+$M+$Md); - $f{"wt"} = sprintf($dec,$wh+$w+$wd); - $f{"dt"} = sprintf($dec,$dh+$d+$dd); - $f{"ht"} = sprintf($dec,$hh+$h+$hd); - $f{"mt"} = sprintf($dec,$mh+$m+$md); - $f{"st"} = sprintf($dec,$sh+$s+$sd); - - $f{"%"} = "%"; - - foreach $format (@format) { - $format=reverse($format); - $out=""; - PARSE: while ($format) { - $c1=chop($format); - if ($c1 eq "%") { - $c1=chop($format); - if (exists($f{$c1})) { - $out .= $f{$c1}; - next PARSE; - } - $c2=chop($format); - if (exists($f{"$c1$c2"})) { - $out .= $f{"$c1$c2"}; - next PARSE; - } - $out .= $c1; - $format .= $c2; - } else { - $out .= $c1; - } - } - push(@out,$out); - } - if ($scalar) { - return $out[0]; - } else { - return (@out); - } -} -use integer; - -sub ParseRecur { - print "DEBUG: ParseRecur\n" if ($Curr{"Debug"} =~ /trace/); - &Date_Init() if (! $Curr{"InitDone"}); - - my($recur,$dateb,$date0,$date1,$flag)=@_; - local($_)=$recur; - - my($recur_0,$recur_1,@recur0,@recur1)=(); - my(@tmp,$tmp,$each,$num,$y,$m,$d,$w,$h,$mn,$s,$delta,$y0,$y1,$yb)=(); - my($yy,$n,$dd,@d,@tmp2,$date,@date,@w,@tmp3,@m,@y,$tmp2,$d2,@flags)=(); - - # $date0, $date1, $dateb, $flag : passed in (these are always the final say - # in determining whether a date matches a - # recurrence IF they are present. - # $date_b, $date_0, $date_1 : if a value can be determined from the - # $flag_t recurrence, they are stored here. - # - # If values can be determined from the recurrence AND are passed in, the - # following are used: - # max($date0,$date_0) i.e. the later of the two dates - # min($date1,$date_1) i.e. the earlier of the two dates - # - # The base date that is used is the first one defined from - # $dateb $date_b - # The base date is only used if necessary (as determined by the recur). - # For example, "every other friday" requires a base date, but "2nd - # friday of every month" doesn't. - - my($date_b,$date_0,$date_1,$flag_t); - - # - # Check the arguments passed in. - # - - $date0="" if (! defined $date0); - $date1="" if (! defined $date1); - $dateb="" if (! defined $dateb); - $flag ="" if (! defined $flag); - - if ($dateb) { - $dateb=&ParseDateString($dateb); - return "" if (! $dateb); - } - if ($date0) { - $date0=&ParseDateString($date0); - return "" if (! $date0); - } - if ($date1) { - $date1=&ParseDateString($date1); - return "" if (! $date1); - } - - # - # Parse the recur. $date_b, $date_0, and $date_e are values obtained - # from the recur. - # - - @tmp=&Recur_Split($_); - - if (@tmp) { - ($recur_0,$recur_1,$flag_t,$date_b,$date_0,$date_1)=@tmp; - $recur_0 = "" if (! defined $recur_0); - $recur_1 = "" if (! defined $recur_1); - $flag_t = "" if (! defined $flag_t); - $date_b = "" if (! defined $date_b); - $date_0 = "" if (! defined $date_0); - $date_1 = "" if (! defined $date_1); - - @recur0 = split(/:/,$recur_0); - @recur1 = split(/:/,$recur_1); - return "" if ($#recur0 + $#recur1 + 2 != 7); - - if ($date_b) { - $date_b=&ParseDateString($date_b); - return "" if (! $date_b); - } - if ($date_0) { - $date_0=&ParseDateString($date_0); - return "" if (! $date_0); - } - if ($date_1) { - $date_1=&ParseDateString($date_1); - return "" if (! $date_1); - } - - } else { - - my($mmm)='\s*'.$Lang{$Cnf{"Language"}}{"Month"}; # \s*(jan|january|...) - my(%mmm)=%{ $Lang{$Cnf{"Language"}}{"MonthH"} }; # { jan=>1, ... } - my($wkexp)='\s*'.$Lang{$Cnf{"Language"}}{"Week"}; # \s*(mon|monday|...) - my(%week)=%{ $Lang{$Cnf{"Language"}}{"WeekH"} }; # { monday=>1, ... } - my($day)='\s*'.$Lang{$Cnf{"Language"}}{"Dabb"}; # \s*(?:d|day|days) - my($month)='\s*'.$Lang{$Cnf{"Language"}}{"Mabb"}; # \s*(?:mon|month|months) - my($week)='\s*'.$Lang{$Cnf{"Language"}}{"Wabb"}; # \s*(?:w|wk|week|weeks) - my($daysexp)=$Lang{$Cnf{"Language"}}{"DoM"}; # (1st|first|...31st) - my(%dayshash)=%{ $Lang{$Cnf{"Language"}}{"DoMH"} }; - # { 1st=>1,first=>1,...} - my($of)='\s*'.$Lang{$Cnf{"Language"}}{"Of"}; # \s*(?:in|of) - my($lastexp)=$Lang{$Cnf{"Language"}}{"Last"}; # (?:last) - my($each)=$Lang{$Cnf{"Language"}}{"Each"}; # (?:each|every) - - my($D)='\s*(\d+)'; - my($Y)='\s*(\d{4}|\d{2})'; - - # Change 1st to 1 - if (/(^|[^a-z])$daysexp($|[^a-z])/i) { - $tmp=lc($2); - $tmp=$dayshash{"$tmp"}; - s/(^|[^a-z])$daysexp($|[^a-z])/$1 $tmp $3/i; - } - s/\s*$//; - - # Get rid of "each" - if (/(^|[^a-z])$each($|[^a-z])/i) { - s/(^|[^a-z])$each($|[^a-z])/$1 $2/i; - $each=1; - } else { - $each=0; - } - - if ($each) { - - if (/^$D?$day(?:$of$mmm?$Y)?$/i || - /^$D?$day(?:$of$mmm())?$/i) { - # every [2nd] day in [june] 1997 - # every [2nd] day [in june] - ($num,$m,$y)=($1,$2,$3); - $num=1 if (! defined $num); - $m="" if (! defined $m); - $y="" if (! defined $y); - - $y=$Curr{"Y"} if (! $y); - if ($m) { - $m=$mmm{lc($m)}; - $date_0=&Date_Join($y,$m,1,0,0,0); - $date_1=&DateCalc_DateDelta($date_0,"+0:1:0:0:0:0:0",0); - } else { - $date_0=&Date_Join($y, 1,1,0,0,0); - $date_1=&Date_Join($y+1,1,1,0,0,0); - } - $date_b=&DateCalc($date_0,"-0:0:0:1:0:0:0",0); - @recur0=(0,0,0,$num,0,0,0); - @recur1=(); - - } elsif (/^$D$day?$of$month(?:$of?$Y)?$/) { - # 2nd [day] of every month [in 1997] - ($num,$y)=($1,$2); - $y=$Curr{"Y"} if (! $y); - - $date_0=&Date_Join($y, 1,1,0,0,0); - $date_1=&Date_Join($y+1,1,1,0,0,0); - $date_b=$date_0; - - @recur0=(0,1,0); - @recur1=($num,0,0,0); - - } elsif (/^$D$wkexp$of$month(?:$of?$Y)?$/ || - /^($lastexp)$wkexp$of$month(?:$of?$Y)?$/) { - # 2nd tuesday of every month [in 1997] - # last tuesday of every month [in 1997] - ($num,$d,$y)=($1,$2,$3); - $y=$Curr{"Y"} if (! $y); - $d=$week{lc($d)}; - $num=-1 if ($num !~ /^$D$/); - - $date_0=&Date_Join($y,1,1,0,0,0); - $date_1=&Date_Join($y+1,1,1,0,0,0); - $date_b=$date_0; - - @recur0=(0,1); - @recur1=($num,$d,0,0,0); - - } elsif (/^$D?$wkexp(?:$of$mmm?$Y)?$/i || - /^$D?$wkexp(?:$of$mmm())?$/i) { - # every tuesday in june 1997 - # every 2nd tuesday in june 1997 - ($num,$d,$m,$y)=($1,$2,$3,$4); - $y=$Curr{"Y"} if (! $y); - $num=1 if (! defined $num); - $m="" if (! defined $m); - $d=$week{lc($d)}; - - if ($m) { - $m=$mmm{lc($m)}; - $date_0=&Date_Join($y,$m,1,0,0,0); - $date_1=&DateCalc_DateDelta($date_0,"+0:1:0:0:0:0:0",0); - } else { - $date_0=&Date_Join($y,1,1,0,0,0); - $date_1=&Date_Join($y+1,1,1,0,0,0); - } - $date_b=&DateCalc($date_0,"-0:0:0:1:0:0:0",0); - - @recur0=(0,0,$num); - @recur1=($d,0,0,0); - - } else { - return ""; - } - - $date_0="" if ($date0); - $date_1="" if ($date1); - } else { - return ""; - } - } - - # - # Override with any values passed in - # - - if ($date0 && $date_0) { - $date0=( &Date_Cmp($date0,$date_0) > 1 ? $date0 : $date_0); - } elsif ($date_0) { - $date0 = $date_0; - } - - if ($date1 && $date_1) { - $date1=( &Date_Cmp($date1,$date_1) > 1 ? $date_1 : $date1); - } elsif ($date_1) { - $date1 = $date_1; - } - - $dateb=$date_b if (! $dateb); - - if ($flag =~ s/^\+//) { - if ($flag_t) { - $flag="$flag_t,$flag"; - } - } - $flag =$flag_t if (! $flag && $flag_t); - - if (! wantarray) { - $tmp = join(":",@recur0); - $tmp .= "*" . join(":",@recur1) if (@recur1); - $tmp .= "*$flag*$dateb*$date0*$date1"; - return $tmp; - } - if (@recur0) { - return () if (! $date0 || ! $date1); # dateb is NOT required in all case - } - - # - # Some flags affect parsing. - # - - @flags = split(/,/,$flag); - my($MDn) = 0; - my($MWn) = 7; - my($f); - foreach $f (@flags) { - if ($f =~ /^MW([1-7])$/i) { - $MWn=$1; - $MDn=0; - - } elsif ($f =~ /^MD([1-7])$/i) { - $MDn=$1; - $MWn=0; - - } elsif ($f =~ /^EASTER$/i) { - ($y,$m,$w,$d,$h,$mn,$s)=(@recur0,@recur1); - # We want something that will return Jan 1 for the given years. - if ($#recur0==-1) { - @recur1=($y,1,0,1,$h,$mn,$s); - } elsif ($#recur0<=3) { - @recur0=($y,0,0,0); - @recur1=($h,$mn,$s); - } elsif ($#recur0==4) { - @recur0=($y,0,0,0,0); - @recur1=($mn,$s); - } elsif ($#recur0==5) { - @recur0=($y,0,0,0,0,0); - @recur1=($s); - } else { - @recur0=($y,0,0,0,0,0,0); - } - } - } - - # - # Determine the dates referenced by the recur. Also, fix the base date - # as necessary for the recurrences which require it. - # - - ($y,$m,$w,$d,$h,$mn,$s)=(@recur0,@recur1); - @y=@m=@w=@d=(); - my(@time)=($h,$mn,$s); - - RECUR: while (1) { - - if ($#recur0==-1) { - # * Y-M-W-D-H-MN-S - if ($y eq "0") { - push(@recur0,0); - shift(@recur1); - - } else { - @y=&ReturnList($y); - foreach $y (@y) { - $y=&Date_FixYear($y) if (length($y)==2); - return () if (length($y)!=4 || ! &IsInt($y)); - } - @y=sort { $a<=>$b } @y; - - $date0=&ParseDate("0000-01-01") if (! $date0); - $date1=&ParseDate("9999-12-31 23:59:59") if (! $date1); - - if ($m eq "0" and $w eq "0") { - # * Y-0-0-0-H-MN-S - # * Y-0-0-DOY-H-MN-S - if ($d eq "0") { - @d=(1); - } else { - @d=&ReturnList($d); - return () if (! @d); - foreach $d (@d) { - return () if (! &IsInt($d,1,366)); - } - @d=sort { $a<=>$b } (@d); - } - - @date=(); - foreach $yy (@y) { - foreach $d (@d) { - ($y,$m,$dd)=&Date_NthDayOfYear($yy,$d); - push(@date, &Date_Join($y,$m,$dd,0,0,0)); - } - } - last RECUR; - - } elsif ($w eq "0") { - # * Y-M-0-0-H-MN-S - # * Y-M-0-DOM-H-MN-S - - @m=&ReturnList($m); - return () if (! @m); - foreach $m (@m) { - return () if (! &IsInt($m,1,12)); - } - @m=sort { $a<=>$b } (@m); - - if ($d eq "0") { - @d=(1); - } else { - @d=&ReturnList($d); - return () if (! @d); - foreach $d (@d) { - return () if (! &IsInt($d,1,31)); - } - @d=sort { $a<=>$b } (@d); - } - - @date=(); - foreach $y (@y) { - foreach $m (@m) { - foreach $d (@d) { - $date=&Date_Join($y,$m,$d,0,0,0); - push(@date,$date) if ($d<29 || &Date_Split($date)); - } - } - } - last RECUR; - - } elsif ($m eq "0") { - # * Y-0-WOY-DOW-H-MN-S - # * Y-0-WOY-0-H-MN-S - @w=&ReturnList($w); - return () if (! @w); - foreach $w (@w) { - return () if (! &IsInt($w,1,53)); - } - - if ($d eq "0") { - @d=($Cnf{"FirstDay"}); - } else { - @d=&ReturnList($d); - return () if (! @d); - foreach $d (@d) { - return () if (! &IsInt($d,1,7)); - } - @d=sort { $a<=>$b } (@d); - } - - @date=(); - foreach $y (@y) { - foreach $w (@w) { - $w="0$w" if (length($w)==1); - foreach $d (@d) { - $date=&ParseDateString("$y-W$w-$d"); - push(@date,$date); - } - } - } - last RECUR; - - } else { - # * Y-M-WOM-DOW-H-MN-S - # * Y-M-WOM-0-H-MN-S - - @m=&ReturnList($m); - return () if (! @m); - foreach $m (@m) { - return () if (! &IsInt($m,1,12)); - } - @m=sort { $a<=>$b } (@m); - - @w=&ReturnList($w); - - if ($d eq "0") { - @d=(); - } else { - @d=&ReturnList($d); - } - - @date=&Date_Recur_WoM(\@y,\@m,\@w,\@d,$MWn,$MDn); - last RECUR; - } - } - } - - if ($#recur0==0) { - # Y * M-W-D-H-MN-S - $n=$y; - $n=1 if ($n==0); - - @m=&ReturnList($m); - return () if (! @m); - foreach $m (@m) { - return () if (! &IsInt($m,1,12)); - } - @m=sort { $a<=>$b } (@m); - - if ($m eq "0") { - # Y * 0-W-D-H-MN-S (equiv to Y-0 * W-D-H-MN-S) - push(@recur0,0); - shift(@recur1); - - } elsif ($w eq "0") { - # Y * M-0-DOM-H-MN-S - return () if (! $dateb); - $d=1 if ($d eq "0"); - - @d=&ReturnList($d); - return () if (! @d); - foreach $d (@d) { - return () if (! &IsInt($d,1,31)); - } - @d=sort { $a<=>$b } (@d); - - # We need to find years that are a multiple of $n from $y(base) - ($y0)=( &Date_Split($date0, 1) )[0]; - ($y1)=( &Date_Split($date1, 1) )[0]; - ($yb)=( &Date_Split($dateb, 1) )[0]; - @date=(); - for ($yy=$y0; $yy<=$y1; $yy++) { - if (($yy-$yb)%$n == 0) { - foreach $m (@m) { - foreach $d (@d) { - $date=&Date_Join($yy,$m,$d,0,0,0); - push(@date,$date) if ($d<29 || &Date_Split($date)); - } - } - } - } - last RECUR; - - } else { - # Y * M-WOM-DOW-H-MN-S - # Y * M-WOM-0-H-MN-S - return () if (! $dateb); - @m=&ReturnList($m); - @w=&ReturnList($w); - if ($d eq "0") { - @d=(); - } else { - @d=&ReturnList($d); - } - - ($y0)=( &Date_Split($date0, 1) )[0]; - ($y1)=( &Date_Split($date1, 1) )[0]; - ($yb)=( &Date_Split($dateb, 1) )[0]; - @y=(); - for ($yy=$y0; $yy<=$y1; $yy++) { - if (($yy-$yb)%$n == 0) { - push(@y,$yy); - } - } - - @date=&Date_Recur_WoM(\@y,\@m,\@w,\@d,$MWn,$MDn); - last RECUR; - } - } - - if ($#recur0==1) { - # Y-M * W-D-H-MN-S - - if ($w eq "0") { - # Y-M * 0-D-H-MN-S (equiv to Y-M-0 * D-H-MN-S) - push(@recur0,0); - shift(@recur1); - - } elsif ($m==0) { - # Y-0 * WOY-0-H-MN-S - # Y-0 * WOY-DOW-H-MN-S - return () if (! $dateb); - $n=$y; - $n=1 if ($n==0); - - @w=&ReturnList($w); - return () if (! @w); - foreach $w (@w) { - return () if (! &IsInt($w,1,53)); - } - - if ($d eq "0") { - @d=($Cnf{"FirstDay"}); - } else { - @d=&ReturnList($d); - return () if (! @d); - foreach $d (@d) { - return () if (! &IsInt($d,1,7)); - } - @d=sort { $a<=>$b } (@d); - } - - # We need to find years that are a multiple of $n from $y(base) - ($y0)=( &Date_Split($date0, 1) )[0]; - ($y1)=( &Date_Split($date1, 1) )[0]; - ($yb)=( &Date_Split($dateb, 1) )[0]; - @date=(); - for ($yy=$y0; $yy<=$y1; $yy++) { - if (($yy-$yb)%$n == 0) { - foreach $w (@w) { - $w="0$w" if (length($w)==1); - foreach $tmp (@d) { - $date=&ParseDateString("$yy-W$w-$tmp"); - push(@date,$date); - } - } - } - } - last RECUR; - - } else { - # Y-M * WOM-0-H-MN-S - # Y-M * WOM-DOW-H-MN-S - return () if (! $dateb); - @tmp=(@recur0); - push(@tmp,0) while ($#tmp<6); - $delta=join(":",@tmp); - @tmp=&Date_Recur($date0,$date1,$dateb,$delta); - - @w=&ReturnList($w); - @m=(); - if ($d eq "0") { - @d=(); - } else { - @d=&ReturnList($d); - } - - @date=&Date_Recur_WoM(\@tmp,\@m,\@w,\@d,$MWn,$MDn); - last RECUR; - } - } - - if ($#recur0==2) { - # Y-M-W * D-H-MN-S - - if ($d eq "0") { - # Y-M-W * 0-H-MN-S - return () if (! $dateb); - $y=1 if ($y==0 && $m==0 && $w==0); - $delta="$y:$m:$w:0:0:0:0"; - @date=&Date_Recur($date0,$date1,$dateb,$delta); - last RECUR; - - } elsif ($m==0 && $w==0) { - # Y-0-0 * DOY-H-MN-S - $y=1 if ($y==0); - $n=$y; - return () if (! $dateb && $y!=1); - - @d=&ReturnList($d); - return () if (! @d); - foreach $d (@d) { - return () if (! &IsInt($d,1,366)); - } - @d=sort { $a<=>$b } (@d); - - # We need to find years that are a multiple of $n from $y(base) - ($y0)=( &Date_Split($date0, 1) )[0]; - ($y1)=( &Date_Split($date1, 1) )[0]; - ($yb)=( &Date_Split($dateb, 1) )[0]; - @date=(); - for ($yy=$y0; $yy<=$y1; $yy++) { - if (($yy-$yb)%$n == 0) { - foreach $d (@d) { - ($y,$m,$dd)=&Date_NthDayOfYear($yy,$d); - push(@date, &Date_Join($y,$m,$dd,0,0,0)); - } - } - } - last RECUR; - - } elsif ($w>0) { - # Y-M-W * DOW-H-MN-S - return () if (! $dateb); - @tmp=(@recur0); - push(@tmp,0) while ($#tmp<6); - $delta=join(":",@tmp); - - @d=&ReturnList($d); - return () if (! @d); - foreach $d (@d) { - return () if (! &IsInt($d,1,7)); - } - - # Find out what DofW the basedate is. - @tmp2=&Date_Split($dateb, 1); - $tmp=&Date_DayOfWeek($tmp2[1],$tmp2[2],$tmp2[0]); - - @date=(); - foreach $d (@d) { - $date_b=$dateb; - # Move basedate to DOW - if ($d != $tmp) { - if (($tmp>=$Cnf{"FirstDay"} && $d<$Cnf{"FirstDay"}) || - ($tmp>=$Cnf{"FirstDay"} && $d>$tmp) || - ($tmp<$d && $d<$Cnf{"FirstDay"})) { - $date_b=&Date_GetNext($date_b,$d); - } else { - $date_b=&Date_GetPrev($date_b,$d); - } - } - push(@date,&Date_Recur($date0,$date1,$date_b,$delta)); - } - @date=sort(@date); - last RECUR; - - } elsif ($m>0) { - # Y-M-0 * DOM-H-MN-S - return () if (! $dateb); - @tmp=(@recur0); - push(@tmp,0) while ($#tmp<6); - $delta=join(":",@tmp); - - @d=&ReturnList($d); - return () if (! @d); - foreach $d (@d) { - return () if (! &IsInt($d,-31,31) || $d==0); - } - @d=sort { $a<=>$b } (@d); - - @tmp2=&Date_Recur($date0,$date1,$dateb,$delta); - @date=(); - foreach $date (@tmp2) { - ($y,$m)=( &Date_Split($date, 1) )[0..1]; - $tmp2=&Date_DaysInMonth($m,$y); - foreach $d (@d) { - $d2=$d; - $d2=$tmp2+1+$d if ($d<0); - push(@date,&Date_Join($y,$m,$d2,0,0,0)) if ($d2<=$tmp2); - } - } - @date=sort (@date); - last RECUR; - - } else { - return (); - } - } - - if ($#recur0>2) { - # Y-M-W-D * H-MN-S - # Y-M-W-D-H * MN-S - # Y-M-W-D-H-MN * S - # Y-M-W-D-H-S - return () if (! $dateb); - @tmp=(@recur0); - push(@tmp,0) while ($#tmp<6); - $delta=join(":",@tmp); - return () if ($delta !~ /[1-9]/); # return if "0:0:0:0:0:0:0" - @date=&Date_Recur($date0,$date1,$dateb,$delta); - if (@recur1) { - unshift(@recur1,-1) while ($#recur1<2); - @time=@recur1; - } else { - shift(@date); - pop(@date); - @time=(); - } - } - - last RECUR; - } - @date=&Date_RecurSetTime($date0,$date1,\@date,@time) if (@time); - - # - # We've got a list of dates. Operate on them with the flags. - # - - my($sign,$forw,$today,$df,$db,$work,$i); - if (@flags) { - FLAG: foreach $f (@flags) { - $f = uc($f); - - if ($f =~ /^(P|N)(D|T)([1-7])$/) { - @tmp=($1,$2,$3); - $forw =($tmp[0] eq "P" ? 0 : 1); - $today=($tmp[1] eq "D" ? 0 : 1); - $d=$tmp[2]; - @tmp=(); - foreach $date (@date) { - if ($forw) { - push(@tmp, &Date_GetNext($date,$d,$today)); - } else { - push(@tmp, &Date_GetPrev($date,$d,$today)); - } - } - @date=@tmp; - next FLAG; - } - - # We want to go forward exact amounts of time instead of - # business mode calculations so that we don't change the time - # (which may have been set in the recur). - if ($f =~ /^(F|B)(D|W)(\d+)$/) { - @tmp=($1,$2,$3); - $sign="+"; - $sign="-" if ($tmp[0] eq "B"); - $work=0; - $work=1 if ($tmp[1] eq "W"); - $n=$tmp[2]; - @tmp=(); - foreach $date (@date) { - for ($i=1; $i<=$n; $i++) { - while (1) { - $date=&DateCalc($date,"${sign}0:0:0:1:0:0:0"); - last if (! $work || &Date_IsWorkDay($date,0)); - } - } - push(@tmp,$date); - } - @date=@tmp; - next FLAG; - } - - if ($f =~ /^CW(N|P|D)$/ || $f =~ /^(N|P|D)W(D)$/) { - $tmp=$1; - my $noalt = $2 ? 1 : 0; - if ($tmp eq "N" || ($tmp eq "D" && $Cnf{"TomorrowFirst"})) { - $forw=1; - } else { - $forw=0; - } - - @tmp=(); - DATE: foreach $date (@date) { - $df=$db=$date; - if (&Date_IsWorkDay($date)) { - push(@tmp,$date); - next DATE; - } - while (1) { - if ($forw) { - $d=$df=&DateCalc($df,"+0:0:0:1:0:0:0"); - } else { - $d=$db=&DateCalc($db,"-0:0:0:1:0:0:0"); - } - if (&Date_IsWorkDay($d)) { - push(@tmp,$d); - next DATE; - } - $forw=1-$forw if (! $noalt); - } - } - @date=@tmp; - next FLAG; - } - - if ($f eq "EASTER") { - @tmp=(); - foreach $date (@date) { - ($y,$m,$d,$h,$mn,$s)=&Date_Split($date, 1); - ($m,$d)=&Date_Easter($y); - $date=&Date_Join($y,$m,$d,$h,$mn,$s); - next if (&Date_Cmp($date,$date0)<0 || - &Date_Cmp($date,$date1)>0); - push(@tmp,$date); - } - @date=@tmp; - } - } - @date = sort(@date); - } - @date; -} - -sub Date_GetPrev { - print "DEBUG: Date_GetPrev\n" if ($Curr{"Debug"} =~ /trace/); - my($date,$dow,$today,$hr,$min,$sec)=@_; - &Date_Init() if (! $Curr{"InitDone"}); - my($y,$m,$d,$h,$mn,$s,$err,$curr_dow,%dow,$num,$delta,$th,$tm,$ts, - $adjust,$curr)=(); - $hr="00" if (defined $hr && $hr eq "0"); - $min="00" if (defined $min && $min eq "0"); - $sec="00" if (defined $sec && $sec eq "0"); - - if (! &Date_Split($date)) { - $date=&ParseDateString($date); - return "" if (! $date); - } - $curr=$date; - ($y,$m,$d)=( &Date_Split($date, 1) )[0..2]; - - if ($dow) { - $curr_dow=&Date_DayOfWeek($m,$d,$y); - %dow=%{ $Lang{$Cnf{"Language"}}{"WeekH"} }; - if (&IsInt($dow)) { - return "" if ($dow<1 || $dow>7); - } else { - return "" if (! exists $dow{lc($dow)}); - $dow=$dow{lc($dow)}; - } - if ($dow == $curr_dow) { - $date=&DateCalc_DateDelta($date,"-0:0:1:0:0:0:0",\$err,0) if (! $today); - $adjust=1 if ($today==2); - } else { - $dow -= 7 if ($dow>$curr_dow); # make sure previous day is less - $num = $curr_dow - $dow; - $date=&DateCalc_DateDelta($date,"-0:0:0:$num:0:0:0",\$err,0); - } - $date=&Date_SetTime($date,$hr,$min,$sec) if (defined $hr); - $date=&DateCalc_DateDelta($date,"-0:0:1:0:0:0:0",\$err,0) - if ($adjust && &Date_Cmp($date,$curr)>0); - - } else { - ($h,$mn,$s)=( &Date_Split($date, 1) )[3..5]; - ($th,$tm,$ts)=&Date_ParseTime($hr,$min,$sec); - if ($hr) { - ($hr,$min,$sec)=($th,$tm,$ts); - $delta="-0:0:0:1:0:0:0"; - } elsif ($min) { - ($hr,$min,$sec)=($h,$tm,$ts); - $delta="-0:0:0:0:1:0:0"; - } elsif ($sec) { - ($hr,$min,$sec)=($h,$mn,$ts); - $delta="-0:0:0:0:0:1:0"; - } else { - confess "ERROR: invalid arguments in Date_GetPrev.\n"; - } - - $d=&Date_SetTime($date,$hr,$min,$sec); - if ($today) { - $d=&DateCalc_DateDelta($d,$delta,\$err,0) if (&Date_Cmp($d,$date)>0); - } else { - $d=&DateCalc_DateDelta($d,$delta,\$err,0) if (&Date_Cmp($d,$date)>=0); - } - $date=$d; - } - return $date; -} - -sub Date_GetNext { - print "DEBUG: Date_GetNext\n" if ($Curr{"Debug"} =~ /trace/); - my($date,$dow,$today,$hr,$min,$sec)=@_; - &Date_Init() if (! $Curr{"InitDone"}); - my($y,$m,$d,$h,$mn,$s,$err,$curr_dow,%dow,$num,$delta,$th,$tm,$ts, - $adjust,$curr)=(); - $hr="00" if (defined $hr && $hr eq "0"); - $min="00" if (defined $min && $min eq "0"); - $sec="00" if (defined $sec && $sec eq "0"); - - if (! &Date_Split($date)) { - $date=&ParseDateString($date); - return "" if (! $date); - } - $curr=$date; - ($y,$m,$d)=( &Date_Split($date, 1) )[0..2]; - - if ($dow) { - $curr_dow=&Date_DayOfWeek($m,$d,$y); - %dow=%{ $Lang{$Cnf{"Language"}}{"WeekH"} }; - if (&IsInt($dow)) { - return "" if ($dow<1 || $dow>7); - } else { - return "" if (! exists $dow{lc($dow)}); - $dow=$dow{lc($dow)}; - } - if ($dow == $curr_dow) { - $date=&DateCalc_DateDelta($date,"+0:0:1:0:0:0:0",\$err,0) if (! $today); - $adjust=1 if ($today==2); - } else { - $curr_dow -= 7 if ($curr_dow>$dow); # make sure next date is greater - $num = $dow - $curr_dow; - $date=&DateCalc_DateDelta($date,"+0:0:0:$num:0:0:0",\$err,0); - } - $date=&Date_SetTime($date,$hr,$min,$sec) if (defined $hr); - $date=&DateCalc_DateDelta($date,"+0:0:1:0:0:0:0",\$err,0) - if ($adjust && &Date_Cmp($date,$curr)<0); - - } else { - ($h,$mn,$s)=( &Date_Split($date, 1) )[3..5]; - ($th,$tm,$ts)=&Date_ParseTime($hr,$min,$sec); - if ($hr) { - ($hr,$min,$sec)=($th,$tm,$ts); - $delta="+0:0:0:1:0:0:0"; - } elsif ($min) { - ($hr,$min,$sec)=($h,$tm,$ts); - $delta="+0:0:0:0:1:0:0"; - } elsif ($sec) { - ($hr,$min,$sec)=($h,$mn,$ts); - $delta="+0:0:0:0:0:1:0"; - } else { - confess "ERROR: invalid arguments in Date_GetNext.\n"; - } - - $d=&Date_SetTime($date,$hr,$min,$sec); - if ($today) { - $d=&DateCalc_DateDelta($d,$delta,\$err,0) if (&Date_Cmp($d,$date)<0); - } else { - $d=&DateCalc_DateDelta($d,$delta,\$err,0) if (&Date_Cmp($d,$date)<1); - } - $date=$d; - } - - return $date; -} - -sub Date_IsHoliday { - print "DEBUG: Date_IsHoliday\n" if ($Curr{"Debug"} =~ /trace/); - my($date)=@_; - &Date_Init() if (! $Curr{"InitDone"}); - $date=&ParseDateString($date); - return undef if (! $date); - $date=&Date_SetTime($date,0,0,0); - my($y)=(&Date_Split($date, 1))[0]; - &Date_UpdateHolidays($y) if (! exists $Holiday{"dates"}{$y}); - return undef if (! exists $Holiday{"dates"}{$y}{$date}); - my($name)=$Holiday{"dates"}{$y}{$date}; - return "" if (! $name); - $name; -} - -sub Events_List { - print "DEBUG: Events_List\n" if ($Curr{"Debug"} =~ /trace/); - my(@args)=@_; - &Date_Init() if (! $Curr{"InitDone"}); - &Events_ParseRaw(); - - my($tmp,$date0,$date1,$flag); - $date0=&ParseDateString($args[0]); - warn "Invalid date $args[0]", return undef if (! $date0); - - if ($#args == 0) { - return &Events_Calc($date0); - } - - if ($args[1]) { - $date1=&ParseDateString($args[1]); - warn "Invalid date $args[1]\n", return undef if (! $date1); - if (&Date_Cmp($date0,$date1)>0) { - $tmp=$date1; - $date1=$date0; - $date0=$tmp; - } - } else { - $date0=&Date_SetTime($date0,"00:00:00"); - $date1=&DateCalc_DateDelta($date0,"+0:0:0:1:0:0:0"); - } - - $tmp=&Events_Calc($date0,$date1); - - $flag=$args[2]; - return $tmp if (! $flag); - - my(@tmp,%ret,$delta)=(); - @tmp=@$tmp; - push(@tmp,$date1); - - if ($flag==1) { - while ($#tmp>0) { - ($date0,$tmp)=splice(@tmp,0,2); - $date1=$tmp[0]; - $delta=&DateCalc_DateDate($date0,$date1); - foreach $flag (@$tmp) { - if (exists $ret{$flag}) { - $ret{$flag}=&DateCalc_DeltaDelta($ret{$flag},$delta); - } else { - $ret{$flag}=$delta; - } - } - } - return \%ret; - - } elsif ($flag==2) { - while ($#tmp>0) { - ($date0,$tmp)=splice(@tmp,0,2); - $date1=$tmp[0]; - $delta=&DateCalc_DateDate($date0,$date1); - $flag=join("+",sort @$tmp); - next if (! $flag); - if (exists $ret{$flag}) { - $ret{$flag}=&DateCalc_DeltaDelta($ret{$flag},$delta); - } else { - $ret{$flag}=$delta; - } - } - return \%ret; - } - - warn "Invalid flag $flag\n"; - return undef; -} - -### -# NOTE: The following routines may be called in the routines below with very -# little time penalty. -### -sub Date_SetTime { - print "DEBUG: Date_SetTime\n" if ($Curr{"Debug"} =~ /trace/); - my($date,$h,$mn,$s)=@_; - &Date_Init() if (! $Curr{"InitDone"}); - my($y,$m,$d)=(); - - if (! &Date_Split($date)) { - $date=&ParseDateString($date); - return "" if (! $date); - } - - ($y,$m,$d)=( &Date_Split($date, 1) )[0..2]; - ($h,$mn,$s)=&Date_ParseTime($h,$mn,$s); - - my($ampm,$wk); - return "" if (&Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk)); - &Date_Join($y,$m,$d,$h,$mn,$s); -} - -sub Date_SetDateField { - print "DEBUG: Date_SetDateField\n" if ($Curr{"Debug"} =~ /trace/); - my($date,$field,$val,$nocheck)=@_; - my($y,$m,$d,$h,$mn,$s)=(); - $nocheck=0 if (! defined $nocheck); - - ($y,$m,$d,$h,$mn,$s)=&Date_Split($date); - - if (! $y) { - $date=&ParseDateString($date); - return "" if (! $date); - ($y,$m,$d,$h,$mn,$s)=&Date_Split($date, 1); - } - - if (lc($field) eq "y") { - $y=$val; - } elsif (lc($field) eq "m") { - $m=$val; - } elsif (lc($field) eq "d") { - $d=$val; - } elsif (lc($field) eq "h") { - $h=$val; - } elsif (lc($field) eq "mn") { - $mn=$val; - } elsif (lc($field) eq "s") { - $s=$val; - } else { - confess "ERROR: Date_SetDateField: invalid field: $field\n"; - } - - $date=&Date_Join($y,$m,$d,$h,$mn,$s); - return $date if ($nocheck || &Date_Split($date)); - return ""; -} - -######################################################################## -# OTHER SUBROUTINES -######################################################################## -# NOTE: These routines should not call any of the routines above as -# there will be a severe time penalty (and the possibility of -# infinite recursion). The last couple routines above are -# exceptions. -# NOTE: Date_Init is a special case. It should be called (conditionally) -# in every routine that uses any variable from the Date::Manip -# namespace. -######################################################################## - -sub Date_DaysInMonth { - print "DEBUG: Date_DaysInMonth\n" if ($Curr{"Debug"} =~ /trace/); - my($m,$y)=@_; - $y=&Date_FixYear($y) if (length($y)!=4); - my(@d_in_m)=(0,31,28,31,30,31,30,31,31,30,31,30,31); - $d_in_m[2]=29 if (&Date_LeapYear($y)); - return $d_in_m[$m]; -} - -sub Date_DayOfWeek { - print "DEBUG: Date_DayOfWeek\n" if ($Curr{"Debug"} =~ /trace/); - my($m,$d,$y)=@_; - $y=&Date_FixYear($y) if (length($y)!=4); - my($dayofweek,$dec31)=(); - - $dec31=5; # Dec 31, 1BC was Friday - $dayofweek=(&Date_DaysSince1BC($m,$d,$y)+$dec31) % 7; - $dayofweek=7 if ($dayofweek==0); - return $dayofweek; -} - -# Can't be in "use integer" because the numbers are too big. -no integer; -sub Date_SecsSince1970 { - print "DEBUG: Date_SecsSince1970\n" if ($Curr{"Debug"} =~ /trace/); - my($m,$d,$y,$h,$mn,$s)=@_; - $y=&Date_FixYear($y) if (length($y)!=4); - my($sec_now,$sec_70)=(); - $sec_now=(&Date_DaysSince1BC($m,$d,$y)-1)*24*3600 + $h*3600 + $mn*60 + $s; -# $sec_70 =(&Date_DaysSince1BC(1,1,1970)-1)*24*3600; - $sec_70 =62167219200; - return ($sec_now-$sec_70); -} - -sub Date_SecsSince1970GMT { - print "DEBUG: Date_SecsSince1970GMT\n" if ($Curr{"Debug"} =~ /trace/); - my($m,$d,$y,$h,$mn,$s)=@_; - &Date_Init() if (! $Curr{"InitDone"}); - $y=&Date_FixYear($y) if (length($y)!=4); - - my($sec)=&Date_SecsSince1970($m,$d,$y,$h,$mn,$s); - return $sec if ($Cnf{"ConvTZ"} eq "IGNORE"); - - my($tz)=$Cnf{"ConvTZ"}; - $tz=$Cnf{"TZ"} if (! $tz); - $tz=$Zone{"n2o"}{lc($tz)} if ($tz !~ /^[+-]\d{4}$/); - - my($tzs)=1; - $tzs=-1 if ($tz<0); - $tz=~/.(..)(..)/; - my($tzh,$tzm)=($1,$2); - $sec - $tzs*($tzh*3600+$tzm*60); -} -use integer; - -sub Date_DaysSince1BC { - print "DEBUG: Date_DaysSince1BC\n" if ($Curr{"Debug"} =~ /trace/); - my($m,$d,$y)=@_; - $y=&Date_FixYear($y) if (length($y)!=4); - my($Ny,$N4,$N100,$N400,$dayofyear,$days)=(); - my($cc,$yy)=(); - - $y=~ /(\d{2})(\d{2})/; - ($cc,$yy)=($1,$2); - - # Number of full years since Dec 31, 1BC (counting the year 0000). - $Ny=$y; - - # Number of full 4th years (incl. 0000) since Dec 31, 1BC - $N4=($Ny-1)/4 + 1; - $N4=0 if ($y==0); - - # Number of full 100th years (incl. 0000) - $N100=$cc + 1; - $N100-- if ($yy==0); - $N100=0 if ($y==0); - - # Number of full 400th years (incl. 0000) - $N400=($N100-1)/4 + 1; - $N400=0 if ($y==0); - - $dayofyear=&Date_DayOfYear($m,$d,$y); - $days= $Ny*365 + $N4 - $N100 + $N400 + $dayofyear; - - return $days; -} - -sub Date_DayOfYear { - print "DEBUG: Date_DayOfYear\n" if ($Curr{"Debug"} =~ /trace/); - my($m,$d,$y)=@_; - $y=&Date_FixYear($y) if (length($y)!=4); - # DinM = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) - my(@days) = ( 0, 31, 59, 90,120,151,181,212,243,273,304,334,365); - my($ly)=0; - $ly=1 if ($m>2 && &Date_LeapYear($y)); - return ($days[$m-1]+$d+$ly); -} - -sub Date_DaysInYear { - print "DEBUG: Date_DaysInYear\n" if ($Curr{"Debug"} =~ /trace/); - my($y)=@_; - $y=&Date_FixYear($y) if (length($y)!=4); - return 366 if (&Date_LeapYear($y)); - return 365; -} - -sub Date_WeekOfYear { - print "DEBUG: Date_WeekOfYear\n" if ($Curr{"Debug"} =~ /trace/); - my($m,$d,$y,$f)=@_; - &Date_Init() if (! $Curr{"InitDone"}); - $y=&Date_FixYear($y) if (length($y)!=4); - - my($day,$dow,$doy)=(); - $doy=&Date_DayOfYear($m,$d,$y); - - # The current DayOfYear and DayOfWeek - if ($Cnf{"Jan1Week1"}) { - $day=1; - } else { - $day=4; - } - $dow=&Date_DayOfWeek(1,$day,$y); - - # Move back to the first day of week 1. - $f-=7 if ($f>$dow); - $day-= ($dow-$f); - - return 0 if ($day>$doy); # Day is in last week of previous year - return (($doy-$day)/7 + 1); -} - -sub Date_LeapYear { - print "DEBUG: Date_LeapYear\n" if ($Curr{"Debug"} =~ /trace/); - my($y)=@_; - $y=&Date_FixYear($y) if (length($y)!=4); - return 0 unless $y % 4 == 0; - return 1 unless $y % 100 == 0; - return 0 unless $y % 400 == 0; - return 1; -} - -sub Date_DaySuffix { - print "DEBUG: Date_DaySuffix\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - &Date_Init() if (! $Curr{"InitDone"}); - return $Lang{$Cnf{"Language"}}{"DoML"}[$d-1]; -} - -sub Date_ConvTZ { - print "DEBUG: Date_ConvTZ\n" if ($Curr{"Debug"} =~ /trace/); - my($date,$from,$to)=@_; - if (not Date_Split($date)) { - croak "date passed in ('$date') is not a Date::Manip object"; - } - - &Date_Init() if (! $Curr{"InitDone"}); - my($gmt)=(); - - if (! $from) { - - if (! $to) { - # TZ -> ConvTZ - return $date if ($Cnf{"ConvTZ"} eq "IGNORE" or ! $Cnf{"ConvTZ"}); - $from=$Cnf{"TZ"}; - $to=$Cnf{"ConvTZ"}; - - } else { - # ConvTZ,TZ -> $to - $from=$Cnf{"ConvTZ"}; - $from=$Cnf{"TZ"} if (! $from); - } - - } else { - - if (! $to) { - # $from -> ConvTZ,TZ - return $date if ($Cnf{"ConvTZ"} eq "IGNORE"); - $to=$Cnf{"ConvTZ"}; - $to=$Cnf{"TZ"} if (! $to); - - } else { - # $from -> $to - } - } - - $to=$Zone{"n2o"}{lc($to)} - if (exists $Zone{"n2o"}{lc($to)}); - $from=$Zone{"n2o"}{lc($from)} - if (exists $Zone{"n2o"}{lc($from)}); - $gmt=$Zone{"n2o"}{"gmt"}; - - return $date if ($from !~ /^[+-]\d{4}$/ or $to !~ /^[+-]\d{4}$/); - return $date if ($from eq $to); - - my($s1,$h1,$m1,$s2,$h2,$m2,$d,$h,$m,$sign,$delta,$err,$yr,$mon,$sec)=(); - # We're going to try to do the calculation without calling DateCalc. - ($yr,$mon,$d,$h,$m,$sec)=&Date_Split($date, 1); - - # Convert $date from $from to GMT - $from=~/([+-])(\d{2})(\d{2})/; - ($s1,$h1,$m1)=($1,$2,$3); - $s1= ($s1 eq "-" ? "+" : "-"); # switch sign - $sign=$s1 . "1"; # + or - 1 - - # and from GMT to $to - $to=~/([+-])(\d{2})(\d{2})/; - ($s2,$h2,$m2)=($1,$2,$3); - - if ($s1 eq $s2) { - # Both the same sign - $m+= $sign*($m1+$m2); - $h+= $sign*($h1+$h2); - } else { - $sign=($s2 eq "-" ? +1 : -1) if ($h1<$h2 || ($h1==$h2 && $m1<$m2)); - $m+= $sign*($m1-$m2); - $h+= $sign*($h1-$h2); - } - - if ($m>59) { - $h+= $m/60; - $m-= ($m/60)*60; - } elsif ($m<0) { - $h+= ($m/60 - 1); - $m-= ($m/60 - 1)*60; - } - - if ($h>23) { - $delta=$h/24; - $h -= $delta*24; - if (($d + $delta) > 28) { - $date=&Date_Join($yr,$mon,$d,$h,$m,$sec); - return &DateCalc_DateDelta($date,"+0:0:0:$delta:0:0:0",\$err,0); - } - $d+= $delta; - } elsif ($h<0) { - $delta=-$h/24 + 1; - $h += $delta*24; - if (($d - $delta) < 1) { - $date=&Date_Join($yr,$mon,$d,$h,$m,$sec); - return &DateCalc_DateDelta($date,"-0:0:0:$delta:0:0:0",\$err,0); - } - $d-= $delta; - } - return &Date_Join($yr,$mon,$d,$h,$m,$sec); -} - -sub Date_TimeZone { - print "DEBUG: Date_TimeZone\n" if ($Curr{"Debug"} =~ /trace/); - my($null,$tz,@tz,$std,$dst,$time,$isdst,$tmp,$in)=(); - &Date_Init() if (! $Curr{"InitDone"}); - - # Get timezones from all of the relevant places - - push(@tz,$Cnf{"TZ"}) if (defined $Cnf{"TZ"}); # TZ config var - push(@tz,$ENV{"TZ"}) if (defined $ENV{"TZ"}); # TZ environ var - push(@tz,$ENV{'SYS$TIMEZONE_RULE'}) - if defined $ENV{'SYS$TIMEZONE_RULE'}; # VMS TZ environ var - push(@tz,$ENV{'SYS$TIMEZONE_NAME'}) - if defined $ENV{'SYS$TIMEZONE_NAME'}; # VMS TZ name environ var - push(@tz,$ENV{'UCX$TZ'}) - if defined $ENV{'UCX$TZ'}; # VMS TZ environ var - push(@tz,$ENV{'TCPIP$TZ'}) - if defined $ENV{'TCPIP$TZ'}; # VMS TZ environ var - - # The `date` command... if we're doing taint checking, we need to - # always call it with a full path... otherwise, use the user's path. - # - # Microsoft operating systems don't have a date command built in. Try - # to trap all the various ways of knowing we are on one of these systems. - # - # We'll try `date +%Z` first, and if that fails, we'll take just the - # `date` program and assume the output is of the format: - # Thu Aug 31 14:57:46 EDT 2000 - - unless (($^X =~ /perl\.exe$/i) or - ($OS eq "Windows") or - ($OS eq "Netware") or - ($OS eq "VMS")) { - if ($Date::Manip::NoTaint) { - if ($OS eq "VMS") { - $tz=$ENV{'SYS$TIMEZONE_NAME'}; - if (! $tz) { - $tz=$ENV{'MULTINET_TIMEZONE'}; - if (! $tz) { - $tz=$ENV{'SYS$TIMEZONE_DIFFERENTIAL'}/3600.; # e.g. '-4' for EDT - } - } - } else { - $tz=`date +%Z 2> /dev/null`; - chomp($tz); - if (! $tz) { - $tz=`date 2> /dev/null`; - chomp($tz); - $tz=(split(/\s+/,$tz))[4]; - } - } - push(@tz,$tz); - } else { - # We need to satisfy taint checking, but also look in all the - # directories in @DatePath. - # - local $ENV{PATH} = join(':', @Date::Manip::DatePath); - local $ENV{BASH_ENV} = ''; - $tz=`date +%Z 2> /dev/null`; - chomp($tz); - if (! $tz) { - $tz=`date 2> /dev/null`; - chomp($tz); - $tz=(split(/\s+/,$tz))[4]; - } - push(@tz,$tz); - } - } - - push(@tz,$main::TZ) if (defined $main::TZ); # $main::TZ - - if (-s "/etc/TIMEZONE") { # /etc/TIMEZONE - $in=new IO::File; - $in->open("/etc/TIMEZONE","r"); - while (! eof($in)) { - $tmp=<$in>; - if ($tmp =~ /^TZ\s*=\s*(.*?)\s*$/) { - push(@tz,$1); - last; - } - } - $in->close; - } - - if (-s "/etc/timezone") { # /etc/timezone - $in=new IO::File; - $in->open("/etc/timezone","r"); - while (! eof($in)) { - $tmp=<$in>; - next if ($tmp =~ /^\s*\043/); - chomp($tmp); - if ($tmp =~ /^\s*(.*?)\s*$/) { - push(@tz,$1); - last; - } - } - $in->close; - } - - # Now parse each one to find the first valid one. - foreach $tz (@tz) { - $tz =~ s/\s*$//; - $tz =~ s/^\s*//; - next if (! $tz); - - return uc($tz) - if (defined $Zone{"n2o"}{lc($tz)}); - - if ($tz =~ /^[+-]\d{4}$/) { - return $tz; - } elsif ($tz =~ /^([+-]\d{2})(?::(\d{2}))?$/) { - my($h,$m)=($1,$2); - $m="00" if (! $m); - return "$h$m"; - } - - # Handle US/Eastern format - if ($tz =~ /^$Zone{"tzones"}$/i) { - $tmp=lc $1; - $tz=$Zone{"tz2z"}{$tmp}; - } - - # Handle STD#DST# format (and STD-#DST-# formats) - if ($tz =~ /^([a-z]+)-?\d([a-z]+)-?\d?$/i) { - ($std,$dst)=($1,$2); - next if (! defined $Zone{"n2o"}{lc($std)} or - ! defined $Zone{"n2o"}{lc($dst)}); - $time = time(); - ($null,$null,$null,$null,$null,$null,$null,$null,$isdst) = - localtime($time); - return uc($dst) if ($isdst); - return uc($std); - } - } - - confess "ERROR: Date::Manip unable to determine TimeZone.\n"; -} - -# Returns 1 if $date is a work day. If $time is non-zero, the time is -# also checked to see if it falls within work hours. Returns "" if -# an invalid date is passed in. -sub Date_IsWorkDay { - print "DEBUG: Date_IsWorkDay\n" if ($Curr{"Debug"} =~ /trace/); - my($date,$time)=@_; - &Date_Init() if (! $Curr{"InitDone"}); - $date=&ParseDateString($date); - return "" if (! $date); - my($d)=$date; - $d=&Date_SetTime($date,$Cnf{"WorkDayBeg"}) if (! $time); - - my($y,$mon,$day,$tmp,$h,$m,$dow)=(); - ($y,$mon,$day,$h,$m,$tmp)=&Date_Split($d, 1); - $dow=&Date_DayOfWeek($mon,$day,$y); - - return 0 if ($dow<$Cnf{"WorkWeekBeg"} or - $dow>$Cnf{"WorkWeekEnd"} or - "$h:$m" lt $Cnf{"WorkDayBeg"} or - "$h:$m" gt $Cnf{"WorkDayEnd"}); - - if (! exists $Holiday{"dates"}{$y}) { - # There will be recursion problems if we ever end up here twice. - $Holiday{"dates"}{$y}={}; - &Date_UpdateHolidays($y) - } - $d=&Date_SetTime($date,"00:00:00"); - return 0 if (exists $Holiday{"dates"}{$y}{$d}); - 1; -} - -# Finds the day $off work days from now. If $time is passed in, we must -# also take into account the time of day. -# -# If $time is not passed in, day 0 is today (if today is a workday) or the -# next work day if it isn't. In any case, the time of day is unaffected. -# -# If $time is passed in, day 0 is now (if now is part of a workday) or the -# start of the very next work day. -sub Date_NextWorkDay { - print "DEBUG: Date_NextWorkDay\n" if ($Curr{"Debug"} =~ /trace/); - my($date,$off,$time)=@_; - &Date_Init() if (! $Curr{"InitDone"}); - $date=&ParseDateString($date); - my($err)=(); - - if (! &Date_IsWorkDay($date,$time)) { - if ($time) { - while (1) { - $date=&Date_GetNext($date,undef,0,$Cnf{"WorkDayBeg"}); - last if (&Date_IsWorkDay($date,$time)); - } - } else { - while (1) { - $date=&DateCalc_DateDelta($date,"+0:0:0:1:0:0:0",\$err,0); - last if (&Date_IsWorkDay($date,$time)); - } - } - } - - while ($off>0) { - while (1) { - $date=&DateCalc_DateDelta($date,"+0:0:0:1:0:0:0",\$err,0); - last if (&Date_IsWorkDay($date,$time)); - } - $off--; - } - - return $date; -} - -# Finds the day $off work days before now. If $time is passed in, we must -# also take into account the time of day. -# -# If $time is not passed in, day 0 is today (if today is a workday) or the -# previous work day if it isn't. In any case, the time of day is unaffected. -# -# If $time is passed in, day 0 is now (if now is part of a workday) or the -# end of the previous work period. Note that since the end of a work day -# will automatically be turned into the start of the next one, this time -# may actually be treated as AFTER the current time. -sub Date_PrevWorkDay { - print "DEBUG: Date_PrevWorkDay\n" if ($Curr{"Debug"} =~ /trace/); - my($date,$off,$time)=@_; - &Date_Init() if (! $Curr{"InitDone"}); - $date=&ParseDateString($date); - my($err)=(); - - if (! &Date_IsWorkDay($date,$time)) { - if ($time) { - while (1) { - $date=&Date_GetPrev($date,undef,0,$Cnf{"WorkDayEnd"}); - last if (&Date_IsWorkDay($date,$time)); - } - while (1) { - $date=&Date_GetNext($date,undef,0,$Cnf{"WorkDayBeg"}); - last if (&Date_IsWorkDay($date,$time)); - } - } else { - while (1) { - $date=&DateCalc_DateDelta($date,"-0:0:0:1:0:0:0",\$err,0); - last if (&Date_IsWorkDay($date,$time)); - } - } - } - - while ($off>0) { - while (1) { - $date=&DateCalc_DateDelta($date,"-0:0:0:1:0:0:0",\$err,0); - last if (&Date_IsWorkDay($date,$time)); - } - $off--; - } - - return $date; -} - -# This finds the nearest workday to $date. If $date is a workday, it -# is returned. -sub Date_NearestWorkDay { - print "DEBUG: Date_NearestWorkDay\n" if ($Curr{"Debug"} =~ /trace/); - my($date,$tomorrow)=@_; - &Date_Init() if (! $Curr{"InitDone"}); - $date=&ParseDateString($date); - my($a,$b,$dela,$delb,$err)=(); - $tomorrow=$Cnf{"TomorrowFirst"} if (! defined $tomorrow); - - return $date if (&Date_IsWorkDay($date)); - - # Find the nearest one. - if ($tomorrow) { - $dela="+0:0:0:1:0:0:0"; - $delb="-0:0:0:1:0:0:0"; - } else { - $dela="-0:0:0:1:0:0:0"; - $delb="+0:0:0:1:0:0:0"; - } - $a=$b=$date; - - while (1) { - $a=&DateCalc_DateDelta($a,$dela,\$err); - return $a if (&Date_IsWorkDay($a)); - $b=&DateCalc_DateDelta($b,$delb,\$err); - return $b if (&Date_IsWorkDay($b)); - } -} - -# &Date_NthDayOfYear($y,$n); -# Returns a list of (YYYY,MM,DD,HH,MM,SS) for the Nth day of the year. -sub Date_NthDayOfYear { - no integer; - print "DEBUG: Date_NthDayOfYear\n" if ($Curr{"Debug"} =~ /trace/); - my($y,$n)=@_; - $y=$Curr{"Y"} if (! $y); - $n=1 if (! defined $n or $n eq ""); - $n+=0; # to turn 023 into 23 - $y=&Date_FixYear($y) if (length($y)<4); - my $leap=&Date_LeapYear($y); - return () if ($n<1); - return () if ($n >= ($leap ? 367 : 366)); - - my(@d_in_m)=(31,28,31,30,31,30,31,31,30,31,30,31); - $d_in_m[1]=29 if ($leap); - - # Calculate the hours, minutes, and seconds into the day. - my $remain=($n - int($n))*24; - my $h=int($remain); - $remain=($remain - $h)*60; - my $mn=int($remain); - $remain=($remain - $mn)*60; - my $s=$remain; - - # Calculate the month and the day. - my($m,$d)=(0,0); - $n=int($n); - while ($n>0) { - $m++; - if ($n<=$d_in_m[0]) { - $d=int($n); - $n=0; - } else { - $n-= $d_in_m[0]; - shift(@d_in_m); - } - } - - ($y,$m,$d,$h,$mn,$s); -} - -######################################################################## -# NOT FOR EXPORT -######################################################################## - -# This is used in Date_Init to fill in a hash based on international -# data. It takes a list of keys and values and returns both a hash -# with these values and a regular expression of keys. -# -# IN: -# $data = [ key1 val1 key2 val2 ... ] -# $opts = lc : lowercase the keys in the regexp -# sort : sort (by length) the keys in the regexp -# back : create a regexp with a back reference -# escape : escape all strings in the regexp -# -# OUT: -# $regexp = '(?:key1|key2|...)' -# $hash = { key1=>val1 key2=>val2 ... } - -sub Date_InitHash { - print "DEBUG: Date_InitHash\n" if ($Curr{"Debug"} =~ /trace/); - my($data,$regexp,$opts,$hash)=@_; - my(@data)=@$data; - my($key,$val,@list)=(); - - # Parse the options - my($lc,$sort,$back,$escape)=(0,0,0,0); - $lc=1 if ($opts =~ /lc/i); - $sort=1 if ($opts =~ /sort/i); - $back=1 if ($opts =~ /back/i); - $escape=1 if ($opts =~ /escape/i); - - # Create the hash - while (@data) { - ($key,$val,@data)=@data; - $key=lc($key) if ($lc); - $$hash{$key}=$val; - } - - # Create the regular expression - if ($regexp) { - @list=keys(%$hash); - @list=sort sortByLength(@list) if ($sort); - if ($escape) { - foreach $val (@list) { - $val="\Q$val\E"; - } - } - if ($back) { - $$regexp="(" . join("|",@list) . ")"; - } else { - $$regexp="(?:" . join("|",@list) . ")"; - } - } -} - -# This is used in Date_Init to fill in regular expressions, lists, and -# hashes based on international data. It takes a list of lists which have -# to be stored as regular expressions (to find any element in the list), -# lists, and hashes (indicating the location in the lists). -# -# IN: -# $data = [ [ [ valA1 valA2 ... ][ valA1' valA2' ... ] ... ] -# [ [ valB1 valB2 ... ][ valB1' valB2' ... ] ... ] -# ... -# [ [ valZ1 valZ2 ... ] [valZ1' valZ1' ... ] ... ] ] -# $lists = [ \@listA \@listB ... \@listZ ] -# $opts = lc : lowercase the values in the regexp -# sort : sort (by length) the values in the regexp -# back : create a regexp with a back reference -# escape : escape all strings in the regexp -# $hash = [ \%hash, TYPE ] -# TYPE 0 : $hash{ valBn=>n-1 } -# TYPE 1 : $hash{ valBn=>n } -# -# OUT: -# $regexp = '(?:valA1|valA2|...|valB1|...)' -# $lists = [ [ valA1 valA2 ... ] # only the 1st list (or -# [ valB1 valB2 ... ] ... ] # 2nd for int. characters) -# $hash - -sub Date_InitLists { - print "DEBUG: Date_InitLists\n" if ($Curr{"Debug"} =~ /trace/); - my($data,$regexp,$opts,$lists,$hash)=@_; - my(@data)=@$data; - my(@lists)=@$lists; - my($i,@ele,$ele,@list,$j,$tmp)=(); - - # Parse the options - my($lc,$sort,$back,$escape)=(0,0,0,0); - $lc=1 if ($opts =~ /lc/i); - $sort=1 if ($opts =~ /sort/i); - $back=1 if ($opts =~ /back/i); - $escape=1 if ($opts =~ /escape/i); - - # Set each of the lists - if (@lists) { - confess "ERROR: Date_InitLists: lists must be 1 per data\n" - if ($#lists != $#data); - for ($i=0; $i<=$#data; $i++) { - @ele=@{ $data[$i] }; - if ($Cnf{"IntCharSet"} && $#ele>0) { - @{ $lists[$i] } = @{ $ele[1] }; - } else { - @{ $lists[$i] } = @{ $ele[0] }; - } - } - } - - # Create the hash - my($hashtype,$hashsave,%hash)=(); - if (@$hash) { - ($hash,$hashtype)=@$hash; - $hashsave=1; - } else { - $hashtype=0; - $hashsave=0; - } - for ($i=0; $i<=$#data; $i++) { - @ele=@{ $data[$i] }; - foreach $ele (@ele) { - @list = @{ $ele }; - for ($j=0; $j<=$#list; $j++) { - $tmp=$list[$j]; - next if (! $tmp); - $tmp=lc($tmp) if ($lc); - $hash{$tmp}= $j+$hashtype; - } - } - } - %$hash = %hash if ($hashsave); - - # Create the regular expression - if ($regexp) { - @list=keys(%hash); - @list=sort sortByLength(@list) if ($sort); - if ($escape) { - foreach $ele (@list) { - $ele="\Q$ele\E"; - } - } - if ($back) { - $$regexp="(" . join("|",@list) . ")"; - } else { - $$regexp="(?:" . join("|",@list) . ")"; - } - } -} - -# This is used in Date_Init to fill in regular expressions and lists based -# on international data. This takes a list of strings and returns a regular -# expression (to find any one of them). -# -# IN: -# $data = [ string1 string2 ... ] -# $opts = lc : lowercase the values in the regexp -# sort : sort (by length) the values in the regexp -# back : create a regexp with a back reference -# escape : escape all strings in the regexp -# -# OUT: -# $regexp = '(string1|string2|...)' - -sub Date_InitStrings { - print "DEBUG: Date_InitStrings\n" if ($Curr{"Debug"} =~ /trace/); - my($data,$regexp,$opts)=@_; - my(@list)=@{ $data }; - - # Parse the options - my($lc,$sort,$back,$escape)=(0,0,0,0); - $lc=1 if ($opts =~ /lc/i); - $sort=1 if ($opts =~ /sort/i); - $back=1 if ($opts =~ /back/i); - $escape=1 if ($opts =~ /escape/i); - - # Create the regular expression - my($ele)=(); - @list=sort sortByLength(@list) if ($sort); - if ($escape) { - foreach $ele (@list) { - $ele="\Q$ele\E"; - } - } - if ($back) { - $$regexp="(" . join("|",@list) . ")"; - } else { - $$regexp="(?:" . join("|",@list) . ")"; - } - $$regexp=lc($$regexp) if ($lc); -} - -# items is passed in (either as a space separated string, or a reference to -# a list) and a regular expression which matches any one of the items is -# prepared. The regular expression will be of one of the forms: -# "(a|b)" @list not empty, back option included -# "(?:a|b)" @list not empty -# "()" @list empty, back option included -# "" @list empty -# $options is a string which contains any of the following strings: -# back : the regular expression has a backreference -# opt : the regular expression is optional and a "?" is appended in -# the first two forms -# optws : the regular expression is optional and may be replaced by -# whitespace -# optWs : the regular expression is optional, but if not present, must -# be replaced by whitespace -# sort : the items in the list are sorted by length (longest first) -# lc : the string is lowercased -# under : any underscores are converted to spaces -# pre : it may be preceded by whitespace -# Pre : it must be preceded by whitespace -# PRE : it must be preceded by whitespace or the start -# post : it may be followed by whitespace -# Post : it must be followed by whitespace -# POST : it must be followed by whitespace or the end -# Spaces due to pre/post options will not be included in the back reference. -# -# If $array is included, then the elements will also be returned as a list. -# $array is a string which may contain any of the following: -# keys : treat the list as a hash and only the keys go into the regexp -# key0 : treat the list as the values of a hash with keys 0 .. N-1 -# key1 : treat the list as the values of a hash with keys 1 .. N -# val0 : treat the list as the keys of a hash with values 0 .. N-1 -# val1 : treat the list as the keys of a hash with values 1 .. N - -# &Date_InitLists([$lang{"month_name"},$lang{"month_abb"}], -# [\$Month,"lc,sort,back"], -# [\@Month,\@Mon], -# [\%Month,1]); - -# This is used in Date_Init to prepare regular expressions. A list of -# items is passed in (either as a space separated string, or a reference to -# a list) and a regular expression which matches any one of the items is -# prepared. The regular expression will be of one of the forms: -# "(a|b)" @list not empty, back option included -# "(?:a|b)" @list not empty -# "()" @list empty, back option included -# "" @list empty -# $options is a string which contains any of the following strings: -# back : the regular expression has a backreference -# opt : the regular expression is optional and a "?" is appended in -# the first two forms -# optws : the regular expression is optional and may be replaced by -# whitespace -# optWs : the regular expression is optional, but if not present, must -# be replaced by whitespace -# sort : the items in the list are sorted by length (longest first) -# lc : the string is lowercased -# under : any underscores are converted to spaces -# pre : it may be preceded by whitespace -# Pre : it must be preceded by whitespace -# PRE : it must be preceded by whitespace or the start -# post : it may be followed by whitespace -# Post : it must be followed by whitespace -# POST : it must be followed by whitespace or the end -# Spaces due to pre/post options will not be included in the back reference. -# -# If $array is included, then the elements will also be returned as a list. -# $array is a string which may contain any of the following: -# keys : treat the list as a hash and only the keys go into the regexp -# key0 : treat the list as the values of a hash with keys 0 .. N-1 -# key1 : treat the list as the values of a hash with keys 1 .. N -# val0 : treat the list as the keys of a hash with values 0 .. N-1 -# val1 : treat the list as the keys of a hash with values 1 .. N -sub Date_Regexp { - print "DEBUG: Date_Regexp\n" if ($Curr{"Debug"} =~ /trace/); - my($list,$options,$array)=@_; - my(@list,$ret,%hash,$i)=(); - local($_)=(); - $options="" if (! defined $options); - $array="" if (! defined $array); - - my($sort,$lc,$under)=(0,0,0); - $sort =1 if ($options =~ /sort/i); - $lc =1 if ($options =~ /lc/i); - $under=1 if ($options =~ /under/i); - my($back,$opt,$pre,$post,$ws)=("?:","","","",""); - $back ="" if ($options =~ /back/i); - $opt ="?" if ($options =~ /opt/i); - $pre ='\s*' if ($options =~ /pre/); - $pre ='\s+' if ($options =~ /Pre/); - $pre ='(?:\s+|^)' if ($options =~ /PRE/); - $post ='\s*' if ($options =~ /post/); - $post ='\s+' if ($options =~ /Post/); - $post ='(?:$|\s+)' if ($options =~ /POST/); - $ws ='\s*' if ($options =~ /optws/); - $ws ='\s+' if ($options =~ /optws/); - - my($hash,$keys,$key0,$key1,$val0,$val1)=(0,0,0,0,0,0); - $keys =1 if ($array =~ /keys/i); - $key0 =1 if ($array =~ /key0/i); - $key1 =1 if ($array =~ /key1/i); - $val0 =1 if ($array =~ /val0/i); - $val1 =1 if ($array =~ /val1/i); - $hash =1 if ($keys or $key0 or $key1 or $val0 or $val1); - - my($ref)=ref $list; - if (! $ref) { - $list =~ s/\s*$//; - $list =~ s/^\s*//; - $list =~ s/\s+/&&&/g; - } elsif ($ref eq "ARRAY") { - $list = join("&&&",@$list); - } else { - confess "ERROR: Date_Regexp.\n"; - } - - if (! $list) { - if ($back eq "") { - return "()"; - } else { - return ""; - } - } - - $list=lc($list) if ($lc); - $list=~ s/_/ /g if ($under); - @list=split(/&&&/,$list); - if ($keys) { - %hash=@list; - @list=keys %hash; - } elsif ($key0 or $key1 or $val0 or $val1) { - $i=0; - $i=1 if ($key1 or $val1); - if ($key0 or $key1) { - %hash= map { $_,$i++ } @list; - } else { - %hash= map { $i++,$_ } @list; - } - } - @list=sort sortByLength(@list) if ($sort); - - $ret="($back" . join("|",@list) . ")"; - $ret="(?:$pre$ret$post)" if ($pre or $post); - $ret.=$opt; - $ret="(?:$ret|$ws)" if ($ws); - - if ($array and $hash) { - return ($ret,%hash); - } elsif ($array) { - return ($ret,@list); - } else { - return $ret; - } -} - -# This will produce a delta with the correct number of signs. At most two -# signs will be in it normally (one before the year, and one in front of -# the day), but if appropriate, signs will be in front of all elements. -# Also, as many of the signs will be equivalent as possible. -sub Delta_Normalize { - print "DEBUG: Delta_Normalize\n" if ($Curr{"Debug"} =~ /trace/); - my($delta,$mode)=@_; - return "" if (! $delta); - return "+0:+0:+0:+0:+0:+0:+0" - if ($delta =~ /^([+-]?0+:){6}[+-]?0+$/ and $Cnf{"DeltaSigns"}); - return "+0:0:0:0:0:0:0" if ($delta =~ /^([+-]?0+:){6}[+-]?0+$/); - - my($tmp,$sign1,$sign2,$len)=(); - - # Calculate the length of the day in minutes - $len=24*60; - $len=$Curr{"WDlen"} if ($mode==2 || $mode==3); - - # We have to get the sign of every component explicitely so that a "-0" - # or "+0" doesn't get lost by treating it numerically (i.e. "-0:0:2" must - # be a negative delta). - - my($y,$mon,$w,$d,$h,$m,$s)=&Delta_Split($delta); - - # We need to make sure that the signs of all parts of a delta are the - # same. The easiest way to do this is to convert all of the large - # components to the smallest ones, then convert the smaller components - # back to the larger ones. - - # Do the year/month part - - $mon += $y*12; # convert y to m - $sign1="+"; - if ($mon<0) { - $mon *= -1; - $sign1="-"; - } - - $y = $mon/12; # convert m to y - $mon -= $y*12; - - $y=0 if ($y eq "-0"); # get around silly -0 problem - $mon=0 if ($mon eq "-0"); - - # Do the wk/day/hour/min/sec part - - { - # Unfortunately, $s is overflowing for dates more than ~70 years - # apart. - no integer; - - if ($mode==3 || $mode==2) { - $s += $d*$len*60 + $h*3600 + $m*60; # convert d/h/m to s - } else { - $s += ($d+7*$w)*$len*60 + $h*3600 + $m*60; # convert w/d/h/m to s - } - $sign2="+"; - if ($s<0) { - $s*=-1; - $sign2="-"; - } - - $m = int($s/60); # convert s to m - $s -= $m*60; - $d = int($m/$len); # convert m to d - $m -= $d*$len; - - # The rest should be fine. - } - $h = $m/60; # convert m to h - $m -= $h*60; - if ($mode == 3 || $mode == 2) { - $w = $w*1; # get around +0 problem - } else { - $w = $d/7; # convert d to w - $d -= $w*7; - } - - $w=0 if ($w eq "-0"); # get around silly -0 problem - $d=0 if ($d eq "-0"); - $h=0 if ($h eq "-0"); - $m=0 if ($m eq "-0"); - $s=0 if ($s eq "-0"); - - # Only include two signs if necessary - $sign1=$sign2 if ($y==0 and $mon==0); - $sign2=$sign1 if ($w==0 and $d==0 and $h==0 and $m==0 and $s==0); - $sign2="" if ($sign1 eq $sign2 and ! $Cnf{"DeltaSigns"}); - - if ($Cnf{"DeltaSigns"}) { - return "$sign1$y:$sign1$mon:$sign2$w:$sign2$d:$sign2$h:$sign2$m:$sign2$s"; - } else { - return "$sign1$y:$mon:$sign2$w:$d:$h:$m:$s"; - } -} - -# This checks a delta to make sure it is valid. If it is, it splits -# it and returns the elements with a sign on each. The 2nd argument -# specifies the default sign. Blank elements are set to 0. If the -# third element is non-nil, exactly 7 elements must be included. -sub Delta_Split { - print "DEBUG: Delta_Split\n" if ($Curr{"Debug"} =~ /trace/); - my($delta,$sign,$exact)=@_; - my(@delta)=split(/:/,$delta); - return () if ($exact and $#delta != 6); - my($i)=(); - $sign="+" if (! defined $sign); - for ($i=0; $i<=$#delta; $i++) { - $delta[$i]="0" if (! $delta[$i]); - return () if ($delta[$i] !~ /^[+-]?\d+$/); - $sign = ($delta[$i] =~ s/^([+-])// ? $1 : $sign); - $delta[$i] = $sign.$delta[$i]; - } - @delta; -} - -# Reads up to 3 arguments. $h may contain the time in any international -# format. Any empty elements are set to 0. -sub Date_ParseTime { - print "DEBUG: Date_ParseTime\n" if ($Curr{"Debug"} =~ /trace/); - my($h,$m,$s)=@_; - my($t)=&CheckTime("one"); - - if (defined $h and $h =~ /$t/) { - $h=$1; - $m=$2; - $s=$3 if (defined $3); - } - $h="00" if (! defined $h); - $m="00" if (! defined $m); - $s="00" if (! defined $s); - - ($h,$m,$s); -} - -# Forms a date with the 6 elements passed in (all of which must be defined). -# No check as to validity is made. -sub Date_Join { - print "DEBUG: Date_Join\n" if ($Curr{"Debug"} =~ /trace/); - foreach (0 .. $#_) { - croak "undefined arg $_ to Date_Join()" if not defined $_[$_]; - } - my($y,$m,$d,$h,$mn,$s)=@_; - my($ym,$md,$dh,$hmn,$mns)=(); - - if ($Cnf{"Internal"} == 0) { - $ym=$md=$dh=""; - $hmn=$mns=":"; - - } elsif ($Cnf{"Internal"} == 1) { - $ym=$md=$dh=$hmn=$mns=""; - - } elsif ($Cnf{"Internal"} == 2) { - $ym=$md="-"; - $dh=" "; - $hmn=$mns=":"; - - } else { - confess "ERROR: Invalid internal format in Date_Join.\n"; - } - $m="0$m" if (length($m)==1); - $d="0$d" if (length($d)==1); - $h="0$h" if (length($h)==1); - $mn="0$mn" if (length($mn)==1); - $s="0$s" if (length($s)==1); - "$y$ym$m$md$d$dh$h$hmn$mn$mns$s"; -} - -# This checks a time. If it is valid, it splits it and returns 3 elements. -# If "one" or "two" is passed in, a regexp with 1/2 or 2 digit hours is -# returned. -sub CheckTime { - print "DEBUG: CheckTime\n" if ($Curr{"Debug"} =~ /trace/); - my($time)=@_; - my($h)='(?:0?[0-9]|1[0-9]|2[0-3])'; - my($h2)='(?:0[0-9]|1[0-9]|2[0-3])'; - my($m)='[0-5][0-9]'; - my($s)=$m; - my($hm)="(?:". $Lang{$Cnf{"Language"}}{"SepHM"} ."|:)"; - my($ms)="(?:". $Lang{$Cnf{"Language"}}{"SepMS"} ."|:)"; - my($ss)=$Lang{$Cnf{"Language"}}{"SepSS"}; - my($t)="^($h)$hm($m)(?:$ms($s)(?:$ss\\d+)?)?\$"; - if ($time eq "one") { - return $t; - } elsif ($time eq "two") { - $t="^($h2)$hm($m)(?:$ms($s)(?:$ss\\d+)?)?\$"; - return $t; - } - - if ($time =~ /$t/i) { - ($h,$m,$s)=($1,$2,$3); - $h="0$h" if (length($h)<2); - $m="0$m" if (length($m)<2); - $s="00" if (! defined $s); - return ($h,$m,$s); - } else { - return (); - } -} - -# This checks a recurrence. If it is valid, it splits it and returns the -# elements. Otherwise, it returns an empty list. -# ($recur0,$recur1,$flags,$dateb,$date0,$date1)=&Recur_Split($recur); -sub Recur_Split { - print "DEBUG: Recur_Split\n" if ($Curr{"Debug"} =~ /trace/); - my($recur)=@_; - my(@ret,@tmp); - - my($R) = '(\*?(?:[-,0-9]+[:\*]){6}[-,0-9]+)'; - my($F) = '(?:\*([^*]*))'; - my($DB,$D0,$D1); - $DB=$D0=$D1=$F; - - if ($recur =~ /^$R$F?$DB?$D0?$D1?$/) { - @ret=($1,$2,$3,$4,$5); - @tmp=split(/\*/,shift(@ret)); - return () if ($#tmp>1); - return (@tmp,"",@ret) if ($#tmp==0); - return (@tmp,@ret); - } - return (); -} - -# This checks a date. If it is valid, it splits it and returns the elements. -# If no date is passed in, it returns a regular expression for the date. -# -# The optional second argument says 'I really expect this to be a -# valid Date::Manip object, please throw an exception if it is -# not'. Otherwise, errors are signalled by returning (). -# -sub Date_Split { - print "DEBUG: Date_Split\n" if ($Curr{"Debug"} =~ /trace/); - my($date, $definitely_valid)=@_; - $definitely_valid = 0 if not defined $definitely_valid; - my($ym,$md,$dh,$hmn,$mns)=(); - my($y)='(\d{4})'; - my($m)='(0[1-9]|1[0-2])'; - my($d)='(0[1-9]|[1-2][0-9]|3[0-1])'; - my($h)='([0-1][0-9]|2[0-3])'; - my($mn)='([0-5][0-9])'; - my($s)=$mn; - - if ($Cnf{"Internal"} == 0) { - $ym=$md=$dh=""; - $hmn=$mns=":"; - - } elsif ($Cnf{"Internal"} == 1) { - $ym=$md=$dh=$hmn=$mns=""; - - } elsif ($Cnf{"Internal"} == 2) { - $ym=$md="-"; - $dh=" "; - $hmn=$mns=":"; - - } else { - confess "ERROR: Invalid internal format in Date_Split.\n"; - } - - my($t)="^$y$ym$m$md$d$dh$h$hmn$mn$mns$s\$"; - - if (not defined $date or $date eq '') { - if ($definitely_valid) { - die "bad date '$date'"; - } else { - return $t; - } - } - - if ($date =~ /$t/) { - ($y,$m,$d,$h,$mn,$s)=($1,$2,$3,$4,$5,$6); - my(@d_in_m)=(0,31,28,31,30,31,30,31,31,30,31,30,31); - $d_in_m[2]=29 if (&Date_LeapYear($y)); - if ($d>$d_in_m[$m]) { - my $msg = "invalid date $date: day $d of month $m, but only $d_in_m[$m] days in that month"; - if ($definitely_valid) { - die $msg; - } - else { - warn $msg; - return (); - } - } - return ($y,$m,$d,$h,$mn,$s); - } - - if ($definitely_valid) { - die "invalid date $date: doesn't match regexp $t"; - } - return (); -} - -# This returns the date easter occurs on for a given year as ($month,$day). -# This is from the Calendar FAQ. -sub Date_Easter { - my($y)=@_; - $y=&Date_FixYear($y) if (length($y)==2); - - my($c) = $y/100; - my($g) = $y % 19; - my($k) = ($c-17)/25; - my($i) = ($c - $c/4 - ($c-$k)/3 + 19*$g + 15) % 30; - $i = $i - ($i/28)*(1 - ($i/28)*(29/($i+1))*((21-$g)/11)); - my($j) = ($y + $y/4 + $i + 2 - $c + $c/4) % 7; - my($l) = $i-$j; - my($m) = 3 + ($l+40)/44; - my($d) = $l + 28 - 31*($m/4); - return ($m,$d); -} - -# This takes a list of years, months, WeekOfMonth's, and optionally -# DayOfWeek's, and returns a list of dates. Optionally, a list of dates -# can be passed in as the 1st argument (with the 2nd argument the null list) -# and the year/month of these will be used. -# -# If $FDn is non-zero, the first week of the month contains the first -# occurence of this day (1=Monday). If $FIn is non-zero, the first week of -# the month contains the date (i.e. $FIn'th day of the month). -sub Date_Recur_WoM { - my($y,$m,$w,$d,$FDn,$FIn)=@_; - my(@y)=@$y; - my(@m)=@$m; - my(@w)=@$w; - my(@d)=@$d; - my($date0,$date1,@tmp,@date,$d0,$d1,@tmp2)=(); - - if (@m) { - @tmp=(); - foreach $y (@y) { - return () if (length($y)==1 || length($y)==3 || ! &IsInt($y,0,9999)); - $y=&Date_FixYear($y) if (length($y)==2); - push(@tmp,$y); - } - @y=sort { $a<=>$b } (@tmp); - - return () if (! @m); - foreach $m (@m) { - return () if (! &IsInt($m,1,12)); - } - @m=sort { $a<=>$b } (@m); - - @tmp=@tmp2=(); - foreach $y (@y) { - foreach $m (@m) { - push(@tmp,$y); - push(@tmp2,$m); - } - } - - @y=@tmp; - @m=@tmp2; - - } else { - foreach $d0 (@y) { - @tmp=&Date_Split($d0); - return () if (! @tmp); - push(@tmp2,$tmp[0]); - push(@m,$tmp[1]); - } - @y=@tmp2; - } - - return () if (! @w); - foreach $w (@w) { - return () if ($w==0 || ! &IsInt($w,-5,5)); - } - - if (@d) { - foreach $d (@d) { - return () if (! &IsInt($d,1,7)); - } - @d=sort { $a<=>$b } (@d); - } - - @date=(); - foreach $y (@y) { - $m=shift(@m); - - # Find 1st day of this month and next month - $date0=&Date_Join($y,$m,1,0,0,0); - $date1=&DateCalc($date0,"+0:1:0:0:0:0:0"); - - if (@d) { - foreach $d (@d) { - # Find 1st occurence of DOW (in both months) - $d0=&Date_GetNext($date0,$d,1); - $d1=&Date_GetNext($date1,$d,1); - - @tmp=(); - while (&Date_Cmp($d0,$d1)<0) { - push(@tmp,$d0); - $d0=&DateCalc($d0,"+0:0:1:0:0:0:0"); - } - - @tmp2=(); - foreach $w (@w) { - if ($w>0) { - push(@tmp2,$tmp[$w-1]); - } else { - push(@tmp2,$tmp[$#tmp+1+$w]); - } - } - @tmp2=sort(@tmp2); - push(@date,@tmp2); - } - - } else { - # Find 1st day of 1st week - if ($FDn != 0) { - $date0=&Date_GetNext($date0,$FDn,1); - } else { - $date0=&Date_Join($y,$m,$FIn,0,0,0); - } - $date0=&Date_GetPrev($date0,$Cnf{"FirstDay"},1); - - # Find 1st day of 1st week of next month - if ($FDn != 0) { - $date1=&Date_GetNext($date1,$FDn,1); - } else { - $date1=&DateCalc($date1,"+0:0:0:".($FIn-1).":0:0:0") if ($FIn>1); - } - $date1=&Date_GetPrev($date1,$Cnf{"FirstDay"},1); - - @tmp=(); - while (&Date_Cmp($date0,$date1)<0) { - push(@tmp,$date0); - $date0=&DateCalc($date0,"+0:0:1:0:0:0:0"); - } - - @tmp2=(); - foreach $w (@w) { - if ($w>0) { - push(@tmp2,$tmp[$w-1]); - } else { - push(@tmp2,$tmp[$#tmp+1+$w]); - } - } - @tmp2=sort(@tmp2); - push(@date,@tmp2); - } - } - - @date; -} - -# This returns a sorted list of dates formed by adding/subtracting -# $delta to $dateb in the range $date0<=$d<$dateb. The first date int -# the list is actually the first date<$date0 and the last date in the -# list is the first date>=$date1 (because sometimes the set part will -# move the date back into the range). -sub Date_Recur { - my($date0,$date1,$dateb,$delta)=@_; - my(@ret,$d)=(); - - while (&Date_Cmp($dateb,$date0)<0) { - $dateb=&DateCalc_DateDelta($dateb,$delta); - } - while (&Date_Cmp($dateb,$date1)>=0) { - $dateb=&DateCalc_DateDelta($dateb,"-$delta"); - } - - # Add the dates $date0..$dateb - $d=$dateb; - while (&Date_Cmp($d,$date0)>=0) { - unshift(@ret,$d); - $d=&DateCalc_DateDelta($d,"-$delta"); - } - # Add the first date earler than the range - unshift(@ret,$d); - - # Add the dates $dateb..$date1 - $d=&DateCalc_DateDelta($dateb,$delta); - while (&Date_Cmp($d,$date1)<0) { - push(@ret,$d); - $d=&DateCalc_DateDelta($d,$delta); - } - # Add the first date later than the range - push(@ret,$d); - - @ret; -} - -# This sets the values in each date of a recurrence. -# -# $h,$m,$s can each be values or lists "1-2,4". If any are equal to "-1", -# they are not set (and none of the larger elements are set). -sub Date_RecurSetTime { - my($date0,$date1,$dates,$h,$m,$s)=@_; - my(@dates)=@$dates; - my(@h,@m,@s,$date,@tmp)=(); - - $m="-1" if ($s eq "-1"); - $h="-1" if ($m eq "-1"); - - if ($h ne "-1") { - @h=&ReturnList($h); - return () if ! (@h); - @h=sort { $a<=>$b } (@h); - - @tmp=(); - foreach $date (@dates) { - foreach $h (@h) { - push(@tmp,&Date_SetDateField($date,"h",$h,1)); - } - } - @dates=@tmp; - } - - if ($m ne "-1") { - @m=&ReturnList($m); - return () if ! (@m); - @m=sort { $a<=>$b } (@m); - - @tmp=(); - foreach $date (@dates) { - foreach $m (@m) { - push(@tmp,&Date_SetDateField($date,"mn",$m,1)); - } - } - @dates=@tmp; - } - - if ($s ne "-1") { - @s=&ReturnList($s); - return () if ! (@s); - @s=sort { $a<=>$b } (@s); - - @tmp=(); - foreach $date (@dates) { - foreach $s (@s) { - push(@tmp,&Date_SetDateField($date,"s",$s,1)); - } - } - @dates=@tmp; - } - - @tmp=(); - foreach $date (@dates) { - push(@tmp,$date) if (&Date_Cmp($date,$date0)>=0 && - &Date_Cmp($date,$date1)<0 && - &Date_Split($date)); - } - - @tmp; -} - -sub DateCalc_DateDate { - print "DEBUG: DateCalc_DateDate\n" if ($Curr{"Debug"} =~ /trace/); - my($D1,$D2,$mode)=@_; - my(@d_in_m)=(0,31,28,31,30,31,30,31,31,30,31,30,31); - $mode=0 if (! defined $mode); - - # Exact mode - if ($mode==0) { - my($y1,$m1,$d1,$h1,$mn1,$s1)=&Date_Split($D1, 1); - my($y2,$m2,$d2,$h2,$mn2,$s2)=&Date_Split($D2, 1); - my($i,@delta,$d,$delta,$y)=(); - - # form the delta for hour/min/sec - $delta[4]=$h2-$h1; - $delta[5]=$mn2-$mn1; - $delta[6]=$s2-$s1; - - # form the delta for yr/mon/day - $delta[0]=$delta[1]=0; - $d=0; - if ($y2>$y1) { - $d=&Date_DaysInYear($y1) - &Date_DayOfYear($m1,$d1,$y1); - $d+=&Date_DayOfYear($m2,$d2,$y2); - for ($y=$y1+1; $y<$y2; $y++) { - $d+= &Date_DaysInYear($y); - } - } elsif ($y2<$y1) { - $d=&Date_DaysInYear($y2) - &Date_DayOfYear($m2,$d2,$y2); - $d+=&Date_DayOfYear($m1,$d1,$y1); - for ($y=$y2+1; $y<$y1; $y++) { - $d+= &Date_DaysInYear($y); - } - $d *= -1; - } else { - $d=&Date_DayOfYear($m2,$d2,$y2) - &Date_DayOfYear($m1,$d1,$y1); - } - $delta[2]=0; - $delta[3]=$d; - - for ($i=0; $i<7; $i++) { - $delta[$i]="+".$delta[$i] if ($delta[$i]>=0); - } - - $delta=join(":",@delta); - $delta=&Delta_Normalize($delta,0); - return $delta; - } - - my($date1,$date2)=($D1,$D2); - my($tmp,$sign,$err,@tmp)=(); - - # make sure both are work days - if ($mode==2 || $mode==3) { - $date1=&Date_NextWorkDay($date1,0,1); - $date2=&Date_NextWorkDay($date2,0,1); - } - - # make sure date1 comes before date2 - if (&Date_Cmp($date1,$date2)>0) { - $sign="-"; - $tmp=$date1; - $date1=$date2; - $date2=$tmp; - } else { - $sign="+"; - } - if (&Date_Cmp($date1,$date2)==0) { - return "+0:+0:+0:+0:+0:+0:+0" if ($Cnf{"DeltaSigns"}); - return "+0:0:0:0:0:0:0"; - } - - my($y1,$m1,$d1,$h1,$mn1,$s1)=&Date_Split($date1, 1); - my($y2,$m2,$d2,$h2,$mn2,$s2)=&Date_Split($date2, 1); - my($dy,$dm,$dw,$dd,$dh,$dmn,$ds,$ddd)=(0,0,0,0,0,0,0,0); - - if ($mode != 3) { - - # Do years - $dy=$y2-$y1; - $dm=0; - if ($dy>0) { - $tmp=&DateCalc_DateDelta($date1,"+$dy:0:0:0:0:0:0",\$err,0); - if (&Date_Cmp($tmp,$date2)>0) { - $dy--; - $tmp=$date1; - $tmp=&DateCalc_DateDelta($date1,"+$dy:0:0:0:0:0:0",\$err,0) - if ($dy>0); - $dm=12; - } - $date1=$tmp; - } - - # Do months - $dm+=$m2-$m1; - if ($dm>0) { - $tmp=&DateCalc_DateDelta($date1,"+0:$dm:0:0:0:0:0",\$err,0); - if (&Date_Cmp($tmp,$date2)>0) { - $dm--; - $tmp=$date1; - $tmp=&DateCalc_DateDelta($date1,"+0:$dm:0:0:0:0:0",\$err,0) - if ($dm>0); - } - $date1=$tmp; - } - - # At this point, check to see that we're on a business day again so that - # Aug 3 (Monday) -> Sep 3 (Sunday) -> Sep 4 (Monday) = 1 month - if ($mode==2) { - if (! &Date_IsWorkDay($date1,0)) { - $date1=&Date_NextWorkDay($date1,0,1); - } - } - } - - # Do days - if ($mode==2 || $mode==3) { - $dd=0; - while (1) { - $tmp=&Date_NextWorkDay($date1,1,1); - if (&Date_Cmp($tmp,$date2)<=0) { - $dd++; - $date1=$tmp; - } else { - last; - } - } - - } else { - ($y1,$m1,$d1)=( &Date_Split($date1, 1) )[0..2]; - $dd=0; - # If we're jumping across months, set $d1 to the first of the next month - # (or possibly the 0th of next month which is equivalent to the last day - # of this month) - if ($m1!=$m2) { - $d_in_m[2]=29 if (&Date_LeapYear($y1)); - $dd=$d_in_m[$m1]-$d1+1; - $d1=1; - $tmp=&DateCalc_DateDelta($date1,"+0:0:0:$dd:0:0:0",\$err,0); - if (&Date_Cmp($tmp,$date2)>0) { - $dd--; - $d1--; - $tmp=&DateCalc_DateDelta($date1,"+0:0:0:$dd:0:0:0",\$err,0); - } - $date1=$tmp; - } - - $ddd=0; - if ($d1<$d2) { - $ddd=$d2-$d1; - $tmp=&DateCalc_DateDelta($date1,"+0:0:0:$ddd:0:0:0",\$err,0); - if (&Date_Cmp($tmp,$date2)>0) { - $ddd--; - $tmp=&DateCalc_DateDelta($date1,"+0:0:0:$ddd:0:0:0",\$err,0); - } - $date1=$tmp; - } - $dd+=$ddd; - } - - # in business mode, make sure h1 comes before h2 (if not find delta between - # now and end of day and move to start of next business day) - $d1=( &Date_Split($date1, 1) )[2]; - $dh=$dmn=$ds=0; - if ($mode==2 || $mode==3 and $d1 != $d2) { - $tmp=&Date_SetTime($date1,$Cnf{"WorkDayEnd"}); - $tmp=&DateCalc_DateDelta($tmp,"+0:0:0:0:0:1:0") - if ($Cnf{"WorkDay24Hr"}); - $tmp=&DateCalc_DateDate($date1,$tmp,0); - ($tmp,$tmp,$tmp,$tmp,$dh,$dmn,$ds)=&Delta_Split($tmp); - $date1=&Date_NextWorkDay($date1,1,0); - $date1=&Date_SetTime($date1,$Cnf{"WorkDayBeg"}); - $d1=( &Date_Split($date1, 1) )[2]; - confess "ERROR: DateCalc DateDate Business.\n" if ($d1 != $d2); - } - - # Hours, minutes, seconds - $tmp=&DateCalc_DateDate($date1,$date2,0); - @tmp=&Delta_Split($tmp); - $dh += $tmp[4]; - $dmn += $tmp[5]; - $ds += $tmp[6]; - - $tmp="$sign$dy:$dm:0:$dd:$dh:$dmn:$ds"; - &Delta_Normalize($tmp,$mode); -} - -sub DateCalc_DeltaDelta { - print "DEBUG: DateCalc_DeltaDelta\n" if ($Curr{"Debug"} =~ /trace/); - my($D1,$D2,$mode)=@_; - my(@delta1,@delta2,$i,$delta,@delta)=(); - $mode=0 if (! defined $mode); - - @delta1=&Delta_Split($D1); - @delta2=&Delta_Split($D2); - for ($i=0; $i<7; $i++) { - $delta[$i]=$delta1[$i]+$delta2[$i]; - $delta[$i]="+".$delta[$i] if ($delta[$i]>=0); - } - - $delta=join(":",@delta); - $delta=&Delta_Normalize($delta,$mode); - return $delta; -} - -sub DateCalc_DateDelta { - print "DEBUG: DateCalc_DateDelta\n" if ($Curr{"Debug"} =~ /trace/); - my($D1,$D2,$errref,$mode)=@_; - my($date)=(); - my(@d_in_m)=(0,31,28,31,30,31,30,31,31,30,31,30,31); - my($h1,$m1,$h2,$m2,$len,$hh,$mm)=(); - $mode=0 if (! defined $mode); - - if ($mode==2 || $mode==3) { - $h1=$Curr{"WDBh"}; - $m1=$Curr{"WDBm"}; - $h2=$Curr{"WDEh"}; - $m2=$Curr{"WDEm"}; - $hh=$h2-$h1; - $mm=$m2-$m1; - if ($mm<0) { - $hh--; - $mm+=60; - } - } - - # Date, delta - my($y,$m,$d,$h,$mn,$s)=&Date_Split($D1, 1); - my($dy,$dm,$dw,$dd,$dh,$dmn,$ds)=&Delta_Split($D2); - - # do the month/year part - $y+=$dy; - while (length($y)<4) { - $y = "0$y"; - } - &ModuloAddition(-12,$dm,\$m,\$y); # -12 means 1-12 instead of 0-11 - $d_in_m[2]=29 if (&Date_LeapYear($y)); - - # if we have gone past the last day of a month, move the date back to - # the last day of the month - if ($d>$d_in_m[$m]) { - $d=$d_in_m[$m]; - } - - # do the week part - if ($mode==0 || $mode==1) { - $dd += $dw*7; - } else { - $date=&DateCalc_DateDelta(&Date_Join($y,$m,$d,$h,$mn,$s), - "+0:0:$dw:0:0:0:0",0); - ($y,$m,$d,$h,$mn,$s)=&Date_Split($date, 1); - } - - # in business mode, set the day to a work day at this point so the h/mn/s - # stuff will work out - if ($mode==2 || $mode==3) { - $d=$d_in_m[$m] if ($d>$d_in_m[$m]); - $date=&Date_NextWorkDay(&Date_Join($y,$m,$d,$h,$mn,$s),0,1); - ($y,$m,$d,$h,$mn,$s)=&Date_Split($date, 1); - } - - # seconds, minutes, hours - &ModuloAddition(60,$ds,\$s,\$mn); - if ($mode==2 || $mode==3) { - while (1) { - &ModuloAddition(60,$dmn,\$mn,\$h); - $h+= $dh; - - if ($h>$h2 or $h==$h2 && $mn>$m2) { - $dh=$h-$h2; - $dmn=$mn-$m2; - $h=$h1; - $mn=$m1; - $dd++; - - } elsif ($h<$h1 or $h==$h1 && $mn<$m1) { - $dh=$h-$h1; - $dmn=$m1-$mn; - $h=$h2; - $mn=$m2; - $dd--; - - } elsif ($h==$h2 && $mn==$m2) { - $dd++; - $dh=-$hh; - $dmn=-$mm; - - } else { - last; - } - } - - } else { - &ModuloAddition(60,$dmn,\$mn,\$h); - &ModuloAddition(24,$dh,\$h,\$d); - } - - # If we have just gone past the last day of the month, we need to make - # up for this: - if ($d>$d_in_m[$m]) { - $dd+= $d-$d_in_m[$m]; - $d=$d_in_m[$m]; - } - - # days - if ($mode==2 || $mode==3) { - if ($dd>=0) { - $date=&Date_NextWorkDay(&Date_Join($y,$m,$d,$h,$mn,$s),$dd,1); - } else { - $date=&Date_PrevWorkDay(&Date_Join($y,$m,$d,$h,$mn,$s),-$dd,1); - } - ($y,$m,$d,$h,$mn,$s)=&Date_Split($date, 1); - - } else { - $d_in_m[2]=29 if (&Date_LeapYear($y)); - $d=$d_in_m[$m] if ($d>$d_in_m[$m]); - $d += $dd; - while ($d<1) { - $m--; - if ($m==0) { - $m=12; - $y--; - if (&Date_LeapYear($y)) { - $d_in_m[2]=29; - } else { - $d_in_m[2]=28; - } - } - $d += $d_in_m[$m]; - } - while ($d>$d_in_m[$m]) { - $d -= $d_in_m[$m]; - $m++; - if ($m==13) { - $m=1; - $y++; - if (&Date_LeapYear($y)) { - $d_in_m[2]=29; - } else { - $d_in_m[2]=28; - } - } - } - } - - if ($y<0 or $y>9999) { - $$errref=3; - return; - } - &Date_Join($y,$m,$d,$h,$mn,$s); -} - -sub Date_UpdateHolidays { - print "DEBUG: Date_UpdateHolidays\n" if ($Curr{"Debug"} =~ /trace/); - my($year)=@_; - $Holiday{"year"}=$year; - $Holiday{"dates"}{$year}={}; - - my($date,$delta,$err)=(); - my($key,@tmp,$tmp); - - foreach $key (keys %{ $Holiday{"desc"} }) { - @tmp=&Recur_Split($key); - if (@tmp) { - $tmp=&ParseDateString("${year}010100:00:00"); - ($date)=&ParseRecur($key,$tmp,$tmp,($year+1)."-01-01"); - next if (! $date); - - } elsif ($key =~ /^(.*)([+-].*)$/) { - # Date +/- Delta - ($date,$delta)=($1,$2); - $tmp=&ParseDateString("$date $year"); - if ($tmp) { - $date=$tmp; - } else { - $date=&ParseDateString($date); - next if ($date !~ /^$year/); - } - $date=&DateCalc($date,$delta,\$err,0); - - } else { - # Date - $date=$key; - $tmp=&ParseDateString("$date $year"); - if ($tmp) { - $date=$tmp; - } else { - $date=&ParseDateString($date); - next if ($date !~ /^$year/); - } - } - $Holiday{"dates"}{$year}{$date}=$Holiday{"desc"}{$key}; - } -} - -# This sets a Date::Manip config variable. -sub Date_SetConfigVariable { - print "DEBUG: Date_SetConfigVariable\n" if ($Curr{"Debug"} =~ /trace/); - my($var,$val)=@_; - - # These are most appropriate for command line options instead of in files. - $Cnf{"PathSep"}=$val, return if ($var =~ /^PathSep$/i); - $Cnf{"PersonalCnf"}=$val, return if ($var =~ /^PersonalCnf$/i); - $Cnf{"PersonalCnfPath"}=$val, return if ($var =~ /^PersonalCnfPath$/i); - &EraseHolidays(), return if ($var =~ /^EraseHolidays$/i); - $Cnf{"IgnoreGlobalCnf"}=1, return if ($var =~ /^IgnoreGlobalCnf$/i); - $Cnf{"GlobalCnf"}=$val, return if ($var =~ /^GlobalCnf$/i); - - $Curr{"InitLang"}=1, - $Cnf{"Language"}=$val, return if ($var =~ /^Language$/i); - $Cnf{"DateFormat"}=$val, return if ($var =~ /^DateFormat$/i); - $Cnf{"TZ"}=$val, return if ($var =~ /^TZ$/i); - $Cnf{"ConvTZ"}=$val, return if ($var =~ /^ConvTZ$/i); - $Cnf{"Internal"}=$val, return if ($var =~ /^Internal$/i); - $Cnf{"FirstDay"}=$val, return if ($var =~ /^FirstDay$/i); - $Cnf{"WorkWeekBeg"}=$val, return if ($var =~ /^WorkWeekBeg$/i); - $Cnf{"WorkWeekEnd"}=$val, return if ($var =~ /^WorkWeekEnd$/i); - $Cnf{"WorkDayBeg"}=$val, - $Curr{"ResetWorkDay"}=1, return if ($var =~ /^WorkDayBeg$/i); - $Cnf{"WorkDayEnd"}=$val, - $Curr{"ResetWorkDay"}=1, return if ($var =~ /^WorkDayEnd$/i); - $Cnf{"WorkDay24Hr"}=$val, - $Curr{"ResetWorkDay"}=1, return if ($var =~ /^WorkDay24Hr$/i); - $Cnf{"DeltaSigns"}=$val, return if ($var =~ /^DeltaSigns$/i); - $Cnf{"Jan1Week1"}=$val, return if ($var =~ /^Jan1Week1$/i); - $Cnf{"YYtoYYYY"}=$val, return if ($var =~ /^YYtoYYYY$/i); - $Cnf{"UpdateCurrTZ"}=$val, return if ($var =~ /^UpdateCurrTZ$/i); - $Cnf{"IntCharSet"}=$val, return if ($var =~ /^IntCharSet$/i); - $Curr{"DebugVal"}=$val, return if ($var =~ /^Debug$/i); - $Cnf{"TomorrowFirst"}=$val, return if ($var =~ /^TomorrowFirst$/i); - $Cnf{"ForceDate"}=$val, return if ($var =~ /^ForceDate$/i); - - confess "ERROR: Unknown configuration variable $var in Date::Manip.\n"; -} - -sub EraseHolidays { - print "DEBUG: EraseHolidays\n" if ($Curr{"Debug"} =~ /trace/); - - $Cnf{"EraseHolidays"}=0; - delete $Holiday{"list"}; - $Holiday{"list"}={}; - delete $Holiday{"desc"}; - $Holiday{"desc"}={}; - $Holiday{"dates"}={}; -} - -# This returns a pointer to a list of times and events in the format -# [ date, [ events ], date, [ events ], ... ] -# where each list of events are events that are in effect at the date -# immediately preceding the list. -# -# This takes either one date or two dates as arguments. -sub Events_Calc { - print "DEBUG: Events_Calc\n" if ($Curr{"Debug"} =~ /trace/); - - my($date0,$date1)=@_; - - my($tmp); - $date0=&ParseDateString($date0); - return undef if (! $date0); - if ($date1) { - $date1=&ParseDateString($date1); - if (&Date_Cmp($date0,$date1)>0) { - $tmp=$date1; - $date1=$date0; - $date0=$tmp; - } - } else { - $date1=&DateCalc_DateDelta($date0,"+0:0:0:0:0:0:1"); - } - - # - # [ d0,d1,del,name ] => [ d0, d1+del ) - # [ d0,0,del,name ] => [ d0, d0+del ) - # - my(%ret,$d0,$d1,$del,$name,$c0,$c1); - my(@tmp)=@{ $Events{"dates"} }; - DATE: while (@tmp) { - ($d0,$d1,$del,$name)=splice(@tmp,0,4); - $d0=&ParseDateString($d0); - $d1=&ParseDateString($d1) if ($d1); - $del=&ParseDateDelta($del) if ($del); - if ($d1) { - if ($del) { - $d1=&DateCalc_DateDelta($d1,$del); - } - } else { - $d1=&DateCalc_DateDelta($d0,$del); - } - if (&Date_Cmp($d0,$d1)>0) { - $tmp=$d1; - $d1=$d0; - $d0=$tmp; - } - # [ date0,date1 ) - # [ d0,d1 ) OR [ d0,d1 ) - next DATE if (&Date_Cmp($d1,$date0)<=0 || - &Date_Cmp($d0,$date1)>=0); - # [ date0,date1 ) - # [ d0,d1 ) - # [ d0, d1 ) - if (&Date_Cmp($d0,$date0)<=0) { - push @{ $ret{$date0} },$name; - push @{ $ret{$d1} },"!$name" if (&Date_Cmp($d1,$date1)<0); - next DATE; - } - # [ date0,date1 ) - # [ d0,d1 ) - if (&Date_Cmp($d1,$date1)>=0) { - push @{ $ret{$d0} },$name; - next DATE; - } - # [ date0,date1 ) - # [ d0,d1 ) - push @{ $ret{$d0} },$name; - push @{ $ret{$d1} },"!$name"; - } - - # - # [ recur,delta0,delta1,name ] => [ {date-delta0},{date+delta1} ) - # - my($rec,$del0,$del1,@d); - @tmp=@{ $Events{"recur"} }; - RECUR: while (@tmp) { - ($rec,$del0,$del1,$name)=splice(@tmp,0,4); - @d=(); - - } - - # Sort them AND take into account the "!$name" entries. - my(%tmp,$date,@tmp2,@ret); - @d=sort { &Date_Cmp($a,$b) } keys %ret; - foreach $date (@d) { - @tmp=@{ $ret{$date} }; - @tmp2=(); - foreach $tmp (@tmp) { - push(@tmp2,$tmp), next if ($tmp =~ /^!/); - $tmp{$tmp}=1; - } - foreach $tmp (@tmp2) { - $tmp =~ s/^!//; - delete $tmp{$tmp}; - } - push(@ret,$date,[ keys %tmp ]); - } - - return \@ret; -} - -# This parses the raw events list -sub Events_ParseRaw { - print "DEBUG: Events_ParseRaw\n" if ($Curr{"Debug"} =~ /trace/); - - # Only need to be parsed once - my($force)=@_; - $Events{"parsed"}=0 if ($force); - return if ($Events{"parsed"}); - $Events{"parsed"}=1; - - my(@events)=@{ $Events{"raw"} }; - my($event,$name,@event,$date0,$date1,$tmp,$delta,$recur0,$recur1,@recur,$r, - $recur); - EVENT: while (@events) { - ($event,$name)=splice(@events,0,2); - @event=split(/\s*;\s*/,$event); - - if ($#event == 0) { - - if ($date0=&ParseDateString($event[0])) { - # - # date = event - # - $tmp=&ParseDateString("$event[0] 00:00:00"); - if ($tmp && $tmp eq $date0) { - $delta="+0:0:0:1:0:0:0"; - } else { - $delta="+0:0:0:0:1:0:0"; - } - push @{ $Events{"dates"} },($date0,0,$delta,$name); - - } elsif ($recur=&ParseRecur($event[0])) { - # - # recur = event - # - ($recur0,$recur1)=&Recur_Split($recur); - if ($recur0) { - if ($recur1) { - $r="$recur0:$recur1"; - } else { - $r=$recur0; - } - } else { - $r=$recur1; - } - (@recur)=split(/:/,$r); - if (pop(@recur)==0 && pop(@recur)==0 && pop(@recur)==0) { - $delta="+0:0:0:1:0:0:0"; - } else { - $delta="+0:0:0:0:1:0:0"; - } - push @{ $Events{"recur"} },($recur,0,$delta,$name); - - } else { - # ??? = event - warn "WARNING: illegal event ignored [ @event ]\n"; - next EVENT; - } - - } elsif ($#event == 1) { - - if ($date0=&ParseDateString($event[0])) { - - if ($date1=&ParseDateString($event[1])) { - # - # date ; date = event - # - $tmp=&ParseDateString("$event[1] 00:00:00"); - if ($tmp && $tmp eq $date1) { - $date1=&DateCalc_DateDelta($date1,"+0:0:0:1:0:0:0"); - } - push @{ $Events{"dates"} },($date0,$date1,0,$name); - - } elsif ($delta=&ParseDateDelta($event[1])) { - # - # date ; delta = event - # - push @{ $Events{"dates"} },($date0,0,$delta,$name); - - } else { - # date ; ??? = event - warn "WARNING: illegal event ignored [ @event ]\n"; - next EVENT; - } - - } elsif ($recur=&ParseRecur($event[0])) { - - if ($delta=&ParseDateDelta($event[1])) { - # - # recur ; delta = event - # - push @{ $Events{"recur"} },($recur,0,$delta,$name); - - } else { - # recur ; ??? = event - warn "WARNING: illegal event ignored [ @event ]\n"; - next EVENT; - } - - } else { - # ??? ; ??? = event - warn "WARNING: illegal event ignored [ @event ]\n"; - next EVENT; - } - - } else { - # date ; delta0 ; delta1 = event - # recur ; delta0 ; delta1 = event - # ??? ; ??? ; ??? ... = event - warn "WARNING: illegal event ignored [ @event ]\n"; - next EVENT; - } - } -} - -# This reads an init file. -sub Date_InitFile { - print "DEBUG: Date_InitFile\n" if ($Curr{"Debug"} =~ /trace/); - my($file)=@_; - my($in)=new IO::File; - local($_)=(); - my($section)="vars"; - my($var,$val,$recur,$name)=(); - - $in->open($file) || return; - while(defined ($_=<$in>)) { - chomp; - s/^\s+//; - s/\s+$//; - next if (! $_ or /^\#/); - - if (/^\*holiday/i) { - $section="holiday"; - &EraseHolidays() if ($section =~ /holiday/i && $Cnf{"EraseHolidays"}); - next; - } elsif (/^\*events/i) { - $section="events"; - next; - } - - if ($section =~ /var/i) { - confess "ERROR: invalid Date::Manip config file line.\n $_\n" - if (! /(.*\S)\s*=\s*(.*)$/); - ($var,$val)=($1,$2); - &Date_SetConfigVariable($var,$val); - - } elsif ($section =~ /holiday/i) { - confess "ERROR: invalid Date::Manip config file line.\n $_\n" - if (! /(.*\S)\s*=\s*(.*)$/); - ($recur,$name)=($1,$2); - $name="" if (! defined $name); - $Holiday{"desc"}{$recur}=$name; - - } elsif ($section =~ /events/i) { - confess "ERROR: invalid Date::Manip config file line.\n $_\n" - if (! /(.*\S)\s*=\s*(.*)$/); - ($val,$var)=($1,$2); - push @{ $Events{"raw"} },($val,$var); - - } else { - # A section not currently used by Date::Manip (but may be - # used by some extension to it). - next; - } - } - close($in); -} - -# $flag=&Date_TimeCheck(\$h,\$mn,\$s,\$ampm); -# Returns 1 if any of the fields are bad. All fields are optional, and -# all possible checks are done on the data. If a field is not passed in, -# it is set to default values. If data is missing, appropriate defaults -# are supplied. -sub Date_TimeCheck { - print "DEBUG: Date_TimeCheck\n" if ($Curr{"Debug"} =~ /trace/); - my($h,$mn,$s,$ampm)=@_; - my($tmp1,$tmp2,$tmp3)=(); - - $$h="" if (! defined $$h); - $$mn="" if (! defined $$mn); - $$s="" if (! defined $$s); - $$ampm="" if (! defined $$ampm); - $$ampm=uc($$ampm) if ($$ampm); - - # Check hour - $tmp1=$Lang{$Cnf{"Language"}}{"AmPm"}; - $tmp2=""; - if ($$ampm =~ /^$tmp1$/i) { - $tmp3=$Lang{$Cnf{"Language"}}{"AM"}; - $tmp2="AM" if ($$ampm =~ /^$tmp3$/i); - $tmp3=$Lang{$Cnf{"Language"}}{"PM"}; - $tmp2="PM" if ($$ampm =~ /^$tmp3$/i); - } elsif ($$ampm) { - return 1; - } - if ($tmp2 eq "AM" || $tmp2 eq "PM") { - $$h="0$$h" if (length($$h)==1); - return 1 if ($$h<1 || $$h>12); - $$h="00" if ($tmp2 eq "AM" and $$h==12); - $$h += 12 if ($tmp2 eq "PM" and $$h!=12); - } else { - $$h="00" if ($$h eq ""); - $$h="0$$h" if (length($$h)==1); - return 1 if (! &IsInt($$h,0,23)); - $tmp2="AM" if ($$h<12); - $tmp2="PM" if ($$h>=12); - } - $$ampm=$Lang{$Cnf{"Language"}}{"AMstr"}; - $$ampm=$Lang{$Cnf{"Language"}}{"PMstr"} if ($tmp2 eq "PM"); - - # Check minutes - $$mn="00" if ($$mn eq ""); - $$mn="0$$mn" if (length($$mn)==1); - return 1 if (! &IsInt($$mn,0,59)); - - # Check seconds - $$s="00" if ($$s eq ""); - $$s="0$$s" if (length($$s)==1); - return 1 if (! &IsInt($$s,0,59)); - - return 0; -} - -# $flag=&Date_DateCheck(\$y,\$m,\$d,\$h,\$mn,\$s,\$ampm,\$wk); -# Returns 1 if any of the fields are bad. All fields are optional, and -# all possible checks are done on the data. If a field is not passed in, -# it is set to default values. If data is missing, appropriate defaults -# are supplied. -# -# If the flag UpdateHolidays is set, the year is set to -# CurrHolidayYear. -sub Date_DateCheck { - print "DEBUG: Date_DateCheck\n" if ($Curr{"Debug"} =~ /trace/); - my($y,$m,$d,$h,$mn,$s,$ampm,$wk)=@_; - my($tmp1,$tmp2,$tmp3)=(); - - my(@d_in_m)=(0,31,28,31,30,31,30,31,31,30,31,30,31); - my($curr_y)=$Curr{"Y"}; - my($curr_m)=$Curr{"M"}; - my($curr_d)=$Curr{"D"}; - $$m=1, $$d=1 if (defined $$y and ! defined $$m and ! defined $$d); - $$y="" if (! defined $$y); - $$m="" if (! defined $$m); - $$d="" if (! defined $$d); - $$wk="" if (! defined $$wk); - $$d=$curr_d if ($$y eq "" and $$m eq "" and $$d eq ""); - - # Check year. - $$y=$curr_y if ($$y eq ""); - $$y=&Date_FixYear($$y) if (length($$y)<4); - return 1 if (! &IsInt($$y,0,9999)); - $d_in_m[2]=29 if (&Date_LeapYear($$y)); - - # Check month - $$m=$curr_m if ($$m eq ""); - $$m=$Lang{$Cnf{"Language"}}{"MonthH"}{lc($$m)} - if (exists $Lang{$Cnf{"Language"}}{"MonthH"}{lc($$m)}); - $$m="0$$m" if (length($$m)==1); - return 1 if (! &IsInt($$m,1,12)); - - # Check day - $$d="01" if ($$d eq ""); - $$d="0$$d" if (length($$d)==1); - return 1 if (! &IsInt($$d,1,$d_in_m[$$m])); - if ($$wk) { - $tmp1=&Date_DayOfWeek($$m,$$d,$$y); - $tmp2=$Lang{$Cnf{"Language"}}{"WeekH"}{lc($$wk)} - if (exists $Lang{$Cnf{"Language"}}{"WeekH"}{lc($$wk)}); - return 1 if ($tmp1 != $tmp2); - } - - return &Date_TimeCheck($h,$mn,$s,$ampm); -} - -# Takes a year in 2 digit form and returns it in 4 digit form -sub Date_FixYear { - print "DEBUG: Date_FixYear\n" if ($Curr{"Debug"} =~ /trace/); - my($y)=@_; - my($curr_y)=$Curr{"Y"}; - $y=$curr_y if (! defined $y or ! $y); - return $y if (length($y)==4); - confess "ERROR: Invalid year ($y)\n" if (length($y)!=2); - my($y1,$y2)=(); - - if (lc($Cnf{"YYtoYYYY"}) eq "c") { - $y1=substring($y,0,2); - $y="$y1$y"; - - } elsif ($Cnf{"YYtoYYYY"} =~ /^c(\d{2})$/i) { - $y1=$1; - $y="$y1$y"; - - } elsif ($Cnf{"YYtoYYYY"} =~ /^c(\d{2})(\d{2})$/i) { - $y1="$1$2"; - $y ="$1$y"; - $y += 100 if ($y<$y1); - - } else { - $y1=$curr_y-$Cnf{"YYtoYYYY"}; - $y2=$y1+99; - $y="19$y"; - while ($y<$y1) { - $y+=100; - } - while ($y>$y2) { - $y-=100; - } - } - $y; -} - -# &Date_NthWeekOfYear($y,$n); -# Returns a list of (YYYY,MM,DD) for the 1st day of the Nth week of the -# year. -# &Date_NthWeekOfYear($y,$n,$dow,$flag); -# Returns a list of (YYYY,MM,DD) for the Nth DoW of the year. If flag -# is nil, the first DoW of the year may actually be in the previous -# year (since the 1st week may include days from the previous year). -# If flag is non-nil, the 1st DoW of the year refers to the 1st one -# actually in the year -sub Date_NthWeekOfYear { - print "DEBUG: Date_NthWeekOfYear\n" if ($Curr{"Debug"} =~ /trace/); - my($y,$n,$dow,$flag)=@_; - my($m,$d,$err,$tmp,$date,%dow)=(); - $y=$Curr{"Y"} if (! defined $y or ! $y); - $n=1 if (! defined $n or $n eq ""); - return () if ($n<0 || $n>53); - if (defined $dow) { - $dow=lc($dow); - %dow=%{ $Lang{$Cnf{"Language"}}{"WeekH"} }; - $dow=$dow{$dow} if (exists $dow{$dow}); - return () if ($dow<1 || $dow>7); - $flag="" if (! defined $flag); - } else { - $dow=""; - $flag=""; - } - - $y=&Date_FixYear($y) if (length($y)<4); - if ($Cnf{"Jan1Week1"}) { - $date=&Date_Join($y,1,1,0,0,0); - } else { - $date=&Date_Join($y,1,4,0,0,0); - } - $date=&Date_GetPrev($date,$Cnf{"FirstDay"},1); - $date=&Date_GetNext($date,$dow,1) if ($dow ne ""); - - if ($flag) { - ($tmp)=&Date_Split($date, 1); - $n++ if ($tmp != $y); - } - - if ($n>1) { - $date=&DateCalc_DateDelta($date,"+0:0:". ($n-1) . ":0:0:0:0",\$err,0); - } elsif ($n==0) { - $date=&DateCalc_DateDelta($date,"-0:0:1:0:0:0:0",\$err,0); - } - ($y,$m,$d)=&Date_Split($date, 1); - ($y,$m,$d); -} - -######################################################################## -# LANGUAGE INITIALIZATION -######################################################################## - -# 8-bit international characters can be gotten by "\xXX". I don't know -# how to get 16-bit characters. I've got to read up on perllocale. -sub Char_8Bit { - my($hash)=@_; - - # grave ` - # A` 00c0 a` 00e0 - # E` 00c8 e` 00e8 - # I` 00cc i` 00ec - # O` 00d2 o` 00f2 - # U` 00d9 u` 00f9 - # W` 1e80 w` 1e81 - # Y` 1ef2 y` 1ef3 - - $$hash{"A`"} = "\xc0"; # LATIN CAPITAL LETTER A WITH GRAVE - $$hash{"E`"} = "\xc8"; # LATIN CAPITAL LETTER E WITH GRAVE - $$hash{"I`"} = "\xcc"; # LATIN CAPITAL LETTER I WITH GRAVE - $$hash{"O`"} = "\xd2"; # LATIN CAPITAL LETTER O WITH GRAVE - $$hash{"U`"} = "\xd9"; # LATIN CAPITAL LETTER U WITH GRAVE - $$hash{"a`"} = "\xe0"; # LATIN SMALL LETTER A WITH GRAVE - $$hash{"e`"} = "\xe8"; # LATIN SMALL LETTER E WITH GRAVE - $$hash{"i`"} = "\xec"; # LATIN SMALL LETTER I WITH GRAVE - $$hash{"o`"} = "\xf2"; # LATIN SMALL LETTER O WITH GRAVE - $$hash{"u`"} = "\xf9"; # LATIN SMALL LETTER U WITH GRAVE - - # acute ' - # A' 00c1 a' 00e1 - # C' 0106 c' 0107 - # E' 00c9 e' 00e9 - # I' 00cd i' 00ed - # L' 0139 l' 013a - # N' 0143 n' 0144 - # O' 00d3 o' 00f3 - # R' 0154 r' 0155 - # S' 015a s' 015b - # U' 00da u' 00fa - # W' 1e82 w' 1e83 - # Y' 00dd y' 00fd - # Z' 0179 z' 017a - - $$hash{"A'"} = "\xc1"; # LATIN CAPITAL LETTER A WITH ACUTE - $$hash{"E'"} = "\xc9"; # LATIN CAPITAL LETTER E WITH ACUTE - $$hash{"I'"} = "\xcd"; # LATIN CAPITAL LETTER I WITH ACUTE - $$hash{"O'"} = "\xd3"; # LATIN CAPITAL LETTER O WITH ACUTE - $$hash{"U'"} = "\xda"; # LATIN CAPITAL LETTER U WITH ACUTE - $$hash{"Y'"} = "\xdd"; # LATIN CAPITAL LETTER Y WITH ACUTE - $$hash{"a'"} = "\xe1"; # LATIN SMALL LETTER A WITH ACUTE - $$hash{"e'"} = "\xe9"; # LATIN SMALL LETTER E WITH ACUTE - $$hash{"i'"} = "\xed"; # LATIN SMALL LETTER I WITH ACUTE - $$hash{"o'"} = "\xf3"; # LATIN SMALL LETTER O WITH ACUTE - $$hash{"u'"} = "\xfa"; # LATIN SMALL LETTER U WITH ACUTE - $$hash{"y'"} = "\xfd"; # LATIN SMALL LETTER Y WITH ACUTE - - # double acute " " - # O" 0150 o" 0151 - # U" 0170 u" 0171 - - # circumflex ^ - # A^ 00c2 a^ 00e2 - # C^ 0108 c^ 0109 - # E^ 00ca e^ 00ea - # G^ 011c g^ 011d - # H^ 0124 h^ 0125 - # I^ 00ce i^ 00ee - # J^ 0134 j^ 0135 - # O^ 00d4 o^ 00f4 - # S^ 015c s^ 015d - # U^ 00db u^ 00fb - # W^ 0174 w^ 0175 - # Y^ 0176 y^ 0177 - - $$hash{"A^"} = "\xc2"; # LATIN CAPITAL LETTER A WITH CIRCUMFLEX - $$hash{"E^"} = "\xca"; # LATIN CAPITAL LETTER E WITH CIRCUMFLEX - $$hash{"I^"} = "\xce"; # LATIN CAPITAL LETTER I WITH CIRCUMFLEX - $$hash{"O^"} = "\xd4"; # LATIN CAPITAL LETTER O WITH CIRCUMFLEX - $$hash{"U^"} = "\xdb"; # LATIN CAPITAL LETTER U WITH CIRCUMFLEX - $$hash{"a^"} = "\xe2"; # LATIN SMALL LETTER A WITH CIRCUMFLEX - $$hash{"e^"} = "\xea"; # LATIN SMALL LETTER E WITH CIRCUMFLEX - $$hash{"i^"} = "\xee"; # LATIN SMALL LETTER I WITH CIRCUMFLEX - $$hash{"o^"} = "\xf4"; # LATIN SMALL LETTER O WITH CIRCUMFLEX - $$hash{"u^"} = "\xfb"; # LATIN SMALL LETTER U WITH CIRCUMFLEX - - # tilde ~ - # A~ 00c3 a~ 00e3 - # I~ 0128 i~ 0129 - # N~ 00d1 n~ 00f1 - # O~ 00d5 o~ 00f5 - # U~ 0168 u~ 0169 - - $$hash{"A~"} = "\xc3"; # LATIN CAPITAL LETTER A WITH TILDE - $$hash{"N~"} = "\xd1"; # LATIN CAPITAL LETTER N WITH TILDE - $$hash{"O~"} = "\xd5"; # LATIN CAPITAL LETTER O WITH TILDE - $$hash{"a~"} = "\xe3"; # LATIN SMALL LETTER A WITH TILDE - $$hash{"n~"} = "\xf1"; # LATIN SMALL LETTER N WITH TILDE - $$hash{"o~"} = "\xf5"; # LATIN SMALL LETTER O WITH TILDE - - # macron - - # A- 0100 a- 0101 - # E- 0112 e- 0113 - # I- 012a i- 012b - # O- 014c o- 014d - # U- 016a u- 016b - - # breve ( [half circle up] - # A( 0102 a( 0103 - # G( 011e g( 011f - # U( 016c u( 016d - - # dot . - # C. 010a c. 010b - # E. 0116 e. 0117 - # G. 0120 g. 0121 - # I. 0130 - # Z. 017b z. 017c - - # diaeresis : [side by side dots] - # A: 00c4 a: 00e4 - # E: 00cb e: 00eb - # I: 00cf i: 00ef - # O: 00d6 o: 00f6 - # U: 00dc u: 00fc - # W: 1e84 w: 1e85 - # Y: 0178 y: 00ff - - $$hash{"A:"} = "\xc4"; # LATIN CAPITAL LETTER A WITH DIAERESIS - $$hash{"E:"} = "\xcb"; # LATIN CAPITAL LETTER E WITH DIAERESIS - $$hash{"I:"} = "\xcf"; # LATIN CAPITAL LETTER I WITH DIAERESIS - $$hash{"O:"} = "\xd6"; # LATIN CAPITAL LETTER O WITH DIAERESIS - $$hash{"U:"} = "\xdc"; # LATIN CAPITAL LETTER U WITH DIAERESIS - $$hash{"a:"} = "\xe4"; # LATIN SMALL LETTER A WITH DIAERESIS - $$hash{"e:"} = "\xeb"; # LATIN SMALL LETTER E WITH DIAERESIS - $$hash{"i:"} = "\xef"; # LATIN SMALL LETTER I WITH DIAERESIS - $$hash{"o:"} = "\xf6"; # LATIN SMALL LETTER O WITH DIAERESIS - $$hash{"u:"} = "\xfc"; # LATIN SMALL LETTER U WITH DIAERESIS - $$hash{"y:"} = "\xff"; # LATIN SMALL LETTER Y WITH DIAERESIS - - # ring o - # U0 016e u0 016f - - # cedilla , [squiggle down and left below the letter] - # ,C 00c7 ,c 00e7 - # ,G 0122 ,g 0123 - # ,K 0136 ,k 0137 - # ,L 013b ,l 013c - # ,N 0145 ,n 0146 - # ,R 0156 ,r 0157 - # ,S 015e ,s 015f - # ,T 0162 ,t 0163 - - $$hash{",C"} = "\xc7"; # LATIN CAPITAL LETTER C WITH CEDILLA - $$hash{",c"} = "\xe7"; # LATIN SMALL LETTER C WITH CEDILLA - - # ogonek ; [squiggle down and right below the letter] - # A; 0104 a; 0105 - # E; 0118 e; 0119 - # I; 012e i; 012f - # U; 0172 u; 0173 - - # caron < [little v on top] - # A< 01cd a< 01ce - # C< 010c c< 010d - # D< 010e d< 010f - # E< 011a e< 011b - # L< 013d l< 013e - # N< 0147 n< 0148 - # R< 0158 r< 0159 - # S< 0160 s< 0161 - # T< 0164 t< 0165 - # Z< 017d z< 017e - - - # Other characters - - # First character is below, 2nd character is above - $$hash{"||"} = "\xa6"; # BROKEN BAR - $$hash{" :"} = "\xa8"; # DIAERESIS - $$hash{"-a"} = "\xaa"; # FEMININE ORDINAL INDICATOR - #$$hash{" -"}= "\xaf"; # MACRON (narrow bar) - $$hash{" -"} = "\xad"; # HYPHEN (wide bar) - $$hash{" o"} = "\xb0"; # DEGREE SIGN - $$hash{"-+"} = "\xb1"; # PLUS\342\200\220MINUS SIGN - $$hash{" 1"} = "\xb9"; # SUPERSCRIPT ONE - $$hash{" 2"} = "\xb2"; # SUPERSCRIPT TWO - $$hash{" 3"} = "\xb3"; # SUPERSCRIPT THREE - $$hash{" '"} = "\xb4"; # ACUTE ACCENT - $$hash{"-o"} = "\xba"; # MASCULINE ORDINAL INDICATOR - $$hash{" ."} = "\xb7"; # MIDDLE DOT - $$hash{", "} = "\xb8"; # CEDILLA - $$hash{"Ao"} = "\xc5"; # LATIN CAPITAL LETTER A WITH RING ABOVE - $$hash{"ao"} = "\xe5"; # LATIN SMALL LETTER A WITH RING ABOVE - $$hash{"ox"} = "\xf0"; # LATIN SMALL LETTER ETH - - # upside down characters - - $$hash{"ud!"} = "\xa1"; # INVERTED EXCLAMATION MARK - $$hash{"ud?"} = "\xbf"; # INVERTED QUESTION MARK - - # overlay characters - - $$hash{"X o"} = "\xa4"; # CURRENCY SIGN - $$hash{"Y ="} = "\xa5"; # YEN SIGN - $$hash{"S o"} = "\xa7"; # SECTION SIGN - $$hash{"O c"} = "\xa9"; # COPYRIGHT SIGN Copyright - $$hash{"O R"} = "\xae"; # REGISTERED SIGN - $$hash{"D -"} = "\xd0"; # LATIN CAPITAL LETTER ETH - $$hash{"O /"} = "\xd8"; # LATIN CAPITAL LETTER O WITH STROKE - $$hash{"o /"} = "\xf8"; # LATIN SMALL LETTER O WITH STROKE - - # special names - - $$hash{"1/4"} = "\xbc"; # VULGAR FRACTION ONE QUARTER - $$hash{"1/2"} = "\xbd"; # VULGAR FRACTION ONE HALF - $$hash{"3/4"} = "\xbe"; # VULGAR FRACTION THREE QUARTERS - $$hash{"<<"} = "\xab"; # LEFT POINTING DOUBLE ANGLE QUOTATION MARK - $$hash{">>"} = "\xbb"; # RIGHT POINTING DOUBLE ANGLE QUOTATION MARK - $$hash{"cent"}= "\xa2"; # CENT SIGN - $$hash{"lb"} = "\xa3"; # POUND SIGN - $$hash{"mu"} = "\xb5"; # MICRO SIGN - $$hash{"beta"}= "\xdf"; # LATIN SMALL LETTER SHARP S - $$hash{"para"}= "\xb6"; # PILCROW SIGN - $$hash{"-|"} = "\xac"; # NOT SIGN - $$hash{"AE"} = "\xc6"; # LATIN CAPITAL LETTER AE - $$hash{"ae"} = "\xe6"; # LATIN SMALL LETTER AE - $$hash{"x"} = "\xd7"; # MULTIPLICATION SIGN - $$hash{"P"} = "\xde"; # LATIN CAPITAL LETTER THORN - $$hash{"/"} = "\xf7"; # DIVISION SIGN - $$hash{"p"} = "\xfe"; # LATIN SMALL LETTER THORN -} - -# $hashref = &Date_Init_LANGUAGE; -# This returns a hash containing all of the initialization for a -# specific language. The hash elements are: -# -# @ month_name full month names January February ... -# @ month_abb month abbreviations Jan Feb ... -# @ day_name day names Monday Tuesday ... -# @ day_abb day abbreviations Mon Tue ... -# @ day_char day character abbrevs M T ... -# @ am AM notations -# @ pm PM notations -# -# @ num_suff number with suffix 1st 2nd ... -# @ num_word numbers spelled out first second ... -# -# $ now words which mean now now today ... -# $ last words which mean last last final ... -# $ each words which mean each each every ... -# $ of of (as in a member of) in of ... -# ex. 4th day OF June -# $ at at 4:00 at -# $ on on Sunday on -# $ future in the future in -# $ past in the past ago -# $ next next item next -# $ prev previous item last previous -# $ later 2 hours later -# -# % offset a hash of special dates { tomorrow->0:0:0:1:0:0:0 } -# % times a hash of times { noon->12:00:00 ... } -# -# $ years words for year y yr year ... -# $ months words for month -# $ weeks words for week -# $ days words for day -# $ hours words for hour -# $ minutes words for minute -# $ seconds words for second -# % replace -# The replace element is quite important, but a bit tricky. In -# English (and probably other languages), one of the abbreviations -# for the word month that would be nice is "m". The problem is that -# "m" matches the "m" in "minute" which causes the string to be -# improperly matched in some cases. Hence, the list of abbreviations -# for month is given as: -# "mon month months" -# In order to allow you to enter "m", replacements can be done. -# $replace is a list of pairs of words which are matched and replaced -# AS ENTIRE WORDS. Having $replace equal to "m"->"month" means that -# the entire word "m" will be replaced with "month". This allows the -# desired abbreviation to be used. Make sure that replace contains -# an even number of words (i.e. all must be pairs). Any time a -# desired abbreviation matches the start of any other, it has to go -# here. -# -# $ exact exact mode exactly -# $ approx approximate mode approximately -# $ business business mode business -# -# r sephm hour/minute separator (?::) -# r sepms minute/second separator (?::) -# r sepss second/fraction separator (?:[.:]) -# -# Elements marked with an asterix (@) are returned as a set of lists. -# Each list contains the strings for each element. The first set is used -# when the 7-bit ASCII (US) character set is wanted. The 2nd set is used -# when an international character set is available. Both of the 1st two -# sets should be complete (but the 2nd list can be left empty to force the -# first set to be used always). The 3rd set and later can be partial sets -# if desired. -# -# Elements marked with a dollar ($) are returned as a simple list of words. -# -# Elements marked with a percent (%) are returned as a hash list. -# -# Elements marked with (r) are regular expression elements which must not -# create a back reference. -# -# ***NOTE*** Every hash element (unless otherwise noted) MUST be defined in -# every language. - -sub Date_Init_English { - print "DEBUG: Date_Init_English\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - - $$d{"month_name"}= - [["January","February","March","April","May","June", - "July","August","September","October","November","December"]]; - - $$d{"month_abb"}= - [["Jan","Feb","Mar","Apr","May","Jun", - "Jul","Aug","Sep","Oct","Nov","Dec"], - [], - ["","","","","","","","","Sept"]]; - - $$d{"day_name"}= - [["Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday"]]; - $$d{"day_abb"}= - [["Mon","Tue","Wed","Thu","Fri","Sat","Sun"], - ["", "Tues","", "Thur","", "", ""]]; - $$d{"day_char"}= - [["M","T","W","Th","F","Sa","S"]]; - - $$d{"num_suff"}= - [["1st","2nd","3rd","4th","5th","6th","7th","8th","9th","10th", - "11th","12th","13th","14th","15th","16th","17th","18th","19th","20th", - "21st","22nd","23rd","24th","25th","26th","27th","28th","29th","30th", - "31st"]]; - $$d{"num_word"}= - [["first","second","third","fourth","fifth","sixth","seventh","eighth", - "ninth","tenth","eleventh","twelfth","thirteenth","fourteenth", - "fifteenth","sixteenth","seventeenth","eighteenth","nineteenth", - "twentieth","twenty-first","twenty-second","twenty-third", - "twenty-fourth","twenty-fifth","twenty-sixth","twenty-seventh", - "twenty-eighth","twenty-ninth","thirtieth","thirty-first"]]; - - $$d{"now"} =["today","now"]; - $$d{"last"} =["last","final"]; - $$d{"each"} =["each","every"]; - $$d{"of"} =["in","of"]; - $$d{"at"} =["at"]; - $$d{"on"} =["on"]; - $$d{"future"} =["in"]; - $$d{"past"} =["ago"]; - $$d{"next"} =["next"]; - $$d{"prev"} =["previous","last"]; - $$d{"later"} =["later"]; - - $$d{"exact"} =["exactly"]; - $$d{"approx"} =["approximately"]; - $$d{"business"}=["business"]; - - $$d{"offset"} =["yesterday","-0:0:0:1:0:0:0","tomorrow","+0:0:0:1:0:0:0"]; - $$d{"times"} =["noon","12:00:00","midnight","00:00:00"]; - - $$d{"years"} =["y","yr","year","yrs","years"]; - $$d{"months"} =["mon","month","months"]; - $$d{"weeks"} =["w","wk","wks","week","weeks"]; - $$d{"days"} =["d","day","days"]; - $$d{"hours"} =["h","hr","hrs","hour","hours"]; - $$d{"minutes"} =["mn","min","minute","minutes"]; - $$d{"seconds"} =["s","sec","second","seconds"]; - $$d{"replace"} =["m","month"]; - - $$d{"sephm"} =':'; - $$d{"sepms"} =':'; - $$d{"sepss"} ='[.:]'; - - $$d{"am"} = ["AM","A.M."]; - $$d{"pm"} = ["PM","P.M."]; -} - -sub Date_Init_Italian { - print "DEBUG: Date_Init_Italian\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - my(%h)=(); - &Char_8Bit(\%h); - my($i)=$h{"i'"}; - - $$d{"month_name"}= - [[qw(Gennaio Febbraio Marzo Aprile Maggio Giugno - Luglio Agosto Settembre Ottobre Novembre Dicembre)]]; - - $$d{"month_abb"}= - [[qw(Gen Feb Mar Apr Mag Giu Lug Ago Set Ott Nov Dic)]]; - - $$d{"day_name"}= - [[qw(Lunedi Martedi Mercoledi Giovedi Venerdi Sabato Domenica)], - [qw(Luned${i} Marted${i} Mercoled${i} Gioved${i} Venerd${i})]]; - $$d{"day_abb"}= - [[qw(Lun Mar Mer Gio Ven Sab Dom)]]; - $$d{"day_char"}= - [[qw(L Ma Me G V S D)]]; - - $$d{"num_suff"}= - [[qw(1mo 2do 3zo 4to 5to 6to 7mo 8vo 9no 10mo 11mo 12mo 13mo 14mo 15mo - 16mo 17mo 18mo 19mo 20mo 21mo 22mo 23mo 24mo 25mo 26mo 27mo 28mo - 29mo 3mo 31mo)]]; - $$d{"num_word"}= - [[qw(primo secondo terzo quarto quinto sesto settimo ottavo nono decimo - undicesimo dodicesimo tredicesimo quattordicesimo quindicesimo - sedicesimo diciassettesimo diciottesimo diciannovesimo ventesimo - ventunesimo ventiduesimo ventitreesimo ventiquattresimo - venticinquesimo ventiseiesimo ventisettesimo ventottesimo - ventinovesimo trentesimo trentunesimo)]]; - - $$d{"now"} =[qw(adesso oggi)]; - $$d{"last"} =[qw(ultimo)]; - $$d{"each"} =[qw(ogni)]; - $$d{"of"} =[qw(della del)]; - $$d{"at"} =[qw(alle)]; - $$d{"on"} =[qw(di)]; - $$d{"future"} =[qw(fra)]; - $$d{"past"} =[qw(fa)]; - $$d{"next"} =[qw(prossimo)]; - $$d{"prev"} =[qw(ultimo)]; - $$d{"later"} =[qw(dopo)]; - - $$d{"exact"} =[qw(esattamente)]; - $$d{"approx"} =[qw(circa)]; - $$d{"business"}=[qw(lavorativi lavorativo)]; - - $$d{"offset"} =[qw(ieri -0:0:0:1:0:0:0 domani +0:0:0:1:0:0:0)]; - $$d{"times"} =[qw(mezzogiorno 12:00:00 mezzanotte 00:00:00)]; - - $$d{"years"} =[qw(anni anno a)]; - $$d{"months"} =[qw(mesi mese mes)]; - $$d{"weeks"} =[qw(settimane settimana sett)]; - $$d{"days"} =[qw(giorni giorno g)]; - $$d{"hours"} =[qw(ore ora h)]; - $$d{"minutes"} =[qw(minuti minuto min)]; - $$d{"seconds"} =[qw(secondi secondo sec)]; - $$d{"replace"} =[qw(s sec m mes)]; - - $$d{"sephm"} =':'; - $$d{"sepms"} =':'; - $$d{"sepss"} ='[.:]'; - - $$d{"am"} = [qw(AM)]; - $$d{"pm"} = [qw(PM)]; -} - -sub Date_Init_French { - print "DEBUG: Date_Init_French\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - my(%h)=(); - &Char_8Bit(\%h); - my($e)=$h{"e'"}; - my($u)=$h{"u^"}; - my($a)=$h{"a'"}; - - $$d{"month_name"}= - [["janvier","fevrier","mars","avril","mai","juin", - "juillet","aout","septembre","octobre","novembre","decembre"], - ["janvier","f${e}vrier","mars","avril","mai","juin", - "juillet","ao${u}t","septembre","octobre","novembre","d${e}cembre"]]; - $$d{"month_abb"}= - [["jan","fev","mar","avr","mai","juin", - "juil","aout","sept","oct","nov","dec"], - ["jan","f${e}v","mar","avr","mai","juin", - "juil","ao${u}t","sept","oct","nov","d${e}c"]]; - - $$d{"day_name"}= - [["lundi","mardi","mercredi","jeudi","vendredi","samedi","dimanche"]]; - $$d{"day_abb"}= - [["lun","mar","mer","jeu","ven","sam","dim"]]; - $$d{"day_char"}= - [["l","ma","me","j","v","s","d"]]; - - $$d{"num_suff"}= - [["1er","2e","3e","4e","5e","6e","7e","8e","9e","10e", - "11e","12e","13e","14e","15e","16e","17e","18e","19e","20e", - "21e","22e","23e","24e","25e","26e","27e","28e","29e","30e", - "31e"]]; - $$d{"num_word"}= - [["premier","deux","trois","quatre","cinq","six","sept","huit","neuf", - "dix","onze","douze","treize","quatorze","quinze","seize","dix-sept", - "dix-huit","dix-neuf","vingt","vingt et un","vingt-deux","vingt-trois", - "vingt-quatre","vingt-cinq","vingt-six","vingt-sept","vingt-huit", - "vingt-neuf","trente","trente et un"], - ["1re"]]; - - $$d{"now"} =["aujourd'hui","maintenant"]; - $$d{"last"} =["dernier"]; - $$d{"each"} =["chaque","tous les","toutes les"]; - $$d{"of"} =["en","de"]; - $$d{"at"} =["a","${a}0"]; - $$d{"on"} =["sur"]; - $$d{"future"} =["en"]; - $$d{"past"} =["il y a"]; - $$d{"next"} =["suivant"]; - $$d{"prev"} =["precedent","pr${e}c${e}dent"]; - $$d{"later"} =["plus tard"]; - - $$d{"exact"} =["exactement"]; - $$d{"approx"} =["approximativement"]; - $$d{"business"}=["professionel"]; - - $$d{"offset"} =["hier","-0:0:0:1:0:0:0","demain","+0:0:0:1:0:0:0"]; - $$d{"times"} =["midi","12:00:00","minuit","00:00:00"]; - - $$d{"years"} =["an","annee","ans","annees","ann${e}e","ann${e}es"]; - $$d{"months"} =["mois"]; - $$d{"weeks"} =["sem","semaine"]; - $$d{"days"} =["j","jour","jours"]; - $$d{"hours"} =["h","heure","heures"]; - $$d{"minutes"} =["mn","min","minute","minutes"]; - $$d{"seconds"} =["s","sec","seconde","secondes"]; - $$d{"replace"} =["m","mois"]; - - $$d{"sephm"} ='[h:]'; - $$d{"sepms"} =':'; - $$d{"sepss"} ='[.:,]'; - - $$d{"am"} = ["du matin"]; - $$d{"pm"} = ["du soir"]; -} - -sub Date_Init_Romanian { - print "DEBUG: Date_Init_Romanian\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - my(%h)=(); - &Char_8Bit(\%h); - my($p)=$h{"p"}; - my($i)=$h{"i^"}; - my($a)=$h{"a~"}; - my($o)=$h{"-o"}; - - $$d{"month_name"}= - [["ianuarie","februarie","martie","aprilie","mai","iunie", - "iulie","august","septembrie","octombrie","noiembrie","decembrie"]]; - $$d{"month_abb"}= - [["ian","febr","mart","apr","mai","iun", - "iul","aug","sept","oct","nov","dec"], - ["","feb"]]; - - $$d{"day_name"}= - [["luni","marti","miercuri","joi","vineri","simbata","duminica"], - ["luni","mar${p}i","miercuri","joi","vineri","s${i}mb${a}t${a}", - "duminic${a}"]]; - $$d{"day_abb"}= - [["lun","mar","mie","joi","vin","sim","dum"], - ["lun","mar","mie","joi","vin","s${i}m","dum"]]; - $$d{"day_char"}= - [["L","Ma","Mi","J","V","S","D"]]; - - $$d{"num_suff"}= - [["prima","a doua","a 3-a","a 4-a","a 5-a","a 6-a","a 7-a","a 8-a", - "a 9-a","a 10-a","a 11-a","a 12-a","a 13-a","a 14-a","a 15-a", - "a 16-a","a 17-a","a 18-a","a 19-a","a 20-a","a 21-a","a 22-a", - "a 23-a","a 24-a","a 25-a","a 26-a","a 27-a","a 28-a","a 29-a", - "a 30-a","a 31-a"]]; - - $$d{"num_word"}= - [["prima","a doua","a treia","a patra","a cincea","a sasea","a saptea", - "a opta","a noua","a zecea","a unsprezecea","a doisprezecea", - "a treisprezecea","a patrusprezecea","a cincisprezecea","a saiprezecea", - "a saptesprezecea","a optsprezecea","a nouasprezecea","a douazecea", - "a douazecisiuna","a douazecisidoua","a douazecisitreia", - "a douazecisipatra","a douazecisicincea","a douazecisisasea", - "a douazecisisaptea","a douazecisiopta","a douazecisinoua","a treizecea", - "a treizecisiuna"], - ["prima","a doua","a treia","a patra","a cincea","a ${o}asea", - "a ${o}aptea","a opta","a noua","a zecea","a unsprezecea", - "a doisprezecea","a treisprezecea","a patrusprezecea","a cincisprezecea", - "a ${o}aiprezecea","a ${o}aptesprezecea","a optsprezecea", - "a nou${a}sprezecea","a dou${a}zecea","a dou${a}zeci${o}iuna", - "a dou${a}zeci${o}idoua","a dou${a}zeci${o}itreia", - "a dou${a}zeci${o}ipatra","a dou${a}zeci${o}icincea", - "a dou${a}zeci${o}i${o}asea","a dou${a}zeci${o}i${o}aptea", - "a dou${a}zeci${o}iopta","a dou${a}zeci${o}inoua","a treizecea", - "a treizeci${o}iuna"], - ["intii", "doi", "trei", "patru", "cinci", "sase", "sapte", - "opt","noua","zece","unsprezece","doisprezece", - "treisprezece","patrusprezece","cincisprezece","saiprezece", - "saptesprezece","optsprezece","nouasprezece","douazeci", - "douazecisiunu","douazecisidoi","douazecisitrei", - "douazecisipatru","douazecisicinci","douazecisisase","douazecisisapte", - "douazecisiopt","douazecisinoua","treizeci","treizecisiunu"], - ["${i}nt${i}i", "doi", "trei", "patru", "cinci", "${o}ase", "${o}apte", - "opt","nou${a}","zece","unsprezece","doisprezece", - "treisprezece","patrusprezece","cincisprezece","${o}aiprezece", - "${o}aptesprezece","optsprezece","nou${a}sprezece","dou${a}zeci", - "dou${a}zeci${o}iunu","dou${a}zeci${o}idoi","dou${a}zeci${o}itrei", - "dou${a}zecisipatru","dou${a}zeci${o}icinci","dou${a}zeci${o}i${o}ase", - "dou${a}zeci${o}i${o}apte","dou${a}zeci${o}iopt", - "dou${a}zeci${o}inou${a}","treizeci","treizeci${o}iunu"]]; - - $$d{"now"} =["acum","azi","astazi","ast${a}zi"]; - $$d{"last"} =["ultima"]; - $$d{"each"} =["fiecare"]; - $$d{"of"} =["din","in","n"]; - $$d{"at"} =["la"]; - $$d{"on"} =["on"]; - $$d{"future"} =["in","${i}n"]; - $$d{"past"} =["in urma", "${i}n urm${a}"]; - $$d{"next"} =["urmatoarea","urm${a}toarea"]; - $$d{"prev"} =["precedenta","ultima"]; - $$d{"later"} =["mai tirziu", "mai t${i}rziu"]; - - $$d{"exact"} =["exact"]; - $$d{"approx"} =["aproximativ"]; - $$d{"business"}=["de lucru","lucratoare","lucr${a}toare"]; - - $$d{"offset"} =["ieri","-0:0:0:1:0:0:0", - "alaltaieri", "-0:0:0:2:0:0:0", - "alalt${a}ieri","-0:0:0:2:0:0:0", - "miine","+0:0:0:1:0:0:0", - "m${i}ine","+0:0:0:1:0:0:0", - "poimiine","+0:0:0:2:0:0:0", - "poim${i}ine","+0:0:0:2:0:0:0"]; - $$d{"times"} =["amiaza","12:00:00", - "amiaz${a}","12:00:00", - "miezul noptii","00:00:00", - "miezul nop${p}ii","00:00:00"]; - - $$d{"years"} =["ani","an","a"]; - $$d{"months"} =["luni","luna","lun${a}","l"]; - $$d{"weeks"} =["saptamini","s${a}pt${a}m${i}ni","saptamina", - "s${a}pt${a}m${i}na","sapt","s${a}pt"]; - $$d{"days"} =["zile","zi","z"]; - $$d{"hours"} =["ore", "ora", "or${a}", "h"]; - $$d{"minutes"} =["minute","min","m"]; - $$d{"seconds"} =["secunde","sec",]; - $$d{"replace"} =["s","secunde"]; - - $$d{"sephm"} =':'; - $$d{"sepms"} =':'; - $$d{"sepss"} ='[.:,]'; - - $$d{"am"} = ["AM","A.M."]; - $$d{"pm"} = ["PM","P.M."]; -} - -sub Date_Init_Swedish { - print "DEBUG: Date_Init_Swedish\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - my(%h)=(); - &Char_8Bit(\%h); - my($ao)=$h{"ao"}; - my($o) =$h{"o:"}; - my($a) =$h{"a:"}; - - $$d{"month_name"}= - [["Januari","Februari","Mars","April","Maj","Juni", - "Juli","Augusti","September","Oktober","November","December"]]; - $$d{"month_abb"}= - [["Jan","Feb","Mar","Apr","Maj","Jun", - "Jul","Aug","Sep","Okt","Nov","Dec"]]; - - $$d{"day_name"}= - [["Mandag","Tisdag","Onsdag","Torsdag","Fredag","Lordag","Sondag"], - ["M${ao}ndag","Tisdag","Onsdag","Torsdag","Fredag","L${o}rdag", - "S${o}ndag"]]; - $$d{"day_abb"}= - [["Man","Tis","Ons","Tor","Fre","Lor","Son"], - ["M${ao}n","Tis","Ons","Tor","Fre","L${o}r","S${o}n"]]; - $$d{"day_char"}= - [["M","Ti","O","To","F","L","S"]]; - - $$d{"num_suff"}= - [["1:a","2:a","3:e","4:e","5:e","6:e","7:e","8:e","9:e","10:e", - "11:e","12:e","13:e","14:e","15:e","16:e","17:e","18:e","19:e","20:e", - "21:a","22:a","23:e","24:e","25:e","26:e","27:e","28:e","29:e","30:e", - "31:a"]]; - $$d{"num_word"}= - [["forsta","andra","tredje","fjarde","femte","sjatte","sjunde", - "attonde","nionde","tionde","elfte","tolfte","trettonde","fjortonde", - "femtonde","sextonde","sjuttonde","artonde","nittonde","tjugonde", - "tjugoforsta","tjugoandra","tjugotredje","tjugofjarde","tjugofemte", - "tjugosjatte","tjugosjunde","tjugoattonde","tjugonionde", - "trettionde","trettioforsta"], - ["f${o}rsta","andra","tredje","fj${a}rde","femte","sj${a}tte","sjunde", - "${ao}ttonde","nionde","tionde","elfte","tolfte","trettonde","fjortonde", - "femtonde","sextonde","sjuttonde","artonde","nittonde","tjugonde", - "tjugof${o}rsta","tjugoandra","tjugotredje","tjugofj${a}rde","tjugofemte", - "tjugosj${a}tte","tjugosjunde","tjugo${ao}ttonde","tjugonionde", - "trettionde","trettiof${o}rsta"]]; - - $$d{"now"} =["idag","nu"]; - $$d{"last"} =["forra","f${o}rra","senaste"]; - $$d{"each"} =["varje"]; - $$d{"of"} =["om"]; - $$d{"at"} =["kl","kl.","klockan"]; - $$d{"on"} =["pa","p${ao}"]; - $$d{"future"} =["om"]; - $$d{"past"} =["sedan"]; - $$d{"next"} =["nasta","n${a}sta"]; - $$d{"prev"} =["forra","f${o}rra"]; - $$d{"later"} =["senare"]; - - $$d{"exact"} =["exakt"]; - $$d{"approx"} =["ungefar","ungef${a}r"]; - $$d{"business"}=["arbetsdag","arbetsdagar"]; - - $$d{"offset"} =["ig${ao}r","-0:0:0:1:0:0:0","igar","-0:0:0:1:0:0:0", - "imorgon","+0:0:0:1:0:0:0"]; - $$d{"times"} =["mitt pa dagen","12:00:00","mitt p${ao} dagen","12:00:00", - "midnatt","00:00:00"]; - - $$d{"years"} =["ar","${ao}r"]; - $$d{"months"} =["man","manad","manader","m${ao}n","m${ao}nad","m${ao}nader"]; - $$d{"weeks"} =["v","vecka","veckor"]; - $$d{"days"} =["d","dag","dagar"]; - $$d{"hours"} =["t","tim","timme","timmar"]; - $$d{"minutes"} =["min","minut","minuter"]; - $$d{"seconds"} =["s","sek","sekund","sekunder"]; - $$d{"replace"} =["m","minut"]; - - $$d{"sephm"} ='[.:]'; - $$d{"sepms"} =':'; - $$d{"sepss"} ='[.:]'; - - $$d{"am"} = ["FM"]; - $$d{"pm"} = ["EM"]; -} - -sub Date_Init_German { - print "DEBUG: Date_Init_German\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - my(%h)=(); - &Char_8Bit(\%h); - my($a)=$h{"a:"}; - my($u)=$h{"u:"}; - my($o)=$h{"o:"}; - my($b)=$h{"beta"}; - - $$d{"month_name"}= - [["Januar","Februar","Maerz","April","Mai","Juni", - "Juli","August","September","Oktober","November","Dezember"], - ["J${a}nner","Februar","M${a}rz","April","Mai","Juni", - "Juli","August","September","Oktober","November","Dezember"]]; - $$d{"month_abb"}= - [["Jan","Feb","Mar","Apr","Mai","Jun", - "Jul","Aug","Sep","Okt","Nov","Dez"], - ["J${a}n","Feb","M${a}r","Apr","Mai","Jun", - "Jul","Aug","Sep","Okt","Nov","Dez"]]; - - $$d{"day_name"}= - [["Montag","Dienstag","Mittwoch","Donnerstag","Freitag","Samstag", - "Sonntag"]]; - $$d{"day_abb"}= - [["Mon","Die","Mit","Don","Fre","Sam","Son"]]; - $$d{"day_char"}= - [["M","Di","Mi","Do","F","Sa","So"]]; - - $$d{"num_suff"}= - [["1.","2.","3.","4.","5.","6.","7.","8.","9.","10.", - "11.","12.","13.","14.","15.","16.","17.","18.","19.","20.", - "21.","22.","23.","24.","25.","26.","27.","28.","29.","30.", - "31."]]; - $$d{"num_word"}= - [ - ["erste","zweite","dritte","vierte","funfte","sechste","siebente", - "achte","neunte","zehnte","elfte","zwolfte","dreizehnte","vierzehnte", - "funfzehnte","sechzehnte","siebzehnte","achtzehnte","neunzehnte", - "zwanzigste","einundzwanzigste","zweiundzwanzigste","dreiundzwanzigste", - "vierundzwanzigste","funfundzwanzigste","sechundzwanzigste", - "siebundzwanzigste","achtundzwanzigste","neunundzwanzigste", - "dreibigste","einunddreibigste"], - ["erste","zweite","dritte","vierte","f${u}nfte","sechste","siebente", - "achte","neunte","zehnte","elfte","zw${o}lfte","dreizehnte", - "vierzehnte","f${u}nfzehnte","sechzehnte","siebzehnte","achtzehnte", - "neunzehnte","zwanzigste","einundzwanzigste","zweiundzwanzigste", - "dreiundzwanzigste","vierundzwanzigste","f${u}nfundzwanzigste", - "sechundzwanzigste","siebundzwanzigste","achtundzwanzigste", - "neunundzwanzigste","drei${b}igste","einunddrei${b}igste"], - ["erster"]]; - - $$d{"now"} =["heute","jetzt"]; - $$d{"last"} =["letzte","letzten"]; - $$d{"each"} =["jeden"]; - $$d{"of"} =["der","im","des"]; - $$d{"at"} =["um"]; - $$d{"on"} =["am"]; - $$d{"future"} =["in"]; - $$d{"past"} =["vor"]; - $$d{"next"} =["nachste","n${a}chste","nachsten","n${a}chsten"]; - $$d{"prev"} =["vorherigen","vorherige","letzte","letzten"]; - $$d{"later"} =["spater","sp${a}ter"]; - - $$d{"exact"} =["genau"]; - $$d{"approx"} =["ungefahr","ungef${a}hr"]; - $$d{"business"}=["Arbeitstag"]; - - $$d{"offset"} =["gestern","-0:0:0:1:0:0:0","morgen","+0:0:0:1:0:0:0"]; - $$d{"times"} =["mittag","12:00:00","mitternacht","00:00:00"]; - - $$d{"years"} =["j","Jahr","Jahre"]; - $$d{"months"} =["Monat","Monate"]; - $$d{"weeks"} =["w","Woche","Wochen"]; - $$d{"days"} =["t","Tag","Tage"]; - $$d{"hours"} =["h","std","Stunde","Stunden"]; - $$d{"minutes"} =["min","Minute","Minuten"]; - $$d{"seconds"} =["s","sek","Sekunde","Sekunden"]; - $$d{"replace"} =["m","Monat"]; - - $$d{"sephm"} =':'; - $$d{"sepms"} ='[: ]'; - $$d{"sepss"} ='[.:]'; - - $$d{"am"} = ["FM"]; - $$d{"pm"} = ["EM"]; -} - -sub Date_Init_Dutch { - print "DEBUG: Date_Init_Dutch\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - my(%h)=(); - &Char_8Bit(\%h); - - $$d{"month_name"}= - [["januari","februari","maart","april","mei","juni","juli","augustus", - "september","october","november","december"], - ["","","","","","","","","","oktober"]]; - - $$d{"month_abb"}= - [["jan","feb","maa","apr","mei","jun","jul", - "aug","sep","oct","nov","dec"], - ["","","mrt","","","","","","","okt"]]; - $$d{"day_name"}= - [["maandag","dinsdag","woensdag","donderdag","vrijdag","zaterdag", - "zondag"]]; - $$d{"day_abb"}= - [["ma","di","wo","do","vr","zat","zon"], - ["","","","","","za","zo"]]; - $$d{"day_char"}= - [["M","D","W","D","V","Za","Zo"]]; - - $$d{"num_suff"}= - [["1ste","2de","3de","4de","5de","6de","7de","8ste","9de","10de", - "11de","12de","13de","14de","15de","16de","17de","18de","19de","20ste", - "21ste","22ste","23ste","24ste","25ste","26ste","27ste","28ste","29ste", - "30ste","31ste"]]; - $$d{"num_word"}= - [["eerste","tweede","derde","vierde","vijfde","zesde","zevende","achtste", - "negende","tiende","elfde","twaalfde", - map {"${_}tiende";} qw (der veer vijf zes zeven acht negen), - "twintigste", - map {"${_}entwintigste";} qw (een twee drie vier vijf zes zeven acht - negen), - "dertigste","eenendertigste"], - ["","","","","","","","","","","","","","","","","","","","", - map {"${_}-en-twintigste";} qw (een twee drie vier vijf zes zeven acht - negen), - "dertigste","een-en-dertigste"], - ["een","twee","drie","vier","vijf","zes","zeven","acht","negen","tien", - "elf","twaalf", - map {"${_}tien"} qw (der veer vijf zes zeven acht negen), - "twintig", - map {"${_}entwintig"} qw (een twee drie vier vijf zes zeven acht negen), - "dertig","eenendertig"], - ["","","","","","","","","","","","","","","","","","","","", - map {"${_}-en-twintig"} qw (een twee drie vier vijf zes zeven acht - negen), - "dertig","een-en-dertig"]]; - - $$d{"now"} =["nu","nou","vandaag"]; - $$d{"last"} =["laatste"]; - $$d{"each"} =["elke","elk"]; - $$d{"of"} =["in","van"]; - $$d{"at"} =["om"]; - $$d{"on"} =["op"]; - $$d{"future"} =["over"]; - $$d{"past"} =["geleden","vroeger","eerder"]; - $$d{"next"} =["volgende","volgend"]; - $$d{"prev"} =["voorgaande","voorgaand"]; - $$d{"later"} =["later"]; - - $$d{"exact"} =["exact","precies","nauwkeurig"]; - $$d{"approx"} =["ongeveer","ong",'ong\.',"circa","ca",'ca\.']; - $$d{"business"}=["werk","zakelijke","zakelijk"]; - - $$d{"offset"} =["morgen","+0:0:0:1:0:0:0","overmorgen","+0:0:0:2:0:0:0", - "gisteren","-0:0:0:1:0:0:0","eergisteren","-0::00:2:0:0:0"]; - $$d{"times"} =["noen","12:00:00","middernacht","00:00:00"]; - - $$d{"years"} =["jaar","jaren","ja","j"]; - $$d{"months"} =["maand","maanden","mnd"]; - $$d{"weeks"} =["week","weken","w"]; - $$d{"days"} =["dag","dagen","d"]; - $$d{"hours"} =["uur","uren","u","h"]; - $$d{"minutes"} =["minuut","minuten","min"]; - $$d{"seconds"} =["seconde","seconden","sec","s"]; - $$d{"replace"} =["m","minuten"]; - - $$d{"sephm"} ='[:.uh]'; - $$d{"sepms"} ='[:.m]'; - $$d{"sepss"} ='[.:]'; - - $$d{"am"} = ["am","a.m.","vm","v.m.","voormiddag","'s_ochtends", - "ochtend","'s_nachts","nacht"]; - $$d{"pm"} = ["pm","p.m.","nm","n.m.","namiddag","'s_middags","middag", - "'s_avonds","avond"]; -} - -sub Date_Init_Polish { - print "DEBUG: Date_Init_Polish\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - - $$d{"month_name"}= - [["stycznia","luty","marca","kwietnia","maja","czerwca", - "lipca","sierpnia","wrzesnia","pazdziernika","listopada","grudnia"], - ["stycznia","luty","marca","kwietnia","maja","czerwca","lipca", - "sierpnia","wrze\x9cnia","pa\x9fdziernika","listopada","grudnia"]]; - $$d{"month_abb"}= - [["sty.","lut.","mar.","kwi.","maj","cze.", - "lip.","sie.","wrz.","paz.","lis.","gru."], - ["sty.","lut.","mar.","kwi.","maj","cze.", - "lip.","sie.","wrz.","pa\x9f.","lis.","gru."]]; - - $$d{"day_name"}= - [["poniedzialek","wtorek","sroda","czwartek","piatek","sobota", - "niedziela"], - ["poniedzia\x81\xb3ek","wtorek","\x9croda","czwartek","pi\x81\xb9tek", - "sobota","niedziela"]]; - $$d{"day_abb"}= - [["po.","wt.","sr.","cz.","pi.","so.","ni."], - ["po.","wt.","\x9cr.","cz.","pi.","so.","ni."]]; - $$d{"day_char"}= - [["p","w","e","c","p","s","n"], - ["p","w","\x9c.","c","p","s","n"]]; - - $$d{"num_suff"}= - [["1.","2.","3.","4.","5.","6.","7.","8.","9.","10.", - "11.","12.","13.","14.","15.","16.","17.","18.","19.","20.", - "21.","22.","23.","24.","25.","26.","27.","28.","29.","30.", - "31."]]; - $$d{"num_word"}= - [["pierwszego","drugiego","trzeczego","czwartego","piatego","szostego", - "siodmego","osmego","dziewiatego","dziesiatego", - "jedenastego","dwunastego","trzynastego","czternastego","pietnastego", - "szestnastego","siedemnastego","osiemnastego","dziewietnastego", - "dwudziestego", - "dwudziestego pierwszego","dwudziestego drugiego", - "dwudziestego trzeczego","dwudziestego czwartego", - "dwudziestego piatego","dwudziestego szostego", - "dwudziestego siodmego","dwudziestego osmego", - "dwudziestego dziewiatego","trzydziestego","trzydziestego pierwszego"], - ["pierwszego","drugiego","trzeczego","czwartego","pi\x81\xb9tego", - "sz\x81\xf3stego","si\x81\xf3dmego","\x81\xf3smego","dziewi\x81\xb9tego", - "dziesi\x81\xb9tego","jedenastego","dwunastego","trzynastego", - "czternastego","pi\x81\xeatnastego","szestnastego","siedemnastego", - "osiemnastego","dziewietnastego","dwudziestego", - "dwudziestego pierwszego","dwudziestego drugiego", - "dwudziestego trzeczego","dwudziestego czwartego", - "dwudziestego pi\x81\xb9tego","dwudziestego sz\x81\xf3stego", - "dwudziestego si\x81\xf3dmego","dwudziestego \x81\xf3smego", - "dwudziestego dziewi\x81\xb9tego","trzydziestego", - "trzydziestego pierwszego"]]; - - $$d{"now"} =["dzisaj","teraz"]; - $$d{"last"} =["ostatni","ostatna"]; - $$d{"each"} =["kazdy","ka\x81\xbfdy", "kazdym","ka\x81\xbfdym"]; - $$d{"of"} =["w","z"]; - $$d{"at"} =["o","u"]; - $$d{"on"} =["na"]; - $$d{"future"} =["za"]; - $$d{"past"} =["temu"]; - $$d{"next"} =["nastepny","nast\x81\xeapny","nastepnym","nast\x81\xeapnym", - "przyszly","przysz\x81\xb3y","przyszlym", - "przysz\x81\xb3ym"]; - $$d{"prev"} =["zeszly","zesz\x81\xb3y","zeszlym","zesz\x81\xb3ym"]; - $$d{"later"} =["later"]; - - $$d{"exact"} =["doklandnie","dok\x81\xb3andnie"]; - $$d{"approx"} =["w przyblizeniu","w przybli\x81\xbfeniu","mniej wiecej", - "mniej wi\x81\xeacej","okolo","oko\x81\xb3o"]; - $$d{"business"}=["sluzbowy","s\x81\xb3u\x81\xbfbowy","sluzbowym", - "s\x81\xb3u\x81\xbfbowym"]; - - $$d{"times"} =["po\x81\xb3udnie","12:00:00", - "p\x81\xf3\x81\xb3noc","00:00:00", - "poludnie","12:00:00","polnoc","00:00:00"]; - $$d{"offset"} =["wczoraj","-0:0:1:0:0:0","jutro","+0:0:1:0:0:0"]; - - $$d{"years"} =["rok","lat","lata","latach"]; - $$d{"months"} =["m.","miesiac","miesi\x81\xb9c","miesiecy", - "miesi\x81\xeacy","miesiacu","miesi\x81\xb9cu"]; - $$d{"weeks"} =["ty.","tydzien","tydzie\x81\xf1","tygodniu"]; - $$d{"days"} =["d.","dzien","dzie\x81\xf1","dni"]; - $$d{"hours"} =["g.","godzina","godziny","godzinie"]; - $$d{"minutes"} =["mn.","min.","minut","minuty"]; - $$d{"seconds"} =["s.","sekund","sekundy"]; - $$d{"replace"} =["m.","miesiac"]; - - $$d{"sephm"} =':'; - $$d{"sepms"} =':'; - $$d{"sepss"} ='[.:]'; - - $$d{"am"} = ["AM","A.M."]; - $$d{"pm"} = ["PM","P.M."]; -} - -sub Date_Init_Spanish { - print "DEBUG: Date_Init_Spanish\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - my(%h)=(); - &Char_8Bit(\%h); - - $$d{"month_name"}= - [["Enero","Febrero","Marzo","Abril","Mayo","Junio","Julio","Agosto", - "Septiembre","Octubre","Noviembre","Diciembre"]]; - - $$d{"month_abb"}= - [["Ene","Feb","Mar","Abr","May","Jun","Jul","Ago","Sep","Oct", - "Nov","Dic"]]; - - $$d{"day_name"}= - [["Lunes","Martes","Miercoles","Jueves","Viernes","Sabado","Domingo"]]; - $$d{"day_abb"}= - [["Lun","Mar","Mie","Jue","Vie","Sab","Dom"]]; - $$d{"day_char"}= - [["L","Ma","Mi","J","V","S","D"]]; - - $$d{"num_suff"}= - [["1o","2o","3o","4o","5o","6o","7o","8o","9o","10o", - "11o","12o","13o","14o","15o","16o","17o","18o","19o","20o", - "21o","22o","23o","24o","25o","26o","27o","28o","29o","30o","31o"], - ["1a","2a","3a","4a","5a","6a","7a","8a","9a","10a", - "11a","12a","13a","14a","15a","16a","17a","18a","19a","20a", - "21a","22a","23a","24a","25a","26a","27a","28a","29a","30a","31a"]]; - $$d{"num_word"}= - [["Primero","Segundo","Tercero","Cuarto","Quinto","Sexto","Septimo", - "Octavo","Noveno","Decimo","Decimo Primero","Decimo Segundo", - "Decimo Tercero","Decimo Cuarto","Decimo Quinto","Decimo Sexto", - "Decimo Septimo","Decimo Octavo","Decimo Noveno","Vigesimo", - "Vigesimo Primero","Vigesimo Segundo","Vigesimo Tercero", - "Vigesimo Cuarto","Vigesimo Quinto","Vigesimo Sexto", - "Vigesimo Septimo","Vigesimo Octavo","Vigesimo Noveno","Trigesimo", - "Trigesimo Primero"], - ["Primera","Segunda","Tercera","Cuarta","Quinta","Sexta","Septima", - "Octava","Novena","Decima","Decimo Primera","Decimo Segunda", - "Decimo Tercera","Decimo Cuarta","Decimo Quinta","Decimo Sexta", - "Decimo Septima","Decimo Octava","Decimo Novena","Vigesima", - "Vigesimo Primera","Vigesimo Segunda","Vigesimo Tercera", - "Vigesimo Cuarta","Vigesimo Quinta","Vigesimo Sexta", - "Vigesimo Septima","Vigesimo Octava","Vigesimo Novena","Trigesima", - "Trigesimo Primera"]]; - - $$d{"now"} =["Hoy","Ahora"]; - $$d{"last"} =["ultimo"]; - $$d{"each"} =["cada"]; - $$d{"of"} =["en","de"]; - $$d{"at"} =["a"]; - $$d{"on"} =["el"]; - $$d{"future"} =["en"]; - $$d{"past"} =["hace"]; - $$d{"next"} =["siguiente"]; - $$d{"prev"} =["anterior"]; - $$d{"later"} =["later"]; - - $$d{"exact"} =["exactamente"]; - $$d{"approx"} =["aproximadamente"]; - $$d{"business"}=["laborales"]; - - $$d{"offset"} =["ayer","-0:0:0:1:0:0:0","manana","+0:0:0:1:0:0:0"]; - $$d{"times"} =["mediodia","12:00:00","medianoche","00:00:00"]; - - $$d{"years"} =["a","ano","ano","anos","anos"]; - $$d{"months"} =["m","mes","mes","meses"]; - $$d{"weeks"} =["sem","semana","semana","semanas"]; - $$d{"days"} =["d","dia","dias"]; - $$d{"hours"} =["hr","hrs","hora","horas"]; - $$d{"minutes"} =["min","min","minuto","minutos"]; - $$d{"seconds"} =["s","seg","segundo","segundos"]; - $$d{"replace"} =["m","mes"]; - - $$d{"sephm"} =':'; - $$d{"sepms"} =':'; - $$d{"sepss"} ='[.:]'; - - $$d{"am"} = ["AM","A.M."]; - $$d{"pm"} = ["PM","P.M."]; -} - -sub Date_Init_Portuguese { - print "DEBUG: Date_Init_Portuguese\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - my(%h)=(); - &Char_8Bit(\%h); - my($o) = $h{"-o"}; - my($c) = $h{",c"}; - my($a) = $h{"a'"}; - my($e) = $h{"e'"}; - my($u) = $h{"u'"}; - my($o2)= $h{"o'"}; - my($a2)= $h{"a`"}; - my($a3)= $h{"a~"}; - my($e2)= $h{"e^"}; - - $$d{"month_name"}= - [["Janeiro","Fevereiro","Marco","Abril","Maio","Junho", - "Julho","Agosto","Setembro","Outubro","Novembro","Dezembro"], - ["Janeiro","Fevereiro","Mar${c}o","Abril","Maio","Junho", - "Julho","Agosto","Setembro","Outubro","Novembro","Dezembro"]]; - - $$d{"month_abb"}= - [["Jan","Fev","Mar","Abr","Mai","Jun", - "Jul","Ago","Set","Out","Nov","Dez"]]; - - $$d{"day_name"}= - [["Segunda","Terca","Quarta","Quinta","Sexta","Sabado","Domingo"], - ["Segunda","Ter${c}a","Quarta","Quinta","Sexta","S${a}bado","Domingo"]]; - $$d{"day_abb"}= - [["Seg","Ter","Qua","Qui","Sex","Sab","Dom"], - ["Seg","Ter","Qua","Qui","Sex","S${a}b","Dom"]]; - $$d{"day_char"}= - [["Sg","T","Qa","Qi","Sx","Sb","D"]]; - - $$d{"num_suff"}= - [["1${o}","2${o}","3${o}","4${o}","5${o}","6${o}","7${o}","8${o}", - "9${o}","10${o}","11${o}","12${o}","13${o}","14${o}","15${o}", - "16${o}","17${o}","18${o}","19${o}","20${o}","21${o}","22${o}", - "23${o}","24${o}","25${o}","26${o}","27${o}","28${o}","29${o}", - "30${o}","31${o}"]]; - $$d{"num_word"}= - [["primeiro","segundo","terceiro","quarto","quinto","sexto","setimo", - "oitavo","nono","decimo","decimo primeiro","decimo segundo", - "decimo terceiro","decimo quarto","decimo quinto","decimo sexto", - "decimo setimo","decimo oitavo","decimo nono","vigesimo", - "vigesimo primeiro","vigesimo segundo","vigesimo terceiro", - "vigesimo quarto","vigesimo quinto","vigesimo sexto","vigesimo setimo", - "vigesimo oitavo","vigesimo nono","trigesimo","trigesimo primeiro"], - ["primeiro","segundo","terceiro","quarto","quinto","sexto","s${e}timo", - "oitavo","nono","d${e}cimo","d${e}cimo primeiro","d${e}cimo segundo", - "d${e}cimo terceiro","d${e}cimo quarto","d${e}cimo quinto", - "d${e}cimo sexto","d${e}cimo s${e}timo","d${e}cimo oitavo", - "d${e}cimo nono","vig${e}simo","vig${e}simo primeiro", - "vig${e}simo segundo","vig${e}simo terceiro","vig${e}simo quarto", - "vig${e}simo quinto","vig${e}simo sexto","vig${e}simo s${e}timo", - "vig${e}simo oitavo","vig${e}simo nono","trig${e}simo", - "trig${e}simo primeiro"]]; - - $$d{"now"} =["agora","hoje"]; - $$d{"last"} =["${u}ltimo","ultimo"]; - $$d{"each"} =["cada"]; - $$d{"of"} =["da","do"]; - $$d{"at"} =["as","${a2}s"]; - $$d{"on"} =["na","no"]; - $$d{"future"} =["em"]; - $$d{"past"} =["a","${a2}"]; - $$d{"next"} =["proxima","proximo","pr${o2}xima","pr${o2}ximo"]; - $$d{"prev"} =["ultima","ultimo","${u}ltima","${u}ltimo"]; - $$d{"later"} =["passadas","passados"]; - - $$d{"exact"} =["exactamente"]; - $$d{"approx"} =["aproximadamente"]; - $$d{"business"}=["util","uteis"]; - - $$d{"offset"} =["ontem","-0:0:0:1:0:0:0", - "amanha","+0:0:0:1:0:0:0","amanh${a3}","+0:0:0:1:0:0:0"]; - $$d{"times"} =["meio-dia","12:00:00","meia-noite","00:00:00"]; - - $$d{"years"} =["anos","ano","ans","an","a"]; - $$d{"months"} =["meses","m${e2}s","mes","m"]; - $$d{"weeks"} =["semanas","semana","sem","sems","s"]; - $$d{"days"} =["dias","dia","d"]; - $$d{"hours"} =["horas","hora","hr","hrs"]; - $$d{"minutes"} =["minutos","minuto","min","mn"]; - $$d{"seconds"} =["segundos","segundo","seg","sg"]; - $$d{"replace"} =["m","mes","s","sems"]; - - $$d{"sephm"} =':'; - $$d{"sepms"} =':'; - $$d{"sepss"} ='[,]'; - - $$d{"am"} = ["AM","A.M."]; - $$d{"pm"} = ["PM","P.M."]; -} - -sub Date_Init_Russian { - print "DEBUG: Date_Init_Russian\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - my(%h)=(); - &Char_8Bit(\%h); - my($a) =$h{"a:"}; - - $$d{"month_name"}= - [ - ["\xd1\xce\xd7\xc1\xd2\xd1","\xc6\xc5\xd7\xd2\xc1\xcc\xd1", - "\xcd\xc1\xd2\xd4\xc1","\xc1\xd0\xd2\xc5\xcc\xd1","\xcd\xc1\xd1", - "\xc9\xc0\xce\xd1", - "\xc9\xc0\xcc\xd1","\xc1\xd7\xc7\xd5\xd3\xd4\xc1", - "\xd3\xc5\xce\xd4\xd1\xc2\xd2\xd1","\xcf\xcb\xd4\xd1\xc2\xd2\xd1", - "\xce\xcf\xd1\xc2\xd2\xd1","\xc4\xc5\xcb\xc1\xc2\xd2\xd1"], - ["\xd1\xce\xd7\xc1\xd2\xd8","\xc6\xc5\xd7\xd2\xc1\xcc\xd8", - "\xcd\xc1\xd2\xd4","\xc1\xd0\xd2\xc5\xcc\xd8","\xcd\xc1\xca", - "\xc9\xc0\xce\xd8", - "\xc9\xc0\xcc\xd8","\xc1\xd7\xc7\xd5\xd3\xd4", - "\xd3\xc5\xce\xd4\xd1\xc2\xd2\xd8","\xcf\xcb\xd4\xd1\xc2\xd2\xd8", - "\xce\xcf\xd1\xc2\xd2\xd8","\xc4\xc5\xcb\xc1\xc2\xd2\xd8"] - ]; - - $$d{"month_abb"}= - [["\xd1\xce\xd7","\xc6\xc5\xd7","\xcd\xd2\xd4","\xc1\xd0\xd2", - "\xcd\xc1\xca","\xc9\xc0\xce", - "\xc9\xc0\xcc","\xc1\xd7\xc7","\xd3\xce\xd4","\xcf\xcb\xd4", - "\xce\xcf\xd1\xc2","\xc4\xc5\xcb"], - ["","\xc6\xd7\xd2","","","\xcd\xc1\xd1","", - "","","\xd3\xc5\xce","\xcf\xcb\xd4","\xce\xcf\xd1",""]]; - - $$d{"day_name"}= - [["\xd0\xcf\xce\xc5\xc4\xc5\xcc\xd8\xce\xc9\xcb", - "\xd7\xd4\xcf\xd2\xce\xc9\xcb","\xd3\xd2\xc5\xc4\xc1", - "\xde\xc5\xd4\xd7\xc5\xd2\xc7","\xd0\xd1\xd4\xce\xc9\xc3\xc1", - "\xd3\xd5\xc2\xc2\xcf\xd4\xc1", - "\xd7\xcf\xd3\xcb\xd2\xc5\xd3\xc5\xce\xd8\xc5"]]; - $$d{"day_abb"}= - [["\xd0\xce\xc4","\xd7\xd4\xd2","\xd3\xd2\xc4","\xde\xd4\xd7", - "\xd0\xd4\xce","\xd3\xd5\xc2","\xd7\xd3\xcb"], - ["\xd0\xcf\xce","\xd7\xd4\xcf","\xd3\xd2e","\xde\xc5\xd4", - "\xd0\xd1\xd4","\xd3\xd5\xc2","\xd7\xcf\xd3\xcb"]]; - $$d{"day_char"}= - [["\xd0\xce","\xd7\xd4","\xd3\xd2","\xde\xd4","\xd0\xd4","\xd3\xc2", - "\xd7\xd3"]]; - - $$d{"num_suff"}= - [["1 ","2 ","3 ","4 ","5 ","6 ","7 ","8 ","9 ","10 ", - "11 ","12 ","13 ","14 ","15 ","16 ","17 ","18 ","19 ","20 ", - "21 ","22 ","23 ","24 ","25 ","26 ","27 ","28 ","29 ","30 ", - "31 "]]; - $$d{"num_word"}= - [["\xd0\xc5\xd2\xd7\xd9\xca","\xd7\xd4\xcf\xd2\xcf\xca", - "\xd4\xd2\xc5\xd4\xc9\xca","\xde\xc5\xd4\xd7\xc5\xd2\xd4\xd9\xca", - "\xd0\xd1\xd4\xd9\xca","\xdb\xc5\xd3\xd4\xcf\xca", - "\xd3\xc5\xc4\xd8\xcd\xcf\xca","\xd7\xcf\xd3\xd8\xcd\xcf\xca", - "\xc4\xc5\xd7\xd1\xd4\xd9\xca","\xc4\xc5\xd3\xd1\xd4\xd9\xca", - "\xcf\xc4\xc9\xce\xce\xc1\xc4\xc3\xc1\xd4\xd9\xca", - "\xc4\xd7\xc5\xce\xc1\xc4\xde\xc1\xd4\xd9\xca", - "\xd4\xd2\xc5\xce\xc1\xc4\xc3\xc1\xd4\xd9\xca", - "\xde\xc5\xd4\xd9\xd2\xce\xc1\xc4\xc3\xc1\xd4\xd9\xca", - "\xd0\xd1\xd4\xce\xc1\xc4\xc3\xc1\xd4\xd9\xca", - "\xdb\xc5\xd3\xd4\xce\xc1\xc4\xc3\xc1\xd4\xd9\xca", - "\xd3\xc5\xcd\xd8\xce\xc1\xc4\xc3\xc1\xd4\xd9\xca", - "\xd7\xcf\xd3\xc5\xcd\xd8\xce\xc1\xc4\xc3\xc1\xd4\xd9\xca", - "\xc4\xc5\xd7\xd1\xd4\xce\xc1\xc4\xc3\xc1\xd4\xd9\xca", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd9\xca", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd0\xc5\xd2\xd7\xd9\xca", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd7\xd4\xcf\xd2\xcf\xca", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd4\xd2\xc5\xd4\xc9\xca", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xde\xc5\xd4\xd7\xc5\xd2\xd4\xd9\xca", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd0\xd1\xd4\xd9\xca", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xdb\xc5\xd3\xd4\xcf\xca", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd3\xc5\xc4\xd8\xcd\xcf\xca", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd7\xcf\xd3\xd8\xcd\xcf\xca", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xc4\xc5\xd7\xd1\xd4\xd9\xca", - "\xd4\xd2\xc9\xc4\xc3\xc1\xd4\xd9\xca", - "\xd4\xd2\xc9\xc4\xc3\xc1\xd4\xd8 \xd0\xc5\xd2\xd7\xd9\xca"], - - ["\xd0\xc5\xd2\xd7\xcf\xc5","\xd7\xd4\xcf\xd2\xcf\xc5", - "\xd4\xd2\xc5\xd4\xd8\xc5","\xde\xc5\xd4\xd7\xc5\xd2\xd4\xcf\xc5", - "\xd0\xd1\xd4\xcf\xc5","\xdb\xc5\xd3\xd4\xcf\xc5", - "\xd3\xc5\xc4\xd8\xcd\xcf\xc5","\xd7\xcf\xd3\xd8\xcd\xcf\xc5", - "\xc4\xc5\xd7\xd1\xd4\xcf\xc5","\xc4\xc5\xd3\xd1\xd4\xcf\xc5", - "\xcf\xc4\xc9\xce\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc5", - "\xc4\xd7\xc5\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc5", - "\xd4\xd2\xc5\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc5", - "\xde\xc5\xd4\xd9\xd2\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc5", - "\xd0\xd1\xd4\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc5", - "\xdb\xc5\xd3\xd4\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc5", - "\xd3\xc5\xcd\xd8\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc5", - "\xd7\xcf\xd3\xc5\xcd\xd8\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc5", - "\xc4\xc5\xd7\xd1\xd4\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc5", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xcf\xc5", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd0\xc5\xd2\xd7\xcf\xc5", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd7\xd4\xcf\xd2\xcf\xc5", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd4\xd2\xc5\xd4\xd8\xc5", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xde\xc5\xd4\xd7\xc5\xd2\xd4\xcf\xc5", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd0\xd1\xd4\xcf\xc5", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xdb\xc5\xd3\xd4\xcf\xc5", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd3\xc5\xc4\xd8\xcd\xcf\xc5", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd7\xcf\xd3\xd8\xcd\xcf\xc5", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xc4\xc5\xd7\xd1\xd4\xcf\xc5", - "\xd4\xd2\xc9\xc4\xc3\xc1\xd4\xcf\xc5", - "\xd4\xd2\xc9\xc4\xc3\xc1\xd4\xd8 \xd0\xc5\xd2\xd7\xcf\xc5"], - - ["\xd0\xc5\xd2\xd7\xcf\xc7\xcf","\xd7\xd4\xcf\xd2\xcf\xc7\xcf", - "\xd4\xd2\xc5\xd4\xd8\xc5\xc7\xcf", - "\xde\xc5\xd4\xd7\xc5\xd2\xd4\xcf\xc7\xcf","\xd0\xd1\xd4\xcf\xc7\xcf", - "\xdb\xc5\xd3\xd4\xcf\xc7\xcf","\xd3\xc5\xc4\xd8\xcd\xcf\xc7\xcf", - "\xd7\xcf\xd3\xd8\xcd\xcf\xc7\xcf", - "\xc4\xc5\xd7\xd1\xd4\xcf\xc7\xcf","\xc4\xc5\xd3\xd1\xd4\xcf\xc7\xcf", - "\xcf\xc4\xc9\xce\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc7\xcf", - "\xc4\xd7\xc5\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc7\xcf", - "\xd4\xd2\xc5\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc7\xcf", - "\xde\xc5\xd4\xd9\xd2\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc7\xcf", - "\xd0\xd1\xd4\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc7\xcf", - "\xdb\xc5\xd3\xd4\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc7\xcf", - "\xd3\xc5\xcd\xd8\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc7\xcf", - "\xd7\xcf\xd3\xc5\xcd\xd8\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc7\xcf", - "\xc4\xc5\xd7\xd1\xd4\xce\xc1\xc4\xc3\xc1\xd4\xcf\xc7\xcf", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xcf\xc7\xcf", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd0\xc5\xd2\xd7\xcf\xc7\xcf", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd7\xd4\xcf\xd2\xcf\xc5", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd4\xd2\xc5\xd4\xd8\xc5\xc7\xcf", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xde\xc5\xd4\xd7\xc5\xd2\xd4\xcf\xc7\xcf", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd0\xd1\xd4\xcf\xc7\xcf", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xdb\xc5\xd3\xd4\xcf\xc7\xcf", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd3\xc5\xc4\xd8\xcd\xcf\xc7\xcf", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xd7\xcf\xd3\xd8\xcd\xcf\xc7\xcf", - "\xc4\xd7\xc1\xc4\xc3\xc1\xd4\xd8 \xc4\xc5\xd7\xd1\xd4\xcf\xc7\xcf", - "\xd4\xd2\xc9\xc4\xc3\xc1\xd4\xcf\xc7\xcf", - "\xd4\xd2\xc9\xc4\xc3\xc1\xd4\xd8 \xd0\xc5\xd2\xd7\xcf\xc7\xcf"]]; - - $$d{"now"} =["\xd3\xc5\xc7\xcf\xc4\xce\xd1","\xd3\xc5\xca\xde\xc1\xd3"]; - $$d{"last"} =["\xd0\xcf\xd3\xcc\xc5\xc4\xce\xc9\xca"]; - $$d{"each"} =["\xcb\xc1\xd6\xc4\xd9\xca"]; - $$d{"of"} =[" "]; - $$d{"at"} =["\xd7"]; - $$d{"on"} =["\xd7"]; - $$d{"future"} =["\xd7\xd0\xc5\xd2\xc5\xc4 \xce\xc1"]; - $$d{"past"} =["\xce\xc1\xda\xc1\xc4 \xce\xc1 "]; - $$d{"next"} =["\xd3\xcc\xc5\xc4\xd5\xc0\xdd\xc9\xca"]; - $$d{"prev"} =["\xd0\xd2\xc5\xc4\xd9\xc4\xd5\xdd\xc9\xca"]; - $$d{"later"} =["\xd0\xcf\xda\xd6\xc5"]; - - $$d{"exact"} =["\xd4\xcf\xde\xce\xcf"]; - $$d{"approx"} =["\xd0\xd2\xc9\xcd\xc5\xd2\xce\xcf"]; - $$d{"business"}=["\xd2\xc1\xc2\xcf\xde\xc9\xc8"]; - - $$d{"offset"} =["\xd0\xcf\xda\xc1\xd7\xde\xc5\xd2\xc1","-0:0:0:2:0:0:0", - "\xd7\xde\xc5\xd2\xc1","-0:0:0:1:0:0:0", - "\xda\xc1\xd7\xd4\xd2\xc1","+0:0:0:1:0:0:0", - "\xd0\xcf\xd3\xcc\xc5\xda\xc1\xd7\xd4\xd2\xc1", - "+0:0:0:2:0:0:0"]; - $$d{"times"} =["\xd0\xcf\xcc\xc4\xc5\xce\xd8","12:00:00", - "\xd0\xcf\xcc\xce\xcf\xde\xd8","00:00:00"]; - - $$d{"years"} =["\xc7","\xc7\xc4","\xc7\xcf\xc4","\xcc\xc5\xd4", - "\xcc\xc5\xd4","\xc7\xcf\xc4\xc1"]; - $$d{"months"} =["\xcd\xc5\xd3","\xcd\xc5\xd3\xd1\xc3", - "\xcd\xc5\xd3\xd1\xc3\xc5\xd7"]; - $$d{"weeks"} =["\xce\xc5\xc4\xc5\xcc\xd1","\xce\xc5\xc4\xc5\xcc\xd8", - "\xce\xc5\xc4\xc5\xcc\xc9","\xce\xc5\xc4\xc5\xcc\xc0"]; - $$d{"days"} =["\xc4","\xc4\xc5\xce\xd8","\xc4\xce\xc5\xca", - "\xc4\xce\xd1"]; - $$d{"hours"} =["\xde","\xde.","\xde\xd3","\xde\xd3\xd7","\xde\xc1\xd3", - "\xde\xc1\xd3\xcf\xd7","\xde\xc1\xd3\xc1"]; - $$d{"minutes"} =["\xcd\xce","\xcd\xc9\xce","\xcd\xc9\xce\xd5\xd4\xc1", - "\xcd\xc9\xce\xd5\xd4"]; - $$d{"seconds"} =["\xd3","\xd3\xc5\xcb","\xd3\xc5\xcb\xd5\xce\xc4\xc1", - "\xd3\xc5\xcb\xd5\xce\xc4"]; - $$d{"replace"} =[]; - - $$d{"sephm"} ="[:\xde]"; - $$d{"sepms"} ="[:\xcd]"; - $$d{"sepss"} ="[:.\xd3]"; - - $$d{"am"} = ["\xc4\xd0","${a}\xf0","${a}.\xf0.","\xce\xcf\xde\xc9", - "\xd5\xd4\xd2\xc1", - "\xc4\xcf \xd0\xcf\xcc\xd5\xc4\xce\xd1"]; - $$d{"pm"} = ["\xd0\xd0","\xf0\xf0","\xf0.\xf0.","\xc4\xce\xd1", - "\xd7\xc5\xde\xc5\xd2\xc1", - "\xd0\xcf\xd3\xcc\xc5 \xd0\xcf\xcc\xd5\xc4\xce\xd1", - "\xd0\xcf \xd0\xcf\xcc\xd5\xc4\xce\xc0"]; -} - -sub Date_Init_Turkish { - print "DEBUG: Date_Init_Turkish\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - - $$d{"month_name"}= - [ - ["ocak","subat","mart","nisan","mayis","haziran", - "temmuz","agustos","eylul","ekim","kasim","aralik"], - ["ocak","\xfeubat","mart","nisan","may\xfds","haziran", - "temmuz","a\xf0ustos","eyl\xfcl","ekim","kas\xfdm","aral\xfdk"] - ]; - - $$d{"month_abb"}= - [ - ["oca","sub","mar","nis","may","haz", - "tem","agu","eyl","eki","kas","ara"], - ["oca","\xfeub","mar","nis","may","haz", - "tem","a\xf0u","eyl","eki","kas","ara"] - ]; - - $$d{"day_name"}= - [ - ["pazartesi","sali","carsamba","persembe","cuma","cumartesi","pazar"], - ["pazartesi","sal\xfd","\xe7ar\xfeamba","per\xfeembe","cuma", - "cumartesi","pazar"], - ]; - - $$d{"day_abb"}= - [ - ["pzt","sal","car","per","cum","cts","paz"], - ["pzt","sal","\xe7ar","per","cum","cts","paz"], - ]; - - $$d{"day_char"}= - [["Pt","S","Cr","Pr","C","Ct","P"], - ["Pt","S","\xc7","Pr","C","Ct","P"]]; - - $$d{"num_suff"}= - [[ "1.", "2.", "3.", "4.", "5.", "6.", "7.", "8.", "9.", "10.", - "11.", "12.", "13.", "14.", "15.", "16.", "17.", "18.", "19.", "20.", - "21.", "22.", "23.", "24.", "25.", "26.", "27.", "28.", "29.", "30.", - "31."]]; - - $$d{"num_word"}= - [ - ["birinci","ikinci","ucuncu","dorduncu", - "besinci","altinci","yedinci","sekizinci", - "dokuzuncu","onuncu","onbirinci","onikinci", - "onucuncu","ondordoncu", - "onbesinci","onaltinci","onyedinci","onsekizinci", - "ondokuzuncu","yirminci","yirmibirinci","yirmikinci", - "yirmiucuncu","yirmidorduncu", - "yirmibesinci","yirmialtinci","yirmiyedinci","yirmisekizinci", - "yirmidokuzuncu","otuzuncu","otuzbirinci"], - ["birinci","ikinci","\xfc\xe7\xfcnc\xfc","d\xf6rd\xfcnc\xfc", - "be\xfeinci","alt\xfdnc\xfd","yedinci","sekizinci", - "dokuzuncu","onuncu","onbirinci","onikinci", - "on\xfc\xe7\xfcnc\xfc","ond\xf6rd\xfcnc\xfc", - "onbe\xfeinci","onalt\xfdnc\xfd","onyedinci","onsekizinci", - "ondokuzuncu","yirminci","yirmibirinci","yirmikinci", - "yirmi\xfc\xe7\xfcnc\xfc","yirmid\xf6rd\xfcnc\xfc", - "yirmibe\xfeinci","yirmialt\xfdnc\xfd","yirmiyedinci","yirmisekizinci", - "yirmidokuzuncu","otuzuncu","otuzbirinci"] - ]; - - $$d{"now"} =["\xfeimdi", "simdi", "bugun","bug\xfcn"]; - $$d{"last"} =["son", "sonuncu"]; - $$d{"each"} =["her"]; - $$d{"of"} =["of"]; - $$d{"at"} =["saat"]; - $$d{"on"} =["on"]; - $$d{"future"} =["gelecek"]; - $$d{"past"} =["ge\xe7mi\xfe", "gecmis","gecen", "ge\xe7en"]; - $$d{"next"} =["gelecek","sonraki"]; - $$d{"prev"} =["onceki","\xf6nceki"]; - $$d{"later"} =["sonra"]; - - $$d{"exact"} =["tam"]; - $$d{"approx"} =["yakla\xfe\xfdk", "yaklasik"]; - $$d{"business"}=["i\xfe","\xe7al\xfd\xfema","is", "calisma"]; - - $$d{"offset"} =["d\xfcn","-0:0:0:1:0:0:0", - "dun", "-0:0:0:1:0:0:0", - "yar\xfdn","+0:0:0:1:0:0:0", - "yarin","+0:0:0:1:0:0:0"]; - - $$d{"times"} =["\xf6\xf0len","12:00:00", - "oglen","12:00:00", - "yarim","12:300:00", - "yar\xfdm","12:30:00", - "gece yar\xfds\xfd","00:00:00", - "gece yarisi","00:00:00"]; - - $$d{"years"} =["yil","y"]; - $$d{"months"} =["ay","a"]; - $$d{"weeks"} =["hafta", "h"]; - $$d{"days"} =["gun","g"]; - $$d{"hours"} =["saat"]; - $$d{"minutes"} =["dakika","dak","d"]; - $$d{"seconds"} =["saniye","sn",]; - $$d{"replace"} =["s","saat"]; - - $$d{"sephm"} =':'; - $$d{"sepms"} =':'; - $$d{"sepss"} ='[.:,]'; - - $$d{"am"} = ["\xf6gleden \xf6nce","ogleden once"]; - $$d{"pm"} = ["\xf6\xf0leden sonra","ogleden sonra"]; -} - -sub Date_Init_Danish { - print "DEBUG: Date_Init_Danish\n" if ($Curr{"Debug"} =~ /trace/); - my($d)=@_; - - $$d{"month_name"}= - [["Januar","Februar","Marts","April","Maj","Juni", - "Juli","August","September","Oktober","November","December"]]; - $$d{"month_abb"}= - [["Jan","Feb","Mar","Apr","Maj","Jun", - "Jul","Aug","Sep","Okt","Nov","Dec"]]; - - $$d{"day_name"}= - [["Mandag","Tirsdag","Onsdag","Torsdag","Fredag","Lordag","Sondag"], - ["Mandag","Tirsdag","Onsdag","Torsdag","Fredag","L\xf8rdag","S\xf8ndag"]]; - - $$d{"day_abb"}= - [["Man","Tis","Ons","Tor","Fre","Lor","Son"], - ["Man","Tis","Ons","Tor","Fre","L\xf8r","S\xf8n"]]; - $$d{"day_char"}= - [["M","Ti","O","To","F","L","S"]]; - - $$d{"num_suff"}= - [["1:e","2:e","3:e","4:e","5:e","6:e","7:e","8:e","9:e","10:e", - "11:e","12:e","13:e","14:e","15:e","16:e","17:e","18:e","19:e","20:e", - "21:e","22:e","23:e","24:e","25:e","26:e","27:e","28:e","29:e","30:e", - "31:e"]]; - $$d{"num_word"}= - [["forste","anden","tredie","fjerde","femte","sjette","syvende", - "ottende","niende","tiende","elfte","tolvte","trettende","fjortende", - "femtende","sekstende","syttende","attende","nittende","tyvende", - "enogtyvende","toogtyvende","treogtyvende","fireogtyvende","femogtyvende", - "seksogtyvende","syvogtyvende","otteogtyvende","niogtyvende", - "tredivte","enogtredivte"], - ["f\xf8rste","anden","tredie","fjerde","femte","sjette","syvende", - "ottende","niende","tiende","elfte","tolvte","trettende","fjortende", - "femtende","sekstende","syttende","attende","nittende","tyvende", - "enogtyvende","toogtyvende","treogtyvende","fireogtyvende","femogtyvende", - "seksogtyvende","syvogtyvende","otteogtyvende","niogtyvende", - "tredivte","enogtredivte"]]; - - $$d{"now"} =["idag","nu"]; - $$d{"last"} =["forrige","sidste","nyeste"]; - $$d{"each"} =["hver"]; - $$d{"of"} =["om"]; - $$d{"at"} =["kl","kl.","klokken"]; - $$d{"on"} =["pa","p\xe5"]; - $$d{"future"} =["om"]; - $$d{"past"} =["siden"]; - $$d{"next"} =["nasta","n\xe6ste"]; - $$d{"prev"} =["forrige"]; - $$d{"later"} =["senere"]; - - $$d{"exact"} =["pracist","pr\xe6cist"]; - $$d{"approx"} =["circa"]; - $$d{"business"}=["arbejdsdag","arbejdsdage"]; - - $$d{"offset"} =["ig\xe5r","-0:0:0:1:0:0:0","igar","-0:0:0:1:0:0:0", - "imorgen","+0:0:0:1:0:0:0"]; - $$d{"times"} =["midt pa dagen","12:00:00","midt p\xe5 dagen","12:00:00", - "midnat","00:00:00"]; - - $$d{"years"} =["ar","\xe5r"]; - $$d{"months"} =["man","maned","maneder","m\xe5n","m\xe5ned","m\xe5neder"]; - $$d{"weeks"} =["u","uge","uger"]; - $$d{"days"} =["d","dag","dage"]; - $$d{"hours"} =["t","tim","time","timer"]; - $$d{"minutes"} =["min","minut","minutter"]; - $$d{"seconds"} =["s","sek","sekund","sekunder"]; - $$d{"replace"} =["m","minut"]; - - $$d{"sephm"} ='[.:]'; - $$d{"sepms"} =':'; - $$d{"sepss"} ='[.:]'; - - $$d{"am"} = ["FM"]; - $$d{"pm"} = ["EM"]; -} - -######################################################################## -# FROM MY PERSONAL LIBRARIES -######################################################################## - -no integer; - -# &ModuloAddition($N,$add,\$val,\$rem); -# This calculates $val=$val+$add and forces $val to be in a certain range. -# This is useful for adding numbers for which only a certain range is -# allowed (for example, minutes can be between 0 and 59 or months can be -# between 1 and 12). The absolute value of $N determines the range and -# the sign of $N determines whether the range is 0 to N-1 (if N>0) or -# 1 to N (N<0). The remainder (as modulo N) is added to $rem. -# Example: -# To add 2 hours together (with the excess returned in days) use: -# &ModuloAddition(60,$s1,\$s,\$day); -sub ModuloAddition { - my($N,$add,$val,$rem)=@_; - return if ($N==0); - $$val+=$add; - if ($N<0) { - # 1 to N - $N = -$N; - if ($$val>$N) { - $$rem+= int(($$val-1)/$N); - $$val = ($$val-1)%$N +1; - } elsif ($$val<1) { - $$rem-= int(-$$val/$N)+1; - $$val = $N-(-$$val % $N); - } - - } else { - # 0 to N-1 - if ($$val>($N-1)) { - $$rem+= int($$val/$N); - $$val = $$val%$N; - } elsif ($$val<0) { - $$rem-= int(-($$val+1)/$N)+1; - $$val = ($N-1)-(-($$val+1)%$N); - } - } -} - -# $Flag=&IsInt($String [,$low, $high]); -# Returns 1 if $String is a valid integer, 0 otherwise. If $low is -# entered, $String must be >= $low. If $high is entered, $String must -# be <= $high. It is valid to check only one of the bounds. -sub IsInt { - my($N,$low,$high)=@_; - return 0 if (! defined $N or - $N !~ /^\s*[-+]?\d+\s*$/ or - defined $low && $N<$low or - defined $high && $N>$high); - return 1; -} - -# $Pos=&SinLindex(\@List,$Str [,$offset [,$CaseInsensitive]]); -# Searches for an exact string in a list. -# -# This is similar to RinLindex except that it searches for elements -# which are exactly equal to $Str (possibly case insensitive). -sub SinLindex { - my($listref,$Str,$offset,$Insensitive)=@_; - my($i,$len,$tmp)=(); - $len=$#$listref; - return -2 if ($len<0 or ! $Str); - return -1 if (&Index_First(\$offset,$len)); - $Str=uc($Str) if ($Insensitive); - for ($i=$offset; $i<=$len; $i++) { - $tmp=$$listref[$i]; - $tmp=uc($tmp) if ($Insensitive); - return $i if ($tmp eq $Str); - } - return -1; -} - -sub Index_First { - my($offsetref,$max)=@_; - $$offsetref=0 if (! $$offsetref); - if ($$offsetref < 0) { - $$offsetref += $max + 1; - $$offsetref=0 if ($$offsetref < 0); - } - return -1 if ($$offsetref > $max); - return 0; -} - -# $File=&CleanFile($file); -# This cleans up a path to remove the following things: -# double slash /a//b -> /a/b -# trailing dot /a/. -> /a -# leading dot ./a -> a -# trailing slash a/ -> a -sub CleanFile { - my($file)=@_; - $file =~ s/\s*$//; - $file =~ s/^\s*//; - $file =~ s|//+|/|g; # multiple slash - $file =~ s|/\.$|/|; # trailing /. (leaves trailing slash) - $file =~ s|^\./|| # leading ./ - if ($file ne "./"); - $file =~ s|/$|| # trailing slash - if ($file ne "/"); - return $file; -} - -# $File=&ExpandTilde($file); -# This checks to see if a "~" appears as the first character in a path. -# If it does, the "~" expansion is interpreted (if possible) and the full -# path is returned. If a "~" expansion is used but cannot be -# interpreted, an empty string is returned. -# -# This is Windows/Mac friendly. -# This is efficient. -sub ExpandTilde { - my($file)=shift; - my($user,$home)=(); - # ~aaa/bbb= ~ aaa /bbb - if ($file =~ s|^~([^/]*)||) { - $user=$1; - # Single user operating systems (Mac, MSWindows) don't have the getpwnam - # and getpwuid routines defined. Try to catch various different ways - # of knowing we are on one of these systems: - return "" if ($OS eq "Windows" or - $OS eq "Mac" or - $OS eq "Netware" or - $OS eq "MPE"); - $user="" if (! defined $user); - - if ($user) { - $home= (getpwnam($user))[7]; - } else { - $home= (getpwuid($<))[7]; - } - $home = VMS::Filespec::unixpath($home) if ($OS eq "VMS"); - return "" if (! $home); - $file="$home/$file"; - } - $file; -} - -# $File=&FullFilePath($file); -# Returns the full or relative path to $file (expanding "~" if necessary). -# Returns an empty string if a "~" expansion cannot be interpreted. The -# path does not need to exist. CleanFile is called. -sub FullFilePath { - my($file)=shift; - my($rootpat) = '^/'; #default pattern to match absolute path - $rootpat = '^(\\|/|([A-Za-z]:[\\/]))' if ($OS eq 'Windows'); - $file=&ExpandTilde($file); - return "" if (! $file); - return &CleanFile($file); -} - -# $Flag=&CheckFilePath($file [,$mode]); -# Checks to see if $file exists, to see what type it is, and whether -# the script can access it. If it exists and has the correct mode, 1 -# is returned. -# -# $mode is a string which may contain any of the valid file test operator -# characters except t, M, A, C. The appropriate test is run for each -# character. For example, if $mode is "re" the -r and -e tests are both -# run. -# -# An empty string is returned if the file doesn't exist. A 0 is returned -# if the file exists but any test fails. -# -# All characters in $mode which do not correspond to valid tests are -# ignored. -sub CheckFilePath { - my($file,$mode)=@_; - my($test)=(); - $file=&FullFilePath($file); - $mode = "" if (! defined $mode); - - # Run tests - return 0 if (! defined $file or ! $file); - return 0 if (( ! -e $file) or - ($mode =~ /r/ && ! -r $file) or - ($mode =~ /w/ && ! -w $file) or - ($mode =~ /x/ && ! -x $file) or - ($mode =~ /R/ && ! -R $file) or - ($mode =~ /W/ && ! -W $file) or - ($mode =~ /X/ && ! -X $file) or - ($mode =~ /o/ && ! -o $file) or - ($mode =~ /O/ && ! -O $file) or - ($mode =~ /z/ && ! -z $file) or - ($mode =~ /s/ && ! -s $file) or - ($mode =~ /f/ && ! -f $file) or - ($mode =~ /d/ && ! -d $file) or - ($mode =~ /l/ && ! -l $file) or - ($mode =~ /s/ && ! -s $file) or - ($mode =~ /p/ && ! -p $file) or - ($mode =~ /b/ && ! -b $file) or - ($mode =~ /c/ && ! -c $file) or - ($mode =~ /u/ && ! -u $file) or - ($mode =~ /g/ && ! -g $file) or - ($mode =~ /k/ && ! -k $file) or - ($mode =~ /T/ && ! -T $file) or - ($mode =~ /B/ && ! -B $file)); - return 1; -} -#&& - -# $Path=&FixPath($path [,$full] [,$mode] [,$error]); -# Makes sure that every directory in $path (a colon separated list of -# directories) appears as a full path or relative path. All "~" -# expansions are removed. All trailing slashes are removed also. If -# $full is non-nil, relative paths are expanded to full paths as well. -# -# If $mode is given, it may be either "e", "r", or "w". In this case, -# additional checking is done to each directory. If $mode is "e", it -# need ony exist to pass the check. If $mode is "r", it must have have -# read and execute permission. If $mode is "w", it must have read, -# write, and execute permission. -# -# The value of $error determines what happens if the directory does not -# pass the test. If it is non-nil, if any directory does not pass the -# test, the subroutine returns the empty string. Otherwise, it is simply -# removed from $path. -# -# The corrected path is returned. -sub FixPath { - my($path,$full,$mode,$err)=@_; - local($_)=""; - my(@dir)=split(/$Cnf{"PathSep"}/,$path); - $full=0 if (! defined $full); - $mode="" if (! defined $mode); - $err=0 if (! defined $err); - $path=""; - if ($mode eq "e") { - $mode="de"; - } elsif ($mode eq "r") { - $mode="derx"; - } elsif ($mode eq "w") { - $mode="derwx"; - } - - foreach (@dir) { - - # Expand path - if ($full) { - $_=&FullFilePath($_); - } else { - $_=&ExpandTilde($_); - } - if (! $_) { - return "" if ($err); - next; - } - - # Check mode - if (! $mode or &CheckFilePath($_,$mode)) { - $path .= $Cnf{"PathSep"} . $_; - } else { - return "" if ($err); - } - } - $path =~ s/^$Cnf{"PathSep"}//; - return $path; -} -#&& - -# $File=&SearchPath($file,$path [,$mode] [,@suffixes]); -# Searches through directories in $path for a file named $file. The -# full path is returned if one is found, or an empty string otherwise. -# The file may exist with one of the @suffixes. The mode is checked -# similar to &CheckFilePath. -# -# The first full path that matches the name and mode is returned. If none -# is found, an empty string is returned. -sub SearchPath { - my($file,$path,$mode,@suff)=@_; - my($f,$s,$d,@dir,$fs)=(); - $path=&FixPath($path,1,"r"); - @dir=split(/$Cnf{"PathSep"}/,$path); - foreach $d (@dir) { - $f="$d/$file"; - $f=~ s|//|/|g; - return $f if (&CheckFilePath($f,$mode)); - foreach $s (@suff) { - $fs="$f.$s"; - return $fs if (&CheckFilePath($fs,$mode)); - } - } - return ""; -} - -# @list=&ReturnList($str); -# This takes a string which should be a comma separated list of integers -# or ranges (5-7). It returns a sorted list of all integers referred to -# by the string, or () if there is an invalid element. -# -# Negative integers are also handled. "-2--1" is equivalent to "-2,-1". -sub ReturnList { - my($str)=@_; - my(@ret,@str,$from,$to,$tmp)=(); - @str=split(/,/,$str); - foreach $str (@str) { - if ($str =~ /^[-+]?\d+$/) { - push(@ret,$str); - } elsif ($str =~ /^([-+]?\d+)-([-+]?\d+)$/) { - ($from,$to)=($1,$2); - if ($from>$to) { - $tmp=$from; - $from=$to; - $to=$tmp; - } - push(@ret,$from..$to); - } else { - return (); - } - } - @ret; -} - -1; diff --git a/lib/Digest/HMAC.pm b/lib/Digest/HMAC.pm deleted file mode 100644 index e2e6b60..0000000 --- a/lib/Digest/HMAC.pm +++ /dev/null @@ -1,111 +0,0 @@ -package Digest::HMAC; -$VERSION = "1.01"; - -use strict; - -# OO interface - -sub new -{ - my($class, $key, $hasher, $block_size) = @_; - $block_size ||= 64; - $key = $hasher->new->add($key)->digest if length($key) > $block_size; - - my $self = bless {}, $class; - $self->{k_ipad} = $key ^ (chr(0x36) x $block_size); - $self->{k_opad} = $key ^ (chr(0x5c) x $block_size); - $self->{hasher} = $hasher->new->add($self->{k_ipad}); - $self; -} - -sub reset -{ - my $self = shift; - $self->{hasher}->reset->add($self->{k_ipad}); - $self; -} - -sub add { my $self = shift; $self->{hasher}->add(@_); $self; } -sub addfile { my $self = shift; $self->{hasher}->addfile(@_); $self; } - -sub _digest -{ - my $self = shift; - my $inner_digest = $self->{hasher}->digest; - $self->{hasher}->reset->add($self->{k_opad}, $inner_digest); -} - -sub digest { shift->_digest->digest; } -sub hexdigest { shift->_digest->hexdigest; } -sub b64digest { shift->_digest->b64digest; } - - -# Functional interface - -require Exporter; -*import = \&Exporter::import; -use vars qw(@EXPORT_OK); -@EXPORT_OK = qw(hmac hmac_hex); - -sub hmac -{ - my($data, $key, $hash_func, $block_size) = @_; - $block_size ||= 64; - $key = &$hash_func($key) if length($key) > $block_size; - - my $k_ipad = $key ^ (chr(0x36) x $block_size); - my $k_opad = $key ^ (chr(0x5c) x $block_size); - - &$hash_func($k_opad, &$hash_func($k_ipad, $data)); -} - -sub hmac_hex { unpack("H*", &hmac); } - -1; - -__END__ - -=head1 NAME - -Digest::HMAC - Keyed-Hashing for Message Authentication - -=head1 SYNOPSIS - - # Functional style - use Digest::HMAC qw(hmac hmac_hex); - $digest = hmac($data, $key, \&myhash); - print hmac_hex($data, $key, \&myhash); - - # OO style - use Digest::HMAC; - $hmac = Digest::HMAC->new($key, "Digest::MyHash"); - - $hmac->add($data); - $hmac->addfile(*FILE); - - $digest = $hmac->digest; - $digest = $hmac->hexdigest; - $digest = $hmac->b64digest; - -=head1 DESCRIPTION - -HMAC is used for message integrity checks between two parties that -share a secret key, and works in combination with some other Digest -algorithm, usually MD5 or SHA-1. The HMAC mechanism is described in -RFC 2104. - -HMAC follow the common C<Digest::> interface, but the constructor -takes the secret key and the name of some other simple C<Digest::> -as argument. - -=head1 SEE ALSO - -L<Digest::HMAC_MD5>, L<Digest::HMAC_SHA1> - -RFC 2104 - -=head1 AUTHORS - -Graham Barr <gbarr@ti.com>, Gisle Aas <gisle@aas.no> - -=cut diff --git a/lib/Digest/HMAC_MD5.pm b/lib/Digest/HMAC_MD5.pm deleted file mode 100644 index 6efa0a1..0000000 --- a/lib/Digest/HMAC_MD5.pm +++ /dev/null @@ -1,71 +0,0 @@ -package Digest::HMAC_MD5; -$VERSION="1.01"; - -use strict; -use Digest::MD5 qw(md5); -use Digest::HMAC qw(hmac); - -# OO interface -use vars qw(@ISA); -@ISA=qw(Digest::HMAC); -sub new -{ - my $class = shift; - $class->SUPER::new($_[0], "Digest::MD5", 64); -} - -# Functional interface -require Exporter; -*import = \&Exporter::import; -use vars qw(@EXPORT_OK); -@EXPORT_OK=qw(hmac_md5 hmac_md5_hex); - -sub hmac_md5 -{ - hmac($_[0], $_[1], \&md5, 64); -} - -sub hmac_md5_hex -{ - unpack("H*", &hmac_md5) -} - -1; - -__END__ - -=head1 NAME - -Digest::HMAC_MD5 - Keyed-Hashing for Message Authentication - -=head1 SYNOPSIS - - # Functional style - use Digest::HMAC_MD5 qw(hmac_md5 hmac_md5_hex); - $digest = hmac_md5($data, $key); - print hmac_md5_hex($data, $key); - - # OO style - use Digest::HMAC_MD5; - $hmac = Digest::HMAC_MD5->new($key); - - $hmac->add($data); - $hmac->addfile(*FILE); - - $digest = $hmac->digest; - $digest = $hmac->hexdigest; - $digest = $hmac->b64digest; - -=head1 DESCRIPTION - -This module provide HMAC-MD5 hashing. - -=head1 SEE ALSO - -L<Digest::HMAC>, L<Digest::MD5>, L<Digest::HMAC_SHA1> - -=head1 AUTHOR - -Gisle Aas <gisle@aas.no> - -=cut diff --git a/lib/Digest/HMAC_SHA1.pm b/lib/Digest/HMAC_SHA1.pm deleted file mode 100644 index fadfb40..0000000 --- a/lib/Digest/HMAC_SHA1.pm +++ /dev/null @@ -1,71 +0,0 @@ -package Digest::HMAC_SHA1; -$VERSION="1.01"; - -use strict; -use Digest::SHA1 qw(sha1); -use Digest::HMAC qw(hmac); - -# OO interface -use vars qw(@ISA); -@ISA=qw(Digest::HMAC); -sub new -{ - my $class = shift; - $class->SUPER::new($_[0], "Digest::SHA1", 64); -} - -# Functional interface -require Exporter; -*import = \&Exporter::import; -use vars qw(@EXPORT_OK); -@EXPORT_OK=qw(hmac_sha1 hmac_sha1_hex); - -sub hmac_sha1 -{ - hmac($_[0], $_[1], \&sha1, 64); -} - -sub hmac_sha1_hex -{ - unpack("H*", &hmac_sha1) -} - -1; - -__END__ - -=head1 NAME - -Digest::HMAC_SHA1 - Keyed-Hashing for Message Authentication - -=head1 SYNOPSIS - - # Functional style - use Digest::HMAC_SHA1 qw(hmac_sha1 hmac_sha1_hex); - $digest = hmac_sha1($data, $key); - print hmac_sha1_hex($data, $key); - - # OO style - use Digest::HMAC_SHA1; - $hmac = Digest::HMAC_SHA1->new($key); - - $hmac->add($data); - $hmac->addfile(*FILE); - - $digest = $hmac->digest; - $digest = $hmac->hexdigest; - $digest = $hmac->b64digest; - -=head1 DESCRIPTION - -This module provide HMAC-SHA-1 hashing. - -=head1 SEE ALSO - -L<Digest::HMAC>, L<Digest::SHA1>, L<Digest::HMAC_MD5> - -=head1 AUTHOR - -Gisle Aas <gisle@aas.no> - -=cut diff --git a/lib/GD/Graph/Data.pm b/lib/GD/Graph/Data.pm deleted file mode 100644 index 23f4624..0000000 --- a/lib/GD/Graph/Data.pm +++ /dev/null @@ -1,725 +0,0 @@ -#========================================================================== -# Copyright (c) 1995-2000 Martien Verbruggen -#-------------------------------------------------------------------------- -# -# Name: -# GD::Graph::Data.pm -# -# $Id: Data.pm,v 1.21 2003/06/17 03:28:11 mgjv Exp $ -# -#========================================================================== - -package GD::Graph::Data; - -($GD::Graph::Data::VERSION) = '$Revision: 1.21 $' =~ /\s([\d.]+)/; - -use strict; -use GD::Graph::Error; - -@GD::Graph::Data::ISA = qw( GD::Graph::Error ); - -=head1 NAME - -GD::Graph::Data - Data set encapsulation for GD::Graph - -=head1 SYNOPSIS - -use GD::Graph::Data; - -=head1 DESCRIPTION - -This module encapsulates the data structure that is needed for GD::Graph -and friends. An object of this class contains a list of X values, and a -number of lists of corresponding Y values. This only really makes sense -if the Y values are numerical, but you can basically store anything. -Undefined values have a special meaning to GD::Graph, so they are -treated with care when stored. - -Many of the methods of this module are intended for internal use by -GD::Graph and the module itself, and will most likely not be useful to -you. Many won't even I<seem> useful to you... - -=head1 EXAMPLES - - use GD::Graph::Data; - use GD::Graph::bars; - - my $data = GD::Graph::Data->new(); - - $data->read(file => '/data/sales.dat', delimiter => ','); - $data = $data->copy(wanted => [2, 4, 5]); - - # Add the newer figures from the database - use DBI; - # do DBI things, like connecting to the database, statement - # preparation and execution - - while (@row = $sth->fetchrow_array) - { - $data->add_point(@row); - } - - my $chart = GD::Graph::bars->new(); - my $gd = $chart->plot($data); - -or for quick changes to legacy code - - # Legacy code builds array like this - @data = ( [qw(Jan Feb Mar)], [1, 2, 3], [5, 4, 3], [6, 3, 7] ); - - # And we quickly need to do some manipulations on that - my $data = GD::Graph::Data->new(); - $data->copy_from(\@data); - - # And now do all the new stuff that's wanted. - while (@foo = bar_baz()) - { - $data->add_point(@foo); - } - -=head1 METHODS - -=head2 $data = GD::Graph::Data->new() - -Create a new GD::Graph::Data object. - -=cut - -# Error constants -use constant ERR_ILL_DATASET => 'Illegal dataset number'; -use constant ERR_ILL_POINT => 'Illegal point number'; -use constant ERR_NO_DATASET => 'No data sets set'; -use constant ERR_ARGS_NO_HASH => 'Arguments must be given as a hash list'; - -sub new -{ - my $proto = shift; - my $class = ref($proto) || $proto; - my $self = []; - bless $self => $class; - $self->copy_from(@_) or return $self->_move_errors if (@_); - return $self; -} - -sub DESTROY -{ - my $self = shift; - $self->clear_errors(); -} - -sub _set_value -{ - my $self = shift; - my ($nd, $np, $val) = @_; - - # Make sure we have empty arrays in between - if ($nd > $self->num_sets) - { - # XXX maybe do this with splice - for ($self->num_sets .. $nd - 1) - { - push @{$self}, []; - } - } - $self->[$nd][$np] = $val; - - return $self; -} - -=head2 $data->set_x($np, $value); - -Set the X value of point I<$np> to I<$value>. Points are numbered -starting with 0. You probably will never need this. Returns undef on -failure. - -=cut - -sub set_x -{ - my $self = shift; - $self->_set_value(0, @_); -} - -=head2 $data->get_x($np) - -Get the X value of point I<$np>. See L<"set_x">. - -=cut - -sub get_x -{ - my $self = shift; - my $np = shift; - return $self->_set_error(ERR_ILL_POINT) - unless defined $np && $np >= 0; - - $self->[0][$np]; -} - -=head2 $data->set_y($nd, $np, $value); - -Set the Y value of point I<$np> in data set I<$nd> to I<$value>. Points -are numbered starting with 0, data sets are numbered starting with 1. -You probably will never need this. Returns undef on failure. - -=cut - -sub set_y -{ - my $self = shift; - return $self->_set_error(ERR_ILL_DATASET) - unless defined $_[0] && $_[0] >= 1; - $self->_set_value(@_); -} - -=head2 $data->get_y($nd, $np) - -Get the Y value of point I<$np> in data set I<$nd>. See L<"set_y">. This -will return undef on an error, but the fact that it returns undef does -not mean there was an error (since undefined values can be stored, and -therefore returned). - -=cut - -sub get_y -{ - my $self = shift; - my ($nd, $np) = @_; - return $self->_set_error(ERR_ILL_DATASET) - unless defined $nd && $nd >= 1 && $nd <= $self->num_sets; - return $self->_set_error(ERR_ILL_POINT) - unless defined $np && $np >= 0; - - $self->[$nd][$np]; -} - -=head2 $data->get_y_cumulative($nd, $np) - -Get the cumulative value of point I<$np> in data set<$nd>. The -cumulative value is obtained by adding all the values of the points -I<$np> in the data sets 1 to I<$nd>. - -=cut - -sub get_y_cumulative -{ - my $self = shift; - my ($nd, $np) = @_; - return $self->_set_error(ERR_ILL_DATASET) - unless defined $nd && $nd >= 1 && $nd <= $self->num_sets; - return $self->_set_error(ERR_ILL_POINT) - unless defined $np && $np >= 0; - - my $value; - for (my $i = 1; $i <= $nd; $i++) - { - $value += $self->[$i][$np] || 0; - } - - return $value; -} - -sub _get_min_max -{ - my $self = shift; - my $nd = shift; - my ($min, $max); - - for my $val (@{$self->[$nd]}) - { - next unless defined $val; - $min = $val if !defined $min || $val < $min; - $max = $val if !defined $max || $val > $max; - } - - return $self->_set_error("No (defined) values in " . - ($nd == 0 ? "X list" : "dataset $nd")) - unless defined $min && defined $max; - - return ($min, $max); -} - -=head2 $data->get_min_max_x - -Returns a list of the minimum and maximum x value or the -empty list on failure. - -=cut - -sub get_min_max_x -{ - my $self = shift; - $self->_get_min_max(0); -} - -=head2 $data->get_min_max_y($nd) - -Returns a list of the minimum and maximum y value in data set $nd or the -empty list on failure. - -=cut - -sub get_min_max_y -{ - my $self = shift; - my $nd = shift; - - return $self->_set_error(ERR_ILL_DATASET) - unless defined $nd && $nd >= 1 && $nd <= $self->num_sets; - - $self->_get_min_max($nd); -} - -=head2 $data->get_min_max_y_all() - -Returns a list of the minimum and maximum y value in all data sets or the -empty list on failure. - -=cut - -sub get_min_max_y_all -{ - my $self = shift; - my ($min, $max); - - for (my $ds = 1; $ds <= $self->num_sets; $ds++) - { - my ($ds_min, $ds_max) = $self->get_min_max_y($ds); - next unless defined $ds_min; - $min = $ds_min if !defined $min || $ds_min < $min; - $max = $ds_max if !defined $max || $ds_max > $max; - } - - return $self->_set_error('No (defined) values in any data set') - unless defined $min && defined $max; - - return ($min, $max); -} - -# Undocumented, not part of interface right now. Might expose at later -# point in time. - -sub set_point -{ - my $self = shift; - my $np = shift; - return $self->_set_error(ERR_ILL_POINT) - unless defined $np && $np >= 0; - - for (my $ds = 0; $ds < @_; $ds++) - { - $self->_set_value($ds, $np, $_[$ds]); - } - return $self; -} - -=head2 $data->add_point($X, $Y1, $Y2 ...) - -Adds a point to the data set. The base for the addition is the current -number of X values. This means that if you have a data set with the -contents - - (X1, X2) - (Y11, Y12) - (Y21) - (Y31, Y32, Y33, Y34) - -a $data->add_point(Xx, Y1x, Y2x, Y3x, Y4x) will result in - - (X1, X2, Xx ) - (Y11, Y12, Y1x) - (Y21, undef, Y2x) - (Y31, Y32, Y3x, Y34) - (undef, undef, Y4x) - -In other words: beware how you use this. As long as you make sure that -all data sets are of equal length, this method is safe to use. - -=cut - -sub add_point -{ - my $self = shift; - $self->set_point(scalar $self->num_points, @_); -} - -=head2 $data->num_sets() - -Returns the number of data sets. - -=cut - -sub num_sets -{ - my $self = shift; - @{$self} - 1; -} - -=head2 $data->num_points() - -In list context, returns a list with its first element the number of X -values, and the subsequent elements the number of respective Y values -for each data set. In scalar context returns the number of points -that have an X value set, i.e. the number of data sets that would result -from a call to C<make_strict>. - -=cut - -sub num_points -{ - my $self = shift; - return (0) unless @{$self}; - - wantarray ? - map { scalar @{$_} } @{$self} : - scalar @{$self->[0]} -} - -=head2 $data->x_values() - -Return a list of all the X values. - -=cut - -sub x_values -{ - my $self = shift; - return $self->_set_error(ERR_NO_DATASET) - unless @{$self}; - @{$self->[0]}; -} - -=head2 $data->y_values($nd) - -Return a list of the Y values for data set I<$nd>. Data sets are -numbered from 1. Returns the empty list if $nd is out of range, or if -the data set at $nd is empty. - -=cut - -sub y_values -{ - my $self = shift; - my $nd = shift; - return $self->_set_error(ERR_ILL_DATASET) - unless defined $nd && $nd >= 1 && $nd <= $self->num_sets; - return $self->_set_error(ERR_NO_DATASET) - unless @{$self}; - - @{$self->[$nd]}; -} - -=head2 $data->reset() OR GD::Graph::Data->reset() - -As an object method: Reset the data container, get rid of all data and -error messages. As a class method: get rid of accumulated error messages -and possible other crud. - -=cut - -sub reset -{ - my $self = shift; - @{$self} = () if ref($self); - $self->clear_errors(); - return $self; -} - -=head2 $data->make_strict() - -Make all data set lists the same length as the X list by truncating data -sets that are too long, and filling data sets that are too short with -undef values. always returns a true value. - -=cut - -sub make_strict -{ - my $self = shift; - - for my $ds (1 .. $self->num_sets) - { - my $data_set = $self->[$ds]; - - my $short = $self->num_points - @{$data_set}; - next if $short == 0; - - if ($short > 0) - { - my @fill = (undef) x $short; - push @{$data_set}, @fill; - } - else - { - splice @{$data_set}, $short; - } - } - return $self; -} - -=head2 $data->cumulate(preserve_undef => boolean) - -The B<cumulate> parameter will summarise the Y value sets as follows: -the first Y value list will be unchanged, the second will contain a -sum of the first and second, the third will contain the sum of first, -second and third, and so on. Returns undef on failure. - -if the argument I<preserve_undef> is set to a true value, then the sum -of exclusively undefined values will be preserved as an undefined value. -If it is not present or a false value, undef will be treated as zero. -Note that this still will leave undefined values in the first data set -alone. - -Note: Any non-numerical defined Y values will be treated as 0, but you -really shouldn't be using this to store that sort of Y data. - -=cut - -sub cumulate -{ - my $self = shift; - - return $self->_set_error(ERR_ARGS_NO_HASH) if (@_ && @_ % 2); - my %args = @_; - - # For all the sets, starting at the last one, ending just - # before the first - for (my $ds = $self->num_sets; $ds > 1; $ds--) - { - # For each point in the set - for my $point (0 .. $#{$self->[$ds]}) - { - # Add the value for each point in lower sets to this one - for my $i (1 .. $ds - 1) - { - # If neither are defined, we want to preserve the - # undefinedness of this point. If we don't do this, then - # the mathematical operation will force undef to be a 0. - next if - $args{preserve_undef} && - ! defined $self->[$ds][$point] && - ! defined $self->[$i][$point]; - - $self->[$ds][$point] += $self->[$i][$point] || 0; - } - } - } - return $self; -} - -=head2 $data->wanted(indexes) - -Removes all data sets except the ones in the argument list. It will also -reorder the data sets in the order given. Returns undef on failure. - -To remove all data sets except the first, sixth and second, in that -order: - - $data->wanted(1, 6, 2) or die $data->error; - -=cut - -sub wanted -{ - my $self = shift; - - for my $wanted (@_) - { - return $self->_set_error("Wanted index $wanted out of range 1-" - . $self->num_sets) - if $wanted < 1 || $wanted > $self->num_sets; - } - @{$self} = @{$self}[0, @_]; - return $self; -} - -=head2 $data->reverse - -Reverse the order of the data sets. - -=cut - -sub reverse -{ - my $self = shift; - @{$self} = ($self->[0], reverse @{$self}[1..$#{$self}]); - return $self; -} - -=head2 $data->copy_from($data_ref) - -Copy an 'old' style GD::Graph data structure or another GD::Graph::Data -object into this object. This will remove the current data. Returns undef -on failure. - -=cut - -sub copy_from -{ - my $self = shift; - my $data = shift; - return $self->_set_error('Not a valid source data structure') - unless defined $data && ( - ref($data) eq 'ARRAY' || ref($data) eq __PACKAGE__); - - $self->reset; - - my $i = 0; - for my $data_set (@{$data}) - { - return $self->_set_error("Invalid data set: $i") - unless ref($data_set) eq 'ARRAY'; - - push @{$self}, [@{$data_set}]; - $i++; - } - - return $self; -} - -=head2 $data->copy() - -Returns a copy of the object, or undef on failure. - -=cut - -sub copy -{ - my $self = shift; - - my $new = $self->new(); - $new->copy_from($self); - return $new; -} - -=head2 $data->read(I<arguments>) - -Read a data set from a file. This will remove the current data. returns -undef on failure. This method uses the standard module -Text::ParseWords to parse lines. If you don't have this for some odd -reason, don't use this method, or your program will die. - -B<Data file format>: The default data file format is tab separated data -(which can be changed with the delimiter argument). Comment lines are -any lines that start with a #. In the following example I have replaced -literal tabs with <tab> for clarity - - # This is a comment, and will be ignored - Jan<tab>12<tab>24 - Feb<tab>13<tab>37 - # March is missing - Mar<tab><tab> - Apr<tab>9<tab>18 - -Valid arguments are: - -I<file>, mandatory. The file name of the file to read from, or a -reference to a file handle or glob. - - $data->read(file => '/data/foo.dat') or die $data->error; - $data->read(file => \*DATA) or die $data->error; - $data->read(file => $file_handle) or die $data->error; - -I<no_comment>, optional. Give this a true value if you don't want lines -with an initial # to be skipped. - - $data->read(file => '/data/foo.dat', no_comment => 1); - -I<delimiter>, optional. A regular expression that will become the -delimiter instead of a single tab. - - $data->read(file => '/data/foo.dat', delimiter => '\s+'); - $data->read(file => '/data/foo.dat', delimiter => qr/\s+/); - -=cut - -sub read -{ - my $self = shift; - - return $self->_set_error(ERR_ARGS_NO_HASH) if (@_ && @_ % 2); - my %args = @_; - - return $self->_set_error('Missing required argument: file') - unless $args{file}; - - my $delim = $args{delimiter} || "\t"; - - $self->reset(); - - # The following will die if these modules are not present, as - # documented. - require Text::ParseWords; - - my $fh; - local *FH; - - if (UNIVERSAL::isa($args{file}, "GLOB")) - { - $fh = $args{file}; - } - else - { - # $fh = \do{ local *FH }; # Odd... This dumps core, sometimes in 5.005 - $fh = \*FH; # XXX Need this for perl 5.005 - open($fh, $args{file}) or - return $self->_set_error("open ($args{file}): $!"); - } - - while (my $line = <$fh>) - { - chomp $line; - next if $line =~ /^#/ && !$args{no_comment}; - my @fields = Text::ParseWords::parse_line($delim, 1, $line); - next unless @fields; - $self->add_point(@fields); - } - return $self; -} - -=head2 $data->error() OR GD::Graph::Data->error() - -Returns a list of all the errors that the current object has -accumulated. In scalar context, returns the last error. If called as a -class method it works at a class level. - -This method is inherited, see L<GD::Graph::Error> for more information. - -=cut - -=head2 $data->has_error() OR GD::Graph::Data->has_error() - -Returns true if the object (or class) has errors pending, false if not. -In some cases (see L<"copy">) this is the best way to check for errors. - -This method is inherited, see L<GD::Graph::Error> for more information. - -=cut - -=head1 NOTES - -As with all Modules for Perl: Please stick to using the interface. If -you try to fiddle too much with knowledge of the internals of this -module, you could get burned. I may change them at any time. -Specifically, I probably won't always keep this implemented as an array -reference. - -=head1 AUTHOR - -Martien Verbruggen E<lt>mgjv@tradingpost.com.auE<gt> - -=head2 Copyright - -(c) Martien Verbruggen. - -All rights reserved. This package is free software; you can redistribute -it and/or modify it under the same terms as Perl itself. - -=head1 SEE ALSO - -L<GD::Graph>, L<GD::Graph::Error> - -=cut - -"Just another true value"; - diff --git a/lib/GD/Graph/Error.pm b/lib/GD/Graph/Error.pm deleted file mode 100644 index 0d8e50c..0000000 --- a/lib/GD/Graph/Error.pm +++ /dev/null @@ -1,346 +0,0 @@ -#========================================================================== -# Copyright (c) 1995-2000 Martien Verbruggen -#-------------------------------------------------------------------------- -# -# Name: -# GD::Graph::Error.pm -# -# $Id: Error.pm,v 1.8 2003/02/10 22:12:41 mgjv Exp $ -# -#========================================================================== - -package GD::Graph::Error; - -($GD::Graph::Error::VERSION) = '$Revision: 1.8 $' =~ /\s([\d.]+)/; - -use strict; -use Carp; - -my %Errors; -use vars qw( $Debug $ErrorLevel $CriticalLevel ); - -$Debug = 0; - -# Warnings from 0 to 4, Errors from 5 to 9, and Critical 10 and above. -$ErrorLevel = 5; -$CriticalLevel = 10; - -=head1 NAME - -GD::Graph::Error - Error handling for GD::Graph classes - -=head1 SYNOPSIS - -use GD::Graph::Error_subclass; - -=head1 DESCRIPTION - -This class is a parent for all GD::Graph classes, including -GD::Graph::Data, and offers error and warning handling and some -debugging control. - -Errors are stored in a lexical hash in this package, so the -implementation of the subclass should be irrelevant. - -=head1 PUBLIC METHODS - -These methods can be used by users of any of the subclasses of -GD::Graph::Error to get at the errors of objects or classes. - -=head2 $object->error() OR Class->error() - -Returns a list of all the errors that the current object has -accumulated. In scalar context, returns the last error. If called as a -class method it works at a class level. This is handy when a constructor -fails, for example: - - my $data = GD::Graph::Data->new() - or die GD::Graph::Data->error; - $data->read(file => '/foo/bar.data') - or die $data->error; - -or if you really are only interested in the last error: - - $data->read(file => '/foo/bar.data') - or die scalar $data->error; - -This implementation does not clear the error list, so if you don't die -on errors, you will need to make sure to never ask for anything but the -last error (put this in scalar context) or to call C<clear_error()> now -and again. - -Errors are more verbose about where the errors originated if the -$GD::Graph::Error::Debug variable is set to a true value, and even more -verbose if this value is larger than 5. - -If $Debug is larger than 3, both of these will always return the -full list of errors and warnings (although the meaning of C<has_warning> -and C<has_error> does not change). - -=cut - -sub _error -{ - my $self = shift; - my $min_level = shift || 0; - my $max_level = shift || 1 << 31; - return unless exists $Errors{$self}; - my $error = $Errors{$self}; - - my @return; - - @return = - map { - ($Debug > 3 ? "[$_->{level}] " : '') . - "$_->{msg}" . - ($Debug ? " at $_->{whence}[1] line $_->{whence}[2]" : '') . - ($Debug > 5 ? " => $_->{caller}[0]($_->{caller}[2])" : '') . - "\n" - } - grep { $_->{level} >= $min_level && $_->{level} <= $max_level } - @$error; - - wantarray && @return > 1 and - $return[-1] =~ s/\n/\n\t/ or - $return[-1] =~ s/\n//; - - return wantarray ? @return : $return[-1]; -} - -sub error -{ - my $self = shift; - $Debug > 3 and return $self->_error(); - $self->_error($ErrorLevel); -} - -sub warning -{ - my $self = shift; - $Debug > 3 and return $self->_error(); - $self->_error(0, $ErrorLevel - 1); -} - -=head2 $object->has_error() OR Class->has_error() - -=head2 $object->has_warning() OR Class->has_warning() - -Returns true if there are pending errors (warnings) for the object -(or class). To be more precise, it returns a list of errors in list -context, and the number of errors in scalar context. - -This allows you to check for errors and warnings after a large number of -operations which each might fail: - - $data->read(file => '/foo/bar.data') or die $data->error; - while (my @foo = $sth->fetchrow_array) - { - $data->add_point(@foo); - } - $data->set_x(12, 'Foo'); - $data->has_warning and warn $data->warning; - $data->has_error and die $data->error; - -The reason to call this, instead of just calling C<error()> or -C<warning()> and looking at its return value, is that this method is -much more efficient and fast. - -If you want to count anything as bad, just set $ErrorLevel to 0, after -which you only need to call C<has_error>. - -=cut - -sub has_error -{ - my $self = shift; - return unless exists $Errors{$self}; - grep { $_->{level} >= $ErrorLevel } @{$Errors{$self}}; -} - -sub has_warning -{ - my $self = shift; - return unless exists $Errors{$self}; - grep { $_->{level} < $ErrorLevel } @{$Errors{$self}}; -} - -=head2 $object->clear_errors() or Class->clear_errors() - -Clears all outstanding errors. - -=cut - -sub clear_errors -{ - my $self = shift; - delete $Errors{$self}; -} - -=head1 PROTECTED METHODS - -These methods are only to be called from within this class and its -Subclasses. - -=head2 $object->_set_error(I<arg>) or Class->_set_error(I<arg>) - -=head2 $object->_set_warning(I<arg>) or Class->_set_warning(I<arg>) - -Subclasses call this to set an error. The argument can be a reference -to an array, of which the first element should be the error level, and -the second element the error message. Alternatively, it can just be the -message, in which case the error level will be assumed to be -$ErrorLevel. - -If the error level is >= $CriticalLevel the program will die, using -Carp::croak to display the current message, as well as all the other -error messages pending. - -In the current implementation these are almost identical when called -with a scalar argument, except that the default ewrror level is -different. When called with an array reference, they are identical in -function. This may change in the future. They're mainly here for code -clarity. - -=cut - -# Private, for construction of error hash. This should probably be an -# object, but that's too much work right now. -sub __error_hash -{ - my $caller = shift; - my $default = shift; - my $msg = shift; - - my %error = (caller => $caller); - - if (ref($msg) && ref($msg) eq 'ARRAY' && @{$msg} >= 2) - { - # Array reference - $error{level} = $msg->[0]; - $error{msg} = $msg->[1]; - } - elsif (ref($_[0]) eq '') - { - # simple scalar - $error{level} = $default; - $error{msg} = $msg; - } - else - { - # someting else, which I can't deal with - warn "Did you read the documentation for GD::Graph::Error?"; - return; - } - - my $lvl = 1; - while (my @c = caller($lvl)) - { - $error{whence} = [@c[0..2]]; - $lvl++; - } - - return \%error; -} - -sub _set_error -{ - my $self = shift; - return unless @_; - - while (@_) - { - my $e_h = __error_hash([caller], $ErrorLevel, shift) or return; - push @{$Errors{$self}}, $e_h; - croak $self->error if $e_h->{level} >= $CriticalLevel; - } - return; -} - -sub _set_warning -{ - my $self = shift; - return unless @_; - - while (@_) - { - my $e_h = __error_hash([caller], $ErrorLevel, shift) or return; - push @{$Errors{$self}}, $e_h; - croak $self->error if $e_h->{level} >= $CriticalLevel; - } - return; -} - -=head2 $object->_move_errors - -Move errors from an object into the class it belongs to. This can be -useful if something nasty happens in the constructor, while -instantiating one of these objects, and you need to move these errors -into the class space before returning. (see GD::Graph::Data::new for an -example) - -=cut - -sub _move_errors -{ - my $self = shift; - my $class = ref($self); - push @{$Errors{$class}}, @{$Errors{$self}}; - return; -} - -sub _dump -{ - my $self = shift; - require Data::Dumper; - my $dd = Data::Dumper->new([$self], ['me']); - $dd->Dumpxs; -} - -=head1 VARIABLES - -=head2 $GD::Graph::Error::Debug - -The higher this value, the more verbose error messages will be. At the -moment, any true value will cause the line number and source file of the -caller at the top of the stack to be included, a value of more than 2 -will include the error severity, and a value of more than 5 will also -include the direct caller's (i.e. the spot where the error message was -generated) line number and package. Default: 0. - -=head2 $GD::Graph::Error::ErrorLevel - -Errors levels below this value will be counted as warnings, and error -levels above (and inclusive) up to $CriticalLevel will be counted as -errors. This is also the default error level for the C<_set_error()> -method. This value should be 0 or larger, and smaller than -$CriticalLevel. Default: 5. - -=head2 $GD::Graph::Error::CriticalLevel - -Any errorlevel of or above this level will immediately cause the program -to die with the specified message, using Carp::croak. Default: 10. - -=head1 NOTES - -As with all Modules for Perl: Please stick to using the interface. If -you try to fiddle too much with knowledge of the internals of this -module, you could get burned. I may change them at any time. - -=head1 AUTHOR - -Martien Verbruggen E<lt>mgjv@tradingpost.com.auE<gt> - -=head2 Copyright - -(c) Martien Verbruggen. - -All rights reserved. This package is free software; you can redistribute -it and/or modify it under the same terms as Perl itself. - -=head1 SEE ALSO - -L<GD::Graph>, L<GD::Graph::Data> - -=cut - -"Just another true value"; diff --git a/lib/GD/Graph/FAQ.pod b/lib/GD/Graph/FAQ.pod deleted file mode 100644 index f6ed237..0000000 --- a/lib/GD/Graph/FAQ.pod +++ /dev/null @@ -1,130 +0,0 @@ -=head1 NAME - -GD::Graph::FAQ - Frequently asked questions - -=head1 DESCRIPTION - -=head2 I get errors like "Can't call method METHOD on an undefined value". What gives? - -You probably had an error somewhere, most likely in the plot() method, -and you didn't check for it. See the section on Error Handling in the -documentation for L<GD::Graph> to find out how to deal with this sort -of thing, and how to get more information about what the error was. - -=head2 I am drawing a bar chart, and the chart area is a lot smaller than the image. What is going on? - -As of version 1.30, GD::Graph automatically corrects the width of the -plotting area of a chart if it needs to draw bars (i.e. for bars and -some mixed charts). This is necessary, because rounding errors cause -irregular gaps between or overlaps of bars if the bar is not an exact -integer number of pixels wide. - -If you want the old behaviour back, set the correct_with attribute to a -false value. - - -=head2 I have my data in some format that doesn't look at all like the array that I am supposed to give to GD::Graph's plot method. Do I really need to mess around with array references? - -Not necessarily. Check out the GD::Graph::Data class. - - -=head2 How do I stop those pesky accents appearing around bars or inside area charts? - -You can set the C<accent_treshold> option to a large enough value -(larger than your chart). Alternatively, you may like it better to set -the C<borderclrs> attribute to be the same as the dclrs one. - -I'll probably include an option in a future version that gives better -control over this. - - -=head2 Where is the ActiveState ppm of GD::Graph? - -Ask them. I have asked them, but didn't get an answer. I don't know what -to do to get it included in their set of ppms, and I really do not have -the time to keep asking them. - -I believe that GD::graph has finally made it into ActiveState's ppm -archive. However, I am going to leave this question here in case they -get behind again. - - -=head2 Do you have some example code for me? - -The distribution has a large set of examples in it. If you don't have -the original distribution, please get it from CPAN (http://www.cpan.org/ -or some local mirror). - - -=head2 Will you support X or Y? - -If you send me a patch that (in a decent manner) adds the functionality -to the latest version, I may very well add it for the next release. If -you don't send me a patch, but just a question, you will have to be -patient. - -=head2 Why does export_format give me a weird string, instead of just 'png' or 'gif'? - -As of version 1.31, export_format in a list context returns all formats -that GD can export. If you are only interested in the answer 'gif' or -'png', make sure that you call it in a scalar context. - - $export_format = GD::Graph->export_format; - $export_format = $graph->export_format; - print "Export format is ", scalar $graph->export_format, "\n"; - print "Export format is " . $graph->export_format . "\n"; - @export_formats = $graph->export_format; - - -=head2 TrueType fonts don't work when I use GD::Graph from a CGI program. - -When your programs run as CGI, they typically do not have the same -environment as when you use them from the command line. The Perl FAQ, -section 9, has some information on this. It is also not guaranteed that -your script runs from the directory that it is in. It is probably better -to include something like: - - use GD::Text; - GD::Text->font_path("/path/to/my/font_dir"); - -See the GD::Text documentation for more information about font paths. - -=head2 I'm trying to use GD's builtin fonts, but it's not working. - -Most likely, you are using the font short name, like gdGiantFont or -gdMediumBoldFont, and you have not put a C<use GD> in your program. -This is needed, because these short names need to be exported into -your name space by the GD library: - - use GD; - # ... - $graph->set_x_axis_font(gdMediumBoldFont); - -If you don't want to include the GD library, you can use the -longer alternative names (which is what I'd recommend anyway): - - $graph1->set_x_axis_font(GD::Font->MediumBold); - -If you C<use strict> then you will actually get an error message if -you try to use the short names without including the GD module. - -Also see the L<GD::Text> documentation for this information. - -=head2 When I have many data sets, some end up having the same colour. - -The default number of colours for data sets is seven, so if you use -more than seven data sets, those colours will be re-used for the -higher data sets. - -This is described in the entry for the C<dclrs> attribute in the -L<GD::Graph> documentation. - -=head1 AUTHOR - -Martien Verbruggen E<lt>mgjv@tradingpost.com.auE<gt> - -(c) Martien Verbruggen. - -All rights reserved. This package is free software; you can redistribute -it and/or modify it under the same terms as Perl itself. - diff --git a/lib/GD/Graph/area.pm b/lib/GD/Graph/area.pm deleted file mode 100644 index a06f114..0000000 --- a/lib/GD/Graph/area.pm +++ /dev/null @@ -1,112 +0,0 @@ -#========================================================================== -# Copyright (c) 1995-2000 Martien Verbruggen -#-------------------------------------------------------------------------- -# -# Name: -# GD::Graph::area.pm -# -# $Id: area.pm,v 1.16 2003/02/10 23:33:40 mgjv Exp $ -# -#========================================================================== - -package GD::Graph::area; - -($GD::Graph::area::VERSION) = '$Revision: 1.16 $' =~ /\s([\d.]+)/; - -use strict; - -use GD::Graph::axestype; - -@GD::Graph::area::ISA = qw( GD::Graph::axestype ); - -# PRIVATE -sub draw_data_set -{ - my $self = shift; # object reference - my $ds = shift; # number of the data set - - my @values = $self->{_data}->y_values($ds) or - return $self->_set_error("Impossible illegal data set: $ds", - $self->{_data}->error); - - # Select a data colour - my $dsci = $self->set_clr($self->pick_data_clr($ds)); - my $brci = $self->set_clr($self->pick_border_clr($ds)); - - # Create a new polygon - my $poly = GD::Polygon->new(); - - my @bottom; - - # Add the data points - for (my $i = 0; $i < @values; $i++) - { - my $value = $values[$i]; - next unless defined $value; - - my $bottom = $self->_get_bottom($ds, $i); - $value = $self->{_data}->get_y_cumulative($ds, $i) - if ($self->{overwrite} == 2); - - my ($x, $y) = $self->val_to_pixel($i + 1, $value, $ds); - $poly->addPt($x, $y); - # Need to keep track of this stuff for hotspots, and because - # it's the only reliable way of closing the polygon, without - # making odd assumptions. - push @bottom, [$x, $bottom]; - - # Hotspot stuff - # XXX needs fixing. Not used at the moment. - next unless defined $self->{_hotspots}->[$ds]->[$i]; - if ($i == 0) - { - $self->{_hotspots}->[$ds]->[$i] = ["poly", - $x, $y, - $x , $bottom, - $x - 1, $bottom, - $x - 1, $y, - $x, $y]; - } - else - { - $self->{_hotspots}->[$ds]->[$i] = ["poly", - $poly->getPt($i), - @{$bottom[$i]}, - @{$bottom[$i-1]}, - $poly->getPt($i-1), - $poly->getPt($i)]; - } - } - - foreach my $bottom (reverse @bottom) - { - $poly->addPt($bottom->[0], $bottom->[1]); - } - - # Draw a filled and a line polygon - $self->{graph}->filledPolygon($poly, $dsci) - if defined $dsci; - $self->{graph}->polygon($poly, $brci) - if defined $brci; - - # Draw the accent lines - if (defined $brci && - ($self->{right} - $self->{left})/@values > $self->{accent_treshold}) - { - for (my $i = 1; $i < @values - 1; $i++) - { - my $value = $values[$i]; - ## XXX Why don't I need this line? - ##next unless defined $value; - - my ($x, $y) = $poly->getPt($i); - my $bottom = $bottom[$i]->[1]; - - $self->{graph}->dashedLine($x, $y, $x, $bottom, $brci); - } - } - - return $ds -} - -"Just another true value"; diff --git a/lib/GD/Graph/axestype3d.pm b/lib/GD/Graph/axestype3d.pm deleted file mode 100644 index 7acb7f3..0000000 --- a/lib/GD/Graph/axestype3d.pm +++ /dev/null @@ -1,787 +0,0 @@ -#========================================================================== -# Module: GD::Graph::axestype3d -# -# Copyright (C) 1999,2001 Wadsack-Allen. All Rights Reserved. -# -# Based on axestype.pm,v 1.21 2000/04/15 08:59:36 mgjv -# Copyright (c) 1995-1998 Martien Verbruggen -# -#-------------------------------------------------------------------------- -# Date Modification Author -# ------------------------------------------------------------------------- -# 1999SEP18 Created 3D axestype base class (this JW -# module) changes noted in comments. -# 1999OCT15 Fixed to include all GIFgraph functions JW -# necessary for PNG support. -# 2000JAN19 Converted to GD::Graph sublcass JW -# 2000FEB21 Fixed bug in y-labels' height JW -# 2000APR18 Updated for compatibility with GD::Graph 1.30 JW -# 2000AUG21 Added 3d shading JW -# 2000SEP04 Allowed box_clr without box axis JW -# 06Dec2001 Fixed bug in rendering of x tick when x_tick_number is set JW -#========================================================================== -# TODO -# * Modify to use true 3-d extrusions at any theta and phi -#========================================================================== -package GD::Graph::axestype3d; - -use strict; - -use GD::Graph; -use GD::Graph::axestype; -use GD::Graph::utils qw(:all); -use GD::Graph::colour qw(:colours); -use Carp; - -@GD::Graph::axestype3d::ISA = qw(GD::Graph::axestype); -$GD::Graph::axestype3d::VERSION = '0.63'; - -# Commented inheritance from GD::Graph::axestype unless otherwise noted. - -use constant PI => 4 * atan2(1,1); - -my %Defaults = ( - depth_3d => 20, - '3d_shading' => 1, - - # the rest are inherited -); - -# Inherit _has_default - - -# Can't inherit initialise, because %Defaults is referenced file- -# specific, not class specific. -sub initialise -{ - my $self = shift; - - my $rc = $self->SUPER::initialise(); - - while( my($key, $val) = each %Defaults ) { - $self->{$key} = $val - } # end while - - return $rc; -} # end initialise - -# PUBLIC -# Inherit plot -# Inherit set -# Inherit setup_text -# Inherit set_x_label_font -# Inherit set_y_label_font -# Inherit set_x_axis_font -# Inherit set_y_axis_font -# Inherit set_legend -# Inherit set_legend_font - - - -# ---------------------------------------------------------- -# Sub: init_graph -# -# Args: (None) -# -# Description: -# Override GD::Graph::init_graph to add 3d shading colors, -# if requested -# -# [From GD::Graph] -# Initialise the graph output canvas, setting colours (and -# getting back index numbers for them) setting the graph to -# transparent, and interlaced, putting a logo (if defined) -# on there. -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 20Aug2000 Added to support 3d graph extensions JW -# ---------------------------------------------------------- -sub init_graph { - my $self = shift; - - # Sets up the canvas and color palette - $self->SUPER::init_graph( @_ ); - - # Now create highlights and showdows for each color - # in the palette - if( $self->{'3d_shading'} ) { - $self->{'3d_highlights'} = []; - $self->{'3d_shadows'} = []; - $self->{'3d_highlights'}[$self->{bgci}] = $self->set_clr( $self->_brighten( _rgb($self->{bgclr}) ) ); - $self->{'3d_shadows'}[$self->{bgci}] = $self->set_clr( $self->_darken( _rgb($self->{bgclr}) ) ); - - $self->{'3d_highlights'}[$self->{fgci}] = $self->set_clr( $self->_brighten( _rgb($self->{fgclr}) ) ); - $self->{'3d_shadows'}[$self->{fgci}] = $self->set_clr( $self->_darken( _rgb($self->{fgclr}) ) ); - - $self->{'3d_highlights'}[$self->{tci}] = $self->set_clr( $self->_brighten( _rgb($self->{textclr}) ) ); - $self->{'3d_shadows'}[$self->{tci}] = $self->set_clr( $self->_darken( _rgb($self->{textclr}) ) ); - - $self->{'3d_highlights'}[$self->{lci}] = $self->set_clr( $self->_brighten( _rgb($self->{labelclr}) ) ); - $self->{'3d_shadows'}[$self->{lci}] = $self->set_clr( $self->_darken( _rgb($self->{labelclr}) ) ); - - $self->{'3d_highlights'}[$self->{alci}] = $self->set_clr( $self->_brighten( _rgb($self->{axislabelclr}) ) ); - $self->{'3d_shadows'}[$self->{alci}] = $self->set_clr( $self->_darken( _rgb($self->{axislabelclr}) ) ); - - $self->{'3d_highlights'}[$self->{acci}] = $self->set_clr( $self->_brighten( _rgb($self->{accentclr}) ) ); - $self->{'3d_shadows'}[$self->{acci}] = $self->set_clr( $self->_darken( _rgb($self->{accentclr}) ) ); - - $self->{'3d_highlights'}[$self->{valuesci}] = $self->set_clr( $self->_brighten( _rgb($self->{valuesclr}) ) ); - $self->{'3d_shadows'}[$self->{valuesci}] = $self->set_clr( $self->_darken( _rgb($self->{valuesclr}) ) ); - - $self->{'3d_highlights'}[$self->{legendci}] = $self->set_clr( $self->_brighten( _rgb($self->{legendclr}) ) ); - $self->{'3d_shadows'}[$self->{legendci}] = $self->set_clr( $self->_darken( _rgb($self->{legendclr}) ) ); - - if( $self->{boxclr} ) { - $self->{'3d_highlights'}[$self->{boxci}] = $self->set_clr( $self->_brighten( _rgb($self->{boxclr}) ) ); - $self->{'3d_shadows'}[$self->{boxci}] = $self->set_clr( $self->_darken( _rgb($self->{boxclr}) ) ); - } # end if - } # end if - - return $self; -} # end init_graph - - -# PRIVATE - -# ---------------------------------------------------------- -# Sub: _brighten -# -# Args: $r, $g, $b -# $r, $g, $b The Red, Green, and Blue components of a color -# -# Description: Brightens the color by adding white -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 21AUG2000 Created to build 3d highlights table JW -# ---------------------------------------------------------- -sub _brighten { - my $self = shift; - my( $r, $g, $b ) = @_; - my $p = ($r + $g + $b) / 70; - $p = 3 if $p < 3; - my $f = _max( $r / $p, _max( $g / $p, $b / $p ) ); - $r = _min( 255, int( $r + $f ) ); - $g = _min( 255, int( $g + $f ) ); - $b = _min( 255, int( $b + $f ) ); - return( $r, $g, $b ); -} # end _brighten - -# ---------------------------------------------------------- -# Sub: _darken -# -# Args: $r, $g, $b -# $r, $g, $b The Red, Green, and Blue components of a color -# -# Description: Darkens the color by adding black -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 21AUG2000 Created to build 3d shadows table JW -# ---------------------------------------------------------- -sub _darken { - my $self = shift; - my( $r, $g, $b ) = @_; - my $p = ($r + $g + $b) / 70; - $p = 3 if $p < 3; - my $f = _max( $r / $p, _max( $g / $p, $b / $p) ); - $r = _max( 0, int( $r - $f ) ); - $g = _max( 0, int( $g - $f ) ); - $b = _max( 0, int( $b - $f ) ); - return( $r, $g, $b ); -} # end _darken - - -# inherit check_data from GD::Graph - -# [JAW] Setup boundaries as parent, the adjust for 3d extrusion -sub _setup_boundaries -{ - my $self = shift; - - $self->SUPER::_setup_boundaries(); - - # adjust for top of 3-d extrusion - $self->{top} += $self->{depth_3d}; - - return $self->_set_error('Vertical size too small') - if $self->{bottom} <= $self->{top}; - - # adjust for right of 3-d extrusion - $self->{right} -= $self->{depth_3d}; - - return $self->_set_error('Horizontal size too small') - if $self->{right} <= $self->{left}; - - return $self; -} # end _setup_boundaries - -# [JAW] Determine 3d-extrusion depth, then call parent -sub setup_coords -{ - my $self = shift; - - # Calculate the 3d-depth of the graph - # Note this sets a minimum depth of ~20 pixels -# if (!defined $self->{x_tick_number}) { - my $depth = _max( $self->{bar_depth}, $self->{line_depth} ); - if( $self->{overwrite} == 1 ) { - $depth *= $self->{_data}->num_sets(); - } # end if - $self->{depth_3d} = _max( $depth, $self->{depth_3d} ); -# } # end if - - $self->SUPER::setup_coords(); - - return $self; -} # end setup_coords - -# Inherit create_y_labels -# Inherit get_x_axis_label_height -# Inherit create_x_labels -# inherit open_graph from GD::Graph -# Inherit draw_text - -# [JAW] Draws entire bounding cube for 3-d extrusion -sub draw_axes -{ - my $s = shift; - my $g = $s->{graph}; - - my ($l, $r, $b, $t) = - ( $s->{left}, $s->{right}, $s->{bottom}, $s->{top} ); - my $depth = $s->{depth_3d}; - - if ( $s->{box_axis} ) { - # -- Draw a bounding box - if( $s->{boxci} ) { - # -- Fill the box with color - # Back box - $g->filledRectangle($l+$depth+1, $t-$depth+1, $r+$depth-1, $b-$depth-1, $s->{boxci}); - - # Left side - my $poly = new GD::Polygon; - $poly->addPt( $l, $t ); - $poly->addPt( $l + $depth, $t - $depth ); - $poly->addPt( $l + $depth, $b - $depth ); - $poly->addPt( $l, $b ); - if( $s->{'3d_shading'} ) { - $g->filledPolygon( $poly, $s->{'3d_shadows'}[$s->{boxci}] ); - } else { - $g->filledPolygon( $poly, $s->{boxci} ); - } # end if - - # Bottom - $poly = new GD::Polygon; - $poly->addPt( $l, $b ); - $poly->addPt( $l + $depth, $b - $depth ); - $poly->addPt( $r + $depth, $b - $depth ); - $poly->addPt( $r, $b ); - if( $s->{'3d_shading'} ) { - $g->filledPolygon( $poly, $s->{'3d_highlights'}[$s->{boxci}] ); - } else { - $g->filledPolygon( $poly, $s->{boxci} ); - } # end if - } # end if - - # -- Draw the box frame - - # Back box - $g->rectangle($l+$depth, $t-$depth, $r+$depth, $b-$depth, $s->{fgci}); - - # Connecting frame - $g->line($l, $t, $l + $depth, $t - $depth, $s->{fgci}); - $g->line($r, $t, $r + $depth, $t - $depth, $s->{fgci}); - $g->line($l, $b, $l + $depth, $b - $depth, $s->{fgci}); - $g->line($r, $b, $r + $depth, $b - $depth, $s->{fgci}); - - # Front box - $g->rectangle($l, $t, $r, $b, $s->{fgci}); - - } else { - if( $s->{boxci} ) { - # -- Fill the background box with color - # Back box - $g->filledRectangle($l+$depth+1, $t-$depth+1, $r+$depth-1, $b-$depth-1, $s->{boxci}); - - # Left side - my $poly = new GD::Polygon; - $poly->addPt( $l, $t ); - $poly->addPt( $l + $depth, $t - $depth ); - $poly->addPt( $l + $depth, $b - $depth ); - $poly->addPt( $l, $b ); - if( $s->{'3d_shading'} ) { - $g->filledPolygon( $poly, $s->{'3d_shadows'}[$s->{boxci}] ); - } else { - $g->filledPolygon( $poly, $s->{boxci} ); - } # end if - - # Bottom - $poly = new GD::Polygon; - $poly->addPt( $l, $b ); - $poly->addPt( $l + $depth, $b - $depth ); - $poly->addPt( $r + $depth, $b - $depth ); - $poly->addPt( $r, $b ); - if( $s->{'3d_shading'} ) { - $g->filledPolygon( $poly, $s->{'3d_highlights'}[$s->{boxci}] ); - } else { - $g->filledPolygon( $poly, $s->{boxci} ); - } # end if - } # end if - # -- Draw the frame only for back & sides - - # Back box - $g->rectangle($l + $depth, $t - $depth, $r + $depth, $b - $depth, $s->{fgci}); - - # Y axis - my $poly = new GD::Polygon; - $poly->addPt( $l, $t ); - $poly->addPt( $l, $b ); - $poly->addPt( $l + $depth, $b - $depth ); - $poly->addPt( $l + $depth, $t - $depth ); - $g->polygon( $poly, $s->{fgci} ); - - # X axis - if( !$s->{zero_axis_only} ) { - $poly = new GD::Polygon; - $poly->addPt( $l, $b ); - $poly->addPt( $r, $b ); - $poly->addPt( $r + $depth, $b - $depth ); - $poly->addPt( $l + $depth, $b - $depth ); - $g->polygon( $poly, $s->{fgci} ); - } # end if - - # Second Y axis - if( $s->{two_axes} ){ - $poly = new GD::Polygon; - $poly->addPt( $r, $b ); - $poly->addPt( $r, $t ); - $poly->addPt( $r + $depth, $t - $depth ); - $poly->addPt( $r + $depth, $b - $depth ); - $g->polygon( $poly, $s->{fgci} ); - } # end if - } # end if - - # Zero axis - if ($s->{zero_axis} or $s->{zero_axis_only}) { - my ($x, $y) = $s->val_to_pixel(0, 0, 1); - my $poly = new GD::Polygon; - $poly->addPt( $l, $y ); - $poly->addPt( $r, $y ); - $poly->addPt( $r + $depth, $y - $depth ); - $poly->addPt( $l + $depth, $y - $depth); - $g->polygon( $poly, $s->{fgci} ); - } # end if - -} # end draw_axes - -# [JAW] Draws ticks and values for y axes in 3d extrusion -# Modified from MVERB source -sub draw_y_ticks -{ - my $self = shift; - - for my $t (0 .. $self->{y_tick_number}) - { - for my $a (1 .. ($self->{two_axes} + 1)) - { - my $value = $self->{y_values}[$a][$t]; - my $label = $self->{y_labels}[$a][$t]; - - my ($x, $y) = $self->val_to_pixel(0, $value, $a); - $x = ($a == 1) ? $self->{left} : $self->{right}; - - # CONTRIB Jeremy Wadsack - # Draw on the back of the extrusion - $x += $self->{depth_3d}; - $y -= $self->{depth_3d}; - - if ($self->{y_long_ticks}) - { - $self->{graph}->line( - $x, $y, - $x + $self->{right} - $self->{left}, $y, - $self->{fgci} - ) unless ($a-1); - # CONTRIB Jeremy Wadsack - # Draw conector ticks - $self->{graph}->line( $x - $self->{depth_3d}, - $y + $self->{depth_3d}, - $x, - $y, - $self->{fgci} - ) unless ($a-1); - } - else - { - $self->{graph}->line( - $x, $y, - $x + (3 - 2 * $a) * $self->{y_tick_length}, $y, - $self->{fgci} - ); - # CONTRIB Jeremy Wadsack - # Draw conector ticks - $self->{graph}->line( $x - $self->{depth_3d}, - $y + $self->{depth_3d}, - $x - $self->{depth_3d} + (3 - 2 * $a) * $self->{y_tick_length}, - $y + $self->{depth_3d} - (3 - 2 * $a) * $self->{y_tick_length}, - $self->{fgci} - ); - } - - next - if $t % ($self->{y_label_skip}) || ! $self->{y_plot_values}; - - $self->{gdta_y_axis}->set_text($label); - $self->{gdta_y_axis}->set_align('center', - $a == 1 ? 'right' : 'left'); - $x -= (3 - 2 * $a) * $self->{axis_space}; - - # CONTRIB Jeremy Wadsack - # Subtract 3-d extrusion width from left axis label - # (it was added for ticks) - $x -= (2 - $a) * $self->{depth_3d}; - - # CONTRIB Jeremy Wadsack - # Add 3-d extrusion height to label - # (it was subtracted for ticks) - $y += $self->{depth_3d}; - - $self->{gdta_y_axis}->draw($x, $y); - - } # end foreach - } # end foreach - - return $self; - -} # end draw_y_ticks - -# [JAW] Darws ticks and values for x axes wih 3d extrusion -# Modified from MVERB source -sub draw_x_ticks -{ - my $self = shift; - - for (my $i = 0; $i < $self->{_data}->num_points; $i++) - { - my ($x, $y) = $self->val_to_pixel($i + 1, 0, 1); - - $y = $self->{bottom} unless $self->{zero_axis_only}; - - # CONTRIB Damon Brodie for x_tick_offset - next if (!$self->{x_all_ticks} and - ($i - $self->{x_tick_offset}) % $self->{x_label_skip} and - $i != $self->{_data}->num_points - 1 - ); - - # CONTRIB Jeremy Wadsack - # Draw on the back of the extrusion - $x += $self->{depth_3d}; - $y -= $self->{depth_3d}; - - if ($self->{x_ticks}) - { - if ($self->{x_long_ticks}) - { - # CONTRIB Jeremy Wadsack - # Move up by 3d depth - $self->{graph}->line( $x, - $self->{bottom} - $self->{depth_3d}, - $x, - $self->{top} - $self->{depth_3d}, - $self->{fgci}); - # CONTRIB Jeremy Wadsack - # Draw conector ticks - $self->{graph}->line( $x - $self->{depth_3d}, - $y + $self->{depth_3d}, - $x, - $y, - $self->{fgci} - ); - } - else - { - $self->{graph}->line( $x, $y, $x, $y - $self->{x_tick_length}, $self->{fgci} ); - # CONTRIB Jeremy Wadsack - # Draw conector ticks - $self->{graph}->line( $x - $self->{depth_3d}, - $y + $self->{depth_3d}, - $x - $self->{depth_3d} + $self->{x_tick_length}, - $y + $self->{depth_3d} - $self->{x_tick_length}, - $self->{fgci} - ); - } - } - - # CONTRIB Damon Brodie for x_tick_offset - next if - ($i - $self->{x_tick_offset}) % ($self->{x_label_skip}) and - $i != $self->{_data}->num_points - 1; - - $self->{gdta_x_axis}->set_text($self->{_data}->get_x($i)); - - # CONTRIB Jeremy Wadsack - # Subtract 3-d extrusion width from left label - # Add 3-d extrusion height to left label - # (they were changed for ticks) - $x -= $self->{depth_3d}; - $y += $self->{depth_3d}; - - my $yt = $y + $self->{axis_space}; - - if ($self->{x_labels_vertical}) - { - $self->{gdta_x_axis}->set_align('center', 'right'); - $self->{gdta_x_axis}->draw($x, $yt, PI/2); - } - else - { - $self->{gdta_x_axis}->set_align('top', 'center'); - $self->{gdta_x_axis}->draw($x, $yt); - } - - } # end for - - return $self; - -} # end draw_x_ticks - - -# CONTRIB Scott Prahl -# Assume x array contains equally spaced x-values -# and generate an appropriate axis -# -#### -# 'True' numerical X axis addition -# From: Gary Deschaines -# -# These modification to draw_x_ticks_number pass x-tick values to the -# val_to_pixel subroutine instead of x-tick indices when ture[sic] numerical -# x-axis mode is detected. Also, x_tick_offset and x_label_skip are -# processed differently when true numerical x-axis mode is detected to -# allow labeled major x-tick marks and un-labeled minor x-tick marks. -# -# For example: -# -# x_tick_number => 14, -# x_ticks => 1, -# x_long_ticks => 1, -# x_tick_length => -4, -# x_min_value => 100, -# x_max_value => 800, -# x_tick_offset => 2, -# x_label_skip => 2, -# -# -# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ -# | | | | | | | | | | | | | -# 1 -| | | | | | | | | | | | | -# | | | | | | | | | | | | | -# 0 _|_________|____|____|____|____|____|____|____|____|____|____|_________| -# | | | | | | | | | | | -# 200 300 400 500 600 700 -#### -# [JAW] Added commented items for 3d rendering -# Based on MVERB source -sub draw_x_ticks_number -{ - my $self = shift; - - for my $i (0 .. $self->{x_tick_number}) - { - my ($value, $x, $y); - - if (defined($self->{x_min_value}) && defined($self->{x_max_value})) - { - next if ($i - $self->{x_tick_offset}) < 0; - next if ($i + $self->{x_tick_offset}) > $self->{x_tick_number}; - $value = $self->{x_values}[$i]; - ($x, $y) = $self->val_to_pixel($value, 0, 1); - } - else - { - $value = ($self->{_data}->num_points - 1) - * ($self->{x_values}[$i] - $self->{true_x_min}) - / ($self->{true_x_max} - $self->{true_x_min}); - ($x, $y) = $self->val_to_pixel($value + 1, 0, 1); - } - - $y = $self->{bottom} unless $self->{zero_axis_only}; - - # Draw on the back of the extrusion - $x += $self->{depth_3d}; - $y -= $self->{depth_3d}; - - if ($self->{x_ticks}) - { - if ($self->{x_long_ticks}) - { - # XXX This mod needs to be done everywhere ticks are - # drawn - if ( $self->{x_tick_length} >= 0 ) - { - # Move up by 3d depth - $self->{graph}->line( $x, - $self->{bottom} - $self->{depth_3d}, - $x, - $self->{top} - $self->{depth_3d}, - $self->{fgci}); - } - else - { - $self->{graph}->line( - $x, $self->{bottom} - $self->{x_tick_length}, - $x, $self->{top}, $self->{fgci}); - } - # CONTRIB Jeremy Wadsack - # Draw conector ticks - $self->{graph}->line( $x - $self->{depth_3d}, - $y + $self->{depth_3d}, - $x, - $y, - $self->{fgci} - ); - } - else - { - $self->{graph}->line($x, $y, - $x, $y - $self->{x_tick_length}, $self->{fgci} ); - # CONTRIB Jeremy Wadsack - # Draw conector ticks - $self->{graph}->line( $x - $self->{depth_3d}, - $y + $self->{depth_3d}, - $x, - $self->{depth_3d} + $self->{tick_length}, - $y, + $self->{depth_3d} - $self->{tick_length}, - $self->{fgci} - ); - } # end if -- x_long_ticks - } # end if -- x_ticks - - # If we have to skip labels, we'll do it here. - # Make sure to always draw the last one. - next if $i % $self->{x_label_skip} && $i != $self->{x_tick_number}; - - $self->{gdta_x_axis}->set_text($self->{x_labels}[$i]); - - # CONTRIB Jeremy Wadsack - # Subtract 3-d extrusion width from left label - # Add 3-d extrusion height to left label - # (they were changed for ticks) - $x -= $self->{depth_3d}; - $y += $self->{depth_3d}; - - if ($self->{x_labels_vertical}) - { - $self->{gdta_x_axis}->set_align('center', 'right'); - my $yt = $y + $self->{text_space}/2; - $self->{gdta_x_axis}->draw($x, $yt, PI/2); - } - else - { - $self->{gdta_x_axis}->set_align('top', 'center'); - my $yt = $y + $self->{text_space}/2; - $self->{gdta_x_axis}->draw($x, $yt); - } # end if - } # end for - - return $self; - -} # end draw_x_tick_number - -# Inherit draw_ticks -# Inherit draw_data -# Inherit draw_data_set -# Inherit set_max_min -# Inherit get_max_y -# Inherit get_min_y -# Inherit get_max_min_y_all -# Inherit _get_bottom -# Inherit val_to_pixel -# Inherit setup_legend - - -# [JW] Override draw_legend and reverse the drawing order -# if cumulate is enabled so legend matches data on chart -sub draw_legend -{ - my $self = shift; - - return unless defined $self->{legend}; - - my $xl = $self->{lg_xs} + $self->{legend_spacing}; - my $y = $self->{lg_ys} + $self->{legend_spacing} - 1; - - # If there's a frame, offset by the size and margin - $xl += $self->{legend_frame_margin} + $self->{legend_frame_size} if $self->{legend_frame_size}; - $y += $self->{legend_frame_margin} + $self->{legend_frame_size} if $self->{legend_frame_size}; - - my $i = 0; - my $row = 1; - my $x = $xl; # start position of current element - my @legends = @{$self->{legend}}; - my $i_step = 1; - - # If we are working in cumulate mode, then reverse the drawing order - if( $self->{cumulate} ) { - @legends = reverse @legends; - $i = scalar(@legends); - $i = $self->{_data}->num_sets if $self->{_data}->num_sets < $i; - $i++; - $i_step = -1; - } # end if - - foreach my $legend (@legends) - { - $i += $i_step; - - # Legend for Pie goes over first set, and all points - # Works in either direction - last if $i > $self->{_data}->num_sets; - last if $i < 1; - - my $xe = $x; # position within an element - - next unless defined($legend) && $legend ne ""; - - $self->draw_legend_marker($i, $xe, $y); - - $xe += $self->{legend_marker_width} + $self->{legend_spacing}; - my $ys = int($y + $self->{lg_el_height}/2 - $self->{lgfh}/2); - - $self->{gdta_legend}->set_text($legend); - $self->{gdta_legend}->draw($xe, $ys); - - $x += $self->{lg_el_width}; - - if (++$row > $self->{lg_cols}) - { - $row = 1; - $y += $self->{lg_el_height}; - $x = $xl; - } - } - - # If there's a frame, draw it now - if( $self->{legend_frame_size} ) { - $x = $self->{lg_xs} + $self->{legend_spacing}; - $y = $self->{lg_ys} + $self->{legend_spacing} - 1; - - for $i ( 0 .. $self->{legend_frame_size} - 1 ) { - $self->{graph}->rectangle( - $x + $i, - $y + $i, - $x + $self->{lg_x_size} + 2 * $self->{legend_frame_margin} - $i - 1, - $y + $self->{lg_y_size} + 2 * $self->{legend_frame_margin} - $i - 1, - $self->{acci}, - ); - } # end for - } # end if - -} - - - -# Inherit draw_legend_marker - -1; diff --git a/lib/GD/Graph/bars.pm b/lib/GD/Graph/bars.pm deleted file mode 100644 index 2650351..0000000 --- a/lib/GD/Graph/bars.pm +++ /dev/null @@ -1,372 +0,0 @@ -#========================================================================== -# Copyright (c) 1995-1998 Martien Verbruggen -#-------------------------------------------------------------------------- -# -# Name: -# GD::Graph::bars.pm -# -# $Id: bars.pm,v 1.25 2003/06/11 00:43:49 mgjv Exp $ -# -#========================================================================== - -package GD::Graph::bars; - -($GD::Graph::bars::VERSION) = '$Revision: 1.25 $' =~ /\s([\d.]+)/; - -use strict; - -use GD::Graph::axestype; -use GD::Graph::utils qw(:all); -use GD::Graph::colour qw(:colours); - -@GD::Graph::bars::ISA = qw(GD::Graph::axestype); - -use constant PI => 4 * atan2(1,1); - -sub initialise -{ - my $self = shift; - $self->SUPER::initialise(); - $self->set(correct_width => 1); -} - -sub draw_data -{ - my $self = shift; - - $self->SUPER::draw_data() or return; - - unless ($self->{no_axes}) - { - # redraw the 'zero' axis - if ($self->{rotate_chart}) - { - $self->{graph}->line( - $self->{zeropoint}, $self->{top}, - $self->{zeropoint}, $self->{bottom}, - $self->{fgci} ); - } - else - { - $self->{graph}->line( - $self->{left}, $self->{zeropoint}, - $self->{right}, $self->{zeropoint}, - $self->{fgci} ); - } - } - - return $self; -} - -sub _top_values -{ - my $self = shift; - my @topvalues; - - if ($self->{cumulate}) - { - my $data = $self->{_data}; - for my $i (0 .. $data->num_points - 1) - { - push @topvalues, $data->get_y_cumulative($data->num_sets, $i); - } - } - - return \@topvalues; -} - -# -# Draw the shadow -# -sub _draw_shadow -{ - my $self = shift; - my ($ds, $i, $value, $topvalues, $l, $t, $r, $b) = @_; - my $bsd = $self->{shadow_depth} or return; - my $bsci = $self->set_clr(_rgb($self->{shadowclr})); - - if ($self->{cumulate}) - { - return if $ds > 1; - $value = $topvalues->[$i]; - if ($self->{rotate_chart}) - { - $r = ($self->val_to_pixel($i + 1, $value, $ds))[0]; - } - else - { - $t = ($self->val_to_pixel($i + 1, $value, $ds))[1]; - } - } - - # XXX Clean this up - if ($value >= 0) - { - if ($self->{rotate_chart}) - { - $self->{graph}->filledRectangle( - $l, $t + $bsd, $r - $bsd, $b + $bsd, $bsci); - } - else - { - $self->{graph}->filledRectangle( - $l + $bsd, $t + $bsd, $r + $bsd, $b, $bsci); - } - } - else - { - if ($self->{rotate_chart}) - { - $self->{graph}->filledRectangle( - $l + $bsd, $t, $r + $bsd, $b, $bsci); - } - else - { - $self->{graph}->filledRectangle( - $l + $bsd, $b, $r + $bsd, $t + $bsd, $bsci); - } - } -} - -sub draw_data_set_h -{ - my $self = shift; - my $ds = shift; - - my $bar_s = $self->{bar_spacing}/2; - - # Pick a data colour - my $dsci = $self->set_clr($self->pick_data_clr($ds)); - # contrib "Bremford, Mike" <mike.bremford@gs.com> - my $brci = $self->set_clr($self->pick_border_clr($ds)); - - my @values = $self->{_data}->y_values($ds) or - return $self->_set_error("Impossible illegal data set: $ds", - $self->{_data}->error); - - my $topvalues = $self->_top_values; - - for my $i (0 .. $#values) - { - my $value = $values[$i]; - next unless defined $value; - - my $l = $self->_get_bottom($ds, $i); - $value = $self->{_data}->get_y_cumulative($ds, $i) - if ($self->{cumulate}); - - # CONTRIB Jeremy Wadsack - # - # cycle_clrs option sets the color based on the point, - # not the dataset. - $dsci = $self->set_clr($self->pick_data_clr($i + 1)) - if $self->{cycle_clrs}; - $brci = $self->set_clr($self->pick_data_clr($i + 1)) - if $self->{cycle_clrs} > 1; - - # get coordinates of right and center of bar - my ($r, $xp) = $self->val_to_pixel($i + 1, $value, $ds); - - # calculate top and bottom of bar - my ($t, $b); - - if (ref $self eq 'GD::Graph::mixed' || $self->{overwrite}) - { - $t = $xp - $self->{x_step}/2 + $bar_s + 1; - $b = $xp + $self->{x_step}/2 - $bar_s; - } - else - { - $t = $xp - - $self->{x_step}/2 - + ($ds - 1) * $self->{x_step}/$self->{_data}->num_sets - + $bar_s + 1; - $b = $xp - - $self->{x_step}/2 - + $ds * $self->{x_step}/$self->{_data}->num_sets - - $bar_s; - } - - # draw the bar - $self->_draw_shadow($ds, $i, $value, $topvalues, $l, $t, $r, $b); - if ($value >= 0) - { - # positive value - $self->{graph}->filledRectangle($l, $t, $r, $b, $dsci) - if defined $dsci; - $self->{graph}->rectangle($l, $t, $r, $b, $brci) - if defined $brci && $b - $t > $self->{accent_treshold}; - - $self->{_hotspots}->[$ds]->[$i] = ['rect', $t, $l, $r, $b] - } - else - { - # negative value - $self->{graph}->filledRectangle($r, $t, $l, $b, $dsci) - if defined $dsci; - $self->{graph}->rectangle($l, $t, $r, $b, $brci) - if defined $brci && $b - $t > $self->{accent_treshold}; - - $self->{_hotspots}->[$ds]->[$i] = ['rect', $t, $l, $b, $r] - } - } - - return $ds; -} - -sub draw_data_set_v -{ - my $self = shift; - my $ds = shift; - - my $bar_s = $self->{bar_spacing}/2; - - # Pick a data colour - my $dsci = $self->set_clr($self->pick_data_clr($ds)); - # contrib "Bremford, Mike" <mike.bremford@gs.com> - my $brci = $self->set_clr($self->pick_border_clr($ds)); - - my @values = $self->{_data}->y_values($ds) or - return $self->_set_error("Impossible illegal data set: $ds", - $self->{_data}->error); - - my $topvalues = $self->_top_values; - - for (my $i = 0; $i < @values; $i++) - { - my $value = $values[$i]; - next unless defined $value; - - my $bottom = $self->_get_bottom($ds, $i); - $value = $self->{_data}->get_y_cumulative($ds, $i) - if ($self->{cumulate}); - - # CONTRIB Jeremy Wadsack - # - # cycle_clrs option sets the color based on the point, - # not the dataset. - $dsci = $self->set_clr($self->pick_data_clr($i + 1)) - if $self->{cycle_clrs}; - $brci = $self->set_clr($self->pick_data_clr($i + 1)) - if $self->{cycle_clrs} > 1; - - # get coordinates of top and center of bar - my ($xp, $t) = $self->val_to_pixel($i + 1, $value, $ds); - - # calculate left and right of bar - my ($l, $r); - - if (ref $self eq 'GD::Graph::mixed' || $self->{overwrite}) - { - $l = $xp - $self->{x_step}/2 + $bar_s + 1; - $r = $xp + $self->{x_step}/2 - $bar_s; - } - else - { - $l = $xp - - $self->{x_step}/2 - + ($ds - 1) * $self->{x_step}/$self->{_data}->num_sets - + $bar_s + 1; - $r = $xp - - $self->{x_step}/2 - + $ds * $self->{x_step}/$self->{_data}->num_sets - - $bar_s; - } - - # draw the bar - $self->_draw_shadow($ds, $i, $value, $topvalues, $l, $t, $r, $bottom); - if ($value >= 0) - { - # positive value - $self->{graph}->filledRectangle($l, $t, $r, $bottom, $dsci) - if defined $dsci; - $self->{graph}->rectangle($l, $t, $r, $bottom, $brci) - if defined $brci && $r - $l > $self->{accent_treshold}; - - $self->{_hotspots}->[$ds]->[$i] = ['rect', $l, $t, $r, $bottom] - } - else - { - # negative value - $self->{graph}->filledRectangle($l, $bottom, $r, $t, $dsci) - if defined $dsci; - $self->{graph}->rectangle($l, $bottom, $r, $t, $brci) - if defined $brci && $r - $l > $self->{accent_treshold}; - - $self->{_hotspots}->[$ds]->[$i] = ['rect', $l, $bottom, $r, $t] - } - } - - return $ds; -} - -sub draw_data_set -{ - $_[0]->{rotate_chart} ? goto &draw_data_set_h : goto &draw_data_set_v; -} - -sub draw_values -{ - my $self = shift; - - return $self unless $self->{show_values}; - - my $text_angle = $self->{values_vertical} ? PI/2 : 0; - - for (my $dsn = 1; $dsn <= $self->{_data}->num_sets; $dsn++) - { - my @values = $self->{_data}->y_values($dsn) or - return $self->_set_error("Impossible illegal data set: $dsn", - $self->{_data}->error); - my @display = $self->{show_values}->y_values($dsn) or next; - - for (my $i = 0; $i < @values; $i++) - { - next unless defined $display[$i]; - - my $value = $display[$i]; - if (defined $self->{values_format}) - { - $value = ref $self->{values_format} eq 'CODE' ? - &{$self->{values_format}}($value) : - sprintf($self->{values_format}, $value); - } - - my ($xp, $yp); - if (defined($self->{x_min_value}) && defined($self->{x_max_value})) - { - ($xp, $yp) = $self->val_to_pixel( - $self->{_data}->get_x($i), $values[$i], $dsn); - } - else - { - ($xp, $yp) = $self->val_to_pixel($i+1, $values[$i], $dsn); - } - if ($self->{rotate_chart}) - { - $xp += $self->{values_space}; - unless ($self->{overwrite}) - { - $yp -= $self->{x_step}/2 - ($dsn - 0.5) - * $self->{x_step}/$self->{_data}->num_sets; - } - } - else - { - $yp -= $self->{values_space}; - unless ($self->{overwrite}) - { - $xp -= $self->{x_step}/2 - ($dsn - 0.5) - * $self->{x_step}/$self->{_data}->num_sets; - } - } - - $self->{gdta_values}->set_text($value); - $self->{gdta_values}->draw($xp, $yp, $text_angle); - } - } - - return $self -} - -"Just another true value"; diff --git a/lib/GD/Graph/bars3d.pm b/lib/GD/Graph/bars3d.pm deleted file mode 100644 index 5344976..0000000 --- a/lib/GD/Graph/bars3d.pm +++ /dev/null @@ -1,349 +0,0 @@ -#========================================================================== -# Module: GD::Graph::bars3d -# -# Copyright (C) 1999,2001 Wadsack-Allen. All Rights Reserved. -# -# Based on GD::Graph::bars.pm,v 1.16 2000/03/18 10:58:39 mgjv -# Copyright (c) 1995-1998 Martien Verbruggen -# -#-------------------------------------------------------------------------- -# Date Modification Author -# ------------------------------------------------------------------------- -# 1999SEP18 Created 3D bar chart class (this module) JAW -# 1999SEP19 Rewrote to include a single bar-drawing JAW -# function and process all bars in series -# 1999SEP19 Implemented support for overwrite 2 style JAW -# 1999SEP19 Fixed a bug in color cycler (colors were off by 1) JAW -# 2000JAN19 Converted to GD::Graph class JAW -# 2000MAR10 Fixed bug where bars ran off bottom of chart JAW -# 2000APR18 Modified to be compatible with GD::Graph 1.30 JAW -# 2000APR24 Fixed a lot of rendering bugs and added shading JAW -# 2000AUG21 Added 3d shading JAW -# 2000AUG24 Fixed shading on cycle_clrs option JAW -# 06Dec2002 Fixed on-bar rendering with bars.pm draw_values JW -#========================================================================== -package GD::Graph::bars3d; - -use strict; - -use GD::Graph::axestype3d; -use GD::Graph::bars; -use GD::Graph::utils qw(:all); -use GD::Graph::colour qw(:colours); - -@GD::Graph::bars3d::ISA = qw(GD::Graph::axestype3d); -$GD::Graph::bars3d::VERSION = '0.63'; - -use constant PI => 4 * atan2(1,1); - - -my %Defaults = ( - # Spacing between the bars - bar_spacing => 0, - - # The 3-d extrusion depth of the bars - bar_depth => 10, -); - -sub initialise -{ - my $self = shift; - - my $rc = $self->SUPER::initialise(); - $self->set(correct_width => 1); - - while( my($key, $val) = each %Defaults ) { - $self->{$key} = $val - } # end while - - return $rc; -} # end initialise - -sub set -{ - my $s = shift; - my %args = @_; - - $s->{_set_error} = 0; - - for (keys %args) - { - /^bar_depth$/ and do - { - $s->{bar_depth} = $args{$_}; - delete $args{$_}; - next; - }; - } - - return $s->SUPER::set(%args); -} - - -# CONTRIB Jeremy Wadsack -# This is a complete overhaul of the original GD::Graph::bars -# design, because all versions (overwrite = 0, 1, 2) -# require that the bars be drawn in a loop of point over sets -sub draw_data -{ - my $self = shift; - my $g = $self->{graph}; - - my $bar_s = _round($self->{bar_spacing}/2); - - my $zero = $self->{zeropoint}; - - my $i; - my @iterate = (0 .. $self->{_data}->num_points()); - for $i ($self->{rotate_chart} ? reverse(@iterate) : @iterate) { - my ($xp, $t); - my $overwrite = 0; - $overwrite = $self->{overwrite} if defined $self->{overwrite}; - - my $j; - my @iterate = (1 .. $self->{_data}->num_sets()); - for $j (($self->{rotate_chart} && $self->{cumulate} == 0) ? reverse(@iterate) : @iterate) { - my $value = $self->{_data}->get_y( $j, $i ); - next unless defined $value; - - my $bottom = $self->_get_bottom($j, $i); - $value = $self->{_data}->get_y_cumulative($j, $i) - if ($self->{cumulate}); - - # Pick a data colour, calc shading colors too, if requested - # cycle_clrs option sets the color based on the point, not the dataset. - my @rgb; - if( $self->{cycle_clrs} ) { - @rgb = $self->pick_data_clr( $i + 1 ); - } else { - @rgb = $self->pick_data_clr( $j ); - } # end if - my $dsci = $self->set_clr( @rgb ); - if( $self->{'3d_shading'} ) { - $self->{'3d_highlights'}[$dsci] = $self->set_clr( $self->_brighten( @rgb ) ); - $self->{'3d_shadows'}[$dsci] = $self->set_clr( $self->_darken( @rgb ) ); - } # end if - - # contrib "Bremford, Mike" <mike.bremford@gs.com> - my $brci; - if( $self->{cycle_clrs} > 1 ) { - $brci = $self->set_clr($self->pick_data_clr($i + 1)); - } else { - $brci = $self->set_clr($self->pick_border_clr($j)); - } # end if - - - # get coordinates of top and center of bar - ($xp, $t) = $self->val_to_pixel($i + 1, $value, $j); - - # calculate offsets of this bar - my $x_offset = 0; - my $y_offset = 0; - if( $overwrite == 1 ) { - $x_offset = $self->{bar_depth} * ($self->{_data}->num_sets() - $j); - $y_offset = $self->{bar_depth} * ($self->{_data}->num_sets() - $j); - } - $t -= $y_offset; - - - # calculate left and right of bar - my ($l, $r); - if ($self->{rotate_chart}) { - $l = $bottom; - ($r) = $self->val_to_pixel($i + 1, $value, $j); - } - - if( (ref $self eq 'GD::Graph::mixed') || ($overwrite >= 1) ) - { - if ($self->{rotate_chart}) { - $bottom = $t + $self->{x_step}/2 - $bar_s + $x_offset; - $t = $t - $self->{x_step}/2 + $bar_s + $x_offset; - } - else - { - $l = $xp - $self->{x_step}/2 + $bar_s + $x_offset; - $r = $xp + $self->{x_step}/2 - $bar_s + $x_offset; - } - } - else - { - if ($self->{rotate_chart}) { - warn "base is $t"; - $bottom = $t - $self->{x_step}/2 - + ($j) * $self->{x_step}/$self->{_data}->num_sets() - + $bar_s + $x_offset; - $t = $t - $self->{x_step}/2 - + ($j-1) * $self->{x_step}/$self->{_data}->num_sets() - - $bar_s + $x_offset; - warn "top bottom is ($t, $bottom)"; - } - else - { - $l = $xp - - $self->{x_step}/2 - + ($j - 1) * $self->{x_step}/$self->{_data}->num_sets() - + $bar_s + $x_offset; - $r = $xp - - $self->{x_step}/2 - + $j * $self->{x_step}/$self->{_data}->num_sets() - - $bar_s + $x_offset; - } - } - - if ($value >= 0) { - # draw the positive bar - $self->draw_bar( $g, $l, $t, $r, $bottom-$y_offset, $dsci, $brci, 0 ) - } else { - # draw the negative bar - $self->draw_bar( $g, $l, $bottom-$y_offset, $r, $t, $dsci, $brci, -1 ) - } # end if - - } # end for - } # end for - - - # redraw the 'zero' axis, front and right - if( $self->{zero_axis} ) { - $g->line( - $self->{left}, $self->{zeropoint}, - $self->{right}, $self->{zeropoint}, - $self->{fgci} ); - $g->line( - $self->{right}, $self->{zeropoint}, - $self->{right}+$self->{depth_3d}, $self->{zeropoint}-$self->{depth_3d}, - $self->{fgci} ); - } # end if - - # redraw the box face - if ( $self->{box_axis} ) { - # Axes box - $g->rectangle($self->{left}, $self->{top}, $self->{right}, $self->{bottom}, $self->{fgci}); - $g->line($self->{right}, $self->{top}, $self->{right} + $self->{depth_3d}, $self->{top} - $self->{depth_3d}, $self->{fgci}); - $g->line($self->{right}, $self->{bottom}, $self->{right} + $self->{depth_3d}, $self->{bottom} - $self->{depth_3d}, $self->{fgci}); - } # end if - - return $self; - -} # end draw_data - -# CONTRIB Jeremy Wadsack -# This function draws a bar at the given -# coordinates. This is called in all three -# overwrite modes. -sub draw_bar { - my $self = shift; - my $g = shift; - my( $l, $t, $r, $b, $dsci, $brci, $neg ) = @_; - - # get depth of the bar - my $depth = $self->{bar_depth}; - - # get the bar shadow depth and color - my $bsd = $self->{shadow_depth}; - my $bsci = $self->set_clr(_rgb($self->{shadowclr})); - - my( $xi ); - - # shadow - if( $bsd > 0 ) { - my $sb = $b - $depth; - my $st = $t - $depth + $bsd; - - if( $neg != 0 ) { - $st -= $bsd; - if( $self->{zero_axis_only} ) { - $sb += $bsd; - } else { - $sb = _min($b-$depth+$bsd, $self->{bottom}-$depth); - } # end if - } # end if - - # ** If this isn't the back bar, then no side shadow should be - # drawn or else the top should be lowered by - # ($bsd * dataset_num), it should be drawn on the back surface, - # and a shadow should be drawn behind the front bar if the - # bar is positive and the back is negative. - - $g->filledRectangle($l+$depth+$bsd, - $st, - $r+$depth+$bsd, - $sb, - $bsci); - - # Only draw bottom shadow if at the bottom and has bottom - # axis. Always draw top shadow - if( ($neg == 0) || ($sb >= $self->{bottom}-$depth) ) { - my $poly = new GD::Polygon; - $poly->addPt( $r, $b ); - $poly->addPt( $r+$bsd, $b ); - $poly->addPt( $r+$depth+$bsd, $b-$depth ); - $poly->addPt( $r+$depth, $b-$depth ); - $g->filledPolygon( $poly, $bsci ); - } # end if - - } # end if - - # side - my $poly = new GD::Polygon; - $poly->addPt( $r, $t ); - $poly->addPt( $r+$depth, $t-$depth ); - $poly->addPt( $r+$depth, $b-$depth ); - $poly->addPt( $r, $b ); - if( $self->{'3d_shading'} ) { - $g->filledPolygon( $poly, $self->{'3d_shadows'}[$dsci] ); - } else { - $g->filledPolygon( $poly, $dsci ); - } # end if - $g->polygon( $poly, $brci ); - - # top - # -- only draw negative tops if the bar starts at zero - if( ($neg == 0) || ($t <= $self->{zeropoint}) ) { - $poly = new GD::Polygon; - $poly->addPt( $l, $t ); - $poly->addPt( $l+$depth, $t-$depth ); - $poly->addPt( $r+$depth, $t-$depth ); - $poly->addPt( $r, $t ); - if( $self->{'3d_shading'} ) { - $g->filledPolygon( $poly, $self->{'3d_highlights'}[$dsci] ); - } else { - $g->filledPolygon( $poly, $dsci ); - } # end if - $g->polygon( $poly, $brci ); - } # end if - - # face - $g->filledRectangle( $l, $t, $r, $b, $dsci ); - $g->rectangle( $l, $t, $r, $b, $brci ); - -} # end draw_bar - -# [JAW] Overrides axestype's set_max_min. -# Go through the parent's process then adjust the baseline to 0 for bar graphs. -sub set_max_min { - my $self = shift; - - $self->SUPER::set_max_min( @_ ); - - # This code is taken from Martien's axestype.pm - for my $i (1..($self->{two_axes} ? 2 : 1)) { - # If at the same side of the zero axis - if( $self->{y_max}[$i] && $self->{y_min}[$i]/$self->{y_max}[$i] > 0 ) { - $self->{y_min}[$i] > 0 ? - $self->{y_min}[$i] = 0 : - $self->{y_max}[$i] = 0 ; - } # end if - } # end for - - return $self; -} # end set_max_min - - -# [JW] Just use the one in GD::Graph::bars -sub draw_values -{ - return &GD::Graph::bars::draw_values( @_ ); -} - - -1; diff --git a/lib/GD/Graph/colour.pm b/lib/GD/Graph/colour.pm deleted file mode 100644 index 8b25059..0000000 --- a/lib/GD/Graph/colour.pm +++ /dev/null @@ -1,371 +0,0 @@ -#========================================================================== -# Copyright (c) 1995-1998 Martien Verbruggen -#-------------------------------------------------------------------------- -# -# Name: -# GD::Graph::colour.pm -# -# Description: -# Package of colour manipulation routines, to be used -# with GD::Graph. -# -# $Id: colour.pm,v 1.10 2003/02/11 05:38:46 mgjv Exp $ -# -#========================================================================== - - -package GD::Graph::colour; - -($GD::Graph::colour::VERSION) = '$Revision: 1.10 $' =~ /\s([\d.]+)/; - -=head1 NAME - -GD::Graph::colour - Colour manipulation routines for use with GD::Graph - -=head1 SYNOPSIS - -use GD::Graph::colour qw(:colours :lists :files :convert); - -=head1 DESCRIPTION - -The B<GD::Graph::colour> package provides a few routines to work with -colours. The functionality of this package is mainly defined by what is -needed, now and historically, by the GD::Graph modules. - -=cut - -use vars qw( @EXPORT_OK %EXPORT_TAGS ); -use strict; -require Exporter; -use Carp; - -@GD::Graph::colour::ISA = qw( Exporter ); - -@EXPORT_OK = qw( - _rgb _luminance _hue add_colour - colour_list sorted_colour_list - read_rgb - hex2rgb rgb2hex -); -%EXPORT_TAGS = ( - colours => [qw( add_colour _rgb _luminance _hue )], - lists => [qw( colour_list sorted_colour_list )], - files => [qw( read_rgb )], - convert => [qw( hex2rgb rgb2hex )], -); - -my %RGB = ( - white => [0xFF,0xFF,0xFF], - lgray => [0xBF,0xBF,0xBF], - gray => [0x7F,0x7F,0x7F], - dgray => [0x3F,0x3F,0x3F], - black => [0x00,0x00,0x00], - lblue => [0x00,0x00,0xFF], - blue => [0x00,0x00,0xBF], - dblue => [0x00,0x00,0x7F], - gold => [0xFF,0xD7,0x00], - lyellow => [0xFF,0xFF,0x00], - yellow => [0xBF,0xBF,0x00], - dyellow => [0x7F,0x7F,0x00], - lgreen => [0x00,0xFF,0x00], - green => [0x00,0xBF,0x00], - dgreen => [0x00,0x7F,0x00], - lred => [0xFF,0x00,0x00], - red => [0xBF,0x00,0x00], - dred => [0x7F,0x00,0x00], - lpurple => [0xFF,0x00,0xFF], - purple => [0xBF,0x00,0xBF], - dpurple => [0x7F,0x00,0x7F], - lorange => [0xFF,0xB7,0x00], - orange => [0xFF,0x7F,0x00], - pink => [0xFF,0xB7,0xC1], - dpink => [0xFF,0x69,0xB4], - marine => [0x7F,0x7F,0xFF], - cyan => [0x00,0xFF,0xFF], - lbrown => [0xD2,0xB4,0x8C], - dbrown => [0xA5,0x2A,0x2A], -); - -=head1 FUNCTIONS - -=head2 colour_list( I<number of colours> ) - -Returns a list of I<number of colours> colour names known to the package. -Exported with the :lists tag. - -=cut - -sub colour_list -{ - my $n = ( $_[0] ) ? $_[0] : keys %RGB; - return (keys %RGB)[0 .. $n-1]; -} - -=head2 sorted_colour_list( I<number of colours> ) - -Returns a list of I<number of colours> colour names known to the package, -sorted by luminance or hue. -B<NB.> Right now it always sorts by luminance. Will add an option in a later -stage to decide sorting method at run time. -Exported with the :lists tag. - -=cut - -sub sorted_colour_list -{ - my $n = $_[0] ? $_[0] : keys %RGB; - return (sort by_luminance keys %RGB)[0 .. $n-1]; - # return (sort by_hue keys %rgb)[0..$n-1]; - - sub by_luminance { _luminance(@{$RGB{$b}}) <=> _luminance(@{$RGB{$a}}) } - sub by_hue { _hue(@{$RGB{$b}}) <=> _hue(@{$RGB{$a}}) } -} - -=head2 _rgb( I<colour name> ) - -Returns a list of the RGB values of I<colour name>. if the colour name -is a string of the form that is acceptable to the hex2rgb sub, then the -colour will be added to the list dynamically. -Exported with the :colours tag. - -=cut - -my %warned_clrs = (); - -# return the RGB values of the colour name -sub _rgb -{ - my $clr = shift or return; - - # Try adding the colour if it doesn't exist yet. It may be of a - # parseable form - add_colour($clr) unless exists $RGB{$clr}; - - my $rgb_ref = $RGB{$clr}; - if (!defined $rgb_ref) - { - $rgb_ref = $RGB{'black'}; - unless ($warned_clrs{$clr}) - { - $warned_clrs{$clr}++; - carp "Colour $clr is not defined, reverting to black"; - } - }; - - @{$rgb_ref}; -} - -=head2 _hue( I<R,G,B> ) - -Returns the hue of the colour with the specified RGB values. -Exported with the :colours tag. - -=head2 _luminance( I<R,G,B> ) - -Returns the luminance of the colour with the specified RGB values. -Exported with the :colours tag. - -=cut - -# return the luminance of the colour (RGB) -sub _luminance -{ - (0.212671 * $_[0] + 0.715160 * $_[1] + 0.072169 * $_[2])/0xFF -} - -# return the hue of the colour (RGB) -sub _hue -{ - ($_[0] + $_[1] + $_[2])/(3 * 0xFF) -} - -=head2 add_colour(colourname => [$r, $g, $b]) or -add_colour('#7fe310') - -Self-explanatory. -Exported with the :colours tag. - -=cut - -sub add_colour -{ - my $name = shift; - my $val = shift; - - if (!defined $val) - { - my @rgb = hex2rgb($name) or return; - $val = [@rgb]; - } - - if (ref $val && ref $val eq 'ARRAY') - { - $RGB{$name} = [@{$val}]; - return $name; - } - - return; -} - -=head2 rgb2hex($red, $green, $blue) - -=head2 hex2rgb('#7fe310') - -These functions translate a list of RGB values into a hexadecimal -string, as is commonly used in HTML and the Image::Magick API, and vice -versa. -Exported with the :convert tag. - -=cut - -# Color translation -sub rgb2hex -{ - return unless @_ == 3; - my $color = '#'; - foreach my $cc (@_) - { - $color .= sprintf("%02x", $cc); - } - return $color; -} - -sub hex2rgb -{ - my $clr = shift; - my @rgb = $clr =~ /^#([a-f0-9]{2})([a-f0-9]{2})([a-f0-9]{2})$/i; - return unless @rgb; - return map { hex $_ } @rgb; -} - -=head2 read_rgb( F<file name> ) - -Reads in colours from a rgb file as used by the X11 system. - -Doing something like: - - use GD::Graph::bars; - use GD::Graph::colour; - - GD::Graph::colour::read_rgb("rgb.txt") or die "cannot read colours"; - -Will allow you to use any colours defined in rgb.txt in your graph. -Exported with the :files tag. - -=cut - -# -# Read a rgb.txt file (X11) -# -# Expected format of the file: -# -# R G B colour name -# -# Fields can be separated by any number of whitespace -# Lines starting with an exclamation mark (!) are comment and -# will be ignored. -# -# returns number of colours read - -sub read_rgb($) # (filename) -{ - my $fn = shift; - my $n = 0; - my $line; - - open(RGB, $fn) or return 0; - - while (defined($line = <RGB>)) - { - next if ($line =~ /\s*!/); - chomp($line); - - # remove leading white space - $line =~ s/^\s+//; - - # get the colours - my ($r, $g, $b, $name) = split(/\s+/, $line, 4); - - # Ignore bad lines - next unless (defined $name); - - $RGB{$name} = [$r, $g, $b]; - $n++; - } - - close(RGB); - - return $n; -} - -sub version { $GD::Graph::colour::VERSION } - -sub dump_colours -{ - my $max = $_[0] ? $_[0] : keys %RGB; - my $n = 0; - - my $clr; - foreach $clr (sorted_colour_list($max)) - { - last if $n > $max; - print "colour: $clr, " . - "${$RGB{$clr}}[0], ${$RGB{$clr}}[1], ${$RGB{$clr}}[2]\n" - } -} - - -"Just another true value"; - -__END__ - -=head1 PREDEFINED COLOUR NAMES - -white, -lgray, -gray, -dgray, -black, -lblue, -blue, -dblue, -gold, -lyellow, -yellow, -dyellow, -lgreen, -green, -dgreen, -lred, -red, -dred, -lpurple, -purple, -dpurple, -lorange, -orange, -pink, -dpink, -marine, -cyan, -lbrown, -dbrown. - -=head1 AUTHOR - -Martien Verbruggen E<lt>mgjv@tradingpost.com.auE<gt> - -=head2 Copyright - -GIFgraph: Copyright (c) 1995-1999 Martien Verbruggen. -Chart::PNGgraph: Copyright (c) 1999 Steve Bonds. -GD::Graph: Copyright (c) 1999 Martien Verbruggen. - -All rights reserved. This package is free software; you can redistribute -it and/or modify it under the same terms as Perl itself. - -=head1 SEE ALSO - -L<GD::Graph>, -L<GD::Graph::FAQ> - diff --git a/lib/GD/Graph/cylinder.pm b/lib/GD/Graph/cylinder.pm deleted file mode 100644 index ba8ab86..0000000 --- a/lib/GD/Graph/cylinder.pm +++ /dev/null @@ -1,126 +0,0 @@ -# $File: //depot/RG/rg/lib/RG/lib/GD/Graph/cylinder.pm $ $Author: autrijus $
-# $Revision: #3 $ $Change: 370 $ $DateTime: 2002/07/17 20:38:38 $
-
-package GD::Graph::cylinder;
-
-use strict;
-
-use GD::Graph::axestype3d;
-use GD::Graph::utils qw(:all);
-use GD::Graph::colour qw(:colours);
-
-use base qw/GD::Graph::bars3d/;
-$GD::Graph::cylinder::VERSION = '0.63';
-
-my %Defaults = (
- # Spacing between the bars
- bar_spacing => 0,
-
- # The 3-d extrusion depth of the bars
- bar_depth => 10,
-);
-
-sub initialise
-{
- my $self = shift;
-
- my $rc = $self->SUPER::initialise();
- $self->set(correct_width => 1);
-
- while( my($key, $val) = each %Defaults ) {
- $self->{$key} = $val
- } # end while
-
- return $rc;
-} # end initialise
-
-sub draw_bar_h {
- my $self = shift;
- my $g = shift;
- my( $l, $t, $r, $b, $dsci, $brci, $neg ) = @_;
- my $fnord = $g->colorAllocate(0,0,0);
-
- my $depth = $self->{bar_depth};
-
- my ($lighter, $darker) = ($dsci, $dsci);
- if ($self->{'3d_shading'}) {
- $lighter = $self->{'3d_highlights'}[$dsci];
- $darker = $self->{'3d_shadows'}[$dsci];
- }
- $g->line($l+$depth, $t+1, $r+$depth, $t+1, $dsci);
- $g->line($l+$depth, $b, $r+$depth, $b, $dsci);
- $g->arc($r+$depth, ($t+$b)/2, $depth*2, ($b-$t), 270, 90, $dsci);
- $g->arc($l+$depth, ($t+$b)/2, $depth*2, ($b-$t), 90, 270, $dsci);
- # find border
- my $foo = $l+$depth;
- --$foo
- until $foo == $l || $g->getPixel($foo, $t+($b-$t)/5) == $dsci;
- my $bar = $foo+1;
- ++$bar
- until $bar == $foo || $g->getPixel($bar, $t+($b-$t)/5) == $dsci;
- $g->line($foo, $t+($b-$t)/5, $bar, $t+($b-$t)/5, $dsci);
- $g->line($foo, $b-($b-$t)/5, $bar, $b-($b-$t)/5, $dsci);
- $g->fillToBorder($l+$depth, ($t+$b)/2, $dsci, $dsci);
- $g->arc($l+$depth, ($b+$t)/2, $depth*2, ($b-$t), 90, 270, $dsci);
- if ($foo < $bar + 3) {
- $g->fillToBorder(($l+$r)/2+$depth, $t+($b-$t)/5-1, $dsci, $lighter)
- unless $g->getPixel(($l+$r)/2+$depth, $t+($b-$t)/5-1) == $dsci;
- $g->fillToBorder(($l+$r)/2+$depth, $b-($b-$t)/5+1, $dsci, $darker)
- unless $g->getPixel(($l+$r)/2+$depth, $b-($b-$t)/5+1) == $dsci;
- $g->fillToBorder(($l+$r)/2, ($t+$b)/2, $dsci, $dsci);
- }
- $g->arc($l+$depth, ($b+$t)/2, $depth*2, ($b-$t), 90, 270, $brci);
- $g->arc($r+$depth, ($b+$t)/2, $depth*2, ($b-$t), 0, 360, $brci);
- $g->line($l+$depth, $t+1, $r+$depth, $t+1, $brci);
- $g->line($l+$depth, $b, $r+$depth, $b, $brci);
- $g->fillToBorder($r+$depth, ($b+$t)/2, $brci, $dsci);
-}
-
-sub draw_bar {
- my $self = shift;
- return $self->draw_bar_h(@_) if $self->{rotate_chart};
- my $g = shift;
- my( $l, $t, $r, $b, $dsci, $brci, $neg ) = @_;
- my $fnord = $g->colorAllocate(0,0,0);
-
- my $depth = $self->{bar_depth};
-
- my ($lighter, $darker) = ($dsci, $dsci);
- if ($self->{'3d_shading'}) {
- $lighter = $self->{'3d_highlights'}[$dsci];
- $darker = $self->{'3d_shadows'}[$dsci];
- }
-
- $g->line($l+1, $t-$depth, $l+1, $b-$depth, $dsci);
- $g->line($r, $t-$depth, $r, $b-$depth, $dsci);
-
- $g->arc(($l+$r)/2, $t-$depth, ($r-$l), $depth*2, 180, 360, $dsci);
- $g->arc(($l+$r)/2, $b-$depth, ($r-$l), $depth*2, 0, 180, $dsci);
- # find border
- my $foo = $b-$depth+1;
- ++$foo
- until $foo == $b || $g->getPixel($l+($r-$l)/5,$foo) == $dsci;
- my $bar = $foo-1;
- --$bar
- until $bar == $foo || $g->getPixel($l+($r-$l)/5,$bar) == $dsci;
- $g->line($l+($r-$l)/5, $bar, $l+($r-$l)/5, $foo, $dsci);
- $g->line($r-($r-$l)/5, $bar, $r-($r-$l)/5, $foo, $dsci);
- $g->fillToBorder(($l+$r)/2, $t-$depth, $dsci, $dsci);
- $g->arc(($l+$r)/2, $b-$depth, ($r-$l), $depth*2, 0, 180, $dsci);
- if ($foo > $bar + 3) {
- $g->fillToBorder($l+($r-$l)/5-1, ($foo+$bar)/2, $dsci, $lighter)
- unless $g->getPixel($l+($r-$l)/5-1, ($foo+$bar)/2) == $dsci;
- $g->fillToBorder($r-($r-$l)/5+1, ($foo+$bar)/2, $dsci, $darker)
- unless $g->getPixel($r-($r-$l)/5+1, ($foo+$bar)/2) == $dsci;
- $g->fillToBorder(($l+$r)/2, ($t+$b)/2, $dsci, $dsci);
- }
- $g->arc(($l+$r)/2, $b-$depth, ($r-$l), $depth*2, 0, 180, $brci);
- $g->arc(($l+$r)/2, $t-$depth, ($r-$l), $depth*2, 0, 360, $brci);
- $g->line($l+1, $t-$depth, $l+1, $b-$depth, $brci);
- $g->line($r, $t-$depth, $r, $b-$depth, $brci);
- $g->fillToBorder(($l+$r)/2, $t-$depth, $brci, $dsci);
-}
-
-1;
-
-
diff --git a/lib/GD/Graph/cylinder3d.pm b/lib/GD/Graph/cylinder3d.pm deleted file mode 100644 index 7bc2490..0000000 --- a/lib/GD/Graph/cylinder3d.pm +++ /dev/null @@ -1,30 +0,0 @@ -############################################################
-#
-# Module: GD::Graph::cylinder3d
-#
-# Description:
-# This is merely a wrapper around GD::Graph::cylinder
-# to be used as an alias
-#
-# Created: 16 October 2002 by Jeremy Wadsack for Wadsack-Allen Digital Group
-# Copyright (C) 2002 Wadsack-Allen. All rights reserved.
-############################################################
-# Date Modification Author
-# ----------------------------------------------------------
-# #
-############################################################
-package GD::Graph::cylinder3d;
-
-use strict;
-use GD;
-use GD::Graph;
-use GD::Graph::cylinder;
-use Carp;
-
-@GD::Graph::cylinder3d::ISA = qw( GD::Graph::cylinder );
-$GD::Graph::cylinder3d::VERSION = '0.63';
-
-# Inherit everything from GD::Graph::cylinder
-
-
-1;
diff --git a/lib/GD/Graph/hbars.pm b/lib/GD/Graph/hbars.pm deleted file mode 100644 index e2268b5..0000000 --- a/lib/GD/Graph/hbars.pm +++ /dev/null @@ -1,71 +0,0 @@ -#========================================================================== -# Copyright (c) 1995-1998 Martien Verbruggen -#-------------------------------------------------------------------------- -# -# Name: -# GD::Graph::hbars.pm -# -# $Id: hbars.pm,v 1.3 2003/02/10 22:12:41 mgjv Exp $ -# -#========================================================================== - -package GD::Graph::hbars; - -($GD::Graph::hbars::VERSION) = '$Revision: 1.3 $' =~ /\s([.\d]+)/; - -use strict; - -use GD::Graph::bars; -use GD::Graph::utils qw(:all); -use GD::Graph::colour qw(:colours); - -@GD::Graph::hbars::ISA = qw(GD::Graph::bars); - -sub initialise -{ - my $self = shift; - $self->SUPER::initialise(); - $self->set(rotate_chart => 1); -} - -"Just another true value"; - -__END__ - -=head1 NAME - -GD::Graph::hbars - make bar graphs with horizontal bars - -=head1 SYNOPSIS - -use GD::Graph::hbars; - -=head1 DESCRIPTION - -This is a wrapper module which is completely identical to creating a -GD::Graph::bars object with the C<rotate_chart> attribute set to a true -value. - -=head1 SEE ALSO - -L<GD::Graph> - -=head1 AUTHOR - -Martien Verbruggen E<lt>mgjv@tradingpost.com.auE<gt> - -=head2 Copyright - -(c) Martien Verbruggen - -=head2 Acknowledgements - -The original author of most of the code needed to implement this was -brian d foy, who sent this module to me after I complained I didn't have -the time to implement horizontal bar charts. I took the code that lived -in here, and distributed it over axestype.pm and bars.pm, to allow for a -better integration all around. His code, in turn, was mainly based on an -earlier version of bars.pm and axestype.pm. - -=cut - diff --git a/lib/GD/Graph/lines.pm b/lib/GD/Graph/lines.pm deleted file mode 100644 index 2dac4dd..0000000 --- a/lib/GD/Graph/lines.pm +++ /dev/null @@ -1,182 +0,0 @@ -#========================================================================== -# Copyright (c) 1995-1998 Martien Verbruggen -#-------------------------------------------------------------------------- -# -# Name: -# GD::Graph::lines.pm -# -# $Id: lines.pm,v 1.15 2003/02/10 22:12:41 mgjv Exp $ -# -#========================================================================== - -package GD::Graph::lines; - -($GD::Graph::lines::VERSION) = '$Revision: 1.15 $' =~ /\s([\d.]+)/; - -use strict; - -use GD; -use GD::Graph::axestype; - -@GD::Graph::lines::ISA = qw( GD::Graph::axestype ); - -# PRIVATE - -sub draw_data_set -{ - my $self = shift; - my $ds = shift; - - my @values = $self->{_data}->y_values($ds) or - return $self->_set_error("Impossible illegal data set: $ds", - $self->{_data}->error); - - my $dsci = $self->set_clr($self->pick_data_clr($ds) ); - my $type = $self->pick_line_type($ds); - - my ($xb, $yb); - if (defined $values[0]) - { - if (defined($self->{x_min_value}) && defined($self->{x_max_value})) - { - ($xb, $yb) = - $self->val_to_pixel($self->{_data}->get_x(0), $values[0], $ds); - } - else - { - ($xb, $yb) = $self->val_to_pixel(1, $values[0], $ds); - } - } - - for (my $i = 0; $i < @values; $i++) - { - if (!defined $values[$i]) - { - ($xb, $yb) = () if $self->{skip_undef}; - next; - } - - my ($xe, $ye); - - if (defined($self->{x_min_value}) && defined($self->{x_max_value})) - { - ($xe, $ye) = $self->val_to_pixel( - $self->{_data}->get_x($i), $values[$i], $ds); - } - else - { - ($xe, $ye) = $self->val_to_pixel($i+1, $values[$i], $ds); - } - - if (defined $xb) - { - $self->draw_line($xb, $yb, $xe, $ye, $type, $dsci) - if defined $dsci; - $self->{_hotspots}->[$ds]->[$i] = - ['line', $xb, $yb, $xe, $ye, $self->{line_width}]; - } - ($xb, $yb) = ($xe, $ye); - } - - return $ds; -} - -sub pick_line_type -{ - my $self = shift; - my $num = shift; - - ref $self->{line_types} ? - $self->{line_types}[ $num % (1 + $#{$self->{line_types}}) - 1 ] : - $num % 4 ? $num % 4 : 4 -} - -sub draw_line # ($xs, $ys, $xe, $ye, $type, $colour_index) -{ - my $self = shift; - my ($xs, $ys, $xe, $ye, $type, $clr) = @_; - - my $lw = $self->{line_width}; - my $lts = $self->{line_type_scale}; - - my $style = gdStyled; - my @pattern = (); - - LINE: { - - ($type == 2) && do { - # dashed - - for (1 .. $lts) { push @pattern, $clr } - for (1 .. $lts) { push @pattern, gdTransparent } - - $self->{graph}->setStyle(@pattern); - - last LINE; - }; - - ($type == 3) && do { - # dotted, - - for (1 .. 2) { push @pattern, $clr } - for (1 .. 2) { push @pattern, gdTransparent } - - $self->{graph}->setStyle(@pattern); - - last LINE; - }; - - ($type == 4) && do { - # dashed and dotted - - for (1 .. $lts) { push @pattern, $clr } - for (1 .. 2) { push @pattern, gdTransparent } - for (1 .. 2) { push @pattern, $clr } - for (1 .. 2) { push @pattern, gdTransparent } - - $self->{graph}->setStyle(@pattern); - - last LINE; - }; - - # default: solid - $style = $clr; - } - - # Tried the line_width thing with setBrush, ugly results - # TODO: This loop probably should be around the datasets - # for nicer results - my $i; - for $i (1..$lw) - { - my $yslw = $ys + int($lw/2) - $i; - my $yelw = $ye + int($lw/2) - $i; - - # Need the setstyle to reset - $self->{graph}->setStyle(@pattern) if (@pattern); - $self->{graph}->line( $xs, $yslw, $xe, $yelw, $style ); - } -} - -sub draw_legend_marker # (data_set_number, x, y) -{ - my $self = shift; - my ($n, $x, $y) = @_; - - my $ci = $self->set_clr($self->pick_data_clr($n)); - return unless defined $ci; - my $type = $self->pick_line_type($n); - - $y += int($self->{lg_el_height}/2); - - # Joe Smith <jms@tardis.Tymnet.COM> - local($self->{line_width}) = 2; # Make these show up better - - $self->draw_line( - $x, $y, - $x + $self->{legend_marker_width}, $y, - $type, $ci - ); -} - -"Just another true value"; diff --git a/lib/GD/Graph/lines3d.pm b/lib/GD/Graph/lines3d.pm deleted file mode 100644 index dfd60c7..0000000 --- a/lib/GD/Graph/lines3d.pm +++ /dev/null @@ -1,522 +0,0 @@ -#========================================================================== -# Module: GD::Graph::lines3d -# -# Copyright (C) 1999,2001 Wadsack-Allen. All Rights Reserved. -# -# Based on GD::Graph::lines.pm,v 1.10 2000/04/15 mgjv -# Copyright (c) 1995-1998 Martien Verbruggen -# -#-------------------------------------------------------------------------- -# Date Modification Author -# ------------------------------------------------------------------------- -# 1999SEP18 Created 3D line chart class (this module) JAW -# 1999SEP19 Finished overwrite 1 style JAW -# 1999SEP19 Polygon'd linewidth rendering JAW -# 2000SEP19 Converted to a GD::Graph class JAW -# 2000APR18 Modified for compatibility with GD::Graph 1.30 JAW -# 2000APR24 Fixed a lot of rendering bugs JAW -# 2000AUG19 Changed render code so lines have consitent width JAW -# 2000AUG21 Added 3d shading JAW -# 2000AUG24 Fixed shading top/botttom vs. postive/negative slope JAW -# 2000SEP04 For single point "lines" made a short segment JAW -# 2000OCT09 Fixed bug in rendering of legend JAW -#========================================================================== -# TODO -# ** The new mitred corners don't work well at data anomlies. Like -# the set (0,0,1,0,0,0,1,0,1) Looks really wrong! -# * Write a draw_data_set that draws the line so they appear to pass -# through one another. This means drawing a border edge at each -# intersection of the data lines so the points of pass-through show. -# Probably want to draw all filled polygons, then run through the data -# again finding intersections of line segments and drawing those edges. -#========================================================================== -package GD::Graph::lines3d; - -use strict; - -use GD; -use GD::Graph::axestype3d; -use Data::Dumper; - -@GD::Graph::lines3d::ISA = qw( GD::Graph::axestype3d ); -$GD::Graph::lines3d::VERSION = '0.63'; - -my $PI = 4 * atan2(1, 1); - -my %Defaults = ( - # The depth of the line in their extrusion - - line_depth => 10, -); - -sub initialise() -{ - my $self = shift; - - my $rc = $self->SUPER::initialise(); - - while( my($key, $val) = each %Defaults ) { - $self->{$key} = $val - - # *** [JAW] - # Should we reset the depth_3d param based on the - # line_depth, numsets and overwrite parameters, here? - # - } # end while - - return $rc; - -} # end initialize - -sub set -{ - my $s = shift; - my %args = @_; - - $s->{_set_error} = 0; - - for (keys %args) - { - /^line_depth$/ and do - { - $s->{line_depth} = $args{$_}; - delete $args{$_}; - next; - }; - } - - return $s->SUPER::set(%args); -} # end set - -# PRIVATE - -# [JAW] Changed to draw_data intead of -# draw_data_set to allow better control -# of multiple set rendering -sub draw_data -{ - my $self = shift; - my $d = $self->{_data}; - my $g = $self->{graph}; - - $self->draw_data_overwrite( $g, $d ); - - # redraw the 'zero' axis, front and right - if( $self->{zero_axis} ) { - $g->line( - $self->{left}, $self->{zeropoint}, - $self->{right}, $self->{zeropoint}, - $self->{fgci} ); - $g->line( - $self->{right}, $self->{zeropoint}, - $self->{right} + $self->{depth_3d}, $self->{zeropoint} - $self->{depth_3d}, - $self->{fgci} ); - } # end if - - # redraw the box face - if ( $self->{box_axis} ) { - # Axes box - $g->rectangle($self->{left}, $self->{top}, $self->{right}, $self->{bottom}, $self->{fgci}); - $g->line($self->{right}, $self->{top}, $self->{right} + $self->{depth_3d}, $self->{top} - $self->{depth_3d}, $self->{fgci}); - $g->line($self->{right}, $self->{bottom}, $self->{right} + $self->{depth_3d}, $self->{bottom} - $self->{depth_3d}, $self->{fgci}); - } # end if - - return $self; - -} # end draw_data - -# Copied from MVERB source -sub pick_line_type -{ - my $self = shift; - my $num = shift; - - ref $self->{line_types} ? - $self->{line_types}[ $num % (1 + $#{$self->{line_types}}) - 1 ] : - $num % 4 ? $num % 4 : 4 -} - -# ---------------------------------------------------------- -# Sub: draw_data_overwrite -# -# Args: $gd -# $gd The GD object to draw on -# -# Description: Draws each line segment for each set. Runs -# over sets, then points so that the appearance is better. -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 19SEP1999 Added this for overwrite support. JW -# 20AUG2000 Changed structure to use points 'objects' JW -# ---------------------------------------------------------- -sub draw_data_overwrite { - my $self = shift; - my $g = shift; - my @points_cache; - - my $i; - for $i (0 .. $self->{_data}->num_points()) - { - my $j; - for $j (1 .. $self->{_data}->num_sets()) - { - my @values = $self->{_data}->y_values($j) or - return $self->_set_error( "Impossible illegal data set: $j", $self->{_data}->error ); - - if( $self->{_data}->num_points() == 1 && $i == 1 ) { - # Copy the first point to the "second" - $values[$i] = $values[0]; - } # end if - - next unless defined $values[$i]; - - # calculate offset of this line - # *** Should offset be the max of line_depth - # and depth_3d/numsets? [JAW] - # - my $offset = $self->{line_depth} * ($self->{_data}->num_sets() - $j); - - # Get the coordinates of the previous point, if this is the first - # point make a point object and start over (i.e. next;) - unless( $i ) { - my( $xb, $yb ); - if (defined($self->{x_min_value}) && defined($self->{x_max_value})) { - ($xb, $yb) = $self->val_to_pixel( $self->{_data}->get_x($i), $values[$i], $j ); - } else { - ($xb, $yb) = $self->val_to_pixel( $i + 1, $values[$i], $j ); - } # end if - $xb += $offset; - $yb -= $offset; - $points_cache[$i][$j] = { coords => [$xb, $yb] }; - next; - } # end unless - - # Pick a data colour, calc shading colors too, if requested - my( @rgb ) = $self->pick_data_clr( $j ); - my $dsci = $self->set_clr( @rgb ); - if( $self->{'3d_shading'} ) { - $self->{'3d_highlights'}[$dsci] = $self->set_clr( $self->_brighten( @rgb ) ); - $self->{'3d_shadows'}[$dsci] = $self->set_clr( $self->_darken( @rgb ) ); - } # end if - - # Get the type - my $type = $self->pick_line_type($j); - - # Get the coordinates of the this point - unless( ref $points_cache[$i][$j] ) { - my( $xe, $ye ); - if( defined($self->{x_min_value}) && defined($self->{x_max_value}) ) { - ( $xe, $ye ) = $self->val_to_pixel( $self->{_data}->get_x($i), $values[$i], $j ); - } else { - ( $xe, $ye ) = $self->val_to_pixel($i + 1, $values[$i], $j); - } # end if - $xe += $offset; - $ye -= $offset; - $points_cache[$i][$j] = { coords => [$xe, $ye] }; - } # end if - - # Find the coordinates of the next point - if( defined $values[$i + 1] ) { - my( $xe, $ye ); - if( defined($self->{x_min_value}) && defined($self->{x_max_value}) ) { - ( $xe, $ye ) = $self->val_to_pixel( $self->{_data}->get_x($i + 1), $values[$i + 1], $j ); - } else { - ( $xe, $ye ) = $self->val_to_pixel($i + 2, $values[$i + 1], $j); - } # end if - $xe += $offset; - $ye -= $offset; - $points_cache[$i + 1][$j] = { coords => [$xe, $ye] }; - } # end if - - if( $self->{_data}->num_points() == 1 && $i == 1 ) { - # Nudge the x coords back- and forwards - my $n = int(($self->{right} - $self->{left}) / 30); - $n = 2 if $n < 2; - $points_cache[$i][$j]{coords}[0] = $points_cache[$i - 1][$j]{coords}[0] + $n; - $points_cache[$i - 1][$j]{coords}[0] -= $n; - } # end if - - # Draw the line segment - $self->draw_line( $points_cache[$i - 1][$j], - $points_cache[$i][$j], - $points_cache[$i + 1][$j], - $type, - $dsci ); - - # Draw the end cap if last segment - if( $i >= $self->{_data}->num_points() - 1 ) { - my $poly = new GD::Polygon; - $poly->addPt( $points_cache[$i][$j]{face}[0], $points_cache[$i][$j]{face}[1] ); - $poly->addPt( $points_cache[$i][$j]{face}[2], $points_cache[$i][$j]{face}[3] ); - $poly->addPt( $points_cache[$i][$j]{face}[2] + $self->{line_depth}, $points_cache[$i][$j]{face}[3] - $self->{line_depth} ); - $poly->addPt( $points_cache[$i][$j]{face}[0] + $self->{line_depth}, $points_cache[$i][$j]{face}[1] - $self->{line_depth} ); - if( $self->{'3d_shading'} ) { - $g->filledPolygon( $poly, $self->{'3d_shadows'}[$dsci] ); - } else { - $g->filledPolygon( $poly, $dsci ); - } # end if - $g->polygon( $poly, $self->{fgci} ); - } # end if - - } # end for -- $self->{_data}->num_sets() - } # end for -- $self->{_data}->num_points() - -} # end sub draw_data_overwrite - -# ---------------------------------------------------------- -# Sub: draw_line -# -# Args: $prev, $this, $next, $type, $clr -# $prev A hash ref for the prev point's object -# $this A hash ref for this point's object -# $next A hash ref for the next point's object -# $type A predefined line type (2..4) = (dashed, dotted, dashed & dotted) -# $clr The color (colour) index to use for the fill -# -# Point "Object" has these properties: -# coords A 2 element array of the coordinates for the line -# (this should be filled in before calling) -# face An 4 element array of end points for the face -# polygon. This will be populated by this method. -# -# Description: Draws a line segment in 3d extrusion that -# connects the prev point the the this point. The next point -# is used to calculate the mitre at the joint. -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 18SEP1999 Modified MVERB source to work on data -# point, not data set for better rendering JAW -# 19SEP1999 Ploygon'd line rendering for better effect JAW -# 19AUG2000 Made line width perpendicular JAW -# 19AUG2000 Changed parameters to use %line_seg hash/obj JAW -# 20AUG2000 Mitred joints of line segments JAW -# ---------------------------------------------------------- -sub draw_line -{ - my $self = shift; - my( $prev, $this, $next, $type, $clr ) = @_; - my $xs = $prev->{coords}[0]; - my $ys = $prev->{coords}[1]; - my $xe = $this->{coords}[0]; - my $ye = $this->{coords}[1]; - - my $lw = $self->{line_width}; - my $lts = $self->{line_type_scale}; - - my $style = gdStyled; - my @pattern = (); - - LINE: { - - ($type == 2) && do { - # dashed - - for (1 .. $lts) { push @pattern, $clr } - for (1 .. $lts) { push @pattern, gdTransparent } - - $self->{graph}->setStyle(@pattern); - - last LINE; - }; - - ($type == 3) && do { - # dotted, - - for (1 .. 2) { push @pattern, $clr } - for (1 .. 2) { push @pattern, gdTransparent } - - $self->{graph}->setStyle(@pattern); - - last LINE; - }; - - ($type == 4) && do { - # dashed and dotted - - for (1 .. $lts) { push @pattern, $clr } - for (1 .. 2) { push @pattern, gdTransparent } - for (1 .. 2) { push @pattern, $clr } - for (1 .. 2) { push @pattern, gdTransparent } - - $self->{graph}->setStyle(@pattern); - - last LINE; - }; - - # default: solid - $style = $clr; - } - - # [JAW] Removed the dataset loop for better results. - - # Need the setstyle to reset - $self->{graph}->setStyle(@pattern) if (@pattern); - - # - # Find the x and y offsets for the edge of the front face - # Do this by adjusting them perpendicularly from the line - # half the line width in front and in back. - # - my( $lwyoff, $lwxoff ); - if( $xe == $xs ) { - $lwxoff = $lw / 2; - $lwyoff = 0; - } elsif( $ye == $ys ) { - $lwxoff = 0; - $lwyoff = $lw / 2; - } else { - my $ln = sqrt( ($ys-$ye)**2 + ($xe-$xs)**2 ); - $lwyoff = ($xe-$xs) / $ln * $lw / 2; - $lwxoff = ($ys-$ye) / $ln * $lw / 2; - } # end if - - # For first line, figure beginning point - unless( defined $prev->{face}[0] ) { - $prev->{face} = []; - $prev->{face}[0] = $xs - $lwxoff; - $prev->{face}[1] = $ys - $lwyoff; - $prev->{face}[2] = $xs + $lwxoff; - $prev->{face}[3] = $ys + $lwyoff; - } # end unless - - # Calc and store this point's face coords - unless( defined $this->{face}[0] ) { - $this->{face} = []; - $this->{face}[0] = $xe - $lwxoff; - $this->{face}[1] = $ye - $lwyoff; - $this->{face}[2] = $xe + $lwxoff; - $this->{face}[3] = $ye + $lwyoff; - } # end if - - # Now find next point and nudge these coords to mitre - if( ref $next->{coords} eq 'ARRAY' ) { - my( $lwyo2, $lwxo2 ); - my( $x2, $y2 ) = @{$next->{coords}}; - if( $x2 == $xe ) { - $lwxo2 = $lw / 2; - $lwyo2 = 0; - } elsif( $y2 == $ye ) { - $lwxo2 = 0; - $lwyo2 = $lw / 2; - } else { - my $ln2 = sqrt( ($ye-$y2)**2 + ($x2-$xe)**2 ); - $lwyo2 = ($x2-$xe) / $ln2 * $lw / 2; - $lwxo2 = ($ye-$y2) / $ln2 * $lw / 2; - } # end if - $next->{face} = []; - $next->{face}[0] = $x2 - $lwxo2; - $next->{face}[1] = $y2 - $lwyo2; - $next->{face}[2] = $x2 + $lwxo2; - $next->{face}[3] = $y2 + $lwyo2; - - # Now get the intersecting coordinates - my $mt = ($ye - $ys)/($xe - $xs); - my $mn = ($y2 - $ye)/($x2 - $xe); - my $bt = $this->{face}[1] - $this->{face}[0] * $mt; - my $bn = $next->{face}[1] - $next->{face}[0] * $mn; - if( $mt != $mn ) { - $this->{face}[0] = ($bn - $bt) / ($mt - $mn); - } # end if - $this->{face}[1] = $mt * $this->{face}[0] + $bt; - $bt = $this->{face}[3] - $this->{face}[2] * $mt; - $bn = $next->{face}[3] - $next->{face}[2] * $mn; - if( $mt != $mn ) { - $this->{face}[2] = ($bn - $bt) / ($mt - $mn); - } # end if - $this->{face}[3] = $mt * $this->{face}[2] + $bt; - } # end if - - - # Make the top/bottom polygon - my $poly = new GD::Polygon; - if( ($ys-$ye)/($xe-$xs) > 1 ) { - $poly->addPt( $prev->{face}[2], $prev->{face}[3] ); - $poly->addPt( $this->{face}[2], $this->{face}[3] ); - $poly->addPt( $this->{face}[2] + $self->{line_depth}, $this->{face}[3] - $self->{line_depth} ); - $poly->addPt( $prev->{face}[2] + $self->{line_depth}, $prev->{face}[3] - $self->{line_depth} ); - if( $self->{'3d_shading'} && $style == $clr ) { - if( ($ys-$ye)/($xe-$xs) > 0 ) { - $self->{graph}->filledPolygon( $poly, $self->{'3d_shadows'}[$clr] ); - } else { - $self->{graph}->filledPolygon( $poly, $self->{'3d_highlights'}[$clr] ); - } # end if - } else { - $self->{graph}->filledPolygon( $poly, $style ); - } # end if - } else { - $poly->addPt( $prev->{face}[0], $prev->{face}[1] ); - $poly->addPt( $this->{face}[0], $this->{face}[1] ); - $poly->addPt( $this->{face}[0] + $self->{line_depth}, $this->{face}[1] - $self->{line_depth} ); - $poly->addPt( $prev->{face}[0] + $self->{line_depth}, $prev->{face}[1] - $self->{line_depth} ); - if( $self->{'3d_shading'} && $style == $clr ) { - if( ($ys-$ye)/($xe-$xs) < 0 ) { - $self->{graph}->filledPolygon( $poly, $self->{'3d_shadows'}[$clr] ); - } else { - $self->{graph}->filledPolygon( $poly, $self->{'3d_highlights'}[$clr] ); - } # end if - } else { - $self->{graph}->filledPolygon( $poly, $style ); - } # end if - } # end if - $self->{graph}->polygon( $poly, $self->{fgci} ); - - # *** This paints dashed and dotted patterns on the faces of - # the polygons. They don't look very good though. Would it - # be better to extrude the style as well as the lines? - # Otherwise could also be improved by using gdTiled instead of - # gdStyled and making the tile a transform of the line style - # for each face. [JAW] - - # Make the face polygon - $poly = new GD::Polygon; - $poly->addPt( $prev->{face}[0], $prev->{face}[1] ); - $poly->addPt( $this->{face}[0], $this->{face}[1] ); - $poly->addPt( $this->{face}[2], $this->{face}[3] ); - $poly->addPt( $prev->{face}[2], $prev->{face}[3] ); - - $self->{graph}->filledPolygon( $poly, $style ); - $self->{graph}->polygon( $poly, $self->{fgci} ); - -} # end draw line - -# ---------------------------------------------------------- -# Sub: draw_legend_marker -# -# Args: $dsn, $x, $y -# $dsn The dataset number to draw the marker for -# $x The x position of the marker -# $y The y position of the marker -# -# Description: Draws the legend marker for the specified -# dataset number at the given coordinates -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2000OCT06 Fixed rendering bugs JW -# ---------------------------------------------------------- -sub draw_legend_marker -{ - my $self = shift; - my ($n, $x, $y) = @_; - - my $ci = $self->set_clr($self->pick_data_clr($n)); - my $type = $self->pick_line_type($n); - - $y += int($self->{lg_el_height}/2); - - # Joe Smith <jms@tardis.Tymnet.COM> - local($self->{line_width}) = 2; # Make these show up better - - $self->draw_line( - { coords => [$x, $y] }, - { coords => [$x + $self->{legend_marker_width}, $y] }, - undef, - $type, - $ci - ); - -} # end draw_legend_marker - -1; diff --git a/lib/GD/Graph/linespoints.pm b/lib/GD/Graph/linespoints.pm deleted file mode 100644 index d913e2c..0000000 --- a/lib/GD/Graph/linespoints.pm +++ /dev/null @@ -1,46 +0,0 @@ -#========================================================================== -# Copyright (c) 1995-1998 Martien Verbruggen -#-------------------------------------------------------------------------- -# -# Name: -# GD::Graph::linespoints.pm -# -# $Id: linespoints.pm,v 1.8 2003/02/10 22:12:41 mgjv Exp $ -# -#========================================================================== - -package GD::Graph::linespoints; - -($GD::Graph::linespoints::VERSION) = '$Revision: 1.8 $' =~ /\s([\d.]+)/; - -use strict; - -use GD::Graph::axestype; -use GD::Graph::lines; -use GD::Graph::points; - -# Even though multiple inheritance is not really a good idea, -# since lines and points have the same parent class, I will do it here, -# because I need the functionality of the markers and the line types - -@GD::Graph::linespoints::ISA = qw(GD::Graph::lines GD::Graph::points); - -# PRIVATE - -sub draw_data_set -{ - my $self = shift; - - $self->GD::Graph::points::draw_data_set(@_) or return; - $self->GD::Graph::lines::draw_data_set(@_); -} - -sub draw_legend_marker -{ - my $self = shift; - - $self->GD::Graph::points::draw_legend_marker(@_); - $self->GD::Graph::lines::draw_legend_marker(@_); -} - -"Just another true value"; diff --git a/lib/GD/Graph/mixed.pm b/lib/GD/Graph/mixed.pm deleted file mode 100644 index daf192f..0000000 --- a/lib/GD/Graph/mixed.pm +++ /dev/null @@ -1,99 +0,0 @@ -#========================================================================== -# Copyright (c) 1995-1998 Martien Verbruggen -#-------------------------------------------------------------------------- -# -# Name: -# GD::Graph::mixed.pm -# -# $Id: mixed.pm,v 1.12 2003/02/10 22:12:41 mgjv Exp $ -# -#========================================================================== - -package GD::Graph::mixed; - -($GD::Graph::mixed::VERSION) = '$Revision: 1.12 $' =~ /\s([\d.]+)/; - -use strict; - -use GD::Graph::axestype; -use GD::Graph::lines; -use GD::Graph::points; -use GD::Graph::linespoints; -use GD::Graph::bars; -use GD::Graph::area; -use Carp; - -# Even though multiple inheritance is not really a good idea, I will -# do it here, because I need the functionality of the markers and the -# line types We'll include axestype as the first one, to make sure -# that's where we look first for methods. - -@GD::Graph::mixed::ISA = qw( - GD::Graph::axestype - GD::Graph::bars - GD::Graph::lines - GD::Graph::points -); - -sub initialise -{ - my $self = shift; - $self->SUPER::initialise(); -} - -sub correct_width -{ - my $self = shift; - - return $self->{correct_width} if defined $self->{correct_width}; - - for my $type ($self->{default_type}, @{$self->{types}}) - { - return 1 if $type eq 'bars'; - } -} - -sub draw_data_set -{ - my $self = shift; - my $ds = $_[0]; - - my $rc; - - my $type = $self->{types}->[$ds-1] || $self->{default_type}; - - # Try to execute the draw_data_set function in the package - # specified by type - $rc = eval '$self->GD::Graph::'.$type.'::draw_data_set(@_)'; - - # If we fail, we try it in the package specified by the - # default_type, and warn the user - if ($@) - { - carp "Set $ds, unknown type $type, assuming $self->{default_type}"; - #carp "Error message: $@"; - - $rc = eval '$self->GD::Graph::'. - $self->{default_type}.'::draw_data_set(@_)'; - } - - # If even that fails, we bail out - croak "Set $ds: unknown default type $self->{default_type}" if $@; - - return $rc; -} - -sub draw_legend_marker -{ - my $self = shift; - my $ds = $_[0]; - - my $type = $self->{types}->[$ds-1] || $self->{default_type}; - - eval '$self->GD::Graph::'.$type.'::draw_legend_marker(@_)'; - - eval '$self->GD::Graph::'. - $self->{default_type}.'::draw_legend_marker(@_)' if $@; -} - -"Just another true value"; diff --git a/lib/GD/Graph/pie.pm b/lib/GD/Graph/pie.pm deleted file mode 100644 index a945ba0..0000000 --- a/lib/GD/Graph/pie.pm +++ /dev/null @@ -1,446 +0,0 @@ -#========================================================================== -# Copyright (c) 1995-1998 Martien Verbruggen -#-------------------------------------------------------------------------- -# -# Name: -# GD::Graph::pie.pm -# -# $Id: pie.pm,v 1.20 2003/02/10 22:12:41 mgjv Exp $ -# -#========================================================================== - -package GD::Graph::pie; - -($GD::Graph::pie::VERSION) = '$Revision: 1.20 $' =~ /\s([\d.]+)/; - -use strict; - -use constant PI => 4 * atan2(1,1); - -use GD; -use GD::Graph; -use GD::Graph::utils qw(:all); -use GD::Graph::colour qw(:colours :lists); -use GD::Text::Align; -use Carp; - -@GD::Graph::pie::ISA = qw( GD::Graph ); - -my $ANGLE_OFFSET = 90; - -my %Defaults = ( - - # Set the height of the pie. - # Because of the dependency of this on runtime information, this - # is being set in GD::Graph::pie::initialise - - # pie_height => _round(0.1*${'width'}), - pie_height => undef, - - # Do you want a 3D pie? - '3d' => 1, - - # The angle at which to start the first data set - # 0 is at the front/bottom - start_angle => 0, - - # Angle below which a label on a pie slice is suppressed. - suppress_angle => 0, # CONTRIB idea ryan <xomina@bitstream.net> - - # and some public attributes without defaults - label => undef, - - # This misnamed attribute is used for pie marker colours - axislabelclr => 'black', -); - -# PRIVATE -sub _has_default { - my $self = shift; - my $attr = shift || return; - exists $Defaults{$attr} || $self->SUPER::_has_default($attr); -} - -sub initialise -{ - my $self = shift; - $self->SUPER::initialise(); - while (my($key, $val) = each %Defaults) - { $self->{$key} = $val } - $self->set( pie_height => _round(0.1 * $self->{height}) ); - $self->set_value_font(gdTinyFont); - $self->set_label_font(gdSmallFont); -} - -# PUBLIC methods, documented in pod -sub plot -{ - my $self = shift; - my $data = shift; - - $self->check_data($data) or return; - $self->init_graph() or return; - $self->setup_text() or return; - $self->setup_coords() or return; - $self->draw_text() or return; - $self->draw_pie() or return; - $self->draw_data() or return; - - return $self->{graph}; -} - -sub set_label_font # (fontname) -{ - my $self = shift; - $self->_set_font('gdta_label', @_) or return; - $self->{gdta_label}->set_align('bottom', 'center'); -} - -sub set_value_font # (fontname) -{ - my $self = shift; - $self->_set_font('gdta_value', @_) or return; - $self->{gdta_value}->set_align('center', 'center'); -} - -# Inherit defaults() from GD::Graph - -# inherit checkdata from GD::Graph - -# Setup the coordinate system and colours, calculate the -# relative axis coordinates in respect to the canvas size. - -sub setup_coords() -{ - my $self = shift; - - # Make sure we're not reserving space we don't need. - $self->{'3d'} = 0 if $self->{pie_height} <= 0; - $self->set(pie_height => 0) unless $self->{'3d'}; - - my $tfh = $self->{title} ? $self->{gdta_title}->get('height') : 0; - my $lfh = $self->{label} ? $self->{gdta_label}->get('height') : 0; - - # Calculate the bounding box for the pie, and - # some width, height, and centre parameters - $self->{bottom} = - $self->{height} - $self->{pie_height} - $self->{b_margin} - - ( $lfh ? $lfh + $self->{text_space} : 0 ); - $self->{top} = - $self->{t_margin} + ( $tfh ? $tfh + $self->{text_space} : 0 ); - - return $self->_set_error('Vertical size too small') - if $self->{bottom} - $self->{top} <= 0; - - $self->{left} = $self->{l_margin}; - $self->{right} = $self->{width} - $self->{r_margin}; - - return $self->_set_error('Horizontal size too small') - if $self->{right} - $self->{left} <= 0; - - $self->{w} = $self->{right} - $self->{left}; - $self->{h} = $self->{bottom} - $self->{top}; - - $self->{xc} = ($self->{right} + $self->{left})/2; - $self->{yc} = ($self->{bottom} + $self->{top})/2; - - return $self; -} - -# inherit open_graph from GD::Graph - -# Setup the parameters for the text elements -sub setup_text -{ - my $self = shift; - - if ( $self->{title} ) - { - #print "'$s->{title}' at ($s->{xc},$s->{t_margin})\n"; - $self->{gdta_title}->set(colour => $self->{tci}); - $self->{gdta_title}->set_text($self->{title}); - } - - if ( $self->{label} ) - { - $self->{gdta_label}->set(colour => $self->{lci}); - $self->{gdta_label}->set_text($self->{label}); - } - - $self->{gdta_value}->set(colour => $self->{alci}); - - return $self; -} - -# Put the text on the canvas. -sub draw_text -{ - my $self = shift; - - $self->{gdta_title}->draw($self->{xc}, $self->{t_margin}) - if $self->{title}; - $self->{gdta_label}->draw($self->{xc}, $self->{height} - $self->{b_margin}) - if $self->{label}; - - return $self; -} - -# draw the pie, without the data slices -sub draw_pie -{ - my $self = shift; - - my $left = $self->{xc} - $self->{w}/2; - - $self->{graph}->arc( - $self->{xc}, $self->{yc}, - $self->{w}, $self->{h}, - 0, 360, $self->{acci} - ); - - $self->{graph}->arc( - $self->{xc}, $self->{yc} + $self->{pie_height}, - $self->{w}, $self->{h}, - 0, 180, $self->{acci} - ) if ( $self->{'3d'} ); - - $self->{graph}->line( - $left, $self->{yc}, - $left, $self->{yc} + $self->{pie_height}, - $self->{acci} - ); - - $self->{graph}->line( - $left + $self->{w}, $self->{yc}, - $left + $self->{w}, $self->{yc} + $self->{pie_height}, - $self->{acci} - ); - - return $self; -} - -# Draw the data slices - -sub draw_data -{ - my $self = shift; - - my $total = 0; - my @values = $self->{_data}->y_values(1); # for now, only one pie.. - for (@values) - { - $total += $_ - } - - return $self->_set_error("Pie data total is <= 0") - unless $total > 0; - - my $ac = $self->{acci}; # Accent colour - my $pb = $self->{start_angle}; - - for (my $i = 0; $i < @values; $i++) - { - # Set the data colour - my $dc = $self->set_clr_uniq($self->pick_data_clr($i + 1)); - - # Set the angles of the pie slice - # Angle 0 faces down, positive angles are clockwise - # from there. - # --- - # / \ - # | | - # \ | / - # --- - # 0 - # $pa/$pb include the start_angle (so if start_angle - # is 90, there will be no pa/pb < 90. - my $pa = $pb; - $pb += my $slice_angle = 360 * $values[$i]/$total; - - # Calculate the end points of the lines at the boundaries of - # the pie slice - my ($xe, $ye) = cartesian( - $self->{w}/2, $pa, - $self->{xc}, $self->{yc}, $self->{h}/$self->{w} - ); - - $self->{graph}->line($self->{xc}, $self->{yc}, $xe, $ye, $ac); - - # Draw the lines on the front of the pie - $self->{graph}->line($xe, $ye, $xe, $ye + $self->{pie_height}, $ac) - if in_front($pa) && $self->{'3d'}; - - # Make an estimate of a point in the middle of the pie slice - # And fill it - ($xe, $ye) = cartesian( - 3 * $self->{w}/8, ($pa+$pb)/2, - $self->{xc}, $self->{yc}, $self->{h}/$self->{w} - ); - - $self->{graph}->fillToBorder($xe, $ye, $ac, $dc); - - # If it's 3d, colour the front ones as well - # - # if one slice is very large (>180 deg) then we will need to - # fill it twice. sbonds. - # - # Independently noted and fixed by Jeremy Wadsack, in a slightly - # different way. - if ($self->{'3d'}) - { - foreach my $fill ($self->_get_pie_front_coords($pa, $pb)) - { - $self->{graph}->fillToBorder( - $fill->[0], $fill->[1] + $self->{pie_height}/2, - $ac, $dc); - } - } - } - - # CONTRIB Jeremy Wadsack - # - # Large text, sticking out over the pie edge, could cause 3D pies to - # fill improperly: Drawing the text for a given slice before the - # next slice was drawn and filled could make the slice boundary - # disappear, causing the fill colour to flow out. With this - # implementation, all the text is on top of the pie. - - $pb = $self->{start_angle}; - for (my $i = 0; $i < @values; $i++) - { - next unless $values[$i]; - - my $pa = $pb; - $pb += my $slice_angle = 360 * $values[$i]/$total; - - next if $slice_angle <= $self->{suppress_angle}; - - my ($xe, $ye) = - cartesian( - 3 * $self->{w}/8, ($pa+$pb)/2, - $self->{xc}, $self->{yc}, $self->{h}/$self->{w} - ); - - $self->put_slice_label($xe, $ye, $self->{_data}->get_x($i)); - } - - return $self; - -} #GD::Graph::pie::draw_data - -sub _get_pie_front_coords # (angle 1, angle 2) -{ - my $self = shift; - my $pa = level_angle(shift); - my $pb = level_angle(shift); - my @fills = (); - - if (in_front($pa)) - { - if (in_front($pb)) - { - # both in front - # don't do anything - # Ah, but if this wraps all the way around the back - # then both pieces of the front need to be filled. - # sbonds. - if ($pa > $pb ) - { - # This takes care of the left bit on the front - # Since we know exactly where we are, and in which - # direction this works, we can just get the coordinates - # for $pa. - my ($x, $y) = cartesian( - $self->{w}/2, $pa, - $self->{xc}, $self->{yc}, $self->{h}/$self->{w} - ); - - # and move one pixel to the left, but only if we don't - # fall out of the pie!. - push @fills, [$x - 1, $y] - if $x - 1 > $self->{xc} - $self->{w}/2; - - # Reset $pa to the right edge of the front arc, to do - # the right bit on the front. - $pa = level_angle(-$ANGLE_OFFSET); - } - } - else - { - # start in front, end in back - $pb = $ANGLE_OFFSET; - } - } - else - { - if (in_front($pb)) - { - # start in back, end in front - $pa = $ANGLE_OFFSET - 180; - } - else - { - # both in back - return; - } - } - - my ($x, $y) = cartesian( - $self->{w}/2, ($pa + $pb)/2, - $self->{xc}, $self->{yc}, $self->{h}/$self->{w} - ); - - push @fills, [$x, $y]; - - return @fills; -} - -# return true if this angle is on the front of the pie -# XXX UGLY! We need to leave a slight room for error because of rounding -# problems -sub in_front -{ - my $a = level_angle(shift); - return - $a > ($ANGLE_OFFSET - 180 + 0.00000001) && - $a < $ANGLE_OFFSET - 0.000000001; -} - -# XXX Ugh! I need to fix this. See the GD::Text module for better ways -# of doing this. -# return a value for angle between -180 and 180 -sub level_angle # (angle) -{ - my $a = shift; - return level_angle($a-360) if ( $a > 180 ); - return level_angle($a+360) if ( $a <= -180 ); - return $a; -} - -# put the slice label on the pie -sub put_slice_label -{ - my $self = shift; - my ($x, $y, $label) = @_; - - return unless defined $label; - - $self->{gdta_value}->set_text($label); - $self->{gdta_value}->draw($x, $y); -} - -# return x, y coordinates from input -# radius, angle, center x and y and a scaling factor (height/width) -# -# $ANGLE_OFFSET is used to define where 0 is meant to be -sub cartesian -{ - my ($r, $phi, $xi, $yi, $cr) = @_; - - return ( - $xi + $r * cos(PI * ($phi + $ANGLE_OFFSET)/180), - $yi + $cr * $r * sin(PI * ($phi + $ANGLE_OFFSET)/180) - ) -} - -"Just another true value"; diff --git a/lib/GD/Graph/pie3d.pm b/lib/GD/Graph/pie3d.pm deleted file mode 100644 index f1b0a76..0000000 --- a/lib/GD/Graph/pie3d.pm +++ /dev/null @@ -1,331 +0,0 @@ -############################################################ -# -# Module: GD::Graph::pie3d -# -# Description: -# This is merely a wrapper around GD::Graph::pie that forces -# the 3d option for pie charts. -# -# Created: 2000.Jan.19 by Jeremy Wadsack for Wadsack-Allen Digital Group -# Copyright (C) 2000,2001 Wadsack-Allen. All rights reserved. -############################################################ -# Date Modification Author -# ---------------------------------------------------------- -# 2000APR18 Modified to be compatible w/ GD::Graph 1.30 JW -# 2000APR24 Set default slice label color to black JW -# 2001Feb16 Added support for a legend JW -############################################################ -package GD::Graph::pie3d; - -use strict; -use GD; -use GD::Graph; -use GD::Graph::pie; -use GD::Graph::utils qw(:all); -use Carp; - -@GD::Graph::pie3d::ISA = qw( GD::Graph::pie ); -$GD::Graph::pie3d::VERSION = '0.63'; - -my %Defaults = ( - '3d' => 1, - axislabelclr => 'black', # values on slices. black because default colors use dblue - - # Size of the legend markers - legend_marker_height => 8, - legend_marker_width => 12, - legend_spacing => 4, - legend_placement => 'BC', # '[BR][LCR]' - lg_cols => undef, - legend_frame_margin => 4, - legend_frame_size => undef, -); - -# PRIVATE -# Have to include because this is a different %Defaults hash -sub _has_default { - my $self = shift; - my $attr = shift || return; - exists $Defaults{$attr} || $self->SUPER::_has_default($attr); -} - -sub initialise { - my $self = shift; - my $rc = $self->SUPER::initialise(); - - while( my($key, $val) = each %Defaults ) { - $self->{$key} = $val; - } # end while - - $self->set_legend_font(GD::gdTinyFont); - return $rc; -} # end initialise - -# Add lengend calc and draw code -sub plot -{ - my $self = shift; - my $data = shift; - - $self->check_data($data) or return; - $self->init_graph() or return; - $self->setup_text() or return; - $self->setup_legend(); - $self->setup_coords() or return; - $self->{b_margin} += 4 if $self->{label}; # Kludge for descenders - $self->draw_text() or return; - $self->draw_pie() or return; - $self->draw_data() or return; - $self->draw_legend(); - - return $self->{graph}; -} - -# Added legend stuff -sub setup_text -{ - my $self = shift; - - my $rc = $self->SUPER::setup_text( @_ ); - - $self->{gdta_legend}->set(colour => $self->{legendci}); - $self->{gdta_legend}->set_align('top', 'left'); - $self->{lgfh} = $self->{gdta_legend}->get('height'); - - return $rc -} # end setup_text - -# Inherit everything else from GD::Graph::pie - - -# Legend Support. Added 16.Feb.2001 - JW/WADG - -sub set_legend # List of legend keys -{ - my $self = shift; - $self->{legend} = [@_]; -} - -sub set_legend_font # (font name) -{ - my $self = shift; - $self->_set_font('gdta_legend', @_); -} - - - -# -# Legend -# -sub setup_legend -{ - my $self = shift; - - return unless defined $self->{legend}; - - my $maxlen = 0; - my $num = 0; - - # Save some variables - $self->{r_margin_abs} = $self->{r_margin}; - $self->{b_margin_abs} = $self->{b_margin}; - - foreach my $legend (@{$self->{legend}}) - { - if (defined($legend) and $legend ne "") - { - $self->{gdta_legend}->set_text($legend); - my $len = $self->{gdta_legend}->get('width'); - $maxlen = ($maxlen > $len) ? $maxlen : $len; - $num++; - } - # Legend for Pie goes over first set, and all points - last if $num >= $self->{_data}->num_points; - } - - $self->{lg_num} = $num; - - # calculate the height and width of each element - my $legend_height = _max($self->{lgfh}, $self->{legend_marker_height}); - - $self->{lg_el_width} = - $maxlen + $self->{legend_marker_width} + 3 * $self->{legend_spacing}; - $self->{lg_el_height} = $legend_height + 2 * $self->{legend_spacing}; - - my ($lg_pos, $lg_align) = split(//, $self->{legend_placement}); - - if ($lg_pos eq 'R') - { - # Always work in one column - $self->{lg_cols} = 1; - $self->{lg_rows} = $num; - - # Just for completeness, might use this in later versions - $self->{lg_x_size} = $self->{lg_cols} * $self->{lg_el_width}; - $self->{lg_y_size} = $self->{lg_rows} * $self->{lg_el_height}; - - # Adjust the right margin for the rest of the graph - $self->{r_margin} += $self->{lg_x_size}; - - # Adjust for frame if defined - if( $self->{legend_frame_size} ) { - $self->{r_margin} += 2 * ($self->{legend_frame_margin} + $self->{legend_frame_size}); - } # end if; - - # Set the x starting point - $self->{lg_xs} = $self->{width} - $self->{r_margin}; - - # Set the y starting point, depending on alignment - if ($lg_align eq 'T') - { - $self->{lg_ys} = $self->{t_margin}; - } - elsif ($lg_align eq 'B') - { - $self->{lg_ys} = $self->{height} - $self->{b_margin} - - $self->{lg_y_size}; - } - else # default 'C' - { - my $height = $self->{height} - $self->{t_margin} - - $self->{b_margin}; - - $self->{lg_ys} = - int($self->{t_margin} + $height/2 - $self->{lg_y_size}/2) ; - } - } - else # 'B' is the default - { - # What width can we use - my $width = $self->{width} - $self->{l_margin} - $self->{r_margin}; - - (!defined($self->{lg_cols})) and - $self->{lg_cols} = int($width/$self->{lg_el_width}); - - $self->{lg_cols} = _min($self->{lg_cols}, $num); - - $self->{lg_rows} = - int($num / $self->{lg_cols}) + (($num % $self->{lg_cols}) ? 1 : 0); - - $self->{lg_x_size} = $self->{lg_cols} * $self->{lg_el_width}; - $self->{lg_y_size} = $self->{lg_rows} * $self->{lg_el_height}; - - # Adjust the bottom margin for the rest of the graph - $self->{b_margin} += $self->{lg_y_size}; - # Adjust for frame if defined - if( $self->{legend_frame_size} ) { - $self->{b_margin} += 2 * ($self->{legend_frame_margin} + $self->{legend_frame_size}); - } # end if; - - # Set the y starting point - $self->{lg_ys} = $self->{height} - $self->{b_margin}; - - # Set the x starting point, depending on alignment - if ($lg_align eq 'R') - { - $self->{lg_xs} = $self->{width} - $self->{r_margin} - - $self->{lg_x_size}; - } - elsif ($lg_align eq 'L') - { - $self->{lg_xs} = $self->{l_margin}; - } - else # default 'C' - { - $self->{lg_xs} = - int($self->{l_margin} + $width/2 - $self->{lg_x_size}/2); - } - } -} - -sub draw_legend -{ - my $self = shift; - - return unless defined $self->{legend}; - - my $xl = $self->{lg_xs} + $self->{legend_spacing}; - my $y = $self->{lg_ys} + $self->{legend_spacing} - 1; - - # If there's a frame, offset by the size and margin - $xl += $self->{legend_frame_margin} + $self->{legend_frame_size} if $self->{legend_frame_size}; - $y += $self->{legend_frame_margin} + $self->{legend_frame_size} if $self->{legend_frame_size}; - - my $i = 0; - my $row = 1; - my $x = $xl; # start position of current element - - foreach my $legend (@{$self->{legend}}) - { - $i++; - # Legend for Pie goes over first set, and all points - last if $i > $self->{_data}->num_points; - - my $xe = $x; # position within an element - - next unless defined($legend) && $legend ne ""; - - $self->draw_legend_marker($i, $xe, $y); - - $xe += $self->{legend_marker_width} + $self->{legend_spacing}; - my $ys = int($y + $self->{lg_el_height}/2 - $self->{lgfh}/2); - - $self->{gdta_legend}->set_text($legend); - $self->{gdta_legend}->draw($xe, $ys); - - $x += $self->{lg_el_width}; - - if (++$row > $self->{lg_cols}) - { - $row = 1; - $y += $self->{lg_el_height}; - $x = $xl; - } - } - - # If there's a frame, draw it now - if( $self->{legend_frame_size} ) { - $x = $self->{lg_xs} + $self->{legend_spacing}; - $y = $self->{lg_ys} + $self->{legend_spacing} - 1; - - for $i ( 0 .. $self->{legend_frame_size} - 1 ) { - $self->{graph}->rectangle( - $x + $i, - $y + $i, - $x + $self->{lg_x_size} + 2 * $self->{legend_frame_margin} - $i - 1, - $y + $self->{lg_y_size} + 2 * $self->{legend_frame_margin} - $i - 1, - $self->{acci}, - ); - } # end for - } # end if - -} - -sub draw_legend_marker # data_set_number, x, y -{ - my $s = shift; - my $n = shift; - my $x = shift; - my $y = shift; - - my $g = $s->{graph}; - - my $ci = $s->set_clr($s->pick_data_clr($n)); - - $y += int($s->{lg_el_height}/2 - $s->{legend_marker_height}/2); - - $g->filledRectangle( - $x, $y, - $x + $s->{legend_marker_width}, $y + $s->{legend_marker_height}, - $ci - ); - - $g->rectangle( - $x, $y, - $x + $s->{legend_marker_width}, $y + $s->{legend_marker_height}, - $s->{acci} - ); -} - - -1; diff --git a/lib/GD/Graph/points.pm b/lib/GD/Graph/points.pm deleted file mode 100644 index 43b6825..0000000 --- a/lib/GD/Graph/points.pm +++ /dev/null @@ -1,183 +0,0 @@ -#========================================================================== -# Copyright (c) 1995-1998 Martien Verbruggen -#-------------------------------------------------------------------------- -# -# Name: -# GD::Graph::points.pm -# -# $Id: points.pm,v 1.13 2003/02/10 22:12:41 mgjv Exp $ -# -#========================================================================== - -package GD::Graph::points; - -($GD::Graph::points::VERSION) = '$Revision: 1.13 $' =~ /\s([\d.]+)/; - -use strict; - -use GD::Graph::axestype; -use GD::Graph::utils qw(:all); - -@GD::Graph::points::ISA = qw( GD::Graph::axestype ); - -# PRIVATE -sub draw_data_set -{ - my $self = shift; - my $ds = shift; - - my @values = $self->{_data}->y_values($ds) or - return $self->_set_error("Impossible illegal data set: $ds", - $self->{_data}->error); - - # Pick a colour - my $dsci = $self->set_clr($self->pick_data_clr($ds)); - my $type = $self->pick_marker($ds); - - for (my $i = 0; $i < @values; $i++) - { - next unless defined $values[$i]; - my ($xp, $yp); - if (defined($self->{x_min_value}) && defined($self->{x_max_value})) - { - ($xp, $yp) = $self->val_to_pixel( - $self->{_data}->get_x($i), $values[$i], $ds); - } - else - { - ($xp, $yp) = $self->val_to_pixel($i+1, $values[$i], $ds); - } - $self->marker($xp, $yp, $type, $dsci ); - $self->{_hotspots}->[$ds]->[$i] = - ['rect', $self->marker_coordinates($xp, $yp)]; - } - - return $ds; -} - -# Pick a marker type - -sub pick_marker # number -{ - my $self = shift; - my $num = shift; - - ref $self->{markers} ? - $self->{markers}[ $num % (1 + $#{$self->{markers}}) - 1 ] : - ($num % 8) || 8; -} - -# Draw a marker - -sub marker_coordinates -{ - my $self = shift; - my ($xp, $yp) = @_; - return ( - $xp - $self->{marker_size}, - $xp + $self->{marker_size}, - $yp + $self->{marker_size}, - $yp - $self->{marker_size}, - ); -} - -sub marker # $xp, $yp, $type, $colourindex -{ - my $self = shift; - my ($xp, $yp, $mtype, $mclr) = @_; - return unless defined $mclr; - - my ($l, $r, $b, $t) = $self->marker_coordinates($xp, $yp); - - MARKER: { - - ($mtype == 1) && do - { # Square, filled - $self->{graph}->filledRectangle($l, $t, $r, $b, $mclr); - last MARKER; - }; - ($mtype == 2) && do - { # Square, open - $self->{graph}->rectangle($l, $t, $r, $b, $mclr); - last MARKER; - }; - ($mtype == 3) && do - { # Cross, horizontal - $self->{graph}->line($l, $yp, $r, $yp, $mclr); - $self->{graph}->line($xp, $t, $xp, $b, $mclr); - last MARKER; - }; - ($mtype == 4) && do - { # Cross, diagonal - $self->{graph}->line($l, $b, $r, $t, $mclr); - $self->{graph}->line($l, $t, $r, $b, $mclr); - last MARKER; - }; - ($mtype == 5) && do - { # Diamond, filled - $self->{graph}->line($l, $yp, $xp, $t, $mclr); - $self->{graph}->line($xp, $t, $r, $yp, $mclr); - $self->{graph}->line($r, $yp, $xp, $b, $mclr); - $self->{graph}->line($xp, $b, $l, $yp, $mclr); - $self->{graph}->fillToBorder($xp, $yp, $mclr, $mclr); - last MARKER; - }; - ($mtype == 6) && do - { # Diamond, open - $self->{graph}->line($l, $yp, $xp, $t, $mclr); - $self->{graph}->line($xp, $t, $r, $yp, $mclr); - $self->{graph}->line($r, $yp, $xp, $b, $mclr); - $self->{graph}->line($xp, $b, $l, $yp, $mclr); - last MARKER; - }; - ($mtype == 7) && do - { # Circle, filled - $self->{graph}->arc($xp, $yp, 2 * $self->{marker_size}, - 2 * $self->{marker_size}, 0, 360, $mclr); - $self->{graph}->fillToBorder($xp, $yp, $mclr, $mclr); - last MARKER; - }; - ($mtype == 8) && do - { # Circle, open - $self->{graph}->arc($xp, $yp, 2 * $self->{marker_size}, - 2 * $self->{marker_size}, 0, 360, $mclr); - last MARKER; - }; - ($mtype == 9) && do - { # Horizontal line - $self->{graph}->line($l, $yp, $r, $yp, $mclr); - last MARKER; - }; - ($mtype == 10) && do - { # vertical line - $self->{graph}->line($xp, $t, $xp, $b, $mclr); - last MARKER; - }; - } -} - -sub draw_legend_marker -{ - my $self = shift; - my $n = shift; - my $x = shift; - my $y = shift; - - my $ci = $self->set_clr($self->pick_data_clr($n)); - - my $old_ms = $self->{marker_size}; - my $ms = _min($self->{legend_marker_height}, $self->{legend_marker_width}); - - ($self->{marker_size} > $ms/2) and $self->{marker_size} = $ms/2; - - $x += int($self->{legend_marker_width}/2); - $y += int($self->{lg_el_height}/2); - - $n = $self->pick_marker($n); - - $self->marker($x, $y, $n, $ci); - - $self->{marker_size} = $old_ms; -} - -"Just another true value"; diff --git a/lib/GD/Graph/utils.pm b/lib/GD/Graph/utils.pm deleted file mode 100644 index b24fc26..0000000 --- a/lib/GD/Graph/utils.pm +++ /dev/null @@ -1,49 +0,0 @@ -#========================================================================== -# Copyright (c) 1995-1999 Martien Verbruggen -#-------------------------------------------------------------------------- -# -# Name: -# GD::Graph::utils.pm -# -# Description: -# Package of general utilities. -# -# $Id: utils.pm,v 1.7 2003/02/10 22:12:41 mgjv Exp $ -# -#========================================================================== - -package GD::Graph::utils; - -($GD::Graph::utils::VERSION) = '$Revision: 1.7 $' =~ /\s([\d.]+)/; - -use strict; - -use vars qw( @EXPORT_OK %EXPORT_TAGS ); -require Exporter; - -@GD::Graph::utils::ISA = qw( Exporter ); - -@EXPORT_OK = qw(_max _min _round); -%EXPORT_TAGS = (all => [qw(_max _min _round)]); - -sub _max { - my ($a, $b) = @_; - return undef if (!defined($a) and !defined($b)); - return $a if (!defined($b)); - return $b if (!defined($a)); - ( $a >= $b ) ? $a : $b; -} - -sub _min { - my ($a, $b) = @_; - return undef if (!defined($a) and !defined($b)); - return $a if (!defined($b)); - return $b if (!defined($a)); - ( $a <= $b ) ? $a : $b; -} - -sub _round { sprintf "%.0f", shift } - -sub version { $GD::Graph::utils::VERSION } - -"Just another true value"; diff --git a/lib/GD/Graph3d.pm b/lib/GD/Graph3d.pm deleted file mode 100644 index 3795689..0000000 --- a/lib/GD/Graph3d.pm +++ /dev/null @@ -1,157 +0,0 @@ -#==========================================================================
-# Module: GD::Graph3d
-#
-# Copyright (C) 2000 Wadsack-Allen. All Rights Reserved.
-#
-#--------------------------------------------------------------------------
-# Date Modification Author
-# -------------------------------------------------------------------------
-# 08Nov2001 Re-sourced to use standard module files and structure.
-# The package is now GD-Graph3d which us what people expect JW
-#==========================================================================
-package GD::Graph3d;
-$GD::Graph3d::VERSION = '0.63';
-1;
-
-=head1 NAME
-
-GD::Graph3D - Create 3D Graphs with GD and GD::Graph
-
-=head1 SYNOPSIS
-
- use GD::Graph::moduleName;
- my @data = (
- ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"],
- [ 1203, 3500, 3973, 2859, 3012, 3423, 1230]
- );
- my $graph = new GD::Graph::moduleName( 400, 300 );
- $graph->set(
- x_label => 'Day of the week',
- y_label => 'Number of hits',
- title => 'Daily Summary of Web Site',
- );
- my $gd = $graph->plot( \@data );
-
-Where I<moduleName> is one of C<bars3d>, C<lines3d> or C<pie3d>.
-
-=head1 DESCRIPTION
-
-This is the GD::Graph3d extensions module. It provides 3D graphs for the
-GD::Graph module by Martien Verbruggen, which in turn generates graph
-using Lincoln Stein's GD.pm.
-
-You use these modules just as you would any of the GD::Graph modules, except
-that they generate 3d-looking graphs. Each graph type is described below
-with only the options that are unique to the 3d version. The modules are
-based on their 2d versions (e.g. GD::Graph::bars3d works like
-GD::Graph::bars), and support all the options in those. Make sure to read
-the documentation on GD::Graph.
-
-=over 4
-
-=item GD::Graph::pie3d
-
-This is merely a wrapper around GD::Graph::pie for consistency. It also
-sets 3d pie mode by default (which GD::Graph does as of version 1.22).
-All options are exactly as in GD::Graph::pie.
-
-=item GD::Graph::bars3d
-
-This works like GD::Graph::bars, but draws 3d bars. The following settings
-are new or changed in GD::Graph::bars3d.
-
-=over 4
-
-=item bar_depth
-
-Sets the z-direction depth of the bars. This defaults to 10. If you have a
-large number of bars or a small chart width, you may want to change this.
-A visually good value for this is approximately
-width_of_chart / number_of_bars.
-
-=item overwrite
-
-In GD::Graph::bars, multiple series of bars are normally drawn side-by-side.
-You can set overwrite to 1 to tell it to draw each series behind the
-previous one. By setting overwrite to 2 you can have them drawn on top of
-each other, that is the series are stacked.
-
-=item shading
-
-By default this is set to '1' and will shade and highlight the bars (and axes).
-The light source is at top-left-center which scan well for most computer
-users. You can disable the shading of bars and axes by specifying a false
-value for this option.
-
-=back
-
-=item GD::Graph::lines3d
-
-This works like GD::Graph::lines, but draws 3d line. The following settings
-are new or changed in GD::Graph::line3d.
-
-=over 4
-
-=item line_depth
-
-Sets the z-direction depth of the lines. This defaults to 10. If you have a
-large number of bars or a small chart width, you may want to change this.
-A visually good value for this is approximately
-width_of_chart / number_of_bars.
-
-=item shading
-
-By default this is set to '1' and will shade and highlight the line (and axes).
-The light source is at top-left-center which scan well for most computer
-users. You can disable the shading of lines and axes by specifiying a false
-value for this option.
-
-=back
-
-=back
-
-=head1 VERSION
-
-0.63 (6 December 2002)
-
-=head1 INSTALLATION
-
-You will need to have the GD::Graph version 1.30 or later installed. You should also
-have Perl version 5.005 or 5.6 installed.
-
-To install, just do the normal:
-
- perl Makefile.PL
- make
- make install
-
-The documentation is in GD::Graph::Graph3d.pod.
-
-=head1 AUTHOR
-
-Jeremy Wadsack for Wadsack-Allen Digital Group.
-<F<dgsupport at wadsack-allen dot com>>
-
-Most of the modules are based on the GD::Graph modules by Martien Verbruggen.
-
-=head1 LATEST RELEASE
-
-The latest release is available from CPAN: http://www.cpan.org/.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1999-2001 Wadsack-Allen. All rights reserved.
-
-Much of the original code is from GD::Graph:
-
-GIFgraph: Copyright (c) 1995-1999 Martien Verbruggen.
-
-Chart::PNGgraph: Copyright (c) 1999 Steve Bonds.
-
-GD::Graph: Copyright (c) 1999 Martien Verbruggen.
-
-This package is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=cut
-
diff --git a/lib/HTML/TextToHTML.pm b/lib/HTML/TextToHTML.pm deleted file mode 100644 index 82f3dc2..0000000 --- a/lib/HTML/TextToHTML.pm +++ /dev/null @@ -1,5266 +0,0 @@ -package HTML::TextToHTML; -use 5.006_001; -use strict; -#------------------------------------------------------------------------ - -=head1 NAME - -HTML::TextToHTML - convert plain text file to HTML. - -=head1 VERSION - -This describes version B<2.42> of HTML::TextToHTML. - -=cut - -our $VERSION = '2.42'; - -=head1 SYNOPSIS - - From the command line: - - txt2html I<arguments> - - From Scripts: - - use HTML::TextToHTML; - - # create a new object - my $conv = new HTML::TextToHTML(); - - # convert a file - $conv->txt2html(infile=>[$text_file], - outfile=>$html_file, - title=>"Wonderful Things", - mail=>1, - ]); - - # reset arguments - $conv->args(infile=>[], mail=>0); - - # convert a string - $newstring = $conv->process_chunk($mystring) - -=head1 DESCRIPTION - -HTML::TextToHTML converts plain text files to HTML. The txt2html script -uses this module to do the same from the command-line. - -It supports headings, tables, lists, simple character markup, and -hyperlinking, and is highly customizable. It recognizes some of the -apparent structure of the source document (mostly whitespace and -typographic layout), and attempts to mark that structure explicitly -using HTML. The purpose for this tool is to provide an easier way of -converting existing text documents to HTML format, giving something nicer -than just whapping the text into a big PRE block. - -=head2 History - -The original txt2html script was written by Seth Golub (see -http://www.aigeek.com/txt2html/), and converted to a perl module by -Kathryn Andersen (see http://www.katspace.com/tools/text_to_html/) and -made into a sourceforge project by Sun Tong (see -http://sourceforge.net/projects/txt2html/). Earlier versions of the -HTML::TextToHTML module called the included script texthyper so as not -to clash with the original txt2html script, but now the projects have -all been merged. - -=head1 REQUIRES - -HTML::TextToHTML requires Perl 5.6.1 or later. - -For installation, it needs: - - Module::Build - -The txt2html script needs: - - Getopt::Long - Getopt::ArgvFile - Pod::Usage - File::Basename - -For testing, it also needs: - - Test::More - -For debugging, it also needs: - - Data::Dumper - -=head1 INSTALLATION - -Make sure you have the dependencies installed first! -(see REQUIRES above) - -Some of those modules come standard with more recent versions of perl, -but I thought I'd mention them anyway, just in case you may not have -them. - -If you don't know how to install these, try using the CPAN module, an -easy way of auto-installing modules from the Comprehensive Perl Archive -Network, where the above modules reside. -Do "perldoc perlmodinstall" or "perldoc CPAN" for more information. - -To install this module type the following: - - perl Build.PL - ./Build - ./Build test - ./Build install - -Or, if you're on a platform (like DOS or Windows) that doesn't like the -"./" notation, you can do this: - - perl Build.PL - perl Build - perl Build test - perl Build install - -In order to install somewhere other than the default, such as -in a directory under your home directory, like "/home/fred/perl" -go - - perl Build.PL --install_base /home/fred/perl - -as the first step instead. - -This will install the files underneath /home/fred/perl. - -You will then need to make sure that you alter the PERL5LIB variable to -find the modules, and the PATH variable to find the script. - -Therefore you will need to change: -your path, to include /home/fred/perl/script (where the script will be) - - PATH=/home/fred/perl/script:${PATH} - -the PERL5LIB variable to add /home/fred/perl/lib - - PERL5LIB=/home/fred/perl/lib:${PERL5LIB} - -Note that the system links dictionary will be installed as -"/home/fred/perl/share/txt2html/txt2html.dict" - -If you want to install in a temporary install directory (such as -if you are building a package) then instead of going - - perl Build install - -go - - perl Build install destdir=/my/temp/dir - -and it will be installed there, with a directory structure under -/my/temp/dir the same as it would be if it were installed plain. -Note that this is NOT the same as setting --install_base, because -certain things are done at build-time which use the install_base info. - -See "perldoc perlrun" for more information on PERL5LIB, and -see "perldoc Module::Build" for more information on -installation options. - -=head1 OPTIONS - -All arguments can be set when the object is created, and further options -can be set when calling the actual txt2html method. Arguments -to methods can take either a hash of arguments, or a reference to an -array. Note that the reference-to-array method is depricated and is only -retained for backwards compatibility. - -Note that all option-names must match exactly -- no abbreviations are -allowed. - -The arguments get treated differently depending on whether they are -given in a hash or a reference to an array. When the arguments are -in a hash, the argument-keys are expected to have values matching -those required for that argument -- whether that be a boolean, a string, -a reference to an array or a reference to a hash. These will replace -any value for that argument that might have been there before. - -When the arguments are in a reference to an array, it is treated -somewhat as if it were a command-line: option names are expected to -start with '--' or '-', boolean options are set to true as soon as the -option is given (no value is expected to follow), boolean options with -the word "no" prepended set the option to false, string options are -expected to have a string value following, and those options which are -internally arrays or hashes are treated as cumulative; that is, the -value following the --option is added to the current set for that -option, to add more, one just repeats the --option with the next value, -and in order to reset that option to empty, the special value of "CLEAR" -must be added to the list. - -NOTE: the reference-to-an-array usage is DEPRECATED and will be removed -in the future. - -=over - -=item append_file - - append_file=>I<filename> - -If you want something appended by default, put the filename here. -The appended text will not be processed at all, so make sure it's -plain text or decent HTML. i.e. do not have things like: - Mary Andersen E<lt>kitty@example.comE<gt> -but instead, have: - Mary Andersen <kitty@example.com> - -(default: nothing) - -=item append_head - - append_head=>I<filename> - -If you want something appended to the head by default, put the filename here. -The appended text will not be processed at all, so make sure it's -plain text or decent HTML. i.e. do not have things like: - Mary Andersen E<lt>kitty@example.comE<gt> -but instead, have: - Mary Andersen <kitty@example.com> - -(default: nothing) - -=item body_deco - - body_deco=>I<string> - -Body decoration string: a string to be added to the BODY tag so that -one can set attributes to the BODY (such as class, style, bgcolor etc) -For example, "class='withimage'". - -=item bold_delimiter - - bold_delimiter=>I<string> - -This defines what character (or string) is taken to be the delimiter of -text which is to be interpreted as bold (that is, to be given a STRONG -tag). If this is empty, then no bolding of text will be done. -(default: #) - -=item bullets - - bullets=>I<string> - -This defines what single characters are taken to be "bullet" characters -for unordered lists. Note that because this is used as a character -class, if you use '-' it must come first. -(default:-=o*\267) - -=item bullets_ordered - - bullets_ordered=>I<string> - -This defines what single characters are taken to be "bullet" placeholder -characters for ordered lists. Ordered lists are normally marked by -a number or letter followed by '.' or ')' or ']' or ':'. If an ordered -bullet is used, then it simply indicates that this is an ordered list, -without giving explicit numbers. - -Note that because this is used as a character class, if you use '-' it -must come first. -(default:nothing) - -=item caps_tag - - caps_tag=>I<tag> - -Tag to put around all-caps lines -(default: STRONG) -If an empty tag is given, then no tag will be put around all-caps lines. - -=item custom_heading_regexp - - custom_heading_regexp=>I<regexp> - -Add a regexp for headings. Header levels are assigned by regexp -in order seen When a line matches a custom header regexp, it is tagged as -a header. If it's the first time that particular regexp has matched, -the next available header level is associated with it and applied to -the line. Any later matches of that regexp will use the same header level. -Therefore, if you want to match numbered header lines, you could use -something like this: - - -H '^ *\d+\. \w+' -H '^ *\d+\.\d+\. \w+' -H '^ *\d+\.\d+\.\d+\. \w+' - -Then lines like - - " 1. Examples " - " 1.1. Things" - and " 4.2.5. Cold Fusion" - -Would be marked as H1, H2, and H3 (assuming they were found in that -order, and that no other header styles were encountered). -If you prefer that the first one specified always be H1, the second -always be H2, the third H3, etc, then use the -EH/--explicit-headings -option. - -This is a multi-valued option. - -(default: none) - -=item debug - - debug=>1 - -Enable copious script debugging output (don't bother, this is for the -developer) (default: false) - -=item default_link_dict - - default_link_dict=>I<filename> - -The name of the default "user" link dictionary. -(default: "$ENV{'HOME'}/.txt2html.dict" -- this is the same as for -the txt2html script. If there is no $ENV{HOME} then it is just '.txt2html.dict') - -=item demoronize - - demoronize=>1 - -Convert Microsoft-generated character codes that are non-ISO codes into -something more reasonable. -(default:true) - -=item dict_debug - - dict_debug=>I<n> - -Debug mode for link dictionaries Bitwise-Or what you want to see: - 1: The parsing of the dictionary - 2: The code that will make the links - 4: When each rule matches something - 8: When each tag is created - -(default: 0) - -=item doctype - - doctype=>I<doctype> - -This gets put in the DOCTYPE field at the top of the document, unless it's -empty. (default : "-//W3C//DTD HTML 3.2 Final//EN") -If --xhtml is true, the contents of this is ignored, unless it's -empty, in which case no DOCTYPE declaration is output. - -=item eight_bit_clean - - eight_bit_clean=>1 - -disable Latin-1 character entity naming -(default: false) - -=item escape_HTML_chars - - escape_HTML_chars=>1 - -turn & E<lt> E<gt> into & > < -(default: true) - -=item explicit_headings - - explicit_headings=>1 - -Don't try to find any headings except the ones specified in the ---custom_heading_regexp option. -Also, the custom headings will not be assigned levels in the order they -are encountered in the document, but in the order they are specified on -the command line. -(default: false) - -=item extract - - extract=>1 - -Extract Mode; don't put HTML headers or footers on the result, just -the plain HTML (thus making the result suitable for inserting into -another document (or as part of the output of a CGI script). -(default: false) - -=item hrule_min - - hrule_min=>I<n> - -Min number of ---s for an HRule. -(default: 4) - -=item indent_width - - indent_width=>I<n> - -Indents this many spaces for each level of a list. -(default: 2) - -=item indent_par_break - - indent_par_break=>1 - -Treat paragraphs marked solely by indents as breaks with indents. -That is, instead of taking a three-space indent as a new paragraph, -put in a <BR> and three non-breaking spaces instead. -(see also --preserve_indent) -(default: false) - -=item infile - - infile=>\@my_files - infile=>['chapter1.txt', 'chapter2.txt'] - "--infile", "chapter1.txt", "--infile", "chapter2.txt" - -The name of the input file(s). When the arguments are given as a hash, -this expects a reference to an array of filenames. When the arguments -are given as a reference to an array, then the "--infile" option must -be repeated for each new file added to the list. If you want to reset -the list to be empty, give the special value of "CLEAR". - -The special filename '-' designates STDIN. - -See also L</inhandle> and L</instring>. - -(default:-) - -=item inhandle - - inhandle=>\@my_handles - inhandle=>[\*MYINHANDLE, \*STDIN] - -An array of input filehandles; use this instead of -L</infile> or L</instring> to use a filehandle or filehandles -as input. - -=item instring - - instring=>\@my_strings - instring=>[$string1, $string2] - -An array of input strings; use this instead of -L</infile> or L</inhandle> to use a string or strings -as input. - -=item italic_delimiter - - italic_delimiter=>I<string> - -This defines what character (or string) is taken to be the delimiter of -text which is to be interpreted as italic (that is, to be given a EM -tag). If this is empty, no italicising of text will be done. -(default: *) - -=item links_dictionaries - - links_dictionaries=>\@my_link_dicts - links_dictionaries=>['url_links.dict', 'format_links.dict'] - "--links_dictionaries", "url_links.dict", "--links_dictionaries", "format_links.dict" - -File(s) to use as a link-dictionary. There can be more than one of -these. These are in addition to the Global Link Dictionary and the User -Link Dictionary. When the arguments are given as a hash, this expects a -reference to an array of filenames. When the arguments are given as a -reference to an array, then the "--links_dictionaries" option must be -repeated for each new file added to the list. If you want to reset the -list to be empty, give the special value of "CLEAR". - -=item link_only - - link_only=>1 - -Do no escaping or marking up at all, except for processing the links -dictionary file and applying it. This is useful if you want to use -the linking feature on an HTML document. If the HTML is a -complete document (includes HTML,HEAD,BODY tags, etc) then you'll -probably want to use the --extract option also. -(default: false) - -=item lower_case_tags - - lower_case_tags=>1 - -Force all tags to be in lower-case. - -=item mailmode - - mailmode=>1 - -Deal with mail headers & quoted text. The mail header paragraph is -given the class 'mail_header', and mail-quoted text is given the class -'quote_mail'. -(default: false) - -=item make_anchors - - make_anchors=>0 - -Should we try to make anchors in headings? -(default: true) - -=item make_links - - make_links=>0 - -Should we try to build links? If this is false, then the links -dictionaries are not consulted and only structural text-to-HTML -conversion is done. (default: true) - -=item make_tables - - make_tables=>1 - -Should we try to build tables? If true, spots tables and marks them up -appropriately. See L</Input File Format> for information on how tables -should be formatted. - -This overrides the detection of lists; if something looks like a table, -it is taken as a table, and list-checking is not done for that -paragraph. - -(default: false) - -=item min_caps_length - - min_caps_length=>I<n> - -min sequential CAPS for an all-caps line -(default: 3) - -=item outfile - - outfile=>I<filename> - -The name of the output file. If it is "-" then the output goes -to Standard Output. -(default: - ) - -=item outhandle - -The output filehandle; if this is given then the output goes -to this filehandle instead of to the file given in L</outfile>. - -=item par_indent - - par_indent=>I<n> - -Minumum number of spaces indented in first lines of paragraphs. - Only used when there's no blank line -preceding the new paragraph. -(default: 2) - -=item preformat_trigger_lines - - preformat_trigger_lines=>I<n> - -How many lines of preformatted-looking text are needed to switch to <PRE> - <= 0 : Preformat entire document - 1 : one line triggers - >= 2 : two lines trigger - -(default: 2) - -=item endpreformat_trigger_lines - - endpreformat_trigger_lines=>I<n> - -How many lines of unpreformatted-looking text are needed to switch from <PRE> - <= 0 : Never preformat within document - 1 : one line triggers - >= 2 : two lines trigger -(default: 2) - -NOTE for preformat_trigger_lines and endpreformat_trigger_lines: -A zero takes precedence. If one is zero, the other is ignored. -If both are zero, entire document is preformatted. - -=item preformat_start_marker - - preformat_start_marker=>I<regexp> - -What flags the start of a preformatted section if --use_preformat_marker -is true. - -(default: "^(:?(:?<)|<)PRE(:?(:?>)|>)\$") - -=item preformat_end_marker - - preformat_end_marker=>I<regexp> - -What flags the end of a preformatted section if --use_preformat_marker -is true. - -(default: "^(:?(:?<)|<)/PRE(:?(:?>)|>)\$") - -=item preformat_whitespace_min - - preformat_whitespace_min=>I<n> - -Minimum number of consecutive whitespace characters to trigger -normal preformatting. -NOTE: Tabs are expanded to spaces before this check is made. -That means if B<tab_width> is 8 and this is 5, then one tab may be -expanded to 8 spaces, which is enough to trigger preformatting. -(default: 5) - -=item prepend_file - - prepend_file=>I<filename> - -If you want something prepended to the processed body text, put the -filename here. The prepended text will not be processed at all, so make -sure it's plain text or decent HTML. - -(default: nothing) - -=item preserve_indent - - preserve_indent=>1 - -Preserve the first-line indentation of paragraphs marked with indents -by replacing the spaces of the first line with non-breaking spaces. -(default: false) - -=item short_line_length - - short_line_length=>I<n> - -Lines this short (or shorter) must be intentionally broken and are kept -that short. -(default: 40) - -=item style_url - - style_url=>I<url> - -This gives the URL of a stylesheet; a LINK tag will be added to the -output. - -=item tab_width - - tab_width=>I<n> - -How many spaces equal a tab? -(default: 8) - -=item table_type - - table_type=>{ ALIGN=>0, PGSQL=>0, BORDER=>1, DELIM=>0 } - -This determines which types of tables will be recognised when "make_tables" -is true. The possible types are ALIGN, PGSQL, BORDER and DELIM. -(default: all types are true) - -=item title - - title=>I<title> - -You can specify a title. Otherwise it will use a blank one. -(default: nothing) - -=item titlefirst - - titlefirst=>1 - -Use the first non-blank line as the title. - -=item underline_length_tolerance - - underline_length_tolerance=>I<n> - -How much longer or shorter can underlines be and still be underlines? -(default: 1) - -=item underline_offset_tolerance - - underline_offset_tolerance=>I<n> - -How far offset can underlines be and still be underlines? -(default: 1) - -=item unhyphenation - - unhyphenation=>0 - -Enables unhyphenation of text. -(default: true) - -=item use_mosaic_header - - use_mosaic_header=>1 - -Use this option if you want to force the heading styles to match what Mosaic -outputs. (Underlined with "***"s is H1, -with "==="s is H2, with "+++" is H3, with "---" is H4, with "~~~" is H5 -and with "..." is H6) -This was the behavior of txt2html up to version 1.10. -(default: false) - -=item use_preformat_marker - - use_preformat_marker=>1 - -Turn on preformatting when encountering "<PRE>" on a line by itself, and turn -it off when there's a line containing only "</PRE>". -When such preformatted text is detected, the PRE tag will be given the -class 'quote_explicit'. -(default: off) - -=item xhtml - - xhtml=>1 - -Try to make the output conform to the XHTML standard, including -closing all open tags and marking empty tags correctly. This -turns on --lower_case_tags and overrides the --doctype option. -Note that if you add a header or a footer file, it is up to you -to make it conform; the header/footer isn't touched by this. -Likewise, if you make link-dictionary entries that break XHTML, -then this won't fix them, except to the degree of putting all tags -into lower-case. - -=back - -=head1 METHODS - -=cut - -#------------------------------------------------------------------------ - -require Exporter; -use Data::Dumper; - -our $PROG = 'HTML::TextToHTML'; - -#------------------------------------------------------------------------ -use constant TEXT_TO_HTML => "TEXT_TO_HTML"; - -######################################## -# Definitions (Don't change these) -# - -# These are just constants I use for making bit vectors to keep track -# of what modes I'm in and what actions I've taken on the current and -# previous lines. - -our $NONE = 0; -our $LIST = 1; -our $HRULE = 2; -our $PAR = 4; -our $PRE = 8; -our $END = 16; -our $BREAK = 32; -our $HEADER = 64; -our $MAILHEADER = 128; -our $MAILQUOTE = 256; -our $CAPS = 512; -our $LINK = 1024; -our $PRE_EXPLICIT = 2048; -our $TABLE = 4096; -our $IND_BREAK = 8192; -our $LIST_START = 16384; -our $LIST_ITEM = 32768; - -# Constants for Link-processing -# bit-vectors for what to do with a particular link-dictionary entry -our $LINK_NOCASE = 1; -our $LINK_EVAL = 2; -our $LINK_HTML = 4; -our $LINK_ONCE = 8; -our $LINK_SECT_ONCE = 16; - -# Constants for Ordered Lists and Unordered Lists. -# And Definition Lists. -# I use this in the list stack to keep track of what's what. - -our $OL = 1; -our $UL = 2; -our $DL = 3; - -# Constants for table types -our $TAB_ALIGN = 1; -our $TAB_PGSQL = 2; -our $TAB_BORDER = 3; -our $TAB_DELIM = 4; - -# Character entity names -# characters to replace with entities -our %char_entities = ( - "\241", "¡", "\242", "¢", "\243", "£", - "\244", "¤", "\245", "¥", "\246", "¦", - "\247", "§", "\250", "¨", "\251", "©", - "\252", "ª", "\253", "«", "\254", "¬", - "\255", "­", "\256", "®", "\257", "&hibar;", - "\260", "°", "\261", "±", "\262", "²", - "\263", "³", "\264", "´", "\265", "µ", - "\266", "¶", "\270", "¸", "\271", "¹", - "\272", "º", "\273", "»", "\274", "¼", - "\275", "½", "\276", "¾", "\277", "¿", - "\300", "À", "\301", "Á", "\302", "Â", - "\303", "Ã", "\304", "Ä", "\305", "Å", - "\306", "Æ", "\307", "Ç", "\310", "È", - "\311", "É", "\312", "Ê", "\313", "Ë", - "\314", "Ì", "\315", "Í", "\316", "Î", - "\317", "Ï", "\320", "Ð", "\321", "Ñ", - "\322", "Ò", "\323", "Ó", "\324", "Ô", - "\325", "Õ", "\326", "Ö", "\327", "×", - "\330", "Ø", "\331", "Ù", "\332", "Ú", - "\333", "Û", "\334", "Ü", "\335", "Ý", - "\336", "Þ", "\337", "ß", "\340", "à", - "\341", "á", "\342", "â", "\343", "ã", - "\344", "ä", "\345", "å", "\346", "æ", - "\347", "ç", "\350", "è", "\351", "é", - "\352", "ê", "\353", "ë", "\354", "ì", - "\355", "í", "\356", "î", "\357", "ï", - "\360", "ð", "\361", "ñ", "\362", "ò", - "\363", "ó", "\364", "ô", "\365", "õ", - "\366", "ö", "\367", "÷", "\370", "ø", - "\371", "ù", "\372", "ú", "\373", "û", - "\374", "ü", "\375", "ý", "\376", "þ", - "\377", "ÿ", "\267", "·", -); - -# alignments for tables -our @alignments = ('', '', ' ALIGN="RIGHT"', ' ALIGN="CENTER"'); -our @lc_alignments = ('', '', ' align="right"', ' align="center"'); -our @xhtml_alignments = - ('', '', ' style="text-align: right;"', ' style="text-align: center;"'); - -#---------------------------------------------------------------# -# Object interface -#---------------------------------------------------------------# - -=head2 new - - $conv = new HTML::TextToHTML() - - $conv = new HTML::TextToHTML(titlefirst=>1, - ... - ); - -Create a new object with new. If one argument is given, it is assumed -to be a reference to an array of arguments. If more than one argument -is given, it is assumed to be a hash of arguments. These arguments will -be used in invocations of other methods. - -See L</OPTIONS> for the possible values of the arguments. - -=cut - -sub new -{ - my $invocant = shift; - my $self = {}; - - my $class = ref($invocant) || $invocant; # Object or class name - init_our_data($self); - - # bless self - bless($self, $class); - - $self->args(@_); - - return $self; -} # new - -=head2 args - - $conv->args(short_line_length=>60, - titlefirst=>1, - .... - ); - -Updates the current arguments/options of the HTML::TextToHTML object. -Takes either a hash, or a reference to an array of arguments, which will -be used in invocations of other methods. -See L</OPTIONS> for the possible values of the arguments. - -NOTE: the reference-to-an-array usage is DEPRECATED and will be removed -in the future. - -=cut - -sub args -{ - my $self = shift; - my %args = (); - my @arg_array = (); - if ( @_ - && @_ == 1 - && ref $_[0] eq 'ARRAY') - { - # this is a reference to an array -- use the old style args - my $aref = shift; - @arg_array = @{$aref}; - } - elsif (@_) - { - %args = @_; - } - - if (%args) - { - if ($self->{debug}) - { - print STDERR "========args(hash)========\n"; - print STDERR Dumper(%args); - } - foreach my $arg (keys %args) - { - if (defined $args{$arg}) - { - if ($arg =~ /^-/) - { - $arg =~ s/^-//; # get rid of first dash - $arg =~ s/^-//; # get rid of possible second dash - } - if ($self->{debug}) - { - print STDERR "--", $arg; - } - $self->{$arg} = $args{$arg}; - if ($self->{debug}) - { - print STDERR " ", $args{$arg}, "\n"; - } - } - } - } - elsif (@arg_array) - { - if ($self->{debug}) - { - print STDERR "========args(array)========\n"; - print STDERR Dumper(@arg_array); - } - # the arg array may have filenames at the end of it, - # so don't consume them - my $look_at_args = 1; - while (@arg_array && $look_at_args) - { - my $arg = shift @arg_array; - # check for arguments which are bools, - # and thus have no companion value - if ($arg =~ /^-/) - { - $arg =~ s/^-//; # get rid of first dash - $arg =~ s/^-//; # get rid of possible second dash - if ($self->{debug}) - { - print STDERR "--", $arg; - } - if ( $arg eq 'debug' - || $arg eq 'demoronize' - || $arg eq 'eight_bit_clean' - || $arg eq 'escape_HTML_chars' - || $arg eq 'explicit_headings' - || $arg eq 'extract' - || $arg eq 'link_only' - || $arg eq 'lower_case_tags' - || $arg eq 'mailmode' - || $arg eq 'make_anchors' - || $arg eq 'make_links' - || $arg eq 'make_tables' - || $arg eq 'preserve_indent' - || $arg eq 'titlefirst' - || $arg eq 'unhyphenation' - || $arg eq 'use_mosaic_header' - || $arg eq 'use_preformat_marker' - || $arg eq 'verbose' - || $arg eq 'xhtml') - { - $self->{$arg} = 1; - if ($self->{debug}) - { - print STDERR "=true\n"; - } - } - elsif ($arg eq 'nodebug' - || $arg eq 'nodemoronize' - || $arg eq 'noeight_bit_clean' - || $arg eq 'noescape_HTML_chars' - || $arg eq 'noexplicit_headings' - || $arg eq 'noextract' - || $arg eq 'nolink_only' - || $arg eq 'nolower_case_tags' - || $arg eq 'nomailmode' - || $arg eq 'nomake_anchors' - || $arg eq 'nomake_links' - || $arg eq 'nomake_tables' - || $arg eq 'nopreserve_indent' - || $arg eq 'notitlefirst' - || $arg eq 'nounhyphenation' - || $arg eq 'nouse_mosaic_header' - || $arg eq 'nouse_preformat_marker' - || $arg eq 'noverbose' - || $arg eq 'noxhtml') - { - $arg =~ s/^no//; - $self->{$arg} = 0; - if ($self->{debug}) - { - print STDERR " $arg=false\n"; - } - } - else - { - my $val = shift @arg_array; - if ($self->{debug}) - { - print STDERR "=", $val, "\n"; - } - # check the types - if (defined $arg && defined $val) - { - if ( $arg eq 'infile' - || $arg eq 'custom_heading_regexp' - || $arg eq 'links_dictionaries') - { # arrays - if ($val eq 'CLEAR') - { - $self->{$arg} = []; - } - else - { - push @{$self->{$arg}}, $val; - } - } - elsif ($arg eq 'file') - { # alternate for 'infile' - if ($val eq 'CLEAR') - { - $self->{infile} = []; - } - else - { - push @{$self->{infile}}, $val; - } - } - elsif ($arg eq 'table_type') - { - # hash - if ($val eq 'CLEAR') - { - $self->{$arg} = {}; - } - else - { - my ($f1, $v1) = split(/=/, $val, 2); - $self->{$arg}->{$f1} = $v1; - } - } - else - { - $self->{$arg} = $val; - } - } - } - } - else - { - # if an option don't start with - then we've - # come to the end of the options - $look_at_args = 0; - } - } - } - if ($self->{debug}) - { - print STDERR Dumper($self); - } - - return 1; -} # args - -=head2 process_chunk - -$newstring = $conv->process_chunk($mystring); - -Convert a string to a HTML fragment. This assumes that this string is -at the least, a single paragraph, but it can contain more than that. -This returns the processed string. If you want to pass arguments to -alter the behaviour of this conversion, you need to do that earlier, -either when you create the object, or with the L</args> method. - - $newstring = $conv->process_chunk($mystring, - close_tags=>0); - -If there are open tags (such as lists) in the input string, -process_chunk will now automatically close them, unless you specify not -to, with the close_tags option. - - $newstring = $conv->process_chunk($mystring, - is_fragment=>1); - -If you want this string to be treated as a fragment, and not assumed to -be a paragraph, set is_fragment to true. If there is more than one -paragraph in the string (ie it contains blank lines) then this option -will be ignored. - -=cut - -sub process_chunk ($$;%) -{ - my $self = shift; - my $chunk = shift; - my %args = ( - close_tags => 1, - is_fragment => 0, - @_ - ); - - my $ret_str = ''; - my @paras = split(/\r?\n\r?\n/, $chunk); - my $ind = 0; - if (@paras == 1) # just one paragraph - { - $ret_str .= $self->process_para( - $chunk, - close_tags => $args{close_tags}, - is_fragment => $args{is_fragment} - ); - } - else - { - my $ind = 0; - foreach my $para (@paras) - { - # if the paragraph doesn't end with a newline, add one - $para .= "\n" if ($para !~ /\n$/); - if ($ind == @paras - 1) # last one - { - $ret_str .= $self->process_para( - $para, - close_tags => $args{close_tags}, - is_fragment => 0 - ); - } - else - { - $ret_str .= $self->process_para( - $para, - close_tags => 0, - is_fragment => 0 - ); - } - $ind++; - } - } - $ret_str; -} # process_chunk - -=head2 process_para - -$newstring = $conv->process_para($mystring); - -Convert a string to a HTML fragment. This assumes that this string is -at the most a single paragraph, with no blank lines in it. If you don't -know whether your string will contain blank lines or not, use the -L</process_chunk> method instead. - -This returns the processed string. If you want to pass arguments to -alter the behaviour of this conversion, you need to do that earlier, -either when you create the object, or with the L</args> method. - - $newstring = $conv->process_para($mystring, - close_tags=>0); - -If there are open tags (such as lists) in the input string, process_para -will now automatically close them, unless you specify not to, with the -close_tags option. - - $newstring = $conv->process_para($mystring, - is_fragment=>1); - -If you want this string to be treated as a fragment, and not assumed to be -a paragraph, set is_fragment to true. - -=cut - -sub process_para ($$;%) -{ - my $self = shift; - my $para = shift; - my %args = ( - close_tags => 1, - is_fragment => 0, - @_ - ); - - # if this is an external call, do certain initializations - $self->do_init_call(); - - my $para_action = $NONE; - - # tables and mailheaders don't carry over from one para to the next - if ($self->{__mode} & $TABLE) - { - $self->{__mode} ^= $TABLE; - } - if ($self->{__mode} & $MAILHEADER) - { - $self->{__mode} ^= $MAILHEADER; - } - - # convert Microsoft character codes into sensible characters - if ($self->{demoronize}) - { - demoronize_char($para); - } - - # if we are not just linking, we are discerning structure - if (!$self->{link_only}) - { - - # Chop trailing whitespace and DOS CRs - $para =~ s/[ \011]*\015$//; - # Chop leading whitespace and DOS CRs - $para =~ s/^[ \011]*\015//; - $para =~ s/\r//g; # remove any stray carriage returns - - my @done_lines = (); # lines which have been processed - - # The PRE_EXPLICIT structure can carry over from one - # paragraph to the next, but it is ended with the - # explicit end-tag designated for it. - # Therefore we can shortcut for this by checking - # for the end of the PRE_EXPLICIT and chomping off - # the preformatted string part of this para before - # we have to split it into lines. - # Note that after this check, we could *still* be - # in PRE_EXPLICIT mode. - if ($self->{__mode} & $PRE_EXPLICIT) - { - my $pre_str = - $self->split_end_explicit_preformat(para_ref => \$para); - if ($pre_str) - { - push @done_lines, $pre_str; - } - } - - if (defined $para && $para ne "") - { - # - # Now we split the paragraph into lines - # - my $para_len = length($para); - my @para_lines = split(/^/, $para); - my @para_line_len = (); - my @para_line_indent = (); - my @para_line_action = (); - my $i = 0; - foreach my $line (@para_lines) - { - # Change all tabs to spaces - while ($line =~ /\011/) - { - my $tw = $self->{tab_width}; - $line =~ s/\011/" " x ($tw - (length($`) % $tw))/e; - } - push @para_line_len, length($line); - if ($line =~ /^\s*$/) - { - # if the line is blank, use the previous indent - # if there is one - push @para_line_indent, - ($i == 0 ? 0 : $para_line_indent[$i - 1]); - } - else - { - # count the number of leading spaces - my ($ws) = $line =~ /^( *)[^ ]/; - push @para_line_indent, length($ws); - } - push @para_line_action, $NONE; - $i++; - } - - # There are two more structures which carry over from one - # paragraph to the next: LIST, PRE - # There are also certain things which will immediately end - # multi-paragraph LIST and PRE, if found at the start - # of a paragraph: - # A list will be ended by - # TABLE, MAILHEADER, HEADER, custom-header - # A PRE will be ended by - # TABLE, MAILHEADER and non-pre text - - my $is_table = 0; - my $table_type = 0; - my $is_mailheader = 0; - my $is_header = 0; - my $is_custom_header = 0; - if (@{$self->{custom_heading_regexp}}) - { - $is_custom_header = - $self->is_custom_heading(line => $para_lines[0]); - } - if ( $self->{make_tables} - && @para_lines > 1) - { - $table_type = $self->get_table_type( - rows_ref => \@para_lines, - para_len => $para_len - ); - $is_table = ($table_type != 0); - } - if ( !$self->{explicit_headings} - && @para_lines > 1 - && !$is_table) - { - $is_header = $self->is_heading( - line_ref => \$para_lines[0], - next_ref => \$para_lines[1] - ); - } - # Note that it is concievable that someone has - # partially disabled mailmode by making a custom header - # which matches the start of mail. - # This is stupid, but allowable, so we check. - if ( $self->{mailmode} - && !$is_table - && !$is_custom_header) - { - $is_mailheader = $self->is_mailheader(rows_ref => \@para_lines); - } - - # end the list if we can end it - if ( - ($self->{__mode} & $LIST) - && ( $is_table - || $is_mailheader - || $is_header - || $is_custom_header) - ) - { - my $list_end = ''; - my $action = 0; - $self->endlist( - num_lists => $self->{__listnum}, - prev_ref => \$list_end, - line_action_ref => \$action - ); - push @done_lines, $list_end; - $self->{__prev_para_action} |= $END; - } - - # end the PRE if we can end it - if ( - ($self->{__mode} & $PRE) - && !($self->{__mode} & $PRE_EXPLICIT) - && ( $is_table - || $is_mailheader - || !$self->is_preformatted($para_lines[0])) - && ($self->{preformat_trigger_lines} != 0) - ) - { - my $pre_end = ''; - my $tag = $self->close_tag('PRE'); - $pre_end = "${tag}\n"; - $self->{__mode} ^= ($PRE & $self->{__mode}); - push @done_lines, $pre_end; - $self->{__prev_para_action} |= $END; - } - - # The PRE and PRE_EXPLICIT structure can carry over - # from one paragraph to the next, but because we don't - # want trailing newlines, such newlines would have been - # gotten rid of in the previous call. However, with - # a preformatted text, we do want the blank lines in it - # to be preserved, so let's add a blank line in here. - if ($self->{__mode} & $PRE) - { - push @done_lines, "\n"; - } - - # Now, we do certain things which are only found at the - # start of a paragraph: - # HEADER, custom-header, TABLE and MAILHEADER - # These could concievably eat the rest of the paragraph. - - if ($is_custom_header) - { - # custom header eats the first line - my $header = shift @para_lines; - shift @para_line_len; - shift @para_line_indent; - shift @para_line_action; - $self->custom_heading(line_ref => \$header); - push @done_lines, $header; - $self->{__prev_para_action} |= $HEADER; - } - elsif ($is_header) - { - # normal header eats the first two lines - my $header = shift @para_lines; - shift @para_line_len; - shift @para_line_indent; - shift @para_line_action; - my $underline = shift @para_lines; - shift @para_line_len; - shift @para_line_indent; - shift @para_line_action; - $self->heading( - line_ref => \$header, - next_ref => \$underline - ); - push @done_lines, $header; - $self->{__prev_para_action} |= $HEADER; - } - - # do the table stuff on the array of lines - if ($self->{make_tables} && $is_table) - { - if ( - $self->tablestuff( - table_type => $table_type, - rows_ref => \@para_lines, - para_len => $para_len - ) - ) - { - # this has used up all the lines - push @done_lines, @para_lines; - @para_lines = (); - } - } - - # check of this para is a mail-header - if ( $is_mailheader - && !($self->{__mode} & $TABLE) - && @para_lines) - { - $self->mailheader(rows_ref => \@para_lines); - # this has used up all the lines - push @done_lines, @para_lines; - @para_lines = (); - } - - # - # Now go through the paragraph lines one at a time - # Note that we won't have TABLE, MAILHEADER, HEADER modes - # because they would have eaten the lines - # - my $prev = ''; - my $prev_action = $self->{__prev_para_action}; - for (my $i = 0; $i < @para_lines; $i++) - { - my $prev_ref; - my $prev_action_ref; - my $prev_line_indent; - my $prev_line_len; - if ($i == 0) - { - $prev_ref = \$prev; - $prev_action_ref = \$prev_action; - $prev_line_indent = 0; - $prev_line_len = 0; - } - else - { - $prev_ref = \$para_lines[$i - 1]; - $prev_action_ref = \$para_line_action[$i - 1]; - $prev_line_indent = $para_line_indent[$i - 1]; - $prev_line_len = $para_line_len[$i - 1]; - } - my $next_ref; - if ($i == $#para_lines) - { - $next_ref = undef; - } - else - { - $next_ref = \$para_lines[$i + 1]; - } - - $para_lines[$i] = escape($para_lines[$i]) - if ($self->{escape_HTML_chars}); - - if ($self->{mailmode} - && !($self->{__mode} & ($PRE_EXPLICIT))) - { - $self->mailquote( - line_ref => \$para_lines[$i], - line_action_ref => \$para_line_action[$i], - prev_ref => $prev_ref, - prev_action_ref => $prev_action_ref, - next_ref => $next_ref - ); - } - - if ( ($self->{__mode} & $PRE) - && ($self->{preformat_trigger_lines} != 0)) - { - $self->endpreformat( - para_lines_ref => \@para_lines, - para_action_ref => \@para_line_action, - ind => $i, - prev_ref => $prev_ref - ); - } - - if (!($self->{__mode} & $PRE)) - { - $self->hrule( - para_lines_ref => \@para_lines, - para_action_ref => \@para_line_action, - ind => $i - ); - } - if (!($self->{__mode} & ($PRE)) - && ($para_lines[$i] !~ /^\s*$/)) - { - $self->liststuff( - para_lines_ref => \@para_lines, - para_action_ref => \@para_line_action, - para_line_indent_ref => \@para_line_indent, - ind => $i, - prev_ref => $prev_ref - ); - } - if ( !($para_line_action[$i] & ($HEADER | $LIST)) - && !($self->{__mode} & ($LIST | $PRE)) - && $self->{__preformat_enabled}) - { - $self->preformat( - mode_ref => \$self->{__mode}, - line_ref => \$para_lines[$i], - line_action_ref => \$para_line_action[$i], - prev_ref => $prev_ref, - next_ref => $next_ref, - prev_action_ref => $prev_action_ref - ); - } - if (!($self->{__mode} & ($PRE))) - { - $self->paragraph( - line_ref => \$para_lines[$i], - line_action_ref => \$para_line_action[$i], - prev_ref => $prev_ref, - prev_action_ref => $prev_action_ref, - line_indent => $para_line_indent[$i], - prev_indent => $prev_line_indent, - is_fragment => $args{is_fragment}, - ind => $i, - ); - } - if (!($self->{__mode} & ($PRE | $LIST))) - { - $self->shortline( - line_ref => \$para_lines[$i], - line_action_ref => \$para_line_action[$i], - prev_ref => $prev_ref, - prev_action_ref => $prev_action_ref, - prev_line_len => $prev_line_len - ); - } - if (!($self->{__mode} & ($PRE))) - { - $self->caps( - line_ref => \$para_lines[$i], - line_action_ref => \$para_line_action[$i] - ); - } - - # put the "prev" line in front of the first line - $para_lines[$i] = $prev . $para_lines[$i] - if ($i == 0 && ($prev !~ /^\s*$/)); - } - - # para action is the action of the last line of the para - $para_action = $para_line_action[$#para_line_action]; - $para_action = $NONE if (!defined $para_action); - - # push them on the done lines - push @done_lines, @para_lines; - @para_lines = (); - - } - # now put the para back together as one string - $para = join('', @done_lines); - - # if this is a paragraph, and we are in XHTML mode, - # close an open paragraph. - if ($self->{xhtml}) - { - my $open_tag = @{$self->{__tags}}[$#{$self->{__tags}}]; - if (defined $open_tag && $open_tag eq 'P') - { - $para .= $self->close_tag('P'); - } - } - - if ( - $self->{unhyphenation} - - # ends in hyphen & next line starts w/letters - && ($para =~ /[^\W\d_]\-\n\s*[^\W\d_]/s) && !( - $self->{__mode} & - ($PRE | $HEADER | $MAILHEADER | $TABLE | $BREAK) - ) - ) - { - $self->unhyphenate_para(\$para); - } - # chop trailing newlines for continuing lists and PRE - if ( $self->{__mode} & $LIST - || $self->{__mode} & $PRE) - { - $para =~ s/\n$//g; - } - } - - # apply links and bold/italic formatting - if ($para !~ /^\s*$/) - { - $self->apply_links( - para_ref => \$para, - para_action_ref => \$para_action - ); - } - - # close any open lists if required to - if ( $args{close_tags} - && $self->{__mode} & $LIST) # End all lists - { - $self->endlist( - num_lists => $self->{__listnum}, - prev_ref => \$para, - line_action_ref => \$para_action - ); - } - # close any open tags - if ($args{close_tags} && $self->{xhtml}) - { - while (@{$self->{__tags}}) - { - $para .= $self->close_tag(''); - } - } - - # convert remaining Microsoft character codes into sensible HTML - if ($self->{demoronize}) - { - $para = demoronize_code($para); - } - # All the matching and formatting is done. Now we can - # replace non-ASCII characters with character entities. - if (!$self->{eight_bit_clean}) - { - my @chars = split(//, $para); - foreach $_ (@chars) - { - $_ = $char_entities{$_} if defined($char_entities{$_}); - } - $para = join('', @chars); - } - - $self->{__prev_para_action} = $para_action; - - return $para; -} # process_para - -=head2 txt2html - - $conv->txt2html(%args); - -Convert a text file to HTML. Takes a hash of arguments, or a reference -to an array of arguments to customize the conversion; (this includes -saying what file to convert!) See L</OPTIONS> for the possible values of -the arguments. Arguments which have already been set with B<new> or -B<args> will remain as they are, unless they are overridden. - -=cut - -sub txt2html ($;$) -{ - my $self = shift; - - if (@_) - { - $self->args(@_); - } - - $self->do_init_call(); - - my $outhandle; - my $outhandle_needs_closing; - - # set up the output - if ($self->{outhandle}) - { - $outhandle = $self->{outhandle}; - $outhandle_needs_closing = 1; - } - elsif ($self->{outfile} eq "-") - { - $outhandle = *STDOUT; - $outhandle_needs_closing = 0; - } - else - { - open($outhandle, "> " . $self->{outfile}) - || die "Error: unable to open ", $self->{outfile}, ": $!\n"; - $outhandle_needs_closing = 1; - } - - # slurp up a paragraph at a time, a file at a time - local $/ = ""; - my $para = ''; - my $count = 0; - my $print_count = 0; - my @sources = (); - my $source_type; - if ($self->{infile} and @{$self->{infile}}) - { - @sources = @{$self->{infile}}; - $source_type = 'file'; - } - elsif ($self->{inhandle} and @{$self->{inhandle}}) - { - @sources = @{$self->{inhandle}}; - $source_type = 'filehandle'; - } - elsif ($self->{instring} and @{$self->{instring}}) - { - @sources = @{$self->{instring}}; - $source_type = 'string'; - } - my $inhandle; - my $inhandle_needs_closing = 0; - foreach my $source (@sources) - { - $inhandle = undef; - if ($source_type eq 'file') - { - if (!$source or $source eq '-') - { - $inhandle = *STDIN; - $inhandle_needs_closing = 0; - } - else - { - if (-f $source && open($inhandle, $source)) - { - $inhandle_needs_closing = 1; - } - else # error - { - warn "Could not open $source\n"; - next; - } - } - } - elsif ($source_type eq 'filehandle') - { - $inhandle = $source; - $inhandle_needs_closing = 1; - } - if ($source_type eq 'string') - { - # process the string - $para = $_; - $para =~ s/\n$//; # trim the endline - if ($count == 0) - { - $self->do_file_start($outhandle, $para); - } - $self->{__done_with_sect_link} = []; - $para = $self->process_chunk($para, close_tags => 0); - print $outhandle $para, "\n"; - $print_count++; - $count++; - } - else # file or filehandle - { - while (<$inhandle>) - { - $para = $_; - $para =~ s/\n$//; # trim the endline - if ($count == 0) - { - $self->do_file_start($outhandle, $para); - } - $self->{__done_with_sect_link} = []; - $para = $self->process_chunk($para, close_tags => 0); - print $outhandle $para, "\n"; - $print_count++; - $count++; - } - if ($inhandle_needs_closing) - { - close($inhandle); - } - } - } # for each file - - $self->{__prev} = ""; - if ($self->{__mode} & $LIST) # End all lists - { - $self->endlist( - num_lists => $self->{__listnum}, - prev_ref => \$self->{__prev}, - line_action_ref => \$self->{__line_action} - ); - } - print $outhandle $self->{__prev}; - - # end open preformats - if ($self->{__mode} & $PRE) - { - my $tag = $self->close_tag('PRE'); - print $outhandle $tag; - } - - # close all open tags - if ( $self->{xhtml} - && !$self->{extract} - && @{$self->{__tags}}) - { - if ($self->{dict_debug} & 8) - { - print STDERR "closing all tags at end\n"; - } - # close any open tags (until we get to the body) - my $open_tag = @{$self->{__tags}}[$#{$self->{__tags}}]; - while (@{$self->{__tags}} - && $open_tag ne 'BODY' - && $open_tag ne 'HTML') - { - print $outhandle $self->close_tag(''); - $open_tag = @{$self->{__tags}}[$#{$self->{__tags}}]; - } - print $outhandle "\n"; - } - - if ($self->{append_file}) - { - if (-r $self->{append_file}) - { - open(APPEND, $self->{append_file}); - while (<APPEND>) - { - print $outhandle $_; - $print_count++; - } - close(APPEND); - } - else - { - print STDERR "Can't find or read file ", $self->{append_file}, - " to append.\n"; - } - } - - # print the closing tags (if we have printed stuff at all) - if ($print_count && !$self->{extract}) - { - print $outhandle $self->close_tag('BODY'), "\n"; - print $outhandle $self->close_tag('HTML'), "\n"; - } - if ($outhandle_needs_closing) - { - close($outhandle); - } - return 1; -} - -#---------------------------------------------------------------# -# Init-related subroutines - -#--------------------------------# -# Name: init_our_data -# Args: -# $self -sub init_our_data ($) -{ - my $self = shift; - - $self->{debug} = 0; - - # - # All the options, in alphabetical order - # - $self->{append_file} = ''; - $self->{append_head} = ''; - $self->{body_deco} = ''; - $self->{bullets} = '-=o*\267'; - $self->{bullets_ordered} = ''; - $self->{bold_delimiter} = '#'; - $self->{caps_tag} = 'STRONG'; - $self->{custom_heading_regexp} = []; - $self->{default_link_dict} = - ($ENV{HOME} ? "$ENV{HOME}/.txt2html.dict" : '.txt2html.dict'); - $self->{dict_debug} = 0; - $self->{doctype} = "-//W3C//DTD HTML 3.2 Final//EN"; - $self->{demoronize} = 1; - $self->{eight_bit_clean} = 0; - $self->{escape_HTML_chars} = 1; - $self->{explicit_headings} = 0; - $self->{extract} = 0; - $self->{hrule_min} = 4; - $self->{indent_width} = 2; - $self->{indent_par_break} = 0; - $self->{infile} = []; - $self->{inhandle} = []; - $self->{instring} = []; - $self->{italic_delimiter} = '*'; - $self->{links_dictionaries} = []; - $self->{link_only} = 0; - $self->{lower_case_tags} = 0; - $self->{mailmode} = 0; - $self->{make_anchors} = 1; - $self->{make_links} = 1; - $self->{make_tables} = 0; - $self->{min_caps_length} = 3; - $self->{outfile} = '-'; - $self->{par_indent} = 2; - $self->{preformat_trigger_lines} = 2; - $self->{endpreformat_trigger_lines} = 2; - $self->{preformat_start_marker} = "^(:?(:?<)|<)PRE(:?(:?>)|>)\$"; - $self->{preformat_end_marker} = "^(:?(:?<)|<)/PRE(:?(:?>)|>)\$"; - $self->{preformat_whitespace_min} = 5; - $self->{prepend_file} = ''; - $self->{preserve_indent} = 0; - $self->{short_line_length} = 40; - $self->{style_url} = ''; - $self->{tab_width} = 8; - $self->{table_type} = { - ALIGN => 1, - PGSQL => 1, - BORDER => 1, - DELIM => 1, - }; - $self->{title} = ''; - $self->{titlefirst} = 0; - $self->{underline_length_tolerance} = 1; - $self->{underline_offset_tolerance} = 1; - $self->{unhyphenation} = 1; - $self->{use_mosaic_header} = 0; - $self->{use_preformat_marker} = 0; - $self->{xhtml} = 0; - - # accumulation variables - $self->{__file} = ""; # Current file being processed - $self->{__heading_styles} = {}; - $self->{__num_heading_styles} = 0; - $self->{__links_table} = {}; - $self->{__links_table_order} = []; - $self->{__search_patterns} = []; - $self->{__repl_code} = []; - $self->{__prev_para_action} = 0; - $self->{__non_header_anchor} = 0; - $self->{__mode} = 0; - $self->{__listnum} = 0; - $self->{__list_nice_indent} = ""; - $self->{__list_indent} = []; - - $self->{__call_init_done} = 0; - - # - # The global links data - # - # This is stored in the DATA handle, after the __DATA__ at - # the end of this file; but because the test scripts (and possibly - # other scripts) don't just create one instance of this object, - # we have to remember the position of the DATA handle - # and reset it after we've read from it, just in case - # we have to read from it again. - # This also means that we don't close it, either. Hope that doesn't - # cause a problem... - # - my $curpos = tell(DATA); # remember the __DATA__ position - my @lines = (); - while (<DATA>) - { - # skip lines that start with '#' - next if /^\#/; - # skip lines that end with unescaped ':' - next if /^.*[^\\]:\s*$/; - push @lines, $_; - } - # reset the data handle to the start, just in case - seek(DATA, $curpos, 0); - $self->{__global_links_data} = join('', @lines); -} # init_our_data - -#---------------------------------------------------------------# -# txt2html-related subroutines - -#--------------------------------# -# Name: deal_with_options -# do extra processing related to particular options -# Args: -# $self -sub deal_with_options ($) -{ - my $self = shift; - - if ($self->{links_dictionaries}) - { - # only put into the links dictionaries files which are readable - my @dict_files = @{$self->{links_dictionaries}}; - $self->args(links_dictionaries => []); - - foreach my $ld (@dict_files) - { - if (-r $ld) - { - $self->{'make_links'} = 1; - $self->args(['--links_dictionaries', $ld]); - } - else - { - print STDERR "Can't find or read link-file $ld\n"; - } - } - } - if (!$self->{make_links}) - { - $self->{'links_dictionaries'} = 0; - } - if ($self->{append_file}) - { - if (!-r $self->{append_file}) - { - print STDERR "Can't find or read ", $self->{append_file}, "\n"; - $self->{append_file} = ''; - } - } - if ($self->{prepend_file}) - { - if (!-r $self->{prepend_file}) - { - print STDERR "Can't find or read ", $self->{prepend_file}, "\n"; - $self->{'prepend_file'} = ''; - } - } - if ($self->{append_head}) - { - if (!-r $self->{append_head}) - { - print STDERR "Can't find or read ", $self->{append_head}, "\n"; - $self->{'append_head'} = ''; - } - } - - if (!$self->{outfile}) - { - $self->{'outfile'} = "-"; - } - - $self->{'preformat_trigger_lines'} = 0 - if ($self->{preformat_trigger_lines} < 0); - $self->{'preformat_trigger_lines'} = 2 - if ($self->{preformat_trigger_lines} > 2); - - $self->{'endpreformat_trigger_lines'} = 1 - if ($self->{preformat_trigger_lines} == 0); - $self->{'endpreformat_trigger_lines'} = 0 - if ($self->{endpreformat_trigger_lines} < 0); - $self->{'endpreformat_trigger_lines'} = 2 - if ($self->{endpreformat_trigger_lines} > 2); - - $self->{__preformat_enabled} = - (($self->{endpreformat_trigger_lines} != 0) - || $self->{use_preformat_marker}); - - if ($self->{use_mosaic_header}) - { - my $num_heading_styles = 0; - my %heading_styles = (); - $heading_styles{"*"} = ++$num_heading_styles; - $heading_styles{"="} = ++$num_heading_styles; - $heading_styles{"+"} = ++$num_heading_styles; - $heading_styles{"-"} = ++$num_heading_styles; - $heading_styles{"~"} = ++$num_heading_styles; - $heading_styles{"."} = ++$num_heading_styles; - $self->{__heading_styles} = \%heading_styles; - $self->{__num_heading_styles} = $num_heading_styles; - } - # XHTML implies lower case - $self->{'lower_case_tags'} = 1 if ($self->{xhtml}); -} - -sub escape ($) -{ - my ($text) = @_; - $text =~ s/&/&/g; - $text =~ s/>/>/g; - $text =~ s/</</g; - return $text; -} - -# Added by Alan Jackson, alan at ajackson dot org, and based -# on the demoronize script by John Walker, http://www.fourmilab.ch/ -# Convert Microsoft character entities into characters. -sub demoronize_char($) -{ - my $s = shift; - # Map strategically incompatible non-ISO characters in the - # range 0x82 -- 0x9F into plausible substitutes where - # possible. - - $s =~ s/\x82/,/g; - $s =~ s/\x84/,,/g; - $s =~ s/\x85/.../g; - - $s =~ s/\x88/^/g; - - $s =~ s/\x8B/</g; - $s =~ s/\x8C/Oe/g; - - $s =~ s/\x91/`/g; - $s =~ s/\x92/'/g; - $s =~ s/\x93/"/g; - $s =~ s/\x94/"/g; - $s =~ s/\x95/*/g; - $s =~ s/\x96/-/g; - $s =~ s/\x97/--/g; - - $s =~ s/\x9B/>/g; - $s =~ s/\x9C/oe/g; - - return $s; -} - -# convert Microsoft character entities into HTML code -sub demoronize_code($) -{ - my $s = shift; - # Map strategically incompatible non-ISO characters in the - # range 0x82 -- 0x9F into plausible substitutes where - # possible. - - $s =~ s-\x83-<em>f</em>-g; - - $s =~ s-\x98-<sup>~</sup>-g; - $s =~ s-\x99-<sup>TM</sup>-g; - - return $s; -} - -# output the tag wanted (add the <> and the / if necessary) -# - output in lower or upper case -# - do tag-related processing -# options: -# tag_type=>'start' | tag_type=>'end' | tag_type=>'empty' -# (default start) -# inside_tag=>string (default empty) -sub get_tag ($$;%) -{ - my $self = shift; - my $in_tag = shift; - my %args = ( - tag_type => 'start', - inside_tag => '', - @_ - ); - my $inside_tag = $args{inside_tag}; - - my $open_tag = @{$self->{__tags}}[$#{$self->{__tags}}]; - if (!defined $open_tag) - { - $open_tag = ''; - } - # close any open tags that need closing - # Note that we only have to check for the structural tags we make, - # not every possible HTML tag - my $tag_prefix = ''; - if ($self->{xhtml}) - { - if ( $open_tag eq 'P' - and $in_tag eq 'P' - and $args{tag_type} ne 'end') - { - $tag_prefix = $self->close_tag('P'); - } - elsif ( $open_tag eq 'P' - and $in_tag =~ /^(HR|UL|OL|DL|PRE|TABLE|H)/) - { - $tag_prefix = $self->close_tag('P'); - } - elsif ( $open_tag eq 'LI' - and $in_tag eq 'LI' - and $args{tag_type} ne 'end') - { - # close a LI before the next LI - $tag_prefix = $self->close_tag('LI'); - } - elsif ( $open_tag eq 'LI' - and $in_tag =~ /^(UL|OL)$/ - and $args{tag_type} eq 'end') - { - # close the LI before the list closes - $tag_prefix = $self->close_tag('LI'); - } - elsif ( $open_tag eq 'DT' - and $in_tag eq 'DD' - and $args{tag_type} ne 'end') - { - # close a DT before the next DD - $tag_prefix = $self->close_tag('DT'); - } - elsif ( $open_tag eq 'DD' - and $in_tag eq 'DT' - and $args{tag_type} ne 'end') - { - # close a DD before the next DT - $tag_prefix = $self->close_tag('DD'); - } - elsif ( $open_tag eq 'DD' - and $in_tag eq 'DL' - and $args{tag_type} eq 'end') - { - # close the DD before the list closes - $tag_prefix = $self->close_tag('DD'); - } - } - - my $out_tag = $in_tag; - if ($args{tag_type} eq 'end') - { - $out_tag = $self->close_tag($in_tag); - } - else - { - if ($self->{lower_case_tags}) - { - $out_tag =~ tr/A-Z/a-z/; - } - else # upper case - { - $out_tag =~ tr/a-z/A-Z/; - } - if ($args{tag_type} eq 'empty') - { - if ($self->{xhtml}) - { - $out_tag = "<${out_tag}${inside_tag}/>"; - } - else - { - $out_tag = "<${out_tag}${inside_tag}>"; - } - } - else - { - push @{$self->{__tags}}, $in_tag; - $out_tag = "<${out_tag}${inside_tag}>"; - } - } - $out_tag = $tag_prefix . $out_tag if $tag_prefix; - if ($self->{dict_debug} & 8) - { - print STDERR - "open_tag = '${open_tag}', in_tag = '${in_tag}', tag_type = ", - $args{tag_type}, - ", inside_tag = '${inside_tag}', out_tag = '$out_tag'\n"; - } - - return $out_tag; -} # get_tag - -# close the open tag -sub close_tag ($$) -{ - my $self = shift; - my $in_tag = shift; - - my $open_tag = pop @{$self->{__tags}}; - $in_tag ||= $open_tag; - # put the open tag back on the stack if the in-tag is not the same - if (defined $open_tag && $open_tag ne $in_tag) - { - push @{$self->{__tags}}, $open_tag; - } - my $out_tag = $in_tag; - if ($self->{lower_case_tags}) - { - $out_tag =~ tr/A-Z/a-z/; - } - else # upper case - { - $out_tag =~ tr/a-z/A-Z/; - } - $out_tag = "<\/${out_tag}>"; - if ($self->{dict_debug} & 8) - { - print STDERR -"close_tag: open_tag = '${open_tag}', in_tag = '${in_tag}', out_tag = '$out_tag'\n"; - } - - return $out_tag; -} - -sub hrule ($%) -{ - my $self = shift; - my %args = ( - para_lines_ref => undef, - para_action_ref => undef, - ind => 0, - @_ - ); - my $para_lines_ref = $args{para_lines_ref}; - my $para_action_ref = $args{para_action_ref}; - my $ind = $args{ind}; - - my $hrmin = $self->{hrule_min}; - if ($para_lines_ref->[$ind] =~ /^\s*([-_~=\*]\s*){$hrmin,}$/) - { - my $tag = $self->get_tag("HR", tag_type => 'empty'); - $para_lines_ref->[$ind] = "$tag\n"; - $para_action_ref->[$ind] |= $HRULE; - } - elsif ($para_lines_ref->[$ind] =~ /\014/) - { - # Linefeeds become horizontal rules - $para_action_ref->[$ind] |= $HRULE; - my $tag = $self->get_tag("HR", tag_type => 'empty'); - $para_lines_ref->[$ind] =~ s/\014/\n${tag}\n/g; - } -} - -sub shortline ($%) -{ - my $self = shift; - my %args = ( - line_ref => undef, - line_action_ref => undef, - prev_ref => undef, - prev_action_ref => undef, - prev_line_len => 0, - @_ - ); - my $mode_ref = $args{mode_ref}; - my $line_ref = $args{line_ref}; - my $line_action_ref = $args{line_action_ref}; - my $prev_ref = $args{prev_ref}; - my $prev_action_ref = $args{prev_action_ref}; - my $prev_line_len = $args{prev_line_len}; - - # Short lines should be broken even on list item lines iff the - # following line is more text. I haven't figured out how to do - # that yet. For now, I'll just not break on short lines in lists. - # (sorry) - - my $tag = $self->get_tag('BR', tag_type => 'empty'); - if ( - ${$line_ref} !~ /^\s*$/ - && ${$prev_ref} !~ /^\s*$/ - && ($prev_line_len < $self->{short_line_length}) - && !( - ${$line_action_ref} & - ($END | $HEADER | $HRULE | $LIST | $IND_BREAK | $PAR) - ) - && !(${$prev_action_ref} & ($HEADER | $HRULE | $BREAK | $IND_BREAK)) - ) - { - ${$prev_ref} .= $tag . chop(${$prev_ref}); - ${$prev_action_ref} |= $BREAK; - } -} - -sub is_mailheader ($%) -{ - my $self = shift; - my %args = ( - rows_ref => undef, - @_ - ); - my $rows_ref = $args{rows_ref}; - - # a mail header is assumed to be the whole - # paragraph which starts with a From , From: or Newsgroups: line - - if ($rows_ref->[0] =~ /^(From:?)|(Newsgroups:) /) - { - return 1; - } - return 0; - -} # is_mailheader - -sub mailheader ($%) -{ - my $self = shift; - my %args = ( - rows_ref => undef, - @_ - ); - my $rows_ref = $args{rows_ref}; - - # a mail header is assumed to be the whole - # paragraph which starts with a From: or Newsgroups: line - my $tag = ''; - my @rows = @{$rows_ref}; - - if ($self->is_mailheader(%args)) - { - $self->{__mode} |= $MAILHEADER; - if ($self->{escape_HTML_chars}) - { - $rows[0] = escape($rows[0]); - } - $self->anchor_mail(\$rows[0]); - chomp ${rows}[0]; - $tag = $self->get_tag('P', inside_tag => " class='mail_header'"); - my $tag2 = $self->get_tag('BR', tag_type => 'empty'); - $rows[0] = - join('', "<!-- New Message -->\n", $tag, $rows[0], $tag2, "\n"); - # now put breaks on the rest of the paragraph - # apart from the last line - for (my $rn = 1; $rn < @rows; $rn++) - { - if ($self->{escape_HTML_chars}) - { - $rows[$rn] = escape($rows[$rn]); - } - if ($rn != (@rows - 1)) - { - $tag = $self->get_tag('BR', tag_type => 'empty'); - chomp $rows[$rn]; - $rows[$rn] =~ s/$/${tag}\n/; - } - } - } - @{$rows_ref} = @rows; - -} # mailheader - -sub mailquote ($%) -{ - my $self = shift; - my %args = ( - line_ref => undef, - line_action_ref => undef, - prev_ref => undef, - prev_action_ref => undef, - next_ref => undef, - @_ - ); - my $line_ref = $args{line_ref}; - my $line_action_ref = $args{line_action_ref}; - my $prev_ref = $args{prev_ref}; - my $prev_action_ref = $args{prev_action_ref}; - my $next_ref = $args{next_ref}; - - my $tag = ''; - if ( - ( - (${$line_ref} =~ /^\w*>/) # Handle "FF> Werewolves." - || (${$line_ref} =~ /^[\|:]/) - ) # Handle "[|:] There wolves." - && defined($next_ref) && (${$next_ref} !~ /^\s*$/) - ) - { - $tag = $self->get_tag('BR', tag_type => 'empty'); - ${$line_ref} =~ s/$/${tag}/; - ${$line_action_ref} |= ($BREAK | $MAILQUOTE); - if (!(${$prev_action_ref} & ($BREAK | $MAILQUOTE))) - { - $tag = $self->get_tag('P', inside_tag => " class='quote_mail'"); - ${$prev_ref} .= $tag; - ${$line_action_ref} |= $PAR; - } - } -} - -# Subtracts modes listed in $mask from $vector. -sub subtract_modes ($$) -{ - my ($vector, $mask) = @_; - return ($vector | $mask) - $mask; -} - -sub paragraph ($%) -{ - my $self = shift; - my %args = ( - line_ref => undef, - line_action_ref => undef, - prev_ref => undef, - prev_action_ref => undef, - line_indent => 0, - prev_indent => 0, - is_fragment => 0, - ind => 0, - @_ - ); - my $line_ref = $args{line_ref}; - my $line_action_ref = $args{line_action_ref}; - my $prev_ref = $args{prev_ref}; - my $prev_action_ref = $args{prev_action_ref}; - my $line_indent = $args{line_indent}; - my $prev_indent = $args{prev_indent}; - my $is_fragment = $args{is_fragment}; - my $line_no = $args{ind}; - - my $tag = ''; - if ( - ${$line_ref} !~ /^\s*$/ - && !subtract_modes( - ${$line_action_ref}, $END | $MAILQUOTE | $CAPS | $BREAK - ) - && ( ${$prev_ref} =~ /^\s*$/ - || (${$line_action_ref} & $END) - || ($line_indent > $prev_indent + $self->{par_indent})) - && !($is_fragment && $line_no == 0) - ) - { - - if ( $self->{indent_par_break} - && ${$prev_ref} !~ /^\s*$/ - && !(${$line_action_ref} & $END) - && ($line_indent > $prev_indent + $self->{par_indent})) - { - $tag = $self->get_tag('BR', tag_type => 'empty'); - ${$prev_ref} .= $tag; - ${$prev_ref} .= " " x $line_indent; - ${$line_ref} =~ s/^ {$line_indent}//; - ${$prev_action_ref} |= $BREAK; - ${$line_action_ref} |= $IND_BREAK; - } - elsif ($self->{preserve_indent}) - { - $tag = $self->get_tag('P'); - ${$prev_ref} .= $tag; - ${$prev_ref} .= " " x $line_indent; - ${$line_ref} =~ s/^ {$line_indent}//; - ${$line_action_ref} |= $PAR; - } - else - { - $tag = $self->get_tag('P'); - ${$prev_ref} .= $tag; - ${$line_action_ref} |= $PAR; - } - } - # detect also a continuing indentation at the same level - elsif ($self->{indent_par_break} - && !($self->{__mode} & ($PRE | $TABLE | $LIST)) - && ${$prev_ref} !~ /^\s*$/ - && !(${$line_action_ref} & $END) - && (${$prev_action_ref} & ($IND_BREAK | $PAR)) - && !subtract_modes(${$line_action_ref}, $END | $MAILQUOTE | $CAPS) - && ($line_indent > $self->{par_indent}) - && ($line_indent == $prev_indent)) - { - $tag = $self->get_tag('BR', tag_type => 'empty'); - ${$prev_ref} .= $tag; - ${$prev_ref} .= " " x $line_indent; - ${$line_ref} =~ s/^ {$line_indent}//; - ${$prev_action_ref} |= $BREAK; - ${$line_action_ref} |= $IND_BREAK; - } -} - -sub listprefix ($$) -{ - my $self = shift; - my $line = shift; - - my ($prefix, $number, $rawprefix, $term); - - my $bullets = $self->{bullets}; - my $bullets_ordered = $self->{bullets_ordered}; - my $number_match = '(\d+|[^\W\d])'; - if ($bullets_ordered) - { - $number_match = '(\d+|[a-zA-Z]|[' . "${bullets_ordered}])"; - } - $self->{__number_match} = $number_match; - my $term_match = '(\w\w+)'; - $self->{__term_match} = $term_match; - return (0, 0, 0, 0) - if ( !($line =~ /^\s*[${bullets}]\s+\S/) - && !($line =~ /^\s*${number_match}[\.\)\]:]\s+\S/) - && !($line =~ /^\s*${term_match}:$/)); - - ($term) = $line =~ /^\s*${term_match}:$/; - ($number) = $line =~ /^\s*${number_match}\S\s+\S/; - $number = 0 unless defined($number); - if ( $bullets_ordered - && $number =~ /[${bullets_ordered}]/) - { - $number = 1; - } - - # That slippery exception of "o" as a bullet - # (This ought to be determined using the context of what lists - # we have in progress, but this will probably work well enough.) - if ($bullets =~ /o/ && $line =~ /^\s*o\s/) - { - $number = 0; - } - - if ($term) - { - ($rawprefix) = $line =~ /^(\s*${term_match}.)$/; - $prefix = $rawprefix; - $prefix =~ s/${term_match}//; # Take the term out - } - elsif ($number) - { - ($rawprefix) = $line =~ /^(\s*${number_match}.)/; - $prefix = $rawprefix; - $prefix =~ s/${number_match}//; # Take the number out - } - else - { - ($rawprefix) = $line =~ /^(\s*[${bullets}].)/; - $prefix = $rawprefix; - } - ($prefix, $number, $rawprefix, $term); -} # listprefix - -sub startlist ($%) -{ - my $self = shift; - my %args = ( - prefix => '', - number => 0, - rawprefix => '', - term => '', - para_lines_ref => undef, - para_action_ref => undef, - ind => 0, - prev_ref => undef, - total_prefix => '', - @_ - ); - my $prefix = $args{prefix}; - my $number = $args{number}; - my $rawprefix = $args{rawprefix}; - my $term = $args{term}; - my $para_lines_ref = $args{para_lines_ref}; - my $para_action_ref = $args{para_action_ref}; - my $ind = $args{ind}; - my $prev_ref = $args{prev_ref}; - - my $tag = ''; - $self->{__listprefix}->[$self->{__listnum}] = $prefix; - if ($number) - { - - # It doesn't start with 1,a,A. Let's not screw with it. - if (($number ne "1") && ($number ne "a") && ($number ne "A")) - { - return 0; - } - $tag = $self->get_tag('OL'); - ${$prev_ref} .= join('', $self->{__list_nice_indent}, $tag, "\n"); - $self->{__list}->[$self->{__listnum}] = $OL; - } - elsif ($term) - { - $tag = $self->get_tag('DL'); - ${$prev_ref} .= join('', $self->{__list_nice_indent}, $tag, "\n"); - $self->{__list}->[$self->{__listnum}] = $DL; - } - else - { - $tag = $self->get_tag('UL'); - ${$prev_ref} .= join('', $self->{__list_nice_indent}, $tag, "\n"); - $self->{__list}->[$self->{__listnum}] = $UL; - } - - $self->{__list_indent}->[$self->{__listnum}] = length($args{total_prefix}); - $self->{__listnum}++; - $self->{__list_nice_indent} = - " " x $self->{__listnum} x $self->{indent_width}; - $para_action_ref->[$ind] |= $LIST; - $para_action_ref->[$ind] |= $LIST_START; - $self->{__mode} |= $LIST; - 1; -} # startlist - -# End N lists -sub endlist ($%) -{ - my $self = shift; - my %args = ( - num_lists => 0, - prev_ref => undef, - line_action_ref => undef, - @_ - ); - my $n = $args{num_lists}; - my $prev_ref = $args{prev_ref}; - my $line_action_ref = $args{line_action_ref}; - - my $tag = ''; - for (; $n > 0; $n--, $self->{__listnum}--) - { - $self->{__list_nice_indent} = - " " x ($self->{__listnum} - 1) x $self->{indent_width}; - if ($self->{__list}->[$self->{__listnum} - 1] == $UL) - { - $tag = $self->get_tag('UL', tag_type => 'end'); - ${$prev_ref} .= join('', $self->{__list_nice_indent}, $tag, "\n"); - pop @{$self->{__list_indent}}; - } - elsif ($self->{__list}->[$self->{__listnum} - 1] == $OL) - { - $tag = $self->get_tag('OL', tag_type => 'end'); - ${$prev_ref} .= join('', $self->{__list_nice_indent}, $tag, "\n"); - pop @{$self->{__list_indent}}; - } - elsif ($self->{__list}->[$self->{__listnum} - 1] == $DL) - { - $tag = $self->get_tag('DL', tag_type => 'end'); - ${$prev_ref} .= join('', $self->{__list_nice_indent}, $tag, "\n"); - pop @{$self->{__list_indent}}; - } - else - { - print STDERR "Encountered list of unknown type\n"; - } - } - ${$line_action_ref} |= $END; - $self->{__mode} ^= $LIST if (!$self->{__listnum}); -} # endlist - -sub continuelist ($%) -{ - my $self = shift; - my %args = ( - para_lines_ref => undef, - para_action_ref => undef, - ind => 0, - term => '', - @_ - ); - my $para_lines_ref = $args{para_lines_ref}; - my $para_action_ref = $args{para_action_ref}; - my $ind = $args{ind}; - my $term = $args{term}; - - my $list_indent = $self->{__list_nice_indent}; - my $bullets = $self->{bullets}; - my $num_match = $self->{__number_match}; - my $term_match = $self->{__term_match}; - my $tag = ''; - if ( $self->{__list}->[$self->{__listnum} - 1] == $UL - && $para_lines_ref->[$ind] =~ /^\s*[${bullets}]\s*/) - { - $tag = $self->get_tag('LI'); - $para_lines_ref->[$ind] =~ s/^\s*[${bullets}]\s*/${list_indent}${tag}/; - $para_action_ref->[$ind] |= $LIST_ITEM; - } - if ($self->{__list}->[$self->{__listnum} - 1] == $OL) - { - $tag = $self->get_tag('LI'); - $para_lines_ref->[$ind] =~ s/^\s*${num_match}.\s*/${list_indent}${tag}/; - $para_action_ref->[$ind] |= $LIST_ITEM; - } - if ( $self->{__list}->[$self->{__listnum} - 1] == $DL - && $term) - { - $tag = $self->get_tag('DT'); - my $tag2 = $self->get_tag('DT', tag_type => 'end'); - $term =~ s/_/ /g; # underscores are now spaces in the term - $para_lines_ref->[$ind] =~ - s/^\s*${term_match}.$/${list_indent}${tag}${term}${tag2}/; - $tag = $self->get_tag('DD'); - $para_lines_ref->[$ind] .= ${tag}; - $para_action_ref->[$ind] |= $LIST_ITEM; - } - $para_action_ref->[$ind] |= $LIST; -} # continuelist - -sub liststuff ($%) -{ - my $self = shift; - my %args = ( - para_lines_ref => undef, - para_action_ref => undef, - para_line_indent_ref => undef, - ind => 0, - prev_ref => undef, - @_ - ); - my $para_lines_ref = $args{para_lines_ref}; - my $para_action_ref = $args{para_action_ref}; - my $para_line_indent_ref = $args{para_line_indent_ref}; - my $ind = $args{ind}; - my $prev_ref = $args{prev_ref}; - - my $i; - - my ($prefix, $number, $rawprefix, $term) = - $self->listprefix($para_lines_ref->[$ind]); - - if (!$prefix) - { - # if the previous line is not blank - if ($ind > 0 && $para_lines_ref->[$ind - 1] !~ /^\s*$/) - { - # inside a list item - return; - } - # This might be a new paragraph within an existing list item; - # It will be the first line, and have the same indentation - # as the list's indentation. - if ( $ind == 0 - && $self->{__listnum} - && $para_line_indent_ref->[$ind] == - $self->{__list_indent}->[$self->{__listnum} - 1]) - { - # start a paragraph - my $tag = $self->get_tag('P'); - ${$prev_ref} .= $tag; - $para_action_ref->[$ind] |= $PAR; - return; - } - # This ain't no list. We'll want to end all of them. - if ($self->{__listnum}) - { - $self->endlist( - num_lists => $self->{__listnum}, - prev_ref => $prev_ref, - line_action_ref => \$para_action_ref->[$ind] - ); - } - return; - } - - # If numbers with more than one digit grow to the left instead of - # to the right, the prefix will shrink and we'll fail to match the - # right list. We need to account for this. - my $prefix_alternate; - if (length("" . $number) > 1) - { - $prefix_alternate = (" " x (length("" . $number) - 1)) . $prefix; - } - - # Maybe we're going back up to a previous list - for ( - $i = $self->{__listnum} - 1; - ($i >= 0) && ($prefix ne $self->{__listprefix}->[$i]); - $i-- - ) - { - if (length("" . $number) > 1) - { - last if $prefix_alternate eq $self->{__listprefix}->[$i]; - } - } - - my $islist; - - # Measure the indent from where the text starts, not where the - # prefix starts. This won't screw anything up, and if we don't do - # it, the next line might appear to be indented relative to this - # line, and get tagged as a new paragraph. - my $bullets = $self->{bullets}; - my $bullets_ordered = $self->{bullets_ordered}; - my $term_match = $self->{__term_match}; - my ($total_prefix) = - $para_lines_ref->[$ind] =~ /^(\s*[${bullets}${bullets_ordered}\w]+.\s*)/; - # a DL indent starts from the edge of the term, plus indent_width - if ($term) - { - ($total_prefix) = $para_lines_ref->[$ind] =~ /^(\s*)${term_match}.$/; - $total_prefix .= " " x $self->{indent_width}; - } - - # Of course, we only use it if it really turns out to be a list. - - $islist = 1; - $i++; - if (($i > 0) && ($i != $self->{__listnum})) - { - $self->endlist( - num_lists => $self->{__listnum} - $i, - prev_ref => $prev_ref, - line_action_ref => \$para_action_ref->[$ind] - ); - $islist = 0; - } - elsif (!$self->{__listnum} || ($i != $self->{__listnum})) - { - if ( - ($para_line_indent_ref->[$ind] > 0) - || $ind == 0 - || ($ind > 0 && ($para_lines_ref->[$ind - 1] =~ /^\s*$/)) - || ( $ind > 0 - && $para_action_ref->[$ind - 1] & ($BREAK | $HEADER | $CAPS)) - ) - { - $islist = $self->startlist( - prefix => $prefix, - number => $number, - rawprefix => $rawprefix, - term => $term, - para_lines_ref => $para_lines_ref, - para_action_ref => $para_action_ref, - ind => $ind, - prev_ref => $prev_ref, - total_prefix => $total_prefix - ); - } - else - { - - # We have something like this: "- foo" which usually - # turns out not to be a list. - return; - } - } - - $self->continuelist( - para_lines_ref => $para_lines_ref, - para_action_ref => $para_action_ref, - ind => $ind, - term => $term - ) - if ($self->{__mode} & $LIST); - $para_line_indent_ref->[$ind] = length($total_prefix) if $islist; -} # liststuff - -# figure out the table type of this table, if any -sub get_table_type ($%) -{ - my $self = shift; - my %args = ( - rows_ref => undef, - para_len => 0, - @_ - ); - my $table_type = 0; - if ( $self->{table_type}->{DELIM} - && $self->is_delim_table(%args)) - { - $table_type = $TAB_DELIM; - } - elsif ($self->{table_type}->{ALIGN} - && $self->is_aligned_table(%args)) - { - $table_type = $TAB_ALIGN; - } - elsif ($self->{table_type}->{PGSQL} - && $self->is_pgsql_table(%args)) - { - $table_type = $TAB_PGSQL; - } - elsif ($self->{table_type}->{BORDER} - && $self->is_border_table(%args)) - { - $table_type = $TAB_BORDER; - } - - return $table_type; -} - -# check if the given paragraph-array is an aligned table -sub is_aligned_table ($%) -{ - my $self = shift; - my %args = ( - rows_ref => undef, - para_len => 0, - @_ - ); - my $rows_ref = $args{rows_ref}; - my $para_len = $args{para_len}; - - # TABLES: spot and mark up tables. We combine the lines of the - # paragraph using the string bitwise or (|) operator, the result - # being in $spaces. A character in $spaces is a space only if - # there was a space at that position in every line of the - # paragraph. $space can be used to search for contiguous spaces - # that occur on all lines of the paragraph. If this results in at - # least two columns, the paragraph is identified as a table. - - # Note that this sub must be called before checking for preformatted - # lines because a table may well have whitespace to the left, in - # which case it must not be incorrectly recognised as a preformat. - my @rows = @{$rows_ref}; - my @starts; - my $spaces = ''; - my $max = 0; - my $min = $para_len; - foreach my $row (@rows) - { - ($spaces |= $row) =~ tr/ /\xff/c; - $min = length $row if length $row < $min; - $max = length $row if $max < length $row; - } - $spaces = substr $spaces, 0, $min; - push(@starts, 0) unless $spaces =~ /^ /; - while ($spaces =~ /((?:^| ) +)(?=[^ ])/g) - { - push @starts, pos($spaces); - } - - if (2 <= @rows and 2 <= @starts) - { - return 1; - } - else - { - return 0; - } -} - -sub is_pgsql_table ($%) -{ - my $self = shift; - my %args = ( - rows_ref => undef, - para_len => 0, - @_ - ); - my $rows_ref = $args{rows_ref}; - my $para_len = $args{para_len}; - - # a PGSQL table can start with an optional table-caption, - # then it has a row of column headings separated by | - # then it has a row of ------+----- - # then it has one or more rows of column values separated by | - # then it has a row-count (N rows) - # Thus it must have at least 4 rows. - if (@{$rows_ref} < 4) - { - return 0; - } - - my @rows = @{$rows_ref}; - if ($rows[0] !~ /\|/ && $rows[0] =~ /^\s*\w+/) # possible caption - { - shift @rows; - } - if (@rows < 4) - { - return 0; - } - if ($rows[0] !~ /^\s*\w+\s+\|\s+/) # Colname | - { - return 0; - } - if ($rows[1] !~ /^\s*[-]+[+][-]+/) # ----+---- - { - return 0; - } - if ($rows[2] !~ /^\s*[^|]*\s+\|\s+/) # value | - { - return 0; - } - # check the last row for rowcount - if ($rows[$#rows] !~ /\(\d+\s+rows\)/) - { - return 0; - } - - return 1; -} - -sub is_border_table ($%) -{ - my $self = shift; - my %args = ( - rows_ref => undef, - para_len => 0, - @_ - ); - my $rows_ref = $args{rows_ref}; - my $para_len = $args{para_len}; - - # a BORDER table can start with an optional table-caption, - # then it has a row of +------+-----+ - # then it has a row of column headings separated by | - # then it has a row of +------+-----+ - # then it has one or more rows of column values separated by | - # then it has a row of +------+-----+ - # Thus it must have at least 5 rows. - # And note that it could be indented with spaces - if (@{$rows_ref} < 5) - { - return 0; - } - - my @rows = @{$rows_ref}; - if ($rows[0] !~ /\|/ && $rows[0] =~ /^\s*\w+/) # possible caption - { - shift @rows; - } - if (@rows < 5) - { - return 0; - } - if ($rows[0] !~ /^\s*[+][-]+[+][-]+[+][-+]*$/) # +----+----+ - { - return 0; - } - if ($rows[1] !~ /^\s*\|\s*\w+\s+\|\s+.*\|$/) # | Colname | - { - return 0; - } - if ($rows[2] !~ /^\s*[+][-]+[+][-]+[+][-+]*$/) # +----+----+ - { - return 0; - } - if ($rows[3] !~ /^\s*\|\s*[^|]*\s+\|\s+.*\|$/) # | value | - { - return 0; - } - # check the last row for +------+------+ - if ($rows[$#rows] !~ /^\s*[+][-]+[+][-]+[+][-+]*$/) # +----+----+ - { - return 0; - } - - return 1; -} # is_border_table - -sub is_delim_table ($%) -{ - my $self = shift; - my %args = ( - rows_ref => undef, - para_len => 0, - @_ - ); - my $rows_ref = $args{rows_ref}; - my $para_len = $args{para_len}; - - # a DELIM table can start with an optional table-caption, - # then it has at least two rows which start and end and are - # punctuated by a non-alphanumeric delimiter. - # - # | val1 | val2 | - # | val3 | val4 | - # - # And note that it could be indented with spaces - if (@{$rows_ref} < 2) - { - return 0; - } - - my @rows = @{$rows_ref}; - if ($rows[0] !~ /[^\w\s]/ && $rows[0] =~ /^\s*\w+/) # possible caption - { - shift @rows; - } - if (@rows < 2) - { - return 0; - } - # figure out if the row starts with a possible delimiter - my $delim = ''; - if ($rows[0] =~ /^\s*([^a-zA-Z0-9])/) - { - $delim = $1; - # have to get rid of ^ and [] - $delim =~ s/\^//g; - $delim =~ s/\[//g; - $delim =~ s/\]//g; - if (!$delim) # no delimiter after all - { - return 0; - } - } - else - { - return 0; - } - # There needs to be at least three delimiters in the row - my @all_delims = ($rows[0] =~ /[${delim}]/g); - my $total_num_delims = @all_delims; - if ($total_num_delims < 3) - { - return 0; - } - # All rows must start and end with the delimiter - # and have $total_num_delims number of them - foreach my $row (@rows) - { - if ($row !~ /^\s*[${delim}]/) - { - return 0; - } - if ($row !~ /[${delim}]\s*$/) - { - return 0; - } - @all_delims = ($row =~ /[${delim}]/g); - if (@all_delims != $total_num_delims) - { - return 0; - } - } - - return 1; -} # is_delim_table - -sub tablestuff ($%) -{ - my $self = shift; - my %args = ( - table_type => 0, - rows_ref => undef, - para_len => 0, - @_ - ); - my $table_type = $args{table_type}; - if ($table_type eq $TAB_ALIGN) - { - return $self->make_aligned_table(%args); - } - if ($table_type eq $TAB_PGSQL) - { - return $self->make_pgsql_table(%args); - } - if ($table_type eq $TAB_BORDER) - { - return $self->make_border_table(%args); - } - if ($table_type eq $TAB_DELIM) - { - return $self->make_delim_table(%args); - } -} # tablestuff - -sub make_aligned_table ($%) -{ - my $self = shift; - my %args = ( - rows_ref => undef, - para_len => 0, - @_ - ); - my $rows_ref = $args{rows_ref}; - my $para_len = $args{para_len}; - - # TABLES: spot and mark up tables. We combine the lines of the - # paragraph using the string bitwise or (|) operator, the result - # being in $spaces. A character in $spaces is a space only if - # there was a space at that position in every line of the - # paragraph. $space can be used to search for contiguous spaces - # that occur on all lines of the paragraph. If this results in at - # least two columns, the paragraph is identified as a table. - - # Note that this sub must be called before checking for preformatted - # lines because a table may well have whitespace to the left, in - # which case it must not be incorrectly recognised as a preformat. - my @rows = @{$rows_ref}; - my @starts; - my @ends; - my $spaces; - my $max = 0; - my $min = $para_len; - foreach my $row (@rows) - { - ($spaces |= $row) =~ tr/ /\xff/c; - $min = length $row if length $row < $min; - $max = length $row if $max < length $row; - } - $spaces = substr $spaces, 0, $min; - push(@starts, 0) unless $spaces =~ /^ /; - while ($spaces =~ /((?:^| ) +)(?=[^ ])/g) - { - push @ends, pos($spaces) - length $1; - push @starts, pos($spaces); - } - shift(@ends) if $spaces =~ /^ /; - push(@ends, $max); - - # Two or more rows and two or more columns indicate a table. - if (2 <= @rows and 2 <= @starts) - { - $self->{__mode} |= $TABLE; - - # For each column, guess whether it should be left, centre or - # right aligned by examining all cells in that column for space - # to the left or the right. A simple majority among those cells - # that actually have space to one side or another decides (if no - # alignment gets a majority, left alignment wins by default). - my @align; - my $cell = ''; - foreach my $col (0 .. $#starts) - { - my @count = (0, 0, 0, 0); - foreach my $row (@rows) - { - my $width = $ends[$col] - $starts[$col]; - $cell = substr $row, $starts[$col], $width; - ++$count[($cell =~ /^ / ? 2 : 0) + - ($cell =~ / $/ || length($cell) < $width ? 1 : 0)]; - } - $align[$col] = 0; - my $population = $count[1] + $count[2] + $count[3]; - foreach (1 .. 3) - { - if ($count[$_] * 2 > $population) - { - $align[$col] = $_; - last; - } - } - } - - foreach my $row (@rows) - { - $row = join '', $self->get_tag('TR'), ( - map { - $cell = substr $row, $starts[$_], $ends[$_] - $starts[$_]; - $cell =~ s/^ +//; - $cell =~ s/ +$//; - - if ($self->{escape_HTML_chars}) - { - $cell = escape($cell); - } - - ( - $self->get_tag( - 'TD', - inside_tag => ( - $self->{xhtml} ? $xhtml_alignments[$align[$_]] - : ( - $self->{lower_case_tags} - ? $lc_alignments[$align[$_]] - : $alignments[$align[$_]] - ) - ) - ), - $cell, - $self->close_tag('TD') - ); - } 0 .. $#starts - ), - $self->close_tag('TR'); - } - - # put the <TABLE> around the rows - my $tag; - if ($self->{xhtml}) - { - $tag = $self->get_tag('TABLE', inside_tag => ' summary=""'); - } - else - { - $tag = $self->get_tag('TABLE'); - } - $rows[0] = join("\n", $tag, $rows[0]); - $tag = $self->close_tag('TABLE', tag_type => 'end'); - $rows[$#rows] .= "\n${tag}"; - @{$rows_ref} = @rows; - return 1; - } - else - { - return 0; - } -} # make_aligned_table - -sub make_pgsql_table ($%) -{ - my $self = shift; - my %args = ( - rows_ref => undef, - para_len => 0, - @_ - ); - my $rows_ref = $args{rows_ref}; - my $para_len = $args{para_len}; - - # a PGSQL table can start with an optional table-caption, - # then it has a row of column headings separated by | - # then it has a row of ------+----- - # then it has one or more rows of column values separated by | - # then it has a row-count (N rows) - # Thus it must have at least 4 rows. - my @rows = @{$rows_ref}; - my $caption = ''; - if ($rows[0] !~ /\|/ && $rows[0] =~ /^\s*\w+/) # possible caption - { - $caption = shift @rows; - } - my @headings = split(/\s+\|\s+/, shift @rows); - # skip the ----+--- line - shift @rows; - # grab the N rows line - my $n_rows = pop @rows; - - # now start making the table - my @tab_lines = (); - my $tag; - my $tag2; - if ($self->{xhtml}) - { - $tag = $self->get_tag('TABLE', inside_tag => ' border="1" summary=""'); - } - else - { - $tag = $self->get_tag('TABLE', inside_tag => ' border="1"'); - } - push @tab_lines, "$tag\n"; - if ($caption) - { - $caption =~ s/^\s+//; - $caption =~ s/\s+$//; - $tag = $self->get_tag('CAPTION'); - $tag2 = $self->close_tag('CAPTION'); - $caption = join('', $tag, $caption, $tag2, "\n"); - push @tab_lines, $caption; - } - # table header - my $thead = ''; - $tag = $self->get_tag('THEAD'); - $thead .= $tag; - $tag = $self->get_tag('TR'); - $thead .= $tag; - foreach my $col (@headings) - { - $col =~ s/^\s+//; - $col =~ s/\s+$//; - $tag = $self->get_tag('TH'); - $tag2 = $self->close_tag('TH'); - $thead .= join('', $tag, $col, $tag2); - } - $tag = $self->close_tag('TR'); - $thead .= $tag; - $tag = $self->close_tag('THEAD'); - $thead .= $tag; - push @tab_lines, "${thead}\n"; - $tag = $self->get_tag('TBODY'); - push @tab_lines, "$tag\n"; - - # each row - foreach my $row (@rows) - { - my $this_row = ''; - $tag = $self->get_tag('TR'); - $this_row .= $tag; - my @cols = split(/\|/, $row); - foreach my $cell (@cols) - { - $cell =~ s/^\s+//; - $cell =~ s/\s+$//; - if ($self->{escape_HTML_chars}) - { - $cell = escape($cell); - } - if (!$cell) - { - $cell = ' '; - } - $tag = $self->get_tag('TD'); - $tag2 = $self->close_tag('TD'); - $this_row .= join('', $tag, $cell, $tag2); - } - $tag = $self->close_tag('TR'); - $this_row .= $tag; - push @tab_lines, "${this_row}\n"; - } - - # end the table - $tag = $self->close_tag('TBODY'); - push @tab_lines, "$tag\n"; - $tag = $self->get_tag('TABLE', tag_type => 'end'); - push @tab_lines, "$tag\n"; - - # and add the N rows line - $tag = $self->get_tag('P'); - push @tab_lines, "${tag}${n_rows}\n"; - if ($self->{xhtml}) - { - $tag = $self->get_tag('P', tag_type => 'end'); - $tab_lines[$#tab_lines] =~ s/\n/${tag}\n/; - } - - # replace the rows - @{$rows_ref} = @tab_lines; -} # make_pgsql_table - -sub make_border_table ($%) -{ - my $self = shift; - my %args = ( - rows_ref => undef, - para_len => 0, - @_ - ); - my $rows_ref = $args{rows_ref}; - my $para_len = $args{para_len}; - - # a BORDER table can start with an optional table-caption, - # then it has a row of +------+-----+ - # then it has a row of column headings separated by | - # then it has a row of +------+-----+ - # then it has one or more rows of column values separated by | - # then it has a row of +------+-----+ - my @rows = @{$rows_ref}; - my $caption = ''; - if ($rows[0] !~ /\|/ && $rows[0] =~ /^\s*\w+/) # possible caption - { - $caption = shift @rows; - } - # skip the +----+---+ line - shift @rows; - # get the head row and cut off the start and end | - my $head_row = shift @rows; - $head_row =~ s/^\s*\|//; - $head_row =~ s/\|$//; - my @headings = split(/\s+\|\s+/, $head_row); - # skip the +----+---+ line - shift @rows; - # skip the last +----+---+ line - pop @rows; - - # now start making the table - my @tab_lines = (); - my $tag; - if ($self->{xhtml}) - { - $tag = $self->get_tag('TABLE', inside_tag => ' border="1" summary=""'); - } - else - { - $tag = $self->get_tag('TABLE', inside_tag => ' border="1"'); - } - push @tab_lines, "$tag\n"; - if ($caption) - { - $caption =~ s/^\s+//; - $caption =~ s/\s+$//; - $tag = $self->get_tag('CAPTION'); - $caption = $tag . $caption; - $tag = $self->close_tag('CAPTION'); - $caption .= $tag; - push @tab_lines, "$caption\n"; - } - # table header - my $thead = ''; - $tag = $self->get_tag('THEAD'); - $thead .= $tag; - $tag = $self->get_tag('TR'); - $thead .= $tag; - foreach my $col (@headings) - { - $col =~ s/^\s+//; - $col =~ s/\s+$//; - $tag = $self->get_tag('TH'); - $thead .= $tag; - $thead .= $col; - $tag = $self->close_tag('TH'); - $thead .= $tag; - } - $tag = $self->close_tag('TR'); - $thead .= $tag; - $tag = $self->close_tag('THEAD'); - $thead .= $tag; - push @tab_lines, "${thead}\n"; - $tag = $self->get_tag('TBODY'); - push @tab_lines, "$tag\n"; - - # each row - foreach my $row (@rows) - { - # cut off the start and end | - $row =~ s/^\s*\|//; - $row =~ s/\|$//; - my $this_row = ''; - $tag = $self->get_tag('TR'); - $this_row .= $tag; - my @cols = split(/\|/, $row); - foreach my $cell (@cols) - { - $cell =~ s/^\s+//; - $cell =~ s/\s+$//; - if ($self->{escape_HTML_chars}) - { - $cell = escape($cell); - } - if (!$cell) - { - $cell = ' '; - } - $tag = $self->get_tag('TD'); - $this_row .= $tag; - $this_row .= $cell; - $tag = $self->close_tag('TD'); - $this_row .= $tag; - } - $tag = $self->close_tag('TR'); - $this_row .= $tag; - push @tab_lines, "${this_row}\n"; - } - - # end the table - $tag = $self->close_tag('TBODY'); - push @tab_lines, "$tag\n"; - $tag = $self->get_tag('TABLE', tag_type => 'end'); - push @tab_lines, "$tag\n"; - - # replace the rows - @{$rows_ref} = @tab_lines; -} # make_border_table - -sub make_delim_table ($%) -{ - my $self = shift; - my %args = ( - rows_ref => undef, - para_len => 0, - @_ - ); - my $rows_ref = $args{rows_ref}; - my $para_len = $args{para_len}; - - # a DELIM table can start with an optional table-caption, - # then it has at least two rows which start and end and are - # punctuated by a non-alphanumeric delimiter. - # A DELIM table has no table-header. - my @rows = @{$rows_ref}; - my $caption = ''; - if ($rows[0] !~ /\|/ && $rows[0] =~ /^\s*\w+/) # possible caption - { - $caption = shift @rows; - } - # figure out the delimiter - my $delim = ''; - if ($rows[0] =~ /^\s*([^a-zA-Z0-9])/) - { - $delim = $1; - } - else - { - return 0; - } - - # now start making the table - my @tab_lines = (); - my $tag; - if ($self->{xhtml}) - { - $tag = $self->get_tag('TABLE', inside_tag => ' border="1" summary=""'); - } - else - { - $tag = $self->get_tag('TABLE', inside_tag => ' border="1"'); - } - push @tab_lines, "$tag\n"; - if ($caption) - { - $caption =~ s/^\s+//; - $caption =~ s/\s+$//; - $tag = $self->get_tag('CAPTION'); - $caption = $tag . $caption; - $tag = $self->close_tag('CAPTION'); - $caption .= $tag; - push @tab_lines, "$caption\n"; - } - - # each row - foreach my $row (@rows) - { - # cut off the start and end delimiter - $row =~ s/^\s*[${delim}]//; - $row =~ s/[${delim}]$//; - my $this_row = ''; - $tag = $self->get_tag('TR'); - $this_row .= $tag; - my @cols = split(/[${delim}]/, $row); - foreach my $cell (@cols) - { - $cell =~ s/^\s+//; - $cell =~ s/\s+$//; - if ($self->{escape_HTML_chars}) - { - $cell = escape($cell); - } - if (!$cell) - { - $cell = ' '; - } - $tag = $self->get_tag('TD'); - $this_row .= $tag; - $this_row .= $cell; - $tag = $self->close_tag('TD'); - $this_row .= $tag; - } - $tag = $self->close_tag('TR'); - $this_row .= $tag; - push @tab_lines, "${this_row}\n"; - } - - # end the table - $tag = $self->get_tag('TABLE', tag_type => 'end'); - push @tab_lines, "$tag\n"; - - # replace the rows - @{$rows_ref} = @tab_lines; -} # make_delim_table - -# Returns true if the passed string is considered to be preformatted -sub is_preformatted ($$) -{ - my $self = shift; - my $line = shift; - - my $pre_white_min = $self->{preformat_whitespace_min}; - my $result = ( - ($line =~ /\s{$pre_white_min,}\S+/o) # whitespaces - || ($line =~ /\.{$pre_white_min,}\S+/o) - ); # dots - return $result; -} - -# modifies the given string, -# and returns the front preformatted part -sub split_end_explicit_preformat ($%) -{ - my $self = shift; - my %args = ( - para_ref => undef, - @_ - ); - my $para_ref = $args{para_ref}; - - my $tag = ''; - my $pre_str = ''; - my $post_str = ''; - if ($self->{__mode} & $PRE_EXPLICIT) - { - my $pe_mark = $self->{preformat_end_marker}; - if (${para_ref} =~ /$pe_mark/io) - { - ($pre_str, $post_str) = split(/$pe_mark/, ${$para_ref}, 2); - if ($self->{escape_HTML_chars}) - { - $pre_str = escape($pre_str); - } - $tag = $self->close_tag('PRE'); - $pre_str .= "${tag}\n"; - $self->{__mode} ^= (($PRE | $PRE_EXPLICIT) & $self->{__mode}); - } - else # no end -- the whole thing is preformatted - { - $pre_str = ${$para_ref}; - if ($self->{escape_HTML_chars}) - { - $pre_str = escape($pre_str); - } - ${$para_ref} = ''; - } - } - return $pre_str; -} # split_end_explicit_preformat - -sub endpreformat ($%) -{ - my $self = shift; - my %args = ( - para_lines_ref => undef, - para_action_ref => undef, - ind => 0, - prev_ref => undef, - @_ - ); - my $para_lines_ref = $args{para_lines_ref}; - my $para_action_ref = $args{para_action_ref}; - my $ind = $args{ind}; - my $prev_ref = $args{prev_ref}; - - my $tag = ''; - if ($self->{__mode} & $PRE_EXPLICIT) - { - my $pe_mark = $self->{preformat_end_marker}; - if ($para_lines_ref->[$ind] =~ /$pe_mark/io) - { - if ($ind == 0) - { - $tag = $self->close_tag('PRE'); - $para_lines_ref->[$ind] = "${tag}\n"; - } - else - { - $tag = $self->close_tag('PRE'); - $para_lines_ref->[$ind - 1] .= "${tag}\n"; - $para_lines_ref->[$ind] = ""; - } - $self->{__mode} ^= (($PRE | $PRE_EXPLICIT) & $self->{__mode}); - $para_action_ref->[$ind] |= $END; - } - return; - } - - if ( - !$self->is_preformatted($para_lines_ref->[$ind]) - && ( - $self->{endpreformat_trigger_lines} == 1 - || ($ind + 1 < @{$para_lines_ref} - && !$self->is_preformatted($para_lines_ref->[$ind + 1])) - || $ind + 1 >= @{$para_lines_ref} # last line of para - ) - ) - { - if ($ind == 0) - { - $tag = $self->close_tag('PRE'); - ${$prev_ref} = "${tag}\n"; - } - else - { - $tag = $self->close_tag('PRE'); - $para_lines_ref->[$ind - 1] .= "${tag}\n"; - } - $self->{__mode} ^= ($PRE & $self->{__mode}); - $para_action_ref->[$ind] |= $END; - } -} # endpreformat - -sub preformat ($%) -{ - my $self = shift; - my %args = ( - mode_ref => undef, - line_ref => undef, - line_action_ref => undef, - prev_ref => undef, - next_ref => undef, - prev_action_ref => undef, - @_ - ); - my $mode_ref = $args{mode_ref}; - my $line_ref = $args{line_ref}; - my $line_action_ref = $args{line_action_ref}; - my $prev_ref = $args{prev_ref}; - my $next_ref = $args{next_ref}; - my $prev_action_ref = $args{prev_action_ref}; - - my $tag = ''; - if ($self->{use_preformat_marker}) - { - my $pstart = $self->{preformat_start_marker}; - if (${$line_ref} =~ /$pstart/io) - { - if (${$prev_ref} =~ s/<P>$//) - { - pop @{$self->{__tags}}; - } - $tag = - $self->get_tag('PRE', inside_tag => " class='quote_explicit'"); - ${$line_ref} = "${tag}\n"; - ${$mode_ref} |= $PRE | $PRE_EXPLICIT; - ${$line_action_ref} |= $PRE; - return; - } - } - - if ( - !(${$line_action_ref} & $MAILQUOTE) - && !(${$prev_action_ref} & $MAILQUOTE) - && ( - $self->{preformat_trigger_lines} == 0 - || ( - $self->is_preformatted(${$line_ref}) - && ( - $self->{preformat_trigger_lines} == 1 - || (defined $next_ref - && $self->is_preformatted(${$next_ref})) - ) - ) - ) - ) - { - if (${$prev_ref} =~ s/<P>$//) - { - pop @{$self->{__tags}}; - } - $tag = $self->get_tag('PRE'); - ${$line_ref} =~ s/^/${tag}\n/; - ${$mode_ref} |= $PRE; - ${$line_action_ref} |= $PRE; - } -} # preformat - -sub make_new_anchor ($$) -{ - my $self = shift; - my $heading_level = shift; - - my ($anchor, $i); - - return sprintf("%d", $self->{__non_header_anchor}++) if (!$heading_level); - - $anchor = "section"; - $self->{__heading_count}->[$heading_level - 1]++; - - # Reset lower order counters - for ($i = @{$self->{__heading_count}}; $i > $heading_level; $i--) - { - $self->{__heading_count}->[$i - 1] = 0; - } - - for ($i = 0; $i < $heading_level; $i++) - { - $self->{__heading_count}->[$i] = 1 - if !$self->{__heading_count}->[$i]; # In case they skip any - $anchor .= sprintf("_%d", $self->{__heading_count}->[$i]); - } - chomp($anchor); - $anchor; -} # make_new_anchor - -sub anchor_mail ($$) -{ - my $self = shift; - my $line_ref = shift; - - if ($self->{make_anchors}) - { - my ($anchor) = $self->make_new_anchor(0); - if ($self->{lower_case_tags}) - { - ${$line_ref} =~ s/([^ ]*)/<a name="$anchor">$1<\/a>/; - } - else - { - ${$line_ref} =~ s/([^ ]*)/<A NAME="$anchor">$1<\/A>/; - } - } -} # anchor_mail - -sub anchor_heading ($$$) -{ - my $self = shift; - my $level = shift; - my $line_ref = shift; - - if ($self->{dict_debug} & 8) - { - print STDERR "anchor_heading: ", ${$line_ref}, "\n"; - } - if ($self->{make_anchors}) - { - my ($anchor) = $self->make_new_anchor($level); - if ($self->{lower_case_tags}) - { - ${$line_ref} =~ s/(<h.>)(.*)(<\/h.>)/$1<a name="$anchor">$2<\/a>$3/; - } - else - { - ${$line_ref} =~ s/(<H.>)(.*)(<\/H.>)/$1<A NAME="$anchor">$2<\/A>$3/; - } - } - if ($self->{dict_debug} & 8) - { - print STDERR "anchor_heading(after): ", ${$line_ref}, "\n"; - } -} # anchor_heading - -sub heading_level ($$) -{ - my $self = shift; - - my ($style) = @_; - $self->{__heading_styles}->{$style} = ++$self->{__num_heading_styles} - if !$self->{__heading_styles}->{$style}; - $self->{__heading_styles}->{$style}; -} # heading_level - -sub is_ul_list_line ($%) -{ - my $self = shift; - my %args = ( - line => undef, - @_ - ); - my $line = $args{line}; - - my ($prefix, $number, $rawprefix, $term) = $self->listprefix($line); - if ($prefix && !$number) - { - return 1; - } - return 0; -} - -sub is_heading ($%) -{ - my $self = shift; - my %args = ( - line_ref => undef, - next_ref => undef, - @_ - ); - my $line_ref = $args{line_ref}; - my $next_ref = $args{next_ref}; - - if ( ${$line_ref} !~ /^\s*$/ - && !$self->is_ul_list_line(line => ${$line_ref}) - && defined $next_ref - && ${$next_ref} =~ /^\s*[-=*.~+]+\s*$/) - { - my ($hoffset, $heading) = ${$line_ref} =~ /^(\s*)(.+)$/; - $hoffset = "" unless defined($hoffset); - $heading = "" unless defined($heading); - # Unescape chars so we get an accurate length - $heading =~ s/&[^;]+;/X/g; - my ($uoffset, $underline) = ${$next_ref} =~ /^(\s*)(\S+)\s*$/; - $uoffset = "" unless defined($uoffset); - $underline = "" unless defined($underline); - my ($lendiff, $offsetdiff); - $lendiff = length($heading) - length($underline); - $lendiff *= -1 if $lendiff < 0; - - $offsetdiff = length($hoffset) - length($uoffset); - $offsetdiff *= -1 if $offsetdiff < 0; - if ( ($lendiff <= $self->{underline_length_tolerance}) - || ($offsetdiff <= $self->{underline_offset_tolerance})) - { - return 1; - } - } - - return 0; - -} # is_heading - -# make a heading -# assumes is_heading is true -sub heading ($%) -{ - my $self = shift; - my %args = ( - line_ref => undef, - next_ref => undef, - @_ - ); - my $line_ref = $args{line_ref}; - my $next_ref = $args{next_ref}; - - my ($hoffset, $heading) = ${$line_ref} =~ /^(\s*)(.+)$/; - $hoffset = "" unless defined($hoffset); - $heading = "" unless defined($heading); - $heading =~ s/&[^;]+;/X/g; # Unescape chars so we get an accurate length - my ($uoffset, $underline) = ${$next_ref} =~ /^(\s*)(\S+)\s*$/; - $uoffset = "" unless defined($uoffset); - $underline = "" unless defined($underline); - - $underline = substr($underline, 0, 1); - - # Call it a different style if the heading is in all caps. - $underline .= "C" if $self->iscaps(${$line_ref}); - ${$next_ref} = " "; # Eat the underline - $self->{__heading_level} = $self->heading_level($underline); - if ($self->{escape_HTML_chars}) - { - ${$line_ref} = escape(${$line_ref}); - } - $self->tagline("H" . $self->{__heading_level}, $line_ref); - $self->anchor_heading($self->{__heading_level}, $line_ref); -} # heading - -# check if the given line matches a custom heading -sub is_custom_heading ($%) -{ - my $self = shift; - my %args = ( - line => undef, - @_ - ); - my $line = $args{line}; - - foreach my $reg (@{$self->{custom_heading_regexp}}) - { - return 1 if ($line =~ /$reg/); - } - return 0; -} # is_custom_heading - -sub custom_heading ($%) -{ - my $self = shift; - my %args = ( - line_ref => undef, - @_ - ); - my $line_ref = $args{line_ref}; - - my $level; - my $i = 0; - foreach my $reg (@{$self->{custom_heading_regexp}}) - { - if (${$line_ref} =~ /$reg/) - { - if ($self->{explicit_headings}) - { - $level = $i + 1; - } - else - { - $level = $self->heading_level("Cust" . $i); - } - if ($self->{escape_HTML_chars}) - { - ${$line_ref} = escape(${$line_ref}); - } - $self->tagline("H" . $level, $line_ref); - $self->anchor_heading($level, $line_ref); - last; - } - $i++; - } -} # custom_heading - -sub unhyphenate_para ($$) -{ - my $self = shift; - my $para_ref = shift; - - # Treating this whole paragraph as one string, look for - # 1 - whitespace - # 2 - a word (ending in a hyphen, followed by a newline) - # 3 - whitespace (starting on the next line) - # 4 - a word with its punctuation - # Substitute this with - # 1-whitespace 2-word 4-word newline 3-whitespace - # We preserve the 3-whitespace because we don't want to mess up - # our existing indentation. - ${$para_ref} =~ - /(\s*)([^\W\d_]*)\-\n(\s*)([^\W\d_]+[\)\}\]\.,:;\'\"\>]*\s*)/s; - ${$para_ref} =~ -s/(\s*)([^\W\d_]*)\-\n(\s*)([^\W\d_]+[\)\}\]\.,:;\'\"\>]*\s*)/$1$2$4\n$3/gs; -} # unhyphenate_para - -sub tagline ($$$) -{ - my $self = shift; - my $tag = shift; - my $line_ref = shift; - - chomp ${$line_ref}; # Drop newline - my $tag1 = $self->get_tag($tag); - my $tag2 = $self->close_tag($tag); - ${$line_ref} =~ s/^\s*(.*)$/${tag1}$1${tag2}\n/; -} # tagline - -sub iscaps -{ - my $self = shift; - local ($_) = @_; - - my $min_caps_len = $self->{min_caps_length}; - - # This is ugly, but I don't know a better way to do it. - # (And, yes, I could use the literal characters instead of the - # numeric codes, but this keeps the script 8-bit clean, which will - # save someone a big headache when they transfer via ASCII ftp. -/^[^a-z\341\343\344\352\353\354\363\370\337\373\375\342\345\347\350\355\357\364\365\376\371\377\340\346\351\360\356\361\362\366\372\374<]*[A-Z\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\330\331\332\333\334\335\336]{$min_caps_len,}[^a-z\341\343\344\352\353\354\363\370\337\373\375\342\345\347\350\355\357\364\365\376\371\377\340\346\351\360\356\361\362\366\372\374<]*$/; -} # iscaps - -sub caps -{ - my $self = shift; - my %args = ( - line_ref => undef, - line_action_ref => undef, - @_ - ); - my $line_ref = $args{line_ref}; - my $line_action_ref = $args{line_action_ref}; - - if ( $self->{caps_tag} - && $self->iscaps(${$line_ref})) - { - $self->tagline($self->{caps_tag}, $line_ref); - ${$line_action_ref} |= $CAPS; - } -} # caps - -sub do_delim -{ - my $self = shift; - my %args = ( - line_ref => undef, - line_action_ref => undef, - delim => '*', - tag => 'STRONG', - @_ - ); - my $line_ref = $args{line_ref}; - my $line_action_ref = $args{line_action_ref}; - my $delim = $args{delim}; - my $tag = $args{tag}; - - if ($delim eq '#') # special treatment of # for the #num case - { - ${$line_ref} =~ -s/#([^0-9#](?![^#]*(?:<li>|<LI>|<P>|<p>))[^#]*[^# \t\n])#/<${tag}>$1<\/${tag}>/gs; - ${$line_ref} =~ s/\B#([a-zA-Z])#\B/<${tag}>$1<\/${tag}>/gs; - } - elsif ($delim eq '^') - { - ${$line_ref} =~ -s/\^((?![^^]*(?:<li>|<LI>|<p>|<P>))(\w|["'<>])[^^]*)\^/<${tag}>$1<\/${tag}>/gs; - ${$line_ref} =~ s/\B\^([a-zA-Z])\^\B/<${tag}>$1<\/${tag}>/gs; - } - elsif (length($delim) eq 1) # one-character, general - { - ${$line_ref} =~ -s/(?<![${delim}])[${delim}](?![^${delim}]*(?:<li>|<LI>|<p>|<P>))((\w|["'<>])[^${delim}]*)[${delim}]/<${tag}>$1<\/${tag}>/gs; - ${$line_ref} =~ - s/\B[${delim}]([a-zA-Z])[${delim}]\B/<${tag}>$1<\/${tag}>/gs; - } - else - { - ${$line_ref} =~ -s/(?<!${delim})${delim}((\w|["'])(\w|[-\s\.;:,!?"'])*[^\s])${delim}/<${tag}>$1<\/${tag}>/gs; - ${$line_ref} =~ s/${delim}]([a-zA-Z])${delim}/<${tag}>$1<\/${tag}>/gs; - } -} # do_delim - -# Convert very simple globs to regexps -sub glob2regexp -{ - my ($glob) = @_; - - # Escape funky chars - $glob =~ s/[^\w\[\]\*\?\|\\]/\\$&/g; - my ($regexp, $i, $len, $escaped) = ("", 0, length($glob), 0); - - for (; $i < $len; $i++) - { - my $char = substr($glob, $i, 1); - if ($escaped) - { - $escaped = 0; - $regexp .= $char; - next; - } - if ($char eq "\\") - { - $escaped = 1; - next; - $regexp .= $char; - } - if ($char eq "?") - { - $regexp .= "."; - next; - } - if ($char eq "*") - { - $regexp .= ".*"; - next; - } - $regexp .= $char; # Normal character - } - join('', "\\b", $regexp, "\\b"); -} # glob2regexp - -sub add_regexp_to_links_table ($$$$) -{ - my $self = shift; - my ($key, $URL, $switches) = @_; - - # No sense adding a second one if it's already in there. - # It would never get used. - if (!$self->{__links_table}->{$key}) - { - - # Keep track of the order they were added so we can - # look for matches in the same order - push(@{$self->{__links_table_order}}, ($key)); - - $self->{__links_table}->{$key} = $URL; # Put it in The Table - $self->{__links_switch_table}->{$key} = $switches; - my $ind = @{$self->{__links_table_order}} - 1; - print STDERR " (", $ind, - ")\tKEY: $key\n\tVALUE: $URL\n\tSWITCHES: $switches\n\n" - if ($self->{dict_debug} & 1); - } - else - { - if ($self->{dict_debug} & 1) - { - print STDERR " Skipping entry. Key already in table.\n"; - print STDERR "\tKEY: $key\n\tVALUE: $URL\n\n"; - } - } -} # add_regexp_to_links_table - -sub add_literal_to_links_table ($$$$) -{ - my $self = shift; - my ($key, $URL, $switches) = @_; - - $key =~ s/(\W)/\\$1/g; # Escape non-alphanumeric chars - $key = "\\b$key\\b"; # Make a regexp out of it - $self->add_regexp_to_links_table($key, $URL, $switches); -} # add_literal_to_links_table - -sub add_glob_to_links_table ($$$$) -{ - my $self = shift; - my ($key, $URL, $switches) = @_; - - $self->add_regexp_to_links_table(glob2regexp($key), $URL, $switches); -} # add_glob_to_links_table - -# Parse the dictionary file. -# (see also load_dictionary_links, for things that were stripped) -sub parse_dict ($$$) -{ - my $self = shift; - - my ($dictfile, $dict) = @_; - - print STDERR "Parsing dictionary file $dictfile\n" - if ($self->{dict_debug} & 1); - - if ($dict =~ /->\s*->/) - { - my $message = "Two consecutive '->'s found in $dictfile\n"; - my $near; - - # Print out any useful context so they can find it. - ($near) = $dict =~ /([\S ]*\s*->\s*->\s*\S*)/; - $message .= "\n$near\n" if $near =~ /\S/; - die $message; - } - - my ($key, $URL, $switches, $options); - while ($dict =~ /\s*(.+)\s+\-+([iehos]+\-+)?\>\s*(.*\S+)\s*\n/ig) - { - $key = $1; - $options = $2; - $options = "" unless defined($options); - $URL = $3; - $switches = 0; - # Case insensitivity - $switches += $LINK_NOCASE if $options =~ /i/i; - # Evaluate as Perl code - $switches += $LINK_EVAL if $options =~ /e/i; - # provides HTML, not just URL - $switches += $LINK_HTML if $options =~ /h/i; - # Only do this link once - $switches += $LINK_ONCE if $options =~ /o/i; - # Only do this link once per section - $switches += $LINK_SECT_ONCE if $options =~ /s/i; - - $key =~ s/\s*$//; # Chop trailing whitespace - - if ($key =~ m|^/|) # Regexp - { - $key = substr($key, 1); - $key =~ s|/$||; # Allow them to forget the closing / - $self->add_regexp_to_links_table($key, $URL, $switches); - } - elsif ($key =~ /^\|/) # alternate regexp format - { - $key = substr($key, 1); - $key =~ s/\|$//; # Allow them to forget the closing | - $key =~ s|/|\\/|g; # Escape all slashes - $self->add_regexp_to_links_table($key, $URL, $switches); - } - elsif ($key =~ /\"/) - { - $key = substr($key, 1); - $key =~ s/\"$//; # Allow them to forget the closing " - $self->add_literal_to_links_table($key, $URL, $switches); - } - else - { - $self->add_glob_to_links_table($key, $URL, $switches); - } - } - -} # parse_dict - -sub setup_dict_checking ($) -{ - my $self = shift; - - # now create the replace funcs and precomile the regexes - my ($URL, $switches, $options, $tag1, $tag2); - my ($href, $r_sw); - my @subs; - my $i = 0; - foreach my $pattern (@{$self->{__links_table_order}}) - { - $switches = $self->{__links_switch_table}->{$pattern}; - - $href = $self->{__links_table}->{$pattern}; - - if (!($switches & $LINK_HTML)) - { - $href =~ s#/#\\/#g; - $href = ( - $self->{lower_case_tags} - ? join('', '<a href="', $href, '">$&<\\/a>') - : join('', '<A HREF="', $href, '">$&<\\/A>') - ); - } - else - { - # change the uppercase tags to lower case - if ($self->{lower_case_tags}) - { - $href =~ s#(</)([A-Z]*)(>)#${1}\L${2}${3}#g; - $href =~ s/(<)([A-Z]*)(>)/${1}\L${2}${3}/g; - # and the anchors - $href =~ s/(<)(A\s*HREF)([^>]*>)/$1\L$2$3/g; - } - $href =~ s#/#\\/#g; - } - - $r_sw = "s"; # Options for replacing - $r_sw .= "i" if ($switches & $LINK_NOCASE); - $r_sw .= "e" if ($switches & $LINK_EVAL); - - # Generate code for replacements. - # Create an anonymous subroutine for each replacement, - # and store its reference in an array. - # We need to do an "eval" to create these because we need to - # be able to treat the *contents* of the $href variable - # as if it were perl code, because sometimes the $href - # contains things which need to be evaluated, such as $& or $1, - # not just those cases where we have a "e" switch. - my $code = <<EOT; -\$self->{__repl_code}->[$i] = -sub { -my \$al = shift; -\$al =~ s/$pattern/$href/$r_sw; -return \$al; -}; -EOT - print STDERR $code if ($self->{dict_debug} & 2); - push @subs, $code; - - # compile searching pattern - if ($switches & $LINK_NOCASE) # i - { - $self->{__search_patterns}->[$i] = qr/$pattern/si; - } - else - { - $self->{__search_patterns}->[$i] = qr/$pattern/s; - } - $i++; - } - # now eval the replacements code string - my $codes = join('', @subs); - eval "$codes"; -} # setup_dict_checking - -sub in_link_context ($$$) -{ - my $self = shift; - my ($match, $before) = @_; - return 1 if $match =~ m@</?A>@i; # No links allowed inside match - - my ($final_open, $final_close); - if ($self->{lower_case_tags}) - { - $final_open = rindex($before, "<a ") - $[; - $final_close = rindex($before, "</a>") - $[; - } - else - { - $final_open = rindex($before, "<A ") - $[; - $final_close = rindex($before, "</A>") - $[; - } - - return 1 if ($final_open >= 0) # Link opened - && ( - ($final_close < 0) # and not closed or - || ($final_open > $final_close) - ); # one opened after last close - - # Now check to see if we're inside a tag, matching a tag name, - # or attribute name or value - $final_open = rindex($before, "<") - $[; - $final_close = rindex($before, ">") - $[; - ($final_open >= 0) # Tag opened - && ( - ($final_close < 0) # and not closed or - || ($final_open > $final_close) - ); # one opened after last close -} # in_link_context - -# apply links and formatting to this paragraph -sub apply_links ($%) -{ - my $self = shift; - my %args = ( - para_ref => undef, - para_action_ref => undef, - @_ - ); - my $para_ref = $args{para_ref}; - my $para_action_ref = $args{para_action_ref}; - - if ($self->{make_links} - && @{$self->{__links_table_order}}) - { - $self->check_dictionary_links( - line_ref => $para_ref, - line_action_ref => $para_action_ref - ); - } - if ($self->{bold_delimiter}) - { - my $tag = ($self->{lower_case_tags} ? 'strong' : 'STRONG'); - $self->do_delim( - line_ref => $para_ref, - line_action_ref => $para_action_ref, - delim => $self->{bold_delimiter}, - tag => $tag - ); - } - if ($self->{italic_delimiter}) - { - my $tag = ($self->{lower_case_tags} ? 'em' : 'EM'); - $self->do_delim( - line_ref => $para_ref, - line_action_ref => $para_action_ref, - delim => $self->{italic_delimiter}, - tag => $tag - ); - } - -} # apply_links - -# Check (and alter if need be) the bits in this line matching -# the patterns in the link dictionary. -sub check_dictionary_links ($%) -{ - my $self = shift; - my %args = ( - line_ref => undef, - line_action_ref => undef, - @_ - ); - my $line_ref = $args{line_ref}; - my $line_action_ref = $args{line_action_ref}; - - my ($switches, $options, $repl_func); - my ($linkme, $line_with_links); - - # for each pattern, check and alter the line - my $i = 0; - foreach my $pattern (@{$self->{__links_table_order}}) - { - $switches = $self->{__links_switch_table}->{$pattern}; - - # check the pattern - if ($switches & $LINK_ONCE) # Do link only once - { - $line_with_links = ''; - if (!$self->{__done_with_link}->[$i] - && ${$line_ref} =~ $self->{__search_patterns}->[$i]) - { - $self->{__done_with_link}->[$i] = 1; - $line_with_links .= $`; - $linkme = $&; - - ${$line_ref} = $'; - if (!$self->in_link_context($linkme, $line_with_links)) - { - print STDERR "Link rule $i matches $linkme\n" - if ($self->{dict_debug} & 4); - - # call the special subroutine already created to do - # this replacement - $repl_func = $self->{__repl_code}->[$i]; - $linkme = &$repl_func($linkme); - } - $line_with_links .= $linkme; - } - ${$line_ref} = $line_with_links . ${$line_ref}; - } - elsif ($switches & $LINK_SECT_ONCE) # Do link only once per section - { - $line_with_links = ''; - if (!$self->{__done_with_sect_link}->[$i] - && ${$line_ref} =~ $self->{__search_patterns}->[$i]) - { - $self->{__done_with_sect_link}->[$i] = 1; - $line_with_links .= $`; - $linkme = $&; - - ${$line_ref} = $'; - if (!$self->in_link_context($linkme, $line_with_links)) - { - print STDERR "Link rule $i matches $linkme\n" - if ($self->{dict_debug} & 4); - - # call the special subroutine already created to do - # this replacement - $repl_func = $self->{__repl_code}->[$i]; - $linkme = &$repl_func($linkme); - } - $line_with_links .= $linkme; - } - ${$line_ref} = $line_with_links . ${$line_ref}; - } - else - { - $line_with_links = ''; - while (${$line_ref} =~ $self->{__search_patterns}->[$i]) - { - $line_with_links .= $`; - $linkme = $&; - - ${$line_ref} = $'; - if (!$self->in_link_context($linkme, $line_with_links)) - { - print STDERR "Link rule $i matches $linkme\n" - if ($self->{dict_debug} & 4); - - # call the special subroutine already created to do - # this replacement - $repl_func = $self->{__repl_code}->[$i]; - $linkme = &$repl_func($linkme); - } - $line_with_links .= $linkme; - } - ${$line_ref} = $line_with_links . ${$line_ref}; - } - $i++; - } - ${$line_action_ref} |= $LINK; -} # check_dictionary_links - -sub load_dictionary_links ($) -{ - my $self = shift; - - @{$self->{__links_table_order}} = (); - %{$self->{__links_table}} = (); - - my $dict; - foreach $dict (@{$self->{links_dictionaries}}) - { - next unless $dict; - open(DICT, "$dict") || die "Can't open Dictionary file $dict\n"; - - my @lines = (); - while (<DICT>) - { - # skip lines that start with '#' - next if /^\#/; - # skip lines that end with unescaped ':' - next if /^.*[^\\]:\s*$/; - push @lines, $_; - } - close(DICT); - my $contents = join('', @lines); - $self->parse_dict($dict, $contents); - } - # last of all, do the system dictionary, already read in from DATA - if ($self->{__global_links_data}) - { - $self->parse_dict("DATA", $self->{__global_links_data}); - } - - $self->setup_dict_checking(); -} # load_dictionary_links - -# do_file_start -# extra stuff needed for the beginning -# Args: -# $self -# $para -# Return: -# processed $para string -sub do_file_start ($$$) -{ - my $self = shift; - my $outhandle = shift; - my $para = shift; - - if (!$self->{extract}) - { - my @para_lines = split(/\n/, $para); - my $first_line = $para_lines[0]; - - if ($self->{doctype}) - { - if ($self->{xhtml}) - { - print $outhandle -'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"', - "\n"; - print $outhandle - '"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">', - "\n"; - } - else - { - print $outhandle '<!DOCTYPE HTML PUBLIC "', $self->{doctype}, - "\">\n"; - } - } - print $outhandle $self->get_tag('HTML'), "\n"; - print $outhandle $self->get_tag('HEAD'), "\n"; - - # if --titlefirst is set and --title isn't, use the first line - # as the title. - if ($self->{titlefirst} && !$self->{title}) - { - my ($tit) = $first_line =~ /^ *(.*)/; # grab first line - $tit =~ s/ *$//; # strip trailing whitespace - $tit = escape($tit) if $self->{escape_HTML_chars}; - $self->{'title'} = $tit; - } - if (!$self->{title}) - { - $self->{'title'} = ""; - } - print $outhandle $self->get_tag('TITLE'), $self->{title}, - $self->close_tag('TITLE'), "\n"; - - if ($self->{append_head}) - { - open(APPEND, $self->{append_head}) - || die "Failed to open ", $self->{append_head}, "\n"; - while (<APPEND>) - { - print $outhandle $_; - } - close(APPEND); - } - - if ($self->{lower_case_tags}) - { - print $outhandle $self->get_tag( - 'META', - tag_type => 'empty', - inside_tag => " name=\"generator\" content=\"$PROG v$VERSION\"" - ), - "\n"; - } - else - { - print $outhandle $self->get_tag( - 'META', - tag_type => 'empty', - inside_tag => " NAME=\"generator\" CONTENT=\"$PROG v$VERSION\"" - ), - "\n"; - } - if ($self->{style_url}) - { - my $style_url = $self->{style_url}; - if ($self->{lower_case_tags}) - { - print $outhandle $self->get_tag( - 'LINK', - tag_type => 'empty', - inside_tag => -" rel=\"stylesheet\" type=\"text/css\" href=\"$style_url\"" - ), - "\n"; - } - else - { - print $outhandle $self->get_tag( - 'LINK', - tag_type => 'empty', - inside_tag => -" REL=\"stylesheet\" TYPE=\"text/css\" HREF=\"$style_url\"" - ), - "\n"; - } - } - print $outhandle $self->close_tag('HEAD'), "\n"; - if ($self->{body_deco}) - { - print $outhandle $self->get_tag('BODY', - inside_tag => $self->{body_deco}), "\n"; - } - else - { - print $outhandle $self->get_tag('BODY'), "\n"; - } - } - - if ($self->{prepend_file}) - { - if (-r $self->{prepend_file}) - { - open(PREPEND, $self->{prepend_file}); - while (<PREPEND>) - { - print $outhandle $_; - } - close(PREPEND); - } - else - { - print STDERR "Can't find or read file ", $self->{prepend_file}, - " to prepend.\n"; - } - } -} # do_file_start - -# do_init_call -# certain things, like reading link dictionaries, need to be -# done once -sub do_init_call ($) -{ - my $self = shift; - - if (!$self->{__call_init_done}) - { - push(@{$self->{links_dictionaries}}, ($self->{default_link_dict})) - if ($self->{make_links} && (-f $self->{default_link_dict})); - $self->deal_with_options(); - if ($self->{make_links}) - { - $self->load_dictionary_links(); - } - - # various initializations - $self->{__non_header_anchor} = 0; - $self->{__mode} = 0; - $self->{__listnum} = 0; - $self->{__list_nice_indent} = ''; - $self->{__list_indent} = []; - $self->{__tags} = []; - - $self->{__call_init_done} = 1; - } -} # do_init_call - -=head1 FILE FORMATS - -There are two files which are used which can affect the outcome of the -conversion. One is the link dictionary, which contains patterns (of how -to recognise http links and other things) and how to convert them. The -other is, naturally, the format of the input file itself. - -=head2 Link Dictionary - -A link dictionary file contains patterns to match, and what to convert -them to. It is called a "link" dictionary because it was intended to be -something which defined what a href link was, but it can be used for -more than that. However, if you wish to define your own links, it is -strongly advised to read up on regular expressions (regexes) because -this relies heavily on them. - -The file consists of comments (which are lines starting with #) -and blank lines, and link entries. -Each entry consists of a regular expression, a -> separator (with -optional flags), and a link "result". - -In the simplest case, with no flags, the regular expression -defines the pattern to look for, and the result says what part -of the regular expression is the actual link, and the link which -is generated has the href as the link, and the whole matched pattern -as the visible part of the link. The first character of the regular -expression is taken to be the separator for the regex, so one -could either use the traditional / separator, or something else -such as | (which can be helpful with URLs which are full of / characters). - -So, for example, an ftp URL might be defined as: - - |ftp:[\w/\.:+\-]+| -> $& - -This takes the whole pattern as the href, and the resultant link -has the same thing in the href as in the contents of the anchor. - -But sometimes the href isn't the whole pattern. - - /<URL:\s*(\S+?)\s*>/ --> $1 - -With the above regex, a () grouping marks the first subexpression, -which is represented as $1 (rather than $& the whole expression). -This entry matches a URL which was marked explicity as a URL -with the pattern <URL:foo> (note the < is shown as the -entity, not the actual character. This is because by the -time the links dictionary is checked, all such things have -already been converted to their HTML entity forms, unless, of course, -the escape_HTML_chars option was turned off) -This would give us a link in the form -<A HREF="foo"><URL:foo></A> - -B<The h flag> - -However, if we want more control over the way the link is constructed, -we can construct it ourself. If one gives the h flag, then the -"result" part of the entry is taken not to contain the href part of -the link, but the whole link. - -For example, the entry: - - /<URL:\s*(\S+?)\s*>/ -h-> <A HREF="$1">$1</A> - -will take <URL:foo> and give us <A HREF="foo">foo</A> - -However, this is a very powerful mechanism, because it -can be used to construct custom tags which aren't links at all. -For example, to flag *italicised words* the following -entry will surround the words with EM tags. - - /\B\*([a-z][a-z -]*[a-z])\*\B/ -hi-> <EM>$1</EM> - -B<The i flag> - -This turns on ignore case in the pattern matching. - -B<The e flag> - -This turns on execute in the pattern substitution. This really -only makes sense if h is turned on too. In that case, the "result" -part of the entry is taken as perl code to be executed, and the -result of that code is what replaces the pattern. - -B<The o flag> - -This marks the entry as a once-only link. This will convert the -first instance of a matching pattern, and ignore any others -further on. - -For example, the following pattern will take the first mention -of HTML::TextToHTML and convert it to a link to the module's home page. - - "HTML::TextToHTML" -io-> http://www.katspace.com/tools/text_to_html/ - -=head2 Input File Format - -For the most part, this module tries to use intuitive conventions for -determining the structure of the text input. Unordered lists are -marked by bullets; ordered lists are marked by numbers or letters; -in either case, an increase in indentation marks a sub-list contained -in the outer list. - -Headers (apart from custom headers) are distinguished by "underlines" -underneath them; headers in all-capitals are distinguished from -those in mixed case. All headers, both normal and custom headers, -are expected to start at the first line in a "paragraph". - -In other words, the following is a header: - - I am Head Man - ------------- - -But the following does not have a header: - - I am not a head Man, man - I am Head Man - ------------- - -Tables require a more rigid convention. A table must be marked as a -separate paragraph, that is, it must be surrounded by blank lines. -Tables come in different types. For a table to be parsed, its ---table_type option must be on, and the --make_tables option must be true. - -B<ALIGN Table Type> - -Columns must be separated by two or more spaces (this prevents -accidental incorrect recognition of a paragraph where interword spaces -happen to line up). If there are two or more rows in a paragraph and -all rows share the same set of (two or more) columns, the paragraph is -assumed to be a table. For example - - -e File exists. - -z File has zero size. - -s File has nonzero size (returns size). - -becomes - - <TABLE> - <TR><TD>-e</TD><TD>File exists.</TD></TR> - <TR><TD>-z</TD><TD>File has zero size.</TD></TR> - <TR><TD>-s</TD><TD>File has nonzero size (returns size).</TD></TR> - </TABLE> - -This guesses for each column whether it is intended to be left, -centre or right aligned. - -B<BORDER Table Type> - -This table type has nice borders around it, and will be rendered -with a border, like so: - - +---------+---------+ - | Column1 | Column2 | - +---------+---------+ - | val1 | val2 | - | val3 | val3 | - +---------+---------+ - -The above becomes - - <TABLE border="1"> - <THEAD><TR><TH>Column1</TH><TH>Column2</TH></TR></THEAD> - <TBODY> - <TR><TD>val1</TD><TD>val2</TD></TR> - <TR><TD>val3</TD><TD>val3</TD></TR> - </TBODY> - </TABLE> - -It can also have an optional caption at the start. - - My Caption - +---------+---------+ - | Column1 | Column2 | - +---------+---------+ - | val1 | val2 | - | val3 | val3 | - +---------+---------+ - -B<PGSQL Table Type> - -This format of table is what one gets from the output of a Postgresql -query. - - Column1 | Column2 - ---------+--------- - val1 | val2 - val3 | val3 - (2 rows) - -This can also have an optional caption at the start. -This table is also rendered with a border and table-headers like -the BORDER type. - -B<DELIM Table Type> - -This table type is delimited by non-alphanumeric characters, and has to -have at least two rows and two columns before it's recognised as a table. - -This one is delimited by the '| character: - - | val1 | val2 | - | val3 | val3 | - -But one can use almost any suitable character such as : # $ % + and so on. -This is clever enough to figure out what you are using as the delimiter -if you have your data set up like a table. Note that the line has to -both begin and end with the delimiter, as well as using it to separate -values. - -This can also have an optional caption at the start. - -=head1 EXAMPLES - - use HTML::TextToHTML; - -=head2 Create a new object - - my $conv = new HTML::TextToHTML(); - - my $conv = new HTML::TextToHTML(title=>"Wonderful Things", - default_link_dict=>$my_link_file, - ); - -=head2 Add further arguments - - $conv->args(short_line_length=>60, - preformat_trigger_lines=>4, - caps_tag=>"strong", - ); - -=head2 Convert a file - - $conv->txt2html(infile=>[$text_file], - outfile=>$html_file, - title=>"Wonderful Things", - mail=>1 - ); - -=head2 Make a pipleline - - open(IN, "ls |") or die "could not open!"; - $conv->txt2html(inhandle=>[\*IN], - outfile=>'-', - ); - -=head1 NOTES - -=over - -=item * - -One cannot use "CLEAR" as a value for the cumulative arguments. - -=item * - -If the underline used to mark a header is off by more than 1, then -that part of the text will not be picked up as a header unless you -change the value of --underline_length_tolerance and/or ---underline_offset_tolerance. People tend to forget this. - -=back - -=head1 BUGS - -Tell me about them. - -=head1 SEE ALSO - -perl -L<txt2html>. -Data::Dumper - -=head1 AUTHOR - - Kathryn Andersen (RUBYKAT) - perlkat AT katspace dot com - http//www.katspace.com/ - -based on txt2html by Seth Golub - -=head1 COPYRIGHT AND LICENCE - -Original txt2html script copyright (c) 1994-2000 Seth Golub <seth AT aigeek.com> - -Copyright (c) 2002-2005 by Kathryn Andersen - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut - -#------------------------------------------------------------------------ -1; -__DATA__ -# -# Global links dictionary file for HTML::TextToHTML -# http://www.katspace.com/tools/text_to_html -# http://txt2html.sourceforge.net/ -# based on links dictionary for Seth Golub's txt2html -# http://www.aigeek.com/txt2html/ -# -# This dictionary contains some patterns for converting obvious URLs, -# ftp sites, hostnames, email addresses and the like to hrefs. -# -# Original adapted from the html.pl package by Oscar Nierstrasz in -# the Software Archive of the Software Composition Group -# http://iamwww.unibe.ch/~scg/Src/ -# - -# Some people even like to mark the URL label explicitly <URL:foo:label> -/<URL:([-\w\.\/:~_\@]+):([a-zA-Z0-9'() ]+)>/ -h-> <A HREF="$1">$2</A> - -# Some people like to mark URLs explicitly <URL:foo> -/<URL:\s*(\S+?)\s*>/ -h-> <A HREF="$1">$1</A> - -# <http://site> -/<(http:\S+?)\s*>/ -h-> <<A HREF="$1">$1</A>> - -# Urls: <service>:<rest-of-url> - -|snews:[\w\.]+| -> $& -|news:[\w\.]+| -> $& -|nntp:[\w/\.:+\-]+| -> $& -|http:[\w/\.:\@+\-~\%#?=&;,]+[\w/]| -> $& -|shttp:[\w/\.:+\-~\%#?=&;,]+| -> $& -|https:[\w/\.:+\-~\%#?=&;,]+| -> $& -|file:[\w/\.:+\-]+| -> $& -|ftp:[\w/\.:+\-]+| -> $& -|wais:[\w/\.:+\-]+| -> $& -|gopher:[\w/\.:+\-]+| -> $& -|telnet:[\w/\@\.:+\-]+| -> $& - - -# catch some newsgroups to avoid confusion with sites: -|([^\w\-/\.:\@>])(alt\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(bionet\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(bit\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(biz\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(clari\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(comp\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(gnu\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(humanities\.[\w\.+\-]+[\w+\-]+)| - -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(k12\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(misc\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(news\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(rec\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(soc\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(talk\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(us\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(ch\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> -|([^\w\-/\.:\@>])(de\.[\w\.+\-]+[\w+\-]+)| -h-> $1<A HREF="news:$2">$2</A> - -# FTP locations (with directory): -# anonymous@<site>:<path> -|(anonymous\@)([a-zA-Z][\w\.+\-]+\.[a-zA-Z]{2,}):(\s*)([\w\d+\-/\.]+)| - -h-> $1<A HREF="ftp://$2/$4">$2:$4</A>$3 - -# ftp@<site>:<path> -|(ftp\@)([a-zA-Z][\w\.+\-]+\.[a-zA-Z]{2,}):(\s*)([\w\d+\-/\.]+)| - -h-> $1<A HREF="ftp://$2/$4">$2:$4</A>$3 - -# Email address -|[a-zA-Z0-9_\+\-\.]+\@([a-zA-Z0-9][\w\.+\-]+\.[a-zA-Z]{2,})| - -> mailto:$& - -# <site>:<path> -|([^\w\-/\.:\@>])([a-zA-Z][\w\.+\-]+\.[a-zA-Z]{2,}):(\s*)([\w\d+\-/\.]+)| - -h-> $1<A HREF="ftp://$2/$4">$2:$4</A>$3 - -# NB: don't confuse an http server with a port number for -# an FTP location! -# internet number version: <internet-num>:<path> -|([^\w\-/\.:\@])(\d{2,}\.\d{2,}\.\d+\.\d+):([\w\d+\-/\.]+)| - -h-> $1<A HREF="ftp://$2/$3">$2:$3</A> - -# telnet <site> <port> -|telnet ([a-zA-Z][\w+\-]+(\.[\w\.+\-]+)+\.[a-zA-Z]{2,})\s+(\d{2,4})| - -h-> telnet <A HREF="telnet://$1:$3/">$1 $3</A> - -# ftp <site> -|ftp ([a-zA-Z][\w+\-]+(\.[\w\.+\-]+)+\.[a-zA-Z]{2,})| - -h-> ftp <A HREF="ftp://$1/">$1</A> - -# host with "ftp" in the machine name -|\b([a-zA-Z][\w])*ftp[\w]*(\.[\w+\-]+){2,}| -h-> ftp <A HREF="ftp://$&/">$&</A> - -# ftp.foo.net/blah/ -|ftp(\.[a-zA-Z0-9_\@:-]+)+/\S+| -> ftp://$& - -# www.thehouse.org/txt2html/ -|www(\.[a-zA-Z0-9_\@:-]+)+/\S+| -> http://$& - -# host with "www" in the machine name -|\b([a-zA-Z][\w])*www[\w]*(\.[\w+\-]+){2,}| -> http://$&/ - -# <site> <port> -|([a-zA-Z][\w+\-]+\.[\w+\-]+\.[a-zA-Z]{2,})\s+(\d{2,4})| - -h-> <A HREF="telnet://$1:$2/">$1 $2</A> - -# just internet numbers with port: -|([^\w\-/\.:\@])(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\s+(\d{1,4})| - -h-> $1<A HREF="telnet://$2:$3">$2 $3</A> - -# just internet numbers: -|([^\w\-/\.:\@])(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})| - -h-> $1<A HREF="telnet://$2">$2</A> - -# RFCs -/RFC ?(\d+)/ -i-> http://www.cis.ohio-state.edu/rfc/rfc$1.txt - -# This would turn "f^H_o^H_o^H_" into "<U>foo</U>". Gross, isn't it? -# Thanks to Mark O'Dell <emark@cns.caltech.edu> for fixing this. -# -# /(.\\010_)+/ -he-> $tmp = $&;$tmp =~ s@\010_@@g;"<U>$tmp</U>" -# /(_\\010.)+/ -he-> $tmp = $&;$tmp =~ s@_\010@@g;"<U>$tmp</U>" -# /(.\^H_)+/ -he-> $tmp = $&;$tmp =~ s@\^H_@@g;"<U>$tmp</U>" -# /(_\^H.)+/ -he-> $tmp = $&;$tmp =~ s@_\^H@@g;"<U>$tmp</U>" - -# Mark _underlined stuff_ as <U>underlined stuff</U> -# Don't mistake variable names for underlines, and -# take account of possible trailing punctuation -/([ \t\n])_([a-z][a-z0-9 -]*[a-z])_([ \t\n\.;:,\!\?])/ -hi-> $1<U>$2</U>$3 - -# Seth and his amazing conversion program :-) - -"Seth Golub" -io-> http://www.aigeek.com/ -"txt2html" -io-> http://txt2html.sourceforge.net/ - -# Kathryn and her amazing modules 8-) -"Kathryn Andersen" -io-> http://www.katspace.com/ -"HTML::TextToHTML" -io-> http://www.katspace.com/tools/text_to_html/ -"hypertoc" -io-> http://www.katspace.com/tools/hypertoc/ -"HTML::GenToc" -io-> http://www.katspace.com/tools/hypertoc/ - -# End of global dictionary - diff --git a/lib/MP3/Info.pm b/lib/MP3/Info.pm deleted file mode 100644 index 3303ac5..0000000 --- a/lib/MP3/Info.pm +++ /dev/null @@ -1,1563 +0,0 @@ -package MP3::Info; -use overload; -use strict; -use Carp; -use Symbol; - -use vars qw( - @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $REVISION - @mp3_genres %mp3_genres @winamp_genres %winamp_genres $try_harder - @t_bitrate @t_sampling_freq @frequency_tbl %v1_tag_fields - @v1_tag_names %v2_tag_names %v2_to_v1_names $AUTOLOAD - @mp3_info_fields -); - -@ISA = 'Exporter'; -@EXPORT = qw( - set_mp3tag get_mp3tag get_mp3info remove_mp3tag - use_winamp_genres -); -@EXPORT_OK = qw(@mp3_genres %mp3_genres use_mp3_utf8); -%EXPORT_TAGS = ( - genres => [qw(@mp3_genres %mp3_genres)], - utf8 => [qw(use_mp3_utf8)], - all => [@EXPORT, @EXPORT_OK] -); - -# $Id: Info.pm,v 1.15 2003/03/02 19:16:43 pudge Exp $ -($REVISION) = ' $Revision: 1.15 $ ' =~ /\$Revision:\s+([^\s]+)/; -$VERSION = '1.02'; - -=pod - -=head1 NAME - -MP3::Info - Manipulate / fetch info from MP3 audio files - -=head1 SYNOPSIS - - #!perl -w - use MP3::Info; - my $file = 'Pearls_Before_Swine.mp3'; - set_mp3tag($file, 'Pearls Before Swine', q"77's", - 'Sticks and Stones', '1990', - q"(c) 1990 77's LTD.", 'rock & roll'); - - my $tag = get_mp3tag($file) or die "No TAG info"; - $tag->{GENRE} = 'rock'; - set_mp3tag($file, $tag); - - my $info = get_mp3info($file); - printf "$file length is %d:%d\n", $info->{MM}, $info->{SS}; - -=cut - -{ - my $c = -1; - # set all lower-case and regular-cased versions of genres as keys - # with index as value of each key - %mp3_genres = map {($_, ++$c, lc, $c)} @mp3_genres; - - # do it again for winamp genres - $c = -1; - %winamp_genres = map {($_, ++$c, lc, $c)} @winamp_genres; -} - -=pod - - my $mp3 = new MP3::Info $file; - $mp3->title('Perls Before Swine'); - printf "$file length is %s, title is %s\n", - $mp3->time, $mp3->title; - - -=head1 DESCRIPTION - -=over 4 - -=item $mp3 = MP3::Info-E<gt>new(FILE) - -OOP interface to the rest of the module. The same keys -available via get_mp3info and get_mp3tag are available -via the returned object (using upper case or lower case; -but note that all-caps "VERSION" will return the module -version, not the MP3 version). - -Passing a value to one of the methods will set the value -for that tag in the MP3 file, if applicable. - -=cut - -sub new { - my($pack, $file) = @_; - - my $info = get_mp3info($file) or return undef; - my $tags = get_mp3tag($file) || { map { ($_ => undef) } @v1_tag_names }; - my %self = ( - FILE => $file, - TRY_HARDER => 0 - ); - - @self{@mp3_info_fields, @v1_tag_names, 'file'} = ( - @{$info}{@mp3_info_fields}, - @{$tags}{@v1_tag_names}, - $file - ); - - return bless \%self, $pack; -} - -sub can { - my $self = shift; - return $self->SUPER::can(@_) unless ref $self; - my $name = uc shift; - return sub { $self->$name(@_) } if exists $self->{$name}; - return undef; -} - -sub AUTOLOAD { - my($self) = @_; - (my $name = uc $AUTOLOAD) =~ s/^.*://; - - if (exists $self->{$name}) { - my $sub = exists $v1_tag_fields{$name} - ? sub { - if (defined $_[1]) { - $_[0]->{$name} = $_[1]; - set_mp3tag($_[0]->{FILE}, $_[0]); - } - return $_[0]->{$name}; - } - : sub { - return $_[0]->{$name} - }; - - no strict 'refs'; - *{$AUTOLOAD} = $sub; - goto &$AUTOLOAD; - - } else { - carp(sprintf "No method '$name' available in package %s.", - __PACKAGE__); - } -} - -sub DESTROY { - -} - - -=item use_mp3_utf8([STATUS]) - -Tells MP3::Info to (or not) return TAG info in UTF-8. -TRUE is 1, FALSE is 0. Default is FALSE. - -Will only be able to it on if Unicode::String is available. ID3v2 -tags will be converted to UTF-8 according to the encoding specified -in each tag; ID3v1 tags will be assumed Latin-1 and converted -to UTF-8. - -Function returns status (TRUE/FALSE). If no argument is supplied, -or an unaccepted argument is supplied, function merely returns status. - -This function is not exported by default, but may be exported -with the C<:utf8> or C<:all> export tag. - -=cut - -my $unicode_module = 0; #eval { require Unicode::String }; -my $UNICODE = 0; - -sub use_mp3_utf8 { - my($val) = @_; - if ($val == 1) { - $UNICODE = 1 if $unicode_module; - } elsif ($val == 0) { - $UNICODE = 0; - } - return $UNICODE; -} - -=pod - -=item use_winamp_genres() - -Puts WinAmp genres into C<@mp3_genres> and C<%mp3_genres> -(adds 68 additional genres to the default list of 80). -This is a separate function because these are non-standard -genres, but they are included because they are widely used. - -You can import the data structures with one of: - - use MP3::Info qw(:genres); - use MP3::Info qw(:DEFAULT :genres); - use MP3::Info qw(:all); - -=cut - -sub use_winamp_genres { - %mp3_genres = %winamp_genres; - @mp3_genres = @winamp_genres; - return 1; -} - -=pod - -=item remove_mp3tag (FILE [, VERSION, BUFFER]) - -Can remove ID3v1 or ID3v2 tags. VERSION should be C<1> for ID3v1, -C<2> for ID3v2, and C<ALL> for both. - -For ID3v1, removes last 128 bytes from file if those last 128 bytes begin -with the text 'TAG'. File will be 128 bytes shorter. - -For ID3v2, removes ID3v2 tag. Because an ID3v2 tag is at the -beginning of the file, we rewrite the file after removing the tag data. -The buffer for rewriting the file is 4MB. BUFFER (in bytes) ca -change the buffer size. - -Returns the number of bytes removed, or -1 if no tag removed, -or undef if there is an error. - -=cut - -sub remove_mp3tag { - my($file, $version, $buf) = @_; - my($fh, $return); - - $buf ||= 4096*1024; # the bigger the faster - $version ||= 1; - - if (not (defined $file && $file ne '')) { - $@ = "No file specified"; - return undef; - } - - if (not -s $file) { - $@ = "File is empty"; - return undef; - } - - if (ref $file) { # filehandle passed - $fh = $file; - } else { - $fh = gensym; - if (not open $fh, "+< $file\0") { - $@ = "Can't open $file: $!"; - return undef; - } - } - - binmode $fh; - - if ($version eq 1 || $version eq 'ALL') { - seek $fh, -128, 2; - my $tell = tell $fh; - if (<$fh> =~ /^TAG/) { - truncate $fh, $tell or carp "Can't truncate '$file': $!"; - $return += 128; - } - } - - if ($version eq 2 || $version eq 'ALL') { - my $h = _get_v2head($fh); - if ($h) { - local $\; - seek $fh, 0, 2; - my $eof = tell $fh; - my $off = $h->{tag_size}; - - while ($off < $eof) { - seek $fh, $off, 0; - read $fh, my($bytes), $buf; - seek $fh, $off - $h->{tag_size}, 0; - print $fh $bytes; - $off += $buf; - } - - truncate $fh, $eof - $h->{tag_size} - or carp "Can't truncate '$file': $!"; - $return += $h->{tag_size}; - } - } - - _close($file, $fh); - - return $return || -1; -} - - -=pod - -=item set_mp3tag (FILE, TITLE, ARTIST, ALBUM, YEAR, COMMENT, GENRE [, TRACKNUM]) - -=item set_mp3tag (FILE, $HASHREF) - -Adds/changes tag information in an MP3 audio file. Will clobber -any existing information in file. - -Fields are TITLE, ARTIST, ALBUM, YEAR, COMMENT, GENRE. All fields have -a 30-byte limit, except for YEAR, which has a four-byte limit, and GENRE, -which is one byte in the file. The GENRE passed in the function is a -case-insensitive text string representing a genre found in C<@mp3_genres>. - -Will accept either a list of values, or a hashref of the type -returned by C<get_mp3tag>. - -If TRACKNUM is present (for ID3v1.1), then the COMMENT field can only be -28 bytes. - -ID3v2 support may come eventually. Note that if you set a tag on a file -with ID3v2, the set tag will be for ID3v1[.1] only, and if you call -C<get_mp3_tag> on the file, it will show you the (unchanged) ID3v2 tags, -unless you specify ID3v1. - -=cut - -sub set_mp3tag { - my($file, $title, $artist, $album, $year, $comment, $genre, $tracknum) = @_; - my(%info, $oldfh, $ref, $fh); - local %v1_tag_fields = %v1_tag_fields; - - # set each to '' if undef - for ($title, $artist, $album, $year, $comment, $tracknum, $genre, - (@info{@v1_tag_names})) - {$_ = defined() ? $_ : ''} - - ($ref) = (overload::StrVal($title) =~ /^(?:.*\=)?([^=]*)\((?:[^\(]*)\)$/) - if ref $title; - # populate data to hashref if hashref is not passed - if (!$ref) { - (@info{@v1_tag_names}) = - ($title, $artist, $album, $year, $comment, $tracknum, $genre); - - # put data from hashref into hashref if hashref is passed - } elsif ($ref eq 'HASH') { - %info = %$title; - - # return otherwise - } else { - carp(<<'EOT'); -Usage: set_mp3tag (FILE, TITLE, ARTIST, ALBUM, YEAR, COMMENT, GENRE [, TRACKNUM]) - set_mp3tag (FILE, $HASHREF) -EOT - return undef; - } - - if (not (defined $file && $file ne '')) { - $@ = "No file specified"; - return undef; - } - - if (not -s $file) { - $@ = "File is empty"; - return undef; - } - - # comment field length 28 if ID3v1.1 - $v1_tag_fields{COMMENT} = 28 if $info{TRACKNUM}; - - - # only if -w is on - if ($^W) { - # warn if fields too long - foreach my $field (keys %v1_tag_fields) { - $info{$field} = '' unless defined $info{$field}; - if (length($info{$field}) > $v1_tag_fields{$field}) { - carp "Data too long for field $field: truncated to " . - "$v1_tag_fields{$field}"; - } - } - - if ($info{GENRE}) { - carp "Genre `$info{GENRE}' does not exist\n" - unless exists $mp3_genres{$info{GENRE}}; - } - } - - if ($info{TRACKNUM}) { - $info{TRACKNUM} =~ s/^(\d+)\/(\d+)$/$1/; - unless ($info{TRACKNUM} =~ /^\d+$/ && - $info{TRACKNUM} > 0 && $info{TRACKNUM} < 256) { - carp "Tracknum `$info{TRACKNUM}' must be an integer " . - "from 1 and 255\n" if $^W; - $info{TRACKNUM} = ''; - } - } - - if (ref $file) { # filehandle passed - $fh = $file; - } else { - $fh = gensym; - if (not open $fh, "+< $file\0") { - $@ = "Can't open $file: $!"; - return undef; - } - } - - binmode $fh; - $oldfh = select $fh; - seek $fh, -128, 2; - # go to end of file if no tag, beginning of file if tag - seek $fh, (<$fh> =~ /^TAG/ ? -128 : 0), 2; - - # get genre value - $info{GENRE} = $info{GENRE} && exists $mp3_genres{$info{GENRE}} ? - $mp3_genres{$info{GENRE}} : 255; # some default genre - - local $\; - # print TAG to file - if ($info{TRACKNUM}) { - print pack "a3a30a30a30a4a28xCC", 'TAG', @info{@v1_tag_names}; - } else { - print pack "a3a30a30a30a4a30C", 'TAG', @info{@v1_tag_names[0..4, 6]}; - } - - select $oldfh; - - _close($file, $fh); - - return 1; -} - -=pod - -=item get_mp3tag (FILE [, VERSION, RAW_V2]) - -Returns hash reference containing tag information in MP3 file. The keys -returned are the same as those supplied for C<set_mp3tag>, except in the -case of RAW_V2 being set. - -If VERSION is C<1>, the information is taken from the ID3v1 tag (if present). -If VERSION is C<2>, the information is taken from the ID3v2 tag (if present). -If VERSION is not supplied, or is false, the ID3v1 tag is read if present, and -then, if present, the ID3v2 tag information will override any existing ID3v1 -tag info. - -If RAW_V2 is C<1>, the raw ID3v2 tag data is returned, without any manipulation -of text encoding. The key name is the same as the frame ID (ID to name mappings -are in the global %v2_tag_names). - -If RAW_V2 is C<2>, the ID3v2 tag data is returned, manipulating for Unicode if -necessary, etc. It also takes multiple values for a given key (such as comments) -and puts them in an arrayref. - -If the ID3v2 version is older than ID3v2.2.0 or newer than ID3v2.4.0, it will -not be read. - -Strings returned will be in Latin-1, unless UTF-8 is specified (L<use_mp3_utf8>), -(unless RAW_V2 is C<1>). - -Also returns a TAGVERSION key, containing the ID3 version used for the returned -data (if TAGVERSION argument is C<0>, may contain two versions). - -=cut - -sub get_mp3tag { - my($file, $ver, $raw_v2) = @_; - my($tag, $v1, $v2, $v2h, %info, @array, $fh); - $raw_v2 ||= 0; - $ver = !$ver ? 0 : ($ver == 2 || $ver == 1) ? $ver : 0; - - if (not (defined $file && $file ne '')) { - $@ = "No file specified"; - return undef; - } - - if (not -s $file) { - $@ = "File is empty"; - return undef; - } - - if (ref $file) { # filehandle passed - $fh = $file; - } else { - $fh = gensym; - if (not open $fh, "< $file\0") { - $@ = "Can't open $file: $!"; - return undef; - } - } - - binmode $fh; - - if ($ver < 2) { - seek $fh, -128, 2; - while(defined(my $line = <$fh>)) { $tag .= $line } - - if ($tag =~ /^TAG/) { - $v1 = 1; - if (substr($tag, -3, 2) =~ /\000[^\000]/) { - (undef, @info{@v1_tag_names}) = - (unpack('a3a30a30a30a4a28', $tag), - ord(substr($tag, -2, 1)), - $mp3_genres[ord(substr $tag, -1)]); - $info{TAGVERSION} = 'ID3v1.1'; - } else { - (undef, @info{@v1_tag_names[0..4, 6]}) = - (unpack('a3a30a30a30a4a30', $tag), - $mp3_genres[ord(substr $tag, -1)]); - $info{TAGVERSION} = 'ID3v1'; - } - if ($UNICODE) { - for my $key (keys %info) { - next unless $info{$key}; - my $u = Unicode::String::latin1($info{$key}); - $info{$key} = $u->utf8; - } - } - } elsif ($ver == 1) { - _close($file, $fh); - $@ = "No ID3v1 tag found"; - return undef; - } - } - - ($v2, $v2h) = _get_v2tag($fh); - - unless ($v1 || $v2) { - _close($file, $fh); - $@ = "No ID3 tag found"; - return undef; - } - - if (($ver == 0 || $ver == 2) && $v2) { - if ($raw_v2 == 1 && $ver == 2) { - %info = %$v2; - $info{TAGVERSION} = $v2h->{version}; - } else { - my $hash = $raw_v2 == 2 ? { map { ($_, $_) } keys %v2_tag_names } : \%v2_to_v1_names; - for my $id (keys %$hash) { - if (exists $v2->{$id}) { - if ($id =~ /^TCON?$/ && $v2->{$id} =~ /^.?\((\d+)\)/) { - $info{$hash->{$id}} = $mp3_genres[$1]; - } else { - my $data1 = $v2->{$id}; - - # this is tricky ... if this is an arrayref, - # we want to only return one, so we pick the - # first one. but if it is a comment, we pick - # the first one where the first charcter after - # the language is NULL and not an additional - # sub-comment, because that is most likely to be - # the user-supplied comment - if (ref $data1 && !$raw_v2) { - if ($id =~ /^COMM?$/) { - my($newdata) = grep /^(....\000)/, @{$data1}; - $data1 = $newdata || $data1->[0]; - } else { - $data1 = $data1->[0]; - } - } - - $data1 = [ $data1 ] if ! ref $data1; - - for my $data (@$data1) { - $data =~ s/^(.)//; # strip first char (text encoding) - my $encoding = $1; - my $desc; - if ($id =~ /^COM[M ]?$/) { - $data =~ s/^(?:...)//; # strip language - $data =~ s/^(.*?)\000+//; # strip up to first NULL(s), - # for sub-comment - $desc = $1; - } - - if ($UNICODE) { - if ($encoding eq "\001" || $encoding eq "\002") { # UTF-16, UTF-16BE - my $u = Unicode::String::utf16($data); - $data = $u->utf8; - $data =~ s/^\xEF\xBB\xBF//; # strip BOM - } elsif ($encoding eq "\000") { - my $u = Unicode::String::latin1($data); - $data = $u->utf8; - } - } - - if ($raw_v2 == 2 && $desc) { - $data = { $desc => $data }; - } - - if ($raw_v2 == 2 && exists $info{$hash->{$id}}) { - if (ref $info{$hash->{$id}} eq 'ARRAY') { - push @{$info{$hash->{$id}}}, $data; - } else { - $info{$hash->{$id}} = [ $info{$hash->{$id}}, $data ]; - } - } else { - $info{$hash->{$id}} = $data; - } - } - } - } - } - if ($ver == 0 && $info{TAGVERSION}) { - $info{TAGVERSION} .= ' / ' . $v2h->{version}; - } else { - $info{TAGVERSION} = $v2h->{version}; - } - } - } - - unless ($raw_v2 && $ver == 2) { - foreach my $key (keys %info) { - if (defined $info{$key}) { - $info{$key} =~ s/\000+.*//g; - $info{$key} =~ s/\s+$//; - } - } - - for (@v1_tag_names) { - $info{$_} = '' unless defined $info{$_}; - } - } - - if (keys %info && exists $info{GENRE} && ! defined $info{GENRE}) { - $info{GENRE} = ''; - } - - _close($file, $fh); - - return keys %info ? {%info} : undef; -} - -sub _get_v2tag { - my($fh) = @_; - my($off, $myseek, $myseek_22, $myseek_23, $v2, $h, $hlen, $num); - $h = {}; - - $v2 = _get_v2head($fh) or return; - if ($v2->{major_version} < 2) { - carp "This is $v2->{version}; " . - "ID3v2 versions older than ID3v2.2.0 not supported\n" - if $^W; - return; - } - - if ($v2->{major_version} == 2) { - $hlen = 6; - $num = 3; - } else { - $hlen = 10; - $num = 4; - } - - $myseek = sub { - seek $fh, $off, 0; - read $fh, my($bytes), $hlen; - return unless $bytes =~ /^([A-Z0-9]{$num})/ - || ($num == 4 && $bytes =~ /^(COM )/); # stupid iTunes - my($id, $size) = ($1, $hlen); - my @bytes = reverse unpack "C$num", substr($bytes, $num, $num); - for my $i (0 .. ($num - 1)) { - $size += $bytes[$i] * 256 ** $i; - } - return($id, $size); - }; - - $off = $v2->{ext_header_size} + 10; - - while ($off < $v2->{tag_size}) { - my($id, $size) = &$myseek or last; - seek $fh, $off + $hlen, 0; - read $fh, my($bytes), $size - $hlen; - if (exists $h->{$id}) { - if (ref $h->{$id} eq 'ARRAY') { - push @{$h->{$id}}, $bytes; - } else { - $h->{$id} = [$h->{$id}, $bytes]; - } - } else { - $h->{$id} = $bytes; - } - $off += $size; - } - - return($h, $v2); -} - - -=pod - -=item get_mp3info (FILE) - -Returns hash reference containing file information for MP3 file. -This data cannot be changed. Returned data: - - VERSION MPEG audio version (1, 2, 2.5) - LAYER MPEG layer description (1, 2, 3) - STEREO boolean for audio is in stereo - - VBR boolean for variable bitrate - BITRATE bitrate in kbps (average for VBR files) - FREQUENCY frequency in kHz - SIZE bytes in audio stream - - SECS total seconds - MM minutes - SS leftover seconds - MS leftover milliseconds - TIME time in MM:SS - - COPYRIGHT boolean for audio is copyrighted - PADDING boolean for MP3 frames are padded - MODE channel mode (0 = stereo, 1 = joint stereo, - 2 = dual channel, 3 = single channel) - FRAMES approximate number of frames - FRAME_LENGTH approximate length of a frame - VBR_SCALE VBR scale from VBR header - -On error, returns nothing and sets C<$@>. - -=cut - -sub get_mp3info { - my($file) = @_; - my($off, $myseek, $byte, $eof, $h, $tot, $fh); - - if (not (defined $file && $file ne '')) { - $@ = "No file specified"; - return undef; - } - - if (not -s $file) { - $@ = "File is empty"; - return undef; - } - - if (ref $file) { # filehandle passed - $fh = $file; - } else { - $fh = gensym; - if (not open $fh, "< $file\0") { - $@ = "Can't open $file: $!"; - return undef; - } - } - - $off = 0; - $tot = 4096; - - $myseek = sub { - seek $fh, $off, 0; - read $fh, $byte, 4; - }; - - binmode $fh; - &$myseek; - - if ($off == 0) { - if (my $id3v2 = _get_v2head($fh)) { - $tot += $off += $id3v2->{tag_size}; - &$myseek; - } - } - - $h = _get_head($byte); - until (_is_mp3($h)) { - $off++; - &$myseek; - $h = _get_head($byte); - if ($off > $tot && !$try_harder) { - _close($file, $fh); - $@ = "Couldn't find MP3 header (perhaps set " . - '$MP3::Info::try_harder and retry)'; - return undef; - } - } - - my $vbr = _get_vbr($fh, $h, \$off); - - seek $fh, 0, 2; - $eof = tell $fh; - seek $fh, -128, 2; - $off += 128 if <$fh> =~ /^TAG/ ? 1 : 0; - - _close($file, $fh); - - $h->{size} = $eof - $off; - - return _get_info($h, $vbr); -} - -sub _get_info { - my($h, $vbr) = @_; - my $i; - - $i->{VERSION} = $h->{IDR} == 2 ? 2 : $h->{IDR} == 3 ? 1 : - $h->{IDR} == 0 ? 2.5 : 0; - $i->{LAYER} = 4 - $h->{layer}; - $i->{VBR} = defined $vbr ? 1 : 0; - - $i->{COPYRIGHT} = $h->{copyright} ? 1 : 0; - $i->{PADDING} = $h->{padding_bit} ? 1 : 0; - $i->{STEREO} = $h->{mode} == 3 ? 0 : 1; - $i->{MODE} = $h->{mode}; - - $i->{SIZE} = $vbr && $vbr->{bytes} ? $vbr->{bytes} : $h->{size}; - - my $mfs = $h->{fs} / ($h->{ID} ? 144000 : 72000); - $i->{FRAMES} = int($vbr && $vbr->{frames} - ? $vbr->{frames} - : $i->{SIZE} / $h->{bitrate} / $mfs - ); - - if ($vbr) { - $i->{VBR_SCALE} = $vbr->{scale} if $vbr->{scale}; - $h->{bitrate} = $i->{SIZE} / $i->{FRAMES} * $mfs; - if (not $h->{bitrate}) { - $@ = "Couldn't determine VBR bitrate"; - return undef; - } - } - - $h->{'length'} = ($i->{SIZE} * 8) / $h->{bitrate} / 10; - $i->{SECS} = $h->{'length'} / 100; - $i->{MM} = int $i->{SECS} / 60; - $i->{SS} = int $i->{SECS} % 60; - $i->{MS} = (($i->{SECS} - ($i->{MM} * 60) - $i->{SS}) * 1000); -# $i->{LF} = ($i->{MS} / 1000) * ($i->{FRAMES} / $i->{SECS}); -# int($i->{MS} / 100 * 75); # is this right? - $i->{TIME} = sprintf "%.2d:%.2d", @{$i}{'MM', 'SS'}; - - $i->{BITRATE} = int $h->{bitrate}; - # should we just return if ! FRAMES? - $i->{FRAME_LENGTH} = int($h->{size} / $i->{FRAMES}) if $i->{FRAMES}; - $i->{FREQUENCY} = $frequency_tbl[3 * $h->{IDR} + $h->{sampling_freq}]; - - return $i; -} - -sub _get_head { - my($byte) = @_; - my($bytes, $h); - - $bytes = _unpack_head($byte); - @$h{qw(IDR ID layer protection_bit - bitrate_index sampling_freq padding_bit private_bit - mode mode_extension copyright original - emphasis version_index bytes)} = ( - ($bytes>>19)&3, ($bytes>>19)&1, ($bytes>>17)&3, ($bytes>>16)&1, - ($bytes>>12)&15, ($bytes>>10)&3, ($bytes>>9)&1, ($bytes>>8)&1, - ($bytes>>6)&3, ($bytes>>4)&3, ($bytes>>3)&1, ($bytes>>2)&1, - $bytes&3, ($bytes>>19)&3, $bytes - ); - - $h->{bitrate} = $t_bitrate[$h->{ID}][3 - $h->{layer}][$h->{bitrate_index}]; - $h->{fs} = $t_sampling_freq[$h->{IDR}][$h->{sampling_freq}]; - - return $h; -} - -sub _is_mp3 { - my $h = $_[0] or return undef; - return ! ( # all below must be false - $h->{bitrate_index} == 0 - || - $h->{version_index} == 1 - || - ($h->{bytes} & 0xFFE00000) != 0xFFE00000 - || - !$h->{fs} - || - !$h->{bitrate} - || - $h->{bitrate_index} == 15 - || - !$h->{layer} - || - $h->{sampling_freq} == 3 - || - $h->{emphasis} == 2 - || - !$h->{bitrate_index} - || - ($h->{bytes} & 0xFFFF0000) == 0xFFFE0000 - || - ($h->{ID} == 1 && $h->{layer} == 3 && $h->{protection_bit} == 1) - || - ($h->{mode_extension} != 0 && $h->{mode} != 1) - ); -} - -sub _get_vbr { - my($fh, $h, $roff) = @_; - my($off, $bytes, @bytes, $myseek, %vbr); - - $off = $$roff; - @_ = (); # closure confused if we don't do this - - $myseek = sub { - my $n = $_[0] || 4; - seek $fh, $off, 0; - read $fh, $bytes, $n; - $off += $n; - }; - - $off += 4; - - if ($h->{ID}) { # MPEG1 - $off += $h->{mode} == 3 ? 17 : 32; - } else { # MPEG2 - $off += $h->{mode} == 3 ? 9 : 17; - } - - &$myseek; - return unless $bytes eq 'Xing'; - - &$myseek; - $vbr{flags} = _unpack_head($bytes); - - if ($vbr{flags} & 1) { - &$myseek; - $vbr{frames} = _unpack_head($bytes); - } - - if ($vbr{flags} & 2) { - &$myseek; - $vbr{bytes} = _unpack_head($bytes); - } - - if ($vbr{flags} & 4) { - $myseek->(100); -# Not used right now ... -# $vbr{toc} = _unpack_head($bytes); - } - - if ($vbr{flags} & 8) { # (quality ind., 0=best 100=worst) - &$myseek; - $vbr{scale} = _unpack_head($bytes); - } else { - $vbr{scale} = -1; - } - - $$roff = $off; - return \%vbr; -} - -sub _get_v2head { - my $fh = $_[0] or return; - my($h, $bytes, @bytes); - - # check first three bytes for 'ID3' - seek $fh, 0, 0; - read $fh, $bytes, 3; - return unless $bytes eq 'ID3'; - - # get version - read $fh, $bytes, 2; - $h->{version} = sprintf "ID3v2.%d.%d", - @$h{qw[major_version minor_version]} = - unpack 'c2', $bytes; - - # get flags - read $fh, $bytes, 1; - if ($h->{major_version} == 2) { - @$h{qw[unsync compression]} = - (unpack 'b8', $bytes)[7, 6]; - $h->{ext_header} = 0; - $h->{experimental} = 0; - } else { - @$h{qw[unsync ext_header experimental]} = - (unpack 'b8', $bytes)[7, 6, 5]; - } - - # get ID3v2 tag length from bytes 7-10 - $h->{tag_size} = 10; # include ID3v2 header size - read $fh, $bytes, 4; - @bytes = reverse unpack 'C4', $bytes; - foreach my $i (0 .. 3) { - # whoaaaaaa nellllllyyyyyy! - $h->{tag_size} += $bytes[$i] * 128 ** $i; - } - - # get extended header size - $h->{ext_header_size} = 0; - if ($h->{ext_header}) { - $h->{ext_header_size} += 10; - read $fh, $bytes, 4; - @bytes = reverse unpack 'C4', $bytes; - for my $i (0..3) { - $h->{ext_header_size} += $bytes[$i] * 256 ** $i; - } - } - - return $h; -} - -sub _unpack_head { - unpack('l', pack('L', unpack('N', $_[0]))); -} - -sub _close { - my($file, $fh) = @_; - unless (ref $file) { # filehandle not passed - close $fh or carp "Problem closing '$file': $!"; - } -} - -BEGIN { - @mp3_genres = ( - 'Blues', - 'Classic Rock', - 'Country', - 'Dance', - 'Disco', - 'Funk', - 'Grunge', - 'Hip-Hop', - 'Jazz', - 'Metal', - 'New Age', - 'Oldies', - 'Other', - 'Pop', - 'R&B', - 'Rap', - 'Reggae', - 'Rock', - 'Techno', - 'Industrial', - 'Alternative', - 'Ska', - 'Death Metal', - 'Pranks', - 'Soundtrack', - 'Euro-Techno', - 'Ambient', - 'Trip-Hop', - 'Vocal', - 'Jazz+Funk', - 'Fusion', - 'Trance', - 'Classical', - 'Instrumental', - 'Acid', - 'House', - 'Game', - 'Sound Clip', - 'Gospel', - 'Noise', - 'AlternRock', - 'Bass', - 'Soul', - 'Punk', - 'Space', - 'Meditative', - 'Instrumental Pop', - 'Instrumental Rock', - 'Ethnic', - 'Gothic', - 'Darkwave', - 'Techno-Industrial', - 'Electronic', - 'Pop-Folk', - 'Eurodance', - 'Dream', - 'Southern Rock', - 'Comedy', - 'Cult', - 'Gangsta', - 'Top 40', - 'Christian Rap', - 'Pop/Funk', - 'Jungle', - 'Native American', - 'Cabaret', - 'New Wave', - 'Psychadelic', - 'Rave', - 'Showtunes', - 'Trailer', - 'Lo-Fi', - 'Tribal', - 'Acid Punk', - 'Acid Jazz', - 'Polka', - 'Retro', - 'Musical', - 'Rock & Roll', - 'Hard Rock', - ); - - @winamp_genres = ( - @mp3_genres, - 'Folk', - 'Folk-Rock', - 'National Folk', - 'Swing', - 'Fast Fusion', - 'Bebob', - 'Latin', - 'Revival', - 'Celtic', - 'Bluegrass', - 'Avantgarde', - 'Gothic Rock', - 'Progressive Rock', - 'Psychedelic Rock', - 'Symphonic Rock', - 'Slow Rock', - 'Big Band', - 'Chorus', - 'Easy Listening', - 'Acoustic', - 'Humour', - 'Speech', - 'Chanson', - 'Opera', - 'Chamber Music', - 'Sonata', - 'Symphony', - 'Booty Bass', - 'Primus', - 'Porn Groove', - 'Satire', - 'Slow Jam', - 'Club', - 'Tango', - 'Samba', - 'Folklore', - 'Ballad', - 'Power Ballad', - 'Rhythmic Soul', - 'Freestyle', - 'Duet', - 'Punk Rock', - 'Drum Solo', - 'Acapella', - 'Euro-House', - 'Dance Hall', - 'Goa', - 'Drum & Bass', - 'Club-House', - 'Hardcore', - 'Terror', - 'Indie', - 'BritPop', - 'Negerpunk', - 'Polsk Punk', - 'Beat', - 'Christian Gangsta Rap', - 'Heavy Metal', - 'Black Metal', - 'Crossover', - 'Contemporary Christian', - 'Christian Rock', - 'Merengue', - 'Salsa', - 'Thrash Metal', - 'Anime', - 'JPop', - 'Synthpop', - ); - - @t_bitrate = ([ - [0, 32, 48, 56, 64, 80, 96, 112, 128, 144, 160, 176, 192, 224, 256], - [0, 8, 16, 24, 32, 40, 48, 56, 64, 80, 96, 112, 128, 144, 160], - [0, 8, 16, 24, 32, 40, 48, 56, 64, 80, 96, 112, 128, 144, 160] - ],[ - [0, 32, 64, 96, 128, 160, 192, 224, 256, 288, 320, 352, 384, 416, 448], - [0, 32, 48, 56, 64, 80, 96, 112, 128, 160, 192, 224, 256, 320, 384], - [0, 32, 40, 48, 56, 64, 80, 96, 112, 128, 160, 192, 224, 256, 320] - ]); - - @t_sampling_freq = ( - [11025, 12000, 8000], - [undef, undef, undef], # reserved - [22050, 24000, 16000], - [44100, 48000, 32000] - ); - - @frequency_tbl = map { $_ ? eval "${_}e-3" : 0 } - map { @$_ } @t_sampling_freq; - - @mp3_info_fields = qw( - VERSION - LAYER - STEREO - VBR - BITRATE - FREQUENCY - SIZE - SECS - MM - SS - MS - TIME - COPYRIGHT - PADDING - MODE - FRAMES - FRAME_LENGTH - VBR_SCALE - ); - - %v1_tag_fields = - (TITLE => 30, ARTIST => 30, ALBUM => 30, COMMENT => 30, YEAR => 4); - - @v1_tag_names = qw(TITLE ARTIST ALBUM YEAR COMMENT TRACKNUM GENRE); - - %v2_to_v1_names = ( - # v2.2 tags - 'TT2' => 'TITLE', - 'TP1' => 'ARTIST', - 'TAL' => 'ALBUM', - 'TYE' => 'YEAR', - 'COM' => 'COMMENT', - 'TRK' => 'TRACKNUM', - 'TCO' => 'GENRE', # not clean mapping, but ... - # v2.3 tags - 'TIT2' => 'TITLE', - 'TPE1' => 'ARTIST', - 'TALB' => 'ALBUM', - 'TYER' => 'YEAR', - 'COMM' => 'COMMENT', - 'TRCK' => 'TRACKNUM', - 'TCON' => 'GENRE', - ); - - %v2_tag_names = ( - # v2.2 tags - 'BUF' => 'Recommended buffer size', - 'CNT' => 'Play counter', - 'COM' => 'Comments', - 'CRA' => 'Audio encryption', - 'CRM' => 'Encrypted meta frame', - 'ETC' => 'Event timing codes', - 'EQU' => 'Equalization', - 'GEO' => 'General encapsulated object', - 'IPL' => 'Involved people list', - 'LNK' => 'Linked information', - 'MCI' => 'Music CD Identifier', - 'MLL' => 'MPEG location lookup table', - 'PIC' => 'Attached picture', - 'POP' => 'Popularimeter', - 'REV' => 'Reverb', - 'RVA' => 'Relative volume adjustment', - 'SLT' => 'Synchronized lyric/text', - 'STC' => 'Synced tempo codes', - 'TAL' => 'Album/Movie/Show title', - 'TBP' => 'BPM (Beats Per Minute)', - 'TCM' => 'Composer', - 'TCO' => 'Content type', - 'TCR' => 'Copyright message', - 'TDA' => 'Date', - 'TDY' => 'Playlist delay', - 'TEN' => 'Encoded by', - 'TFT' => 'File type', - 'TIM' => 'Time', - 'TKE' => 'Initial key', - 'TLA' => 'Language(s)', - 'TLE' => 'Length', - 'TMT' => 'Media type', - 'TOA' => 'Original artist(s)/performer(s)', - 'TOF' => 'Original filename', - 'TOL' => 'Original Lyricist(s)/text writer(s)', - 'TOR' => 'Original release year', - 'TOT' => 'Original album/Movie/Show title', - 'TP1' => 'Lead artist(s)/Lead performer(s)/Soloist(s)/Performing group', - 'TP2' => 'Band/Orchestra/Accompaniment', - 'TP3' => 'Conductor/Performer refinement', - 'TP4' => 'Interpreted, remixed, or otherwise modified by', - 'TPA' => 'Part of a set', - 'TPB' => 'Publisher', - 'TRC' => 'ISRC (International Standard Recording Code)', - 'TRD' => 'Recording dates', - 'TRK' => 'Track number/Position in set', - 'TSI' => 'Size', - 'TSS' => 'Software/hardware and settings used for encoding', - 'TT1' => 'Content group description', - 'TT2' => 'Title/Songname/Content description', - 'TT3' => 'Subtitle/Description refinement', - 'TXT' => 'Lyricist/text writer', - 'TXX' => 'User defined text information frame', - 'TYE' => 'Year', - 'UFI' => 'Unique file identifier', - 'ULT' => 'Unsychronized lyric/text transcription', - 'WAF' => 'Official audio file webpage', - 'WAR' => 'Official artist/performer webpage', - 'WAS' => 'Official audio source webpage', - 'WCM' => 'Commercial information', - 'WCP' => 'Copyright/Legal information', - 'WPB' => 'Publishers official webpage', - 'WXX' => 'User defined URL link frame', - - # v2.3 tags - 'AENC' => 'Audio encryption', - 'APIC' => 'Attached picture', - 'COMM' => 'Comments', - 'COMR' => 'Commercial frame', - 'ENCR' => 'Encryption method registration', - 'EQUA' => 'Equalization', - 'ETCO' => 'Event timing codes', - 'GEOB' => 'General encapsulated object', - 'GRID' => 'Group identification registration', - 'IPLS' => 'Involved people list', - 'LINK' => 'Linked information', - 'MCDI' => 'Music CD identifier', - 'MLLT' => 'MPEG location lookup table', - 'OWNE' => 'Ownership frame', - 'PCNT' => 'Play counter', - 'POPM' => 'Popularimeter', - 'POSS' => 'Position synchronisation frame', - 'PRIV' => 'Private frame', - 'RBUF' => 'Recommended buffer size', - 'RVAD' => 'Relative volume adjustment', - 'RVRB' => 'Reverb', - 'SYLT' => 'Synchronized lyric/text', - 'SYTC' => 'Synchronized tempo codes', - 'TALB' => 'Album/Movie/Show title', - 'TBPM' => 'BPM (beats per minute)', - 'TCOM' => 'Composer', - 'TCON' => 'Content type', - 'TCOP' => 'Copyright message', - 'TDAT' => 'Date', - 'TDLY' => 'Playlist delay', - 'TENC' => 'Encoded by', - 'TEXT' => 'Lyricist/Text writer', - 'TFLT' => 'File type', - 'TIME' => 'Time', - 'TIT1' => 'Content group description', - 'TIT2' => 'Title/songname/content description', - 'TIT3' => 'Subtitle/Description refinement', - 'TKEY' => 'Initial key', - 'TLAN' => 'Language(s)', - 'TLEN' => 'Length', - 'TMED' => 'Media type', - 'TOAL' => 'Original album/movie/show title', - 'TOFN' => 'Original filename', - 'TOLY' => 'Original lyricist(s)/text writer(s)', - 'TOPE' => 'Original artist(s)/performer(s)', - 'TORY' => 'Original release year', - 'TOWN' => 'File owner/licensee', - 'TPE1' => 'Lead performer(s)/Soloist(s)', - 'TPE2' => 'Band/orchestra/accompaniment', - 'TPE3' => 'Conductor/performer refinement', - 'TPE4' => 'Interpreted, remixed, or otherwise modified by', - 'TPOS' => 'Part of a set', - 'TPUB' => 'Publisher', - 'TRCK' => 'Track number/Position in set', - 'TRDA' => 'Recording dates', - 'TRSN' => 'Internet radio station name', - 'TRSO' => 'Internet radio station owner', - 'TSIZ' => 'Size', - 'TSRC' => 'ISRC (international standard recording code)', - 'TSSE' => 'Software/Hardware and settings used for encoding', - 'TXXX' => 'User defined text information frame', - 'TYER' => 'Year', - 'UFID' => 'Unique file identifier', - 'USER' => 'Terms of use', - 'USLT' => 'Unsychronized lyric/text transcription', - 'WCOM' => 'Commercial information', - 'WCOP' => 'Copyright/Legal information', - 'WOAF' => 'Official audio file webpage', - 'WOAR' => 'Official artist/performer webpage', - 'WOAS' => 'Official audio source webpage', - 'WORS' => 'Official internet radio station homepage', - 'WPAY' => 'Payment', - 'WPUB' => 'Publishers official webpage', - 'WXXX' => 'User defined URL link frame', - - # v2.4 additional tags - # note that we don't restrict tags from 2.3 or 2.4, - 'ASPI' => 'Audio seek point index', - 'EQU2' => 'Equalisation (2)', - 'RVA2' => 'Relative volume adjustment (2)', - 'SEEK' => 'Seek frame', - 'SIGN' => 'Signature frame', - 'TDEN' => 'Encoding time', - 'TDOR' => 'Original release time', - 'TDRC' => 'Recording time', - 'TDRL' => 'Release time', - 'TDTG' => 'Tagging time', - 'TIPL' => 'Involved people list', - 'TMCL' => 'Musician credits list', - 'TMOO' => 'Mood', - 'TPRO' => 'Produced notice', - 'TSOA' => 'Album sort order', - 'TSOP' => 'Performer sort order', - 'TSOT' => 'Title sort order', - 'TSST' => 'Set subtitle', - - # grrrrrrr - 'COM ' => 'Broken iTunes comments', - ); -} - -1; - -__END__ - -=pod - -=back - -=head1 TROUBLESHOOTING - -If you find a bug, please send me a patch (see the project page in L<"SEE ALSO">). -If you cannot figure out why it does not work for you, please put the MP3 file in -a place where I can get it (preferably via FTP, or HTTP, or .Mac iDisk) and send me -mail regarding where I can get the file, with a detailed description of the problem. - -If I download the file, after debugging the problem I will not keep the MP3 file -if it is not legal for me to have it. Just let me know if it is legal for me to -keep it or not. - - -=head1 TODO - -=over 4 - -=item ID3v2 Support - -Still need to do more for reading tags, such as using Compress::Zlib to decompress -compressed tags. But until I see this in use more, I won't bother. If something -does not work properly with reading, follow the instructions above for -troubleshooting. - -ID3v2 I<writing> is coming soon. - -=item Get data from scalar - -Instead of passing a file spec or filehandle, pass the -data itself. Would take some work, converting the seeks, etc. - -=item Padding bit ? - -Do something with padding bit. - -=item Test suite - -Test suite could use a bit of an overhaul and update. Patches very welcome. - -=over 4 - -=item * - -Revamp getset.t. Test all the various get_mp3tag args. - -=item * - -Test Unicode. - -=item * - -Test OOP API. - -=item * - -Test error handling, check more for missing files, bad MP3s, etc. - -=back - -=item Other VBR - -Right now, only Xing VBR is supported. - -=back - - -=head1 THANKS - -Edward Allen E<lt>allenej@c51844-a.spokn1.wa.home.comE<gt>, -Vittorio Bertola E<lt>v.bertola@vitaminic.comE<gt>, -Michael Blakeley E<lt>mike@blakeley.comE<gt>, -Per Bolmstedt E<lt>tomten@kol14.comE<gt>, -Tony Bowden E<lt>tony@tmtm.comE<gt>, -Tom Brown E<lt>thecap@usa.netE<gt>, -Sergio Camarena E<lt>scamarena@users.sourceforge.netE<gt>, -Chris Dawson E<lt>cdawson@webiphany.comE<gt>, -Luke Drumm E<lt>lukedrumm@mypad.comE<gt>, -Kyle Farrell E<lt>kyle@cantametrix.comE<gt>, -Jeffrey Friedl E<lt>jfriedl@yahoo.comE<gt>, -brian d foy E<lt>comdog@panix.comE<gt>, -Ben Gertzfield E<lt>che@debian.orgE<gt>, -Brian Goodwin E<lt>brian@fuddmain.comE<gt>, -Todd Hanneken E<lt>thanneken@hds.harvard.eduE<gt>, -Todd Harris E<lt>harris@cshl.orgE<gt>, -Woodrow Hill E<lt>asim@mindspring.comE<gt>, -Kee Hinckley E<lt>nazgul@somewhere.comE<gt>, -Roman Hodek E<lt>Roman.Hodek@informatik.uni-erlangen.deE<gt>, -Peter Kovacs E<lt>kovacsp@egr.uri.eduE<gt>, -Johann Lindvall, -Peter Marschall E<lt>peter.marschall@mayn.deE<gt>, -Trond Michelsen E<lt>mike@crusaders.noE<gt>, -Dave O'Neill E<lt>dave@nexus.carleton.caE<gt>, -Christoph Oberauer E<lt>christoph.oberauer@sbg.ac.atE<gt>, -Jake Palmer E<lt>jake.palmer@db.comE<gt>, -Andrew Phillips E<lt>asp@wasteland.orgE<gt>, -David Reuteler E<lt>reuteler@visi.comE<gt>, -John Ruttenberg E<lt>rutt@chezrutt.comE<gt>, -Matthew Sachs E<lt>matthewg@zevils.comE<gt>, -E<lt>scfc_de@users.sf.netE<gt>, -Hermann Schwaerzler E<lt>Hermann.Schwaerzler@uibk.ac.atE<gt>, -Chris Sidi E<lt>sidi@angband.orgE<gt>, -Roland Steinbach E<lt>roland@support-system.comE<gt>, -Stuart E<lt>schneis@users.sourceforge.netE<gt>, -Jeffery Sumler E<lt>jsumler@mediaone.netE<gt>, -Predrag Supurovic E<lt>mpgtools@dv.co.yuE<gt>, -Bogdan Surdu E<lt>tim@go.roE<gt>, -E<lt>tim@tim-landscheidt.deE<gt>, -Pass F. B. Travis E<lt>pftravis@bellsouth.netE<gt>, -Tobias Wagener E<lt>tobias@wagener.nuE<gt>, -Ronan Waide E<lt>waider@stepstone.ieE<gt>, -Andy Waite E<lt>andy@mailroute.comE<gt>, -Ken Williams E<lt>ken@forum.swarthmore.eduE<gt>, -Meng Weng Wong E<lt>mengwong@pobox.comE<gt>. - - -=head1 AUTHOR AND COPYRIGHT - -Chris Nandor E<lt>pudge@pobox.comE<gt>, http://pudge.net/ - -Copyright (c) 1998-2003 Chris Nandor. All rights reserved. This program is -free software; you can redistribute it and/or modify it under the terms -of the Artistic License, distributed with Perl. - - -=head1 SEE ALSO - -=over 4 - -=item MP3::Info Project Page - - http://projects.pudge.net/ - -=item mp3tools - - http://www.zevils.com/linux/mp3tools/ - -=item mpgtools - - http://www.dv.co.yu/mpgscript/mpgtools.htm - http://www.dv.co.yu/mpgscript/mpeghdr.htm - -=item mp3tool - - http://www.dtek.chalmers.se/~d2linjo/mp3/mp3tool.html - -=item ID3v2 - - http://www.id3.org/ - -=item Xing Variable Bitrate - - http://www.xingtech.com/support/partner_developer/mp3/vbr_sdk/ - -=item MP3Ext - - http://rupert.informatik.uni-stuttgart.de/~mutschml/MP3ext/ - -=item Xmms - - http://www.xmms.org/ - - -=back - -=head1 VERSION - -v1.02, Sunday, March 2, 2003 - -=cut diff --git a/lib/Mail/SendEasy.pm b/lib/Mail/SendEasy.pm index c7d5064..5b7cc43 100644 --- a/lib/Mail/SendEasy.pm +++ b/lib/Mail/SendEasy.pm @@ -110,7 +110,7 @@ sub send { { my @from = &_check_emails( $mail{from} ) ; return( undef ) if $ER ; if ($#from > 0) { $ER = "More than one From: " . join(" ; ", @from) ; return( undef ) ;} - $mail{from} = @from[0] ; + $mail{from} = $from[0] ; my @to = &_check_emails( $mail{to} ) ; return( undef ) if $ER ; $mail{to} = \@to ; @@ -122,12 +122,12 @@ sub send { if ( defined $mail{reply} ) { my @reply = &_check_emails( $mail{reply} ) ; return( undef ) if $ER ; - $mail{reply} = @reply[0] ; delete $mail{reply} if $mail{reply} eq '' ; + $mail{reply} = $reply[0] ; delete $mail{reply} if $mail{reply} eq '' ; } if ( defined $mail{error} ) { my @error = &_check_emails( $mail{error} ) ; return( undef ) if $ER ; - $mail{error} = @error[0] ; delete $mail{error} if $mail{error} eq '' ; + $mail{error} = $error[0] ; delete $mail{error} if $mail{error} eq '' ; } } diff --git a/lib/Net/Amazon.pm b/lib/Net/Amazon.pm deleted file mode 100644 index 4630c11..0000000 --- a/lib/Net/Amazon.pm +++ /dev/null @@ -1,1255 +0,0 @@ -##################################################################### -package Net::Amazon; -###################################################################### -# Mike Schilli <m@perlmeister.com>, 2003 -###################################################################### - -use 5.006; -use strict; -use warnings; - -our $VERSION = '0.34'; -our @CANNED_RESPONSES = (); - -use LWP::UserAgent; -use HTTP::Request::Common; -use XML::Simple; -use Data::Dumper; -use URI; -use Log::Log4perl qw(:easy get_logger); -use Time::HiRes qw(usleep gettimeofday tv_interval); - -# Each key represents a search() type, and each value indicates which -# Net::Amazon::Request:: class to use to handle it. -use constant SEARCH_TYPE_CLASS_MAP => { - artist => 'Artist', - asin => 'ASIN', - blended => 'Blended', - browsenode => 'BrowseNode', - exchange => 'Exchange', - keyword => 'Keyword', - manufacturer => 'Manufacturer', - power => 'Power', - seller => 'Seller', - similar => 'Similar', - textstream => 'TextStream', - upc => 'UPC', - wishlist => 'Wishlist', -}; - - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - if(! exists $options{token}) { - die "Mandatory paramter 'token' not defined"; - } - - if(! exists $options{affiliate_id}) { - $options{affiliate_id} = "webservices-20"; - } - - my $self = { - strict => 1, - response_dump => 0, - rate_limit => 1.0, # 1 req/sec - max_pages => 5, - ua => LWP::UserAgent->new(), - %options, - }; - - help_xml_simple_choose_a_parser(); - - bless $self, $class; -} - -################################################## -sub search { -################################################## - my($self, %params) = @_; - - foreach my $key ( keys %params ) { - next unless ( my $class = SEARCH_TYPE_CLASS_MAP->{$key} ); - - return $self->_make_request($class, \%params); - } - - # FIX? - # This seems like it really should be a die() instead...this is - # indicative of a programming problem. Generally speaking, it's - # best to issue warnings from a module--you can't be sure that the - # client has a stderr to begin with, or that he wants errors - # spewed to it. - warn "No Net::Amazon::Request type could be determined"; - - return undef; -} - -################################################## -sub intl_url { -################################################## - my($self, $url) = @_; - - # Every time Amazon is adding a new country to the web service, - # they're rolling a dice on what the new URL is going to be. - # This method will try to keep up with their crazy mappings. - - if(! exists $self->{locale}) { - return $url; - } - - if ($self->{locale} eq "jp") { - $url =~ s/\.com/.co.jp/; - return $url; - } - - if($self->{locale} eq "uk" or - $self->{locale} eq "de") { - $url =~ s/xml/xml-eu/; - return $url; - } - - return $url; -} - -################################################## -sub request { -################################################## - my($self, $request) = @_; - - my $AMZN_WISHLIST_BUG_ENCOUNTERED = 0; - - my $resp_class = $request->response_class(); - - eval "require $resp_class;" or - die "Cannot find '$resp_class'"; - - my $res = $resp_class->new(); - - my $url = URI->new($self->intl_url($request->amzn_xml_url())); - my $page = $request->{page}; - my $ref; - - { - my %params = $request->params(); - $params{page} = $page; - $params{locale} = $self->{locale} if exists $self->{locale}; - - $url->query_form( - 'dev-t' => $self->{token}, - 't' => $self->{affiliate_id}, - map { $_, $params{$_} } sort keys %params, - ); - - my $urlstr = $url->as_string; - my $xml = fetch_url($self, $urlstr, $res); - - if(!defined $xml) { - return $res; - } - - DEBUG(sub { "Received [ " . $xml . "]" }); - - # Let the response class parse the XML - $ref = $res->xml_parse($xml); - - # DEBUG(sub { Data::Dumper::Dumper($ref) }); - - if(! defined $ref) { - ERROR("Invalid XML"); - $res->messages( [ "Invalid XML" ]); - $res->status(""); - return $res; - } - - if(exists $ref->{TotalPages}) { - INFO("Page $page/$ref->{TotalPages}"); - } - - if(exists $ref->{TotalResults}) { - $res->total_results( $ref->{TotalResults} ); - } - - if(exists $ref->{ErrorMsg}) { - - if($AMZN_WISHLIST_BUG_ENCOUNTERED && - $ref->{ErrorMsg} =~ /no exact matches/) { - DEBUG("End of buggy wishlist detected"); - last; - } - - if (ref($ref->{ErrorMsg}) eq "ARRAY") { - # multiple errors, set arrary ref - $res->messages( $ref->{ErrorMsg} ); - } else { - # single error, create array - $res->messages( [ $ref->{ErrorMsg} ] ); - } - - ERROR("Fetch Error: " . $res->message ); - $res->status(""); - return $res; - } - - my $new_items = $res->xmlref_add($ref); - DEBUG("Received valid XML ($new_items items)"); - - # Stop if we've fetched max_pages already - if($self->{max_pages} <= $page) { - DEBUG("Fetched max_pages ($self->{max_pages}) -- stopping"); - last; - } - - # Work around the Amazon bug not setting TotalPages properly - # for wishlists - if(ref($res) =~ /Wishlist/ and - !exists $ref->{TotalPages} and - $new_items == 10 - ) { - $AMZN_WISHLIST_BUG_ENCOUNTERED = 1; - DEBUG("Trying to fetch additional wishlist page (AMZN bug)"); - $page++; - redo; - } - - if(exists $ref->{TotalPages} and - $ref->{TotalPages} > $page) { - DEBUG("Page $page of $ref->{TotalPages} fetched - continuing"); - $page++; - redo; - } - - # We're gonna fall out of this loop here. - } - - $res->status(1); - # We have a valid response, so if TotalResults isn't set, - # we most likely have a single response - $res->total_results(1) unless defined $res->total_results(); - return $res; -} - -################################################## -sub fetch_url { -################################################## - my($self, $url, $res) = @_; - - my $max_retries = 2; - - INFO("Fetching $url"); - - if(@CANNED_RESPONSES) { - INFO("Serving canned response (testing)"); - return shift @CANNED_RESPONSES; - } - - if(exists $self->{cache}) { - my $resp = $self->{cache}->get($url); - if(defined $resp) { - INFO("Serving from cache"); - return $resp; - } - - INFO("Cache miss"); - } - - my $ua = $self->{ua}; - $ua->env_proxy(); - - my $resp; - - { - # wait up to a second before the next request so - # as to not violate Amazon's 1 query per second - # rule (or the configured rate_limit). - $self->pause() if $self->{strict}; - - $resp = $ua->request(GET $url); - - $self->reset_timer() if $self->{strict}; - - if($resp->is_error) { - # retry on 503 Service Unavailable errors - if ($resp->code == 503) { - if ($max_retries-- >= 0) { - INFO("Temporary Amazon error 503, retrying"); - redo; - } else { - INFO("Out of retries, giving up"); - $res->status(""); - $res->messages( [ "Too many temporary Amazon errors" ] ); - return undef; - } - } else { - $res->status(""); - $res->messages( [ $resp->message ] ); - return undef; - } - } - - if($self->{response_dump}) { - my $dumpfile = "response-$self->{response_dump}.txt"; - open FILE, ">$dumpfile" or die "Cannot open $dumpfile"; - print FILE $resp->content(); - close FILE; - $self->{response_dump}++; - } - - if($resp->content =~ /<ErrorMsg>/ && - $resp->content =~ /Please retry/i) { - if($max_retries-- >= 0) { - INFO("Temporary Amazon error, retrying"); - redo; - } else { - INFO("Out of retries, giving up"); - $res->status(""); - $res->messages( [ "Too many temporary Amazon errors" ] ); - return undef; - } - } - } - - if(exists $self->{cache}) { - $self->{cache}->set($url, $resp->content()); - } - - return $resp->content(); -} - -################################################## -# Poor man's Class::Struct -################################################## -sub make_accessor { -################################################## - my($package, $name) = @_; - - no strict qw(refs); - - my $code = <<EOT; - *{"$package\\::$name"} = sub { - my(\$self, \$value) = \@_; - - if(defined \$value) { - \$self->{$name} = \$value; - } - if(exists \$self->{$name}) { - return (\$self->{$name}); - } else { - return ""; - } - } -EOT - if(! defined *{"$package\::$name"}) { - eval $code or die "$@"; - } -} - -################################################## -# Make accessors for arrays -################################################## -sub make_array_accessor { -################################################## - my($package, $name) = @_; - - no strict qw(refs); - - my $code = <<EOT; - *{"$package\\::$name"} = sub { - my(\$self, \$nameref) = \@_; - if(defined \$nameref) { - if(ref \$nameref eq "ARRAY") { - \$self->{$name} = \$nameref; - } else { - \$self->{$name} = [\$nameref]; - } - } - # Return a list - if(exists \$self->{$name} and - ref \$self->{$name} eq "ARRAY") { - return \@{\$self->{$name}}; - } - - return undef; - } -EOT - - if(! defined *{"$package\::$name"}) { - eval $code or die "$@"; - } -} - -################################################## -sub artist { -################################################## - my($self, $nameref) = @_; - - # Only return the first artist - return ($self->artists($nameref))[0]; -} - - -################################################## -sub xmlref_add { -################################################## - my($self, $xmlref) = @_; - - my $nof_items_added = 0; - - # Push a nested hash structure, retrieved via XMLSimple, onto the - # object's internal 'xmlref' entry, which holds a ref to an array, - # whichs elements are refs to hashes holding an item's attributes - # (like OurPrice etc.) - - #DEBUG("xmlref_add ", Data::Dumper::Dumper($xmlref)); - - unless(ref($self->{xmlref}) eq "HASH" && - ref($self->{xmlref}->{Details}) eq "ARRAY") { - $self->{xmlref}->{Details} = []; - } - - if(ref($xmlref->{Details}) eq "ARRAY") { - # Is it an array of items? - push @{$self->{xmlref}->{Details}}, @{$xmlref->{Details}}; - $nof_items_added = scalar @{$xmlref->{Details}}; - } else { - # It is a single item - push @{$self->{xmlref}->{Details}}, $xmlref->{Details}; - $nof_items_added = 1; - } - - #DEBUG("xmlref_add (after):", Data::Dumper::Dumper($self)); - return $nof_items_added; -} - -################################################## -sub help_xml_simple_choose_a_parser { -################################################## - - eval "require XML::Parser"; - unless($@) { - $XML::Simple::PREFERRED_PARSER = "XML::Parser"; - return; - } - - eval "require XML::SAX::PurePerl"; - unless($@) { - $XML::Simple::PREFERRED_PARSER = "XML::SAX::PurePerl"; - return; - } -} - -################################################## -# This timer makes sure we don't query Amazon more -# than once a second. -################################################## -sub reset_timer { -################################################## - - my $self = shift; - $self->{t0} = [gettimeofday]; -} - -################################################## -# Pause for up to a second if necessary. -################################################## -sub pause { -################################################## - - my $self = shift; - return unless ($self->{t0}); - - my $t1 = [gettimeofday]; - my $dur = (1.0/$self->{rate_limit} - - tv_interval($self->{t0}, $t1)) * 1000000; - if($dur > 0) { - # Use a pseudo subclass for the logger, since the app - # might not want to log that as 'ERROR'. Log4perl's - # inheritance mechanism makes sure it does the right - # thing for the current class. - my $logger = get_logger(__PACKAGE__ . "::RateLimit"); - $logger->error("Ratelimiting: Sleeping $dur microseconds"); - usleep($dur); - } -} - -## -## 'PRIVATE' METHODS -## - -# $self->_make_request( TYPE, PARAMS ) -# -# Takes a TYPE that corresponds to a Net::Amazon::Request -# class, require()s that class, instantiates it, and returns -# the result of that instance's request() method. -# -sub _make_request { - my ($self, $type, $params) = @_; - - my $class = "Net::Amazon::Request::$type"; - - eval "require $class"; - - my $req = $class->new(%{$params}); - - return $self->request($req); -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon - Framework for accessing amazon.com via SOAP and XML/HTTP - -=head1 SYNOPSIS - - use Net::Amazon; - - my $ua = Net::Amazon->new(token => 'YOUR_AMZN_TOKEN'); - - # Get a request object - my $response = $ua->search(asin => '0201360683'); - - if($response->is_success()) { - print $response->as_string(), "\n"; - } else { - print "Error: ", $response->message(), "\n"; - } - -=head1 ABSTRACT - - Net::Amazon provides an object-oriented interface to amazon.com's - SOAP and XML/HTTP interfaces. This way it's possible to create applications - using Amazon's vast amount of data via a functional interface, without - having to worry about the underlying communication mechanism. - -=head1 DESCRIPTION - -C<Net::Amazon> works very much like C<LWP>: First you define a useragent -like - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN', - max_pages => 3, - ); - -which you pass your personal amazon developer's token (can be obtained -from L<http://amazon.com/soap>) and (optionally) the maximum number of -result pages the agent is going to request from Amazon in case all -results don't fit on a single page (typically holding 20 items). Note that -each new page requires a minimum delay of 1 second to comply with Amazon's -one-query-per-second policy. - -According to the different search methods on Amazon, there's a bunch -of different request types in C<Net::Amazon>. The user agent's -convenience method C<search()> triggers different request objects, -depending on which parameters you pass to it: - -=over 4 - -=item C<< $ua->search(asin => "0201360683") >> - -The C<asin> parameter has Net::Amazon search for an item with the -specified ASIN. If the specified value is an arrayref instead of a single -scalar, like in - - $ua->search(asin => ["0201360683", "0596005083"]) - -then a search for multiple ASINs is performed, returning a list of -results. - -=item C<< $ua->search(artist => "Rolling Stones") >> - -The C<artist> parameter has the user agent search for items created by -the specified artist. Can return many results. - -=item C<< $ua->search(browsenode=>"4025", mode=>"books" [, keywords=>"perl"]) >> - -Returns a list of items by category ID (node). For example node "4025" -is the CGI books category. You can add a keywords parameter to filter -the results by that keyword. - -=item C<< $ua->search(exchange => 'Y04Y3424291Y2398445') >> - -Returns an item offered by a third-party seller. The item is referenced -by the so-called I<exchange ID>. - -=item C<< $ua->search(keyword => "perl xml", mode => "books") >> - -Search by keyword, mandatory parameters C<keyword> and C<mode>. -Can return many results. - -=item C<< $ua->search(wishlist => "1XL5DWOUFMFVJ") >> - -Search for all items in a specified wishlist. -Can return many results. - -=item C<< $ua->search(upc => "075596278324", mode => "music") >> - -Music search by UPC (product barcode), mandatory parameter C<upc>. -C<mode> has to be set to C<music>. Returns at most one result. - -=item C<< $ua->search(similar => "0201360683") >> - -Search for all items similar to the one represented by the ASIN provided. -Can return many results. - -=item C<< $ua->search(power => "subject: perl and author: schwartz", mode => "books") >> - -Initiate a power search for all books matching the power query. -Can return many results. See L<Net::Amazon::Request::Power> for details. - -=item C<< $ua->search(manufacturer => "o'reilly", mode => "books") >> - -Initiate a search for all items made by a given manufacturrer. -Can return many results. See L<Net::Amazon::Request::Manufacturer> -for details. - -=item C<< $ua->search(blended => "Perl") >> - -Initiate a search for items in all categories. - -=item C<< $ua->search(seller => "A2GXAGU54VOP7") >> - -Start a search on items sold by a specific third-party seller, referenced -by its ID (not seller name). - -=item C<< $ua->search(textstream => "Blah blah Rolling Stones blah blah") >> - -Find items related to keywords within a text stream. - -=back - -The user agent's C<search> method returns a response object, which can be -checked for success or failure: - - if($resp->is_success()) { - print $resp->as_string(); - } else { - print "Error: ", $resp->message(), "\n"; - } - -In case the request for an item search -succeeds, the response contains one or more -Amazon 'properties', as it calls the products found. -All matches can be retrieved from the Response -object using it's C<properties()> method. - -In case the request fails, the response contains one or more -error messages. The response object's C<message()> method will -return it (or them) as a single string, while C<messages()> (notice -the plural) will -return a reference to an array of message strings. - -Response objects always have the methods -C<is_success()>, -C<is_error()>, -C<message()>, -C<total_results()>, -C<as_string()> and -C<properties()> available. - -C<total_results()> returns the total number of results the search -yielded. -C<properties()> returns one or more C<Net::Amazon::Property> objects of type -C<Net::Amazon::Property> (or one of its subclasses like -C<Net::Amazon::Property::Book>, C<Net::Amazon::Property::Music> -or Net::Amazon::Property::DVD), each -of which features accessors named after the attributes of the product found -in Amazon's database: - - for ($resp->properties) { - print $_->Asin(), " ", - $_->OurPrice(), "\n"; - } - -In scalar context, C<properties()> just returns the I<first> -C<Net::Amazon::Property> object found. -Commonly available accessors to C<Net::Amazon::Property> objects are -C<OurPrice()>, -C<ImageUrlLarge()>, -C<ImageUrlMedium()>, -C<ImageUrlSmall()>, -C<ReleaseDate()>, -C<Catalog()>, -C<Asin()>, -C<url()>, -C<Manufacturer()>, -C<UsedPrice()>, -C<ListPrice()>, -C<ProductName()>, -C<Availability()>, -C<SalesRank()>, -C<CollectiblePrice()>, -C<CollectibleCount()>, -C<NumberOfOfferings()>, -C<UsedCount()>, -C<ThirdPartyNewPrice()>, -C<ThirdPartyNewCount()>, -C<similar_asins()>. -For details, check L<Net::Amazon::Property>. - -Also, the specialized classes C<Net::Amazon::Property::Book> and -C<Net::Amazon::Property::Music> feature convenience methods like -C<authors()> (returning the list of authors of a book) or -C<album()> for CDs, returning the album title. - -Customer reviews: -Every property features a C<review_set()> method which returns a -C<Net::Amazon::Attribute::ReviewSet> object, which in turn offers -a list of C<Net::Amazon::Attribute::Review> objects. Check the respective -man pages for details on what's available. - -=head2 Requests behind the scenes - -C<Net::Amazon>'s C<search()> method is just a convenient way to -create different kinds of request objects behind the scenes and -trigger them to send requests to Amazon. - -Depending on the parameters fed to the C<search> method, C<Net::Amazon> will -determine the kind of search requested and create one of the following -request objects: - -=over 4 - -=item Net::Amazon::Request::ASIN - -Search by ASIN, mandatory parameter C<asin>. -Returns at most one result. - -=item Net::Amazon::Request::Artist - -Music search by Artist, mandatory parameter C<artist>. -Can return many results. - -=item Net::Amazon::Request::BrowseNode - -Returns category (node) listing. Mandatory parameters C<browsenode> -(must be numeric) and C<mode>. Can return many results. - -=item Net::Amazon::Request::Keyword - -Keyword search, mandatory parameters C<keyword> and C<mode>. -Can return many results. - -=item Net::Amazon::Request::UPC - -Music search by UPC (product barcode), mandatory parameter C<upc>. -C<mode> has to be set to C<music>. Returns at most one result. - -=item Net::Amazon::Request::Blended - -'Blended' search on a keyword, resulting in matches across the board. -No 'mode' parameter is allowed. According to Amazon's developer's kit, -this will result in up to three matches per category and can yield -a total of 45 matches. - -=item Net::Amazon::Request::Power - -Understands power search strings. See L<Net::Amazon::Request::Power> -for details. Mandatory parameter C<power>. - -=item Net::Amazon::Request::Manufacturer - -Searches for all items made by a given manufacturer. Mandatory parameter -C<manufacturer>. - -=item Net::Amazon::Request::Similar - -Finds items similar to a given one. - -=item Net::Amazon::Request::Wishlist - -Find item on someone's wish list. - -=item Net::Amazon::Request::Seller - -Searches for a third-party seller on Amazon by seller ID. This search -is different than the previous ones, since it doesn't return Amazon -items, but a single seller record. Don't use the C<properties()> method -on the response, use C<result()> instead, which returns a -L<Net::Amazon::Result::Seller> object. Check the manpage for details. - -=item Net::Amazon::Request::Exchange - -Searches for items offered by third-party sellers. Items are referenced -by their so-called I<Exchange ID>. -Similar to L<Net::Amazon::Request::Seller>, -this request doesn't return a list of Amazon properties, so please use -C<result()> instead, which will return a I<single> -L<Net::Amazon::Result::Seller::Listing> item. -Check the manpage for details on what attributes are available there. - -=back - -Check the respective man pages for details on these request objects. -Request objects are typically created like this (with a Keyword query -as an example): - - my $req = Net::Amazon::Request::Keyword->new( - keyword => 'perl', - mode => 'books', - ); - -and are handed over to the user agent like that: - - # Response is of type Net::Amazon::Response::ASIN - my $resp = $ua->request($req); - -The convenient C<search()> method just does these two steps in one. - -=head2 METHODS - -=over 4 - -=item $ua = Net::Amazon->new(token => $token, ...) - -Create a new Net::Amazon useragent. C<$token> is the value of -the mandatory Amazon developer's token, which can be obtained from -L<http://amazon.com/soap>. - -Additional optional parameters: - -=over 4 - -=item C<< max_pages => $max_pages >> - -Sets how many -result pages the module is supposed to fetch back from Amazon, which -only sends back 10 results per page. -Since each page requires a new query to Amazon, at most one query -per second will be made in C<strict> mode to comply with Amazon's terms -of service. This will impact performance if you perform a search -returning many pages of results. - -=item C<< affiliate_id => $affiliate_id >> - -your Amazon affiliate ID, if you have one. It defaults to -C<webservices-20> which is currently (as of 06/2003) -required by Amazon. - -=item C<< strict => 1 >> - -Makes sure that C<Net::Amazon> complies with Amazon's terms of service -by limiting the number of outgoing requests to 1 per second. Defaults -to C<1>, enabling rate limiting as defined via C<rate_limit>. - -=item C<< rate_limit => $reqs_per_sec >> - -Sets the rate limit to C<$reqs_per_sec> requests per second if -rate limiting has been enabled with C<strict> (see above). -Defaults to C<1>, limiting the number of outgoing requests to -1 per second. - -=item C<< $resp = $ua->request($request) >> - -Sends a request to the Amazon web service. C<$request> is of a -C<Net::Amazon::Request::*> type and C<$response> will be of the -corresponding C<Net::Amazon::Response::*> type. - -=back - -=head2 Accessing foreign Amazon Catalogs - -As of this writing (07/2003), Amazon also offers its web service for -the UK, Germany, and Japan. Just pass in - - locale => 'uk' - locale => 'de' - locale => 'jp' - -respectively to C<Net::Amazon>'s constructor C<new()> and instead of returning -results sent by the US mothership, it will query the particular country's -catalog and show prices in (gack!) local currencies. - -=head2 EXAMPLE - -Here's a full-fledged example doing a artist search: - - use Net::Amazon; - use Net::Amazon::Request::Artist; - use Data::Dumper; - - die "usage: $0 artist\n(use Zwan as an example)\n" - unless defined $ARGV[0]; - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN', - ); - - my $req = Net::Amazon::Request::Artist->new( - artist => $ARGV[0], - ); - - # Response is of type Net::Amazon::Artist::Response - my $resp = $ua->request($req); - - if($resp->is_success()) { - print $resp->as_string, "\n"; - } else { - print $resp->message(), "\n"; - } - -And here's one displaying someone's wishlist: - - use Net::Amazon; - use Net::Amazon::Request::Wishlist; - - die "usage: $0 wishlist_id\n" . - "(use 1XL5DWOUFMFVJ as an example)\n" unless $ARGV[0]; - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN', - ); - - my $req = Net::Amazon::Request::Wishlist->new( - id => $ARGV[0] - ); - - # Response is of type Net::Amazon::ASIN::Response - my $resp = $ua->request($req); - - if($resp->is_success()) { - print $resp->as_string, "\n"; - } else { - print $resp->message(), "\n"; - } - -=head1 CACHING - -Responses returned by Amazon's web service can be cached locally. -C<Net::Amazon>'s C<new> method accepts a reference to a C<Cache> -object. C<Cache> (or one of its companions like C<Cache::Memory>, -C<Cache::File>, etc.) can be downloaded from CPAN, please check their -documentation for details. In fact, any other type of cache -implementation will do as well, see the requirements below. - -Here's an example utilizing a file cache which causes C<Net::Amazon> to -cache responses for 30 minutes: - - use Cache::File; - - my $cache = Cache::File->new( - cache_root => '/tmp/mycache', - default_expires => '30 min', - ); - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN', - cache => $cache, - ); - -C<Net::Amazon> uses I<positive> caching only, errors won't be cached. -Erroneous requests will be sent to Amazon every time. Positive cache -entries are keyed by the full URL used internally by requests submitted -to Amazon. - -Caching isn't limited to the C<Cache> class. Any cache object which -adheres to the following interface can be used: - - # Set a cache value - $cache->set($key, $value); - - # Return a cached value, 'undef' if it doesn't exist - $cache->get($key); - -=head1 PROXY SETTINGS - -C<Net::Amazon> uses C<LWP::UserAgent> under the hood to send -web requests to Amazon's web site. If you're in an environment where -all Web traffic goes through a proxy, there's two ways to configure that. - -First, C<Net::Amazon> picks up proxy settings from environment variables: - - export http_proxy=http://proxy.my.place:8080 - -in the surrounding shell or setting - - $ENV{http_proxy} = "http://proxy.my.place:8080"; - -in your Perl script -will route all requests through the specified proxy. - -Secondly, you can -pass a user agent instance to Net::Amazon's constructor: - - use Net::Amazon; - use LWP::UserAgent; - - my $ua = LWP::UserAgent->new(); - my $na = Net::Amazon->new(ua => $ua, token => 'YOUR_AMZN_TOKEN'); - # ... - -This way, you can configure C<$ua> up front before Net::Amazon will use it. - -=head1 DEBUGGING - -If something's going wrong and you want more verbosity, just bump up -C<Net::Amazon>'s logging level. C<Net::Amazon> comes with C<Log::Log4perl> -statements embedded, which are disabled by default. However, if you initialize -C<Log::Log4perl>, e.g. like - - use Net::Amazon; - use Log::Log4perl qw(:easy); - - Log::Log4perl->easy_init($DEBUG); - my Net::Amazon->new(); - # ... - -you'll see what's going on behind the scenes, what URLs the module -is requesting from Amazon and so forth. Log::Log4perl allows all kinds -of fancy stuff, like writing to a file or enabling verbosity in certain -parts only -- check http://log4perl.sourceforge.net for details. - -=head1 LIVE TESTING - -Results returned by Amazon can be incomplete or simply wrong at times, -due to their "best effort" design of the service. This is why the test -suite that comes with this module has been changed to perform its test -cases against canned data. If you want to perform the tests against -the live Amazon servers instead, just set the environment variable - - NET_AMAZON_LIVE_TESTS=1 - -=head1 WHY ISN'T THERE SUPPORT FOR METHOD XYZ? - -Because nobody wrote it yet. If Net::Amazon doesn't yet support a method -advertised on Amazon's web service, you could help us out. Net::Amazon -has been designed to be expanded over time, usually it only takes a couple -of lines to support a new method, the rest is done via inheritance within -Net::Amazon. - -Here's the basic plot: - -=over 4 - -=item * - -Get Net::Amazon from CVS. Use - - # (Just hit enter when prompted for a password) - cvs -d:pserver:anonymous@cvs.net-amazon.sourceforge.net:/cvsroot/net-amazon login - cvs -z3 -d:pserver:anonymous@cvs.net-amazon.sourceforge.net:/cvsroot/net-amazon co Net-Amazon - -If this doesn't work, just use the latest distribution from -net-amazon.sourceforge.net. - -=item * - -Write a new Net::Amazon::Request::XYZ package, start with this template - - ###################################### - package Net::Amazon::Request::XYZ; - ###################################### - use base qw(Net::Amazon::Request); - - ###################################### - sub new { - ###################################### - my($class, %options) = @_; - - if(!exists $options{XYZ_option}) { - die "Mandatory parameter 'XYZ_option' not defined"; - } - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate - } - -and add documentation. Then, create a new Net::Amazon::Response::XYZ module: - - ############################## - package Net::Amazon::Response; - ############################## - use base qw(Net::Amazon::Response); - - use Net::Amazon::Property; - - ############################## - sub new { - ############################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate - } - -and also add documentation to it. Then, add the line - - use Net::Amazon::Request::XYZ; - -to Net/Amazon.pm. - -=back - -And that's it! Again, don't forget the I<add documentation> part. Modules -without documentation are of no use to anybody but yourself. - -Check out the different Net::Amazon::Request::* -and Net::Amazon::Response modules in the distribution if you need to adapt -your new module to fulfil any special needs, like a different Amazon URL -or a different way to handle the as_string() method. Also, post -and problems you might encounter to the mailing list, we're gonna help you -out. - -If possible, provide a test case for your extension. When finished, send -a patch to the mailing list at - - net-amazon-devel@lists.sourceforge.net - -and if it works, I'll accept it and will work it into the main distribution. -Your name will show up in the contributor's list below (unless you tell -me otherwise). - -=head2 SAMPLE SCRIPTS - -There's a number of useful scripts in the distribution's eg/ directory. -Take C<power> for example, written by Martin Streicher -E<lt>martin.streicher@apress.comE<gt>: I lets you perform -a I<power search> using Amazon's query language. To search for all books -written by Randal Schwartz about Perl, call this from the command line: - - power 'author: schwartz subject: perl' - -Note that you need to quote the query string to pass it as one argument -to C<power>. If a power search returns more results than you want to -process at a time, just limit the number of pages, telling C<power> -which page to start at (C<-s>) and which one to finish with (C<-f>). -Here's a search for all books on the subject C<computer>, limited -to the first 10 pages: - - power -s 1 -f 10 'subject: computer' - -Check out the script C<power> in eg/ for more options. - -=head2 HOW TO SEND ME PATCHES - -If you want me to include your modification or enhancement -in the distribution of Net::Amazon, please do the following: - -=over 4 - -=item * - -Work off the latest CVS version. Here's the steps to get it: - - CVSROOT=:pserver:anonymous@cvs.net-amazon.sourceforge.net:/cvsroot/net-amazon - export CVSROOT - cvs login (just hit Enter) - cvs co Net-Amazon - -This will create a new C<Net-Amazon> directory with the latest -development version of C<Net::Amazon> on your local machine. - -=item * - -Apply your changes to this development tree. - -=item * - -Run a diff between the tree and your changes it in this way: - - cd Net-Amazon - cvs diff -Nau >patch_to_mike.txt - -=item * - -Email me C<patch_to_mike.txt>. If your patch works (and you've included -test cases and documentation), I'll apply it on the spot. - -=back - -=head1 INSTALLATION - -C<Net::Amazon> depends on Log::Log4perl, which can be pulled from CPAN by -simply saying - - perl -MCPAN -eshell 'install Log::Log4perl' - -Also, it needs LWP::UserAgent and XML::Simple 2.x, which can be obtained -in a similar way. - -Once all dependencies have been resolved, C<Net::Amazon> installs with -the typical sequence - - perl Makefile.PL - make - make test - make install - -Make sure you're connected to the Internet while running C<make test> -because it will actually contact amazon.com and run a couple of live tests. - -The module's distribution tarball and documentation are available at - - http://perlmeister.com/devel/#amzn - -and on CPAN. - -=head1 SEE ALSO - -The following modules play well within the C<Net::Amazon> framework: - -=over 4 - -=item C<Net::Amazon::RemoteCart> - -by David Emery E<lt>dave@skiddlydee.comE<gt> provides a complete API for -creating Amazon shopping carts on a local site, managing them and finally -submitting them to Amazon for checkout. It is available on CPAN. - -=back - -=head1 CONTACT - -The C<Net::Amazon> project's home page is hosted on - - http://net-amazon.sourceforge.net - -where you can find documentation, news and the latest development and -stable releases for download. If you have questions about how to -use C<Net::Amazon>, want to report a bug or just participate in its -development, please send a message to the mailing -list net-amazon-devel@lists.sourceforge.net - -=head1 AUTHOR - -Mike Schilli, E<lt>na@perlmeister.comE<gt> (Please contact me via the mailing list: net-amazon-devel@lists.sourceforge.net ) - -Contributors (thanks y'all!): - - Andy Grundman <andy@hybridized.org> - Barnaby Claydon <bclaydon@perseus.com> - Batara Kesuma <bkesuma@gaijinweb.com> - Bill Fitzpatrick - Brian <brianbrian@gmail.com> - Brian Hirt <bhirt@mobygames.com> - Dan Kreft <dan@kreft.net> - Dan Sully <daniel@electricrain.com> - Jackie Hamilton <kira@cgi101.com> - Konstantin Gredeskoul <kig@get.topica.com> - Lance Cleveland <lancec@proactivewm.com> - Martha Greenberg <marthag@mit.edu> - Martin Streicher <martin.streicher@apress.com> - Mike Evron <evronm@dtcinc.net> - Padraic Renaghan <padraic@renaghan.com> - rayg <rayg@varchars.com> - Robert Graff <rgraff@workingdemo.com> - Robert Rothenberg <wlkngowl@i-2000.com> - Steve Rushe <steve@deeden.co.uk> - Tatsuhiko Miyagawa <miyagawa@livedoor.jp> - Tony Bowden <tony@kasei.com> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003, 2004 by Mike Schilli E<lt>na@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Attribute/Review.pm b/lib/Net/Amazon/Attribute/Review.pm deleted file mode 100644 index 5a5d094..0000000 --- a/lib/Net/Amazon/Attribute/Review.pm +++ /dev/null @@ -1,104 +0,0 @@ -###################################################################### -package Net::Amazon::Attribute::Review; -###################################################################### -use warnings; -use strict; -use Log::Log4perl qw(:easy); -use base qw(Net::Amazon); - -__PACKAGE__->make_accessor($_) for qw(rating summary comment); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = { - rating => "", - summary => "", - comment => "", - %options, - }; - - bless $self, $class; -} - -################################################## -sub init_via_xmlref { -################################################## - my($self, $xmlref) = @_; - - for(qw(Rating Summary Comment)) { - my $method = lc($_); - if($xmlref->{$_}) { - $self->$method($xmlref->{$_}); - } else { - #LOGWARN "No '$_'"; - return undef; - } - } -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Attribute::Review - Customer Review Class - -=head1 SYNOPSIS - - use Net::Amazon::Attribute::Review; - my $rev = Net::Amazon::Attribute::Review->new( - 'rating' => $rating, - 'summary' => $summary, - 'comment' => $comment, - ); - -=head1 DESCRIPTION - -C<Net::Amazon::Attribute::Review> holds customer reviews. - -=head2 METHODS - -=over 4 - -=item rating() - -Accessor for the numeric value of the rating. - -=item summary() - -Accessor for the string value of the summary. - -=item comment() - -Accessor for the string value of the customer comment. - -=back - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -__END__ - <Reviews> - <AvgCustomerRating>4.33</AvgCustomerRating> - <TotalCustomerReviews>6</TotalCustomerReviews> - <CustomerReview> - <Rating>4</Rating> - <Summary>Good introduction to Perl, and great reference</Summary> - <Comment>From its corny title you might expect another one of those - diff --git a/lib/Net/Amazon/Attribute/ReviewSet.pm b/lib/Net/Amazon/Attribute/ReviewSet.pm deleted file mode 100644 index 29a34e6..0000000 --- a/lib/Net/Amazon/Attribute/ReviewSet.pm +++ /dev/null @@ -1,137 +0,0 @@ -###################################################################### -package Net::Amazon::Attribute::ReviewSet; -###################################################################### -use warnings; -use strict; -use Log::Log4perl qw(:easy); -use Net::Amazon::Attribute::Review; -use base qw(Net::Amazon); - -__PACKAGE__->make_accessor($_) for qw(average_customer_rating total_reviews); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = { - reviews => [], # list of reviews - }; - - bless $self, $class; -} - -########################################### -sub add_review { -########################################### - my($self, $review) = @_; - - if(ref $review ne "Net::Amazon::Attribute::Review") { - warn "add_review called with type ", ref $review; - return undef; - } - - push @{$self->{reviews}}, $review; -} - -########################################### -sub reviews { -########################################### - my($self) = @_; - - return @{$self->{reviews}}; -} - -################################################## -sub init_via_xmlref { -################################################## - my($self, $xmlref) = @_; - - my @pairs = qw(AvgCustomerRating average_customer_rating - TotalCustomerReviews total_reviews); - - while(my($field, $method) = splice @pairs, 0, 2) { - - if(defined $xmlref->{$field}) { - DEBUG "Setting $field via $method to $xmlref->{$field}"; - $self->$method($xmlref->{$field}); - } else { - LOGWARN "No '$field'"; - return undef; - } - } - - if(ref $xmlref->{CustomerReview} ne "ARRAY") { - $xmlref->{CustomerReview} = [$xmlref->{CustomerReview}]; - } - - for my $review_xmlref (@{$xmlref->{CustomerReview}}) { - my $review = Net::Amazon::Attribute::Review->new(); - $review->init_via_xmlref($review_xmlref); - DEBUG "Adding review ", $review->summary(); - $self->add_review($review); - } -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Attribute::ReviewSet - A set of customer reviews - -=head1 SYNOPSIS - - use Net::Amazon::Attribute::ReviewSet; - my $rev = Net::Amazon::Attribute::Review->new( - average_customer_rating => $avg, - total_reviews => $total, - ); - -=head1 DESCRIPTION - -C<Net::Amazon::Attribute::ReviewSet> holds a list of customer -reviews, each of type C<Net::Amazon::Attribute::Review>. - -=head2 METHODS - -=over 4 - -=item C<< $self->reviews() >> - -Returns a list of C<Net::Amazon::Attribute::Review> objects. - -=item C<< $self->average_customer_rating() >> - -Accessor for the average customer rating, a numeric value. - -=item C<< $self->total_reviews() >> - -Accessor for the total number of reviews. Please note that this -might not be equal to the number of reviews held in the list, since -there might be less customer reviews than total reviews (reviews -can also be non-customer-reviews, but they're not available by -the web service as of Aug 2003). - -=item C<< $self->add_review($rev) >> - -Add a C<Net::Amazon::Attribute::Review> object to the list. -(Used internally only). - -=back - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Property.pm b/lib/Net/Amazon/Property.pm deleted file mode 100644 index 6c06957..0000000 --- a/lib/Net/Amazon/Property.pm +++ /dev/null @@ -1,320 +0,0 @@ -###################################################################### -package Net::Amazon::Property; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon); - -use Net::Amazon::Property::DVD; -use Net::Amazon::Property::Book; -use Net::Amazon::Property::Music; -use Net::Amazon::Attribute::ReviewSet; -use Data::Dumper; -use Log::Log4perl qw(:easy); - -use warnings; -use strict; - -our @DEFAULT_ATTRIBUTES = qw( - OurPrice ImageUrlLarge ImageUrlMedium ImageUrlSmall - ReleaseDate Catalog Asin url Manufacturer UsedPrice - ListPrice ProductName Availability SalesRank - Media NumMedia ProductDescription - CollectiblePrice CollectibleCount NumberOfOfferings - UsedCount ThirdPartyNewPrice ThirdPartyNewCount - ThirdPartyProductInfo -); - -__PACKAGE__->make_accessor($_) for @DEFAULT_ATTRIBUTES; -__PACKAGE__->make_accessor($_) for qw(year review_set); -__PACKAGE__->make_array_accessor($_) for qw(browse_nodes similar_asins); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - if(!$options{xmlref}) { - die "Mandatory param xmlref missing"; - } - - my $self = { - %options, - }; - - bless $self, $class; - - # Set default attributes - for my $attr (@DEFAULT_ATTRIBUTES) { - $self->$attr($options{xmlref}->{$attr}); - } - - # The release date is sometimes missing - if($options{xmlref}->{ReleaseDate}) { - my ($year) = ($options{xmlref}->{ReleaseDate} =~ /(\d{4})/); - $self->year($year); - } else { - $self->year(""); - } - - my $browse_nodes = $options{xmlref}->{BrowseList}->{BrowseNode}; - if(ref($browse_nodes) eq "ARRAY") { - my @nodes = map { - $_->{BrowseName} - } @{ $browse_nodes }; - $self->browse_nodes(\@nodes); - } elsif (ref($browse_nodes) eq "HASH") { - $self->browse_nodes([ $browse_nodes->{BrowseName} ]); - } else { - $self->browse_nodes([ ]); - } - - my $similar = $options{xmlref}->{SimilarProducts}; - if(ref($similar) eq "HASH") { - $self->similar_asins($similar->{Product}); - } else { - $self->similar_asins([ ]); - } - - return $self; -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - my $result = "\"$self->{xmlref}->{ProductName}\", "; - - if($self->{xmlref}->{Manufacturer}) { - $result .= "$self->{xmlref}->{Manufacturer}, "; - } - - $result .= $self->year() . ", " if $self->year(); - - $result .= $self->OurPrice() . ", "; - $result .= $self->Asin(); - return $result; -} - -################################################## -sub factory { -################################################## - my(%options) = @_; - - my $xmlref = $options{xmlref}; - die "Called factory without xmlref" unless $xmlref; - - # DEBUG(sub {"factory xmlref=" . Data::Dumper::Dumper($xmlref)}); - - my $catalog = $xmlref->{Catalog}; - my $obj; - - if(0) { - } elsif($catalog eq "Book") { - DEBUG("Creating new Book Property"); - $obj = Net::Amazon::Property::Book->new(xmlref => $xmlref); - } elsif($catalog eq "Music") { - DEBUG("Creating new Music Property"); - $obj = Net::Amazon::Property::Music->new(xmlref => $xmlref); - } elsif($catalog eq "DVD") { - DEBUG("Creating new DVD Property"); - $obj = Net::Amazon::Property::DVD->new(xmlref => $xmlref); - } else { - DEBUG("Creating new Default Property ($catalog)"); - $obj = Net::Amazon::Property->new(xmlref => $xmlref); - } - - return $obj; -} - -################################################## -sub init_via_xmlref { -################################################## - my($self, $xmlref) = @_; - - my $reviewset = Net::Amazon::Attribute::ReviewSet->new(); - - if(exists $xmlref->{Reviews}) { - $reviewset->init_via_xmlref($xmlref->{Reviews}); - } - - $self->review_set($reviewset); -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Property - Baseclass for products on amazon.com - -=head1 SYNOPSIS - - use Net::Amazon; - - # ... - - if($resp->is_success()) { - for my $prop ($resp->properties) { - print $_->ProductName(), " ", - $_->Manufacturer(), " ", - $_->OurPrice(), "\n"; - -=head1 DESCRIPTION - -C<Net::Amazon::Property> is the baseclass for results returned -from Amazon web service queries. The term 'properties' is used as -a generic description for an item on amazon.com. - -Typically, the C<properties()> method of a C<Net::Amazon::Response::*> object -will return one or more objects of class C<Net::Amazon::Property> or -one of its subclasses, e.g. C<Net::Amazon::Property::Book> or -C<Net::Amazon::Property::CD>. - -While C<Net::Amazon::Property> objects expose accessors for all -fields returned in the XML response (like C<OurPrice()>, C<ListPrice()>, -C<Manufacturer()>, C<Asin()>, C<Catalog()>, C<ProductName()>, subclasses -might define their own accessors to more class-specific fields -(like the iC<Net::Amazon::Property::Book>'s C<authors()> method returning -a list of authors, while C<Net::Amazon::Property>'s C<Authors()> method -will return a reference to a sub-hash containing a C<Author> field, just like -the response's XML contained it). - -=head2 METHODS - -Methods vary, depending on the item returned from a query. Here's the most -common ones. They're all accessors, meaning they can be used like C<Method()> -to retrieve the value or like C<Method($value)> to set the value of the -field. - -=over 4 - -=item Asin() - -The item's ASIN number. - -=item ProductName() - -Book title, CD album name or item name - -=item Availability() - -Text string describing if the item is available. Examples: -C<"Usually ships within 24 hours"> or -C<"Out of Print--Limited Availability">. - -=item Catalog() - -Shows the catalog the item was found in: C<Book>, C<Music>, C<Classical>, -C<Electronics> etc. - -=item Authors() - -Returns a sub-hash with a C<Author> key, which points to either a single -$scalar or to a reference of an array containing author names as scalars. - -=item ReleaseDate() - -Item's release date, format is "NN Monthname, Year". - -=item Manufacturer() - -Music label, publishing company or manufacturer - -=item ImageUrlSmall() - -URL to a small (thumbnail) image of the item - -=item ImageUrlMedium() - -URL to a medium-size image of the item - -=item ImageUrlLarge() - -URL to a large image of the item - -=item ListPrice() - -List price of the item - -=item OurPrice() - -Amazon price of the item - -=item UsedPrice() - -Used price of the item - -=item SalesRank() - -Sales rank of the item (contains digits and commas, like 1,000,001) - -=item Media() - -Type of media (Paperback, etc.). - -=item NumMedia() - -Number of media the item carries (1,2 CDs etc.). - -=item ProductDescription() - -Lengthy textual description of the product. - -=item CollectiblePrice() - -Lowest price in "Collectible" category. - -=item CollectibleCount() - -Number of offerings in "Collectible" category. - -=item NumberOfOfferings() - -Total number of offerings in all categories. - -=item UsedCount() - -Number of offerings in "Used" category. - -=item ThirdPartyNewPrice() - -Lowest price in "Third Party New" category. - -=item ThirdPartyNewCount() - -Number of offerings in "Third Party New" category. - -=item year() - -The release year extracted from ReleaseDate(). - -=item browse_nodes() - -Returns a list of browse nodes (text string categories) for this item. - -=item similar_asins() - -Returns a list of ASINs of similar items for this item. - -=back - -Please check the subclasses of C<Net::Amazon::Property> for specialized -methods. - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Property/Book.pm b/lib/Net/Amazon/Property/Book.pm deleted file mode 100644 index 8a01756..0000000 --- a/lib/Net/Amazon/Property/Book.pm +++ /dev/null @@ -1,152 +0,0 @@ -###################################################################### -package Net::Amazon::Property::Book; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Property); - -__PACKAGE__->make_accessor($_) for qw(title publisher binding isbn); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - bless $self, $class; # Bless into this class - - if(exists $options{xmlref}) { - $self->init_via_xmlref($options{xmlref}); - } - - return $self; -} - -################################################## -sub init_via_xmlref { -################################################## - my($self, $xmlref) = @_; - - $self->SUPER::init_via_xmlref($xmlref); - - $self->authors($xmlref->{Authors}->{Author}); - $self->title($xmlref->{ProductName}); - $self->publisher($xmlref->{Manufacturer}); - $self->binding($xmlref->{Media}); - $self->isbn($xmlref->{Isbn}); -} - -################################################## -sub author { -################################################## - my($self, $nameref) = @_; - - # Only return the first author - return ($self->authors($nameref))[0]; -} - -################################################## -sub authors { -################################################## - my($self, $nameref) = @_; - - if(defined $nameref) { - if(ref $nameref eq "ARRAY") { - $self->{authors} = $nameref; - } else { - $self->{authors} = [$nameref]; - } - } - - # Return a list - return $self->{authors} ? @{$self->{authors}} : (); -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - return join('/', $self->authors) . ", " . - '"' . $self->title . '"' . ", " . - $self->year . ", " . - $self->OurPrice . ", " . - $self->Asin; -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Property::Book - Class for books on amazon.com - -=head1 SYNOPSIS - - use Net::Amazon; - - # ... - - if($resp->is_success()) { - for my $prop ($resp->properties) { - print join("/", $prop->authors(), " ", - $prop->title(), " ", - $prop->publisher(), " ", - $prop->year(), "\n"; - } - -=head1 DESCRIPTION - -C<Net::Amazon::Property::Book> is derived from -C<Net::Amazon::Property> and on top of the all-purpose -methods the base class provides, it offers specialized accessors for -book parameters. - -=head2 METHODS - -=over 4 - -=item authors() - -Returns a list of the book's authors. There's also a C<author()> method -which just returns the I<first> author. - -=item publisher() - -Returns the book's publishing company as a string. - -=item title() - -Returns the book's title as a string. - -=item isbn() - -Returns the book's ISBN number. - -=item new(xmlref => $xmlref) - -Initializes an object by passing a hash of hashes structure containing -the XML data returned from the service. Usually, this is just used by -C<Net::Amazon> internally to initialize objects for on backcoming -data. - -=back - -Check out L<Net::Amazon::Property> for all-purpose accessors, like -C<year>, C<OurPrice>, C<ListPrice>, etc. - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Property/DVD.pm b/lib/Net/Amazon/Property/DVD.pm deleted file mode 100644 index dc7fd5a..0000000 --- a/lib/Net/Amazon/Property/DVD.pm +++ /dev/null @@ -1,156 +0,0 @@ -###################################################################### -package Net::Amazon::Property::DVD; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Property); - -__PACKAGE__->make_accessor($_) for qw(title studio theatrical_release_date - media nummedia upc mpaa_rating); -__PACKAGE__->make_array_accessor($_) for qw(directors starring features); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - bless $self, $class; # Bless into this class - - if(exists $options{xmlref}) { - $self->init_via_xmlref($options{xmlref}); - } - - return $self; -} - -################################################## -sub director { -################################################## - my($self, $nameref) = @_; - - # Only return the first director - return ($self->directors($nameref))[0]; -} - -################################################## -sub init_via_xmlref { -################################################## - my($self, $xmlref) = @_; - - $self->SUPER::init_via_xmlref($xmlref); - - $self->title($xmlref->{ProductName}); - $self->studio($xmlref->{Manufacturer}); - $self->directors($xmlref->{Directors}->{Director}); - $self->starring($xmlref->{Starring}->{Actor}); - $self->media($xmlref->{Media}); - $self->nummedia($xmlref->{NumMedia}); - $self->upc($xmlref->{Upc}); - $self->theatrical_release_date($xmlref->{TheatricalReleaseDate}); - $self->mpaa_rating($xmlref->{MpaaRating}); - $self->features($xmlref->{Features}->{Feature}); -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Property::DVD - Class for DVDs on amazon.com - -=head1 SYNOPSIS - - use Net::Amazon; - - # ... - - if($resp->is_success()) { - for my $prop ($resp->properties) { - print $_->title(), " ", - $_->studio(), " ", - $_->year(), "\n"; - } - -=head1 DESCRIPTION - -C<Net::Amazon::Property::DVD> is derived from -C<Net::Amazon::Property> and on top of the all-purpose -methods the base class provides, it offers specialized accessors for -DVD parameters. - -=head2 METHODS - -=over 4 - -=item title() - -Returns the title of the DVD. - -=item studio() - -Returns the studio. - -=item directors() - -Returns a list of directors. Note that there's also a director() method -only returning the first director. - -=item starring() - -Returns a list of actors starring in the movie. - -=item upc() - -Returns the DVD's UPC as a string. - -=item media() - -Returns the DVD's media type as a string. - -=item nummedia() - -Returns the DVD's number of media (number of discs) as a string. -Amazon doesn't always send this back, so if you get undef assume it -is 1. - -=item theatrical_release_date() - -Returns the DVD's theatrical release date. - -=item mpaa_rating() - -Returns the DVD's MPAA rating. - -=item features() - -Returns the DVD's features as a list of strings. Examples: -"Color", "Closed-captioned", "Widescreen". - -=item new(xmlref => $xmlref) - -Initializes an object by passing a hash of hashes structure containing -the XML data returned from the service. Usually, this is just used by -C<Net::Amazon> internally to initialize objects for on backcoming -data. - -=back - -Check out L<Net::Amazon::Property> for all-purpose accessors, like -C<year>, C<OurPrice>, C<ListPrice>, etc. - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Property/Music.pm b/lib/Net/Amazon/Property/Music.pm deleted file mode 100644 index 59807be..0000000 --- a/lib/Net/Amazon/Property/Music.pm +++ /dev/null @@ -1,161 +0,0 @@ -###################################################################### -package Net::Amazon::Property::Music; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Property); - -__PACKAGE__->make_accessor($_) for qw(album label media nummedia upc); -__PACKAGE__->make_array_accessor($_) for qw(artists tracks); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - bless $self, $class; # Bless into this class - - if(exists $options{xmlref}) { - $self->init_via_xmlref($options{xmlref}); - } - - return $self; -} - -################################################## -sub artist { -################################################## - my($self, $nameref) = @_; - - # Only return the first artist - return ($self->artists($nameref))[0]; -} - -################################################## -sub init_via_xmlref { -################################################## - my($self, $xmlref) = @_; - - $self->SUPER::init_via_xmlref($xmlref); - - $self->artists($xmlref->{Artists}->{Artist}); - $self->tracks($xmlref->{Tracks}->{Track}); - $self->album($xmlref->{ProductName}); - $self->label($xmlref->{Manufacturer}); - $self->upc($xmlref->{Upc}); - $self->media($xmlref->{Media}); - $self->nummedia($xmlref->{NumMedia}); -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - return join('/', $self->artists) . ", " . - '"' . $self->album . '"' . ", " . - $self->year . ", " . - $self->OurPrice . ", " . - $self->Asin; -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Property::Music - Class for pop CDs on amazon.com - -=head1 SYNOPSIS - - use Net::Amazon; - - # ... - - if($resp->is_success()) { - for my $prop ($resp->properties) { - print join("/", $_->artists(), " ", - $_->album(), " ", - $_->label(), " ", - $_->year(), " "; - $_->upc(), " "; - $_->media(), " "; - $_->nummedia(), "\n"; - } - -=head1 DESCRIPTION - -C<Net::Amazon::Property::Music> is derived from -C<Net::Amazon::Property> and on top of the all-purpose -methods the base class provides, it offers specialized accessors for -popular music CD parameters. - -=head2 METHODS - -=over 4 - -=item artists() - -Returns a list of the CD's artists. There's also a C<artist()> method -which just returns the first artist. - -=item tracks() - -Returns a list of the CD's track titles. - -=item label() - -Returns the music label as a string. - -=item album() - -Returns the CD's title as a string. - -=item upc() - -Returns the CD's UPC as a string. - -=item media() - -Returns the CD's media type as a string. - -=item nummedia() - -Returns the CD's number of media (number of discs) as a string. -Amazon doesn't always send this back, so if you get undef assume it -is 1. - -=item new(xmlref => $xmlref) - -Initializes an object by passing a hash of hashes structure containing -the XML data returned from the service. Usually, this is just used by -C<Net::Amazon> internally to initialize objects for on backcoming -data. - -=back - -Check out L<Net::Amazon::Property> for all-purpose accessors, like -C<year>, C<OurPrice>, C<ListPrice>, etc. - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 THANKS - -Thanks to Padraic Renaghan E<lt>padraic@renaghan.com<gt> for adding -the upc/media/nummedia fields. - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - diff --git a/lib/Net/Amazon/Request.pm b/lib/Net/Amazon/Request.pm deleted file mode 100644 index 962d7bf..0000000 --- a/lib/Net/Amazon/Request.pm +++ /dev/null @@ -1,221 +0,0 @@ -###################################################################### -package Net::Amazon::Request; -###################################################################### - -use warnings; -use strict; - -use constant DEFAULT_MODE => 'books'; -use constant DEFAULT_TYPE => 'heavy'; -use constant DEFAULT_PAGE_COUNT => 1; -use constant DEFAULT_FORMAT => 'xml'; -use constant DEFAULT_SORT_CRITERIA => '+salesrank'; - -use constant VALID_TYPES => { map { $_ => 1 } qw(heavy lite) }; - -our $AMZN_XML_URL = "http://xml.amazon.com/onca/xml3"; - -################################################## -sub amzn_xml_url { -################################################## - return $AMZN_XML_URL; -} - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = { - mode => DEFAULT_MODE, - type => DEFAULT_TYPE, - page => DEFAULT_PAGE_COUNT, - f => DEFAULT_FORMAT, - sort => DEFAULT_SORT_CRITERIA, - %options, - }; - - die "Unknown type in ", __PACKAGE__, " constructor: ", - $self->{type} unless exists VALID_TYPES->{$self->{type}}; - - bless $self, $class; -} - -################################################## -sub params { -################################################## - my($self) = @_; - - return(%$self); -} - -################################################## -# Figure out the Response class to a given Request -# class. To be used by sub classes. -################################################## -sub response_class { -################################################## - my($self) = @_; - - my $response_class = ref($self); - $response_class =~ s/Request/Response/; - return $response_class; -} - -## -## 'PRIVATE' METHODS -## - -# CLASS->_convert_option( OPTIONS, ORIGINAL, TARGET [, CALLBACK] ) -# -# Takes a reference to a hash of OPTIONS and renames the -# ORIGINAL key name to the TARGET key name. If the optional -# CALLBACK subroutine reference is defined, that subroutine -# is invoked with two arguments: -# -# CALLBACK->( OPTIONS, TARGET ) -# -# The result of the CALLBACK's execution is then returned to -# the caller. No assumptions are made about what the CALLBACK -# should return (or even *if* is should return)--that's the -# caller's responsibility. -# -# Returns 1 in the absensence of a CALLBACK. -# -sub _convert_option { - my ($class, $options, $original, $target, $callback) = @_; - - if ( exists $options->{$original} ) { - $options->{$target} = $options->{$original}; - delete $options->{$original}; - } - - return 1 unless ( $callback ); - - # The key name is explicitly passed-in so that the caller doesn't - # have think "Hrmm.. now which key am I working on, the original - # or the target key?" Confusion is bad. - return $callback->($options, $target); -} - -# CLASS->_assert_options_defined( OPTIONS, KEYS ) -# -# Takes a reference to a hash of OPTIONS and a list of -# one or more KEYS. Tests to see if each key in KEYS -# has a defined value. Calls die() upon the first -# missing key. Otherwise, returns undef. -# -sub _assert_options_defined { - my ($class, $options, @keys) = @_; - - foreach my $key ( @keys ) { - die "Mandatory parameter '$key' not defined" - unless ( defined $options->{$key} ); - } -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Request - Baseclass for requests to Amazon's web service - -=head1 SYNOPSIS - - my $req = Net::Amazon::Request::XXX->new( - [ type => 'heavy', ] - [ page => $start_page, ] - [ mode => $mode, ] - [ offer => 'All', ] - [ sort => $sort_type, ] - ); - -=head1 DESCRIPTION - -Don't use this class directly, use derived classes -(like C<Net::Amazon::Request::ASIN>, C<Net::Amazon::Request::Wishlist> -etc.) instead to specify the type of request and its parameters. - -However, there's a bunch of parameters to the constructor -that all request types have in common, here they are: - -=over 4 - -=item type - -Defaults to C<heavy>, but can be set to C<lite> if no reviews etc. -on a product are wanted. Some fields (e.g. C<isbn>) are not going to be -available in C<lite> mode, though. - -=item mode - -Defaults to C<books>, but can be set to other catalog values. - -=item page - -Defaults to C<1>, but can be set to a different number to -start with a different result page. Used in conjunction with the -C<max_pages> parameter of the C<Net::Amazon> object. C<page> is the -offset, C<max_pages> is the maximum number of pages pulled in starting -at C<page>. - -=item sort - -Defaults to C<+salesrank>, but search results can be sorted in various -ways, depending on the type of product returned by the search. Search -results may be sorted by the following criteria: - -=over 8 - -=item * -Featured Items - -=item * -Bestselling - -=item * -Alphabetical (A-Z and Z-A) - -=item * -Price (High to Low and Low to High) - -=item * -Publication or Release Date - -=item * -Manufacturer - -=item * -Average Customer Review - -=item * -Artist Name - -=back - -Consult L<Net::Amazon::Request::Sort> for details. - -=item offer - -To receive values for the fields -C<CollectibleCount>, C<NumberOfOfferings>, C<UsedCount>, -specify C<offer =E<gt> "All">. - -=back - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Request/ASIN.pm b/lib/Net/Amazon/Request/ASIN.pm deleted file mode 100644 index 4d8f752..0000000 --- a/lib/Net/Amazon/Request/ASIN.pm +++ /dev/null @@ -1,139 +0,0 @@ -###################################################################### -package Net::Amazon::Request::ASIN; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Request); - -# These values are defined in the AWS SDK -# (http://amazon.com/webservices) under -# "Product and Catalog Data" / "ASIN and ISBN Searches" -use constant MAX_ASINS_PER_TYPE => { - heavy => 10, - lite => 30, -}; - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - $class->_assert_options_defined(\%options, 'asin'); - - $class->_convert_option(\%options, - 'asin', - 'AsinSearch', - \&_process_asin_option); - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -## -## PRIVATE FUNCTIONS -## - -# _process_asin_option( OPTIONS, KEY ) -# -# Takes a reference to a hash of OPTIONS and checks the value keyed by -# KEY to make sure it looks legitimate. If the value associated with -# KEY is an array, we check to make sure that we're not asking for -# too many asins at once. -# -# Returns true if all goes well. If any problems are encountered, -# die() will be called. -# -sub _process_asin_option { - my ($options, $key) = @_; - - # If the asins are supplied in the form of an array, we have to - # make sure that the caller isn't trying to ask for too many at a - # time. If we don't make this test, those excessive asins will be - # silently ignored by the AWS servers...resulting in potentially - # confusing results for the user. - if ( ref $options->{$key} eq 'ARRAY' ) { - my $type = $options->{'type'} || __PACKAGE__->SUPER::DEFAULT_TYPE; - my $max_asins = MAX_ASINS_PER_TYPE->{$type}; - - # Dying is the right thing to do here because this is - # indicative of a programming error. - die "Only $max_asins may be requested at a time using type '$type'" - if ( @{$options->{$key}} > $max_asins ); - - $options->{$key} = join ',', @{$options->{$key}}; - } elsif ( ref $options->{$key} ) { - die "The 'asin' parameter must either be a scalar or an array"; - } - - return 1; -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Request::ASIN - Class for submitting ASIN requests - -=head1 SYNOPSIS - - use Net::Amazon; - use Net::Amazon::Request::ASIN; - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN' - ); - - my $req = Net::Amazon::Request::ASIN->new( - asin => '0201360683' - ); - - # Response is of type Net::Amazon::Response::ASIN - my $resp = $ua->request($req); - -=head1 DESCRIPTION - -C<Net::Amazon::Request::ASIN> is a class used to submit ASIN requests -to the Amazon web service. - -The ASIN of the item to look is specified in the C<asin> parameter. - -Upon success, the responses' C<properties()> method will return one -single C<Net::Amazon::Property::*> object. - -=head2 METHODS - -=over 4 - -=item new( asin => $asin ) - -Constructs a new C<Net::Amazon::Request::ASIN> object, used to query -the Amazon web service for an item with the specified ASIN number. - -C<$asin> can also be a reference to an array of ASINs, like in - - $ua->search(asin => ["0201360683", "0596005083"]) - -in which case a search for multiple ASINs is performed, returning a list of -results. - -=back - -Check L<Net::Amazon::Request> for common request parameters not listed here. - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Request/Artist.pm b/lib/Net/Amazon/Request/Artist.pm deleted file mode 100644 index 4c111f8..0000000 --- a/lib/Net/Amazon/Request/Artist.pm +++ /dev/null @@ -1,86 +0,0 @@ -###################################################################### -package Net::Amazon::Request::Artist; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Request); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - if(exists $options{artist}) { - $options{ArtistSearch} = $options{artist}; - delete $options{artist}; - $options{mode} = "music"; - } else { - die "Mandatory parameter 'artist' not defined"; - } - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Request::Artist - Class for submitting Artist requests - -=head1 SYNOPSIS - - use Net::Amazon; - use Net::Amazon::Request::Artist; - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN' - ); - - my $req = Net::Amazon::Request::Artist->new( - artist => 'Zwan' - ); - - # Response is of type Net::Amazon::Response::Artist - my $resp = $ua->request($req); - -=head1 DESCRIPTION - -C<Net::Amazon::Request::Artist> is a class used to submit Artist search -requests to the Amazon web service. - -The artist to search for is specified in the C<artist> parameter. - -Upon success, the responses' C<properties()> method will return a list of -C<Net::Amazon::Property::Music> objects. - -Check L<Net::Amazon::Request> for common request parameters not listed here. - -=head2 METHODS - -=over 4 - -=item new( artist => $artist ) - -Constructs a new C<Net::Amazon::Request::Artist> object, used to query -the Amazon web service for items of a given artist. - -=back - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Request/Blended.pm b/lib/Net/Amazon/Request/Blended.pm deleted file mode 100644 index 1000eec..0000000 --- a/lib/Net/Amazon/Request/Blended.pm +++ /dev/null @@ -1,80 +0,0 @@ -###################################################################### -package Net::Amazon::Request::Blended; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Request); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - $class->_assert_options_defined(\%options, 'blended'); - - $class->_convert_option(\%options, - 'blended', - 'BlendedSearch'); - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Request::Blended - request class for 'Blended Search' - -=head1 SYNOPSIS - - use Net::Amazon; - use Net::Amazon::Request::Blended; - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN' - ); - - my $req = Net::Amazon::Request::Blended->new( - blended => 'perl' - ); - - # Response is of type Net::Amazon::Response::Blended - my $resp = $ua->request($req); - -=head1 DESCRIPTION - -C<Net::Amazon::Request::Blended> is a class used to request -I<Blended Searches> from the Amazon web service. - -The C<blended> parameter specifies the keyword search string -for the blended query. C<mode> is not applicable to blended -searches which returns books, music, etc all at once. - -Upon success, the response's C<properties()> method will return a list -of C<Net::Amazon::Property::*> objects. - -=head2 METHODS - -=over 4 - -=item new(keyword => $search_string) - -Constructs a new C<Net::Amazon::Request::Blended> object. - -See the "Amazon Web Services 2.1 API and Integration Guide" for details. - -=back - -Check L<Net::Amazon::Request> for common request parameters not listed here. - -=head1 SEE ALSO - -=head1 AUTHORS - -Robert Graff, E<lt>rgraff@workingdemo.comE<gt> - -=cut diff --git a/lib/Net/Amazon/Request/BrowseNode.pm b/lib/Net/Amazon/Request/BrowseNode.pm deleted file mode 100644 index 2f8d92f..0000000 --- a/lib/Net/Amazon/Request/BrowseNode.pm +++ /dev/null @@ -1,137 +0,0 @@ -###################################################################### -package Net::Amazon::Request::BrowseNode; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Request); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - $class->_assert_options_defined(\%options, - qw(browsenode mode)); - - $class->_convert_option(\%options, - 'browsenode', - 'BrowseNodeSearch', - \&_assert_node_is_numeric); - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -## -## 'PRIVATE' FUNCTIONS -## - -# _assert_node_is_numeric( OPTIONS, KEY ) -# -# Takes a reference to a hash of OPTIONS and makes sure -# that the browse node id keyed by KEY is numeric. -# -# Returns if all is well, dies otherwise. -# -sub _assert_node_is_numeric { - my ($options, $key) = @_; - - die "Browse Node ID must be numeric." - if ( $options->{$key} =~ /\D/ ); -} - - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Request::BrowseNode - request class for browse node search - -=head1 SYNOPSIS - - use Net::Amazon; - use Net::Amazon::Request::BrowseNode; - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN' - ); - - my $req = Net::Amazon::Request::BrowseNode->new( - browsenode => 30, - mode => 'books' - ); - - # Response is of type Net::Amazon::Response::BrowseNode - my $resp = $ua->request($req); - -=head1 DESCRIPTION - -C<Net::Amazon::Request::BrowseNode> is a class used to submit node search -requests to the Amazon web service. - -The node to search for is specified in the C<browsenode> parameter. The -browse node ID is a number that corresponds to a general subject area -of Amazon.com. - -To find browse node IDs, the best way is to visit the "browse" area -of the various product lines at Amazon.com. When you find a subject area -that you would like to generate XML for, look at the web page URL. The -browse ID should appear after the string "/tg/browse/-/". Here are some -examples of URLs that contain browse IDs: - -=over 8 - -http://www.amazon.com/exec/obidos/tg/browse/-/30 -(In this example, the browse ID = 30) - -http://www.amazon.com/exec/obidos/tg/browse/-/467970 -(In this example, the browse ID = 467970) - -http://www.amazon.com/exec/obidos/tg/browse/-/602314 -(In this example, the browse ID = 60231 - -=back - -Please be aware that some nodes cannot be used with a -BrowseNodeSearch. (The vast majority of them can, but you -may run across a few that simply will not work). It is also -important to point out that from time to time, some browse -nodes are deprecated or are changed without notice. - -The catalog to search in is specified in the C<mode> parameter, -typical values are C<books>, C<music>, C<classical> or C<electronics>. - -An optional C<keywords> parameter may be added to filter the results by that keyword. - -Upon success, the responses' C<properties()> method will return a list of -C<Net::Amazon::Properties::*> objects. - -=head2 METHODS - -=over 4 - -=item new( browsenode => $nodeID, mode => $mode [, keywords => $keywords] ) - -Constructs a new C<Net::Amazon::Request::BrowseNode> object, used to query -the Amazon web service for items in a particular category (node) in the -mode (catalog) specified. - -=back - -Check L<Net::Amazon::Request> for common request parameters not listed here. - -=head1 AUTHOR - -Net::Amazon framework by Mike Schilli, E<lt>m@perlmeister.comE<gt> - -BrowseNode.pm by Jackie Hamilton, E<lt>kira@cgi101.comE<gt> - -=head1 LICENSE - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Request/Exchange.pm b/lib/Net/Amazon/Request/Exchange.pm deleted file mode 100644 index df75549..0000000 --- a/lib/Net/Amazon/Request/Exchange.pm +++ /dev/null @@ -1,91 +0,0 @@ -###################################################################### -package Net::Amazon::Request::Exchange; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Request); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - if(exists $options{exchange}) { - $options{ExchangeSearch} = $options{exchange}; - delete $options{exchange}; - $options{type} = "lite"; - $options{mode} = ""; - } else { - die "Mandatory parameter 'exchange' not defined"; - } - -# if(!exists $options{exchange}) { -# die "Mandatory parameter 'exchange' not defined"; -# } - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Request::Exchange - Class for submitting Exchange requests - -=head1 SYNOPSIS - - use Net::Amazon; - use Net::Amazon::Request::Exchange; - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN' - ); - - my $req = Net::Amazon::Request::Exchange->new( - exchange => 'Y04Y3424291Y2398445' - ); - - # Response is of type Net::Amazon::Response::Seller - my $resp = $ua->request($req); - -=head1 DESCRIPTION - -C<Net::Amazon::Request::Exchange> is a class used to submit Exchange search -requests to the Amazon web service. Exchange requests send an item's -exchange ID and retrieve a description of the item, offered by a third -party seller on Amazon. - -Upon success, the responses' C<result()> method will return a single -C<Net::Amazon::Result::Seller::Listing> object. - -Check L<Net::Amazon::Request> for common request parameters not listed here. - -=head2 METHODS - -=over 4 - -=item new( exchange => $exchange_id ) - -Constructs a new C<Net::Amazon::Request::Exchange> object, used to query -the Amazon web service with the given seller id. - -=back - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2005 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Request/Keyword.pm b/lib/Net/Amazon/Request/Keyword.pm deleted file mode 100644 index 0b15d1d..0000000 --- a/lib/Net/Amazon/Request/Keyword.pm +++ /dev/null @@ -1,90 +0,0 @@ -###################################################################### -package Net::Amazon::Request::Keyword; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Request); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - $class->_assert_options_defined(\%options, - qw(keyword mode)); - - $class->_convert_option(\%options, - 'keyword', - 'KeywordSearch'); - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Request::Keyword - request class for keyword search - -=head1 SYNOPSIS - - use Net::Amazon; - use Net::Amazon::Request::Keyword; - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN' - ); - - my $req = Net::Amazon::Request::Keyword->new( - keyword => 'Zwan', - mode => 'books' - ); - - # Response is of type Net::Amazon::Response::Keyword - my $resp = $ua->request($req); - -=head1 DESCRIPTION - -C<Net::Amazon::Request::Keyword> is a class used to submit keyword search -requests to the Amazon web service. - -The keyword to search for is specified in the C<keyword> parameter. - -The catalog to search in is specified in the C<mode> parameter, -typical values are C<books>, C<music>, C<classical> or C<electronics>. - -Upon success, the responses' C<properties()> method will return a list of -C<Net::Amazon::Property::*> objects. - -=head2 METHODS - -=over 4 - -=item new( keyword => $keyword, mode => $mode ) - -Constructs a new C<Net::Amazon::Request::Keyword> object, used to query -the Amazon web service for items matching a given keyword in the -mode (catalog) specified. - -=back - -Check L<Net::Amazon::Request> for common request parameters not listed here. - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Request/Manufacturer.pm b/lib/Net/Amazon/Request/Manufacturer.pm deleted file mode 100644 index 0e8adb8..0000000 --- a/lib/Net/Amazon/Request/Manufacturer.pm +++ /dev/null @@ -1,78 +0,0 @@ -######################################
-package Net::Amazon::Request::Manufacturer;
-######################################
-use warnings;
-use strict;
-use base qw(Net::Amazon::Request);
-
-######################################
-sub new {
-######################################
- my($class, %options) = @_;
-
- $class->_assert_options_defined(\%options,
- 'manufacturer');
-
- $class->_convert_option(\%options,
- 'manufacturer',
- 'ManufacturerSearch');
-
- my $self = $class->SUPER::new(%options);
-
- bless $self, $class; # reconsecrate
-}
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Amazon::Request::Manufacturer - Class for submitting Manufacturer requests
-
-=head1 SYNOPSIS
-
- use Net::Amazon;
- use Net::Amazon::Request::Manufacturer;
-
- my $ua = Net::Amazon->new(
- token => 'YOUR_AMZN_TOKEN'
- );
-
- my $req = Net::Amazon::Request::Manufacturer->new(
- manufacturer => 'Disney'
- );
-
- # Response is of type Net::Amazon::Response::Manufacturer
- my $resp = $ua->request($req);
-
-=head1 DESCRIPTION
-
-C<Net::Amazon::Request::Manufacturer> is a class used to submit
-searches for items made by a given manufacturer.
-
-The manufacturer to search for is specified in the C<manufacturer> parameter.
-
-Upon success, the responses' C<properties()> method will return one
-or more C<Net::Amazon::Property::*> objects.
-
-=head2 METHODS
-
-=over 4
-
-=item new( manufacturer => $manufacturer )
-
-Constructs a new C<Net::Amazon::Request::Manufacturer> object, used to query
-the Amazon web service for an item with the specified manufacturer name.
-
-=back
-
-Check L<Net::Amazon::Request> for common request parameters not listed here.
-
-=head1 SEE ALSO
-
-=head1 AUTHORS
-
-Bill Fitzpatrick
-Mike Schilli, E<lt>m@perlmeister.comE<gt>
-
-=cut
diff --git a/lib/Net/Amazon/Request/Power.pm b/lib/Net/Amazon/Request/Power.pm deleted file mode 100644 index fdfd74e..0000000 --- a/lib/Net/Amazon/Request/Power.pm +++ /dev/null @@ -1,95 +0,0 @@ -###################################################################### -package Net::Amazon::Request::Power; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Request); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - $class->_assert_options_defined(\%options, - qw(power mode)); - - $class->_convert_option(\%options, - 'power', - 'PowerSearch'); - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Request::Power - request class for 'Power Search' - -=head1 SYNOPSIS - - use Net::Amazon; - use Net::Amazon::Request::Power; - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN' - ); - - my $req = Net::Amazon::Request::Power->new( - power => 'subject: perl and author: schwartz', - mode => 'books', - ); - - # Response is of type Net::Amazon::Response::Power - my $resp = $ua->request($req); - -=head1 DESCRIPTION - -C<Net::Amazon::Request::Power> is a class used to request -so-called I<Power Searches> from the Amazon web service. - -The C<power> parameter specifies the power search string, C<mode> -defines which properties to look for. - -Upon success, the response's C<properties()> method will return a list -of C<Net::Amazon::Property::*> objects. - -=head2 METHODS - -=over 4 - -=item new(power => $search_string, mode => $property) - -Constructs a new C<Net::Amazon::Request::Power> object. C<$property> -is typically C<"books">. Examples for C<$search_string> are: - - author: schwartz - - author: schwartz and pubdate: after 10-2002 - - subject: perl and (objects or object-oriented) - - keywords: "high tech*" and not fiction and pubdate: during 1999 - - power "author: randal schwartz and publisher: Addison Wesley" - - author: randal schwartz and title: object books - -See the "Amazon Web Services 2.1 API and Integration Guide" for details. - -=back - -Check L<Net::Amazon::Request> for common request parameters not listed here. - -=head1 SEE ALSO - -=head1 AUTHORS - -Martin Streicher, E<lt>martin.streicher@apress.comE<gt> -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=cut diff --git a/lib/Net/Amazon/Request/Seller.pm b/lib/Net/Amazon/Request/Seller.pm deleted file mode 100644 index 54e1930..0000000 --- a/lib/Net/Amazon/Request/Seller.pm +++ /dev/null @@ -1,84 +0,0 @@ -###################################################################### -package Net::Amazon::Request::Seller; -###################################################################### -use base qw(Net::Amazon::Request); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - if(exists $options{seller}) { - $options{SellerSearch} = $options{seller}; - delete $options{seller}; - } else { - die "Mandatory parameter 'seller' not defined"; - } - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Request::Seller - Class for submitting Seller requests - -=head1 SYNOPSIS - - use Net::Amazon; - use Net::Amazon::Request::Seller; - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN' - ); - - my $req = Net::Amazon::Request::Seller->new( - seller => 'A2GXAGU54VOP7' - ); - - # Response is of type Net::Amazon::Response::Seller - my $resp = $ua->request($req); - -=head1 DESCRIPTION - -C<Net::Amazon::Request::Seller> is a class used to submit Seller search -requests to the Amazon web service. - -The seller to search for is specified in the C<seller> parameter, which -contains the seller's ID (not the seller's nickname!). - -Upon success, the responses' C<result()> method will return a single -C<Net::Amazon::Result::Seller> object. - -Check L<Net::Amazon::Request> for common request parameters not listed here. - -=head2 METHODS - -=over 4 - -=item new( seller => $seller_id ) - -Constructs a new C<Net::Amazon::Request::Seller> object, used to query -the Amazon web service with the given seller id. - -=back - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2004 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Request/Similar.pm b/lib/Net/Amazon/Request/Similar.pm deleted file mode 100644 index c5b5a53..0000000 --- a/lib/Net/Amazon/Request/Similar.pm +++ /dev/null @@ -1,95 +0,0 @@ -###################################################################### -package Net::Amazon::Request::Similar; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Request); - -our $AMZN_XML_URL = "http://xml.amazon.com/onca/xml3"; - -################################################## -sub amzn_xml_url { -################################################## - return $AMZN_XML_URL; -} - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - # For backwards compatibility - $class->_convert_option(\%options, 'asin', 'similar'); - - $class->_assert_options_defined(\%options, 'similar'); - - $class->_convert_option(\%options, - 'similar', - 'SimilaritySearch'); - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Request::Similar - request class for 'Similarities Search' - -=head1 SYNOPSIS - - use Net::Amazon; - use Net::Amazon::Request::Similar; - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN' - ); - - my $req = Net::Amazon::Request::Similar->new( - similar => 'B00005B6TL', - ); - - # Response is of type Net::Amazon::Response::Similar - my $resp = $ua->request($req); - -=head1 DESCRIPTION - -C<Net::Amazon::Request::Similar> is a class used to request -so-called I<Similarities Searches> from the Amazon web service. - -The C<asin> parameter specifies the ASIN of the item which you want -to get similar items for. - -Upon success, the response's C<properties()> method will return a list -of C<Net::Amazon::Property::*> objects. - -=head2 METHODS - -=over 4 - -=item new(similar => $asin) - -Constructs a new C<Net::Amazon::Request::Similar> object. - -=back - -Check L<Net::Amazon::Request> for common request parameters not listed here. - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Request/Sort.pm b/lib/Net/Amazon/Request/Sort.pm deleted file mode 100644 index 059845d..0000000 --- a/lib/Net/Amazon/Request/Sort.pm +++ /dev/null @@ -1,246 +0,0 @@ -=pod
-
-=head1 SORT TYPES
-
-Search results can be sorted in various ways, depending on the type of
-product returned by the search. If a sort parameter isn't specified in
-the request, the results will be ordered as if the +salesrank value is
-specified.
-
-=head2 Sorting Books Results
-
- +---------------------------------------------------+
- | Sort Type | Value |
- |-------------------------+-------------------------+
- | Featured Items | +pmrank |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Average Customer Review | +reviewrank |
- |-------------------------+-------------------------+
- | Price (Low to High) | +pricerank |
- |-------------------------+-------------------------+
- | Price (High to Low) | +inverse-pricerank |
- |-------------------------+-------------------------+
- | Publication Date | +daterank |
- |-------------------------+-------------------------+
- | Alphabetical (A-Z) | +titlerank |
- |-------------------------+-------------------------+
- | Alphabetical (Z-A) | -titlerank |
- +---------------------------------------------------+
-
-=head2 Sorting Software Results
-
- +---------------------------------------------------+
- | Sort Type | Value |
- |-------------------------+-------------------------+
- | Featured items | +pmrank |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Alphabetical | +titlerank |
- |-------------------------+-------------------------+
- | Price (High to Low) | +price |
- |-------------------------+-------------------------+
- | Price (Low to High) | -price |
- +---------------------------------------------------+
-
-=head2 Sorting Outdoor Living Results
-
- +---------------------------------------------------+
- | Sort Type | Value |
- |-------------------------+-------------------------+
- | Featured Items | +psrank |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Alphabetical (A-Z) | +titlerank |
- |-------------------------+-------------------------+
- | Alphabetical (Z-A) | -titlerank |
- |-------------------------+-------------------------+
- | Manufacturer (A-Z) | +manufactrank |
- |-------------------------+-------------------------+
- | Manufacturer (Z-A) | -manufactrank |
- |-------------------------+-------------------------+
- | Price (Low to High) | +price |
- |-------------------------+-------------------------+
- | Price (High to Low) | -price |
- +---------------------------------------------------+
-
-=head2 Sorting Tools Results
-
- +---------------------------------------------------+
- | Sort Type | Value |
- |-------------------------+-------------------------+
- | Featured Items | +psrank |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Alphabetical (A-Z) | +titlerank |
- |-------------------------+-------------------------+
- | Alphabetical (Z-A) | -titlerank |
- |-------------------------+-------------------------+
- | Manufacturer (A-Z) | +manufactrank |
- |-------------------------+-------------------------+
- | Manufacturer (Z-A) | -manufactrank |
- |-------------------------+-------------------------+
- | Price (Low to High) | +price |
- |-------------------------+-------------------------+
- | Price (High to Low) | -price |
- +---------------------------------------------------+
-
-=head2 Sorting Camera and Photo Results
-
- +---------------------------------------------------+
- | Sort Type | Value |
- |-------------------------+-------------------------+
- | Featured Items | +pmrank |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Alphabetical (A-Z) | +titlerank |
- |-------------------------+-------------------------+
- | Alphabetical (Z-A) | -titlerank |
- +---------------------------------------------------+
-
-=head2 Sorting Computers Results
-
- +---------------------------------------------------+
- | Sort Type | Value |
- |-------------------------+-------------------------+
- | Featured Items | +psrank |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Alphabetical (A-Z) | +titlerank |
- |-------------------------+-------------------------+
- | Alphabetical (Z-A) | -titlerank |
- +---------------------------------------------------+
-
-=head2 Sorting Video Games Results
-
- +---------------------------------------------------+
- | Sort Type | Value |
- |-------------------------+-------------------------+
- | Featured Items | +pmrank |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Alphabetical | +titlerank |
- |-------------------------+-------------------------+
- | Price (Low to High) | +price |
- |-------------------------+-------------------------+
- | Price (High to Low) | -price |
- +---------------------------------------------------+
-
-=head2 Sorting Music Results
-
- +---------------------------------------------------+
- | Sort Type | Value |
- |-------------------------+-------------------------+
- | Featured Items | +psrank |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Artist Name | +artistrank |
- |-------------------------+-------------------------+
- | Original Release Date | +orig-rel-date |
- |-------------------------+-------------------------+
- | Alphabetical | +titlerank |
- +---------------------------------------------------+
-
-=head2 Sorting Office Products Results
-
- +---------------------------------------------------+
- | Sort Type | Value |
- |-------------------------+-------------------------+
- | Featured Items | +pmrank |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Alphabetical (A-Z) | +titlerank |
- |-------------------------+-------------------------+
- | Alphabetical (Z-A) | -titlerank |
- |-------------------------+-------------------------+
- | Price (Low to High) | +price |
- |-------------------------+-------------------------+
- | Price (High to Low) | -price |
- |-------------------------+-------------------------+
- | Review | +reviewrank |
- +---------------------------------------------------+
-
-=head2 Sorting Video Results
-
- +---------------------------------------------------+
- | Sort Type | Value |
- |-------------------------+-------------------------+
- | Featured Items | +psrank |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Alphabetical | +titlerank |
- +---------------------------------------------------+
-
-=head2 Sorting Electronics Results
-
- +---------------------------------------------------+
- | Type | Value |
- |-------------------------+-------------------------+
- | Featured Items | +pmrank |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Alphabetical | +titlerank |
- |-------------------------+-------------------------+
- | Review | +reviewrank |
- +---------------------------------------------------+
-
-=head2 Sorting DVDs Results
-
- +---------------------------------------------------+
- | Type | Value |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Alphabetical | +titlerank |
- +---------------------------------------------------+
-
-=head2 Sorting Kitchen Results
-
- +---------------------------------------------------+
- | Type | Value |
- |-------------------------+-------------------------+
- | Featured Items | +pmrank |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Alphabetical (A-Z) | +titlerank |
- |-------------------------+-------------------------+
- | Alphabetical (Z-A) | -titlerank |
- |-------------------------+-------------------------+
- | Manufacturer (A-Z) | +manufactrank |
- |-------------------------+-------------------------+
- | Manufacturer (Z-A) | -manufactrank |
- |-------------------------+-------------------------+
- | Price (Low to High) | +price |
- |-------------------------+-------------------------+
- | Price (High to Low) | -price |
- +---------------------------------------------------+
-
-=head2 Sorting Toys Results
-
- +---------------------------------------------------+
- | Type | Value |
- |-------------------------+-------------------------+
- | Featured Items | +pmrank |
- |-------------------------+-------------------------+
- | Bestselling | +salesrank |
- |-------------------------+-------------------------+
- | Price (Low to High) | +pricerank |
- |-------------------------+-------------------------+
- | Price (High to Low) | +inverse-pricerank |
- |-------------------------+-------------------------+
- | Alphabetical (A-Z) | +titlerank |
- +---------------------------------------------------+
-
-=cut
diff --git a/lib/Net/Amazon/Request/TextStream.pm b/lib/Net/Amazon/Request/TextStream.pm deleted file mode 100644 index 62a0717..0000000 --- a/lib/Net/Amazon/Request/TextStream.pm +++ /dev/null @@ -1,76 +0,0 @@ -######################################################################
-package Net::Amazon::Request::TextStream;
-######################################################################
-use warnings;
-use strict;
-use base qw(Net::Amazon::Request);
-
-##################################################
-sub new {
-##################################################
- my($class, %options) = @_;
-
- $class->_assert_options_defined(\%options,
- 'textstream');
-
- $class->_convert_option(\%options,
- 'textstream',
- 'TextStreamSearch');
-
- my $self = $class->SUPER::new(%options);
-
- bless $self, $class; # reconsecrate
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Amazon::Request::TextStream - request class for text stream search
-
-=head1 SYNOPSIS
-
- use Net::Amazon;
- use Net::Amazon::Request::TextStream;
-
- my $ua = Net::Amazon->new(
- token => 'YOUR_AMZN_TOKEN'
- );
-
- my $req = Net::Amazon::Request::TextStream->new(
- textstream => 'Here is some text that mentions the Rolling Stones.',
- );
-
- # Response is of type Net::Amazon::Response::TextStream
- my $resp = $ua->request($req);
-
-=head1 DESCRIPTION
-
-C<Net::Amazon::Request::TextStream> is a class used to perform a search on
-a block of text. Amazon extracts keywords from the given block of text,
-but note that conjunctions and helper words, such as "and", "or", "the",
-etc. are not excluded, so strip them out yourself if need be.
-
-TextStream searching is only available for the US service.
-
-Upon success, the response's C<properties()> method will return a list
-of C<Net::Amazon::Property::*> objects.
-
-=head2 METHODS
-
-=over 4
-
-=item new(textstream => $text)
-
-Constructs a new C<Net::Amazon::Request::TextStream> object, used to query
-the Amazon web service with a block of text.
-
-=back
-
-Check L<Net::Amazon::Request> for common request parameters not listed here.
-
-=head1 SEE ALSO
-
-=cut
diff --git a/lib/Net/Amazon/Request/UPC.pm b/lib/Net/Amazon/Request/UPC.pm deleted file mode 100644 index ae77645..0000000 --- a/lib/Net/Amazon/Request/UPC.pm +++ /dev/null @@ -1,94 +0,0 @@ -###################################################################### -package Net::Amazon::Request::UPC; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Request); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - $class->_assert_options_defined(\%options, 'upc'); - - $class->_convert_option(\%options, - 'upc', - 'UpcSearch'); - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Request::UPC - request class for UPC search - -=head1 SYNOPSIS - - use Net::Amazon; - use Net::Amazon::Request::UPC; - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN' - ); - - my $req = Net::Amazon::Request::UPC->new( - upc => '724381198421', - mode => 'music', - - ); - - # Response is of type Net::Amazon::Response::UPC - my $resp = $ua->request($req); - -=head1 DESCRIPTION - -C<Net::Amazon::Request::UPC> is a class used to submit UPC (product barcode) -search requests to the Amazon web service. - -The UPC number to search for is specified in the C<upc> parameter. -It currently works with the following values of the C<mode> parameter: -C<music>, -C<classical>, -C<software>, -C<dvd>, -C<video>, -C<vhs>, -C<electronics>, -C<pc-hardware>, and -C<photo>. - -Upon success, the response's C<properties()> method will return a single -C<Net::Amazon::Property::Music> object. - -=head2 METHODS - -=over 4 - -=item new(upc => $upc) - -Constructs a new C<Net::Amazon::Request::UPC> object, used to query -the Amazon web service for an item with the given UPC number. - -=back - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Request/Wishlist.pm b/lib/Net/Amazon/Request/Wishlist.pm deleted file mode 100644 index 824d5d4..0000000 --- a/lib/Net/Amazon/Request/Wishlist.pm +++ /dev/null @@ -1,89 +0,0 @@ -###################################################################### -package Net::Amazon::Request::Wishlist; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Request); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - # For backwards compatibility: - $class->_convert_option(\%options, 'id', 'wishlist'); - - $class->_assert_options_defined(\%options, 'wishlist'); - - $class->_convert_option(\%options, - 'wishlist', - 'WishlistSearch'); - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Request::Wishlist - request class for wishlist search - -=head1 SYNOPSIS - - use Net::Amazon; - use Net::Amazon::Request::Wishlist; - - my $ua = Net::Amazon->new( - token => 'YOUR_AMZN_TOKEN' - ); - - my $req = Net::Amazon::Request::Wishlist->new( - wishlist => '1XL5DWOUFMFVJ', - ); - - # Response is of type Net::Amazon::Response::Wishlist - my $resp = $ua->request($req); - -=head1 DESCRIPTION - -C<Net::Amazon::Request::Wishlist> is a class used to request -a specified wishlist. - -The wishlist ID (can be found as parameters in URLs when a customer's -Amazon wishlist is being pulled up) is specified in the C<id> parameter. - -Upon success, the response's C<properties()> method will return a list -of C<Net::Amazon::Property::*> objects. - -=head2 METHODS - -=over 4 - -=item new(wishlist => $id) - -Constructs a new C<Net::Amazon::Request::Wishlist> object, used to query -the Amazon web service for a specific wishlist, identified by the wishlist -ID. - -=back - -Check L<Net::Amazon::Request> for common request parameters not listed here. - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Response.pm b/lib/Net/Amazon/Response.pm deleted file mode 100644 index 6147e0e..0000000 --- a/lib/Net/Amazon/Response.pm +++ /dev/null @@ -1,214 +0,0 @@ -###################################################################### -package Net::Amazon::Response; -###################################################################### -use warnings; -use strict; - -use base qw(Net::Amazon); - -use Text::Wrap qw($columns wrap); -use XML::Simple; - -our @FORCE_ARRAY_FIELDS = (); - -__PACKAGE__->make_accessor($_) for qw( - status messages items xmlref total_results); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = { - status => "", - messages => [], - items => [], - xmlref => {}, - total_results => undef, - }; - - bless $self, $class; -} - -sub message { - my($self) = @_; - - return join(";",@{$self->{messages}}); -} - -########################################### -sub is_success { -########################################### - my($self) = @_; - - return $self->{status} ? 1 : ""; -} - -########################################### -sub is_error { -########################################### - my($self) = @_; - - return !$self->is_success(); -} - -########################################### -sub push_item { -########################################### - my($self, $item) = @_; - - push @{$self->{items}}, $item; -} - -########################################### -sub as_string { -########################################### - my($self) = @_; - - return Data::Dumper::Dumper($self); -} - -########################################### -sub list_as_string { -########################################### - my($self, @properties) = @_; - - my $full = ""; - - # Column with - $columns = 60; - my $bullet = 1; - - foreach my $property (@properties) { - $full .= "\n" if $full; - my $bullet_string = sprintf("[%d]%s", - $bullet, (" " x (3-length($bullet)))); - $full .= wrap("", " ", $bullet_string . $property->as_string()); - $bullet++; - } - - return $full; -} - -################################################## -sub properties { -################################################## - my($self) = @_; - - my @properties = (); - - if($self->is_success && ref($self->{xmlref}->{Details}) eq 'ARRAY') { - foreach my $xmlref (@{$self->{xmlref}->{Details}}) { - my $property = Net::Amazon::Property::factory(xmlref => $xmlref); - push @properties, $property; - } - } - - if(wantarray) { - return (@properties); - } - - if(@properties) { - # Scalar context and we've got results. Return the first one. - return $properties[0]; - } - - # Scalar context and we don't have anything. - return undef; -} - -################################################## -sub xml_parse { -################################################## - my($self, $xml) = @_; - - my $xs = XML::Simple->new(); - return $xs->XMLin($xml, ForceArray => [ @FORCE_ARRAY_FIELDS ]); -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Response - Baseclass for responses from Amazon's web service - -=head1 SYNOPSIS - - $resp = $ua->request($request); - - if($resp->is_success()) { - print $resp->as_string(); - } - - if($resp->is_error()) { - print $resp->message(); - } - - if($resp->is_success()) { - for my $property ($resp->properties) { - print $property->as_string(), "\n"; - } - } - -=head1 DESCRIPTION - -C<Net::Amazon::Response> is the baseclass for responses coming back -from the useragent's C<request> method. Responses are typically -not of type C<Net::Amazon::Response> but one of its subclasses -C<Net::Amazon::Response::*>. However, for basic error handling and -dumping content, C<Net::Amazon::Response>'s methods are typically used, -because we typically don't know what type of object we're -actually dealing with. - -=head2 METHODS - -=over 4 - -=item is_success() - -Returns true if the request was successful. This doesn't mean any objects -have been found, it just indicates a successful roundtrip. - -=item is_error() - -Returns true if an error occurred. Use C<message()> to determine what -kind of error. - -=item properties() - -Returns the list of C<Net::Amazon::Property> objects which were found -by the query. - -=item as_string() - -Dumps the content of the response. - -=item message() - -Returns the error message as a string in case an error occurred. In case -several errors occurred, they're stringed together. Look up C<messages()> -if you need them separated. - -=item messages() - -Returns all error messages for a response as a reference to an array -of string messages. - -=back - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Response/ASIN.pm b/lib/Net/Amazon/Response/ASIN.pm deleted file mode 100644 index 32bad76..0000000 --- a/lib/Net/Amazon/Response/ASIN.pm +++ /dev/null @@ -1,28 +0,0 @@ -###################################################################### -package Net::Amazon::Response::ASIN; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Response); - -use Net::Amazon::Property; - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - return $self->SUPER::list_as_string($self->properties); -} - -1; diff --git a/lib/Net/Amazon/Response/Artist.pm b/lib/Net/Amazon/Response/Artist.pm deleted file mode 100644 index 0ee653b..0000000 --- a/lib/Net/Amazon/Response/Artist.pm +++ /dev/null @@ -1,29 +0,0 @@ -###################################################################### -package Net::Amazon::Response::Artist; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Response); - -use Net::Amazon::Property; -use Data::Dumper; - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - return $self->SUPER::list_as_string($self->properties); -} - -1; diff --git a/lib/Net/Amazon/Response/Blended.pm b/lib/Net/Amazon/Response/Blended.pm deleted file mode 100644 index 3c75ded..0000000 --- a/lib/Net/Amazon/Response/Blended.pm +++ /dev/null @@ -1,73 +0,0 @@ -###################################################################### -package Net::Amazon::Response::Blended; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Response); - -use Net::Amazon::Property; -use XML::Simple; - -our @FORCE_ARRAY_FIELDS = qw(ProductLine); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - return $self->SUPER::list_as_string($self->properties); -} - -################################################## -sub xmlref_add { -################################################## - my($self, $xmlref) = @_; - - my $nof_items_added = 0; - - unless(ref($self->{xmlref}) eq "HASH" && - ref($self->{xmlref}->{Details}) eq "ARRAY") { - $self->{xmlref}->{Details} = []; - } - - if ($xmlref->{ProductLine} && (ref($xmlref->{ProductLine}) eq "ARRAY")) { - my @lines = @{$xmlref->{ProductLine}}; # Copy the lines - # sort the copies by relevance - @lines = sort { $a->{RelevanceRank} <=> $b->{RelevanceRank} } @lines; - - foreach (@lines) { - next unless $_->{ProductInfo}->{Details}; - my $details = $_->{ProductInfo}->{Details}; - if (ref($details) eq "ARRAY") { - push @{$self->{xmlref}->{Details}}, @$details; - $nof_items_added += scalar @$details; - } else { - push @{$self->{xmlref}->{Details}}, $details; - $nof_items_added++; - } - } - } - - return $nof_items_added; -} - -################################################## -sub xml_parse { -################################################## - my($self, $xml) = @_; - - my $xs = XML::Simple->new(); - return $xs->XMLin($xml, ForceArray => [ @FORCE_ARRAY_FIELDS ]); -} - -1; diff --git a/lib/Net/Amazon/Response/BrowseNode.pm b/lib/Net/Amazon/Response/BrowseNode.pm deleted file mode 100644 index 8f40a63..0000000 --- a/lib/Net/Amazon/Response/BrowseNode.pm +++ /dev/null @@ -1,29 +0,0 @@ -###################################################################### -package Net::Amazon::Response::BrowseNode; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Response); - -use Net::Amazon::Property; -use Data::Dumper; - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - return $self->SUPER::list_as_string($self->properties); -} - -1; diff --git a/lib/Net/Amazon/Response/Exchange.pm b/lib/Net/Amazon/Response/Exchange.pm deleted file mode 100644 index 56852fe..0000000 --- a/lib/Net/Amazon/Response/Exchange.pm +++ /dev/null @@ -1,81 +0,0 @@ -###################################################################### -package Net::Amazon::Response::Exchange; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Response); - -use Net::Amazon::Property; -use Net::Amazon::Result::Seller::Listing; -use Log::Log4perl qw(:easy); - -__PACKAGE__->make_array_accessor($_) for qw(listings); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -################################################## -sub result { -################################################## - my($self) = @_; - - if($self->is_success()) { - return Net::Amazon::Result::Seller::Listing->new( - xmlref => $self->{xmlref}->{ListingProductDetails}->[0], - ); - } - - return undef; -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - return "TODO: as_string not defined yet in ", __PACKAGE__; -} - -################################################## -sub xmlref_add { -################################################## - my($self, $xmlref) = @_; - - my $nof_items_added = 0; - - unless(ref($self->{xmlref}) eq "HASH" && - ref($self->{xmlref}->{ListingProductDetails}) eq "ARRAY") { - $self->{xmlref}->{Details} = []; - } - - if(ref($xmlref->{ListingProductDetails}) eq "ARRAY") { - # Is it an array of items? - push @{$self->{xmlref}->{ListingProductDetails}}, - @{$xmlref->{ListingProductDetails}}; - $nof_items_added = scalar @{$xmlref->{ListingProductDetails}}; - } else { - # It is a single item - push @{$self->{xmlref}->{ListingProductDetails}}, - $xmlref->{ListingProductDetails}; - $nof_items_added = 1; - } - - return $nof_items_added; -} - -################################################## -sub properties { -################################################## - my($self) = @_; - - die "properties() not defined in ", __PACKAGE__, ". Use result() instead"; -} - -1; diff --git a/lib/Net/Amazon/Response/Keyword.pm b/lib/Net/Amazon/Response/Keyword.pm deleted file mode 100644 index f6277d6..0000000 --- a/lib/Net/Amazon/Response/Keyword.pm +++ /dev/null @@ -1,29 +0,0 @@ -###################################################################### -package Net::Amazon::Response::Keyword; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Response); - -use Net::Amazon::Property; -use Data::Dumper; - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - return $self->SUPER::list_as_string($self->properties); -} - -1; diff --git a/lib/Net/Amazon/Response/Manufacturer.pm b/lib/Net/Amazon/Response/Manufacturer.pm deleted file mode 100644 index 97ceebf..0000000 --- a/lib/Net/Amazon/Response/Manufacturer.pm +++ /dev/null @@ -1,29 +0,0 @@ -######################################################################
-package Net::Amazon::Response::Manufacturer;
-######################################################################
-use warnings;
-use strict;
-use base qw(Net::Amazon::Response);
-
-use Net::Amazon::Property;
-use Data::Dumper;
-
-##################################################
-sub new {
-##################################################
- my($class, %options) = @_;
-
- my $self = $class->SUPER::new(%options);
-
- bless $self, $class; # reconsecrate
-}
-
-##################################################
-sub as_string {
-##################################################
- my($self) = @_;
-
- return $self->SUPER::list_as_string($self->properties);
-}
-
-1;
diff --git a/lib/Net/Amazon/Response/Power.pm b/lib/Net/Amazon/Response/Power.pm deleted file mode 100644 index 88cdd2d..0000000 --- a/lib/Net/Amazon/Response/Power.pm +++ /dev/null @@ -1,28 +0,0 @@ -###################################################################### -package Net::Amazon::Response::Power; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Response); - -use Net::Amazon::Property; - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - return $self->SUPER::list_as_string($self->properties); -} - -1; diff --git a/lib/Net/Amazon/Response/Seller.pm b/lib/Net/Amazon/Response/Seller.pm deleted file mode 100644 index f33ed50..0000000 --- a/lib/Net/Amazon/Response/Seller.pm +++ /dev/null @@ -1,78 +0,0 @@ -############################################# -package Net::Amazon::Response::Seller; -############################################# -use base qw(Net::Amazon::Response); - -use Net::Amazon::Result::Seller; -use Data::Dumper; -use Log::Log4perl qw(:easy); - -############################## -sub new { -############################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - bless $self, $class; # reconsecrate -} - -################################################## -sub result { -################################################## - my($self) = @_; - - if($self->is_success()) { - DEBUG "Calling Seller constructor with ", Dumper($self); - return Net::Amazon::Result::Seller->new( - xmlref => $self->{xmlref}->{SellerSearchDetails}->[0], - ); - } - - return undef; -} - -################################################## -sub properties { -################################################## - my($self) = @_; - - die "properties() not defined in ", __PACKAGE__, ". Use result() instead"; -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - return $self->result()->as_string(); -} - -################################################## -sub xmlref_add { -################################################## - my($self, $xmlref) = @_; - - my $nof_items_added = 0; - - unless(ref($self->{xmlref}) eq "HASH" && - ref($self->{xmlref}->{SellerSearchDetails}) eq "ARRAY") { - $self->{xmlref}->{Details} = []; - } - - if(ref($xmlref->{SellerSearchDetails}) eq "ARRAY") { - # Is it an array of items? - push @{$self->{xmlref}->{SellerSearchDetails}}, - @{$xmlref->{SellerSearchDetails}}; - $nof_items_added = scalar @{$xmlref->{SellerSearchDetails}}; - } else { - # It is a single item - push @{$self->{xmlref}->{SellerSearchDetails}}, - $xmlref->{SellerSearchDetails}; - $nof_items_added = 1; - } - - #DEBUG("xmlref_add (after):", Data::Dumper::Dumper($self)); - return $nof_items_added; -} - -1; diff --git a/lib/Net/Amazon/Response/Similar.pm b/lib/Net/Amazon/Response/Similar.pm deleted file mode 100644 index 27add88..0000000 --- a/lib/Net/Amazon/Response/Similar.pm +++ /dev/null @@ -1,28 +0,0 @@ -###################################################################### -package Net::Amazon::Response::Similar; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Response); - -use Net::Amazon::Property; - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - return $self->SUPER::list_as_string($self->properties); -} - -1; diff --git a/lib/Net/Amazon/Response/TextStream.pm b/lib/Net/Amazon/Response/TextStream.pm deleted file mode 100644 index 0cee872..0000000 --- a/lib/Net/Amazon/Response/TextStream.pm +++ /dev/null @@ -1,28 +0,0 @@ -######################################################################
-package Net::Amazon::Response::TextStream;
-######################################################################
-use warnings;
-use strict;
-use base qw(Net::Amazon::Response);
-
-use Net::Amazon::Property;
-
-##################################################
-sub new {
-##################################################
- my($class, %options) = @_;
-
- my $self = $class->SUPER::new(%options);
-
- bless $self, $class; # reconsecrate
-}
-
-##################################################
-sub as_string {
-##################################################
- my($self) = @_;
-
- return $self->SUPER::list_as_string($self->properties);
-}
-
-1;
diff --git a/lib/Net/Amazon/Response/UPC.pm b/lib/Net/Amazon/Response/UPC.pm deleted file mode 100644 index 4fba4ad..0000000 --- a/lib/Net/Amazon/Response/UPC.pm +++ /dev/null @@ -1,40 +0,0 @@ -###################################################################### -package Net::Amazon::Response::UPC; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Response); - -use Net::Amazon::Property; - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - my($property) = $self->properties; - return $property->as_string(); -} - -################################################## -sub properties { -################################################## - my($self) = @_; - - my $property = Net::Amazon::Property::factory( - xmlref => $self->{xmlref}->{Details}->[0]); - - return ($property); -} - -1; diff --git a/lib/Net/Amazon/Response/Wishlist.pm b/lib/Net/Amazon/Response/Wishlist.pm deleted file mode 100644 index 15fd999..0000000 --- a/lib/Net/Amazon/Response/Wishlist.pm +++ /dev/null @@ -1,29 +0,0 @@ -###################################################################### -package Net::Amazon::Response::Wishlist; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon::Response); - -use Net::Amazon::Property; -use Data::Dumper; - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - my $self = $class->SUPER::new(%options); - - bless $self, $class; # reconsecrate -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - return $self->SUPER::list_as_string($self->properties); -} - -1; diff --git a/lib/Net/Amazon/Result/Seller.pm b/lib/Net/Amazon/Result/Seller.pm deleted file mode 100644 index cb876a6..0000000 --- a/lib/Net/Amazon/Result/Seller.pm +++ /dev/null @@ -1,130 +0,0 @@ -###################################################################### -package Net::Amazon::Result::Seller; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon); - -use Data::Dumper; -use Log::Log4perl qw(:easy); -use Net::Amazon::Result::Seller::Listing; - -our @DEFAULT_ATTRIBUTES = qw(StoreName SellerNickname - NumberOfOpenListings StoreId); -__PACKAGE__->make_accessor($_) for @DEFAULT_ATTRIBUTES; -__PACKAGE__->make_array_accessor($_) for qw(listings); - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - if(!$options{xmlref}) { - die "Mandatory param xmlref missing"; - } - - my @listings = (); - - my $self = { - %options, - }; - - bless $self, $class; - - # Set default attributes - for my $attr (@DEFAULT_ATTRIBUTES) { - DEBUG "Setting attribute $attr to $options{xmlref}->{$attr}"; - $self->$attr($options{xmlref}->{$attr}); - } - - for my $listing (@{$options{xmlref}->{ListingProductInfo}->{ListingProductDetails}}) { - push @listings, - Net::Amazon::Result::Seller::Listing->new( - xmlref => $listing); - } - - $self->listings(\@listings); - - return $self; -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - my $result = $self->StoreName() . - " (" . - $self->SellerNickname() . - "): " . - $self->NumberOfOpenListings() . - ""; - - return $result; -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Result::Seller - Class for Seller info - -=head1 SYNOPSIS - - use Net::Amazon; - - # ... - - if($resp->is_success()) { - print $resp->result()->as_string(); - } - -=head1 DESCRIPTION - -C<Net::Amazon::Result::Seller> is a container for results on a seller -search. It contains data on one particular seller (the one turned up by -the previous search) and the listings this seller is currently running. - -=head2 METHODS - -=over 4 - -=item StoreName() - -Name of the seller's store. - -=item SellerNickname() - -Seller's nickname. - -=item StoreId() - -ID of seller's store. - -=item NumberOfOpenListings() - -Number of listings the seller has currently open. - -=item listings() - -Returns an array of C<Net::Amazon::Result::Seller::Listing> objects. -See the documentation of this class for details. - -=back - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2004 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Net/Amazon/Result/Seller/Listing.pm b/lib/Net/Amazon/Result/Seller/Listing.pm deleted file mode 100644 index c09ec08..0000000 --- a/lib/Net/Amazon/Result/Seller/Listing.pm +++ /dev/null @@ -1,146 +0,0 @@ -###################################################################### -package Net::Amazon::Result::Seller::Listing; -###################################################################### -use warnings; -use strict; -use base qw(Net::Amazon); - -use Data::Dumper; -use Log::Log4perl qw(:easy); - -our @DEFAULT_ATTRIBUTES = qw( - ExchangeStartDate ExchangeConditionType - ExchangeAsin ExchangeSellerId ExchangeEndDate ExchangePrice - ExchangeSellerRating ExchangeStatus ExchangeId ExchangeTitle - ExchangeQuantityAllocated ExchangeQuantity ExchangeSellerCountry - ExchangeSellerState ExchangeSellerNickname ExchangeFeaturedCategory - ExchangeAvailability ExchangeOfferingType ListingId ExchangeCondition - ExchangeDescription -); - -__PACKAGE__->make_accessor($_) for @DEFAULT_ATTRIBUTES; - -################################################## -sub new { -################################################## - my($class, %options) = @_; - - if(!$options{xmlref}) { - die "Mandatory param xmlref missing"; - } - - my $self = { - %options, - }; - - bless $self, $class; - - DEBUG "Calling Listing with xmlref=", Dumper($options{xmlref}); - - # Set default attributes - for my $attr (@DEFAULT_ATTRIBUTES) { - $self->$attr($options{xmlref}->{$attr}); - } - - return $self; -} - -################################################## -sub as_string { -################################################## - my($self) = @_; - - my $result = - $self->ExchangeTitle() . - " (" . - $self->ExchangeAsin() . - "): " . - $self->ExchangePrice() . - ""; - - return $result; -} - -1; - -__END__ - -=head1 NAME - -Net::Amazon::Result::Seller::Listing - Class for a single Listing of a Seller - -=head1 SYNOPSIS - - for($seller_search_resp->result()->seller()->listings()) { - print $_->as_string(), "\n"; - } - -=head1 DESCRIPTION - -C<Net::Amazon::Result::Seller::Listing> is a container for a single listing -owned by a third-party seller, who is represented by a -C<Net::Amazon::Result::Seller> object. - -An object of this class is also returned by an C<Exchange> request, using -C<Net::Amazon::Response::Exchange>'s C<result> method. - -=head2 METHODS - -=over 4 - -=item ExchangeStartDate() - -=item ExchangeConditionType() - -=item ExchangeAsin() - -=item ExchangeSellerId() - -=item ExchangeEndDate() - -=item ExchangePrice() - -=item ExchangeSellerRating() - -=item ExchangeStatus() - -=item ExchangeId() - -=item ExchangeTitle() - -=item ExchangeQuantityAllocated() - -=item ExchangeQuantity() - -=item ExchangeSellerCountry() - -=item ExchangeSellerState() - -=item ExchangeSellerNickname() - -=item ExchangeFeaturedCategory() - -=item ExchangeAvailability() - -=item ExchangeOfferingType() - -=item ListingId() - -=item ExchangeCondition() - -=back - -=head1 SEE ALSO - -=head1 AUTHOR - -Mike Schilli, E<lt>m@perlmeister.comE<gt> - -=head1 COPYRIGHT AND LICENSE - -Copyright 2004 by Mike Schilli E<lt>m@perlmeister.comE<gt> - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Template.pm b/lib/Template.pm deleted file mode 100644 index bd56cc5..0000000 --- a/lib/Template.pm +++ /dev/null @@ -1,961 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template -# -# DESCRIPTION -# Module implementing a simple, user-oriented front-end to the Template -# Toolkit. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2002 Andy Wardley. All Rights Reserved. -# Copyright (C) 1998-2002 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. -# -# REVISION -# $Id: Template.pm,v 2.76 2004/01/13 15:27:35 abw Exp $ -# -#======================================================================== - -package Template; -use base qw( Template::Base ); - -require 5.005; - -use strict; -use vars qw( $VERSION $AUTOLOAD $ERROR $DEBUG $BINMODE ); -use Template::Base; -use Template::Config; -use Template::Constants; -use Template::Provider; -use Template::Service; -use File::Basename; -use File::Path; - -## This is the main version number for the Template Toolkit. -## It is extracted by ExtUtils::MakeMaker and inserted in various places. -$VERSION = '2.13'; -$ERROR = ''; -$DEBUG = 0; - -# we used to default to binary mode for all win32 files but that make -# line endings strange, so we're turning it off and letting users set -# it explicitly as an argument to process() -# $BINMODE = ($^O eq 'MSWin32') ? 1 : 0; -$BINMODE = 0 unless defined $BINMODE; - -# 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) && UNIVERSAL::isa($opts[0], '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 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 the CONTEXT object withint the SERVICE -# object. -#------------------------------------------------------------------------ - -sub context { - my $self = shift; - return $self->{ SERVICE }->{ CONTEXT }; -} - - -#======================================================================== -# -- 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 (UNIVERSAL::can($where, '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 FP if $options->{ binmode }; - 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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 new() constructor method (implemented by the Template::Base base -class) instantiates a new 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 Template object is returned, or undef on error. -In the latter case, the error message can be retrieved by calling -error() as a class method (e.g. C<Template-E<gt>error()>) or by -examining the $ERROR package variable directly -(e.g. C<$Template::ERROR>). - - 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 process() method is called to process a template. The first -parameter indicates the input template as one of: a filename relative -to INCLUDE_PATH, if defined; a reference to a text string containing -the template text; or a file handle reference (e.g. IO::Handle or -sub-class) or GLOB (e.g. \*STDIN), from which the template can be -read. A reference to a hash array may be passed as the second -parameter, containing definitions of template variables. - - $text = "[% INCLUDE header %]\nHello world!\n[% INCLUDE footer %]"; - - # filename - $tt->process('welcome.tt2') - || die $tt->error(), "\n"; - - # text reference - $tt->process(\$text) - || die $tt->error(), "\n"; - - # 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 STDOUT. The -process() method then returns 1 to indicate success. A third -parameter may be passed to the process() method to specify a different -output location. This value may be one of: a plain string indicating -a filename which will be opened (relative to OUTPUT_PATH, if defined) -and the output written to; a file GLOB opened ready for output; a -reference to a scalar (e.g. a text string) to which output/error is -appended; a reference to a subroutine which is called, passing the -output as a parameter; or any object reference which implements a -'print' method (e.g. IO::Handle, Apache::Request, etc.) which will -be called, passing the generated output as a parameter. - -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; - - ... - - # 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 (name, value) pairs providing further -options for the output. The only option currently supported is -"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"; - -The OUTPUT configuration item can be used to specify a default output -location other than \*STDOUT. The 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 process() method returns 1 on success or undef on error. The error -message generated in the latter case can be retrieved by calling the -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 $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 -_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 -Template::Exception class. If the process() method returns a false -value then the error() method can be called to return an object of -this class. The type() and info() methods can called on the object to -retrieve the error type and information string, respectively. The -as_string() method can be called to return a string of the form "$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 Template module delegates most of the effort of processing templates -to an underlying Template::Service object. This method returns a reference -to that object. - -=head2 context() - -The Template::Service module uses a core Template::Context object for -runtime processing of templates. This method returns a reference to -that object and is equivalent to $template-E<gt>service-E<gt>context(); - -=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 - -=over 4 - -=item START_TAG, END_TAG - -Define tokens that indicate start and end of directives (default: '[%' and -'%]'). - -=item TAG_STYLE - -Set START_TAG and END_TAG according to a pre-defined style (default: -'template', as above). - -=item PRE_CHOMP, POST_CHOMP - -Remove whitespace before/after directives (default: 0/0). - -=item TRIM - -Remove leading and trailing whitespace from template output (default: 0). - -=item INTERPOLATE - -Interpolate variables embedded like $this or ${this} (default: 0). - -=item ANYCASE - -Allow directive keywords in lower case (default: 0 - UPPER only). - -=back - -=head2 Template Files and Blocks - -=over 4 - -=item INCLUDE_PATH - -One or more directories to search for templates. - -=item DELIMITER - -Delimiter for separating paths in INCLUDE_PATH (default: ':'). - -=item ABSOLUTE - -Allow absolute file names, e.g. /foo/bar.html (default: 0). - -=item RELATIVE - -Allow relative filenames, e.g. ../foo/bar.html (default: 0). - -=item DEFAULT - -Default template to use when another not found. - -=item BLOCKS - -Hash array pre-defining template blocks. - -=item AUTO_RESET - -Enabled by default causing BLOCK definitions to be reset each time a -template is processed. Disable to allow BLOCK definitions to persist. - -=item RECURSION - -Flag to permit recursion into templates (default: 0). - -=back - -=head2 Template Variables - -=over 4 - -=item VARIABLES, PRE_DEFINE - -Hash array of variables and values to pre-define in the stash. - -=back - -=head2 Runtime Processing Options - -=over 4 - -=item EVAL_PERL - -Flag to indicate if PERL/RAWPERL blocks should be processed (default: 0). - -=item PRE_PROCESS, POST_PROCESS - -Name of template(s) to process before/after main template. - -=item PROCESS - -Name of template(s) to process instead of main template. - -=item ERROR - -Name of error template or reference to hash array mapping error types to -templates. - -=item OUTPUT - -Default output location or handler. - -=item OUTPUT_PATH - -Directory into which output files can be written. - -=item DEBUG - -Enable debugging messages. - -=back - -=head2 Caching and Compiling Options - -=over 4 - -=item CACHE_SIZE - -Maximum number of compiled templates to cache in memory (default: -undef - cache all) - -=item COMPILE_EXT - -Filename extension for compiled template files (default: undef - don't -compile). - -=item COMPILE_DIR - -Root of directory in which compiled template files should be written -(default: undef - don't compile). - -=back - -=head2 Plugins and Filters - -=over 4 - -=item PLUGINS - -Reference to a hash array mapping plugin names to Perl packages. - -=item PLUGIN_BASE - -One or more base classes under which plugins may be found. - -=item LOAD_PERL - -Flag to indicate regular Perl modules should be loaded if a named plugin -can't be found (default: 0). - -=item FILTERS - -Hash array mapping filter names to filter subroutines or factories. - -=back - -=head2 Compatibility, Customisation and Extension - -=over 4 - -=item V1DOLLAR - -Backwards compatibility flag enabling version 1.* handling (i.e. ignore it) -of leading '$' on variables (default: 0 - '$' indicates interpolation). - -=item LOAD_TEMPLATES - -List of template providers. - -=item LOAD_PLUGINS - -List of plugin providers. - -=item LOAD_FILTERS - -List of filter providers. - -=item TOLERANT - -Set providers to tolerate errors as declinations (default: 0). - -=item SERVICE - -Reference to a custom service object (default: Template::Service). - -=item CONTEXT - -Reference to a custom context object (default: Template::Context). - -=item STASH - -Reference to a custom stash object (default: Template::Stash). - -=item PARSER - -Reference to a custom parser object (default: Template::Parser). - -=item GRAMMAR - -Reference to a custom grammar object (default: Template::Grammar). - -=back - -=head1 DIRECTIVE SUMMARY - -The following list gives a short summary of each Template Toolkit directive. -See L<Template::Manual::Directives> for full details. - -=over 4 - -=item 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" %] - -=item CALL - -As per GET but without printing result (e.g. call code) - - [% CALL variable %] - -=item 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, ... } - %] - -=item DEFAULT - -Like SET above, but variables are only set if currently unset (i.e. have no -true value). - - [% DEFAULT variable = value %] - -=item INSERT - -Insert a file without any processing performed on the contents. - - [% INSERT legalese.txt %] - -=item INCLUDE - -Process another template file or block and include the output. Variables -are localised. - - [% INCLUDE template %] - [% INCLUDE template var = val, ... %] - -=item PROCESS - -As INCLUDE above, but without localising variables. - - [% PROCESS template %] - [% PROCESS template var = val, ... %] - -=item WRAPPER - -Process the enclosed block WRAPPER ... END block then INCLUDE the -named template, passing the block output in the 'content' variable. - - [% WRAPPER template %] - content... - [% END %] - -=item BLOCK - -Define a named template block for subsequent INCLUDE, PROCESS, etc., - - [% BLOCK template %] - content - [% END %] - -=item FOREACH - -Repeat the enclosed FOREACH ... END block for each value in the list. - - [% FOREACH variable = [ val, val, val ] %] # either - [% FOREACH variable = list %] # or - [% FOREACH list %] # or - content... - [% variable %] - [% END %] - -=item WHILE - -Enclosed WHILE ... END block is processed while condition is true. - - [% WHILE condition %] - content - [% END %] - -=item IF / UNLESS / ELSIF / ELSE - -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 %] - -=item SWITCH / CASE - -Multi-way switch/case statement. - - [% SWITCH variable %] - [% CASE val1 %] - content - [% CASE [ val2, val3 ] %] - content - [% CASE %] # or [% CASE DEFAULT %] - content - [% END %] - -=item MACRO - -Define a named macro. - - [% MACRO name <directive> %] - [% MACRO name(arg1, arg2) <directive> %] - ... - [% name %] - [% name(val1, val2) %] - -=item FILTER - -Process enclosed FILTER ... END block then pipe through a filter. - - [% FILTER name %] # either - [% FILTER name( params ) %] # or - [% FILTER alias = name( params ) %] # or - content - [% END %] - -=item USE - -Load a "plugin" module, or any regular Perl module if LOAD_PERL option is -set. - - [% USE name %] # either - [% USE name( params ) %] # or - [% USE var = name( params ) %] # or - ... - [% name.method %] - [% var.method %] - -=item PERL / RAWPERL - -Evaluate enclosed blocks as Perl code (requires 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 %] - -=item 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 %] - -=item NEXT - -Jump straight to the next item in a FOREACH/WHILE loop. - - [% NEXT %] - -=item LAST - -Break out of FOREACH/WHILE loop. - - [% LAST %] - -=item RETURN - -Stop processing current template and return to including templates. - - [% RETURN %] - -=item STOP - -Stop processing all templates and return to caller. - - [% STOP %] - -=item TAGS - -Define new tag style or characters (default: [% %]). - - [% TAGS html %] - [% TAGS <!-- --> %] - -=item 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 - %] - -=back - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Base.pm b/lib/Template/Base.pm deleted file mode 100644 index 5f19d78..0000000 --- a/lib/Template/Base.pm +++ /dev/null @@ -1,314 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Base -# -# DESCRIPTION -# Base class module implementing common functionality for various other -# Template Toolkit modules. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#------------------------------------------------------------------------ -# -# $Id: Base.pm,v 2.69 2004/01/13 16:19:09 abw Exp $ -# -#======================================================================== - -package Template::Base; - -require 5.004; - -use strict; -use vars qw( $VERSION ); -use Template::Constants; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.69 $ =~ /(\d+)\.(\d+)/); - - -#------------------------------------------------------------------------ -# 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 qw( refs ); - $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 -# local $" = ', '; -# print STDERR "args: [@_]\n"; - $cfg = defined $_[0] && UNIVERSAL::isa($_[0], '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 -# abscence 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; - print STDERR "DEBUG: ", @_; -} - -sub debug { - my $self = shift; - my $msg = join('', @_); - my ($pkg, $file, $line) = caller(); - - unless ($msg =~ /\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"}; -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 -_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 error() class method or directly via the package variable ERROR -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 _ERROR member -or as a class method to get/set the $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 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 foobar() method is called, the following message -is sent to STDERR: - - [My::Module] called foobar() - -Objects can set an internal DEBUG value which the debug() -method will examine. If this value sets the relevant bits -to indicate DEBUG_CALLER then the file and line number of -the caller will be appened 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 - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.69, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Config.pm b/lib/Template/Config.pm deleted file mode 100644 index 9a3f378..0000000 --- a/lib/Template/Config.pm +++ /dev/null @@ -1,467 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Config -# -# DESCRIPTION -# Template Toolkit configuration module. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#------------------------------------------------------------------------ -# -# $Id: Config.pm,v 2.67 2004/01/13 16:19:10 abw Exp $ -# -#======================================================================== - -package Template::Config; - -require 5.004; - -use strict; -use base qw( Template::Base ); -use vars qw( $VERSION $DEBUG $ERROR $INSTDIR - $PARSER $PROVIDER $PLUGINS $FILTERS $ITERATOR - $LATEX_PATH $PDFLATEX_PATH $DVIPS_PATH - $STASH $SERVICE $CONTEXT $CONSTANTS @PRELOAD ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.67 $ =~ /(\d+)\.(\d+)/); -$DEBUG = 0 unless defined $DEBUG; -$ERROR = ''; -$CONTEXT = 'Template::Context'; -$FILTERS = 'Template::Filters'; -$ITERATOR = 'Template::Iterator'; -$PARSER = 'Template::Parser'; -$PLUGINS = 'Template::Plugins'; -$PROVIDER = 'Template::Provider'; -$SERVICE = 'Template::Service'; -$STASH = 'Template::Stash'; -$CONSTANTS = 'Template::Namespace::Constants'; - -@PRELOAD = ( $CONTEXT, $FILTERS, $ITERATOR, $PARSER, - $PLUGINS, $PROVIDER, $SERVICE, $STASH ); - -# the following is set at installation time by the Makefile.PL -$INSTDIR = ''; - -# LaTeX executable paths set at installation time by the Makefile.PL -# Empty strings cause the latex(pdf|dvi|ps) filters to throw an error. -$LATEX_PATH = ''; -$PDFLATEX_PATH = ''; -$DVIPS_PATH = ''; - -#======================================================================== -# --- 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 occurences 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'; -# print STDERR "loading $module\n" -# if $DEBUG; - 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]) && UNIVERSAL::isa($_[0], '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]) && UNIVERSAL::isa($_[0], '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]) && UNIVERSAL::isa($_[0], '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]) && UNIVERSAL::isa($_[0], '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]) && UNIVERSAL::isa($_[0], '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]) && UNIVERSAL::isa($_[0], '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]) && UNIVERSAL::isa($_[0], '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]) && UNIVERSAL::isa($_[0], '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"); - $inst =~ s[/$][]g; - $inst .= "/$dir" if $dir; - return $inst; -} - -#------------------------------------------------------------------------ -# latexpaths() -# -# Returns a reference to a three element array: -# [latex_path, pdf2latex_path, dvips_path] -# These values are determined by Makefile.PL at installation time -# and are used by the latex(pdf|dvi|ps) filters. -#------------------------------------------------------------------------ - -sub latexpaths { - return [$LATEX_PATH, $PDFLATEX_PATH, $DVIPS_PATH]; -} - -#======================================================================== -# 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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 $STASH, $SERVICE, $CONTEXT, etc., contain -the default module/package name for each component (Template::Stash, -Template::Service and Template::Context, respectively) and are used by -the various factory methods (stash(), service() and 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 via require(). Any occurences of '::' in the module name -are be converted to '/' and '.pm' is appended. Returns 1 on success -or undef on error. Use $class-E<gt>error() to examine the error string. - -=head2 preload() - -This method preloads all the other Template::* modules that are likely -to be used. It is called by the Template module when running under -mod_perl ($ENV{MOD_PERL} is set). - -=head2 parser(\%config) - -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. - -=head2 provider(\%config) - -Instantiate a new template provider object (default: Template::Provider). -Returns an object reference or undef on error, as above. - -=head2 plugins(\%config) - -Instantiate a new plugins provider object (default: Template::Plugins). -Returns an object reference or undef on error, as above. - -=head2 filters(\%config) - -Instantiate a new filter provider object (default: Template::Filters). -Returns an object reference or undef on error, as above. - -=head2 stash(\%vars) - -Instantiate a new stash object (Template::Stash or 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: Template::Context). -Returns an object reference or undef on error, as above. - -=head2 service(\%config) - -Instantiate a new template service object (default: Template::Service). -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 undef and sets $Template::Config::ERROR appropriately if the -optional components of the Template Toolkit have not been installed. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.67, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Constants.pm b/lib/Template/Constants.pm deleted file mode 100644 index b227467..0000000 --- a/lib/Template/Constants.pm +++ /dev/null @@ -1,287 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Constants.pm -# -# DESCRIPTION -# Definition of constants for the Template Toolkit. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Constants.pm,v 2.67 2004/01/13 16:19:10 abw Exp $ -# -#============================================================================ - -package Template::Constants; - -require 5.004; -require Exporter; - -use strict; -use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS ); -use vars qw( $DEBUG_OPTIONS @STATUS @ERROR @CHOMP @DEBUG); - -@ISA = qw( Exporter ); -$VERSION = sprintf("%d.%02d", q$Revision: 2.67 $ =~ /(\d+)\.(\d+)/); - - -#======================================================================== -# ----- 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, stoppped 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 -use constant CHOMP_COLLAPSE => 2; # collapse whitespace to a single space - -# 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 extraxt 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_COLLAPSE ); -@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 =~ /^\d+$/) { - foreach $flag (@DEBUG) { - next if $flag =~ /^DEBUG_(OFF|ALL|FLAGS)$/; - - # don't trash the original - my $copy = $flag; - $flag =~ s/^DEBUG_//; - $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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Constants - Defines constants for the Template Toolkit - -=head1 SYNOPSIS - - use Template::Constants qw( :status :error :all ); - -=head1 DESCRIPTION - -The Template::Constants modules defines, and optionally exports into the -caller's namespace, a number of constants used by the Template package. - -Constants may be used by specifying the 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; :status, :error, :all. - - use Template::Constants qw( :status ); - - print STATUS_DECLINED; - -See L<Exporter> 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_ALL # remove whitespace - CHOMP_COLLAPSE # collapse whitespace to a single space - - :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@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.67, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template>, L<Exporter|Exporter> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Context.pm b/lib/Template/Context.pm deleted file mode 100644 index cdc699e..0000000 --- a/lib/Template/Context.pm +++ /dev/null @@ -1,1570 +0,0 @@ -#============================================================= -*-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@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -# REVISION -# $Id: Context.pm,v 2.89 2004/01/30 18:37:47 abw Exp $ -# -#============================================================================ - -package Template::Context; - -require 5.004; - -use strict; -use vars qw( $VERSION $DEBUG $AUTOLOAD $DEBUG_FORMAT ); -use base qw( Template::Base ); - -use Template::Base; -use Template::Config; -use Template::Constants; -use Template::Exception; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.89 $ =~ /(\d+)\.(\d+)/); -$DEBUG_FORMAT = "\n## \$file line \$line : [% \$text %] ##\n"; - - -#======================================================================== -# ----- 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 objects, or - # CODE references are assumed to be pre-compiled templates and are - # returned intact - return $name - if UNIVERSAL::isa($name, 'Template::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 ($^O eq '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 (UNIVERSAL::isa($template, 'Template::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 Template::View->new($self, @_) - || $self->throw(&Template::Constants::ERROR_VIEW, - $Template::View::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 (UNIVERSAL::isa($component, 'Template::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 UNIVERSAL::isa($compiled, 'Template::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; - } - $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 ($^O eq '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 (UNIVERSAL::isa($error, 'Template::Exception')) { - die $error; - } - elsif (defined $info) { - die (Template::Exception->new($error, $info, $output)); - } - else { - $error ||= ''; - die (Template::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 errror -# 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 (UNIVERSAL::isa($error, 'Template::Exception')) { - $error->text($output) if $output; - return $error; - } - else { - return Template::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 persistance 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 -# succesful or undef on failure. Call error() to retrieve the -# relevent 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"); -} - - -#------------------------------------------------------------------------ -# 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 }; -} - - -#------------------------------------------------------------------------ -# 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(@_); -} - - -#------------------------------------------------------------------------ -# 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 = @_; - -# print "*** debug(@args)\n"; - if (@args) { - if ($args[0] =~ /^on|1$/i) { - $self->{ DEBUG_DIRS } = 1; - shift(@args); - } - elsif ($args[0] =~ /^off|0$/i) { - $self->{ DEBUG_DIRS } = 0; - shift(@args); - } - } - - if (@args) { - if ($args[0] =~ /^msg$/i) { - 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 ($args[0] =~ /^format$/i) { - $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'; -# print(STDERR "prefix $key => $val => [", -# join(', ', @{ $prefix_map->{ $key } }), "]\n"); - } - - # 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 }; - - 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 - }; - - # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # 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; -} - - -#------------------------------------------------------------------------ -# _dump() -# -# Debug method which returns a string representing the internal state -# of the context object. -#------------------------------------------------------------------------ - -sub _dump { - my $self = shift; - my $output = "[Template::Context] {\n"; - my $format = " %-16s => %s\n"; - my $key; - - foreach $key (qw( RECURSION EVAL_PERL TRIM )) { - $output .= sprintf($format, $key, $self->{ $key }); - } - foreach my $pname (qw( LOAD_TEMPLATES LOAD_PLUGINS LOAD_FILTERS )) { - my $provtext = "[\n"; - foreach my $prov (@{ $self->{ $pname } }) { - $provtext .= $prov->_dump(); -# $provtext .= ",\n"; - } - $provtext =~ s/\n/\n /g; - $provtext =~ s/\s+$//; - $provtext .= ",\n ]"; - $output .= sprintf($format, $pname, $provtext); - } - $output .= sprintf($format, STASH => $self->{ STASH }->_dump()); - $output .= '}'; - return $output; -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 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 Template::Context object is created by the Template module. -Any Template::Context options may be passed to the Template new() -constructor method and will be forwarded to the 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 Template::Context constructor will forward all configuration -parameters onto other default objects (e.g. Template::Provider, Template::Plugins, -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 Template::Context object (or subclass/derivative) can be explicitly -instantiated and passed to the Template new() constructor method as -the CONTEXT item. - - use Template; - use Template::Context; - - my $context = Template::Context->new({ TRIM => 1 }); - my $template = Template->new({ CONTEXT => $context }); - -The Template module uses the Template::Config context() factory method -to create a default context object when required. The -$Template::Config::CONTEXT package variable may be set to specify an -alternate context module. This will be loaded automatically and its -new() constructor method called by the 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 new() constructor method is called to instantiate a Template::Context -object. Configuration parameters may be specified as a HASH reference or -as a list of (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 new() method returns a Template::Context object (or sub-class) or -undef on error. In the latter case, a relevant error message can be -retrieved by the error() class method or directly from the -$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. - -=over 4 - - -=item VARIABLES, PRE_DEFINE - -The VARIABLES option (or 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 STASH item is defined. - - my $context = Template::Context->new({ - VARIABLES => { - title => 'A Demo Page', - author => 'Joe Random Hacker', - version => 3.14, - }, - }; - -or - - my $context = Template::Context->new({ - PRE_DEFINE => { - title => 'A Demo Page', - author => 'Joe Random Hacker', - version => 3.14, - }, - }; - - - - - -=item BLOCKS - -The 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 Template::Document -objects. - - my $context = Template::Context->new({ - BLOCKS => { - header => 'The Header. [% title %]', - footer => sub { return $some_output_text }, - another => Template::Document->new({ ... }), - }, - }); - - - - - -=item TRIM - -The TRIM option can be set to have any leading and trailing whitespace -automatically removed from the output of all template files and BLOCKs. - -By example, the following BLOCK definition - - [% BLOCK foo %] - Line 1 of foo - [% END %] - -will be processed is as "\nLine 1 of foo\n". When INCLUDEd, the surrounding -newlines will also be introduced. - - before - [% INCLUDE foo %] - after - -output: - before - - Line 1 of foo - - after - -With the TRIM option set to any true value, the leading and trailing -newlines (which count as whitespace) will be removed from the output -of the BLOCK. - - before - Line 1 of foo - after - -The TRIM option is disabled (0) by default. - - - - - - -=item EVAL_PERL - -This flag is used to indicate if PERL and/or RAWPERL blocks should be -evaluated. By default, it is disabled and any PERL or RAWPERL blocks -encountered will raise exceptions of type 'perl' with the message -'EVAL_PERL not set'. Note however that any RAWPERL blocks should -always contain valid Perl code, regardless of the EVAL_PERL flag. The -parser will fail to compile templates that contain invalid Perl code -in RAWPERL blocks and will throw a 'file' exception. - -When using compiled templates (see -L<COMPILE_EXT|Template::Manual::Config/Caching_and_Compiling_Options> and -L<COMPILE_DIR|Template::Manual::Config/Caching_and_Compiling_Options>), -the 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 EVAL_PERL is set when a template is compiled, then all PERL and -RAWPERL blocks will be included in the compiled template. If the -EVAL_PERL option isn't set, then Perl code will be generated which -B<always> throws a 'perl' exception with the message 'EVAL_PERL not -set' B<whenever> the compiled template code is run. - -Thus, you must have EVAL_PERL set if you want your compiled templates -to include PERL and 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 EVAL_PERL option was set at the time the -template was compiled, then the output of any 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 -EVAL_PERL status. - -Regular PERL blocks are a little more cautious, however. If the -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 'perl' -exception with the message, 'EVAL_PERL not set'. - -Thus you can compile templates to include PERL blocks, but optionally -disable them when you process them later. Note however that it is -possible for a PERL block to contain a Perl "BEGIN { # some code }" -block which will always get run regardless of the runtime EVAL_PERL -status. Thus, if you set 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 EVAL_PERL disabled. - - - - - - - -=item 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. - - - -=item LOAD_TEMPLATES - -The LOAD_TEMPLATE option can be used to provide a reference to a list -of 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({ ... }), - ], - }); - -When a PROCESS, INCLUDE or WRAPPER directive is encountered, the named -template may refer to a locally defined BLOCK or a file relative to -the INCLUDE_PATH (or an absolute or relative path if the appropriate -ABSOLUTE or RELATIVE options are set). If a BLOCK definition can't be -found (see the Template::Context template() method for a discussion of -BLOCK locality) then each of the LOAD_TEMPLATES provider objects is -queried in turn via the 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 -INSERT directive but it bypasses any BLOCK definitions and doesn't -attempt is to parse or process the contents of the template file. - -This is an implementation of the 'Chain of Responsibility' -design pattern as described in -"Design Patterns", Erich Gamma, Richard Helm, Ralph Johnson, John -Vlissides), Addision-Wesley, ISBN 0-201-63361-2, page 223 -. - -If LOAD_TEMPLATES is undefined, a single default provider will be -instantiated using the current configuration parameters. For example, -the Template::Provider INCLUDE_PATH option can be specified in the Template::Context configuration and will be correctly passed to the provider's -constructor method. - - my $context = Template::Context->new({ - INCLUDE_PATH => '/here:/there', - }); - - - - - -=item LOAD_PLUGINS - -The LOAD_PLUGINS options can be used to specify a list of provider -objects (i.e. they implement the fetch() method) which are responsible -for loading and instantiating template plugin objects. The -Template::Content plugin() method queries each provider in turn in a -"Chain of Responsibility" as per the template() and filter() methods. - - my $context = Template::Context->new({ - LOAD_PLUGINS => [ - MyOrg::Template::Plugins->new({ ... }), - Template::Plugins->new({ ... }), - ], - }); - -By default, a single Template::Plugins object is created using the -current configuration hash. Configuration items destined for the -Template::Plugins constructor may be added to the Template::Context -constructor. - - my $context = Template::Context->new({ - PLUGIN_BASE => 'MyOrg::Template::Plugins', - LOAD_PERL => 1, - }); - - - - - -=item LOAD_FILTERS - -The LOAD_FILTERS option can be used to specify a list of provider -objects (i.e. they implement the fetch() method) which are responsible -for returning and/or creating filter subroutines. The -Template::Context filter() method queries each provider in turn in a -"Chain of Responsibility" as per the template() and plugin() methods. - - my $context = Template::Context->new({ - LOAD_FILTERS => [ - MyTemplate::Filters->new(), - Template::Filters->new(), - ], - }); - -By default, a single Template::Filters object is created for the -LOAD_FILTERS list. - - - -=item STASH - -A reference to a 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, - }); - -If unspecified, a default stash object is created using the VARIABLES -configuration item to initialise the stash variables. These may also -be specified as the PRE_DEFINE option for backwards compatibility with -version 1. - - my $context = Template::Context->new({ - VARIABLES => { - id => 'abw', - name => 'Andy Wardley', - }, - }; - - - -=item DEBUG - -The DEBUG option can be used to enable various debugging features -of the Template::Context module. - - use Template::Constants qw( :debug ); - - my $template = Template->new({ - DEBUG => DEBUG_CONTEXT | DEBUG_DIRS, - }); - -The DEBUG value can include any of the following. Multiple values -should be combined using the logical OR operator, '|'. - -=over 4 - -=item DEBUG_CONTEXT - -Enables general debugging messages for the -L<Template::Context|Template::Context> module. - -=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 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 - - -=back - - - - - -=back - -=head2 template($name) - -Returns a compiled template by querying each of the LOAD_TEMPLATES providers -(instances of Template::Provider, or sub-class) in turn. - - $template = $context->template('header'); - -On error, a Template::Exception object of type 'file' is thrown via -die(). This can be caught by enclosing the call to template() in an -eval block and examining $@. - - 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 LOAD_PLUGINS -providers. The default LOAD_PLUGINS provider is a Template::Plugins -object which attempts to load plugin modules, according the various -configuration items such as PLUGIN_BASE, LOAD_PERL, etc., and then -instantiate an object via 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 Template::Exception objects -of type 'plugin'. - - $plugin = $context->plugin('DBI', 'dbi:msql:mydbname'); - -=head2 filter($name, \@args, $alias) - -Instantiates a filter subroutine by querying the LOAD_FILTERS providers. -The default LOAD_FILTERS providers is a 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 $name if $alias is undefined. -Subsequent calls to 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 Template::Exception -objects of typre '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 Template::Exception objects via die(). - - $output = $context->process('header', { title => 'Hello World' }); - -=head2 include($template, \%vars) - -Similar to process() above, but using localised variables. Changes made to -any variables will only persist until the include() method completes. - - $output = $context->include('header', { title => 'Hello World' }); - -=head2 throw($error_type, $error_message, \$output) - -Raises an exception in the form of 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"); - -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 -Template::Exception object or some other value. In the latter case, -the error string is promoted to a Template::Exception object of -'undef' type. This method also accepts a reference to the current -output buffer which is passed to the Template::Exception constructor, -or is appended to the output buffer stored in an existing -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 BLOCKS cache. The first -argument should contain the name of the block and the second a reference -to a 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 Template::Document reference) on -success or undef on failure. The relevant error message can be -retrieved by calling the error() method. - -=head2 define_filter($name, \&filter, $is_dynamic) - -Adds a new filter definition by calling the store() method on each of -the LOAD_FILTERS providers until accepted (in the usual case, this is -accepted straight away by the one and only 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 'filter' exception on error. - -=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 Template::Document objects immediately before -they process their content. It is called to register any local BLOCK -definitions with the context object so that they may be subsequently -delivered on request. - -=head2 leave() - -Compliment to visit(), above. Called by Template::Document objects -immediately after they process their content. - -=head2 reset() - -Clears the local BLOCKS cache of any BLOCK definitions. Any initial set of -BLOCKS specified as a configuration item to the constructor will be reinstated. - -=head2 AUTOLOAD - -An 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@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.89, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template>, L<Template::Document|Template::Document>, L<Template::Exception|Template::Exception>, L<Template::Filters|Template::Filters>, L<Template::Plugins|Template::Plugins>, L<Template::Provider|Template::Provider>, L<Template::Service|Template::Service>, L<Template::Stash|Template::Stash> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Directive.pm b/lib/Template/Directive.pm deleted file mode 100644 index c3f86a9..0000000 --- a/lib/Template/Directive.pm +++ /dev/null @@ -1,1004 +0,0 @@ -#================================================================= -*-Perl-*- -# -# Template::Directive -# -# DESCRIPTION -# Factory module for constructing templates from Perl code. -# -# AUTHOR -# Andy Wardley <abw@kfs.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, particulary 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-2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Directive.pm,v 2.18 2003/10/08 09:34:41 abw Exp $ -# -#============================================================================ - -package Template::Directive; - -require 5.004; - -use strict; -use Template::Base; -use Template::Constants; -use Template::Exception; - -use base qw( Template::Base ); -use vars qw( $VERSION $DEBUG $PRETTY $WHILE_MAX $OUTPUT ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.18 $ =~ /(\d+)\.(\d+)/); - -$WHILE_MAX = 1000 unless defined $WHILE_MAX; -$PRETTY = 0 unless defined $PRETTY; -$OUTPUT = '$output .= '; - - -sub _init { - my ($self, $config) = @_; - $self->{ NAMESPACE } = $config->{ NAMESPACE }; - return $self; -} - - -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 ($class, $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 \$error; - - eval { BLOCK: { -$block - } }; - if (\$@) { - \$error = \$context->catch(\$@, \\\$output); - die \$error unless \$error->type eq 'return'; - } - - return \$output; -} -EOF -} - - -#------------------------------------------------------------------------ -# anon_block($block) [% BLOCK %] ... [% END %] -#------------------------------------------------------------------------ - -sub anon_block { - my ($class, $block) = @_; - $block = pad($block, 2) if $PRETTY; - - return <<EOF; - -# BLOCK -$OUTPUT do { - my \$output = ''; - my \$error; - - eval { BLOCK: { -$block - } }; - if (\$@) { - \$error = \$context->catch(\$@, \\\$output); - die \$error unless \$error->type eq 'return'; - } - - \$output; -}; -EOF -} - - -#------------------------------------------------------------------------ -# block($blocktext) -#------------------------------------------------------------------------ - -sub block { - my ($class, $block) = @_; - return join("\n", @{ $block || [] }); -} - - -#------------------------------------------------------------------------ -# textblock($text) -#------------------------------------------------------------------------ - -sub textblock { - my ($class, $text) = @_; - return "$OUTPUT " . &text($class, $text) . ';'; -} - - -#------------------------------------------------------------------------ -# text($text) -#------------------------------------------------------------------------ - -sub text { - my ($class, $text) = @_; - for ($text) { - s/(["\$\@\\])/\\$1/g; - s/\n/\\n/g; - } - return '"' . $text . '"'; -} - - -#------------------------------------------------------------------------ -# quoted(\@items) "foo$bar" -#------------------------------------------------------------------------ - -sub quoted { - my ($class, $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 ($class, $ident) = @_; - return "''" unless @$ident; - my $ns; - - # does the first element of the identifier have a NAMESPACE - # handler defined? - if (ref $class && @$ident > 2 && ($ns = $class->{ NAMESPACE })) { - my $key = $ident->[0]; - $key =~ s/^'(.+)'$/$1/s; - 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 ($class, $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 ($class, $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 ($class, $args) = @_; - my $hash = shift @$args; - push(@$args, '{ ' . join(', ', @$hash) . ' }') - if @$hash; - - return '0' unless @$args; - return '[ ' . join(', ', @$args) . ' ]'; -} - -#------------------------------------------------------------------------ -# filenames(\@names) -#------------------------------------------------------------------------ - -sub filenames { - my ($class, $names) = @_; - if (@$names > 1) { - $names = '[ ' . join(', ', @$names) . ' ]'; - } - else { - $names = shift @$names; - } - return $names; -} - - -#------------------------------------------------------------------------ -# get($expr) [% foo %] -#------------------------------------------------------------------------ - -sub get { - my ($class, $expr) = @_; - return "$OUTPUT $expr;"; -} - - -#------------------------------------------------------------------------ -# call($expr) [% CALL bar %] -#------------------------------------------------------------------------ - -sub call { - my ($class, $expr) = @_; - $expr .= ';'; - return $expr; -} - - -#------------------------------------------------------------------------ -# set(\@setlist) [% foo = bar, baz = qux %] -#------------------------------------------------------------------------ - -sub set { - my ($class, $setlist) = @_; - my $output; - while (my ($var, $val) = splice(@$setlist, 0, 2)) { - $output .= &assign($class, $var, $val) . ";\n"; - } - chomp $output; - return $output; -} - - -#------------------------------------------------------------------------ -# default(\@setlist) [% DEFAULT foo = bar, baz = qux %] -#------------------------------------------------------------------------ - -sub default { - my ($class, $setlist) = @_; - my $output; - while (my ($var, $val) = splice(@$setlist, 0, 2)) { - $output .= &assign($class, $var, $val, 1) . ";\n"; - } - chomp $output; - return $output; -} - - -#------------------------------------------------------------------------ -# insert(\@nameargs) [% INSERT file %] -# # => [ [ $file, ... ], \@args ] -#------------------------------------------------------------------------ - -sub insert { - my ($class, $nameargs) = @_; - my ($file, $args) = @$nameargs; - $file = $class->filenames($file); - return "$OUTPUT \$context->insert($file);"; -} - - -#------------------------------------------------------------------------ -# include(\@nameargs) [% INCLUDE template foo = bar %] -# # => [ [ $file, ... ], \@args ] -#------------------------------------------------------------------------ - -sub include { - my ($class, $nameargs) = @_; - my ($file, $args) = @$nameargs; - my $hash = shift @$args; - $file = $class->filenames($file); - $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; - return "$OUTPUT \$context->include($file);"; -} - - -#------------------------------------------------------------------------ -# process(\@nameargs) [% PROCESS template foo = bar %] -# # => [ [ $file, ... ], \@args ] -#------------------------------------------------------------------------ - -sub process { - my ($class, $nameargs) = @_; - my ($file, $args) = @$nameargs; - my $hash = shift @$args; - $file = $class->filenames($file); - $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; - return "$OUTPUT \$context->process($file);"; -} - - -#------------------------------------------------------------------------ -# if($expr, $block, $else) [% IF foo < bar %] -# ... -# [% ELSE %] -# ... -# [% END %] -#------------------------------------------------------------------------ - -sub if { - my ($class, $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 ($class, $target, $list, $args, $block) = @_; - $args = shift @$args; - $args = @$args ? ', { ' . join(', ', @$args) . ' }' : ''; - - my ($loop_save, $loop_set, $loop_restore, $setiter); - if ($target) { - $loop_save = 'eval { $oldloop = ' . &ident($class, ["'loop'"]) . ' }'; - $loop_set = "\$stash->{'$target'} = \$value"; - $loop_restore = "\$stash->set('loop', \$oldloop)"; - } - else { - $loop_save = '$stash = $context->localise()'; -# $loop_set = "\$stash->set('import', \$value) " -# . "if ref \$value eq 'HASH'"; - $loop_set = "\$stash->get(['import', [\$value]]) " - . "if ref \$value eq 'HASH'"; - $loop_restore = '$stash = $context->delocalise()'; - } - $block = pad($block, 3) if $PRETTY; - - return <<EOF; - -# FOREACH -do { - my (\$value, \$error, \$oldloop); - my \$list = $list; - - unless (UNIVERSAL::isa(\$list, 'Template::Iterator')) { - \$list = Template::Config->iterator(\$list) - || die \$Template::Config::ERROR, "\\n"; - } - - (\$value, \$error) = \$list->get_first(); - $loop_save; - \$stash->set('loop', \$list); - eval { -LOOP: while (! \$error) { - $loop_set; -$block; - (\$value, \$error) = \$list->get_next(); - } - }; - $loop_restore; - die \$@ if \$@; - \$error = 0 if \$error && \$error eq Template::Constants::STATUS_DONE; - die \$error if \$error; -}; -EOF -} - -#------------------------------------------------------------------------ -# next() [% NEXT %] -# -# Next iteration of a FOREACH loop (experimental) -#------------------------------------------------------------------------ - -sub next { - return <<EOF; -(\$value, \$error) = \$list->get_next(); -next LOOP; -EOF -} - - -#------------------------------------------------------------------------ -# wrapper(\@nameargs, $block) [% WRAPPER template foo = bar %] -# # => [ [$file,...], \@args ] -#------------------------------------------------------------------------ - -sub wrapper { - my ($class, $nameargs, $block) = @_; - my ($file, $args) = @$nameargs; - my $hash = shift @$args; - - local $" = ', '; -# print STDERR "wrapper([@$file], { @$hash })\n"; - - return $class->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 ($class, $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 ($class, $expr, $block) = @_; - $block = pad($block, 2) if $PRETTY; - - return <<EOF; - -# WHILE -do { - my \$failsafe = $WHILE_MAX; -LOOP: - while (--\$failsafe && ($expr)) { -$block - } - die "WHILE loop terminated (> $WHILE_MAX iterations)\\n" - unless \$failsafe; -}; -EOF -} - - -#------------------------------------------------------------------------ -# switch($expr, \@case) [% SWITCH %] -# [% CASE foo %] -# ... -# [% END %] -#------------------------------------------------------------------------ - -sub switch { - my ($class, $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; -\$match = $match; -\$match = [ \$match ] unless ref \$match eq 'ARRAY'; -if (grep(/^\$result\$/, \@\$match)) { -$block - last SWITCH; -} -EOF - } - - $caseblock .= $default - if defined $default; - $caseblock = pad($caseblock, 2) if $PRETTY; - -return <<EOF; - -# SWITCH -do { - my \$result = $expr; - my \$match; - SWITCH: { -$caseblock - } -}; -EOF -} - - -#------------------------------------------------------------------------ -# try($block, \@catch) [% TRY %] -# ... -# [% CATCH %] -# ... -# [% END %] -#------------------------------------------------------------------------ - -sub try { - my ($class, $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 $error if $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 (\$handler eq '$match') {\n$mblock\n}\n" - : "if (\$handler eq '$match') {\n$mblock\n}\n"; - } - $catchblock .= "\$error = 0;"; - $catchblock = pad($catchblock, 3) if $PRETTY; - if ($default) { - $default = pad($default, 1) if $PRETTY; - $default = "else {\n # DEFAULT\n$default\n \$error = '';\n}"; - } - else { - $default = '# NO DEFAULT'; - } - $default = pad($default, 2) if $PRETTY; - - $handlers = join(', ', @$handlers); -return <<EOF; - -# TRY -$OUTPUT do { - my \$output = ''; - my (\$error, \$handler); - eval { -$block - }; - if (\$@) { - \$error = \$context->catch(\$@, \\\$output); - die \$error if \$error->type =~ /^return|stop\$/; - \$stash->set('error', \$error); - \$stash->set('e', \$error); - if (defined (\$handler = \$error->select_handler($handlers))) { -$catchblock - } -$default - } -$final -}; -EOF -} - - -#------------------------------------------------------------------------ -# throw(\@nameargs) [% THROW foo "bar error" %] -# # => [ [$type], \@args ] -#------------------------------------------------------------------------ - -sub throw { - my ($class, $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 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 ($class, $lnameargs) = @_; - my ($file, $args, $alias) = @$lnameargs; - $file = shift @$file; # same production rule as INCLUDE - $alias ||= $file; - $args = &args($class, $args); - $file .= ", $args" if $args; -# my $set = &assign($class, $alias, '$plugin'); - return "# USE\n" - . "\$stash->set($alias,\n" - . " \$context->plugin($file));"; -} - -#------------------------------------------------------------------------ -# view(\@nameargs, $block) [% VIEW name args %] -# # => [ [$file, ... ], \@args ] -#------------------------------------------------------------------------ - -sub view { - my ($class, $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 \$oldv = \$stash->get('view'); - my \$view = \$context->view($hash); - \$stash->set($name, \$view); - \$stash->set('view', \$view); - -$block - - \$stash->set('view', \$oldv); - \$view->seal(); - \$output; -}; -EOF -} - - -#------------------------------------------------------------------------ -# perl($block) -#------------------------------------------------------------------------ - -sub perl { - my ($class, $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 \$result = ''; - tie *Template::Perl::PERLOUT, 'Template::TieString', \\\$result; - my \$save_stdout = select *Template::Perl::PERLOUT; - - eval \$output; - select \$save_stdout; - \$context->throw(\$@) if \$@; - \$result; -}; -EOF -} - - -#------------------------------------------------------------------------ -# no_perl() -#------------------------------------------------------------------------ - -sub no_perl { - my $class = 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 ($class, $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 ($class, $lnameargs, $block) = @_; - my ($name, $args, $alias) = @$lnameargs; - $name = shift @$name; - $args = &args($class, $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 \$filter = \$context->filter($name) - || \$context->throw(\$context->error); - -$block - - &\$filter(\$output); -}; -EOF -} - - -#------------------------------------------------------------------------ -# capture($name, $block) -#------------------------------------------------------------------------ - -sub capture { - my ($class, $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 ($class, $ident, $block, $args) = @_; - $block = pad($block, 2) if $PRETTY; - - if ($args) { - my $nargs = scalar @$args; - $args = join(', ', map { "'$_'" } @$args); - $args = $nargs > 1 - ? "\@args{ $args } = splice(\@_, 0, $nargs)" - : "\$args{ $args } = shift"; - - return <<EOF; - -# MACRO -\$stash->set('$ident', sub { - my \$output = ''; - my (%args, \$params); - $args; - \$params = shift; - \$params = { } unless ref(\$params) eq 'HASH'; - \$params = { \%args, %\$params }; - - my \$stash = \$context->localise(\$params); - eval { -$block - }; - \$stash = \$context->delocalise(); - die \$@ if \$@; - return \$output; -}); -EOF - - } - else { - return <<EOF; - -# MACRO -\$stash->set('$ident', sub { - my \$params = \$_[0] if ref(\$_[0]) eq 'HASH'; - my \$output = ''; - - my \$stash = \$context->localise(\$params); - eval { -$block - }; - \$stash = \$context->delocalise(); - die \$@ if \$@; - return \$output; -}); -EOF - } -} - - -sub debug { - my ($class, $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__ - diff --git a/lib/Template/Document.pm b/lib/Template/Document.pm deleted file mode 100644 index ce3beb2..0000000 --- a/lib/Template/Document.pm +++ /dev/null @@ -1,492 +0,0 @@ -##============================================================= -*-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@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Document.pm,v 2.71 2004/01/13 16:19:10 abw Exp $ -# -#============================================================================ - -package Template::Document; - -require 5.004; - -use strict; -use vars qw( $VERSION $ERROR $COMPERR $DEBUG $AUTOLOAD ); -use base qw( Template::Base ); -use Template::Constants; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.71 $ =~ /(\d+)\.(\d+)/); - - -#======================================================================== -# ----- 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, $metadata) = @$doc{ qw( BLOCK DEFBLOCKS 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! - $block =~ /(.*)/s; - $block = $1; - - $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, - _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 nameand the values -# are references to Template::Document objects. Returns 0 (# an empty hash) -# if no blocks are defined. -#------------------------------------------------------------------------ - -sub blocks { - return $_[0]->{ _DEFBLOCKS }; -} - - -#------------------------------------------------------------------------ -# 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; -} - - -#------------------------------------------------------------------------ -# 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 }; -} - - -#======================================================================== -# ----- PRIVATE METHODS ----- -#======================================================================== - - -#------------------------------------------------------------------------ -# _dump() -# -# Debug method which returns a string representing the internal state -# of the object. -#------------------------------------------------------------------------ - -sub _dump { - my $self = shift; - my $dblks; - my $output = "$self : $self->{ name }\n"; - - $output .= "BLOCK: $self->{ _BLOCK }\nDEFBLOCKS:\n"; - - if ($dblks = $self->{ _DEFBLOCKS }) { - foreach my $b (keys %$dblks) { - $output .= " $b: $dblks->{ $b }\n"; - } - } - - return $output; -} - - -#======================================================================== -# ----- 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/\n/\n /g; - $block =~ s/\s+$//; - - $defblocks = join('', map { - my $code = $defblocks->{ $_ }; - $code =~ s/\n/\n /g; - $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 $file =~ /^(.+)$/s; - - eval { - require File::Temp; - require File::Basename; - ($fh, $tmpfile) = File::Temp::tempfile( - DIR => File::Basename::dirname($file) - ); - print $fh $class->as_perl($content) || die $!; - close($fh); - }; - return $class->error($@) if $@; - return rename($tmpfile, $file) - || $class->error($!); -} - - -#------------------------------------------------------------------------ -# catch_warnings($msg) -# -# Installed as -#------------------------------------------------------------------------ - -sub catch_warnings { - $COMPERR .= join('', @_); -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 Template::Parser module creates a -Template::Document instance to encapsulate a template as it is compiled -into Perl code. - -The constructor method, new(), expects a reference to a hash array -containing the BLOCK, DEFBLOCKS and METADATA items. The BLOCK item -should contain a reference to a Perl subroutine or a textual -representation of Perl code, as generated by the Template::Parser -module, which is then evaluated into a subroutine reference using -eval(). The DEFLOCKS item should reference a hash array containing -further named BLOCKs which may be defined in the template. The keys -represent BLOCK names and the values should be subroutine references -or text strings of Perl code as per the main BLOCK item. The METADATA -item should reference a hash array of metadata items relevant to the -document. - -The process() method can then be called on the instantiated -Template::Document object, passing a reference to a Template::Content -object as the first parameter. This will install any locally defined -blocks (DEFBLOCKS) in the the contexts() BLOCKS cache (via a call to -visit()) so that they may be subsequently resolved by the context. The -main 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 process() method, after calling the context leave() -method to permit cleanup and de-registration of named BLOCKS previously -installed. - -An AUTOLOAD method provides access to the METADATA items for the document. -The Template::Service module installs a reference to the main -Template::Document object in the stash as the 'template' variable. -This allows metadata items to be accessed from within templates, -including PRE_PROCESS templates. - -header: - - <html> - <head> - <title>[% template.title %] - </head> - ... - -Template::Document objects are usually created by the 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; - -BLOCK and DEFBLOCKS items may be expressed as references to Perl subroutines -or as text strings containing Perl subroutine definitions, as is generated -by the Template::Parser module. These are evaluated into subroutine references -using eval(). - -Returns a new Template::Document object or undef on error. The error() class -method can be called, or the $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 Template::Context object should be passed as the first parameter. The -method installs any locally defined blocks via a call to the context -visit() method, processes it's own template, passing the context reference -by parameter and then calls 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 die(). - -=head2 block() - -Returns a reference to the main BLOCK subroutine. - -=head2 blocks() - -Returns a reference to the hash array of named DEFBLOCKS subroutines. - -=head2 AUTOLOAD - -An autoload method returns METADATA items. - - print $doc->author(); - -=head1 PACKAGE SUB-ROUTINES - -=head2 write_perl_file(\%config) - -This package subroutine is provided to effect persistance of compiled -templates. If the COMPILE_EXT option (to indicate a file extension -for saving compiled templates) then the Template::Parser module calls -this subroutine before calling the 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 susequently require() the file -and have Perl parse and compile it into a Template::Document. Thus we -have persistance of compiled templates. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.71, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template>, L<Template::Parser|Template::Parser> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Exception.pm b/lib/Template/Exception.pm deleted file mode 100644 index 9a95af7..0000000 --- a/lib/Template/Exception.pm +++ /dev/null @@ -1,254 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Exception -# -# DESCRIPTION -# Module implementing a generic exception class used for error handling -# in the Template Toolkit. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#------------------------------------------------------------------------ -# -# $Id: Exception.pm,v 2.64 2004/01/13 16:19:10 abw Exp $ -# -#======================================================================== - - -package Template::Exception; - -require 5.005; - -use strict; -use vars qw( $VERSION ); - -use constant TYPE => 0; -use constant INFO => 1; -use constant TEXT => 2; -use overload q|""| => "as_string", fallback => 1; - - -$VERSION = sprintf("%d.%02d", q$Revision: 2.64 $ =~ /(\d+)\.(\d+)/); - - -#------------------------------------------------------------------------ -# 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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 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 THROW directive, - - [% THROW user.login 'no user id: please login' %] - -or by calling the throw() method on the current Template::Context object, - - $context->throw('user.passwd', 'Incorrect Password'); - $context->throw('Incorrect Password'); # type 'undef' - -or from Perl code by calling die() with a Template::Exception object, - - die (Template::Exception->new('user.denied', 'Invalid User ID')); - -or by simply calling die() with an error string. This is -automagically caught and converted to an exception of 'undef' -type 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. 'foo', 'foo.bar', 'foo.bar.baz'). -Exception types are considered to be hierarchical such that 'foo.bar' -would be a specific type of the more general 'foo' type. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.64, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template>, L<Template::Context|Template::Context> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/FAQ.pod b/lib/Template/FAQ.pod deleted file mode 100644 index 0807ace..0000000 --- a/lib/Template/FAQ.pod +++ /dev/null @@ -1,329 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::FAQ -# -# DESCRIPTION -# This is the Frequently Asked Questions list for the Template -# Toolkit. More accurately, it's a very thin placeholder for where -# the FAQ will soon be. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# 2.69 -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::FAQ - Frequently Asked Questions about the Template Toolkit - -=head1 DESCRIPTION - -This is the Frequently Asked Questions list for the Template Toolkit. -More accurately, it's a very thin placeholder for where the FAQ will -soon be. - - -=head1 Template Toolkit Language - -=head2 Why doesn't [% a = b IF c %] work as expected? - -Because the parser interprets it as - - [% a = (b IF c) %] - -Do this instead: - - [% SET a = b IF c %] - -=head2 If I'm using TT to write out a TT template, is there a good way to escape [% and %]? - -You can do this: - - [% stag = "[\%" - etag = "%\]" - %] - -and then: - - [% stag; 'hello'; etag %] - -Or something like: - - [% TAGS [- -] %] - [- INCLUDE foo -] # is a directive - [% INCLUDE foo %] # not a directive, just plain text, passed through - -=head2 How do I iterate over a hash? - -This is covered in the L<Template::Manual::VMethods|VMethods> section -of the manual page. A list of all the keys that are in the hash can -be obtained with the '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 %] - - -=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 Template::Provider. See the mailing list archives for further -info. - -=head2 Can I fetch templates via http? - -To do the job properly, you should sublcass Template::Provider to -Template::Provider::HTTP and use a PREFIX_MAP option to bind the -'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 PREFIX_MAP - it may not be properly documented anywhere -else...yet!). e.g. (untested due to lack of existing HTTP Provider -- patches welcome!). - - 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 %] - -But similarly, 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's post from the mailing list has some useful -pointers on how to acheive this using existing modules: - - To: Adam Theo <adamtheo@theoretic.com> - From: Craig Barratt <craig@arraycomm.com> - Date: Fri, 18 May 2001 17:06:59 -0700 - - > i was wondering if there is anyway to fetch a file using http:// or - > ftp:// and include that? - - Here's one way. Set the LOAD_PERL option: - - use Template; - - my $template = Template->new({ - LOAD_PERL => 1 - }); - $template->process("example.tt", { stdout => *STDOUT }) - || die $template->error(); - - and then use LWP::UserAgent and HTTP::Request: - - [% - USE ua = LWP.UserAgent; - ua.proxy("http", "http://your_proxy/"); - USE req = HTTP.Request("GET", "http://www.cpan.org"); - ua.request(req).content; - -%] - - For FTP use Net::FTP: - - [% - USE ftp = Net.FTP("ftp.cpan.org"); - x = ftp.login("anonymous", "me@here.there"); - x = ftp.cwd("/"); - x = ftp.get("welcome.msg", stdout); - x = ftp.quit; - -%] - - Normally ftp.get would write the file into the current directory. - Instead we pass stdout as a second argument so that it is written - to stdout. We set stdout to STDOUT in the variables we pass to - process. - - Craig - -=head1 Miscellaneous - -=head2 How can I configure variables on a per-request basis? - -One easy way to acheive this is to define a single 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. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.69, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Filters.pm b/lib/Template/Filters.pm deleted file mode 100644 index a9c4846..0000000 --- a/lib/Template/Filters.pm +++ /dev/null @@ -1,1448 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Filters -# -# DESCRIPTION -# Defines filter plugins as used by the FILTER directive. -# -# AUTHORS -# Andy Wardley <abw@kfs.org>, with a number of filters contributed -# by Leslie Michael Orchard <deus_x@nijacode.com> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Filters.pm,v 2.77 2004/01/13 16:19:10 abw Exp $ -# -#============================================================================ - -package Template::Filters; - -require 5.004; - -use strict; -use base qw( Template::Base ); -use vars qw( $VERSION $DEBUG $FILTERS $URI_ESCAPES $PLUGIN_FILTER ); -use Template::Constants; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.77 $ =~ /(\d+)\.(\d+)/); - - -#------------------------------------------------------------------------ -# 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. -#------------------------------------------------------------------------ - -$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, - 'uri' => \&uri_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 ], - 'latex' => [ \&latex_filter_factory, 1 ], -}; - -# name of module implementing plugin filters -$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 paramter. -# -# 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 (UNIVERSAL::isa($name, $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; -} - - - -#------------------------------------------------------------------------ -# _dump() -# -# Debug method -#------------------------------------------------------------------------ - -sub _dump { - my $self = shift; - my $output = "[Template::Filters] {\n"; - my $format = " %-16s => %s\n"; - my $key; - - foreach $key (qw( TOLERANT )) { - my $val = $self->{ $key }; - $val = '<undef>' unless defined $val; - $output .= sprintf($format, $key, $val); - } - - my $filters = $self->{ FILTERS }; - $filters = join('', map { - sprintf(" $format", $_, $filters->{ $_ }); - } keys %$filters); - $filters = "{\n$filters }"; - - $output .= sprintf($format, 'FILTERS (local)' => $filters); - - $filters = $FILTERS; - $filters = join('', map { - my $f = $filters->{ $_ }; - my ($ref, $dynamic) = ref $f eq 'ARRAY' ? @$f : ($f, 0); - sprintf(" $format", $_, $dynamic ? 'dynamic' : 'static'); - } sort keys %$filters); - $filters = "{\n$filters }"; - - $output .= sprintf($format, 'FILTERS (global)' => $filters); - - $output .= '}'; - return $output; -} - - -#======================================================================== -# -- STATIC FILTER SUBS -- -#======================================================================== - -#------------------------------------------------------------------------ -# uri_filter() [% FILTER uri %] -# -# URI escape a string. This code is borrowed from Gisle Aas' URI::Escape -# module. For something so simple, I can't see any validation in making -# the user install the URI modules just for this, so we cut and paste. -# -# URI::Escape is Copyright 1995-2000 Gisle Aas. -#------------------------------------------------------------------------ - -sub uri_filter { - my $text = shift; - - # construct and cache a lookup table for escapes (faster than - # doing a sprintf() for every character in every string each - # time) - $URI_ESCAPES ||= { - map { ( chr($_), sprintf("%%%02X", $_) ) } (0..255), - }; - - $text =~ s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*'()])/$URI_ESCAPES->{$1}/g; - $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; -} - - -#------------------------------------------------------------------------ -# 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 html_entity_filter_factory { - my $context = shift; - - # if Apache::Util is installed then we use it - eval { - require Apache::Util; - Apache::Util::escape_html(''); - }; - return \&Apache::Util::escape_html - unless $@; - - # otherwise if HTML::Entities is installed then we use that - eval { - require HTML::Entities; - }; - return \&HTML::Entities::encode_entities - unless $@; - - return (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) = @_; - $len = 32 unless defined $len; - - return sub { - my $text = shift; - return $text if length $text < $len; - return substr($text, 0, $len - 3) . "..."; - } -} - - -#------------------------------------------------------------------------ -# 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; - - $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 ''; - } -} - - -#------------------------------------------------------------------------ -# latex_filter_factory($context, $outputType) [% FILTER latex(outputType) %] -# -# Return a filter sub that converts a (hopefully) complete LaTeX source -# file to either "ps", "dvi", or "pdf". Output type should be "ps", "dvi" -# or "pdf" (pdf is default). -# -# Creates a temporary directory below File::Spec->tmpdir() (often /tmp) -# and writes the text into doc.tex. It then runs either pdflatex or -# latex and optionally dvips. Based on the exit status either returns -# the entire doc.(pdf|ps|dvi) output or throws an error with a summary -# of the error messages from doc.log. -# -# Written by Craig Barratt, Apr 28 2001. -# Win32 additions by Richard Tietjen. -#------------------------------------------------------------------------ -use File::Path; -use File::Spec; -use Cwd; - -sub latex_filter_factory -{ - my($context, $output) = @_; - - $output = lc($output); - my $fName = "latex"; - my($LaTeXPath, $PdfLaTeXPath, $DviPSPath) - = @{Template::Config->latexpaths()}; - if ( $output eq "ps" || $output eq "dvi" ) { - $context->throw($fName, - "latex not installed (see Template::Config::LATEX_PATH)") - if ( $LaTeXPath eq "" ); - } else { - $output = "pdf"; - $LaTeXPath = $PdfLaTeXPath; - $context->throw($fName, - "pdflatex not installed (see Template::Config::PDFLATEX_PATH)") - if ( $LaTeXPath eq "" ); - } - if ( $output eq "ps" && $DviPSPath eq "" ) { - $context->throw($fName, - "dvips not installed (see Template::Config::DVIPS_PATH)"); - } - if ( $^O !~ /^(MacOS|os2|VMS)$/i ) { - return sub { - local(*FH); - my $text = shift; - my $tmpRootDir = File::Spec->tmpdir(); - my $cnt = 0; - my($tmpDir, $fileName, $devnull); - my $texDoc = 'doc'; - - do { - $tmpDir = File::Spec->catdir($tmpRootDir, - "tt2latex$$" . "_$cnt"); - $cnt++; - } while ( -e $tmpDir ); - mkpath($tmpDir, 0, 0700); - $context->throw($fName, "can't create temp dir $tmpDir") - if ( !-d $tmpDir ); - $fileName = File::Spec->catfile($tmpDir, "$texDoc.tex"); - $devnull = File::Spec->devnull(); - if ( !open(FH, ">$fileName") ) { - rmtree($tmpDir); - $context->throw($fName, "can't open $fileName for output"); - } - print(FH $text); - close(FH); - - # latex must run in tmpDir directory - my $currDir = cwd(); - if ( !chdir($tmpDir) ) { - rmtree($tmpDir); - $context->throw($fName, "can't chdir $tmpDir"); - } - # - # We don't need to quote the backslashes on windows, but we - # do on other OSs - # - my $LaTeX_arg = "\\nonstopmode\\input{$texDoc}"; - $LaTeX_arg = "'$LaTeX_arg'" if ( $^O ne 'MSWin32' ); - if ( system("$LaTeXPath $LaTeX_arg" - . " 1>$devnull 2>$devnull 0<$devnull") ) { - my $texErrs = ""; - $fileName = File::Spec->catfile($tmpDir, "$texDoc.log"); - if ( open(FH, "<$fileName") ) { - my $state = 0; - # - # Try to extract just the interesting errors from - # the verbose log file - # - while ( <FH> ) { - # - # TeX errors seems to start with a "!" at the - # start of the line, and are followed several - # lines later by a line designator of the - # form "l.nnn" where nnn is the line number. - # We make sure we pick up every /^!/ line, and - # the first /^l.\d/ line after each /^!/ line. - # - if ( /^(!.*)/ ) { - $texErrs .= $1 . "\n"; - $state = 1; - } - if ( $state == 1 && /^(l\.\d.*)/ ) { - $texErrs .= $1 . "\n"; - $state = 0; - } - } - close(FH); - } else { - $texErrs = "Unable to open $fileName\n"; - } - my $ok = chdir($currDir); - rmtree($tmpDir); - $context->throw($fName, "can't chdir $currDir") if ( !$ok ); - $context->throw($fName, "latex exited with errors:\n$texErrs"); - } - if ( $output eq "ps" ) { - $fileName = File::Spec->catfile($tmpDir, "$texDoc.dvi"); - if ( system("$DviPSPath $texDoc -o" - . " 1>$devnull 2>$devnull 0<$devnull") ) { - my $ok = chdir($currDir); - rmtree($tmpDir); - $context->throw($fName, "can't chdir $currDir") if ( !$ok ); - $context->throw($fName, "can't run $DviPSPath $fileName"); - } - } - if ( !chdir($currDir) ) { - rmtree($tmpDir); - $context->throw($fName, "can't chdir $currDir"); - } - - my $retStr; - $fileName = File::Spec->catfile($tmpDir, "$texDoc.$output"); - if ( open(FH, $fileName) ) { - local $/ = undef; # slurp file in one go - binmode(FH); - $retStr = <FH>; - close(FH); - } else { - rmtree($tmpDir); - $context->throw($fName, "Can't open output file $fileName"); - } - rmtree($tmpDir); - return $retStr; - } - } else { - $context->throw("$fName not yet supported on $^O OS." - . " Please contribute code!!"); - } -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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); - -=head1 DESCRIPTION - -The Template::Filters module implements a provider for creating and/or -returning subroutines that implement the standard filters. Additional -custom filters may be provided via the FILTERS options. - -=head1 METHODS - -=head2 new(\%params) - -Constructor method which instantiates and returns a reference to a -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 Template::Filters module is created by the Template.pm module -if the 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 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 Template::Context -object. - -The method returns a reference to a filter sub-routine on success. It -may also return (undef, STATUS_DECLINE) to decline the request, to allow -delegation onto other filter providers in the LOAD_FILTERS chain of -responsibility. On error, ($error, STATUS_ERROR) is returned where $error -is an error message or Template::Exception object indicating the error -that occurred. - -When the TOLERANT option is set, errors are automatically downgraded to -a STATUS_DECLINE response. - - -=head1 CONFIGURATION OPTIONS - -The following list details the configuration options that can be provided -to the Template::Filters new() constructor. - -=over 4 - - - - -=item FILTERS - -The FILTERS option can be used to specify custom filters which can -then be used with the 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 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 (0) or -dynamic (1). A filter may also be specified as a solitary subroutine -reference and is assumed to be static. - - $filters = Template::Filters->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 -define_filter() method on the current 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. '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. '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 -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 FILTER directive for further examples. - - - - -=item TOLERANT - -The TOLERANT flag is used by the various Template Toolkit provider -modules (Template::Provider, Template::Plugins, 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 (template, plugin, filter) being denied and an exception -raised. When the TOLERANT flag is set to any true values, errors will -be silently ignored and the provider will instead return -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 'E<lt>resourceE<gt> not found' exception is raised. - - - - -=item DEBUG - -The DEBUG option can be used to enable debugging messages from the -Template::Filters module by setting it to include the DEBUG_FILTERS -value. - - use Template::Constants qw( :debug ); - - my $template = Template->new({ - DEBUG => DEBUG_FILTERS | DEBUG_PLUGINS, - }); - - - - -=back - -=head1 TEMPLATE TOOLKIT FILTERS - -The following standard filters are distributed with the Template Toolkit. - - - -=head2 format(format) - -The 'format' filter takes a format string as a parameter (as per -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. --> - -=head2 upper - -Folds the input to UPPER CASE. - - [% "hello world" FILTER upper %] - -output: - - HELLO WORLD - -=head2 lower - -Folds the input to lower case. - - [% "Hello World" FILTER lower %] - -output: - - hello world - -=head2 ucfirst - -Folds the first character of the input to UPPER CASE. - - [% "hello" FILTER ucfirst %] - -output: - - Hello - -=head2 lcfirst - -Folds the first character of the input to lower case. - - [% "HELLO" FILTER lcfirst %] - -output: - - hELLO - -=head2 trim - -Trims any leading or trailing whitespace from the input text. Particularly -useful in conjunction with INCLUDE, PROCESS, etc., having the same effect -as the TRIM configuration option. - - [% INCLUDE myfile | trim %] - -=head2 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 - -=head2 html - -Converts the characters 'E<lt>', 'E<gt>' and '&' to '<', '>' and -'&', 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... - -=head2 html_entity - -The html filter is fast and simple but it doesn't encode the full -range of HTML entities that your text may contain. The html_entity -filter uses either the Apache::Util module (which is written in C and -is therefore faster) or the 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 escape_html() or encode_entities() subroutines -respectively) to convert all extended characters into their -appropriate HTML entities (e.g. converting 'é' to 'é'). If -neither module is available on your system then an 'html_entity' exception -will be thrown reporting an appropriate message. - -For further information on HTML entity encoding, see -http://www.w3.org/TR/REC-html40/sgml/entities.html. - -=head2 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 E<lt>pE<gt>...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> - -=head2 html_break / html_para_break - -Similar to the html_para filter described above, but uses the HTML tag -sequence 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. - -=head2 html_line_break - -This filter replaces any newlines with 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> - -=head2 uri - -This filter URI escapes the input text, converting any characters -outside of the permitted URI character set (as defined by RFC 2396) -into a C<%nn> hex escape. - - [% 'my file.html' | uri %] - -output: - - my%20file.html - -Note that URI escaping isn't always enough when generating hyperlinks in -an HTML document. The C<&> character, for example, is valid in a URI and -will not be escaped by the URI filter. In this case you should also filter -the text through the 'html' filter. - - <a href="[% filename | uri | html %]">click here</a> - -=head2 indent(pad) - -Indents the text block by a fixed pad string or width. The '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 - -=head2 truncate(length) - -Truncates the text block to the length specified, or a default length of -32. Truncated text will be terminated with '...' (i.e. the '...' 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... - -=head2 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! - -=head2 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 - -=head2 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 - -=head2 redirect(file, options) - -The 'redirect' filter redirects the output of the block into a separate -file, specified relative to the OUTPUT_PATH configuration item. - - [% FOREACH user = myorg.userlist %] - [% FILTER redirect("users/${user.id}.html") %] - [% INCLUDE userinfo %] - [% END %] - [% END %] - -or more succinctly, using side-effect notation: - - [% INCLUDE userinfo - FILTER redirect("users/${user.id}.html") - FOREACH user = myorg.userlist - %] - -A 'file' exception will be thrown if the OUTPUT_PATH option is undefined. - -An optional '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 'binmode' option -as shown in the first example. - -=head2 eval / evaltt - -The '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 'evaltt' filter is provided as an alias for 'eval'. - -=head2 perl / evalperl - -The 'perl' filter evaluates the block as Perl code. The EVAL_PERL -option must be set to a true value or a 'perl' exception will be -thrown. - - [% my_perl_code | perl %] - -In most cases, the [% PERL %] ... [% 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 'evalperl' filter is provided as an alias for 'perl' for backwards -compatibility. - -=head2 stdout(options) - -The stdout filter prints the output generated by the enclosing block to -STDOUT. The 'binmode' option can be passed as either a named parameter -or a single argument to set 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 stdout filter can be used to force binmode on STDOUT, or also inside -redirect, null or stderr blocks to make sure that particular output goes -to stdout. See the null filter below for an example. - -=head2 stderr - -The stderr filter prints the output generated by the enclosing block to -STDERR. - -=head2 null - -The 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 stdout filter to ensure that a particular expression -generates output to stdout (in this case in binary mode). - -=head2 latex(outputType) - -Passes the text block to LaTeX and produces either PDF, DVI or -PostScript output. The 'outputType' argument determines the output -format and it should be set to one of the strings: "pdf" (default), -"dvi", or "ps". - -The text block should be a complete LaTeX source file. - - [% FILTER latex("pdf") -%] - \documentclass{article} - - \begin{document} - - \title{A Sample TT2 \LaTeX\ Source File} - \author{Craig Barratt} - \maketitle - - \section{Introduction} - This is some text. - - \end{document} - [% END -%] - -The output will be a PDF file. You should be careful not to prepend or -append any extraneous characters or text outside the FILTER block, -since this text will wrap the (binary) output of the latex filter. -Notice the END directive uses '-%]' for the END_TAG to remove the -trailing new line. - -One example where you might prepend text is in a CGI script where -you might include the Content-Type before the latex output, eg: - - Content-Type: application/pdf - - [% FILTER latex("pdf") -%] - \documentclass{article} - \begin{document} - ... - \end{document} - [% END -%] - -In other cases you might use the redirect filter to put the output -into a file, rather than delivering it to stdout. This might be -suitable for batch scripts: - - [% output = FILTER latex("pdf") -%] - \documentclass{article} - \begin{document} - ... - \end{document} - [% END; output | redirect("document.pdf", 1) -%] - -(Notice the second argument to redirect to force binary mode.) - -Note that the latex filter runs one or two external programs, so it -isn't very fast. But for modest documents the performance is adequate, -even for interactive applications. - -A error of type 'latex' will be thrown if there is an error reported -by latex, pdflatex or dvips. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.77, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template>, L<Template::Context|Template::Context>, L<Template::Manual::Filters|Template::Manual::Filters> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Grammar.pm b/lib/Template/Grammar.pm deleted file mode 100644 index 8635426..0000000 --- a/lib/Template/Grammar.pm +++ /dev/null @@ -1,6179 +0,0 @@ -#============================================================= -*-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-2000 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. -# -#------------------------------------------------------------------------ -# -# 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). -# -#------------------------------------------------------------------------ -# -# $Id: Grammar.pm,v 2.22 2004/01/13 16:19:10 abw Exp $ -# -#======================================================================== - -package Template::Grammar; - -require 5.004; - -use strict; -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.22 $ =~ /(\d+)\.(\d+)/); - -my (@RESERVED, %CMPOP, $LEXTABLE, $RULES, $STATES); -my ($factory, $rawstart); - - -#======================================================================== - -# Reserved words, comparison and binary operators -#======================================================================== - -@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 - < < - > > - >= >= - <= <= -); - - -#======================================================================== -# 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 @tokens = qw< ( ) [ ] { } ${ $ + / ; : ? >; - my @cmpop = keys %CMPOP; -# my @binop = qw( + - * % ); # '/' above, in @tokens - 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 ); -} - - -#======================================================================== -# 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; -} - - -#======================================================================== -# States -#======================================================================== - -$STATES = [ - {#State 0 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'template' => 52, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'switch' => 34, - 'try' => 35, - 'assign' => 19, - 'block' => 72, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 1 - ACTIONS => { - "\$" => 43, - 'LITERAL' => 75, - 'IDENT' => 2, - "\${" => 37 - }, - GOTOS => { - 'setlist' => 76, - 'item' => 39, - 'assign' => 19, - 'node' => 23, - 'ident' => 74 - } - }, - {#State 2 - DEFAULT => -130 - }, - {#State 3 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 79, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 4 - DEFAULT => -23 - }, - {#State 5 - ACTIONS => { - ";" => 80 - } - }, - {#State 6 - DEFAULT => -37 - }, - {#State 7 - DEFAULT => -14 - }, - {#State 8 - ACTIONS => { - "\"" => 89, - "\$" => 86, - 'LITERAL' => 88, - 'FILENAME' => 83, - 'IDENT' => 81, - 'NUMBER' => 84 - }, - GOTOS => { - 'filepart' => 87, - 'names' => 91, - 'nameargs' => 90, - 'filename' => 85, - 'name' => 82 - } - }, - {#State 9 - ACTIONS => { - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "]" => 94, - "\${" => 37 - }, - GOTOS => { - 'sterm' => 96, - 'item' => 39, - 'range' => 93, - 'node' => 23, - 'ident' => 77, - 'term' => 95, - 'list' => 92, - 'lterm' => 56 - } - }, - {#State 10 - ACTIONS => { - ";" => 97 - } - }, - {#State 11 - DEFAULT => -5 - }, - {#State 12 - ACTIONS => { - ";" => -20 - }, - DEFAULT => -27 - }, - {#State 13 - DEFAULT => -78, - GOTOS => { - '@5-1' => 98 - } - }, - {#State 14 - ACTIONS => { - 'IDENT' => 99 - }, - DEFAULT => -87, - GOTOS => { - 'blockargs' => 102, - 'metadata' => 101, - 'meta' => 100 - } - }, - {#State 15 - ACTIONS => { - 'IDENT' => 99 - }, - GOTOS => { - 'metadata' => 103, - 'meta' => 100 - } - }, - {#State 16 - ACTIONS => { - 'DOT' => 104, - 'ASSIGN' => 105 - }, - DEFAULT => -109 - }, - {#State 17 - ACTIONS => { - "\"" => 89, - "\$" => 86, - 'LITERAL' => 88, - 'FILENAME' => 83, - 'IDENT' => 81, - 'NUMBER' => 84 - }, - GOTOS => { - 'filepart' => 87, - 'names' => 91, - 'nameargs' => 106, - 'filename' => 85, - 'name' => 82 - } - }, - {#State 18 - ACTIONS => { - 'IDENT' => 107 - } - }, - {#State 19 - DEFAULT => -149 - }, - {#State 20 - DEFAULT => -12 - }, - {#State 21 - ACTIONS => { - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 108, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'sterm' => 68, - 'item' => 39, - 'loopvar' => 110, - 'node' => 23, - 'ident' => 77, - 'term' => 109, - 'lterm' => 56 - } - }, - {#State 22 - DEFAULT => -40 - }, - {#State 23 - DEFAULT => -127 - }, - {#State 24 - DEFAULT => -6 - }, - {#State 25 - ACTIONS => { - "\"" => 117, - "\$" => 114, - 'LITERAL' => 116, - 'FILENAME' => 83, - 'IDENT' => 111, - 'NUMBER' => 84, - "\${" => 37 - }, - GOTOS => { - 'filepart' => 87, - 'names' => 91, - 'nameargs' => 118, - 'filename' => 85, - 'lvalue' => 112, - 'lnameargs' => 115, - 'item' => 113, - 'name' => 82 - } - }, - {#State 26 - DEFAULT => -113 - }, - {#State 27 - ACTIONS => { - "\$" => 43, - 'IDENT' => 2, - "\${" => 37 - }, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'ident' => 119 - } - }, - {#State 28 - ACTIONS => { - 'LITERAL' => 124, - 'FILENAME' => 83, - 'IDENT' => 120, - 'NUMBER' => 84 - }, - DEFAULT => -87, - GOTOS => { - 'blockargs' => 123, - 'filepart' => 87, - 'filename' => 122, - 'blockname' => 121, - 'metadata' => 101, - 'meta' => 100 - } - }, - {#State 29 - DEFAULT => -43 - }, - {#State 30 - ACTIONS => { - "\$" => 43, - 'LITERAL' => 129, - 'IDENT' => 2, - "\${" => 37 - }, - DEFAULT => -119, - GOTOS => { - 'params' => 128, - 'hash' => 125, - 'item' => 126, - 'param' => 127 - } - }, - {#State 31 - DEFAULT => -25 - }, - {#State 32 - ACTIONS => { - "\"" => 117, - "\$" => 114, - 'LITERAL' => 116, - 'FILENAME' => 83, - 'IDENT' => 111, - 'NUMBER' => 84, - "\${" => 37 - }, - GOTOS => { - 'filepart' => 87, - 'names' => 91, - 'nameargs' => 118, - 'filename' => 85, - 'lvalue' => 112, - 'lnameargs' => 130, - 'item' => 113, - 'name' => 82 - } - }, - {#State 33 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -2, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 131, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 34 - DEFAULT => -22 - }, - {#State 35 - DEFAULT => -24 - }, - {#State 36 - ACTIONS => { - "\"" => 89, - "\$" => 86, - 'LITERAL' => 88, - 'FILENAME' => 83, - 'IDENT' => 81, - 'NUMBER' => 84 - }, - GOTOS => { - 'filepart' => 87, - 'names' => 91, - 'nameargs' => 132, - 'filename' => 85, - 'name' => 82 - } - }, - {#State 37 - ACTIONS => { - "\"" => 60, - "\$" => 43, - 'LITERAL' => 78, - 'IDENT' => 2, - 'REF' => 27, - 'NUMBER' => 26, - "\${" => 37 - }, - GOTOS => { - 'sterm' => 133, - 'item' => 39, - 'node' => 23, - 'ident' => 77 - } - }, - {#State 38 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 134, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 39 - ACTIONS => { - "(" => 135 - }, - DEFAULT => -128 - }, - {#State 40 - ACTIONS => { - ";" => 136 - } - }, - {#State 41 - DEFAULT => -38 - }, - {#State 42 - DEFAULT => -11 - }, - {#State 43 - ACTIONS => { - 'IDENT' => 137 - } - }, - {#State 44 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 138, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 45 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 139, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 46 - DEFAULT => -42 - }, - {#State 47 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 140, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 48 - ACTIONS => { - 'IF' => 144, - 'FILTER' => 143, - 'FOR' => 142, - 'WHILE' => 146, - 'WRAPPER' => 145, - 'UNLESS' => 141 - } - }, - {#State 49 - DEFAULT => -39 - }, - {#State 50 - DEFAULT => -10 - }, - {#State 51 - ACTIONS => { - "\"" => 89, - "\$" => 86, - 'LITERAL' => 88, - 'FILENAME' => 83, - 'IDENT' => 81, - 'NUMBER' => 84 - }, - GOTOS => { - 'filepart' => 87, - 'names' => 91, - 'nameargs' => 147, - 'filename' => 85, - 'name' => 82 - } - }, - {#State 52 - ACTIONS => { - '' => 148 - } - }, - {#State 53 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 57, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 149, - 'term' => 58, - 'expr' => 151, - 'assign' => 150, - 'lterm' => 56 - } - }, - {#State 54 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 152, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 55 - ACTIONS => { - "\"" => 89, - "\$" => 86, - 'LITERAL' => 88, - 'FILENAME' => 83, - 'IDENT' => 81, - 'NUMBER' => 84 - }, - GOTOS => { - 'filepart' => 87, - 'names' => 91, - 'nameargs' => 153, - 'filename' => 85, - 'name' => 82 - } - }, - {#State 56 - DEFAULT => -103 - }, - {#State 57 - ACTIONS => { - 'ASSIGN' => 154 - }, - DEFAULT => -112 - }, - {#State 58 - DEFAULT => -146 - }, - {#State 59 - DEFAULT => -15 - }, - {#State 60 - DEFAULT => -176, - GOTOS => { - 'quoted' => 155 - } - }, - {#State 61 - ACTIONS => { - "\"" => 89, - "\$" => 86, - 'LITERAL' => 88, - 'FILENAME' => 83, - 'IDENT' => 81, - 'NUMBER' => 84 - }, - GOTOS => { - 'filepart' => 87, - 'names' => 91, - 'nameargs' => 156, - 'filename' => 85, - 'name' => 82 - } - }, - {#State 62 - ACTIONS => { - ";" => -16, - "+" => 157, - 'CAT' => 163, - 'CMPOP' => 164, - "?" => 158, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'AND' => 160, - 'BINOP' => 161, - 'OR' => 162 - }, - DEFAULT => -26 - }, - {#State 63 - DEFAULT => -13 - }, - {#State 64 - DEFAULT => -36 - }, - {#State 65 - ACTIONS => { - "\"" => 89, - "\$" => 86, - 'LITERAL' => 88, - 'FILENAME' => 83, - 'IDENT' => 81, - 'NUMBER' => 84 - }, - GOTOS => { - 'filepart' => 87, - 'names' => 91, - 'nameargs' => 167, - 'filename' => 85, - 'name' => 82 - } - }, - {#State 66 - DEFAULT => -9 - }, - {#State 67 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 168, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 68 - DEFAULT => -104 - }, - {#State 69 - ACTIONS => { - "\$" => 43, - 'LITERAL' => 75, - 'IDENT' => 2, - "\${" => 37 - }, - GOTOS => { - 'setlist' => 169, - 'item' => 39, - 'assign' => 19, - 'node' => 23, - 'ident' => 74 - } - }, - {#State 70 - ACTIONS => { - "\$" => 43, - 'COMMA' => 171, - 'LITERAL' => 75, - 'IDENT' => 2, - "\${" => 37 - }, - DEFAULT => -19, - GOTOS => { - 'item' => 39, - 'assign' => 170, - 'node' => 23, - 'ident' => 74 - } - }, - {#State 71 - DEFAULT => -8 - }, - {#State 72 - DEFAULT => -1 - }, - {#State 73 - DEFAULT => -21 - }, - {#State 74 - ACTIONS => { - 'ASSIGN' => 172, - 'DOT' => 104 - } - }, - {#State 75 - ACTIONS => { - 'ASSIGN' => 154 - } - }, - {#State 76 - ACTIONS => { - "\$" => 43, - 'COMMA' => 171, - 'LITERAL' => 75, - 'IDENT' => 2, - "\${" => 37 - }, - DEFAULT => -30, - GOTOS => { - 'item' => 39, - 'assign' => 170, - 'node' => 23, - 'ident' => 74 - } - }, - {#State 77 - ACTIONS => { - 'DOT' => 104 - }, - DEFAULT => -109 - }, - {#State 78 - DEFAULT => -112 - }, - {#State 79 - ACTIONS => { - 'CMPOP' => 164, - "?" => 158, - ";" => 173, - "+" => 157, - 'MOD' => 165, - 'DIV' => 159, - "/" => 166, - 'AND' => 160, - 'CAT' => 163, - 'BINOP' => 161, - 'OR' => 162 - } - }, - {#State 80 - DEFAULT => -7 - }, - {#State 81 - DEFAULT => -173 - }, - {#State 82 - DEFAULT => -166 - }, - {#State 83 - DEFAULT => -172 - }, - {#State 84 - DEFAULT => -174 - }, - {#State 85 - ACTIONS => { - 'DOT' => 174 - }, - DEFAULT => -168 - }, - {#State 86 - ACTIONS => { - "\$" => 43, - 'IDENT' => 2, - "\${" => 37 - }, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'ident' => 175 - } - }, - {#State 87 - DEFAULT => -171 - }, - {#State 88 - DEFAULT => -169 - }, - {#State 89 - DEFAULT => -176, - GOTOS => { - 'quoted' => 176 - } - }, - {#State 90 - DEFAULT => -35 - }, - {#State 91 - ACTIONS => { - "+" => 177, - "(" => 178 - }, - DEFAULT => -156, - GOTOS => { - 'args' => 179 - } - }, - {#State 92 - ACTIONS => { - "{" => 30, - 'COMMA' => 182, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "]" => 180, - "\${" => 37 - }, - GOTOS => { - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 181, - 'lterm' => 56 - } - }, - {#State 93 - ACTIONS => { - "]" => 183 - } - }, - {#State 94 - DEFAULT => -107 - }, - {#State 95 - DEFAULT => -116 - }, - {#State 96 - ACTIONS => { - 'TO' => 184 - }, - DEFAULT => -104 - }, - {#State 97 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 185, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 98 - ACTIONS => { - ";" => 186 - } - }, - {#State 99 - ACTIONS => { - 'ASSIGN' => 187 - } - }, - {#State 100 - DEFAULT => -99 - }, - {#State 101 - ACTIONS => { - 'COMMA' => 189, - 'IDENT' => 99 - }, - DEFAULT => -86, - GOTOS => { - 'meta' => 188 - } - }, - {#State 102 - ACTIONS => { - ";" => 190 - } - }, - {#State 103 - ACTIONS => { - 'COMMA' => 189, - 'IDENT' => 99 - }, - DEFAULT => -17, - GOTOS => { - 'meta' => 188 - } - }, - {#State 104 - ACTIONS => { - "\$" => 43, - 'IDENT' => 2, - 'NUMBER' => 192, - "\${" => 37 - }, - GOTOS => { - 'item' => 39, - 'node' => 191 - } - }, - {#State 105 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'WRAPPER' => 55, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - "\"" => 60, - 'PROCESS' => 61, - 'FILTER' => 25, - 'RETURN' => 64, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 193, - 'DEFAULT' => 69, - "{" => 30, - "\${" => 37 - }, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'term' => 58, - 'loop' => 4, - 'expr' => 195, - 'wrapper' => 46, - 'atomexpr' => 48, - 'atomdir' => 12, - 'mdir' => 194, - 'sterm' => 68, - 'filter' => 29, - 'ident' => 149, - 'perl' => 31, - 'setlist' => 70, - 'switch' => 34, - 'try' => 35, - 'assign' => 19, - 'directive' => 196, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 106 - DEFAULT => -33 - }, - {#State 107 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'INCLUDE' => 17, - "(" => 198, - 'SWITCH' => 54, - 'WRAPPER' => 55, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - "\"" => 60, - 'PROCESS' => 61, - 'FILTER' => 25, - 'RETURN' => 64, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 193, - 'DEFAULT' => 69, - "{" => 30, - "\${" => 37 - }, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'term' => 58, - 'loop' => 4, - 'expr' => 199, - 'wrapper' => 46, - 'atomexpr' => 48, - 'atomdir' => 12, - 'mdir' => 197, - 'sterm' => 68, - 'filter' => 29, - 'ident' => 149, - 'perl' => 31, - 'setlist' => 70, - 'switch' => 34, - 'try' => 35, - 'assign' => 19, - 'directive' => 196, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 108 - ACTIONS => { - 'IN' => 201, - 'ASSIGN' => 200 - }, - DEFAULT => -130 - }, - {#State 109 - DEFAULT => -156, - GOTOS => { - 'args' => 202 - } - }, - {#State 110 - ACTIONS => { - ";" => 203 - } - }, - {#State 111 - ACTIONS => { - 'ASSIGN' => -130 - }, - DEFAULT => -173 - }, - {#State 112 - ACTIONS => { - 'ASSIGN' => 204 - } - }, - {#State 113 - DEFAULT => -159 - }, - {#State 114 - ACTIONS => { - "\$" => 43, - 'IDENT' => 205, - "\${" => 37 - }, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'ident' => 175 - } - }, - {#State 115 - ACTIONS => { - ";" => 206 - } - }, - {#State 116 - ACTIONS => { - 'ASSIGN' => -161 - }, - DEFAULT => -169 - }, - {#State 117 - DEFAULT => -176, - GOTOS => { - 'quoted' => 207 - } - }, - {#State 118 - DEFAULT => -158 - }, - {#State 119 - ACTIONS => { - 'DOT' => 104 - }, - DEFAULT => -110 - }, - {#State 120 - ACTIONS => { - 'ASSIGN' => 187 - }, - DEFAULT => -173 - }, - {#State 121 - DEFAULT => -83 - }, - {#State 122 - ACTIONS => { - 'DOT' => 174 - }, - DEFAULT => -84 - }, - {#State 123 - ACTIONS => { - ";" => 208 - } - }, - {#State 124 - DEFAULT => -85 - }, - {#State 125 - ACTIONS => { - "}" => 209 - } - }, - {#State 126 - ACTIONS => { - 'ASSIGN' => 210 - } - }, - {#State 127 - DEFAULT => -122 - }, - {#State 128 - ACTIONS => { - "\$" => 43, - 'COMMA' => 212, - 'LITERAL' => 129, - 'IDENT' => 2, - "\${" => 37 - }, - DEFAULT => -118, - GOTOS => { - 'item' => 126, - 'param' => 211 - } - }, - {#State 129 - ACTIONS => { - 'ASSIGN' => 213 - } - }, - {#State 130 - DEFAULT => -73 - }, - {#State 131 - DEFAULT => -4 - }, - {#State 132 - ACTIONS => { - ";" => 214 - } - }, - {#State 133 - ACTIONS => { - "}" => 215 - } - }, - {#State 134 - ACTIONS => { - "+" => 157, - 'CAT' => 163, - 'CMPOP' => 164, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'BINOP' => 161 - }, - DEFAULT => -142 - }, - {#State 135 - DEFAULT => -156, - GOTOS => { - 'args' => 216 - } - }, - {#State 136 - DEFAULT => -76, - GOTOS => { - '@4-2' => 217 - } - }, - {#State 137 - DEFAULT => -132 - }, - {#State 138 - ACTIONS => { - 'CMPOP' => 164, - "?" => 158, - ";" => 218, - "+" => 157, - 'MOD' => 165, - 'DIV' => 159, - "/" => 166, - 'AND' => 160, - 'CAT' => 163, - 'BINOP' => 161, - 'OR' => 162 - } - }, - {#State 139 - ACTIONS => { - "+" => 157, - 'CAT' => 163, - 'CMPOP' => 164, - "?" => 158, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'AND' => 160, - 'BINOP' => 161, - 'OR' => 162 - }, - DEFAULT => -29 - }, - {#State 140 - ACTIONS => { - "+" => 157, - 'CAT' => 163, - 'CMPOP' => 164, - "?" => 158, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'AND' => 160, - 'BINOP' => 161, - 'OR' => 162 - }, - DEFAULT => -28 - }, - {#State 141 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 219, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 142 - ACTIONS => { - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 108, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'sterm' => 68, - 'item' => 39, - 'loopvar' => 220, - 'node' => 23, - 'ident' => 77, - 'term' => 109, - 'lterm' => 56 - } - }, - {#State 143 - ACTIONS => { - "\"" => 117, - "\$" => 114, - 'LITERAL' => 116, - 'FILENAME' => 83, - 'IDENT' => 111, - 'NUMBER' => 84, - "\${" => 37 - }, - GOTOS => { - 'filepart' => 87, - 'names' => 91, - 'nameargs' => 118, - 'filename' => 85, - 'lvalue' => 112, - 'lnameargs' => 221, - 'item' => 113, - 'name' => 82 - } - }, - {#State 144 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 222, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 145 - ACTIONS => { - "\"" => 89, - "\$" => 86, - 'LITERAL' => 88, - 'FILENAME' => 83, - 'IDENT' => 81, - 'NUMBER' => 84 - }, - GOTOS => { - 'filepart' => 87, - 'names' => 91, - 'nameargs' => 223, - 'filename' => 85, - 'name' => 82 - } - }, - {#State 146 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 224, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 147 - DEFAULT => -41 - }, - {#State 148 - DEFAULT => 0 - }, - {#State 149 - ACTIONS => { - 'DOT' => 104, - 'ASSIGN' => 172 - }, - DEFAULT => -109 - }, - {#State 150 - ACTIONS => { - ")" => 225 - } - }, - {#State 151 - ACTIONS => { - 'CMPOP' => 164, - "?" => 158, - "+" => 157, - 'MOD' => 165, - 'DIV' => 159, - "/" => 166, - 'AND' => 160, - 'CAT' => 163, - 'BINOP' => 161, - ")" => 226, - 'OR' => 162 - } - }, - {#State 152 - ACTIONS => { - 'CMPOP' => 164, - "?" => 158, - ";" => 227, - "+" => 157, - 'MOD' => 165, - 'DIV' => 159, - "/" => 166, - 'AND' => 160, - 'CAT' => 163, - 'BINOP' => 161, - 'OR' => 162 - } - }, - {#State 153 - ACTIONS => { - ";" => 228 - } - }, - {#State 154 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 229, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 155 - ACTIONS => { - "\"" => 234, - 'TEXT' => 231, - ";" => 233, - "\$" => 43, - 'IDENT' => 2, - "\${" => 37 - }, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'ident' => 230, - 'quotable' => 232 - } - }, - {#State 156 - DEFAULT => -34 - }, - {#State 157 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 235, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 158 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 236, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 159 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 237, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 160 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 238, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 161 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 239, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 162 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 240, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 163 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 241, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 164 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 242, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 165 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 243, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 166 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 244, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 167 - DEFAULT => -32 - }, - {#State 168 - ACTIONS => { - 'CMPOP' => 164, - "?" => 158, - ";" => 245, - "+" => 157, - 'MOD' => 165, - 'DIV' => 159, - "/" => 166, - 'AND' => 160, - 'CAT' => 163, - 'BINOP' => 161, - 'OR' => 162 - } - }, - {#State 169 - ACTIONS => { - "\$" => 43, - 'COMMA' => 171, - 'LITERAL' => 75, - 'IDENT' => 2, - "\${" => 37 - }, - DEFAULT => -31, - GOTOS => { - 'item' => 39, - 'assign' => 170, - 'node' => 23, - 'ident' => 74 - } - }, - {#State 170 - DEFAULT => -147 - }, - {#State 171 - DEFAULT => -148 - }, - {#State 172 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 246, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 173 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 247, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 174 - ACTIONS => { - 'FILENAME' => 83, - 'IDENT' => 81, - 'NUMBER' => 84 - }, - GOTOS => { - 'filepart' => 248 - } - }, - {#State 175 - ACTIONS => { - 'DOT' => 104 - }, - DEFAULT => -156, - GOTOS => { - 'args' => 249 - } - }, - {#State 176 - ACTIONS => { - "\"" => 250, - 'TEXT' => 231, - ";" => 233, - "\$" => 43, - 'IDENT' => 2, - "\${" => 37 - }, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'ident' => 230, - 'quotable' => 232 - } - }, - {#State 177 - ACTIONS => { - "\"" => 89, - 'LITERAL' => 88, - 'FILENAME' => 83, - 'IDENT' => 81, - 'NUMBER' => 84 - }, - GOTOS => { - 'filepart' => 87, - 'filename' => 85, - 'name' => 251 - } - }, - {#State 178 - DEFAULT => -156, - GOTOS => { - 'args' => 252 - } - }, - {#State 179 - ACTIONS => { - "{" => 30, - 'COMMA' => 258, - 'LITERAL' => 256, - 'IDENT' => 2, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - DEFAULT => -163, - GOTOS => { - 'sterm' => 68, - 'item' => 254, - 'param' => 255, - 'node' => 23, - 'ident' => 253, - 'term' => 257, - 'lterm' => 56 - } - }, - {#State 180 - DEFAULT => -105 - }, - {#State 181 - DEFAULT => -114 - }, - {#State 182 - DEFAULT => -115 - }, - {#State 183 - DEFAULT => -106 - }, - {#State 184 - ACTIONS => { - "\"" => 60, - "\$" => 43, - 'LITERAL' => 78, - 'IDENT' => 2, - 'REF' => 27, - 'NUMBER' => 26, - "\${" => 37 - }, - GOTOS => { - 'sterm' => 259, - 'item' => 39, - 'node' => 23, - 'ident' => 77 - } - }, - {#State 185 - ACTIONS => { - 'FINAL' => 260, - 'CATCH' => 262 - }, - DEFAULT => -72, - GOTOS => { - 'final' => 261 - } - }, - {#State 186 - ACTIONS => { - 'TEXT' => 263 - } - }, - {#State 187 - ACTIONS => { - "\"" => 266, - 'LITERAL' => 265, - 'NUMBER' => 264 - } - }, - {#State 188 - DEFAULT => -97 - }, - {#State 189 - DEFAULT => -98 - }, - {#State 190 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'template' => 267, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 72, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 191 - DEFAULT => -125 - }, - {#State 192 - DEFAULT => -126 - }, - {#State 193 - ACTIONS => { - ";" => 268 - } - }, - {#State 194 - DEFAULT => -89 - }, - {#State 195 - ACTIONS => { - ";" => -150, - "+" => 157, - 'LITERAL' => -150, - 'IDENT' => -150, - 'CAT' => 163, - "\$" => -150, - 'CMPOP' => 164, - "?" => 158, - 'DIV' => 159, - 'MOD' => 165, - 'COMMA' => -150, - "/" => 166, - 'AND' => 160, - 'BINOP' => 161, - 'OR' => 162, - "\${" => -150 - }, - DEFAULT => -26 - }, - {#State 196 - DEFAULT => -92 - }, - {#State 197 - DEFAULT => -91 - }, - {#State 198 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 57, - 'IDENT' => 269, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'sterm' => 68, - 'item' => 39, - 'margs' => 270, - 'node' => 23, - 'ident' => 149, - 'term' => 58, - 'expr' => 151, - 'assign' => 150, - 'lterm' => 56 - } - }, - {#State 199 - ACTIONS => { - "+" => 157, - 'CAT' => 163, - 'CMPOP' => 164, - "?" => 158, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'AND' => 160, - 'BINOP' => 161, - 'OR' => 162 - }, - DEFAULT => -26 - }, - {#State 200 - ACTIONS => { - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 271, - 'lterm' => 56 - } - }, - {#State 201 - ACTIONS => { - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 272, - 'lterm' => 56 - } - }, - {#State 202 - ACTIONS => { - "{" => 30, - 'COMMA' => 258, - 'LITERAL' => 256, - 'IDENT' => 2, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - DEFAULT => -64, - GOTOS => { - 'sterm' => 68, - 'item' => 254, - 'param' => 255, - 'node' => 23, - 'ident' => 253, - 'term' => 257, - 'lterm' => 56 - } - }, - {#State 203 - DEFAULT => -56, - GOTOS => { - '@1-3' => 273 - } - }, - {#State 204 - ACTIONS => { - "\"" => 89, - "\$" => 86, - 'LITERAL' => 88, - 'FILENAME' => 83, - 'IDENT' => 81, - 'NUMBER' => 84 - }, - GOTOS => { - 'filepart' => 87, - 'names' => 91, - 'nameargs' => 274, - 'filename' => 85, - 'name' => 82 - } - }, - {#State 205 - ACTIONS => { - 'ASSIGN' => -132 - }, - DEFAULT => -130 - }, - {#State 206 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 275, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 207 - ACTIONS => { - "\"" => 276, - 'TEXT' => 231, - ";" => 233, - "\$" => 43, - 'IDENT' => 2, - "\${" => 37 - }, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'ident' => 230, - 'quotable' => 232 - } - }, - {#State 208 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 277, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 209 - DEFAULT => -108 - }, - {#State 210 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 278, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 211 - DEFAULT => -120 - }, - {#State 212 - DEFAULT => -121 - }, - {#State 213 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 279, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 214 - DEFAULT => -74, - GOTOS => { - '@3-3' => 280 - } - }, - {#State 215 - DEFAULT => -131 - }, - {#State 216 - ACTIONS => { - "{" => 30, - 'COMMA' => 258, - 'LITERAL' => 256, - 'IDENT' => 2, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - ")" => 281, - "\${" => 37 - }, - GOTOS => { - 'sterm' => 68, - 'item' => 254, - 'param' => 255, - 'node' => 23, - 'ident' => 253, - 'term' => 257, - 'lterm' => 56 - } - }, - {#State 217 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 282, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 218 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 283, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 219 - ACTIONS => { - 'CMPOP' => 164, - "?" => 158, - "+" => 157, - 'MOD' => 165, - 'DIV' => 159, - "/" => 166, - 'AND' => 160, - 'CAT' => 163, - 'BINOP' => 161, - 'OR' => 162 - }, - DEFAULT => -47 - }, - {#State 220 - DEFAULT => -58 - }, - {#State 221 - DEFAULT => -81 - }, - {#State 222 - ACTIONS => { - 'CMPOP' => 164, - "?" => 158, - "+" => 157, - 'MOD' => 165, - 'DIV' => 159, - "/" => 166, - 'AND' => 160, - 'CAT' => 163, - 'BINOP' => 161, - 'OR' => 162 - }, - DEFAULT => -45 - }, - {#State 223 - DEFAULT => -66 - }, - {#State 224 - ACTIONS => { - 'CMPOP' => 164, - "?" => 158, - "+" => 157, - 'MOD' => 165, - 'DIV' => 159, - "/" => 166, - 'AND' => 160, - 'CAT' => 163, - 'BINOP' => 161, - 'OR' => 162 - }, - DEFAULT => -61 - }, - {#State 225 - DEFAULT => -144 - }, - {#State 226 - DEFAULT => -145 - }, - {#State 227 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 284, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 228 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 285, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 229 - ACTIONS => { - "+" => 157, - 'CAT' => 163, - 'CMPOP' => 164, - "?" => 158, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'AND' => 160, - 'BINOP' => 161, - 'OR' => 162 - }, - DEFAULT => -151 - }, - {#State 230 - ACTIONS => { - 'DOT' => 104 - }, - DEFAULT => -177 - }, - {#State 231 - DEFAULT => -178 - }, - {#State 232 - DEFAULT => -175 - }, - {#State 233 - DEFAULT => -179 - }, - {#State 234 - DEFAULT => -111 - }, - {#State 235 - ACTIONS => { - 'DIV' => 159, - 'MOD' => 165, - "/" => 166 - }, - DEFAULT => -135 - }, - {#State 236 - ACTIONS => { - ":" => 286, - 'CMPOP' => 164, - "?" => 158, - "+" => 157, - 'MOD' => 165, - 'DIV' => 159, - "/" => 166, - 'AND' => 160, - 'CAT' => 163, - 'BINOP' => 161, - 'OR' => 162 - } - }, - {#State 237 - ACTIONS => { - 'MOD' => 165 - }, - DEFAULT => -136 - }, - {#State 238 - ACTIONS => { - "+" => 157, - 'CAT' => 163, - 'CMPOP' => 164, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'BINOP' => 161 - }, - DEFAULT => -140 - }, - {#State 239 - ACTIONS => { - "+" => 157, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166 - }, - DEFAULT => -133 - }, - {#State 240 - ACTIONS => { - "+" => 157, - 'CAT' => 163, - 'CMPOP' => 164, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'BINOP' => 161 - }, - DEFAULT => -141 - }, - {#State 241 - ACTIONS => { - "+" => 157, - 'CMPOP' => 164, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'BINOP' => 161 - }, - DEFAULT => -139 - }, - {#State 242 - ACTIONS => { - "+" => 157, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'BINOP' => 161 - }, - DEFAULT => -138 - }, - {#State 243 - DEFAULT => -137 - }, - {#State 244 - ACTIONS => { - 'DIV' => 159, - 'MOD' => 165 - }, - DEFAULT => -134 - }, - {#State 245 - DEFAULT => -59, - GOTOS => { - '@2-3' => 287 - } - }, - {#State 246 - ACTIONS => { - "+" => 157, - 'CAT' => 163, - 'CMPOP' => 164, - "?" => 158, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'AND' => 160, - 'BINOP' => 161, - 'OR' => 162 - }, - DEFAULT => -150 - }, - {#State 247 - ACTIONS => { - 'ELSIF' => 290, - 'ELSE' => 288 - }, - DEFAULT => -50, - GOTOS => { - 'else' => 289 - } - }, - {#State 248 - DEFAULT => -170 - }, - {#State 249 - ACTIONS => { - "{" => 30, - 'COMMA' => 258, - 'LITERAL' => 256, - 'IDENT' => 2, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - DEFAULT => -162, - GOTOS => { - 'sterm' => 68, - 'item' => 254, - 'param' => 255, - 'node' => 23, - 'ident' => 253, - 'term' => 257, - 'lterm' => 56 - } - }, - {#State 250 - DEFAULT => -167 - }, - {#State 251 - DEFAULT => -165 - }, - {#State 252 - ACTIONS => { - "{" => 30, - 'COMMA' => 258, - 'LITERAL' => 256, - 'IDENT' => 2, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - ")" => 291, - "\${" => 37 - }, - GOTOS => { - 'sterm' => 68, - 'item' => 254, - 'param' => 255, - 'node' => 23, - 'ident' => 253, - 'term' => 257, - 'lterm' => 56 - } - }, - {#State 253 - ACTIONS => { - 'DOT' => 104, - 'ASSIGN' => 292 - }, - DEFAULT => -109 - }, - {#State 254 - ACTIONS => { - "(" => 135, - 'ASSIGN' => 210 - }, - DEFAULT => -128 - }, - {#State 255 - DEFAULT => -153 - }, - {#State 256 - ACTIONS => { - 'ASSIGN' => 213 - }, - DEFAULT => -112 - }, - {#State 257 - DEFAULT => -152 - }, - {#State 258 - DEFAULT => -155 - }, - {#State 259 - DEFAULT => -117 - }, - {#State 260 - ACTIONS => { - ";" => 293 - } - }, - {#State 261 - ACTIONS => { - 'END' => 294 - } - }, - {#State 262 - ACTIONS => { - ";" => 296, - 'DEFAULT' => 297, - 'FILENAME' => 83, - 'IDENT' => 81, - 'NUMBER' => 84 - }, - GOTOS => { - 'filepart' => 87, - 'filename' => 295 - } - }, - {#State 263 - ACTIONS => { - 'END' => 298 - } - }, - {#State 264 - DEFAULT => -102 - }, - {#State 265 - DEFAULT => -100 - }, - {#State 266 - ACTIONS => { - 'TEXT' => 299 - } - }, - {#State 267 - ACTIONS => { - 'END' => 300 - } - }, - {#State 268 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 301, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 269 - ACTIONS => { - 'COMMA' => -96, - 'IDENT' => -96, - ")" => -96 - }, - DEFAULT => -130 - }, - {#State 270 - ACTIONS => { - 'COMMA' => 304, - 'IDENT' => 302, - ")" => 303 - } - }, - {#State 271 - DEFAULT => -156, - GOTOS => { - 'args' => 305 - } - }, - {#State 272 - DEFAULT => -156, - GOTOS => { - 'args' => 306 - } - }, - {#State 273 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 307, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 274 - DEFAULT => -157 - }, - {#State 275 - ACTIONS => { - 'END' => 308 - } - }, - {#State 276 - ACTIONS => { - 'ASSIGN' => -160 - }, - DEFAULT => -167 - }, - {#State 277 - ACTIONS => { - 'END' => 309 - } - }, - {#State 278 - ACTIONS => { - "+" => 157, - 'CAT' => 163, - 'CMPOP' => 164, - "?" => 158, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'AND' => 160, - 'BINOP' => 161, - 'OR' => 162 - }, - DEFAULT => -124 - }, - {#State 279 - ACTIONS => { - "+" => 157, - 'CAT' => 163, - 'CMPOP' => 164, - "?" => 158, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'AND' => 160, - 'BINOP' => 161, - 'OR' => 162 - }, - DEFAULT => -123 - }, - {#State 280 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 310, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 281 - DEFAULT => -129 - }, - {#State 282 - ACTIONS => { - 'END' => 311 - } - }, - {#State 283 - ACTIONS => { - 'ELSIF' => 290, - 'ELSE' => 288 - }, - DEFAULT => -50, - GOTOS => { - 'else' => 312 - } - }, - {#State 284 - ACTIONS => { - 'CASE' => 313 - }, - DEFAULT => -55, - GOTOS => { - 'case' => 314 - } - }, - {#State 285 - ACTIONS => { - 'END' => 315 - } - }, - {#State 286 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 316, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 287 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 317, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 288 - ACTIONS => { - ";" => 318 - } - }, - {#State 289 - ACTIONS => { - 'END' => 319 - } - }, - {#State 290 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 320, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 291 - DEFAULT => -164 - }, - {#State 292 - ACTIONS => { - 'NOT' => 38, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "(" => 53, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'expr' => 321, - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 58, - 'lterm' => 56 - } - }, - {#State 293 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 322, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 294 - DEFAULT => -67 - }, - {#State 295 - ACTIONS => { - 'DOT' => 174, - ";" => 323 - } - }, - {#State 296 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 324, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 297 - ACTIONS => { - ";" => 325 - } - }, - {#State 298 - DEFAULT => -79 - }, - {#State 299 - ACTIONS => { - "\"" => 326 - } - }, - {#State 300 - DEFAULT => -82 - }, - {#State 301 - ACTIONS => { - 'END' => 327 - } - }, - {#State 302 - DEFAULT => -94 - }, - {#State 303 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'WRAPPER' => 55, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - "\"" => 60, - 'PROCESS' => 61, - 'FILTER' => 25, - 'RETURN' => 64, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 193, - 'DEFAULT' => 69, - "{" => 30, - "\${" => 37 - }, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'term' => 58, - 'loop' => 4, - 'expr' => 199, - 'wrapper' => 46, - 'atomexpr' => 48, - 'atomdir' => 12, - 'mdir' => 328, - 'sterm' => 68, - 'filter' => 29, - 'ident' => 149, - 'perl' => 31, - 'setlist' => 70, - 'switch' => 34, - 'try' => 35, - 'assign' => 19, - 'directive' => 196, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 304 - DEFAULT => -95 - }, - {#State 305 - ACTIONS => { - "{" => 30, - 'COMMA' => 258, - 'LITERAL' => 256, - 'IDENT' => 2, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - DEFAULT => -62, - GOTOS => { - 'sterm' => 68, - 'item' => 254, - 'param' => 255, - 'node' => 23, - 'ident' => 253, - 'term' => 257, - 'lterm' => 56 - } - }, - {#State 306 - ACTIONS => { - "{" => 30, - 'COMMA' => 258, - 'LITERAL' => 256, - 'IDENT' => 2, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - DEFAULT => -63, - GOTOS => { - 'sterm' => 68, - 'item' => 254, - 'param' => 255, - 'node' => 23, - 'ident' => 253, - 'term' => 257, - 'lterm' => 56 - } - }, - {#State 307 - ACTIONS => { - 'END' => 329 - } - }, - {#State 308 - DEFAULT => -80 - }, - {#State 309 - DEFAULT => -88 - }, - {#State 310 - ACTIONS => { - 'END' => 330 - } - }, - {#State 311 - DEFAULT => -77 - }, - {#State 312 - ACTIONS => { - 'END' => 331 - } - }, - {#State 313 - ACTIONS => { - ";" => 332, - 'DEFAULT' => 334, - "{" => 30, - 'LITERAL' => 78, - 'IDENT' => 2, - "\"" => 60, - "\$" => 43, - "[" => 9, - 'NUMBER' => 26, - 'REF' => 27, - "\${" => 37 - }, - GOTOS => { - 'sterm' => 68, - 'item' => 39, - 'node' => 23, - 'ident' => 77, - 'term' => 333, - 'lterm' => 56 - } - }, - {#State 314 - ACTIONS => { - 'END' => 335 - } - }, - {#State 315 - DEFAULT => -65 - }, - {#State 316 - ACTIONS => { - "+" => 157, - 'CAT' => 163, - 'CMPOP' => 164, - "?" => 158, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'AND' => 160, - 'BINOP' => 161, - 'OR' => 162 - }, - DEFAULT => -143 - }, - {#State 317 - ACTIONS => { - 'END' => 336 - } - }, - {#State 318 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 337, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 319 - DEFAULT => -46 - }, - {#State 320 - ACTIONS => { - 'CMPOP' => 164, - "?" => 158, - ";" => 338, - "+" => 157, - 'MOD' => 165, - 'DIV' => 159, - "/" => 166, - 'AND' => 160, - 'CAT' => 163, - 'BINOP' => 161, - 'OR' => 162 - } - }, - {#State 321 - ACTIONS => { - "+" => 157, - 'CAT' => 163, - 'CMPOP' => 164, - "?" => 158, - 'DIV' => 159, - 'MOD' => 165, - "/" => 166, - 'AND' => 160, - 'BINOP' => 161, - 'OR' => 162 - }, - DEFAULT => -154 - }, - {#State 322 - DEFAULT => -71 - }, - {#State 323 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 339, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 324 - ACTIONS => { - 'FINAL' => 260, - 'CATCH' => 262 - }, - DEFAULT => -72, - GOTOS => { - 'final' => 340 - } - }, - {#State 325 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 341, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 326 - DEFAULT => -101 - }, - {#State 327 - DEFAULT => -93 - }, - {#State 328 - DEFAULT => -90 - }, - {#State 329 - DEFAULT => -57 - }, - {#State 330 - DEFAULT => -75 - }, - {#State 331 - DEFAULT => -44 - }, - {#State 332 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 342, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 333 - ACTIONS => { - ";" => 343 - } - }, - {#State 334 - ACTIONS => { - ";" => 344 - } - }, - {#State 335 - DEFAULT => -51 - }, - {#State 336 - DEFAULT => -60 - }, - {#State 337 - DEFAULT => -49 - }, - {#State 338 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 345, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 339 - ACTIONS => { - 'FINAL' => 260, - 'CATCH' => 262 - }, - DEFAULT => -72, - GOTOS => { - 'final' => 346 - } - }, - {#State 340 - DEFAULT => -70 - }, - {#State 341 - ACTIONS => { - 'FINAL' => 260, - 'CATCH' => 262 - }, - DEFAULT => -72, - GOTOS => { - 'final' => 347 - } - }, - {#State 342 - DEFAULT => -54 - }, - {#State 343 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 348, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 344 - ACTIONS => { - 'SET' => 1, - 'PERL' => 40, - 'NOT' => 38, - 'IDENT' => 2, - 'CLEAR' => 41, - 'UNLESS' => 3, - 'IF' => 44, - "\$" => 43, - 'STOP' => 6, - 'CALL' => 45, - 'THROW' => 8, - 'GET' => 47, - "[" => 9, - 'TRY' => 10, - 'LAST' => 49, - 'DEBUG' => 51, - 'RAWPERL' => 13, - 'META' => 15, - 'INCLUDE' => 17, - "(" => 53, - 'SWITCH' => 54, - 'MACRO' => 18, - 'WRAPPER' => 55, - ";" => -18, - 'FOR' => 21, - 'NEXT' => 22, - 'LITERAL' => 57, - 'TEXT' => 24, - "\"" => 60, - 'PROCESS' => 61, - 'RETURN' => 64, - 'FILTER' => 25, - 'INSERT' => 65, - 'NUMBER' => 26, - 'REF' => 27, - 'WHILE' => 67, - 'BLOCK' => 28, - 'DEFAULT' => 69, - "{" => 30, - 'USE' => 32, - 'VIEW' => 36, - "\${" => 37 - }, - DEFAULT => -3, - GOTOS => { - 'item' => 39, - 'node' => 23, - 'rawperl' => 59, - 'term' => 58, - 'loop' => 4, - 'use' => 63, - 'expr' => 62, - 'capture' => 42, - 'statement' => 5, - 'view' => 7, - 'wrapper' => 46, - 'atomexpr' => 48, - 'chunk' => 11, - 'defblock' => 66, - 'atomdir' => 12, - 'anonblock' => 50, - 'sterm' => 68, - 'defblockname' => 14, - 'filter' => 29, - 'ident' => 16, - 'perl' => 31, - 'setlist' => 70, - 'chunks' => 33, - 'try' => 35, - 'switch' => 34, - 'assign' => 19, - 'block' => 349, - 'directive' => 71, - 'macro' => 20, - 'condition' => 73, - 'lterm' => 56 - } - }, - {#State 345 - ACTIONS => { - 'ELSIF' => 290, - 'ELSE' => 288 - }, - DEFAULT => -50, - GOTOS => { - 'else' => 350 - } - }, - {#State 346 - DEFAULT => -68 - }, - {#State 347 - DEFAULT => -69 - }, - {#State 348 - ACTIONS => { - 'CASE' => 313 - }, - DEFAULT => -55, - GOTOS => { - 'case' => 351 - } - }, - {#State 349 - DEFAULT => -53 - }, - {#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]->{ INFOR } || $_[0]->{ INWHILE } - ? 'last LOOP;' - : 'last;' } - ], - [#Rule 40 - 'atomdir', 1, -sub -#line 127 "Parser.yp" -{ $_[0]->{ INFOR } - ? $factory->next() - : ($_[0]->{ INWHILE } - ? 'next LOOP;' - : 'next;') } - ], - [#Rule 41 - 'atomdir', 2, -sub -#line 132 "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 145 "Parser.yp" -{ $factory->if(@_[2, 4, 5]) } - ], - [#Rule 45 - 'condition', 3, -sub -#line 146 "Parser.yp" -{ $factory->if(@_[3, 1]) } - ], - [#Rule 46 - 'condition', 6, -sub -#line 148 "Parser.yp" -{ $factory->if("!($_[2])", @_[4, 5]) } - ], - [#Rule 47 - 'condition', 3, -sub -#line 149 "Parser.yp" -{ $factory->if("!($_[3])", $_[1]) } - ], - [#Rule 48 - 'else', 5, -sub -#line 153 "Parser.yp" -{ unshift(@{$_[5]}, [ @_[2, 4] ]); - $_[5]; } - ], - [#Rule 49 - 'else', 3, -sub -#line 155 "Parser.yp" -{ [ $_[3] ] } - ], - [#Rule 50 - 'else', 0, -sub -#line 156 "Parser.yp" -{ [ undef ] } - ], - [#Rule 51 - 'switch', 6, -sub -#line 160 "Parser.yp" -{ $factory->switch(@_[2, 5]) } - ], - [#Rule 52 - 'case', 5, -sub -#line 164 "Parser.yp" -{ unshift(@{$_[5]}, [ @_[2, 4] ]); - $_[5]; } - ], - [#Rule 53 - 'case', 4, -sub -#line 166 "Parser.yp" -{ [ $_[4] ] } - ], - [#Rule 54 - 'case', 3, -sub -#line 167 "Parser.yp" -{ [ $_[3] ] } - ], - [#Rule 55 - 'case', 0, -sub -#line 168 "Parser.yp" -{ [ undef ] } - ], - [#Rule 56 - '@1-3', 0, -sub -#line 171 "Parser.yp" -{ $_[0]->{ INFOR }++ } - ], - [#Rule 57 - 'loop', 6, -sub -#line 172 "Parser.yp" -{ $_[0]->{ INFOR }--; - $factory->foreach(@{$_[2]}, $_[5]) } - ], - [#Rule 58 - 'loop', 3, -sub -#line 176 "Parser.yp" -{ $factory->foreach(@{$_[3]}, $_[1]) } - ], - [#Rule 59 - '@2-3', 0, -sub -#line 177 "Parser.yp" -{ $_[0]->{ INWHILE }++ } - ], - [#Rule 60 - 'loop', 6, -sub -#line 178 "Parser.yp" -{ $_[0]->{ INWHILE }--; - $factory->while(@_[2, 5]) } - ], - [#Rule 61 - 'loop', 3, -sub -#line 180 "Parser.yp" -{ $factory->while(@_[3, 1]) } - ], - [#Rule 62 - 'loopvar', 4, -sub -#line 183 "Parser.yp" -{ [ @_[1, 3, 4] ] } - ], - [#Rule 63 - 'loopvar', 4, -sub -#line 184 "Parser.yp" -{ [ @_[1, 3, 4] ] } - ], - [#Rule 64 - 'loopvar', 2, -sub -#line 185 "Parser.yp" -{ [ 0, @_[1, 2] ] } - ], - [#Rule 65 - 'wrapper', 5, -sub -#line 189 "Parser.yp" -{ $factory->wrapper(@_[2, 4]) } - ], - [#Rule 66 - 'wrapper', 3, -sub -#line 191 "Parser.yp" -{ $factory->wrapper(@_[3, 1]) } - ], - [#Rule 67 - 'try', 5, -sub -#line 195 "Parser.yp" -{ $factory->try(@_[3, 4]) } - ], - [#Rule 68 - 'final', 5, -sub -#line 199 "Parser.yp" -{ unshift(@{$_[5]}, [ @_[2,4] ]); - $_[5]; } - ], - [#Rule 69 - 'final', 5, -sub -#line 202 "Parser.yp" -{ unshift(@{$_[5]}, [ undef, $_[4] ]); - $_[5]; } - ], - [#Rule 70 - 'final', 4, -sub -#line 205 "Parser.yp" -{ unshift(@{$_[4]}, [ undef, $_[3] ]); - $_[4]; } - ], - [#Rule 71 - 'final', 3, -sub -#line 207 "Parser.yp" -{ [ $_[3] ] } - ], - [#Rule 72 - 'final', 0, -sub -#line 208 "Parser.yp" -{ [ 0 ] } - ], - [#Rule 73 - 'use', 2, -sub -#line 211 "Parser.yp" -{ $factory->use($_[2]) } - ], - [#Rule 74 - '@3-3', 0, -sub -#line 214 "Parser.yp" -{ $_[0]->push_defblock(); } - ], - [#Rule 75 - 'view', 6, -sub -#line 215 "Parser.yp" -{ $factory->view(@_[2,5], - $_[0]->pop_defblock) } - ], - [#Rule 76 - '@4-2', 0, -sub -#line 219 "Parser.yp" -{ ${$_[0]->{ INPERL }}++; } - ], - [#Rule 77 - 'perl', 5, -sub -#line 220 "Parser.yp" -{ ${$_[0]->{ INPERL }}--; - $_[0]->{ EVAL_PERL } - ? $factory->perl($_[4]) - : $factory->no_perl(); } - ], - [#Rule 78 - '@5-1', 0, -sub -#line 226 "Parser.yp" -{ ${$_[0]->{ INPERL }}++; - $rawstart = ${$_[0]->{'LINE'}}; } - ], - [#Rule 79 - 'rawperl', 5, -sub -#line 228 "Parser.yp" -{ ${$_[0]->{ INPERL }}--; - $_[0]->{ EVAL_PERL } - ? $factory->rawperl($_[4], $rawstart) - : $factory->no_perl(); } - ], - [#Rule 80 - 'filter', 5, -sub -#line 235 "Parser.yp" -{ $factory->filter(@_[2,4]) } - ], - [#Rule 81 - 'filter', 3, -sub -#line 237 "Parser.yp" -{ $factory->filter(@_[3,1]) } - ], - [#Rule 82 - 'defblock', 5, -sub -#line 242 "Parser.yp" -{ my $name = join('/', @{ $_[0]->{ DEFBLOCKS } }); - pop(@{ $_[0]->{ DEFBLOCKS } }); - $_[0]->define_block($name, $_[4]); - undef - } - ], - [#Rule 83 - 'defblockname', 2, -sub -#line 249 "Parser.yp" -{ push(@{ $_[0]->{ DEFBLOCKS } }, $_[2]); - $_[2]; - } - ], - [#Rule 84 - 'blockname', 1, undef - ], - [#Rule 85 - 'blockname', 1, -sub -#line 255 "Parser.yp" -{ $_[1] =~ s/^'(.*)'$/$1/; $_[1] } - ], - [#Rule 86 - 'blockargs', 1, undef - ], - [#Rule 87 - 'blockargs', 0, undef - ], - [#Rule 88 - 'anonblock', 5, -sub -#line 263 "Parser.yp" -{ local $" = ', '; - print STDERR "experimental block args: [@{ $_[2] }]\n" - if $_[2]; - $factory->anon_block($_[4]) } - ], - [#Rule 89 - 'capture', 3, -sub -#line 269 "Parser.yp" -{ $factory->capture(@_[1, 3]) } - ], - [#Rule 90 - 'macro', 6, -sub -#line 273 "Parser.yp" -{ $factory->macro(@_[2, 6, 4]) } - ], - [#Rule 91 - 'macro', 3, -sub -#line 274 "Parser.yp" -{ $factory->macro(@_[2, 3]) } - ], - [#Rule 92 - 'mdir', 1, undef - ], - [#Rule 93 - 'mdir', 4, -sub -#line 278 "Parser.yp" -{ $_[3] } - ], - [#Rule 94 - 'margs', 2, -sub -#line 281 "Parser.yp" -{ push(@{$_[1]}, $_[2]); $_[1] } - ], - [#Rule 95 - 'margs', 2, -sub -#line 282 "Parser.yp" -{ $_[1] } - ], - [#Rule 96 - 'margs', 1, -sub -#line 283 "Parser.yp" -{ [ $_[1] ] } - ], - [#Rule 97 - 'metadata', 2, -sub -#line 286 "Parser.yp" -{ push(@{$_[1]}, @{$_[2]}); $_[1] } - ], - [#Rule 98 - 'metadata', 2, undef - ], - [#Rule 99 - 'metadata', 1, undef - ], - [#Rule 100 - 'meta', 3, -sub -#line 291 "Parser.yp" -{ for ($_[3]) { s/^'//; s/'$//; - s/\\'/'/g }; - [ @_[1,3] ] } - ], - [#Rule 101 - 'meta', 5, -sub -#line 294 "Parser.yp" -{ [ @_[1,4] ] } - ], - [#Rule 102 - 'meta', 3, -sub -#line 295 "Parser.yp" -{ [ @_[1,3] ] } - ], - [#Rule 103 - 'term', 1, undef - ], - [#Rule 104 - 'term', 1, undef - ], - [#Rule 105 - 'lterm', 3, -sub -#line 307 "Parser.yp" -{ "[ $_[2] ]" } - ], - [#Rule 106 - 'lterm', 3, -sub -#line 308 "Parser.yp" -{ "[ $_[2] ]" } - ], - [#Rule 107 - 'lterm', 2, -sub -#line 309 "Parser.yp" -{ "[ ]" } - ], - [#Rule 108 - 'lterm', 3, -sub -#line 310 "Parser.yp" -{ "{ $_[2] }" } - ], - [#Rule 109 - 'sterm', 1, -sub -#line 313 "Parser.yp" -{ $factory->ident($_[1]) } - ], - [#Rule 110 - 'sterm', 2, -sub -#line 314 "Parser.yp" -{ $factory->identref($_[2]) } - ], - [#Rule 111 - 'sterm', 3, -sub -#line 315 "Parser.yp" -{ $factory->quoted($_[2]) } - ], - [#Rule 112 - 'sterm', 1, undef - ], - [#Rule 113 - 'sterm', 1, undef - ], - [#Rule 114 - 'list', 2, -sub -#line 320 "Parser.yp" -{ "$_[1], $_[2]" } - ], - [#Rule 115 - 'list', 2, undef - ], - [#Rule 116 - 'list', 1, undef - ], - [#Rule 117 - 'range', 3, -sub -#line 325 "Parser.yp" -{ $_[1] . '..' . $_[3] } - ], - [#Rule 118 - 'hash', 1, undef - ], - [#Rule 119 - 'hash', 0, -sub -#line 330 "Parser.yp" -{ "" } - ], - [#Rule 120 - 'params', 2, -sub -#line 333 "Parser.yp" -{ "$_[1], $_[2]" } - ], - [#Rule 121 - 'params', 2, undef - ], - [#Rule 122 - 'params', 1, undef - ], - [#Rule 123 - 'param', 3, -sub -#line 338 "Parser.yp" -{ "$_[1] => $_[3]" } - ], - [#Rule 124 - 'param', 3, -sub -#line 339 "Parser.yp" -{ "$_[1] => $_[3]" } - ], - [#Rule 125 - 'ident', 3, -sub -#line 342 "Parser.yp" -{ push(@{$_[1]}, @{$_[3]}); $_[1] } - ], - [#Rule 126 - 'ident', 3, -sub -#line 343 "Parser.yp" -{ push(@{$_[1]}, - map {($_, 0)} split(/\./, $_[3])); - $_[1]; } - ], - [#Rule 127 - 'ident', 1, undef - ], - [#Rule 128 - 'node', 1, -sub -#line 349 "Parser.yp" -{ [ $_[1], 0 ] } - ], - [#Rule 129 - 'node', 4, -sub -#line 350 "Parser.yp" -{ [ $_[1], $factory->args($_[3]) ] } - ], - [#Rule 130 - 'item', 1, -sub -#line 353 "Parser.yp" -{ "'$_[1]'" } - ], - [#Rule 131 - 'item', 3, -sub -#line 354 "Parser.yp" -{ $_[2] } - ], - [#Rule 132 - 'item', 2, -sub -#line 355 "Parser.yp" -{ $_[0]->{ V1DOLLAR } - ? "'$_[2]'" - : $factory->ident(["'$_[2]'", 0]) } - ], - [#Rule 133 - 'expr', 3, -sub -#line 360 "Parser.yp" -{ "$_[1] $_[2] $_[3]" } - ], - [#Rule 134 - 'expr', 3, -sub -#line 361 "Parser.yp" -{ "$_[1] $_[2] $_[3]" } - ], - [#Rule 135 - 'expr', 3, -sub -#line 362 "Parser.yp" -{ "$_[1] $_[2] $_[3]" } - ], - [#Rule 136 - 'expr', 3, -sub -#line 363 "Parser.yp" -{ "int($_[1] / $_[3])" } - ], - [#Rule 137 - 'expr', 3, -sub -#line 364 "Parser.yp" -{ "$_[1] % $_[3]" } - ], - [#Rule 138 - 'expr', 3, -sub -#line 365 "Parser.yp" -{ "$_[1] $CMPOP{ $_[2] } $_[3]" } - ], - [#Rule 139 - 'expr', 3, -sub -#line 366 "Parser.yp" -{ "$_[1] . $_[3]" } - ], - [#Rule 140 - 'expr', 3, -sub -#line 367 "Parser.yp" -{ "$_[1] && $_[3]" } - ], - [#Rule 141 - 'expr', 3, -sub -#line 368 "Parser.yp" -{ "$_[1] || $_[3]" } - ], - [#Rule 142 - 'expr', 2, -sub -#line 369 "Parser.yp" -{ "! $_[2]" } - ], - [#Rule 143 - 'expr', 5, -sub -#line 370 "Parser.yp" -{ "$_[1] ? $_[3] : $_[5]" } - ], - [#Rule 144 - 'expr', 3, -sub -#line 371 "Parser.yp" -{ $factory->assign(@{$_[2]}) } - ], - [#Rule 145 - 'expr', 3, -sub -#line 372 "Parser.yp" -{ "($_[2])" } - ], - [#Rule 146 - 'expr', 1, undef - ], - [#Rule 147 - 'setlist', 2, -sub -#line 376 "Parser.yp" -{ push(@{$_[1]}, @{$_[2]}); $_[1] } - ], - [#Rule 148 - 'setlist', 2, undef - ], - [#Rule 149 - 'setlist', 1, undef - ], - [#Rule 150 - 'assign', 3, -sub -#line 382 "Parser.yp" -{ [ $_[1], $_[3] ] } - ], - [#Rule 151 - 'assign', 3, -sub -#line 383 "Parser.yp" -{ [ @_[1,3] ] } - ], - [#Rule 152 - 'args', 2, -sub -#line 390 "Parser.yp" -{ push(@{$_[1]}, $_[2]); $_[1] } - ], - [#Rule 153 - 'args', 2, -sub -#line 391 "Parser.yp" -{ push(@{$_[1]->[0]}, $_[2]); $_[1] } - ], - [#Rule 154 - 'args', 4, -sub -#line 392 "Parser.yp" -{ push(@{$_[1]->[0]}, "'', " . - $factory->assign(@_[2,4])); $_[1] } - ], - [#Rule 155 - 'args', 2, -sub -#line 394 "Parser.yp" -{ $_[1] } - ], - [#Rule 156 - 'args', 0, -sub -#line 395 "Parser.yp" -{ [ [ ] ] } - ], - [#Rule 157 - 'lnameargs', 3, -sub -#line 405 "Parser.yp" -{ push(@{$_[3]}, $_[1]); $_[3] } - ], - [#Rule 158 - 'lnameargs', 1, undef - ], - [#Rule 159 - 'lvalue', 1, undef - ], - [#Rule 160 - 'lvalue', 3, -sub -#line 410 "Parser.yp" -{ $factory->quoted($_[2]) } - ], - [#Rule 161 - 'lvalue', 1, undef - ], - [#Rule 162 - 'nameargs', 3, -sub -#line 414 "Parser.yp" -{ [ [$factory->ident($_[2])], $_[3] ] } - ], - [#Rule 163 - 'nameargs', 2, -sub -#line 415 "Parser.yp" -{ [ @_[1,2] ] } - ], - [#Rule 164 - 'nameargs', 4, -sub -#line 416 "Parser.yp" -{ [ @_[1,3] ] } - ], - [#Rule 165 - 'names', 3, -sub -#line 419 "Parser.yp" -{ push(@{$_[1]}, $_[3]); $_[1] } - ], - [#Rule 166 - 'names', 1, -sub -#line 420 "Parser.yp" -{ [ $_[1] ] } - ], - [#Rule 167 - 'name', 3, -sub -#line 423 "Parser.yp" -{ $factory->quoted($_[2]) } - ], - [#Rule 168 - 'name', 1, -sub -#line 424 "Parser.yp" -{ "'$_[1]'" } - ], - [#Rule 169 - 'name', 1, undef - ], - [#Rule 170 - 'filename', 3, -sub -#line 436 "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 450 "Parser.yp" -{ push(@{$_[1]}, $_[2]) - if defined $_[2]; $_[1] } - ], - [#Rule 176 - 'quoted', 0, -sub -#line 452 "Parser.yp" -{ [ ] } - ], - [#Rule 177 - 'quotable', 1, -sub -#line 455 "Parser.yp" -{ $factory->ident($_[1]) } - ], - [#Rule 178 - 'quotable', 1, -sub -#line 456 "Parser.yp" -{ $factory->text($_[1]) } - ], - [#Rule 179 - 'quotable', 1, -sub -#line 457 "Parser.yp" -{ undef } - ] -]; - - - -1; - - - - - - - - - - - - diff --git a/lib/Template/Iterator.pm b/lib/Template/Iterator.pm deleted file mode 100644 index 710ecdc..0000000 --- a/lib/Template/Iterator.pm +++ /dev/null @@ -1,456 +0,0 @@ -#============================================================= -*-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. -# -# An iterator is an object which provides a consistent way to -# navigate through data which may have a complex underlying form. -# This implementation uses the get_first() and get_next() methods to -# iterate through a dataset. The get_first() method is called once -# to perform any data initialisation and return the first value, -# then get_next() is called repeatedly to return successive values. -# Both these methods return a pair of values which are the data item -# itself and a status code. The default implementation handles -# iteration through an array (list) of elements which is passed by -# reference to the constructor. An empty list is used if none is -# passed. The module may be sub-classed to provide custom -# implementations which iterate through any kind of data in any -# manner as long as it can conforms to the get_first()/get_next() -# interface. The object also implements the get_all() method for -# returning all remaining elements as a list reference. -# -# For further information on iterators see "Design Patterns", by the -# "Gang of Four" (Erich Gamma, Richard Helm, Ralph Johnson, John -# Vlissides), Addision-Wesley, ISBN 0-201-63361-2. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Iterator.pm,v 2.64 2004/01/13 16:19:15 abw Exp $ -# -#============================================================================ - -package Template::Iterator; - -require 5.004; - -use strict; -use vars qw( $VERSION $DEBUG $AUTOLOAD ); # AUTO? -use base qw( Template::Base ); -use Template::Constants; -use Template::Exception; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.64 $ =~ /(\d+)\.(\d+)/); -$DEBUG = 0 unless defined $DEBUG; - - -#======================================================================== -# ----- 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 (UNIVERSAL::can($data, '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 $self = shift; - my ($max, $index) = @$self{ qw( MAX INDEX ) }; - my $data = $self->{ _DATASET }; - - # warn about incorrect usage - unless (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... - if ($index < $max) { - # update counters and flags - $index++; - @$self{ qw( INDEX COUNT FIRST LAST ) } - = ( $index, $index + 1, 0, $index == $max ? 1 : 0 ); - @$self{ qw( PREV NEXT ) } = @$data[ $index - 1, $index + 1 ]; - return $data->[ $index ]; ## RETURN ## - } - else { - return (undef, Template::Constants::STATUS_DONE); ## 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; - - # if there's still some data to go... - if ($index < $max) { - $index++; - @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 ## - } -} - - -#------------------------------------------------------------------------ -# AUTOLOAD -# -# Provides access to internal fields (e.g. size, first, last, max, etc) -#------------------------------------------------------------------------ - -sub AUTOLOAD { - my $self = shift; - my $item = $AUTOLOAD; - $item =~ s/.*:://; - return if $item eq 'DESTROY'; - - # alias NUMBER to COUNT for backwards compatability - $item = 'COUNT' if $item =~ /NUMBER/i; - - return $self->{ uc $item }; -} - - -#======================================================================== -# ----- PRIVATE DEBUG METHODS ----- -#======================================================================== - -#------------------------------------------------------------------------ -# _dump() -# -# Debug method which returns a string detailing the internal state of -# the iterator object. -#------------------------------------------------------------------------ - -sub _dump { - my $self = shift; - join('', - " Data: ", $self->{ _DATA }, "\n", - " Index: ", $self->{ INDEX }, "\n", - "Number: ", $self->{ NUMBER }, "\n", - " Max: ", $self->{ MAX }, "\n", - " Size: ", $self->{ SIZE }, "\n", - " First: ", $self->{ FIRST }, "\n", - " Last: ", $self->{ LAST }, "\n", - "\n" - ); -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Iterator - Data iterator used by the FOREACH directive - -=head1 SYNOPSIS - - my $iter = Template::Iterator->new(\@data, \%options); - -=head1 DESCRIPTION - -The Template::Iterator module defines a generic data iterator for use -by the 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 get_first() and 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 'key' and '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 as_list() method then the 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 MyListObject -object, $list. - -By adding an as_list() method to the MyListObject class, we can force -the 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 item, 'foo' and 'bar', which the -MyObjectList encapsulates. - -=head2 get_first() - -Returns a ($value, $error) pair for the first item in the iterator set. -The $error returned may be zero or undefined to indicate a valid datum -was successfully returned. Returns an error of STATUS_DONE if the list -is empty. - -=head2 get_next() - -Returns a ($value, $error) pair for the next item in the iterator set. -Returns an error of STATUS_DONE if all items in the list have been -visited. - -=head2 get_all() - -Returns a (\@values, $error) pair for all remaining items in the iterator -set. Returns an error of 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 size() - 1. - -=head2 index() - -Returns the current index number which is in the range 0 to max(). - -=head2 count() - -Returns the current iteration count in the range 1 to size(). This is -equivalent to index() + 1. Note that number() is supported as an alias -for count() for backwards compatability. - -=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 undef if the iterator is -on the first item. - -=head2 next() - -Returns the next item in the data set or undef if the iterator is on the -last item. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.64, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Library/HTML.pod b/lib/Template/Library/HTML.pod deleted file mode 100644 index e39c120..0000000 --- a/lib/Template/Library/HTML.pod +++ /dev/null @@ -1,316 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Library::HTML -# -# DESCRIPTION -# The HTML library provides a number of basic templates for use in -# building HTML pages. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# 2.69 -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Library::HTML - Template library for building basic HTML pages - -=head1 DESCRIPTION - -B<NOTE:> This documentation is incomplete and may be incorrect -in places. - -The 'html' template library is distributed as part of the Template -Toolkit. It can be found in the 'templates' sub-directory of the -installation directory. - - use Template; - - my $tt2 = Template->new({ - INCLUDE_PATH => '/usr/local/tt2/templates', - }); - -For a portable way to determine the installation 'templates' directory, -you can use the C<Template::Config-E<gt>instdir()> class method. - - use Template; - - my $tt2 = Template->new({ - INCLUDE_PATH => Template::Config->instdir('templates'), - }); - -You should now be able to access the html library as, for example: - - [% INCLUDE html/header %] - -Note that some of the more basic elements don't give you much more -than the raw HTML tags. In many cases you might be well advised to -stick to regular HTML rather than complicating matters by the use -of template elements. - -e.g. - - <table> - . . . - </table> - -vs - - [% WRAPPER html/table %] - . . . - [% END %] - -However, the use of template elements to generate the underlying HTML -does have some important benefits, particularly as the constructs start -to get more complicated and more magical. - -See the example in the 'examples' sub-directory of the distribution -directory for further examples and enlightenment on using this library. - -=head2 Headers, Footers and Pages - -=over 4 - -=item header - -The 'header' element generates the regular header required as the -pre-amble for an HTML document. That is, everything from the initial -E<lt>htmlE<gt> to the opening E<lt>bodyE<gt>. - - [% INCLUDE html/header - title = 'This is a Test' - bgcol = '#ffffff' - %] - -Additional header items can be provided by explicitly setting the 'headers' -variable, e.g. - - [% headers = BLOCK %] - <META name="description" content="Template Toolkit"> - <META name="REVISIT-AFTER" content="14 days"> - <META name="keywords" content="Templates, Web, ...etc..."> - [% END %] - - [% INCLUDE html/header - title = 'This is a Test' - bgcol = '#ffffff' - %] - -=item footer - -The 'footer' element generates the terminating E<lt>/bodyE<gt> and -E<lt>/htmlE<gt> element to balance the header. - - [% PROCESS html/header %] - - ...page content here... - - [% PROCESS html/footer %] - -=item page - -The 'page' element combines the 'html/header' and 'html/footer' elements. - - [% WRAPPER html/page %] - - ...page content here... - - [% END %] - -Page content should be defined in the 'content' variable (e.g. via WRAPPER). -Additional HTML headers should be defined in the 'headers' variable. - - [% WRAPPER html/page - headers = '<META name="keywords" content="foo, bar, ...">' - %] - - ...page content here... - - [% END %] - -=back - -=head2 Tables, Bars and Boxes - -=over 4 - -=item table - -A basic element for creating HTML tables. - - [% WRAPPER html/table pad=10 space=4 col='#404040' %] - <tr> - <td>Hello</td> <td>World</td> - </tr> - [% END %] - -The following variables may be defined: - -=over 4 - -=item border - -Set the border width (default: 0) - -=item col - -Set the background colour (default: none). - -=item width - -Set a fixed table width. - -=item pad - -Set the cellpadding. - -=item space - -Set the cellspacing. - -=item content - -Content for the box. Supplied automatically if used via WRAPPER. - -=back - -=item row - -A basic element for creating HTML table rows. - - [% WRAPPER html/table %] - [% WRAPPER html/row %] - <td>Hello</td> <td>World</td> - [% END %] - [% END %] - -The following variables may be defined: - -=over 4 - -=item col - -Set the background colour (default: none). - -=item valign - -Set the vertical alignment. - -=item rowspan - -Specify the number of rows to span. - -=item content - -Content for the box. Supplied automatically if used via WRAPPER. - -=back - -=item cell - -A basic element for creating HTML table cells. - - [% WRAPPER html/table %] - [% WRAPPER html/row %] - [% INCLUDE html/cell - FOREACH content = ['Hello', 'World'] %] - [% END %] - [% END %] - -The following variables may be defined: - -=over 4 - -=item col - -Set the background colour (default: none). - -=item align - -Set the horizontal alignment. - -=item colspan - -Specify the number of columns to span. - -=item content - -Content for the cell. Supplied automatically if used via WRAPPER. - -=back - -=item bar - -The bar element is a wrapping of html/table + html/row. - - [% WRAPPER html/bar %] - <td>Foo</td> <td>Bar</td> - [% END %] - -=item box - -The box element is a wrapping of html/table + html/row + html/cell - - [% WRAPPER html/box %] - Hello World! - [% END %] - -=back - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.69, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Library::Splash|Template::Library::Splash> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Library/PostScript.pod b/lib/Template/Library/PostScript.pod deleted file mode 100644 index c30246c..0000000 --- a/lib/Template/Library/PostScript.pod +++ /dev/null @@ -1,78 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Library::PostScript -# -# DESCRIPTION -# This library contains a number of useful templates for generating -# PostScript pages. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# 2.69 -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Library::PostScript - Template library for generating PostScript - -=head1 DESCRIPTION - -The PostScript library contains a number of templates for generating -PostScript pages. It's very new, very incomplete, very ad-hoc and -isn't yet documented. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.69, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Library/Splash.pod b/lib/Template/Library/Splash.pod deleted file mode 100644 index e8c4f8b..0000000 --- a/lib/Template/Library/Splash.pod +++ /dev/null @@ -1,1030 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Library::Splash -# -# DESCRIPTION -# The Splash! library is built on top of the HTML library and -# implements a set of widgets for easy construction of stylish HTML -# pages -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# 2.69 -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Library::Splash - Template library for building stylish HTML user interfaces - -=head1 DESCRIPTION - -B<NOTE:> This documentation is incomplete, incorrect and outdated. -The Splash! library is still evolving and subject to change. See -the examples for a much more recent and accurate demonstration of -use. - -=head2 Introduction - -The 'Splash' template library is distributed as part of the Template -Toolkit. It can be found in the 'templates' sub-directory of the -installation directory. - - /your/tt2/installation - | - +-- docs - | ... - | - +-- images - | ... - | - +-- examples - | ... - | - +-- templates - | - +-- html - | ... - +-- pod - | ... - +-- splash <<<< YOU ARE HERE - ... - - -To use the Splash library, you first need to tell the Template Toolkit -where to find the template files. - - use Template; - - my $tt2 = Template->new({ - INCLUDE_PATH => '/usr/local/tt2/templates', - }); - -For a portable way to determine the installation 'templates' directory, -you can use the C<Template::Config-E<gt>instdir()> class method. - - use Template; - - my $tt2 = Template->new({ - INCLUDE_PATH => Template::Config->instdir('templates'), - }); - -Note that you should set the INCLUDE_PATH to the 'templates' directory -as shown here and don't be tempted to set the INCLUDE_PATH to -'templates/splash'. Many of the Splash! components use elements in -the 'html' directory and contain directives of the form: - - [% INCLUDE html/something %]. - -=head2 Configuration - -The 'splash/config' template defines a 'splash' hash array which -contains numerous configuration items for the Splash library. You -must PROCESS this template to ensure that the hash definition is -imported into your calling template. An INCLUDE is not sufficient as -it localises variables and prevents the 'splash' hash array from -existing outside the splash/config template. - - [% PROCESS splash/config %] - -Alternately, you can define the splash/config template as a PRE_PROCESS -item when you create the Template processor. - - use Template; - - my $tt2 = Template->new({ - INCLUDE_PATH => Template::Config->instdir('templates'), - PRE_PROCESS => 'splash/config', - }); - -You can modify the default configuration by creating your own -PRE_PROCESS config file which loads the 'splash/config' and then -tweaks the settings to your own preferences. - - my $tt2 = Template->new({ - INCLUDE_PATH => [ '/home/abw/tt2/templates', - Template::Config->instdir('templates') ], - PRE_PROCESS => 'config' - }); - -/home/abw/tt2/templates/config: - - [% # load the 'splash' configuration - PROCESS splash/config; - - # tweak values to personal preferences - splash.images = '/~abw/tt2/images/splash' - splash.select.col = 'leaf' - splash.unselect.col = 'bud' - %] - -The splash/config file includes some instructional comments on -things you might like to tweak. - -=head2 Colours - -The Splash! library uses the colours defined in the html/rgb template. -The 'rgb' hash defined therein is imported as the 'splash.rgb' hash. - - [% INCLUDE splash/box col='grey75' %] - -See the examples for further enlightenment on using colour. - -=head2 Style - -There are two very primitive "styles" implemented called "select" and -"unselect". These are used to indicate which item on a menu is -selected, for example. Each style defines characteristics like -background colour, font face, size and colour, text alignment, and so -on. - -The styles are implemented as hashes within the 'splash' hash. Many -of the components respond to a 'style' variable being set and you can -pass a direct reference to splash.select or splash.unselect (or your -own styles). e.g. - - [% INCLUDE splash/button - content = "Unselected" - style = splash.unselect - %] - [% INCLUDE splash/button - content ="Selected" - style = splash.select - %] - -Alternately, you can use the 'select' variable to indicate either -of the inbuilt styles: splash.select or splash.unselect. - - [% INCLUDE splash/button - content = "Unselected" - select = 0 - %] - [% INCLUDE splash/button - content = "Selected" - select = 1 - %] - -=head1 COMPONENT TEMPLATES - -This section describes some of the component templates in the Splash! -library. This documentation is incomplete and may also be inaccurate -in places. The examples in the 'examples' directory are likely to be -a much better reference. - - -=head2 splash/text - -Simple template to format text according to a selected/unselected style, -adding links, etc. - - [% INCLUDE splash/text - content = 'Template Toolkit' - link = 'http://www.template-toolkit.org' - select = 0 - bold = 1 - %] - - -Configuration items: - -=over 4 - - -=item content - -Text content. - - -=item link - -URL which can be defined to make the text a link. - - -=item style - -Reference to a style hash. - - -=item select - -Flag to default the style to splash.select (select == true value) or -splash.unselect (select == false value). - - -=back - -The following items default to the relevant style values: - -=over 4 - - -=item col (style.col.text) - - -=item font (style.font.face) - - -=item bold (style.font.bold) - - -=item size (style.font.size) - - -=back - - - -=head2 splash/table - -A thin wrapper around html/table, allowing a colour to be specified -by name. - - [% WRAPPER splash/table - col = 'aqua' - pad = 4 - width = '100%' - %] - <tr> - <td>Foo</td> - <td>Bar</td> - </tr> - [% END %] - - -Configuration items: - -=over 4 - - -=item content - -Table content. - - -=item col - -Background colour. - - -=item border - -Border width (default: 0) - - -=item width - -Width in absolute pixels (e.g. '100') or as a percentage (e.g. '50%'). - -=item pad - -Cell padding. - - -=item space - -Cell padding. - - -=back - - - -=head2 splash/row - -Creates a row for an HTML table. - - [% WRAPPER splash/table %] - - [% WRAPPER splash/row col='marine' %] - <td>Foo</td><td>Bar</td> - [% END %] - - [% WRAPPER splash/row col='aqua' %] - <td>Foo</td><td>Bar</td> - [% END %] - - [% END %] - - -Configuration items: - -=over 4 - - -=item content - -Row content. - - -=item col - -Background colour. - - -=item valign - -Vertical alignment - - -=item rowspan - -Number of rows to span. - - -=back - - - -=head2 splash/cell - -Creates a cell for an HTML table. - - [% WRAPPER splash/table + splash/row + splash/cell col='grey75' %] - Hello World - [% END %] - - -Configuration items: - -=over 4 - - -=item content - -Cell content. - - -=item col - -Background colour. - - -=item align - -Horizontal alignment - - -=item colspan - -Number of columns to span. - - -=back - - - -=head2 splash/box - -A box created from a union of splash/table, splash/row and splash/cell. -The following is equivalent to the previous example. - - [% WRAPPER splash/box col='grey75' %] - Hello World - [% END %] - -Configuration items are as per the individual templates. - - -=head2 splash/button - -Creates a small button with rounded corners. - - [% INCLUDE splash/button - content = 'Template Toolkit' - select = 1 - width = '50%' - %] - - -Configuration items: - -=over 4 - - -=item content - -Button content. - - -=item style - -Reference to a style hash. - - -=item select - -Flag to default the style to splash.select (select == true value) or -splash.unselect (select == false value). - - -=item width - -Width in absolute pixels (e.g. '100') or as a percentage (e.g. '50%'). - -=back - -The following items default to the relevant style values: - -=over 4 - - -=item col (style.col.text) - - -=item textcol (style.col.text) - - -=item font (style.font.face) - - -=item size (style.font.size) - - -=item bold (style.font.bold) - - -=item width (style.button.width) - - -=item align (style.button.align) - - -=back - - - -=head2 splash/bar - -Creates a bar with rounded corners at either the top or bottom, and -square corners on the other. Default has rounded at the top, set -'invert' to select bottom. - - [% INCLUDE splash/bar - content = 'Hello World', - select = 1 - %] - - -Configuration items: - -=over 4 - - -=item content - -Bar content. - - -=item style - -Reference to a style hash. - - -=item select - -Flag to default the style to splash.select (select == true value) or -splash.unselect (select == false value). - - -=item width - -Width in absolute pixels (e.g. '100') or as a percentage (e.g. '50%'). - -=item invert - -Flag to invert bar to hang down instead of sitting -upright. - - -=back - -The following items default to the relevant style values: - -=over 4 - - -=item col (style.col.text) - - -=item textcol (style.col.text) - - -=item font (style.font.face) - - -=item size (style.font.size) - - -=item bold (style.font.bold) - - -=item width (style.button.width) - - -=item align (style.button.align) - - -=back - - -=head2 splash/hair - -Generates a frame enclosing the content within crosshair corners. - - [% INCLUDE splash/hair - content = 'Template Toolkit' - %] - - -Configuration items: - -=over 4 - - -=item content - -Hair content. - - -=item style - -Reference to a style hash. - - -=back - -The following items default to the relevant style values: - -=over 4 - - -=item col (style.col.text) - - -=item bgcol (style.col.back) - - -=item align (style.button.align) - - -=back - - -=head2 splash/menu - -Creates a menu as a series of splash/button elements. - - [% buttons = [ - { text => 'One', link => 'one.html' } - { text => 'Two', link => 'two.html' } - ] - %] - - [% INCLUDE splash/menu - select = 2 # Two - %] - - -Configuration items: - -=over 4 - - -=item buttons - -A reference to a list of hash arrays containing 'text' and 'link' items. - - -=item select (n or 0) - -Indicates which button should be selected. First item is 1. 0 indicates -no button selected. - - -=item width - -Width in absolute pixels (e.g. '100') or as a percentage (e.g. '50%'). - -=item align - -Horizontal alignment - - -=back - - - -=head2 splash/menubar - -As above, but incorporated into a wider bar. - - [% WRAPPER splash/menubar %] - Section Title - [% END %] - - -Configuration items: - -=over 4 - - -=item buttons - -A reference to a list of hash arrays containing 'text' and 'link' items. - - -=item select (n or 0) - -Indicates which button should be selected. First item is 1. 0 indicates -no button selected. - - -=item width - -Width in absolute pixels (e.g. '100') or as a percentage (e.g. '50%'). - -=item align - -Horizontal alignment - - -=back - - - -=head2 splash/panel - -A table with a coloured edge. - - [% WRAPPER splash/panel edge='black' fill='grey75' border=2 %] - <tr> - <td>Hello World</td> - </tr> - [% END %] - - -Configuration items: - -=over 4 - - -=item content - -Panel content. - - -=item style - -Reference to a style hash. - - -=item select - -Flag to default the style to splash.select (select == true value) or -splash.unselect (select == false value). - - -=item width - -Width in absolute pixels (e.g. '100') or as a percentage (e.g. '50%'). - -=item align - -Horizontal alignment - - -=item border - -Border width (default: 0) - - -=back - -The following items default to the relevant style values: - -=over 4 - - -=item edge (style.col.edge) - - -=item fill (style.col.fill) - - -=item pad (style.pad) - - -=back - - - -=head2 splash/pane - -A union of splash/row + splash/cell. - - [% WRAPPER splash/panel select=1 %] - [% WRAPPER splash/pane col='grey75' %] - Hello World - [% END %] - - [% WRAPPER splash/pane col='grey50' %] - Hello Again - [% END %] - [% END %] - - -=head2 splash/tab - -A simple button looking like a page tab. - - [% INCLUDE splash/tab - content = 'Option 1' - col = 'aqua' - %] - - -Configuration items: - -=over 4 - - -=item content - -Tab content. - - -=item style - -Reference to a style hash. - - -=item select - -Flag to default the style to splash.select (select == true value) or -splash.unselect (select == false value). - - -=item width - -Width in absolute pixels (e.g. '100') or as a percentage (e.g. '50%'). - -=item align - -Horizontal alignment - - -=back - -The following items default to the relevant style values: - -=over 4 - - -=item col (style.col.text) - - -=item textcol (style.col.text) - - -=item font (style.font.face) - - -=item size (style.font.size) - - -=item bold (style.font.bold) - - -=item tabalign (style.tab.align) - - -=back - - - -=head2 splash/tabset - -A set of splash/tab components, similar to a menu. - - -Configuration items: - -=over 4 - - -=item tabs - -List of hash references containing text/link entries, as per -menu buttons. - - -=item select - -Flag to default the style to splash.select (select == true value) or -splash.unselect (select == false value). - - -=item invert - -Flag to invert tab to hang down instead of sitting -upright. - - -=back - - - -=head2 splash/tabbox - -Add a splash/tab to the top of a splash/box. - - -Configuration items: - -=over 4 - - -=item title - - title. - - -=item content - - content. - - -=item width - -Width in absolute pixels (e.g. '100') or as a percentage (e.g. '50%'). - -=item tabwidth - -Width of tabs. - - -=item select - -Flag to default the style to splash.select (select == true value) or -splash.unselect (select == false value). - - -=item border - -Border width (default: 0) - - -=back - -The following items default to the relevant style values: - -=over 4 - - -=item col (style.col.text) - - -=item fill (style.col.fill) - - -=item tabalign (style.tab.align) - - -=item tablocate (style.tab.locate) - - -=back - - - -=head2 splash/tabsbox - -Add a splash/tabset to the top of a splash/box. - - -Configuration items: - -=over 4 - - -=item tabs - -List of hash references containing text/link entries, as per -menu buttons. - - -=item select - -Flag to default the style to splash.select (select == true value) or -splash.unselect (select == false value). - - -=item content - - content. - - -=item width - -Width in absolute pixels (e.g. '100') or as a percentage (e.g. '50%'). - -=item border - -Border width (default: 0) - - -=item invert - -Flag to invert to hang down instead of sitting -upright. - - -=back - -The following items default to the relevant style values: - -=over 4 - - -=item col (style.col.text) - - -=item fill (style.col.fill) - - -=item tabalign (style.tab.align) - - -=item tablocate (style.tab.locate) - - -=back - - -=head2 splash/tabspanel - -As per splash/tabsbox, but attached to a splash/panel instead of a -splash/box. - - -=head1 EXAMPLES - -See the examples in the 'examples' sub-directory of the installation -for comprehensive examples showing use of the Splash! library. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.69, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Library::HTML|Template::Library::HTML> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Manual.pod b/lib/Template/Manual.pod deleted file mode 100644 index 8775a5b..0000000 --- a/lib/Template/Manual.pod +++ /dev/null @@ -1,180 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Manual -# -# DESCRIPTION -# This is the comprehensive user guide and reference manual for the -# Template Toolkit. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Manual - User guide and reference manual for the Template Toolkit - -=head1 DESCRIPTION - -This is the comprehensive user guide and reference manual for the -Template Toolkit. - -=over 4 - -=item L<Template::Manual::Intro|Template::Manual::Intro> - -Introduction to the Template Toolkit - -This section provides a general introduction to the Template Toolkit, -giving a quick overview of features, examples of template directives -and use of the Template.pm module. It also described the basic concept -underlying the toolkit: the separation of presentation elements from -application logic and data. - -=item L<Template::Manual::Syntax|Template::Manual::Syntax> - -Directive syntax, structure and semantics - -This section describes the syntax, structure and semantics of the -Template Toolkit directives and general presentation language. - -=item L<Template::Manual::Directives|Template::Manual::Directives> - -Template directives - -This section provides a reference of all Template Toolkit directives, -complete with examples of use. - -=item L<Template::Manual::Variables|Template::Manual::Variables> - -Template variables and code bindings - -This section describes the different ways in which Perl data can be -bound to template variables and accessed via Template Toolkit -directives. - -=item L<Template::Manual::VMethods|Template::Manual::VMethods> - -Virtual Methods - -The Template Toolkit provides virtual methods for manipulating variable -values. Most of them are analogous to regular Perl functions of the -same names. This section describes the different virtual methods that -can be applied to scalar, list and hash values. - -=item L<Template::Manual::Config|Template::Manual::Config> - -Configuration options - -This section contains details of all the configuration options that can -be used to customise the behaviour and extend the features of the -Template Toolkit. - -=item L<Template::Manual::Filters|Template::Manual::Filters> - -Standard filters - -This section lists all the standard filters distributed with the -Template Toolkit for post-processing output. - -=item L<Template::Manual::Plugins|Template::Manual::Plugins> - -Standard plugins - -This section lists the standard plugins which can be used to extend the -runtime functionality of the Template Toolkit. The plugins are -distributed with the Template Toolkit but may required additional -modules from CPAN. - -=item L<Template::Manual::Internals|Template::Manual::Internals> - -Template Toolkit internals - -This document provides an overview of the internal architecture of the -Template Toolkit. It is a work in progress and is far from complete, -currently providing little more than an overview of how the major -components fit together. Nevertheless, it's a good starting point for -anyone wishing to delve into the source code to find out how it all -works. - -=item L<Template::Manual::Views|Template::Manual::Views> - -Template Toolkit views (experimental) - -This section describes dynamic views: a powerful but experimental new -feature in version 2.01 of the Template Toolkit. - -=item L<Template::Manual::Refs|Template::Manual::Refs> - -Related modules, projects and other resources - -This section provides references to external modules, projects and -other resources related to the Template Toolkit. - -=item L<Template::Manual::Credits|Template::Manual::Credits> - -Author and contributor credits - -This section provides a brief history of the Template Toolkit and -details the primary author and numerous other people who have -contributed to it. - - - -=back - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Manual/Config.pod b/lib/Template/Manual/Config.pod deleted file mode 100644 index 5020556..0000000 --- a/lib/Template/Manual/Config.pod +++ /dev/null @@ -1,2122 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Manual::Config -# -# DESCRIPTION -# This section contains details of all the configuration options that -# can be used to customise the behaviour and extend the features of -# the Template Toolkit. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Manual::Config - Configuration options - -=head1 DESCRIPTION - -This section contains details of all the configuration options that can -be used to customise the behaviour and extend the features of the -Template Toolkit. - -=head2 Template Style and Parsing Options - -=over 4 - - - -=item START_TAG, END_TAG - -The START_TAG and END_TAG options are used to specify character -sequences or regular expressions that mark the start and end of a -template directive. The default values for START_TAG and END_TAG are -'[%' and '%]' 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 TAGS directive can also be used to set the START_TAG and END_TAG values -on a per-template file basis. - - [% TAGS <+ +> %] - - - - - - -=item TAG_STYLE - -The TAG_STYLE option can be used to set both START_TAG and 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) - -Any values specified for START_TAG and/or END_TAG will over-ride -those defined by a TAG_STYLE. - -The TAGS directive may also be used to set a TAG_STYLE - - [% TAGS html %] - <!-- INCLUDE header --> - - - - - - -=item PRE_CHOMP, POST_CHOMP - -Anything outside a directive tag is considered plain text and is -generally passed through unaltered (but see the 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 PRE_CHOMP and 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 PRE_CHOMP set to 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 POST_CHOMP set to 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 PRE_CHOMP or POST_CHOMP is set to 2, then instead of removing all -the whitespace, the whitespace will be collapsed to a single space. -This is useful for HTML, where (usually) a contiguous block of -whitespace is rendered the same as a single space. - -You may use the CHOMP_NONE, CHOMP_ALL, and CHOMP_COLLAPSE constants -from the Template::Constants module to deactivate chomping, remove -all whitespace, or collapse whitespace to a single space. - -PRE_CHOMP and POST_CHOMP can be activated for individual directives by -placing a '-' immediately at the start and/or end of the directive. - - [% FOREACH user = userlist %] - [%- user -%] - [% END %] - -The '-' characters activate both PRE_CHOMP and POST_CHOMP for the one -directive '[%- name -%]'. Thus, the template will be processed as if -written: - - [% FOREACH user = userlist %][% user %][% END %] - -Note that this is the same as if PRE_CHOMP and POST_CHOMP were set -to CHOMP_ALL; the only way to get the CHOMP_COLLAPSE behavior is -to set PRE_CHOMP or POST_CHOMP accordingly. If PRE_CHOMP or POST_CHOMP -is already set to CHOMP_COLLAPSE, using '-' will give you CHOMP_COLLAPSE -behavior, not CHOMP_ALL behavior. - -Similarly, '+' characters can be used to disable PRE_CHOMP or -POST_CHOMP (i.e. leave the whitespace/newline intact) options on a -per-directive basis. - - [% FOREACH user = userlist %] - User: [% user +%] - [% END %] - -With POST_CHOMP enabled, the above example would be parsed as if written: - - [% FOREACH user = userlist %]User: [% user %] - [% END %] - - - - - -=item TRIM - -The TRIM option can be set to have any leading and trailing whitespace -automatically removed from the output of all template files and BLOCKs. - -By example, the following BLOCK definition - - [% BLOCK foo %] - Line 1 of foo - [% END %] - -will be processed is as "\nLine 1 of foo\n". When INCLUDEd, the surrounding -newlines will also be introduced. - - before - [% INCLUDE foo %] - after - -output: - before - - Line 1 of foo - - after - -With the TRIM option set to any true value, the leading and trailing -newlines (which count as whitespace) will be removed from the output -of the BLOCK. - - before - Line 1 of foo - after - -The TRIM option is disabled (0) by default. - - - - - -=item INTERPOLATE - -The INTERPOLATE flag, when set to any true value will cause variable -references in plain text (i.e. not surrounded by START_TAG and END_TAG) -to be recognised and interpolated accordingly. - - my $template = Template->new({ - INTERPOLATE => 1, - }); - -Variables should be prefixed by a '$' to identify them. Curly braces -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 INTERPOLATE or split the templates in several -smaller files or blocks which can then be joined backed together via -PROCESS or INCLUDE. - - - - - - - -=item ANYCASE - -By default, directive keywords should be expressed in UPPER CASE. The -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 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 ANYCASE option, are the operators: - - and or not mod div - - - - - - -=back - -=head2 Template Files and Blocks - -=over 4 - - - -=item INCLUDE_PATH - -The 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 BLOCK, each of the 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 ':'. - - 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 ':' followed by a '/' or '\'. This avoids confusion when using -directory names like 'C:\Blah Blah'. - -When specified as a list, the INCLUDE_PATH path can contain elements -which dynamically generate a list of INCLUDE_PATH directories. These -generator elements can be specified as a reference to a subroutine or -an object which implements a 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 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 die(). Generator objects should return undef and make an -error available via its 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; - - - - - -=item DELIMITER - -Used to provide an alternative delimiter character sequence for -separating paths specified in the INCLUDE_PATH. The default -value for DELIMITER is ':'. - - # tolerate Silly Billy's file system conventions - my $template = Template->new({ - DELIMITER => '; ', - INCLUDE_PATH => 'C:/HERE/NOW; D:/THERE/THEN', - }); - - # better solution: install Linux! :-) - -On Win32 systems, the default delimiter is a little more intelligent, -splitting paths only on ':' characters that aren't followed by a '/'. -This means that the following should work as planned, splitting the -INCLUDE_PATH into 2 separate directories, C:/foo and 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 DELIMITER character to something else (e.g. ';') -rather than rely on this subtle magic. - - - - -=item ABSOLUTE - -The ABSOLUTE flag is used to indicate if templates specified with -absolute filenames (e.g. '/foo/bar') should be processed. It is -disabled by default and any attempt to load a template by such a -name will cause a '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 - - - - - - -=item RELATIVE - -The RELATIVE flag is used to indicate if templates specified with -filenames relative to the current directory (e.g. './foo/bar' or -'../../some/where/else') should be loaded. It is also disabled by -default, and will raise a 'file' error if such template names are -encountered. - - my $template = Template->new({ - RELATIVE => 1, - }); - - [% INCLUDE ../logs/error.log %] - - - - - -=item DEFAULT - -The DEFAULT option can be used to specify a default template which should -be used whenever a specified template can't be found in the INCLUDE_PATH. - - my $template = Template->new({ - DEFAULT => 'notfound.html', - }); - -If a non-existant template is requested through the Template process() -method, or by an INCLUDE, PROCESS or WRAPPER directive, then the -DEFAULT template will instead be processed, if defined. Note that the -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. - - - - - -=item BLOCKS - -The 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 Template::Document -objects. - - my $template = Template->new({ - BLOCKS => { - header => 'The Header. [% title %]', - footer => sub { return $some_output_text }, - another => Template::Document->new({ ... }), - }, - }); - - - - -=item AUTO_RESET - -The AUTO_RESET option is set by default and causes the local BLOCKS -cache for the Template::Context object to be reset on each call to the -Template process() method. This ensures that any BLOCKs defined -within a template will only persist until that template is finished -processing. This prevents BLOCKs defined in one processing request -from interfering with other independent requests subsequently -processed by the same context object. - -The BLOCKS item may be used to specify a default set of block definitions -for the Template::Context object. Subsequent BLOCK definitions in templates -will over-ride these but they will be reinstated on each reset if AUTO_RESET -is enabled (default), or if the Template::Context reset() method is called. - - - - - - - - - -=item 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. - - - -=back - -=head2 Template Variables - -=over 4 - -=item VARIABLES, PRE_DEFINE - -The VARIABLES option (or 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 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, - }, - }; - - - - -=item CONSTANTS - -The 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, - }, - }; - -=item CONSTANT_NAMESPACE - -Constant variables are accessed via the 'constants' namespace by -default. - - [% constants.title %] - -The 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 %] - -=item 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 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 2 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|Template::Namespace::Constants> -for an example of what a namespace handler looks like on the inside. - - - - - -=back - -=head2 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 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 -Template::Service module which, unsurprisingly, also has a process() -method. Any templates defined by the 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 PROCESS templates -are defined then they are instead processed in turn. In this case, -one of the 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 PROCESS template(s) -is then wrapped in any WRAPPER templates, if defined. WRAPPER -templates don't need to worry about explicitly processing the template -because it will have been done for them already. Instead WRAPPER -templates access the content they are wrapping via the 'content' -variable. - - wrapper before - [% content %] - wrapper after - -This output generated from processing the main template, and/or any -PROCESS or WRAPPER templates is added to the output buffer. Finally, -any 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 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 WRAPPER and POST_PROCESS templates. If no relevant ERROR -option is defined, or if the error occurs in one of the PRE_PROCESS, -WRAPPER or POST_PROCESS templates, then the process will terminate -immediately and the error will be returned. - - - -=over 4 - - - -=item PRE_PROCESS, POST_PROCESS - -These values may be set to contain the name(s) of template files -(relative to 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 INCLUDE, -PROCESS, 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 ':'. This delimiter string can be changed via the -DELIMITER option. - - my $template = Template->new({ - PRE_PROCESS => 'config:header', - POST_PROCESS => 'footer', - }; - -The PRE_PROCESS and 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 Template::Document object representing the main template being processed -is available within PRE_PROCESS and POST_PROCESS templates as the 'template' -variable. Metadata items defined via the 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 %]"> - - - - - - - - - - - - - - -=item PROCESS - -The PROCESS option may be set to contain the name(s) of template files -(relative to INCLUDE_PATH) which should be processed instead of the -main template passed to the Template process() method. This can -be used to apply consistent wrappers around all templates, similar to -the use of PRE_PROCESS and 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 'template' -variable. Metadata items can be inspected and the template can be -processed by specifying it as a variable reference (i.e. prefixed by -'$') to an INCLUDE, PROCESS or WRAPPER directive. - -content: - - <html> - <head> - <title>[% template.title %]</title> - </head> - - <body> - [% PROCESS $template %] - <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> - <h1>The Foo Page</h1> - Welcome to the Foo Page, blah blah blah - <hr> - © Copyright 2000 Fred Foo - </body> - </html> - - - - - - - -=item WRAPPER - -The 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 PROCESS template(s)) and -the output generated is then passed as the 'content' variable to the -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 WRAPPER template by setting the value to -be a reference to a list of templates. The 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 WRAPPER -configuration item (and also the 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 'foo' template is processed before the wrapper template meaning -that the '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 META items which are then -accessed via the 'template' variable (which you are still free to -use within WRAPPER templates), but gives you more flexibility in -the type and complexity of data that you can define. - - - - - -=item ERROR - -The ERROR (or 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 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 'default' template may be provided for the general -case. Note that 'ERROR' can be pluralised to '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 'user' exceptions thrown will cause the -'user/index.html' template to be processed, 'dbi' errors are handled -by 'error/database' and all others by the 'error/default' template. -Any PRE_PROCESS and/or POST_PROCESS templates will also be applied -to these error templates. - -Note that exception types are hierarchical and a 'foo' handler will -catch all 'foo.*' errors (e.g. foo.bar, 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 '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 $template object, or -other templates or code called from within, can raise a 'user.login' -exception and have the service redirect to the 'user/login.html' -template. Similarly, a 'user.passwd' exception has a specific -handling template, 'user/badpasswd.html', while all other 'user' or -'user.*' exceptions cause a redirection to the 'user/index.html' page. -All other exception types are handled by 'error/default'. - - -Exceptions can be raised in a template using the THROW directive, - - [% THROW user.login 'no user id: please login' %] - -or by calling the throw() method on the current Template::Context object, - - $context->throw('user.passwd', 'Incorrect Password'); - $context->throw('Incorrect Password'); # type 'undef' - -or from Perl code by calling die() with a Template::Exception object, - - die (Template::Exception->new('user.denied', 'Invalid User ID')); - -or by simply calling die() with an error string. This is -automagically caught and converted to an exception of 'undef' -type which can then be handled in the usual way. - - die "I'm sorry Dave, I can't do that"; - - - - - - -=back - -=head2 Template Runtime Options - -=over 4 - - - - -=item EVAL_PERL - -This flag is used to indicate if PERL and/or RAWPERL blocks should be -evaluated. By default, it is disabled and any PERL or RAWPERL blocks -encountered will raise exceptions of type 'perl' with the message -'EVAL_PERL not set'. Note however that any RAWPERL blocks should -always contain valid Perl code, regardless of the EVAL_PERL flag. The -parser will fail to compile templates that contain invalid Perl code -in RAWPERL blocks and will throw a 'file' exception. - -When using compiled templates (see -L<COMPILE_EXT|Template::Manual::Config/Caching_and_Compiling_Options> and -L<COMPILE_DIR|Template::Manual::Config/Caching_and_Compiling_Options>), -the 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 EVAL_PERL is set when a template is compiled, then all PERL and -RAWPERL blocks will be included in the compiled template. If the -EVAL_PERL option isn't set, then Perl code will be generated which -B<always> throws a 'perl' exception with the message 'EVAL_PERL not -set' B<whenever> the compiled template code is run. - -Thus, you must have EVAL_PERL set if you want your compiled templates -to include PERL and 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 EVAL_PERL option was set at the time the -template was compiled, then the output of any 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 -EVAL_PERL status. - -Regular PERL blocks are a little more cautious, however. If the -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 'perl' -exception with the message, 'EVAL_PERL not set'. - -Thus you can compile templates to include PERL blocks, but optionally -disable them when you process them later. Note however that it is -possible for a PERL block to contain a Perl "BEGIN { # some code }" -block which will always get run regardless of the runtime EVAL_PERL -status. Thus, if you set 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 EVAL_PERL disabled. - - - - - - - -=item OUTPUT - -Default output location or handler. This may be specified as one of: -a file name (relative to OUTPUT_PATH, if defined, or the current -working directory if not specified absolutely); a file handle -(e.g. GLOB or 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 -push()ed; or as a reference to any object that supports the print() -method. This latter option includes the 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 OUTPUT location be overridden by passing a third parameter -to the Template process() method. This can be specified as any of the -above argument types. - - $t->process($file, $vars, "/tmp/foo"); - $t->process($file, $vars, "bar"); - $t->process($file, $vars, \*MYGLOB); - $t->process($file, $vars, \@output); - $t->process($file, $vars, $r); # Apache::Request - ... - - - - - - - - -=item OUTPUT_PATH - -The OUTPUT_PATH allows a directory to be specified into which output -files should be written. An output file can be specified by the -OUTPUT option, or passed by name as the third parameter to the -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 '/tmp/src/foo.html' and -'/tmp/src/bar.html' and write the processed output to '/tmp/dest/foo.html' -and '/tmp/dest/bar.html', respectively. - - - - - - - - -=item DEBUG - -The DEBUG option can be used to enable debugging within the various -different modules that comprise the Template Toolkit. The -L<Template::Constants|Template::Constants> module defines a set of -DEBUG_XXXX constants which can be combined using the logical OR -operator, '|'. - - 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 DEBUG_XXXX flags can be used: - -=over 4 - -=item DEBUG_SERVICE - -Enables general debugging messages for the -L<Template::Service|Template::Service> module. - -=item DEBUG_CONTEXT - -Enables general debugging messages for the -L<Template::Context|Template::Context> module. - -=item DEBUG_PROVIDER - -Enables general debugging messages for the -L<Template::Provider|Template::Provider> module. - -=item DEBUG_PLUGINS - -Enables general debugging messages for the -L<Template::Plugins|Template::Plugins> module. - -=item DEBUG_FILTERS - -Enables general debugging messages for the -L<Template::Filters|Template::Filters> module. - -=item DEBUG_PARSER - -This flag causes the L<Template::Parser|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 '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 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 - -=item DEBUG_FORMAT - -The DEBUG_FORMAT option can be used to specify a format string for the -debugging messages generated via the DEBUG_DIRS option described -above. Any occurances 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 %] -->' %] - - -=back - -=head2 Caching and Compiling Options - -=over 4 - - - -=item CACHE_SIZE - -The Template::Provider module caches compiled templates to avoid the need -to re-parse template files or blocks each time they are used. The CACHE_SIZE -option is used to limit the number of compiled templates that the module -should cache. - -By default, the 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 == CACHE_SIZE), the least recently used compiled template -is discarded to make room for the new one. - -The CACHE_SIZE can be set to 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 - }); - - - - - - -=item 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 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 COMPILE_EXT is defined (and COMPILE_DIR isn't, see below) then compiled -template files with the 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 COMPILE_EXT or 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 require(), leaving Perl to handle -all the parsing and compilation. This is a Good Thing. - -=item COMPILE_DIR - -The 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 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 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 INCLUDE_PATH is replicated in full beneath the -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 INCLUDE_PATH directories will have their -compiled forms save in the relevant 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 COMPILE_DIR value(s) to prevent illegal filename being generated. -Any colon in 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 - - -=back - -=head2 Plugins and Filters - -=over 4 - - - -=item PLUGINS - -The 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. 'table', 'cgi', 'dbi', etc.) which map to -their corresponding Template::Plugin::* counterparts. These can be -redefined by values in the PLUGINS hash. - - my $template = Template->new({ - PLUGINS => { - cgi => 'MyOrg::Template::Plugin::CGI', - foo => 'MyOrg::Template::Plugin::Foo', - bar => 'MyOrg::Template::Plugin::Bar', - }, - }); - -The USE directive is used to create plugin objects and does so by -calling the plugin() method on the current Template::Context object. -If the plugin name is defined in the PLUGINS hash then the -corresponding Perl module is loaded via require(). The context then -calls the load() class method which should return the class name -(default and general case) or a prototype object against which the -new() method can be called to instantiate individual plugin objects. - -If the plugin name is not defined in the PLUGINS hash then the PLUGIN_BASE -and/or LOAD_PERL options come into effect. - - - - - -=item PLUGIN_BASE - -If a plugin is not defined in the PLUGINS hash then the PLUGIN_BASE is used -to attempt to construct a correct Perl module name which can be successfully -loaded. - -The PLUGIN_BASE can be specified as a single value or as a reference -to an array of multiple values. The default PLUGIN_BASE value, -'Template::Plugin', is always added the the end of the PLUGIN_BASE -list (a single value is first converted to a list). Each value should -contain a Perl package name to which the requested plugin name is -appended. - -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' ], - }); - - [% USE Foo %] # => MyOrg::Template::Plugin::Foo - or YourOrg::Template::Plugin::Foo - or Template::Plugin::Foo - - - - - - -=item LOAD_PERL - -If a plugin cannot be loaded using the PLUGINS or 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 -Template::Plugin or some other such namespace) to be loaded and used -as plugins. - -By default, the LOAD_PERL option is set to 0 and no attempt will be made -to load any Perl modules that aren't named explicitly in the PLUGINS -hash or reside in a package as named by one of the PLUGIN_BASE -components. - -Plugins loaded using the PLUGINS or PLUGIN_BASE receive a reference to -the current context object as the first argument to the new() -constructor. Modules loaded using LOAD_PERL are assumed to not -conform to the plugin interface. They must provide a 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 -load() class method (or inherit the default one from the -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, new() constructor convention then a simple plugin wrapper -can be written to interface to it. - - - - -=item FILTERS - -The FILTERS option can be used to specify custom filters which can -then be used with the 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 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 (0) or -dynamic (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 -define_filter() method on the current 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. '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. '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 -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 FILTER directive for further examples. - - -=back - -=head2 Compatibility, Customisation and Extension - -=over 4 - - - -=item V1DOLLAR - -In version 1 of the Template Toolkit, an optional leading '$' could be placed -on any template variable and would be silently ignored. - - # VERSION 1 - [% $foo %] === [% foo %] - [% $hash.$key %] === [% hash.key %] - -To interpolate a variable value the '${' ... '}' construct was used. -Typically, one would do this to index into a hash array when the key -value was stored in a variable. - -example: - - my $vars = { - users => { - aba => { name => 'Alan Aardvark', ... }, - abw => { name => 'Andy Wardley', ... }, - ... - }, - uid => 'aba', - ... - }; - - $template->process('user/home.html', $vars) - || die $template->error(), "\n"; - -'user/home.html': - - [% user = users.${uid} %] # users.aba - Name: [% user.name %] # Alan Aardvark - -This was inconsistent with double quoted strings and also the -INTERPOLATE mode, where a leading '$' in text was enough to indicate a -variable for interpolation, and the additional curly braces were used -to delimit variable names where necessary. Note that this use is -consistent with UNIX and Perl conventions, among others. - - # double quoted string interpolation - [% name = "$title ${user.name}" %] - - # INTERPOLATE = 1 - <img src="$images/help.gif"></a> - <img src="$images/${icon.next}.gif"> - -For version 2, these inconsistencies have been removed and the syntax -clarified. A leading '$' on a variable is now used exclusively to -indicate that the variable name should be interpolated -(e.g. subsituted for its value) before being used. The earlier example -from version 1: - - # VERSION 1 - [% user = users.${uid} %] - Name: [% user.name %] - -can now be simplified in version 2 as: - - # VERSION 2 - [% user = users.$uid %] - Name: [% user.name %] - -The leading dollar is no longer ignored and has the same effect of -interpolation as '${' ... '}' in version 1. The curly braces may -still be used to explicitly scope the interpolated variable name -where necessary. - -e.g. - - [% user = users.${me.id} %] - Name: [% user.name %] - -The rule applies for all variables, both within directives and in -plain text if processed with the INTERPOLATE option. This means that -you should no longer (if you ever did) add a leading '$' to a variable -inside a directive, unless you explicitly want it to be interpolated. - -One obvious side-effect is that any version 1 templates with variables -using a leading '$' will no longer be processed as expected. Given -the following variable definitions, - - [% foo = 'bar' - bar = 'baz' - %] - -version 1 would interpret the following as: - - # VERSION 1 - [% $foo %] => [% GET foo %] => bar - -whereas version 2 interprets it as: - - # VERSION 2 - [% $foo %] => [% GET $foo %] => [% GET bar %] => baz - -In version 1, the '$' is ignored and the value for the variable 'foo' is -retrieved and printed. In version 2, the variable '$foo' is first interpolated -to give the variable name 'bar' whose value is then retrieved and printed. - -The use of the optional '$' has never been strongly recommended, but -to assist in backwards compatibility with any version 1 templates that -may rely on this "feature", the V1DOLLAR option can be set to 1 -(default: 0) to revert the behaviour and have leading '$' characters -ignored. - - my $template = Template->new({ - V1DOLLAR => 1, - }); - - - - -=item LOAD_TEMPLATES - -The LOAD_TEMPLATE option can be used to provide a reference to a list -of 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 PROCESS, INCLUDE or WRAPPER directive is encountered, the named -template may refer to a locally defined BLOCK or a file relative to -the INCLUDE_PATH (or an absolute or relative path if the appropriate -ABSOLUTE or RELATIVE options are set). If a BLOCK definition can't be -found (see the Template::Context template() method for a discussion of -BLOCK locality) then each of the LOAD_TEMPLATES provider objects is -queried in turn via the 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 -INSERT directive but it bypasses any BLOCK definitions and doesn't -attempt is to parse or process the contents of the template file. - -This is an implementation of the 'Chain of Responsibility' -design pattern as described in -"Design Patterns", Erich Gamma, Richard Helm, Ralph Johnson, John -Vlissides), Addision-Wesley, ISBN 0-201-63361-2, page 223 -. - -If LOAD_TEMPLATES is undefined, a single default provider will be -instantiated using the current configuration parameters. For example, -the Template::Provider INCLUDE_PATH option can be specified in the Template configuration and will be correctly passed to the provider's -constructor method. - - my $template = Template->new({ - INCLUDE_PATH => '/here:/there', - }); - - - - - -=item LOAD_PLUGINS - -The LOAD_PLUGINS options can be used to specify a list of provider -objects (i.e. they implement the fetch() method) which are responsible -for loading and instantiating template plugin objects. The -Template::Content plugin() method queries each provider in turn in a -"Chain of Responsibility" as per the template() and filter() methods. - - my $template = Template->new({ - LOAD_PLUGINS => [ - MyOrg::Template::Plugins->new({ ... }), - Template::Plugins->new({ ... }), - ], - }); - -By default, a single Template::Plugins object is created using the -current configuration hash. Configuration items destined for the -Template::Plugins constructor may be added to the Template -constructor. - - my $template = Template->new({ - PLUGIN_BASE => 'MyOrg::Template::Plugins', - LOAD_PERL => 1, - }); - - - - - -=item LOAD_FILTERS - -The LOAD_FILTERS option can be used to specify a list of provider -objects (i.e. they implement the fetch() method) which are responsible -for returning and/or creating filter subroutines. The -Template::Context filter() method queries each provider in turn in a -"Chain of Responsibility" as per the template() and plugin() methods. - - my $template = Template->new({ - LOAD_FILTERS => [ - MyTemplate::Filters->new(), - Template::Filters->new(), - ], - }); - -By default, a single Template::Filters object is created for the -LOAD_FILTERS list. - - - - - -=item TOLERANT - -The TOLERANT flag is used by the various Template Toolkit provider -modules (Template::Provider, Template::Plugins, 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 (template, plugin, filter) being denied and an exception -raised. When the TOLERANT flag is set to any true values, errors will -be silently ignored and the provider will instead return -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 'E<lt>resourceE<gt> not found' exception is raised. - - - - - - -=item SERVICE - -A reference to a Template::Service object, or sub-class thereof, to which -the Template module should delegate. If unspecified, a Template::Service -object is automatically created using the current configuration hash. - - my $template = Template->new({ - SERVICE => MyOrg::Template::Service->new({ ... }), - }); - - - - - -=item CONTEXT - -A reference to a Template::Context object which is used to define a -specific environment in which template are processed. A 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 to INCLUDE or PROCESS another template (include() and -process() methods, respectively), to USE a plugin (plugin()) or -instantiate a filter (filter()) or to access the stash (stash()) which -manages variable definitions via the get() and set() methods. - - my $template = Template->new({ - CONTEXT => MyOrg::Template::Context->new({ ... }), - }); - - - -=item STASH - -A reference to a 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 VARIABLES -configuration item to initialise the stash variables. These may also -be specified as the PRE_DEFINE option for backwards compatibility with -version 1. - - my $template = Template->new({ - VARIABLES => { - id => 'abw', - name => 'Andy Wardley', - }, - }; - - - - - -=item PARSER - -The 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 -Template::Provider whenever a template is loaded and requires -compilation. The PARSER option can be used to provide a reference to -an alternate parser object. - - my $template = Template->new({ - PARSER => MyOrg::Template::Parser->new({ ... }), - }); - - - - - -=item GRAMMAR - -The 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 Template::Parser -using the 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 Template::Grammar file is constructed from a YACC like grammar -(using Parse::YAPP) and a skeleton module template. These files are -provided, along with a small script to rebuild the grammar, in the -'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 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 Template::Grammar will be -created and used automatically if a GRAMMAR item isn't specified. - - use MyOrg::Template::Grammar; - - my $template = Template->new({ - GRAMMAR = MyOrg::Template::Grammar->new(); - }); - - - -=back - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Manual/Credits.pod b/lib/Template/Manual/Credits.pod deleted file mode 100644 index 64999ac..0000000 --- a/lib/Template/Manual/Credits.pod +++ /dev/null @@ -1,188 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Manual::Credits -# -# DESCRIPTION -# This section provides a brief history of the Template Toolkit and -# details the primary author and numerous other people who have -# contributed to it. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Manual::Credits - Author and contributor credits - -=head1 DESCRIPTION - -This section provides a brief history of the Template Toolkit and -details the primary author and numerous other people who have -contributed to it. - -=head1 HISTORY - -The Template Toolkit began its life as the 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/) - -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. (http://www.cre.canon.co.uk), 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. - - - - -=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. - - Chuck Adams <scrytch@uswest.net> - Stephen Adkins <stephen.adkins@officevision.com> - Ivan Adzhubey <iadzhubey@rics.bwh.harvard.edu> - Mark Anderson <mda@discerning.com> - Bradley Baetz <bbaetz@student.usyd.edu.au> - Thierry-Michel Barral <kktos@electron-libre.com> - Craig Barratt <craig@arraycomm.com> - Stas Bekman <stas@stason.org> - Tony Bowden <tony-tt@kasei.com> - Neil Bowers <neilb@cre.canon.co.uk> - Leon Brocard <acme@astray.com> - Lyle Brooks <brooks@deseret.com> - Dave Cash <dave@gnofn.org> - Piers Cawley <pdcawley@bofh.org.uk> - Darren Chamberlain <dlc@users.sourceforge.net> - Eric Cholet <cholet@logilune.com> - Dave Cross <dave@dave.org.uk> - Chris Dean <ctdean@babycenter.com> - Francois Desarmenien <desar@club-internet.fr> - Horst Dumcke <hdumcke@cisco.com> - Mark Fowler <mark@indicosoftware.com> - Michael Fowler <michael@shoebox.net> - Axel Gerstmair <anthill@web.de> - Dylan William Hardison <dylanwh@tampabay.rr.com> - Perrin Harkins <pharkins@etoys.com> - Bryce Harrington <bryce@osdl.org> - Dave Hodgkinson <daveh@davehodgkinson.com> - Harald Joerg <Harald.Joerg@fujitsu-siemens.com> - Colin Johnson <colin@knowledgepool.com> - Vivek Khera <khera@kciLink.com> - Rafael Kitover <caelum@debian.org> - Ivan Kurmanov <http://www.ahinea.com> - Hans von Lengerke <hans@lengerke.org> - Jonas Liljegren <jonas@paranormal.se> - Simon Luff <simon@sports.com> - Paul Makepeace <Paul.Makepeace@realprogrammers.com> - Gervase Markham <gerv@mozilla.org> - Simon Matthews <sam@knowledgepool.com> - Robert McArthur <mcarthur@dstc.edu.au> - Craig McLane <mclanec@oxy.edu> - Leslie Michael Orchard <deus_x@ninjacode.com> - Eugene Miretskiy <eugene@invision.net> - Tatsuhiko Miyagawa <miyagawa@edge.co.jp> - Keith G. Murphy <keithmur@mindspring.com> - Chris Nandor <pudge@pobox.com> - Briac Pilpré <briac@pilpre.com> - Martin Portman <mrp@cre.canon.co.uk> - Slaven Rezic <slaven.rezic@berlin.de> - Christian Schaffner <schaffner@eeh.ee.ethz.ch> - Randal L. Schwartz <merlyn@stonehenge.com> - Paul Sharpe <paul@miraclefish.com> - Ville Skyttä <ville.skytta@iki.fi> - Doug Steinwand <dsteinwand@etoys.com> - Michael Stevens <michael@etla.org> - Drew Taylor <dtaylor@vialogix.com> - Swen Thuemmler <Swen.Thuemmler@paderlinx.de> - Richard Tietjen <Richard_Tietjen@mcgraw-hill.com> - Stathy G. Touloumis <stathy.touloumis@edventions.com> - Jim Vaughan <jim@mrjim.com> - Simon Wilcox <simonw@simonwilcox.co.uk> - Chris Winters <cwinters@intes.net> - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Manual/Directives.pod b/lib/Template/Manual/Directives.pod deleted file mode 100644 index 3b8af3e..0000000 --- a/lib/Template/Manual/Directives.pod +++ /dev/null @@ -1,2179 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Manual::Directives -# -# DESCRIPTION -# This section provides a reference of all Template Toolkit -# directives, complete with examples of use. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Manual::Directives - Template directives - -=head1 DESCRIPTION - -This section provides a reference of all Template Toolkit directives, -complete with examples of use. - -=head2 Accessing and Updating Template Variables - -=over 4 - - -=item GET - -The GET directive retrieves and outputs the value of the named variable. - - [% GET foo %] - -The 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 (and, or, not, ?:) and -mathematic operators (+ - * / % mod div). - - [% template.title or default.title %] - - [% score * 100 %] - - [% order.nitems ? checkout(order.total) : 'no items' %] - -The 'div' operator returns the integer result of division. Both '%' and -'mod' return the modulus (i.e. remainder) of division. 'mod' is provided -as an alias for '%' for backwards compatibility with version 1. - - [% 15 / 6 %] # 2.5 - [% 15 div 6 %] # 2 - [% 15 mod 6 %] # 3 - - - -=item CALL - -The CALL directive is similar to 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) %] - - - - -=item SET - -The SET directive allows you to assign new values to existing variables -or create new temporary variables. - - [% SET title = 'Hello World' %] - -The SET keyword is also optional. - - [% title = 'Hello World' %] - -Variables may be assigned the values of other variables, unquoted -numbers (digits), 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 '$', 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 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 ' _ ' operator. In Perl 5, -the '.' is used for string concatenation, but in Perl 6, as in the Template -Toolkit, the '.' will be used as the method calling operator and ' _ ' 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" %] - - - - - -=item DEFAULT - -The DEFAULT directive is similar to 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 %]"> - - -=back - -=head2 Processing Other Template Files and Blocks - -=over 4 - - -=item INSERT - -The 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 INCLUDE_PATH -directories. Absolute (i.e. starting with C</>) and relative -(i.e. starting with C<.>) filenames may be used if the ABSOLUTE and -RELATIVE options are set, respectively. Both these options are -disabled by default. - - my $template = Template->new({ - INCLUDE_PATH => '/here:/there', - }); - - $template->process('myfile'); - -'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 '$' 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 '+' 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 - - - - - - - - - - - - - - - - - -=item INCLUDE - -The INCLUDE directive is used to process and include the output of -another template file or block. - - [% INCLUDE header %] - -If a 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 BLOCK definition is not currently visible then the template name -should be a file relative to one of the INCLUDE_PATH directories, or -an absolute or relative file name if the ABSOLUTE/RELATIVE options are -appropriately enabled. The INCLUDE directive automatically quotes the -filename specified, as per INSERT described above. When a variable -contains the name of the template for the INCLUDE directive, it should -be explicitly prefixed by '$' 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> - ... - -'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 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 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 'foo' -variable referencing a hash will be copied to create a new 'foo' -variable but which points to the same hash array. Thus, if you update -compound variables (e.g. 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 PROCESS directive which is -faster by virtue of not performing any localisation. - -From version 2.04 onwards, you can specify dotted variables as "local" -variables to an 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 actualy 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 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 -'$variables') joined together by '+'. The 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 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. - - - -=item PROCESS - -The PROCESS directive is similar to 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 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 PROCESS directive is slightly faster than INCLUDE because it -avoids the need to localise (i.e. copy) the variable stash before -processing the template. As with INSERT and INCLUDE, the first -parameter does not need to be quoted as long as it contains only -alphanumeric characters, underscores, periods or forward slashes. -A '$' 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 INCLUDE, multiple templates can be specified, delimited by -'+', and are processed in order. - - [% PROCESS html/header + my/header %] - - - - - -=item 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 WRAPPER directive provides a way of simplifying this a little. It -encloses a block up to a matching END directive, which is first -processed to generate some output. This is then passed to the named -template file or BLOCK as the '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: - - <p> - <h2>[% title %]</h2> - [% 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 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> - - - - - - - - - - - - - - - - - - -=item BLOCK - -The BLOCK ... END construct can be used to define template component -blocks which can be processed with the INCLUDE, PROCESS and 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 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 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 'julius'. - -Anonymous BLOCKs 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 - - - -=back - -=head2 Conditional Processing - -=over 4 - - -=item IF / UNLESS / ELSIF / ELSE - -The IF and 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 ELSIF and/or 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 - -Note that C<and>, C<or> and C<not> are also provided as aliases for -C<&&>, C<||> and C<!>, respectively. - -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 %] - - - - - - -=item SWITCH / CASE - -The SWITCH / CASE construct can be used to perform a multi-way -conditional test. The SWITCH directive expects an expression which is -first evaluated and then compared against each CASE statement in turn. -Each CASE directive should contain a single value or a list of values -which should match. CASE may also be left blank or written as [% CASE -DEFAULT %] to specify a default match. Only one CASE matches, there -is no drop-through between CASE statements. - - [% SWITCH myvar %] - [% CASE value1 %] - ... - [% CASE [ value2 value3 ] %] # multiple values - ... - [% CASE myhash.keys %] # ditto - ... - [% CASE %] # default - ... - [% END %] - - - - -=back - -=head2 Loop Processing - -=over 4 - - -=item FOREACH - -The FOREACH directive will iterate through the items in a list, processing -the enclosed block for each one. - - my $vars = { - foo => 'Foo', - items => [ 'one', 'two', 'three' ], - }; - -template: - - Things: - [% FOREACH thing = [ foo 'Bar' "$foo Baz" ] %] - * [% thing %] - [% END %] - - Items: - [% FOREACH i = items %] - * [% i %] - [% END %] - - Stuff: - [% stuff = [ foo "$foo Bar" ] %] - [% FOREACH s = stuff %] - * [% s %] - [% END %] - -output: - - Things: - * Foo - * Bar - * Foo Baz - - Items: - * one - * two - * three - - Stuff: - * Foo - * Foo Bar - -You can use also use 'IN' instead of '=' if you prefer. - - [% FOREACH crook IN government %] - -When the 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 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 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 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 NEXT directive starts the next iteration in the FOREACH loop. - - [% FOREACH user IN userlist %] - [% NEXT IF user.isguest %] - Name: [% user.name %] Email: [% user.email %] - [% END %] - -The LAST directive can be used to prematurely exit the loop. BREAK is -also provided as an alias for LAST. - - [% FOREACH match IN results.nsort('score').reverse %] - [% LAST IF match.score < 50 %] - [% match.score %] : [% match.url %] - [% END %] - -The FOREACH directive is implemented using the Template::Iterator -module. A reference to the iterator object for a FOREACH directive is -implicitly available in the 'loop' variable. The following methods -can be called on the '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> - -Note that the number() method is supported as an alias for count() for -backwards compatibility but may be deprecated in some future version. - -Nested loops will work as expected, with the '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 '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 'loop'. See 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 %] - - - - -=item WHILE - -The 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 IF / 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 NEXT directive can be used to start the next iteration of a -WHILE loop and BREAK can be used to exit the loop, both as per FOREACH. - -The Template Toolkit uses a failsafe counter to prevent runaway WHILE -loops which would otherwise never terminate. If the loop exceeds 1000 -iterations then an 'undef' exception will be thrown, reporting the -error: - - WHILE loop terminated (> 1000 iterations) - -The $Template::Directive::WHILE_MAX variable controls this behaviour -and can be set to a higher value if necessary. - - -=back - -=head2 Filters, Plugins, Macros and Perl - -=over 4 - - -=item FILTER - -The 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 '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 FILTER directive can also follow various other non-block directives. -For example: - - [% INCLUDE mytext FILTER html %] - -The '|' character can also be used as an alias for '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 '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 '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 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 '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 FILTERS option, described in L<Template::Manual::Config>, allows -custom filters to be defined when a Template object is instantiated. -The 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 FILTER directive automatically quotes the name of the filter. As -with INCLUDE et al, you can use a variable to provide the name of the -filter, prefixed by '$'. - - [% 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 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 PERL block within a template that is loaded via 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 define_filter() method on the current Template::Context -object. - -See L<Template::Manual::Filters> for a complete list of available filters, -their descriptions and examples of use. - - - - - - -=item USE - -The 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>. - -The plugin name is case-sensitive and will be appended to the -PLUGIN_BASE value (default: 'Template::Plugin') to construct a full -module name. Any periods, '.', in the name will be converted to '::'. - - [% USE MyPlugin %] # => Template::Plugin::MyPlugin - [% USE Foo.Bar %] # => Template::Plugin::Foo::Bar - -Various standard plugins are included with the Template Toolkit (see -below and L<Template::Manual::Plugins>). These can be specified in lower -case and are mapped to the appropriate name. - - [% USE cgi %] # => Template::Plugin::CGI - [% USE table %] # => Template::Plugin::Table - -Any additional parameters supplied in parenthesis after the plugin -name will be also be passed to the new() constructor. A reference to -the current Template::Context object is always passed as the first -parameter. - - [% USE MyPlugin('foo', 123) %] - -equivalent to: - - Template::Plugin::MyPlugin->new($context, 'foo', 123); - -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 = table.rows %] - <tr> - [% FOREACH item = 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 = scores.rows %] - ... - [% END %] - -You can use this approach to create multiple plugin objects with -different configurations. This example shows how the 'format' plugin -is used to create sub-routines bound to variables for formatting text -as per 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 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 CGI plugin is an example of one which delegates to another Perl -module. In this this case, it is to Lincoln Stein's CGI.pm module. -All of the methods provided by CGI.pm 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 %] - -Simon Matthews has written the DBI plugin which provides an interface -to Tim Bunce's DBI module (available from CPAN). Here's a short -example: - - [% USE DBI('DBI:mSQL:mydbname') %] - - [% FOREACH user = DBI.query('SELECT * FROM users') %] - [% user.id %] [% user.name %] [% user.etc.etc %] - [% END %] - -See L<Template::Manual::Plugins> for more information on the plugins -distributed with the toolkit or available from CPAN. - -The 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 Template::Plugin::* or other module relative to some -PLUGIN_BASE) supports an object-oriented interface and a 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 %] - - - - - - -=item MACRO - -The 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 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 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 MACRO may also be defined as an anonymous BLOCK. The block will be -evaluated each time the macro is called. - - [% MACRO header BLOCK %] - ...content... - [% END %] - - [% header %] - -If you've got the EVAL_PERL option set, then you can even define a -MACRO as a PERL block (see below): - - [% MACRO triple(n) PERL %] - my $n = $stash->get('n'); - print $n * 3; - [% END -%] - - - - - - - -=item PERL - -(for the advanced reader) - -The PERL directive is used to mark the start of a block which contains -Perl code for evaluation. The EVAL_PERL option must be enabled for Perl -code to be evaluated or a 'perl' exception will be thrown with the -message 'EVAL_PERL not set'. - -Perl code is evaluated in the Template::Perl package. The $context -package variable contains a reference to the current 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 $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 PERL block by calling print(). Note that -the Template::Perl::PERLOUT handle is selected (tied to an output -buffer) instead of 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 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 PERL blocks via die() and will be -correctly caught by enclosing TRY blocks. - - [% TRY %] - [% PERL %] - die "nothing to live for\n"; - [% END %] - [% CATCH %] - error: [% error.info %] - [% END %] - -output: - error: nothing to live for - - - - -=item 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 eval() to evaluate -it into a subroutine reference. This subroutine is then called to -process the template, passing a reference to the current -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 $Template::Parser::DEBUG package variable to any true value. You -can also set the $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 -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 PERL ... END construct allows Perl code to be embedded into a -template (when the EVAL_PERL option is set), but it is evaluated at -"runtime" using 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 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 RAWPERL blocks more -efficient than PERL blocks. - -The downside is that you must code much closer to the metal. Within -PERL blocks, you can call print() to generate some output. 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 '$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 PERL blocks, the $context and $stash references are pre-defined -and available for use within RAWPERL code. - - -=back - -=head2 Exception Handling and Flow Control - -=over 4 - - -=item TRY / THROW / CATCH / FINAL - -(more advanced material) - -The Template Toolkit supports fully functional, nested exception -handling. The TRY directive introduces an exception handling scope -which continues until the matching END directive. Any errors that -occur within that block will be caught and can be handled by one -of the 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 Template::Exception -class) and contain two fields, 'type' and 'info'. The exception -'type' can be any string containing letters, numbers, '_' or '.', and -is used to indicate the kind of error that occurred. The 'info' field -contains an error message indicating what actually went wrong. Within -a catch block, the exception object is aliased to the 'error' variable. -You can access the 'type' and 'info' fields directly. - - [% mydsn = 'dbi:MySQL:foobar' %] - ... - - [% TRY %] - [% USE DBI(mydsn) %] - [% CATCH %] - ERROR! Type: [% error.type %] - Info: [% error.info %] - [% END %] - -output (assuming a non-existant database called 'foobar'): - - ERROR! Type: DBI - Info: Unknown database "foobar" - -The 'error' variable can also be specified by itself and will return a -string of the form "$type error - $info". - - ... - [% CATCH %] - ERROR: [% error %] - [% END %] - -output: - - ERROR: DBI error - Unknown database "foobar" - -Each CATCH block may be specified with a particular exception type -denoting the kind of error that it should catch. Multiple CATCH -blocks can be provided to handle different types of exception that may -be thrown in the TRY block. A 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 -[% 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 ';'. Thus, you might prefer to write your simple -CATCH blocks more succinctly as: - - [% TRY %] - ... - [% CATCH file; "File Error! $error.info" %] - [% CATCH DBI; INCLUDE database/error.html %] - [% CATCH; error %] - [% END %] - -or even: - - [% TRY %] - ... - [% CATCH file ; - "File Error! $error.info" ; - CATCH DBI ; - INCLUDE database/error.html ; - CATCH ; - error ; - END - %] - -The DBI plugin throws exceptions of the 'DBI' type (in case that -wasn't already obvious). The other specific exception caught here is -of the 'file' type. - -A 'file' error 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 INCLUDE, PROCESS, INSERT or WRAPPER directive. -If 'myfile' can't be found in the example above, the [% INCLUDE myfile -%] directive will raise a 'file' exception which is then caught by the -[% CATCH file %] block, generating the output: - - File Error! myfile: not found - -Note that the 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-existant file is requested (unless, of course, the DEFAULT file -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. the TRY block doesn't have a type specific -or default CATCH handler) may be caught by enclosing 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 -process() method will return a false value to the caller. The -relevant Template::Exception object can be retrieved by calling the -error() method. - - [% TRY %] - ... - [% TRY %] - [% INCLUDE $user.header %] - [% CATCH file %] - [% INCLUDE header %] - [% END %] - ... - [% CATCH DBI %] - [% INCLUDE database/error.html %] - [% END %] - -In this example, the inner TRY block is used to ensure that the first -INCLUDE directive works as expected. We're using a variable to -provide the name of the template we want to include, user.header, and -it's possible this contains the name of a non-existant template, or -perhaps one containing invalid template directives. If the INCLUDE fails - with a 'file' error then we CATCH it in the inner block and INCLUDE -the default 'header' file instead. Any DBI errors that occur within -the scope of the outer TRY block will be caught in the relevant CATCH -block, causing the '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. -e.g. - -'database/error.html': - - <h2>Database Error</h2> - A database error has occurred: [% error.info %] - -You can also specify a FINAL block. This is always processed -regardless of the outcome of the TRY and/or CATCH block. If an -exception is uncaught then the 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 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 CLEAR directive can be used in a CATCH or FINAL block to clear -any output created in the 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 'DBI.connect' exception is a more -specific kind of 'DBI' error. Similarly, a 'myown.error.barf' is a -more specific kind of 'myown.error' type which itself is also a -'myown' error. A CATCH handler that specifies a general exception -type (such as 'DBI' or 'myown.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 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 'DBI.connect' error has it's own handler, a more -general 'DBI' block is used for all other DBI or DBI.* errors and a -default handler catches everything else. - -Exceptions can be raised in a template using the THROW directive. The -first parameter is the exception type which doesn't need to be quoted -(but can be, it's the same as 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 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 'info' field will be a hash array containing -the named arguments, in this case 'msg' =E<gt> 'Missing Ingredients', -and an 'args' item which contains a list of the positional arguments, -in this case 'eggs' and 'flour'. The error 'type' field remains -unchanged, here set to 'food'. - - [% CATCH food %] - [% error.info.msg %] - [% FOREACH item = error.info.args %] - * [% item %] - [% END %] - [% END %] - -This produces the output: - - Missing Ingredients - * eggs - * flour - -In addition to specifying individual positional arguments as -[% error.info.args.n %], the '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 die() passing a reference to a -Template::Exception object as the argument. This will then be caught -by any enclosing 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 '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 die() with a single string, as is common in much -existing Perl code. This will automatically be converted to an -exception of the 'undef' type (that's the literal string 'undef', -not the undefined value). If the string isn't terminated with a -newline then Perl will append the familiar " 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 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 throw() method. You can pass it an -Template::Exception object reference, a pair of ($type, $info) parameters -or just an $info string to create an exception of 'undef' type. - - $context->throw($e); # exception object - $context->throw('Denied'); # 'undef' type - $context->throw('user.passwd', 'Bad Password'); - - - - - - - -=item NEXT - -The NEXT directive can be used to start the next iteration of a FOREACH -or WHILE loop. - - [% FOREACH user = userlist %] - [% NEXT IF user.isguest %] - Name: [% user.name %] Email: [% user.email %] - [% END %] - - - - - -=item LAST - -The LAST directive can be used to prematurely exit a FOREACH or WHILE -loop. - - [% FOREACH user = userlist %] - Name: [% user.name %] Email: [% user.email %] - [% LAST IF some.condition %] - [% END %] - -BREAK can also be used as an alias for LAST. - - - - -=item RETURN - -The 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 INCLUDE, PROCESS or -WRAPPER directive. If there is no enclosing template then the -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 - - - - -=item STOP - -The 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 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 %] - <p>Cannot connect to the database: [% error.info %]</p> - <br> - We apologise for the inconvenience. The cleaning lady - has removed the server power to plug in her vacuum cleaner. - Please try again later. - </p> - [% INCLUDE footer %] - [% STOP %] - [% END %] - - - - -=item CLEAR - -The 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 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 %] - - - - -=back - -=head2 Miscellaneous - -=over 4 - - -=item META - -The 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 META variables). - - [% META - title = 'The Cat in the Hat' - author = 'Dr. Seuss' - version = 1.23 - %] - -The '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 'name' and '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 PRE_PROCESS and POST_PROCESS options allow common headers and -footers to be added to all templates. The '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> - - - -=item TAGS - -The TAGS directive can be used to set the START_TAG and END_TAG values -on a per-template file basis. - - [% TAGS <+ +> %] - - <+ INCLUDE header +> - -The TAGS directive may also be used to set a named TAG_STYLE - - [% TAGS html %] - <!-- INCLUDE header --> - -See the TAGS and TAG_STYLE configuration options for further details. - - - - - - - - -=item DEBUG - -The DEBUG directive can be used to enable or disable directive debug -messages within a template. The DEBUG configuration option must be -set to include DEBUG_DIRS for the DEBUG directives to have any effect. -If DEBUG_DIRS is not set then the parser will automatically ignore and -remove any DEBUG directives. - -The DEBUG directive can be used with an 'on' or '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 'format' parameter can be used to change the format of the debugging -message. - - [% DEBUG format '<!-- $file line $line : [% $text %] -->' %] - - - - - -=back - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Manual/Filters.pod b/lib/Template/Manual/Filters.pod deleted file mode 100644 index c42f2ef..0000000 --- a/lib/Template/Manual/Filters.pod +++ /dev/null @@ -1,529 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Manual::Filters -# -# DESCRIPTION -# This section lists all the standard filters distributed with the -# Template Toolkit for post-processing output. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Manual::Filters - Standard filters - -=head1 DESCRIPTION - -This section lists all the standard filters distributed with the -Template Toolkit for post-processing output. - -=head1 STANDARD FILTERS - - - -=head2 format(format) - -The 'format' filter takes a format string as a parameter (as per -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. --> - -=head2 upper - -Folds the input to UPPER CASE. - - [% "hello world" FILTER upper %] - -output: - - HELLO WORLD - -=head2 lower - -Folds the input to lower case. - - [% "Hello World" FILTER lower %] - -output: - - hello world - -=head2 ucfirst - -Folds the first character of the input to UPPER CASE. - - [% "hello" FILTER ucfirst %] - -output: - - Hello - -=head2 lcfirst - -Folds the first character of the input to lower case. - - [% "HELLO" FILTER lcfirst %] - -output: - - hELLO - -=head2 trim - -Trims any leading or trailing whitespace from the input text. Particularly -useful in conjunction with INCLUDE, PROCESS, etc., having the same effect -as the TRIM configuration option. - - [% INCLUDE myfile | trim %] - -=head2 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 - -=head2 html - -Converts the characters 'E<lt>', 'E<gt>' and '&' to '<', '>' and -'&', 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... - -=head2 html_entity - -The html filter is fast and simple but it doesn't encode the full -range of HTML entities that your text may contain. The html_entity -filter uses either the Apache::Util module (which is written in C and -is therefore faster) or the 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 escape_html() or encode_entities() subroutines -respectively) to convert all extended characters into their -appropriate HTML entities (e.g. converting 'é' to 'é'). If -neither module is available on your system then an 'html_entity' exception -will be thrown reporting an appropriate message. - -For further information on HTML entity encoding, see -http://www.w3.org/TR/REC-html40/sgml/entities.html. - -=head2 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 E<lt>pE<gt>...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> - -=head2 html_break / html_para_break - -Similar to the html_para filter described above, but uses the HTML tag -sequence 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. - -=head2 html_line_break - -This filter replaces any newlines with 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> - -=head2 uri - -This filter URI escapes the input text, converting any characters -outside of the permitted URI character set (as defined by RFC 2396) -into a C<%nn> hex escape. - - [% 'my file.html' | uri %] - -output: - - my%20file.html - -Note that URI escaping isn't always enough when generating hyperlinks in -an HTML document. The C<&> character, for example, is valid in a URI and -will not be escaped by the URI filter. In this case you should also filter -the text through the 'html' filter. - - <a href="[% filename | uri | html %]">click here</a> - -=head2 indent(pad) - -Indents the text block by a fixed pad string or width. The '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 - -=head2 truncate(length) - -Truncates the text block to the length specified, or a default length of -32. Truncated text will be terminated with '...' (i.e. the '...' 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... - -=head2 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! - -=head2 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 - -=head2 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 - -=head2 redirect(file, options) - -The 'redirect' filter redirects the output of the block into a separate -file, specified relative to the OUTPUT_PATH configuration item. - - [% FOREACH user = myorg.userlist %] - [% FILTER redirect("users/${user.id}.html") %] - [% INCLUDE userinfo %] - [% END %] - [% END %] - -or more succinctly, using side-effect notation: - - [% INCLUDE userinfo - FILTER redirect("users/${user.id}.html") - FOREACH user = myorg.userlist - %] - -A 'file' exception will be thrown if the OUTPUT_PATH option is undefined. - -An optional '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 'binmode' option -as shown in the first example. - -=head2 eval / evaltt - -The '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 'evaltt' filter is provided as an alias for 'eval'. - -=head2 perl / evalperl - -The 'perl' filter evaluates the block as Perl code. The EVAL_PERL -option must be set to a true value or a 'perl' exception will be -thrown. - - [% my_perl_code | perl %] - -In most cases, the [% PERL %] ... [% 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 'evalperl' filter is provided as an alias for 'perl' for backwards -compatibility. - -=head2 stdout(options) - -The stdout filter prints the output generated by the enclosing block to -STDOUT. The 'binmode' option can be passed as either a named parameter -or a single argument to set 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 stdout filter can be used to force binmode on STDOUT, or also inside -redirect, null or stderr blocks to make sure that particular output goes -to stdout. See the null filter below for an example. - -=head2 stderr - -The stderr filter prints the output generated by the enclosing block to -STDERR. - -=head2 null - -The 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 stdout filter to ensure that a particular expression -generates output to stdout (in this case in binary mode). - -=head2 latex(outputType) - -Passes the text block to LaTeX and produces either PDF, DVI or -PostScript output. The 'outputType' argument determines the output -format and it should be set to one of the strings: "pdf" (default), -"dvi", or "ps". - -The text block should be a complete LaTeX source file. - - [% FILTER latex("pdf") -%] - \documentclass{article} - - \begin{document} - - \title{A Sample TT2 \LaTeX\ Source File} - \author{Craig Barratt} - \maketitle - - \section{Introduction} - This is some text. - - \end{document} - [% END -%] - -The output will be a PDF file. You should be careful not to prepend or -append any extraneous characters or text outside the FILTER block, -since this text will wrap the (binary) output of the latex filter. -Notice the END directive uses '-%]' for the END_TAG to remove the -trailing new line. - -One example where you might prepend text is in a CGI script where -you might include the Content-Type before the latex output, eg: - - Content-Type: application/pdf - - [% FILTER latex("pdf") -%] - \documentclass{article} - \begin{document} - ... - \end{document} - [% END -%] - -In other cases you might use the redirect filter to put the output -into a file, rather than delivering it to stdout. This might be -suitable for batch scripts: - - [% output = FILTER latex("pdf") -%] - \documentclass{article} - \begin{document} - ... - \end{document} - [% END; output | redirect("document.pdf", 1) -%] - -(Notice the second argument to redirect to force binary mode.) - -Note that the latex filter runs one or two external programs, so it -isn't very fast. But for modest documents the performance is adequate, -even for interactive applications. - -A error of type 'latex' will be thrown if there is an error reported -by latex, pdflatex or dvips. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Manual/Internals.pod b/lib/Template/Manual/Internals.pod deleted file mode 100644 index b8cf80b..0000000 --- a/lib/Template/Manual/Internals.pod +++ /dev/null @@ -1,556 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Manual::Internals -# -# DESCRIPTION -# This document provides an overview of the internal architecture of -# the Template Toolkit. It is a work in progress and is far from -# complete, currently providing little more than an overview of how -# the major components fit together. Nevertheless, it's a good -# starting point for anyone wishing to delve into the source code to -# find out how it all works. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Manual::Internals - Template Toolkit internals - -=head1 DESCRIPTION - -This document provides an overview of the internal architecture of the -Template Toolkit. It is a work in progress and is far from complete, -currently providing little more than an overview of how the major -components fit together. Nevertheless, it's a good starting point for -anyone wishing to delve into the source code to find out how it all -works. - -=head2 Outside Looking In - -The B<Template> module is simply a front end module which creates and -uses a Template::Service and pipes the output wherever you want it to -go (STDOUT by default, or maybe a file, scalar, etc). The -Apache::Template module (available separately from CPAN) is another -front end. That creates a Template::Service::Apache object, calls on -it as required and sends the output back to the relevant -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 Apache::Template -front end, for example, handles Apache::Request specifics and -configuration via the httpd.conf. The regular Template front-end -deals with STDOUT, variable refs, etc. Otherwise it is -Template::Service (or subclass) which does all the work. - -The B<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. Template::Service hides that all -away and makes everything look simple to the outsider. It provides -extra features, like PRE_PROCESS, PROCESS and POST_PROCESS, and also -provides the error recovery mechanism via ERROR. You ask it to -process a template and it takes care of everything for you. The -Template::Service::Apache module goes a little bit further, adding -some extra headers to the 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 process() method and schedules the named template -specified as an argument, and possibly several other templates -(PRE_PROCESS, etc) to be processed in order. It doesn't actually -process the templates itself, but instead makes a process() call -against a Template::Context object. - -B<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 -Template::Provider objects (the LOAD_TEMPLATES posse) who themselves -might get involved with a 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 template() -method. You call it passing a template name as an argument, and it -returns a compiled template in the form of a Template::Document -object, or otherwise raises an exception. - -A B<Template::Document> is a thin object wrapper around a compiled -template subroutine. The object implements a 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 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 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 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 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); - } - - -=head2 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 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 -Template::Exception object. An exception object is really just a -convenient wrapper for the 'type' and '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 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 Template::Service object calls on -Template::Context to handle a 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 B<Template::Stash> -object. This is a blessed hash array in which template variables are -defined. The object wrapper provides get() and set() method which -implement all the 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 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 get() method hides the details of the underlying variable -types, automatically calling code references, checking return values, -and performing other such tricks. If '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 get() call: - - $stash->get([ 'title', ['The Cat Sat on the Mat'] ]); - -Dotted compound variables can be requested by passing a single -list reference to the 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 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 process() -method lies the include() method. Just as with the PROCESS / INCLUDE -directives, the key difference is in variable localisation. Before -processing a template, the process() method simply updates the stash -to set any new variable definitions, overwriting any existing values. -In contrast, the 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 include() -method restores the previous variable state by I<decloning> the stash. - -The context also provides an insert() method to implement the INSERT -directive, but no wrapper() method. This functionality can be implemented -by rewriting the Perl code and calling include(). - - [% WRAPPER foo -%] - blah blah [% x %] - [%- END %] - - $context->include('foo', { - content => 'blah blah ' . $stash->get('x'), - }); - -Other than the template processing methods process(), include() and insert(), -the context defines methods for fetching plugin objects, plugin(), and -filters, filter(). - - [% USE foo = Bar(10) %] - - $stash->set('foo', $context->plugin('Bar', [10])); - - [% FILTER bar(20) %] - blah blah blah - [% END %] - - 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 IF, UNLESS, FOREACH and so on all have direct -counterparts in Perl. - - [% IF msg %] - Message: [% msg %] - [% END %]; - - 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 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 STDOUT remains as you would expect: - - The dog sat on the log - -The output sent to 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. - -When you start to hack on the Template Toolkit, please make sure you -start from the latest developer release. Stable releases are uploaded -to CPAN and have all-numerical version numbers, e.g. 2.04, 2.05. -Developer releases are available from the Template Toolkit web site -and have a character suffix on the version, e.g. 2.04a, 2.04b, etc. - -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 '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 '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 updating existing documentation -then you should download the 'docsrc' bundle from which all the -Template Toolkit documentation is built and make your changes in there. -It's also available from the Template Toolkit web site. See the -README distributed in the archive for further information. - -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 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). - -Aesthetics aside, if I do want to extract the documentation into the -docsrc bundle then it's easy for me to do it if it's all written in -one chunk and extremely tedious if not. So for practical reasons -alone, please keep Perl and POD sections separate. Comment blocks -within the code are of course welcome. - -To share your changes with the rest of the world, you'll need to -prepare a patch file. To do this you should have 2 directories -side-by-side, one which is the original, unmodified distribution -directory for the latest developer release, and the other is a -copy of that same directory which includes your changes. - -The following example shows a typical hacking session. First we -unpack the latest developer release. - - $ tar zxf Template-Toolkit-2.05c.tar.gz - -At this point, it's a good idea to rename the directory to give -some indicate of what it contains. - - $ mv Template-Toolkit-2.05c Template-Toolkit-2.05c-abw-xyz-hack - -Then go hack! - - $ cd Template-Toolkit-2.05c-abw-xyz-hack - - [ hacking ] - - $ cd .. - -When you're all done and ready to prepare a patch, unpack the -distribution archive again so that you've got the original to -diff against your new code. - - $ tar zxf Template-Toolkit-2.05c.tar.gz - -You should now have an original distribution directory and a modified -version of that same directory, side-by-side. - - $ ls - Template-Toolkit-2.05c Template-Toolkit-2.05c-abw-xyz-hack - -Now run diff and save the output into an appropriately named patch -file. - - $ diff -Naur Template-Toolkit-2.05c Template-Toolkit-2.05c-abw-xyz-hack > patch-TT205c-abw-xyz-hack - -You can then post the generated patch file to the mailing list, -describing what it does, why it does it, how it does it and any -other relevant information. - -If you want to apply someone else's patch then you should start with the -same original distribution source on which the patch is based. From within -the root of the distribution, run 'patch' feeding in the patch file as -standard input. The 'p1' option is required to strip the first element -of the path name (e.g. Template-Toolkit-2.05c/README becomes README which -is then the correct path). - - $ tar zxf Template-Toolkit-2.05c.tar.gz - $ cd Template-Toolkit-2.05c - $ patch -p1 < ../patch-TT205c-abw-xyz-hack - -The output generated by 'patch' should be something like the following: - - patching file README - patching file lib/Template.pm - patching file lib/Template/Provider.pm - patching file t/provider.t - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Manual/Intro.pod b/lib/Template/Manual/Intro.pod deleted file mode 100644 index c50c9e8..0000000 --- a/lib/Template/Manual/Intro.pod +++ /dev/null @@ -1,295 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Manual::Intro -# -# DESCRIPTION -# This section provides a general introduction to the Template -# Toolkit, giving a quick overview of features, examples of template -# directives and use of the Template.pm module. It also described the -# basic concept underlying the toolkit: the separation of -# presentation elements from application logic and data. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Manual::Intro - Introduction to the Template Toolkit - -=head1 DESCRIPTION - -This section provides a general introduction to the Template Toolkit, -giving a quick overview of features, examples of template directives -and use of the Template.pm module. It also described the basic concept -underlying the toolkit: the separation of presentation elements from -application logic and data. - -The Template Toolkit is a collection of modules which implement a -fast, flexible, powerful and extensible template processing system. -It was originally designed and remains primarily useful for generating -dynamic web content, but it can be used equally well for processing -any kind of text documents. This POD documentation is all generated -using the Template Toolkit batch mode utility F<ttree>, for example. - -At the simplest level it provides an easy way to process template -files, filling in embedded variable references with their equivalent -values. - - 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 '[%' ... '%]' but you can change these and various other -options to configure how the Template Toolkit looks, feels and works. -You can set the 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. - ... - -=head2 Template.pm - -The Template.pm module is the front end to the Template Toolkit, -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 Template.pm constructor, new(), which are then used -to configure the underlying objects. - - use Template; - - my $tt = Template->new({ - INCLUDE_PATH => '/usr/local/templates', - INTERPOLATE => 1, - }) || die "$Template::ERROR\n"; - -The Template object implements a 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 process() method returns true (1) on success and prints the -template output to STDOUT, by default. On error, the process() method -returns false (undef). The error() method can then be called to -retrieve details of the error. - -=head2 Component Based Content Construction - -A number of special directives are provided, such as INSERT, INCLUDE -and 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> - -=head2 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 '.' is used to access into lists and -hashes or to call object methods. The FOREACH directive is provided for -iterating through lists, and various logical tests are available using -directives such as IF, UNLESS, ELSIF, ELSE, SWITCH, CASE, etc. - - [% FOREACH section = menu %] - <a href="[% root %]/[% section %]/index.html">[% section %]</a> - [% END %] - - <b>Client</a>: [% 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 %] - -=head2 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. - -=head2 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. - -=head2 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. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Manual/Plugins.pod b/lib/Template/Manual/Plugins.pod deleted file mode 100644 index 7955640..0000000 --- a/lib/Template/Manual/Plugins.pod +++ /dev/null @@ -1,552 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Manual::Plugins -# -# DESCRIPTION -# This section lists the standard plugins which can be used to extend -# the runtime functionality of the Template Toolkit. The plugins are -# distributed with the Template Toolkit but may required additional -# modules from CPAN. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Manual::Plugins - Standard plugins - -=head1 DESCRIPTION - -This section lists the standard plugins which can be used to extend the -runtime functionality of the Template Toolkit. The plugins are -distributed with the Template Toolkit but may required additional -modules from CPAN. - - - -=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 Autoformat - -The Autoformat plugin is an interface to Damian Conway's Text::Autoformat -Perl module which provides advanced text wrapping and formatting. See -L<Template::Plugin::Autoformat> and L<Text::Autoformat> for further -details. - - [% USE autoformat(left=10, right=20) %] - [% autoformat(mytext) %] # call autoformat sub - [% mytext FILTER autoformat %] # or use autoformat filter - -The Text::Autoformat module is available from CPAN: - - http://www.cpan.org/modules/by-module/Text/ - -=head2 CGI - -The CGI plugin is a wrapper around Lincoln Stein's -E<lt>lstein@genome.wi.mit.eduE<gt> CGI.pm module. The plugin is -distributed with the Template Toolkit (see L<Template::Plugin::CGI>) -and the 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 int he 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 Date plugin provides an easy way to generate formatted time and date -strings by delegating to the POSIX 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 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 DBI plugin, developed by Simon Matthews -E<lt>sam@knowledgepool.comE<gt>, brings the full power of Tim Bunce's -E<lt>Tim.Bunce@ig.co.ukE<gt> database interface module (DBI) to your -templates. See L<Template::Plugin::DBI> and L<DBI> for further details. - - [% USE DBI('dbi:driver:database', 'user', 'pass') %] - - [% FOREACH user = DBI.query( 'SELECT * FROM users' ) %] - [% user.id %] [% user.name %] - [% END %] - -The DBI and relevant DBD modules are available from CPAN: - - http://www.cpan.org/modules/by-module/DBI/ - -=head2 Dumper - -The Dumper plugin provides an interface to the Data::Dumper module. See -L<Template::Plugin::Dumper> and L<Data::Dumper> for futher details. - - [% USE dumper(indent=0, pad="<br>") %] - [% dumper.dump(myvar, yourvar) %] - -=head2 File - -The 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; - } - - # 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 Format plugin provides a simple way to format text according to a -printf()-like format. See L<Template::Plugin::Format> for further -details. - - [% USE bold = format('<b>%s</b>') %] - [% bold('Hello') %] - -=head2 GD::Image, GD::Polygon, GD::Constants - -These plugins provide access to the GD graphics library via Lincoln -D. Stein's GD.pm interface. These plugins allow PNG, JPEG and other -graphical formats to be generated. - - [% FILTER null; - USE im = GD.Image(100,100); - # allocate some colors - black = im.colorAllocate(0, 0, 0); - red = im.colorAllocate(255,0, 0); - blue = im.colorAllocate(0, 0, 255); - # Draw a blue oval - im.arc(50,50,95,75,0,360,blue); - # And fill it with red - im.fill(50,50,red); - # Output image in PNG format - im.png | stdout(1); - END; - -%] - -See L<Template::Plugin::GD::Image> for further details. - -=head2 GD::Text, GD::Text::Align, GD::Text::Wrap - -These plugins provide access to Martien Verbruggen's GD::Text, -GD::Text::Align and GD::Text::Wrap modules. These plugins allow the -layout, alignment and wrapping of text when drawing text in GD images. - - [% FILTER null; - USE gd = GD.Image(200,400); - USE gdc = GD.Constants; - black = gd.colorAllocate(0, 0, 0); - green = gd.colorAllocate(0, 255, 0); - txt = "This is some long text. " | repeat(10); - USE wrapbox = GD.Text.Wrap(gd, - line_space => 4, - color => green, - text => txt, - ); - wrapbox.set_font(gdc.gdMediumBoldFont); - wrapbox.set(align => 'center', width => 160); - wrapbox.draw(20, 20); - gd.png | stdout(1); - END; - -%] - -See L<Template::Plugin::GD::Text>, L<Template::Plugin::GD::Text::Align> -and L<Template::Plugin::GD::Text::Wrap> for further details. - -=head2 GD::Graph::lines, GD::Graph::bars, GD::Graph::points, GD::Graph::linespoin -ts, GD::Graph::area, GD::Graph::mixed, GD::Graph::pie - -These plugins provide access to Martien Verbruggen's GD::Graph module -that allows graphs, plots and charts to be created. These plugins allow -graphs, plots and charts to be generated in PNG, JPEG and other -graphical formats. - - [% FILTER null; - data = [ - ["1st","2nd","3rd","4th","5th","6th"], - [ 4, 2, 3, 4, 3, 3.5] - ]; - USE my_graph = GD.Graph.pie(250, 200); - my_graph.set( - title => 'A Pie Chart', - label => 'Label', - axislabelclr => 'black', - pie_height => 36, - transparent => 0, - ); - my_graph.plot(data).png | stdout(1); - END; - -%] - -See -L<Template::Plugin::GD::Graph::lines>, -L<Template::Plugin::GD::Graph::bars>, -L<Template::Plugin::GD::Graph::points>, -L<Template::Plugin::GD::Graph::linespoints>, -L<Template::Plugin::GD::Graph::area>, -L<Template::Plugin::GD::Graph::mixed>, -L<Template::Plugin::GD::Graph::pie>, and -L<GD::Graph>, -for more details. - -=head2 GD::Graph::bars3d, GD::Graph::lines3d, GD::Graph::pie3d - -These plugins provide access to Jeremy Wadsack's GD::Graph3d -module. This allows 3D bar charts and 3D lines plots to -be generated. - - [% FILTER null; - data = [ - ["1st","2nd","3rd","4th","5th","6th","7th", "8th", "9th"], - [ 1, 2, 5, 6, 3, 1.5, 1, 3, 4], - ]; - USE my_graph = GD.Graph.bars3d(); - my_graph.set( - x_label => 'X Label', - y_label => 'Y label', - title => 'A 3d Bar Chart', - y_max_value => 8, - y_tick_number => 8, - y_label_skip => 2, - # shadows - bar_spacing => 8, - shadow_depth => 4, - shadowclr => 'dred', - transparent => 0, - my_graph.plot(data).png | stdout(1); - END; - -%] - -See -L<Template::Plugin::GD::Graph::lines3d>, -L<Template::Plugin::GD::Graph::bars3d>, and -L<Template::Plugin::GD::Graph::pie3d> -for more details. - -=head2 HTML - -The HTML plugin is very new and 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 (as discussed recently on the mod_perl mailing list). - - [% 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 Iterator plugin provides a way to create a Template::Iterator -object to iterate over a data set. An iterator is created -automatically by the FOREACH directive and is aliased to the 'loop' -variable. This plugin allows an iterator to be explicitly created -with a given name, or the default plugin name, '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 String - -The 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 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 URL plugin provides a simple way of contructing 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 Wrap plugin uses the Text::Wrap module by David Muir Sharnoff -E<lt>muir@idiom.comE<gt> (with help from Tim Pierce and many many others) -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 Text::Wrap module is available from CPAN: - - http://www.cpan.org/modules/by-module/Text/ - -=head2 XML::DOM - -The XML::DOM plugin gives access to the XML Document Object Module via -Clark Cooper E<lt>cooper@sch.ge.comE<gt> and Enno Derksen's -E<lt>enno@att.comE<gt> XML::DOM module. See L<Template::Plugin::XML::DOM> -and L<XML::DOM> for further details. - - [% USE dom = XML.DOM %] - [% doc = dom.parse(filename) %] - - [% FOREACH node = doc.getElementsByTagName('CODEBASE') %] - * [% node.getAttribute('href') %] - [% END %] - -The plugin requires the XML::DOM module, available from CPAN: - - http://www.cpan.org/modules/by-module/XML/ - -=head2 XML::RSS - -The XML::RSS plugin is a simple interface to Jonathan Eisenzopf's -E<lt>eisen@pobox.comE<gt> XML::RSS module. A RSS (Rich Site Summary) -file is typically used to store short news 'headlines' describing -different links within a site. This plugin allows you to parse RSS -files and format the contents accordingly using templates. -See L<Template::Plugin::XML::RSS> and L<XML::RSS> for further details. - - [% USE news = XML.RSS(filename) %] - - [% FOREACH item = news.items %] - <a href="[% item.link %]">[% item.title %]</a> - [% END %] - -The XML::RSS module is available from CPAN: - - http://www.cpan.org/modules/by-module/XML/ - -=head2 XML::Simple - -This plugin implements an interface to the L<XML::Simple|XML::Simple> -module. - - [% USE xml = XML.Simple(xml_file_or_text) %] - - [% xml.head.title %] - -See L<Template::Plugin::XML::Simple> for further details. - -=head2 XML::Style - -This plugin defines a filter for performing simple stylesheet based -transformations of XML text. - - [% USE xmlstyle - table = { - attributes = { - border = 0 - cellpadding = 4 - cellspacing = 1 - } - } - %] - - [% FILTER xmlstyle %] - <table> - <tr> - <td>Foo</td> <td>Bar</td> <td>Baz</td> - </tr> - </table> - [% END %] - -See L<Template::Plugin::XML::Style> for further details. - -=head2 XML::XPath - -The XML::XPath plugin provides an interface to Matt Sergeant's -E<lt>matt@sergeant.orgE<gt> XML::XPath module. See -L<Template::Plugin::XML::XPath> and L<XML::XPath> for further details. - - [% USE xpath = XML.XPath(xmlfile) %] - [% FOREACH page = xpath.findnodes('/html/body/page') %] - [% page.getAttribute('title') %] - [% END %] - -The plugin requires the XML::XPath module, available from CPAN: - - http://www.cpan.org/modules/by-module/XML/ - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Manual/Refs.pod b/lib/Template/Manual/Refs.pod deleted file mode 100644 index b0c9719..0000000 --- a/lib/Template/Manual/Refs.pod +++ /dev/null @@ -1,171 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Manual::Refs -# -# DESCRIPTION -# This section provides references to external modules, projects and -# other resources related to the Template Toolkit. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Manual::Refs - Related modules, projects and other resources - -=head1 DESCRIPTION - -This section provides references to external modules, projects and -other resources related to the Template Toolkit. - -=head2 Resources - -The Template Toolkit web site contains the latest information, news and -other resources. - - http://www.template-toolkit.org/ - -A mailing list exists for up-to-date information on the Template Toolkit -and for following and contributing to the development process. To -subscribe, send an email to - - templates-request@template-toolkit.org - -with the message 'subscribe' in the body. You can also use the web -interface to subscribe or browse the archives: - - http://www.template-toolkit.org/mailman/listinfo/templates - -The F<tpage> and F<ttree> scripts are distributed and installed along -with the Template Toolkit. The F<tpage> script simply processes named -files or STDIN if unspecified, using a default Template object. The -F<ttree> script can be used to process entire directory trees of templates, -allowing large content systems such as web sites to be rebuilt from a -single command or configuration file. - - perldoc tpage - perldoc ttree - -The F<Template::Tutorial> document provides an introduction to the Template -Toolkit and shows some typical examples of usage. - - perldoc Template::Tutorial - -You may also like to consult the paper 'Building and Managing Web Systems -with the Template Toolkit' and accompanying slides from the presentation -at the 4th Perl Conference. These are available from the Template -Toolkit web site: - - http://www.template-toolkit.org/docs.html - - - -=head2 Projects - -There are a number of other projects related to the Template Toolkit. - -=over 4 - -=item OpenInteract - -OpenInteract is a robust web application framework built to run under -Apache and mod_perl using the Template Toolkit as a foundation. - - http://www.openinteract.org/ - -=item Apache::Template - -This is an Apache/mod_perl interface to the Template Toolkit. Available -from CPAN in the directory: - - http://www.cpan.org/modules/by-module/Apache/ - -=item AxKit::Template - -AxKit is Matt Sergeant's Apache XML Delivery Toolkit. AxKit::Template -provides an interface between AxKit and the Template Toolkit. Available -from CPAN in the directory: - - http://www.cpan.org/modules/by-module/Apache/ - -=item Slashcode - -Slashcode is the code which runs Slashdot. Version 2 uses the -Template Toolkit for generating the user interface from database -driven template. - - http://slashcode.org/ - -=item OpenFrame - -OpenFrame is an open source application framework for distributed -media applications. It ships with a generator for the Template -Toolkit. - - http://openframe.fotango.com/ - -=item PCMT - -PCMT is the Personal Content Management Toolkit. It uses the Template -Toolkit as the presentation engine. - - http://pcmt.sf.net/ - -=back - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Manual/Syntax.pod b/lib/Template/Manual/Syntax.pod deleted file mode 100644 index cc1b6c8..0000000 --- a/lib/Template/Manual/Syntax.pod +++ /dev/null @@ -1,306 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Manual::Syntax -# -# DESCRIPTION -# This section describes the syntax, structure and semantics of the -# Template Toolkit directives and general presentation language. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Manual::Syntax - Directive syntax, structure and semantics - -=head1 DESCRIPTION - -This section describes the syntax, structure and semantics of the -Template Toolkit directives and general presentation language. - -=head2 Tag Styles - -By default, template directives are embedded within the character sequences -'[%' and '%]'. e.g. - - [% 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 START_TAG, END_TAG and -TAG_STYLE configuration options. You can also use the TAGS directive -to define a new tag style for the current template file. - -You can also set the INTERPOLATE option to allow simple variable -references to be embedded directly in templates, prefixed by a '$'. - - # 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%]) - -=head2 Comments - -The '#' 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> - %] - -=head2 Chomping Whitespace - -You can add '-' or '+' to the immediate start or end of a directive -tag to control the whitespace chomping options. See the PRE_CHOMP and -POST_CHOMP options for further details. - - [% BLOCK foo -%] # remove trailing newline - This is block foo - [%- END %] # remove leading newline - -=head2 Implicit Directives: GET and SET - -The simplest directives are GET and SET which retrieve and update -variable values respectively. The GET and 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 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 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 'stop' which is -entirely separate from the STOP directive. - - [% stop = 'Clackett Lane Bus Depot' %] - - The bus will next stop at [% stop %] # variable - - [% STOP %] # directive - -=head2 Block Directives - -Directives such as FOREACH, WHILE, BLOCK, FILTER, etc., mark the start -of a block which may contain text or other directives up to the -matching END directive. Blocks may be nested indefinitely. The -IF, UNLESS, ELSIF and 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 %] - -=head2 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 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 %] - -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 IF block which returns -'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 %] - -=head2 Chaining Filters - -Multiple 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, '|', can also be used as an alias for FILTER. - - [% PROCESS somefile | truncate(100) | html %] - -=head2 Multiple Directive Blocks - -Multiple directives can be included within a single tag when delimited -by semi-colons, ';'. Note however that the 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 %] - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Manual/VMethods.pod b/lib/Template/Manual/VMethods.pod deleted file mode 100644 index 7e380fa..0000000 --- a/lib/Template/Manual/VMethods.pod +++ /dev/null @@ -1,529 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Manual::VMethods -# -# DESCRIPTION -# The Template Toolkit provides virtual methods for manipulating -# variable values. Most of them are analogous to regular Perl -# functions of the same names. This section describes the different -# virtual methods that can be applied to scalar, list and hash -# values. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Manual::VMethods - Virtual Methods - -=head1 DESCRIPTION - -The Template Toolkit provides virtual methods for manipulating variable -values. Most of them are analogous to regular Perl functions of the -same names. This section describes the different virtual methods that -can be applied to scalar, list and hash values. - -=head2 Scalar Virtual Methods - -=over 4 - -=item defined - -Returns true if the value is defined. - - [% user = get_user(uid) IF uid.defined %] - -=item length - -Returns the length of the string representation of the item: - - [% IF password.length < 8 %] - Password too short, dumbass! - [% END %] - -=item repeat(n) - -Repeat the string a specified number of times. - - [% name = 'foo' %] - [% name.repeat(3) %] # foofoofoo - -=item 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 - -=item match(pattern) - -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); - %] - -=item search(pattern) - -Performs a similar function to '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 'match'. Move along -now, there's nothing more to see here. - -=item split(pattern) - -Calls Perl's split() function to split a string into a list of -strings. - - [% FOREACH dir = mypath.split(':') %] - [% dir %] - [% END %] - -=item 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 - -=item 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 '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 - -=item hash - -Return the value as a hash reference containing a single entry with -the key 'value' indicating the original scalar value. As with the -'list' virtual method, this is generally used to help massage data -into different formats. - -=item size - -Always returns 1 for scalar values. This method is provided for -consistency with the hash and list size methods. - -=back - - -=head2 Hash Virtual Methods - -=over 4 - -=item keys, values, each - -The regular hash operators returning lists of keys, values or both. -Note how we use a '$' prefix on the 'key' variable in this example to -have it interpolated (i.e. replaced with its value) before use. - - [% FOREACH key = product.keys %] - [% key %] => [% product.$key %] - [% END %] - -=item sort, nsort - -Return a list of the keys, sorted alphabetically (sort) or numerically -(nsort) according to the corresponding values in the hash. - - [% FOREACH n = phones.sort %] - [% phones.$n %] is [% n %], - [% END %] - -=item import - -The 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 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 - -=item 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' %] - -=item size - -Returns the number of key =E<gt> value pairs in the hash. - -=item item - -Returns an item from the hash using a key passed as an argument. - - [% hash.item('foo') %] # same as hash.foo - -=item list - -Returns the contents of the hash in list form. An argument can be -passed to indicate the desired items required in the list: 'keys' to -return a list of the keys (same as hash.keys), 'values' to return a -list of the values (same as hash.values), or 'each' to return as list -of (key, value) pairs (same as hash.each). When called without an -argument it returns a list of hash references, each of which contains -a 'key' and 'value' item representing a single key =E<gt> value pair -in the hash. - -=back - - -=head2 List Virtual Methods - -=over 4 - -=item 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(", ") %]. - -=item 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 - -=item reverse - -Returns the items of the list in reverse order. - - [% FOREACH s = scores.reverse %] - ... - [% END %] - -=item join - -Joins the items in the list into a single string, using Perl's join -function. - - [% items.join(', ') %] - -=item grep - -Returns a list of the items in the list that match a regular expression -pattern. - - [% FOREACH directory.files.grep('\.txt$') %] - ... - [% END %] - -=item sort, nsort - -Returns the items in alpha (sort) or numerical (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 'books' list can contains hash references with -an 'author' key or objects with an 'author' method. - -=item unshift(item), push(item) - -Adds an item to the start/end of a list. - - [% mylist.unshift('prev item') %] - [% mylist.push('next item') %] - -=item shift, pop - -Removes the first/last item from the list and returns it. - - [% first = mylist.shift %] - [% last = mylist.pop %] - -=item 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 %] - -=item 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. - -=item slice(from, to) - -Returns a slice of items in the list between the bounds passed as -arguments. If the second argument, '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) %] - -=item splice(offset, length, list) - -Behaves just like Perl's splice() function allowing you to selectively -remove and/or replace elements in a list. It removes 'length' items -from the list, starting at 'offset' and replaces them with the items -in '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 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 ]); - %] - -=back - -=head2 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). 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 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 'something' is bound to a subroutine -which might return 1 or more items: - - [% FOREACH item = 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 'first' method, for example, then that -will be called, as expected, in preference to the list virtual method. - -=head2 Defining Custom Virtual Methods - -You can define your own virtual methods for scalars, lists and hash -arrays. The Template::Stash package variables $SCALAR_OPS, $LIST_OPS -and $HASH_OPS are references to hash arrays that define these virtual -methods. HASH_OPS and LIST_OPS methods are subroutines that accept a -hash/list reference as the first item. 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 ]; - }; - -template: - - [% primes = [ 2, 3, 5, 7, 9 ] %] - [% primes.odd.join(', ') %] # 3, 5, 7, 9 - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Manual/Variables.pod b/lib/Template/Manual/Variables.pod deleted file mode 100644 index e8d998c..0000000 --- a/lib/Template/Manual/Variables.pod +++ /dev/null @@ -1,868 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Manual::Variables -# -# DESCRIPTION -# This section describes the different ways in which Perl data can be -# bound to template variables and accessed via Template Toolkit -# directives. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Manual::Variables - Template variables and code bindings - -=head1 DESCRIPTION - -This section describes the different ways in which Perl data can be -bound to template variables and accessed via Template Toolkit -directives. - -=head2 Template Variables - -A reference to a hash array may be passed as the second argument to -the process() method, containing definitions of template variables. -The VARIABLES (a.k.a. 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); - -'myfile': - - This is version [% version %] ([% release %]). - Serial number: [% serial_no %] - -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 'foo', -'Foo' and '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: - - 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'), - }; - -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') %] - -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 '.' operator. - - my $vars = { - 'home' => 'http://www.myserver.com/homepage.html', - 'page' => { - 'this' => 'mypage.html', - 'next' => 'nextpage.html', - 'prev' => 'prevpage.html', - }, - }; - -template: - - <a href="[% home %]">Home</a> - <a href="[% page.prev %]">Previous Page</a> - <a href="[% page.next %]">Next Page</a> - -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 '_' or '.' 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 -DEBUG option is enabled). - - my $vars = { - message => 'Hello World!', - _secret => "On the Internet, no-one knows you're a dog", - thing => { - public => 123, - _private => 456, - '.hidden' => 789, - }, - }; - -template: - - [% message %] # outputs "Hello World!" - [% _secret %] # no output - [% thing.public %] # outputs "123" - [% thing._private %] # no output - [% thing..hidden %] # ERROR: unexpected token (..) - -To access a hash entry using a key stored in another variable, prefix -the key variable with '$' to have it interpolated before use (see -L<Variable Interpolation>). - - [% pagename = 'next' %] - [% page.$pagename %] # same as [% page.next %] - -When you assign to a variable that contains multiple namespace -elements (i.e. it has one or more '.' characters in the name), -any hashes required to represent intermediate namespaces will be -created automatically. In this following example, the '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 - -output: - - The XYZ-2000 Bogon Generator - costs $666.00 - -You can use Perl's familiar '{' ... '}' construct to explicitly create -a hash and assign it to a variable. Note that commas are optional -between key/value pairs and '=' can be used in place of '=E<gt>'. - - [% product = { - id => 'XYZ-2000', - desc => 'Bogon Generator', - price => 666, - } - %] - -=head2 List References - -Items in lists are also accessed by use of the dot operator. - - my $vars = { - 'people' => [ 'Tom', 'Dick', 'Larry' ], - }; - -template: - - [% people.0 %] # Tom - [% people.1 %] # Dick - [% people.2 %] # Larry - -The FOREACH directive can be used to iterate through items in a list. - - [% FOREACH person = people %] - Hello [% person %] - [% END %] - -output: - - Hello Tom - Hello Dick - Hello Larry - -Lists can be constructed in-situ using the regular anonymous list -'[' ... ']' construct. Commas between items are optional. - - [% cols = [ 'red', 'green', 'blue' ] %] - - [% FOREACH c = cols %] - ... - -or: - - [% FOREACH c = [ 'red', 'green', 'blue' ] %] - ... - -You can also create simple numerical sequences using the familiar '..' -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!', @_) }, - }; - -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'), - }; - -template: - - [% FOREACH p = cgi.param %] # returns list of param keys - [% p %] => [% cgi.param(p) %] # fetch each param value - [% END %] - -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 Parameters and Return 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 '=E<gt>' or '=' 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 } || ' + ', @_); - } - -template: - - [% myjoin(10, 20, 30) %] - [% myjoin(10, 20, 30, joint = ' - ' %] - [% myjoin(joint => ' * ', 10, 20, 30 %] - -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' ) }, - }; - -template: - - [% FOREACH i = items1 %] - ... - [% END %] - - [% FOREACH i = items2 %] - ... - [% END %] - -=head2 Error Handling - -Errors can be reported from user code by calling 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 'error' -variable. - - my $vars = { - barf => sub { - die "a sick error has occurred\n"; - }, - }; - -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 die() are converted to exceptions of type -'undef'. Exceptions of user-defined types can be thrown by calling -die() with a reference to a Template::Exception object. - - use Template::Exception; - - ... - - my $vars = { - login => sub { - ... - die Template::Exception->new('badpwd', - 'password too silly'); - }, - }; - -template: - - [% TRY %] - [% login %] - [% CATCH badpwd %] - Bad password: [% error.info %] - [% CATCH %] - Some other '[% error.type %]' error: [% error.info %] - [% END %] - -The exception types 'stop' and 'return' are used to implement the -STOP and RETURN directives. Throwing an exception as: - - die (Template::Exception->new('stop')); - -has the same effect as the directive: - - [% STOP %] - -Subroutines and methods can also raise errors by returning a list or -reference to a list containing the undefined value (undef) followed by -an exception object or error message. This is supported for backwards -compatibility with version 1 but may be deprecated in some future -version. - - my $vars = { - # currently equivalent - barf => sub { - die "I'm sorry Dave, I can't do that"; - }, - yack => sub { - return (undef, "I'm sorry Dave, I can't do that"); - }, - }; - -=head2 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 '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 '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. - -=head2 Variable Interpolation - -The Template Toolkit uses '$' 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 INTERPOLATE option is set: - - Dear $honorific $firstname $surname, - -The same rules apply within directives. If a variable is prefixed -with a '$' 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' %] - [% userlist.$uid %] # same as 'userlist.abw' - -Curly braces can be used to delimit interpolated variable names where -necessary. - - [% userlist.${me.id}.name %] - -Directives such as INCLUDE, PROCESS, etc., that accept a template name -as the first argument, will automatically quote it for convenience. - - [% INCLUDE foo/bar.txt %] - -equivalent to: - - [% INCLUDE "foo/bar.txt" %] - -To INCLUDE a template whose name is stored in a variable, simply -prefix the variable name with '$' to have it interpolated. - - [% myfile = 'header' %] - [% INCLUDE $myfile %] - -equivalent to: - - [% INCLUDE header %] - -Note also that a variable containing a reference to a Template::Document -object can also be processed in this way. - - my $vars = { - header => Template::Document->new({ ... }), - }; - -template: - - [% INCLUDE $header %] - -=head2 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 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 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 %] - -=head2 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 CONSTANTS hash as a -constructor item as per VARIABLES. The 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 '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 -'joint' is a runtime variable and cannot be determined at compile -time. - - # ERROR: runtime variable argument! - [% constants.col.keys.sort.join(joint) %] - -The 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 %] - -=head2 Special Variables - -A number of special variables are automatically defined by the Template -Toolkit. - -=over 4 - -=item template - -The 'template' variable contains a reference to the main template -being processed, in the form of a Template::Document object. This -variable is correctly defined within PRE_PROCESS, PROCESS and -POST_PROCESS templates, allowing standard headers, footers, etc., to -access metadata items from the main template. The 'name' and -'modtime' metadata items are automatically provided, giving the -template name and modification time in seconds since the epoch. - -Note that the 'template' variable always references the top-level -template, even when processing other template components via INCLUDE, -PROCESS, etc. - -=item component - -The 'component' variable is like 'template' but always contains a -reference to the current, innermost template component being processed. -In the main template, the 'template' and 'component' variable will -reference the same Template::Document object. In any other template -component called from the main template, the 'template' variable -will remain unchanged, but 'component' will contain a new reference -to the current component. - -This example should demonstrate the difference: - - $template->process('foo') - || die $template->error(), "\n"; - -'foo': - - [% template.name %] # foo - [% component.name %] # foo - [% PROCESS footer %] - -'footer': - - [% template.name %] # foo - [% component.name %] # footer - -=item loop - -Within a FOREACH loop, the 'loop' variable references the Template::Iterator -object responsible for controlling the loop. - - [% FOREACH item = [ 'foo', 'bar', 'baz' ] -%] - [% "Items:\n" IF loop.first -%] - [% loop.count %]/[% loop.size %]: [% item %] - [% END %] - -=item error - -Within a CATCH block, the 'error' variable contains a reference to the -Template::Exception object thrown from within the TRY block. The -'type' and 'info' methods can be called or the variable itself can -be printed for automatic stringification into a message of the form -"$type error - $info". See L<Template::Exception> for further details. - - [% TRY %] - ... - [% CATCH %] - [% error %] - [% END %] - -=item content - -The 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 %] - <table border=1> - <tr> - <td> - [% content %] - </td> - </tr> - </table> - [% END %] - -=back - -=head2 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. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Manual/Views.pod b/lib/Template/Manual/Views.pod deleted file mode 100644 index 7bc53b0..0000000 --- a/lib/Template/Manual/Views.pod +++ /dev/null @@ -1,642 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Manual::Views -# -# DESCRIPTION -# This section describes dynamic views: a powerful but experimental -# new feature in version 2.01 of the Template Toolkit. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Manual::Views - Template Toolkit views (experimental) - -=head1 DESCRIPTION - -This section describes dynamic views: a powerful but experimental new -feature in version 2.01 of the Template Toolkit. - -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 -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 independant, 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. - -=head2 Views as Template Collectors/Providers - -The 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 END directive. - - [% VIEW myview %] - ... - [% END %] - -The first role of a view is to act as a collector and provider of templates. -The include() method can be called on a view to effectively do the same -thing as the 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 'prefix' and '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 AUTOLOAD method which maps method names to the -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') %] - -=head2 Local BLOCK Definitions - -A VIEW definition can include BLOCK definitions which remain local to -the view. A request for a particular template will return a 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 BLOCK definitions, a VIEW can contain any other -template directives. The entire VIEW definition block is processed to -initialise the view but no output is generated (this may change RSN - -and get stored as 'output' item, subsequently accessible as [% -view.output %]). However, directives that have side-effects, such as -those that update a variable, will have noticable consequences. - -=head2 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 (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 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 'title' as a simple variable, a template -defined in an external file, possibly with a prefix/suffix automatically -appended, or as a local BLOCK definition within the [% VIEW %] ... [% END %] -definition. If you use the syntax above then the view will Do The Right -Thing to return the appropriate output. - -At the END of the 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 END of the VIEW definition block then -an '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 '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 'base' -parameter. This example shows how a base class view is defined which -applies a '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 '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 INCLUDE/PROCESS/WRAPPER directives work entirely -independantly 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 -VIEW ... END block by its specified name and also by the special name -'view' (similar to the C<my $self = shift;> in a Perl method or the -'this' pointer in C++, etc). The view is initially unsealed allowing -any data items to be defined and updated within the 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 (SEALED), it should be possible to set an option in the view to -allow external contexts to update existing variables (UPDATE) or even -create totally new view variables (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, 'fancy', or by the general name, 'view'. Outside of the -view block, however, you should always use the given name, 'fancy': - - [% fancy.title %] - [% fancy.author %] - [% fancy.col.bg %] - -The choice of given name or 'view' is much more important when it -comes to BLOCK definitions within a VIEW. It is generally recommended -that you use 'view' inside a 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 '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 'foo' variable, the header -block still correctly accesses the 'title' attribute of the view to -which it belongs. Whenever a view BLOCK is processed, the '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 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 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 '::' converted to a single '_'. - - [% 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 ('thingies' and '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 'default' map entry, specified as part of the 'map' -hash or as a parameter by itself. - - - [% VIEW foo - map = { ... }, - default = 'whatever' - %] - ... - [% END %] - -or - - [% VIEW foo %] - [% view.map = { ... } - view.default = 'whatever' - %] - ... - [% END %] - -The print() method provides one more piece of magic. If you pass it a -reference to an object which provides a 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 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 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 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 XML::DOM trees. The documentation for the -Template::Plugins::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 File/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 'pod/html/head1', 'pod/html/head2', '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: t/pod.t and -t/view.t which may shed some more light on this. See the distribution -sub-directory 'examples/pod/html' for examples of Pod -E<gt> HTML templates. - -(This documentation is incomplete but I'm not going to get it 100% pefect -until the syntax and API stabilise). - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Modules.pod b/lib/Template/Modules.pod deleted file mode 100644 index 78dadb8..0000000 --- a/lib/Template/Modules.pod +++ /dev/null @@ -1,448 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Modules -# -# DESCRIPTION -# This section contains the documentation for the modules that -# comprise the Template Toolkit. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Modules - Core modules comprising the Template Toolkit - -=head1 DESCRIPTION - -This section contains the documentation for the modules that comprise -the Template Toolkit. - -=over 4 - -=item L<Template|Template> - -Front-end module to the Template Toolkit - - - -=item L<Template::Base|Template::Base> - -Base class module implementing common functionality - - - -=item L<Template::Config|Template::Config> - -Factory module for instantiating other TT2 modules - - - -=item L<Template::Constants|Template::Constants> - -Defines constants for the Template Toolkit - - - -=item L<Template::Context|Template::Context> - -Runtime context in which templates are processed - - - -=item L<Template::Document|Template::Document> - -Compiled template document object - - - -=item L<Template::Exception|Template::Exception> - -Exception handling class module - - - -=item L<Template::Filters|Template::Filters> - -Post-processing filters for template blocks - - - -=item L<Template::Iterator|Template::Iterator> - -Data iterator used by the FOREACH directive - - - -=item L<Template::Namespace::Constants|Template::Namespace::Constants> - -Compile time constant folding - - - -=item L<Template::Parser|Template::Parser> - -LALR(1) parser for compiling template documents - - - -=item L<Template::Plugin|Template::Plugin> - -Base class for Template Toolkit plugins - - - -=item L<Template::Plugins|Template::Plugins> - -Plugin provider module - - - -=item L<Template::Provider|Template::Provider> - -Provider module for loading/compiling templates - - - -=item L<Template::Service|Template::Service> - -General purpose template processing service - - - -=item L<Template::Stash|Template::Stash> - -Magical storage for template variables - - - -=item L<Template::Stash::Context|Template::Stash::Context> - -Experimetal stash allowing list/scalar context definition - - - -=item L<Template::Stash::XS|Template::Stash::XS> - -Experimetal high-speed stash written in XS - - - -=item L<Template::Test|Template::Test> - -Module for automating TT2 test scripts - - - -=item L<Template::Plugin::Autoformat|Template::Plugin::Autoformat> - -Interface to Text::Autoformat module - - - -=item L<Template::Plugin::CGI|Template::Plugin::CGI> - -Interface to the CGI module - - - -=item L<Template::Plugin::DBI|Template::Plugin::DBI> - -Template interface to the DBI module - - - -=item L<Template::Plugin::Datafile|Template::Plugin::Datafile> - -Plugin to construct records from a simple data file - - - -=item L<Template::Plugin::Date|Template::Plugin::Date> - -Plugin to generate formatted date strings - - - -=item L<Template::Plugin::Directory|Template::Plugin::Directory> - -Plugin for generating directory listings - - - -=item L<Template::Plugin::Dumper|Template::Plugin::Dumper> - -Plugin interface to Data::Dumper - - - -=item L<Template::Plugin::File|Template::Plugin::File> - -Plugin providing information about files - - - -=item L<Template::Plugin::Filter|Template::Plugin::Filter> - -Base class for plugin filters - - - -=item L<Template::Plugin::Format|Template::Plugin::Format> - -Plugin to create formatting functions - - - -=item L<Template::Plugin::GD::Image|Template::Plugin::GD::Image> - -Interface to GD Graphics Library - - - -=item L<Template::Plugin::GD::Polygon|Template::Plugin::GD::Polygon> - -Interface to GD module Polygon class - - - -=item L<Template::Plugin::GD::Constants|Template::Plugin::GD::Constants> - -Interface to GD module constants - - - -=item L<Template::Plugin::GD::Text|Template::Plugin::GD::Text> - -Text utilities for use with GD - - - -=item L<Template::Plugin::GD::Text::Align|Template::Plugin::GD::Text::Align> - -Draw aligned strings in GD images - - - -=item L<Template::Plugin::GD::Text::Wrap|Template::Plugin::GD::Text::Wrap> - -Break and wrap strings in GD images - - - -=item L<Template::Plugin::GD::Graph::lines|Template::Plugin::GD::Graph::lines> - -Create line graphs with axes and legends - - - -=item L<Template::Plugin::GD::Graph::lines3d|Template::Plugin::GD::Graph::lines3d> - -Create 3D line graphs with axes and legends - - - -=item L<Template::Plugin::GD::Graph::bars|Template::Plugin::GD::Graph::bars> - -Create bar graphs with axes and legends - - - -=item L<Template::Plugin::GD::Graph::bars3d|Template::Plugin::GD::Graph::bars3d> - -Create 3D bar graphs with axes and legends - - - -=item L<Template::Plugin::GD::Graph::points|Template::Plugin::GD::Graph::points> - -Create point graphs with axes and legends - - - -=item L<Template::Plugin::GD::Graph::linespoints|Template::Plugin::GD::Graph::linespoints> - -Create line/point graphs with axes and legends - - - -=item L<Template::Plugin::GD::Graph::area|Template::Plugin::GD::Graph::area> - -Create area graphs with axes and legends - - - -=item L<Template::Plugin::GD::Graph::mixed|Template::Plugin::GD::Graph::mixed> - -Create mixed graphs with axes and legends - - - -=item L<Template::Plugin::GD::Graph::pie|Template::Plugin::GD::Graph::pie> - -Create pie charts with legends - - - -=item L<Template::Plugin::GD::Graph::pie3d|Template::Plugin::GD::Graph::pie3d> - -Create 3D pie charts with legends - - - -=item L<Template::Plugin::HTML|Template::Plugin::HTML> - -Plugin to create HTML elements - - - -=item L<Template::Plugin::Image|Template::Plugin::Image> - -Plugin access to image sizes - - - -=item L<Template::Plugin::Iterator|Template::Plugin::Iterator> - -Plugin to create iterators (Template::Iterator) - - - -=item L<Template::Plugin::Math|Template::Plugin::Math> - -Plugin interface to mathematical functions - - - -=item L<Template::Plugin::Pod|Template::Plugin::Pod> - -Plugin interface to Pod::POM (Pod Object Model) - - - -=item L<Template::Plugin::Procedural|Template::Plugin::Procedural> - -Base class for procedural plugins - - - -=item L<Template::Plugin::String|Template::Plugin::String> - -Object oriented interface for string manipulation - - - -=item L<Template::Plugin::Table|Template::Plugin::Table> - -Plugin to present data in a table - - - -=item L<Template::Plugin::URL|Template::Plugin::URL> - -Plugin to construct complex URLs - - - -=item L<Template::Plugin::View|Template::Plugin::View> - -Plugin to create views (Template::View) - - - -=item L<Template::Plugin::Wrap|Template::Plugin::Wrap> - -Plugin interface to Text::Wrap - - - -=item L<Template::Plugin::XML::DOM|Template::Plugin::XML::DOM> - -Plugin interface to XML::DOM - - - -=item L<Template::Plugin::XML::RSS|Template::Plugin::XML::RSS> - -Plugin interface to XML::RSS - - - -=item L<Template::Plugin::XML::Simple|Template::Plugin::XML::Simple> - -Plugin interface to XML::Simple - - - -=item L<Template::Plugin::XML::Style|Template::Plugin::XML::Style> - -Simple XML stylesheet transfomations - - - -=item L<Template::Plugin::XML::XPath|Template::Plugin::XML::XPath> - -Plugin interface to XML::XPath - - - - - -=back - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Namespace/Constants.pm b/lib/Template/Namespace/Constants.pm deleted file mode 100644 index e1b5114..0000000 --- a/lib/Template/Namespace/Constants.pm +++ /dev/null @@ -1,205 +0,0 @@ -#================================================================= -*-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@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2002 Andy Wardley. All Rights Reserved. -# Copyright (C) 1998-2002 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. -# -# REVISION -# $Id: Constants.pm,v 1.22 2004/01/13 16:20:36 abw Exp $ -# -#============================================================================ - -package Template::Namespace::Constants; - -use strict; -use Template::Base; -use Template::Config; -use Template::Directive; -use Template::Exception; - -use base qw( Template::Base ); -use vars qw( $VERSION $DEBUG ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.22 $ =~ /(\d+)\.(\d+)/); -$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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 Template::Namespace::Constants module implements a namespace handler -which is plugged into the Template::Directive compiler module. This then -performs compile time constant folding of variables in a particular namespace. - -=head1 PUBLIC 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@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -1.22, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Directive|Template::Directive> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Parser.pm b/lib/Template/Parser.pm deleted file mode 100644 index 68bf9e0..0000000 --- a/lib/Template/Parser.pm +++ /dev/null @@ -1,1446 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Parser -# -# DESCRIPTION -# This module implements a LALR(1) parser and assocated 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@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -# 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Parser.pm,v 2.81 2004/01/13 16:19:15 abw Exp $ -# -#============================================================================ - -package Template::Parser; - -require 5.004; - -use strict; -use vars qw( $VERSION $DEBUG $ERROR ); -use base qw( Template::Base ); -use vars qw( $TAG_STYLE $DEFAULT_STYLE $QUOTED_ESCAPES ); - -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; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.81 $ =~ /(\d+)\.(\d+)/); -$DEBUG = 0 unless defined $DEBUG; -$ERROR = ''; - - -#======================================================================== -# -- COMMON TAG STYLES -- -#======================================================================== - -$TAG_STYLE = { - 'default' => [ '\[%', '%\]' ], - 'template1' => [ '[\[%]%', '%[\]%]' ], - 'metatext' => [ '%%', '%%' ], - 'html' => [ '<!--', '-->' ], - 'mason' => [ '<%', '>' ], - 'asp' => [ '<%', '%>' ], - 'php' => [ '<\?', '\?>' ], - 'star' => [ '\[\*', '\*\]' ], -}; -$TAG_STYLE->{ template } = $TAG_STYLE->{ tt2 } = $TAG_STYLE->{ default }; - - -$DEFAULT_STYLE = { - START_TAG => $TAG_STYLE->{ default }->[0], - END_TAG => $TAG_STYLE->{ default }->[1], -# TAG_STYLE => 'default', - ANYCASE => 0, - INTERPOLATE => 0, - PRE_CHOMP => 0, - POST_CHOMP => 0, - V1DOLLAR => 0, - EVAL_PERL => 0, -}; - -$QUOTED_ESCAPES = { - n => "\n", - r => "\r", - t => "\t", -}; - - -#======================================================================== -# ----- PUBLIC METHODS ----- -#======================================================================== - -#------------------------------------------------------------------------ -# new(\%config) -# -# Constructor method. -#------------------------------------------------------------------------ - -sub new { - my $class = shift; - my $config = $_[0] && UNIVERSAL::isa($_[0], 'HASH') ? shift(@_) : { @_ }; - my ($tagstyle, $debug, $start, $end, $defaults, $grammar, $hash, $key, $udef); - - my $self = bless { - START_TAG => undef, - END_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 => '', - 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(); - }; - - # build a FACTORY object to include any NAMESPACE definitions, - # but only if FACTORY isn't already an object - if ($config->{ NAMESPACE } && ! ref $self->{ FACTORY }) { - my $fclass = $self->{ FACTORY }; - $self->{ FACTORY } = $fclass->new( NAMESPACE => $config->{ NAMESPACE } ) - || return $class->error($fclass->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; -} - - -#------------------------------------------------------------------------ -# 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, $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) = @$tags; - $config->{ START_TAG } ||= $start; - $config->{ END_TAG } ||= $end; - } - - foreach $key (keys %$DEFAULT_STYLE) { - $style->{ $key } = $config->{ $key } if defined $config->{ $key }; - } - push(@$styles, $style); - return $style; -} - - -#------------------------------------------------------------------------ -# 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 } = [ ]; - - $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, - 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, $prechomp, $postchomp, $interp ) = - @$style{ qw( START_TAG END_TAG PRE_CHOMP POST_CHOMP INTERPOLATE ) }; - - my @tokens = (); - my $line = 1; - - return \@tokens ## RETURN ## - unless defined $text && length $text; - - # extract all directives from the text - while ($text =~ s/ - ^(.*?) # $1 - start of line up to directive - (?: - $start # start of tag - (.*?) # $2 - tag contents - $end # end of tag - ) - //sx) { - - ($pre, $dir) = ($1, $2); - $pre = '' unless defined $pre; - $dir = '' unless defined $dir; - - $postlines = 0; # denotes lines chomped - $prelines = ($pre =~ tr/\n//); # NULL - count only - $dirlines = ($dir =~ tr/\n//); # ditto - - # the directive CHOMP options may modify the preceding text - for ($dir) { - # remove leading whitespace and check for a '-' chomp flag - s/^([-+\#])?\s*//s; - if ($1 && $1 eq '#') { - # comment out entire directive except for any chomp flag - $dir = ($dir =~ /([-+])$/) ? $1 : ''; - } - else { - $chomp = ($1 && $1 eq '+') ? 0 : ($1 || $prechomp); -# my $space = $prechomp == &Template::Constants::CHOMP_COLLAPSE - my $space = $prechomp == CHOMP_COLLAPSE - ? ' ' : ''; - - # chomp off whitespace and newline preceding directive - $chomp and $pre =~ s/(\n|^)([ \t]*)\Z/($1||$2) ? $space : ''/me - and $1 eq "\n" - and $prelines++; - } - - # remove trailing whitespace and check for a '-' chomp flag - s/\s*([-+])?\s*$//s; - $chomp = ($1 && $1 eq '+') ? 0 : ($1 || $postchomp); - my $space = $postchomp == &Template::Constants::CHOMP_COLLAPSE - ? ' ' : ''; - - $postlines++ - if $chomp and $text =~ s/ - ^ - ([ \t]*)\n # whitespace to newline - (?:(.|\n)|$) # any char (not EOF) - / - (($1||$2) ? $space : '') . (defined $2 ? $2 : '') - /ex; - } - - # 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\s+(.*)/i) { - my @tags = split(/\s+/, $1); - if (scalar @tags > 1) { - ($start, $end) = map { quotemeta($_) } @tags; - } - elsif ($tags = $TAG_STYLE->{ $tags[0] }) { - ($start, $end) = @$tags; - } - 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)) { - # reserved words may be in lower case unless case sensitive - $uctoken = $anycase ? uc $token : $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; - - $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' - 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 ) }; - - # 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 - $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"); -} - - -#------------------------------------------------------------------------ -# _dump() -# -# Debug method returns a string representing the internal state of the -# object. -#------------------------------------------------------------------------ - -sub _dump { - my $self = shift; - my $output = "[Template::Parser] {\n"; - my $format = " %-16s => %s\n"; - my $key; - - foreach $key (qw( START_TAG END_TAG TAG_STYLE ANYCASE INTERPOLATE - PRE_CHOMP POST_CHOMP V1DOLLAR )) { - my $val = $self->{ $key }; - $val = '<undef>' unless defined $val; - $output .= sprintf($format, $key, $val); - } - - $output .= '}'; - return $output; -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 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 new() constructor creates and returns a reference to a new -Template::Parser object. A reference to a hash may be supplied as a -parameter to provide configuration values. These may include: - -=over - - - - -=item START_TAG, END_TAG - -The START_TAG and END_TAG options are used to specify character -sequences or regular expressions that mark the start and end of a -template directive. The default values for START_TAG and END_TAG are -'[%' and '%]' 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 $parser = Template::Parser->new({ - START_TAG => quotemeta('<+'), - END_TAG => quotemeta('+>'), - }); - -example: - - <+ INCLUDE foobar +> - -The TAGS directive can also be used to set the START_TAG and END_TAG values -on a per-template file basis. - - [% TAGS <+ +> %] - - - - - - -=item TAG_STYLE - -The TAG_STYLE option can be used to set both START_TAG and END_TAG -according to pre-defined tag styles. - - my $parser = Template::Parser->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) - -Any values specified for START_TAG and/or END_TAG will over-ride -those defined by a TAG_STYLE. - -The TAGS directive may also be used to set a TAG_STYLE - - [% TAGS html %] - <!-- INCLUDE header --> - - - - - - -=item PRE_CHOMP, POST_CHOMP - -Anything outside a directive tag is considered plain text and is -generally passed through unaltered (but see the 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 PRE_CHOMP and POST_CHOMP options can help to clean up some of this -extraneous whitespace. Both are disabled by default. - - my $parser = Template::Parser->new({ - PRE_CHOMP => 1, - POST_CHOMP => 1, - }); - -With PRE_CHOMP set to 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 POST_CHOMP set to 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 PRE_CHOMP or POST_CHOMP is set to 2, then instead of removing all -the whitespace, the whitespace will be collapsed to a single space. -This is useful for HTML, where (usually) a contiguous block of -whitespace is rendered the same as a single space. - -You may use the CHOMP_NONE, CHOMP_ALL, and CHOMP_COLLAPSE constants -from the Template::Constants module to deactivate chomping, remove -all whitespace, or collapse whitespace to a single space. - -PRE_CHOMP and POST_CHOMP can be activated for individual directives by -placing a '-' immediately at the start and/or end of the directive. - - [% FOREACH user = userlist %] - [%- user -%] - [% END %] - -The '-' characters activate both PRE_CHOMP and POST_CHOMP for the one -directive '[%- name -%]'. Thus, the template will be processed as if -written: - - [% FOREACH user = userlist %][% user %][% END %] - -Note that this is the same as if PRE_CHOMP and POST_CHOMP were set -to CHOMP_ALL; the only way to get the CHOMP_COLLAPSE behavior is -to set PRE_CHOMP or POST_CHOMP accordingly. If PRE_CHOMP or POST_CHOMP -is already set to CHOMP_COLLAPSE, using '-' will give you CHOMP_COLLAPSE -behavior, not CHOMP_ALL behavior. - -Similarly, '+' characters can be used to disable PRE_CHOMP or -POST_CHOMP (i.e. leave the whitespace/newline intact) options on a -per-directive basis. - - [% FOREACH user = userlist %] - User: [% user +%] - [% END %] - -With POST_CHOMP enabled, the above example would be parsed as if written: - - [% FOREACH user = userlist %]User: [% user %] - [% END %] - - - - - -=item INTERPOLATE - -The INTERPOLATE flag, when set to any true value will cause variable -references in plain text (i.e. not surrounded by START_TAG and END_TAG) -to be recognised and interpolated accordingly. - - my $parser = Template::Parser->new({ - INTERPOLATE => 1, - }); - -Variables should be prefixed by a '$' to identify them. Curly braces -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 INTERPOLATE or split the templates in several -smaller files or blocks which can then be joined backed together via -PROCESS or INCLUDE. - - - - - - - -=item ANYCASE - -By default, directive keywords should be expressed in UPPER CASE. The -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 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 ANYCASE option, are the operators: - - and or not mod div - - - - - - - - -=item V1DOLLAR - -In version 1 of the Template Toolkit, an optional leading '$' could be placed -on any template variable and would be silently ignored. - - # VERSION 1 - [% $foo %] === [% foo %] - [% $hash.$key %] === [% hash.key %] - -To interpolate a variable value the '${' ... '}' construct was used. -Typically, one would do this to index into a hash array when the key -value was stored in a variable. - -example: - - my $vars = { - users => { - aba => { name => 'Alan Aardvark', ... }, - abw => { name => 'Andy Wardley', ... }, - ... - }, - uid => 'aba', - ... - }; - - $template->process('user/home.html', $vars) - || die $template->error(), "\n"; - -'user/home.html': - - [% user = users.${uid} %] # users.aba - Name: [% user.name %] # Alan Aardvark - -This was inconsistent with double quoted strings and also the -INTERPOLATE mode, where a leading '$' in text was enough to indicate a -variable for interpolation, and the additional curly braces were used -to delimit variable names where necessary. Note that this use is -consistent with UNIX and Perl conventions, among others. - - # double quoted string interpolation - [% name = "$title ${user.name}" %] - - # INTERPOLATE = 1 - <img src="$images/help.gif"></a> - <img src="$images/${icon.next}.gif"> - -For version 2, these inconsistencies have been removed and the syntax -clarified. A leading '$' on a variable is now used exclusively to -indicate that the variable name should be interpolated -(e.g. subsituted for its value) before being used. The earlier example -from version 1: - - # VERSION 1 - [% user = users.${uid} %] - Name: [% user.name %] - -can now be simplified in version 2 as: - - # VERSION 2 - [% user = users.$uid %] - Name: [% user.name %] - -The leading dollar is no longer ignored and has the same effect of -interpolation as '${' ... '}' in version 1. The curly braces may -still be used to explicitly scope the interpolated variable name -where necessary. - -e.g. - - [% user = users.${me.id} %] - Name: [% user.name %] - -The rule applies for all variables, both within directives and in -plain text if processed with the INTERPOLATE option. This means that -you should no longer (if you ever did) add a leading '$' to a variable -inside a directive, unless you explicitly want it to be interpolated. - -One obvious side-effect is that any version 1 templates with variables -using a leading '$' will no longer be processed as expected. Given -the following variable definitions, - - [% foo = 'bar' - bar = 'baz' - %] - -version 1 would interpret the following as: - - # VERSION 1 - [% $foo %] => [% GET foo %] => bar - -whereas version 2 interprets it as: - - # VERSION 2 - [% $foo %] => [% GET $foo %] => [% GET bar %] => baz - -In version 1, the '$' is ignored and the value for the variable 'foo' is -retrieved and printed. In version 2, the variable '$foo' is first interpolated -to give the variable name 'bar' whose value is then retrieved and printed. - -The use of the optional '$' has never been strongly recommended, but -to assist in backwards compatibility with any version 1 templates that -may rely on this "feature", the V1DOLLAR option can be set to 1 -(default: 0) to revert the behaviour and have leading '$' characters -ignored. - - my $parser = Template::Parser->new({ - V1DOLLAR => 1, - }); - - - - - - -=item GRAMMAR - -The 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 Template::Parser -using the 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 Template::Grammar file is constructed from a YACC like grammar -(using Parse::YAPP) and a skeleton module template. These files are -provided, along with a small script to rebuild the grammar, in the -'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 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 Template::Grammar will be -created and used automatically if a GRAMMAR item isn't specified. - - use MyOrg::Template::Grammar; - - my $parser = Template::Parser->new({ - GRAMMAR = MyOrg::Template::Grammar->new(); - }); - - - -=item DEBUG - -The DEBUG option can be used to enable various debugging features -of the Template::Parser module. - - use Template::Constants qw( :debug ); - - my $template = Template->new({ - DEBUG => DEBUG_PARSER | DEBUG_DIRS, - }); - -The DEBUG value can include any of the following. Multiple values -should be combined using the logical OR operator, '|'. - -=over 4 - -=item DEBUG_PARSER - -This flag causes the L<Template::Parser|Template::Parser> to generate -debugging messages that show the Perl code generated by parsing and -compiling each template. - -=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 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 - - -=back - - - - -=back - -=head2 parse($text) - -The parse() method parses the text passed in the first parameter and -returns a reference to a Template::Document object which contains the -compiled representation of the template text. On error, undef is -returned. - -Example: - - $doc = $parser->parse($text) - || die $parser->error(); - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - - - -=head1 VERSION - -2.81, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - - - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -The original Template::Parser module was derived from a standalone -parser generated by version 0.16 of the Parse::Yapp module. 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. - -=head1 SEE ALSO - -L<Template|Template>, L<Template::Grammar|Template::Grammar>, L<Template::Directive|Template::Directive> - diff --git a/lib/Template/Plugin.pm b/lib/Template/Plugin.pm deleted file mode 100644 index a6c9df2..0000000 --- a/lib/Template/Plugin.pm +++ /dev/null @@ -1,409 +0,0 @@ -#============================================================= -*-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@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Plugin.pm,v 2.65 2004/01/13 16:19:15 abw Exp $ -# -#============================================================================ - -package Template::Plugin; - -require 5.004; - -use strict; -use Template::Base; - -use vars qw( $VERSION $DEBUG $ERROR $AUTOLOAD ); -use base qw( Template::Base ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.65 $ =~ /(\d+)\.(\d+)/); -$DEBUG = 0; - - -#======================================================================== -# ----- 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; -} - -sub old_new { - my ($class, $context, $delclass, @params) = @_; - my ($delegate, $delmod); - - return $class->error("no context passed to $class constructor\n") - unless defined $context; - - if (ref $delclass) { - # $delclass contains a reference to a delegate object - $delegate = $delclass; - } - else { - # delclass is the name of a module to load and instantiate - ($delmod = $delclass) =~ s|::|/|g; - - eval { - require "$delmod.pm"; - $delegate = $delclass->new(@params) - || die "failed to instantiate $delclass object\n"; - }; - return $class->error($@) if $@; - } - - bless { - _CONTEXT => $context, - _DELEGATE => $delegate, - _PARAMS => \@params, - }, $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(@_); -} - - -#======================================================================== -# ----- OBJECT METHODS ----- -#======================================================================== - -#------------------------------------------------------------------------ -# AUTOLOAD -# -# General catch-all method which delegates all calls to the _DELEGATE -# object. -#------------------------------------------------------------------------ - -sub OLD_AUTOLOAD { - my $self = shift; - my $method = $AUTOLOAD; - - $method =~ s/.*:://; - return if $method eq 'DESTROY'; - - if (ref $self eq 'HASH') { - my $delegate = $self->{ _DELEGATE } || return; - return $delegate->$method(@_); - } - my ($pkg, $file, $line) = caller(); -# warn "no such '$method' method called on $self at $file line $line\n"; - return undef; -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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. Template::Plugin::*) and -conforms to a regular standard, allowing it to be loaded and used -automatically. - -The 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 PLUGIN_BASE option to specify the namespace that you use. e.g. - - use Template; - my $template = Template->new({ - PLUGIN_BASE => 'MyOrg::Template::Plugin', - }); - -=head1 PLUGIN API - -The following methods form the basic interface between the Template -Toolkit and plugin modules. - -=over 4 - -=item 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 -Template::Context object loading the plugin is also passed. The -default behaviour for the load() method is to simply return the class -name. The calling context then uses this class name to call the new() -package method. - - package MyPlugin; - - sub load { # called as MyPlugin->load($context) - my ($class, $context) = @_; - return $class; # returns 'MyPlugin' - } - -=item new($context, @params) - -This method is called to instantiate a new plugin object for the USE -directive. It is called as a package method against the class name -returned by load(). A reference to the Template::Context object creating -the plugin is passed, along with any additional parameters specified in -the USE directive. - - sub new { # called as MyPlugin->new($context) - my ($class, $context, @params) = @_; - bless { - _CONTEXT => $context, - }, $class; # returns blessed MyPlugin object - } - -=item error($error) - -This method, inherited from the Template::Base module, is used for -reporting and returning errors. It can be called as a package method -to set/return the $ERROR package variable, or as an object method to -set/return the object _ERROR member. When called with an argument, it -sets the relevant variable and returns undef. When called without an -argument, it returns the value of the variable. - - sub new { - my ($class, $context, $dsn) = @_; - - return $class->error('No data source specified') - unless $dsn; - - bless { - _DSN => $dsn, - }, $class; - } - - ... - - my $something = MyModule->new() - || die MyModule->error(), "\n"; - - $something->do_something() - || die $something->error(), "\n"; - -=back - -=head1 DEEPER MAGIC - -The Template::Context object that handles the loading and use of -plugins calls the new() and error() methods against the package name -returned by the load() method. In pseudo-code terms, it might look -something like this: - - $class = MyPlugin->load($context); # returns 'MyPlugin' - - $object = $class->new($context, @params) # MyPlugin->new(...) - || die $class->error(); # MyPlugin->error() - -The load() method may alterately return a blessed reference to an -object instance. In this case, new() and 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 load() is called and this simply returns itself for -each call to new(). - -Another implementation might require individual objects to be created -for every call to 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 MyServer instance is created. The new() -method is called against this object which instantiates and returns a -MyClient object, primed to communicate with the creating MyServer. - -=head1 Template::Plugin Delegation - -As of version 2.01, the Template::Plugin module no longer provides an -AUTOLOAD method to delegate to other objects or classes. This was a -badly designed feature that caused more trouble than good. You can -easily add your own AUTOLOAD method to perform delegation if you -require this kind of functionality. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.65, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template>, L<Template::Plugins|Template::Plugins>, L<Template::Context|Template::Context> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/Autoformat.pm b/lib/Template/Plugin/Autoformat.pm deleted file mode 100644 index b7153e4..0000000 --- a/lib/Template/Plugin/Autoformat.pm +++ /dev/null @@ -1,242 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::Autoformat -# -# DESCRIPTION -# Plugin interface to Damian Conway's Text::Autoformat module. -# -# AUTHORS -# Robert McArthur <mcarthur@dstc.edu.au> -# - original plugin code -# -# Andy Wardley <abw@kfs.org> -# - added FILTER registration, support for forms and some additional -# documentation -# -# COPYRIGHT -# Copyright (C) 2000 Robert McArthur & 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Autoformat.pm,v 2.64 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::Autoformat; - -require 5.004; - -use strict; -use vars qw( $VERSION ); -use base qw( Template::Plugin ); -use Template::Plugin; -use Text::Autoformat; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.64 $ =~ /(\d+)\.(\d+)/); - -sub new { - my ($class, $context, $options) = @_; - my $filter_factory; - my $plugin; - - if ($options) { - # create a closure to generate filters with additional options - $filter_factory = sub { - my $context = shift; - my $filtopt = ref $_[-1] eq 'HASH' ? pop : { }; - @$filtopt{ keys %$options } = values %$options; - return sub { - tt_autoformat(@_, $filtopt); - }; - }; - - # and a closure to represent the plugin - $plugin = sub { - my $plugopt = ref $_[-1] eq 'HASH' ? pop : { }; - @$plugopt{ keys %$options } = values %$options; - tt_autoformat(@_, $plugopt); - }; - } - else { - # simple filter factory closure (no legacy options from constructor) - $filter_factory = sub { - my $context = shift; - my $filtopt = ref $_[-1] eq 'HASH' ? pop : { }; - return sub { - tt_autoformat(@_, $filtopt); - }; - }; - - # plugin without options can be static - $plugin = \&tt_autoformat; - } - - # now define the filter and return the plugin - $context->define_filter('autoformat', [ $filter_factory => 1 ]); - return $plugin; -} - -sub tt_autoformat { - my $options = ref $_[-1] eq 'HASH' ? pop : { }; - my $form = $options->{ form }; - my $out = $form ? Text::Autoformat::form($options, $form, @_) - : Text::Autoformat::autoformat(join('', @_), $options); - return $out; -} - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::Autoformat - Interface to Text::Autoformat module - -=head1 SYNOPSIS - - [% USE autoformat(options) %] - - [% autoformat(text, more_text, ..., options) %] - - [% FILTER autoformat(options) %] - a block of text - [% END %] - -=head1 EXAMPLES - - # define some text for the examples - [% text = BLOCK %] - Be not afeard. The isle is full of noises, sounds and sweet - airs that give delight but hurt not. - [% END %] - - # pass options to constructor... - [% USE autoformat(case => 'upper') %] - [% autoformat(text) %] - - # and/or pass options to the autoformat subroutine itself - [% USE autoformat %] - [% autoformat(text, case => 'upper') %] - - # using the autoformat filter - [% USE autoformat(left => 10, right => 30) %] - [% FILTER autoformat %] - Be not afeard. The isle is full of noises, sounds and sweet - airs that give delight but hurt not. - [% END %] - - # another filter example with configuration options - [% USE autoformat %] - [% FILTER autoformat(left => 20) %] - Be not afeard. The isle is full of noises, sounds and sweet - airs that give delight but hurt not. - [% END %] - - # another FILTER example, defining a 'poetry' filter alias - [% USE autoformat %] - [% text FILTER poetry = autoformat(left => 20, right => 40) %] - - # reuse the 'poetry' filter alias - [% text FILTER poetry %] - - # shorthand form ('|' is an alias for 'FILTER') - [% text | autoformat %] - - # using forms - [% USE autoformat(form => '>>>>.<<<', numeric => 'AllPlaces') %] - [% autoformat(10, 20.32, 11.35) %] - -=head1 DESCRIPTION - -The autoformat plugin is an interface to Damian Conway's Text::Autoformat -Perl module which provides advanced text wrapping and formatting. - -Configuration options may be passed to the plugin constructor via the -USE directive. - - [% USE autoformat(right => 30) %] - -The autoformat subroutine can then be called, passing in text items which -will be wrapped and formatted according to the current configuration. - - [% autoformat('The cat sat on the mat') %] - -Additional configuration items can be passed to the autoformat subroutine -and will be merged with any existing configuration specified via the -constructor. - - [% autoformat(text, left => 20) %] - -Configuration options are passed directly to the Text::Autoformat plugin. -At the time of writing, the basic configuration items are: - - left left margin (default: 1) - right right margin (default 72) - justify justification as one of 'left', 'right', 'full' - or 'centre' (default: left) - case case conversion as one of 'lower', 'upper', - 'sentence', 'title', or 'highlight' (default: none) - squeeze squeeze whitespace (default: enabled) - -The plugin also accepts a 'form' item which can be used to define a -format string. When a form is defined, the plugin will call the -underlying form() subroutine in preference to autoformat(). - - [% USE autoformat(form => '>>>>.<<') %] - [% autoformat(123.45, 666, 3.14) %] - -Additional configuration items relevant to forms can also be specified. - - [% USE autoformat(form => '>>>>.<<', numeric => 'AllPlaces') %] - [% autoformat(123.45, 666, 3.14) %] - -These can also be passed directly to the autoformat subroutine. - - [% USE autoformat %] - [% autoformat( 123.45, 666, 3.14, - form => '>>>>.<<', - numeric => 'AllPlaces' ) - %] - -See L<Text::Autoformat> for further details. - -=head1 AUTHORS - -Robert McArthur E<lt>mcarthur@dstc.edu.auE<gt> wrote the original plugin -code, with some modifications and additions from Andy Wardley -E<lt>abw@wardley.orgE<gt>. - -Damian Conway E<lt>damian@conway.orgE<gt> wrote the Text::Autoformat -module (in his copious spare time :-) which does all the clever stuff. - -=head1 VERSION - -2.64, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - - - -=head1 COPYRIGHT - -Copyright (C) 2000 Robert McArthur & 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|Template::Plugin>, L<Text::Autoformat|Text::Autoformat> - diff --git a/lib/Template/Plugin/CGI.pm b/lib/Template/Plugin/CGI.pm deleted file mode 100644 index 53b19d8..0000000 --- a/lib/Template/Plugin/CGI.pm +++ /dev/null @@ -1,168 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::CGI -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the CGI.pm module. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: CGI.pm,v 2.64 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::CGI; - -require 5.004; - -use strict; -use vars qw( $VERSION ); -use base qw( Template::Plugin ); -use Template::Plugin; -use CGI; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.64 $ =~ /(\d+)\.(\d+)/); - -sub new { - my $class = shift; - my $context = shift; - CGI->new(@_); -} - -package CGI; - -sub params { - my $self = shift; - local $" = ', '; - - return $self->{ _TT_PARAMS } ||= do { - # must call Vars() in a list context to receive - # plain list of key/vals rather than a tied hash - my $params = { $self->Vars() }; - - # convert any null separated values into lists - @$params{ keys %$params } = map { - /\0/ ? [ split /\0/ ] : $_ - } values %$params; - - $params; - }; -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::CGI - Interface to the CGI module - -=head1 SYNOPSIS - - [% USE CGI %] - [% CGI.param('parameter') %] - - [% USE things = CGI %] - [% things.param('name') %] - - # see CGI docs for other methods provided by the CGI object - -=head1 DESCRIPTION - -This is a very simple Template Toolkit Plugin interface to the CGI module. -A CGI object will be instantiated via the following directive: - - [% USE CGI %] - -CGI methods may then be called as follows: - - [% CGI.header %] - [% CGI.param('parameter') %] - -An alias can be used to provide an alternate name by which the object should -be identified. - - [% USE mycgi = CGI %] - [% mycgi.start_form %] - [% mycgi.popup_menu({ Name => 'Color' - Values => [ 'Green' 'Black' 'Brown' ] }) %] - -Parenthesised parameters to the USE directive will be passed to the plugin -constructor: - - [% USE cgiprm = CGI('uid=abw&name=Andy+Wardley') %] - [% cgiprm.param('uid') %] - -=head1 METHODS - -In addition to all the methods supported by the CGI module, this -plugin defines the following. - -=head2 params() - -This method returns a reference to a hash of all the CGI parameters. -Any parameters that have multiple values will be returned as lists. - - [% USE CGI('user=abw&item=foo&item=bar') %] - - [% CGI.params.user %] # abw - [% CGI.params.item.join(', ') %] # foo, bar - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.64, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin>, L<CGI|CGI> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/DBI.pm b/lib/Template/Plugin/DBI.pm deleted file mode 100644 index b916bfc..0000000 --- a/lib/Template/Plugin/DBI.pm +++ /dev/null @@ -1,947 +0,0 @@ -#============================================================================== -# -# Template::Plugin::DBI -# -# DESCRIPTION -# A Template Toolkit plugin to provide access to a DBI data source. -# -# AUTHORS -# Original version by Simon Matthews <sam@knowledgepool.com> -# with some reworking by Andy Wardley <abw@kfs.org> and other -# contributions from Craig Barratt <craig@arraycomm.com>, -# Dave Hodgkinson <daveh@davehodgkinson.com> and Rafael Kitover -# <caelum@debian.org> -# -# COPYRIGHT -# Copyright (C) 1999-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. -# -# REVISION -# $Id: DBI.pm,v 2.62 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================== - -package Template::Plugin::DBI; - -require 5.004; - -use strict; -use Template::Plugin; -use Template::Exception; -use DBI; - -use vars qw( $VERSION $DEBUG $QUERY $ITERATOR ); -use base qw( Template::Plugin ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.62 $ =~ /(\d+)\.(\d+)/); -$DEBUG = 0 unless defined $DEBUG; -$QUERY = 'Template::Plugin::DBI::Query'; -$ITERATOR = 'Template::Plugin::DBI::Iterator'; - -# alias _connect() to connect() for backwards compatability -*_connect = \*connect; - - -#------------------------------------------------------------------------ -# new($context, @params) -# -# Constructor which returns a reference to a new DBI plugin object. -# A connection string (dsn), user name and password may be passed as -# positional arguments or a hash array of connection parameters can be -# passed to initialise a connection. Otherwise, an unconnected DBI -# plugin object is returned. -#------------------------------------------------------------------------ - -sub new { - my $class = shift; - my $context = shift; - my $self = ref $class ? $class : bless { - _CONTEXT => $context, - _STH => [ ], - }, $class; - - $self->connect(@_) if @_; - - return $self; -} - - -#------------------------------------------------------------------------ -# connect( $data_source, $username, $password, $attributes ) -# connect( { data_source => 'dbi:driver:database' -# username => 'foo' -# password => 'bar' } ) -# -# Opens a DBI connection for the plugin. -#------------------------------------------------------------------------ - -sub connect { - my $self = shift; - my $params = ref $_[-1] eq 'HASH' ? pop(@_) : { }; - my ($dbh, $dsn, $user, $pass, $klobs); - - # set debug flag - $DEBUG = $params->{ debug } if exists $params->{ debug }; - $self->{ _DEBUG } = $params->{ debug } || 0; - - # fetch 'dbh' named paramater or use positional arguments or named - # parameters to specify 'dsn', 'user' and 'pass' - - if ($dbh = $params->{ dbh }) { - # disconnect any existing database handle that we previously opened - $self->{ _DBH }->disconnect() - if $self->{ _DBH } && $self->{ _DBH_CONNECT }; - - # store new dbh but leave _DBH_CONNECT false to prevent us - # from automatically closing it in the future - $self->{ _DBH } = $dbh; - $self->{ _DBH_CONNECT } = 0; - } - else { - - # certain Perl programmers are known to have problems with short - # term memory loss (see Tie::Hash::Cannabinol) so we let the poor - # blighters fumble any kind of argument that looks like it might - # identify the database - - $dsn = shift - || $params->{ data_source } - || $params->{ database } - || $params->{ connect } - || $params->{ dsn } - || $params->{ db } - || $ENV{DBI_DSN} - || return $self->_throw('data source not defined'); - - # add 'dbi:' prefix if it's not there - $dsn = "dbi:$dsn" unless $dsn =~ /^dbi:/i; - - $user = shift - || $params->{ username } - || $params->{ user }; - - $pass = shift - || $params->{ password } - || $params->{ pass }; - - # save connection data because we might need it later to do a tie() - @$self{ qw( _DSN _USER _PASS ) } = ($dsn, $user, $pass); - - # reuse existing database handle if connection params match - my $connect = join(':', $dsn || '', $user || '', $pass || ''); - return '' - if $self->{ _DBH } && $self->{ _DBH_CONNECT } eq $connect; - - # otherwise disconnect any existing database handle that we opened - $self->{ _DBH }->disconnect() - if $self->{ _DBH } && $self->{ _DBH_CONNECT }; - - # don't need DBI to automatically print errors because all calls go - # via this plugin interface and we always check return values - $params->{ PrintError } = 0 - unless defined $params->{ PrintError }; - - $self->{ _DBH } = DBI->connect_cached( $dsn, $user, $pass, $params ) - || return $self->_throw("DBI connect failed: $DBI::errstr"); - - # store the connection parameters - $self->{ _DBH_CONNECT } = $connect; - } - - return ''; -} - - -#------------------------------------------------------------------------ -# disconnect() -# -# Disconnects the current active database connection. -#------------------------------------------------------------------------ - -sub disconnect { - my $self = shift; - $self->{ _DBH }->disconnect() - if $self->{ _DBH }; - delete $self->{ _DBH }; - return ''; -} - - -#------------------------------------------------------------------------ -# tie( $table, $key ) -# -# Return a hash tied to a table in the database, indexed by the specified -# key. -#------------------------------------------------------------------------ - -sub tie { - my $self = shift; - my $params = ref $_[-1] eq 'HASH' ? pop(@_) : { }; - my ($table, $key, $klobs, $debug, %hash); - - eval { require Tie::DBI }; - $self->_throw("failed to load Tie::DBI module: $@") if $@; - - $table = shift - || $params->{ table } - || $self->_throw('table not defined'); - - $key = shift - || $params->{ key } - || $self->_throw('key not defined'); - - # Achtung der Klobberman! - $klobs = $params->{ clobber }; - $klobs = $params->{ CLOBBER } unless defined $klobs; - - # going the extra mile to allow user to use UPPER or lower case or - # inherit internel debug flag set by connect() - $debug = $params->{ debug }; - $debug = $params->{ DEBUG } unless defined $debug; - $debug = $self->{ _DEBUG } unless defined $debug; - - tie %hash, 'Tie::DBI', { - %$params, # any other Tie::DBI options like DEBUG, WARN, etc - db => $self->{ _DBH } || $self->{ _DSN }, - user => $self->{ _USER }, - password => $self->{ _PASS }, - table => $table, - key => $key, - CLOBBER => $klobs || 0, - DEBUG => $debug || 0, - }; - - return \%hash; -} - - -#------------------------------------------------------------------------ -# prepare($sql) -# -# Prepare a query and store the live statement handle internally for -# subsequent execute() calls. -#------------------------------------------------------------------------ - -sub prepare { - my $self = shift; - my $sql = shift || return undef; - - my $sth = $self->dbh->prepare($sql) - || return $self->_throw("DBI prepare failed: $DBI::errstr"); - - # create wrapper object around handle to return to template client - $sth = $QUERY->new($sth); - push(@{ $self->{ _STH } }, $sth); - - return $sth; -} - - -#------------------------------------------------------------------------ -# execute() -# -# Calls execute() on the most recent statement created via prepare(). -#------------------------------------------------------------------------ - -sub execute { - my $self = shift; - - my $sth = $self->{ _STH }->[-1] - || return $self->_throw('no query prepared'); - - $sth->execute(@_); -} - - -#------------------------------------------------------------------------ -# query($sql, @params) -# -# Prepares and executes a SQL query. -#------------------------------------------------------------------------ - -sub query { - my $self = shift; - my $sql = shift; - - $self->prepare($sql)->execute(@_); -} - - -#------------------------------------------------------------------------ -# do($sql, \%attr, @bind) -# -# Prepares and executes a SQL statement. -#------------------------------------------------------------------------ - -sub do { - my $self = shift; - - return $self->dbh->do(@_) - || $self->_throw("DBI do failed: $DBI::errstr"); -} - - -#------------------------------------------------------------------------ -# quote($value [, $data_type ]) -# -# Returns a quoted string (correct for the connected database) from the -# value passed in. -#------------------------------------------------------------------------ - -sub quote { - my $self = shift; - $self->dbh->quote(@_); -} - - -#------------------------------------------------------------------------ -# dbh() -# -# Internal method to retrieve the database handle belonging to the -# instance or attempt to create a new one using connect. -#------------------------------------------------------------------------ - -sub dbh { - my $self = shift; - - return $self->{ _DBH } || do { - $self->connect; - $self->{ _DBH }; - }; -} - - -#------------------------------------------------------------------------ -# DESTROY -# -# Called automatically when the plugin object goes out of scope to -# disconnect the database handle cleanly -#------------------------------------------------------------------------ - -sub DESTROY { - my $self = shift; - delete($self->{ _STH }); # first DESTROY any queries - $self->{ _DBH }->disconnect() - if $self->{ _DBH } && $self->{ _DBH_CONNECT }; -} - - -#------------------------------------------------------------------------ -# _throw($error) -# -# Raise an error by throwing it via die() as a Template::Exception -# object of type 'DBI'. -#------------------------------------------------------------------------ - -sub _throw { - my $self = shift; - my $error = shift || die "DBI throw() called without an error string\n"; - - # throw error as DBI exception - die (Template::Exception->new('DBI', $error)); -} - - -#======================================================================== -# Template::Plugin::DBI::Query -#======================================================================== - -package Template::Plugin::DBI::Query; -use vars qw( $DEBUG $ITERATOR ); - -*DEBUG = \$Template::Plugin::DBI::DEBUG; -*ITERATOR = \$Template::Plugin::DBI::ITERATOR; - - -sub new { - my ($class, $sth) = @_; - bless \$sth, $class; -} - -sub execute { - my $self = shift; - - $$self->execute(@_) - || return Template::Plugin::DBI->_throw("execute failed: $DBI::errstr"); - - $ITERATOR->new($$self); -} - -sub DESTROY { - my $self = shift; - $$self->finish(); -} - - -#======================================================================== -# Template::Plugin::DBI::Iterator; -#======================================================================== - -package Template::Plugin::DBI::Iterator; - -use Template::Iterator; -use base qw( Template::Iterator ); -use vars qw( $DEBUG ); - -*DEBUG = \$Template::Plugin::DBI::DEBUG; - - -sub new { - my ($class, $sth, $params) = @_; - - my $rows = $sth->rows(); - - my $self = bless { - _STH => $sth, - SIZE => $rows, - MAX => $rows - 1, - }, $class; - - - return $self; -} - - -#------------------------------------------------------------------------ -# get_first() -# -# Initialises iterator to read from statement handle. We maintain a -# one-record lookahead buffer to allow us to detect if the current -# record is the last in the series. -#------------------------------------------------------------------------ - -sub get_first { - my $self = shift; - $self->{ _STARTED } = 1; - - # set some status variables into $self - @$self{ qw( PREV ITEM FIRST LAST COUNT INDEX ) } - = ( undef, undef, 2, 0, 0, -1 ); - - # support 'number' as an alias for 'count' for backwards compatability - $self->{ NUMBER } = 0; - - print STDERR "get_first() called\n" if $DEBUG; - - # get the first row - $self->_fetchrow(); - - print STDERR "get_first() calling get_next()\n" if $DEBUG; - - return $self->get_next(); -} - - -#------------------------------------------------------------------------ -# get_next() -# -# Called to read remaining result records from statement handle. -#------------------------------------------------------------------------ - -sub get_next { - my $self = shift; - my ($data, $fixup); - - # increment the 'index' and 'count' counts - $self->{ INDEX }++; - $self->{ COUNT }++; - $self->{ NUMBER }++; # 'number' is old name for 'count' - - # decrement the 'first-record' flag - $self->{ FIRST }-- if $self->{ FIRST }; - - # we should have a row already cache in NEXT - return (undef, Template::Constants::STATUS_DONE) - unless $data = $self->{ NEXT }; - - # set PREV to be current ITEM from last iteration - $self->{ PREV } = $self->{ ITEM }; - - # look ahead to the next row so that the rowcache is refilled - $self->_fetchrow(); - - $self->{ ITEM } = $data; - return ($data, Template::Constants::STATUS_OK); -} - - -sub get { - my $self = shift; - my ($data, $error); - - ($data, $error) = $self->{ _STARTED } - ? $self->get_next() : $self->get_first(); - - return $data; -} - - -sub get_all { - my $self = shift; - my $sth = $self->{ _STH }; - my $error; - - my $data = $sth->fetchall_arrayref({}); - $self->throw($error) if ($error = $sth->err()); - unshift(@$data, $self->{ NEXT }) if $self->{ NEXT }; - $self->{ LAST } = 1; - $self->{ NEXT } = undef; - $sth->finish(); - - return $data; -} - - -#------------------------------------------------------------------------ -# _fetchrow() -# -# Retrieve a record from the statement handle and store in row cache. -#------------------------------------------------------------------------ - -sub _fetchrow { - my $self = shift; - my $sth = $self->{ _STH }; - - my $data = $sth->fetchrow_hashref() || do { - $self->{ LAST } = 1; - $self->{ NEXT } = undef; - $sth->finish(); - return; - }; - $self->{ NEXT } = $data; - return; -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::DBI - Template interface to the DBI module - -=head1 SYNOPSIS - -Making an implicit database connection: - - # ...using positional arguments - [% USE DBI('dbi:driver:dbname', 'user', 'pass') %] - - # ...using named parameters - [% USE DBI( database = 'dbi:driver:dbname', - username = 'user', - password = 'pass' ) - %] - - # ...using short named parameters (4 lzy ppl and bad typsits) - [% USE DBI( db = 'driver:dbname', - user = 'user', - pass = 'pass' ) - %] - - # ...or an existing DBI database handle - [% USE DBI( dbh = my_dbh_ref ) %] - -Making explicit database connections: - - [% USE DBI %] - - [% DBI.connect(db, user, pass) %] - ... - - [% DBI.connect(new_db, new_user, new_pass) %] - ... - - [% DBI.disconnect %] # final disconnect is optional - -Making an automagical database connection using DBI_DSN environment variable: - - [% USE DBI %] - -Making database queries: - - # single step query - [% FOREACH user = DBI.query('SELECT * FROM users') %] - [% user.uid %] blah blah [% user.name %] etc. etc. - [% END %] - - # two stage prepare/execute - [% query = DBI.prepare('SELECT * FROM users WHERE uid = ?') %] - - [% FOREACH user = query.execute('sam') %] - ... - [% END %] - - [% FOREACH user = query.execute('abw') %] - ... - [% END %] - -Making non-SELECT statements: - - [% IF DBI.do("DELETE FROM users WHERE uid = '$uid'") %] - The user '[% uid %]' was successfully deleted. - [% END %] - -Using named DBI connections: - - [% USE one = DBI(...) %] - [% USE two = DBI(...) %] - - [% FOREACH item = one.query("SELECT ...etc...") %] - ... - [% END %] - - [% FOREACH item = two.query("SELECT ...etc...") %] - ... - [% END %] - -Tieing to a database table (via Tie::DBI): - - [% people = DBI.tie('users', 'uid') %] - - [% me = people.abw %] # => SELECT * FROM users WHERE uid='abw' - - I am [% me.name %] - - # clobber option allows table updates (see Tie::DBI) - [% people = DBI.tie('users', 'uid', clobber=1) %] - - [% people.abw.name = 'not a number' %] - - I am [% people.abw.name %] # I am a free man! - -=head1 DESCRIPTION - -This Template Toolkit plugin module provides an interface to the Perl -DBI/DBD modules, allowing you to integrate SQL queries into your -template documents. It also provides an interface via the Tie::DBI -module (if installed on your system) so that you can access database -records without having to embed any SQL in your templates. - -A DBI plugin object can be created as follows: - - [% USE DBI %] - -This creates an uninitialised DBI object. You can then open a connection -to a database using the connect() method. - - [% DBI.connect('dbi:driver:dbname', 'user', 'pass') %] - -The DBI connection can be opened when the plugin is created by passing -arguments to the constructor, called from the USE directive. - - [% USE DBI('dbi:driver:dbname', 'user', 'pass') %] - -You can also use named parameters to provide the data source connection -string, user name and password. - - [% USE DBI(database => 'dbi:driver:dbname', - username => 'user', - password => 'pass') %] - -For backwards compatability with previous versions of this plugin, you can -also spell 'database' as 'data_source'. - - [% USE DBI(data_source => 'dbi:driver:dbname', - username => 'user', - password => 'pass') %] - -Lazy Template hackers may prefer to use 'db', 'dsn' or 'connect' as a -shorthand form of the 'database' parameter, and 'user' and 'pass' as -shorthand forms of 'username' and 'password', respectively. You can -also drop the 'dbi:' prefix from the database connect string because -the plugin will add it on for you automagically. - - [% USE DBI(db => 'driver:dbname', - user => 'user', - pass => 'pass') %] - -Any additional DBI attributes can be specified as named parameters. -The 'PrintError' attribute defaults to 0 unless explicitly set true. - - [% USE DBI(db, user, pass, ChopBlanks=1) %] - -An alternate variable name can be provided for the plugin as per regular -Template Toolkit syntax: - - [% USE mydb = DBI('dbi:driver:dbname', 'user', 'pass') %] - - [% FOREACH item = mydb.query('SELECT * FROM users') %] - ... - [% END %] - -You can also specify the DBI plugin name in lower case if you prefer: - - [% USE dbi(dsn, user, pass) %] - - [% FOREACH item = dbi.query('SELECT * FROM users') %] - ... - [% END %] - -The disconnect() method can be called to explicitly disconnect the -current database, but this generally shouldn't be necessary as it is -called automatically when the plugin goes out of scope. You can call -connect() at any time to open a connection to another database. The -previous connection will be closed automatically. - -Internally, the DBI connect_cached() method is used instead of the -connect() method. This allows for connection caching in a server -environment, such as when the Template Toolkit is used from an Apache -mod_perl handler. In such a case, simply enable the mod_env module -and put in a line such as: - - SetEnv DBI_DSN "dbi:mysql:dbname;host=dbhost; - user=uname;password=pword" - -(NOTE: the string shown here is split across 2 lines for the sake of -reasonable page formatting, but you should specify it all as one long -string with no spaces or newlines). - -You can then use the DBI plugin without any parameters or the need -to explicitly call connect(). - -Once you've loaded a DBI plugin and opened a database connection using -one of the techniques shown above, you can then make queries on the database -using the familiar dotted notation: - - [% FOREACH user = DBI.query('SELECT * FROM users') %] - [% user.uid %] blah blah [% user.name %] etc. etc. - [% END %] - -The query() method prepares a query and executes it all in one go. -If you want to repeat a query with different parameters then you -can use a separate prepare/execute cycle. - - [% query = DBI.prepare('SELECT * FROM users WHERE uid = ?') %] - - [% FOREACH user = query.execute('sam') %] - ... - [% END %] - - [% FOREACH user = query.execute('abw') %] - ... - [% END %] - -The query() and execute() methods return an iterator object which -manages the result set returned. You can save a reference to the -iterator and access methods like size() to determine the number of -rows returned by a query. - - [% users = DBI.query('SELECT * FROM users') %] - [% users.size %] records returned - -or even - - [% DBI.query('SELECT * FROM users').size %] - -When used within a FOREACH loop, the iterator is always aliased to the -special C<loop> variable. This makes it possible to do things like this: - - [% FOREACH user = DBI.query('SELECT * FROM users') %] - [% loop.count %]/[% loop.size %]: [% user.name %] - [% END %] - -to generate a result set of the form: - - 1/3: Jerry Garcia - 2/3: Kurt Cobain - 3/3: Freddie Mercury - -See L<Template::Iterator> for further details on iterators and the -methods that they implement. - -The DBI plugin also provides the do() method to execute non-SELECT -statements like this: - - [% IF DBI.do("DELETE FROM users WHERE uid = '$uid'") %] - The user '[% uid %]' was successfully deleted. - [% END %] - -The plugin also allows you to create a tie to a table in the database -using the Tie::DBI module. Simply call the tie() method, passing the -name of the table and the primary key as arguments. - - [% people = DBI.tie('person', 'uid') %] - -You can then access records in the database table as if they were -entries in the 'people' hash. - - My name is [% people.abw.name %] - -IMPORTANT NOTE: the XS Stash (Template::Stash::XS) does not currently -support access to tied hashes. If you are using the XS stash and having -problems then you should try enabling the regular stash instead. You -can do this by setting $Template::Config::STASH to 'Template::Stash' -before instantiating the Template object. - -=head1 OBJECT METHODS - -=head2 connect($database, $username, $password) - -Establishes a database connection. This method accepts both positional -and named parameter syntax. e.g. - - [% DBI.connect( 'dbi:driver:dbname', 'timmy', 'sk8D00Dz' ) %] - - [% DBI.connect( database = 'dbi:driver:dbname' - username = 'timmy' - password = 'sk8D00Dz' ) %] - -The connect method allows you to connect to a data source explicitly. -It can also be used to reconnect an exisiting object to a different -data source. - -If you already have a database handle then you can instruct the plugin -to reuse it by passing it as the 'dbh' parameter. - - [% DBI.connect( dbh = my_dbh_ref ) %] - -=head2 query($sql) - -This method submits an SQL query to the database and creates an iterator -object to return the results. This may be used directly in a FOREACH -directive as shown below. Data is automatically fetched a row at a time -from the query result set as required for memory efficiency. - - [% FOREACH user = DBI.query('SELECT * FROM users') %] - Each [% user.field %] can be printed here - [% END %] - -=head2 prepare($sql) - -Prepare a query for later execution. This returns a compiled query -object (of the Template::Plugin::DBI::Query class) on which the -execute() method can subsequently be called. - - [% query = DBI.prepare('SELECT * FROM users WHERE id = ?') %] - -=head2 execute(@args) - -Execute a previously prepared query. This method should be called on -the query object returned by the prepare() method. Returns an -iterator object which can be used directly in a FOREACH directive. - - [% query = DBI.prepare('SELECT * FROM users WHERE manager = ?') %] - - [% FOREACH minion = query.execute('abw') %] - [% minion.name %] - [% END %] - - [% FOREACH minion = query.execute('sam') %] - [% minion.name %] - [% END %] - -=head2 do($sql) - -The do() method executes a sql statement from which no records are -returned. It will return true if the statement was successful - - [% IF DBI.do("DELETE FROM users WHERE uid = 'sam'") %] - The user was successfully deleted. - [% END %] - -=head2 tie($table, $key, \%args) - -Returns a reference to a hash array tied to a table in the database, -implemented using the Tie::DBI module. You should pass the name of -the table and the key field as arguments. - - [% people = DBI.tie('users', 'uid') %] - -Or if you prefer, you can use the 'table' and 'key' named parameters. - - [% people = DBI.tie(table='users', key='uid') %] - -In this example, the Tie::DBI module will convert the accesses into -the 'people' hash into SQL queries of the form: - - SELECT * FROM users WHERE uid=? - -For example: - - [% me = people.abw %] - -The record returned can then be accessed just like a normal hash. - - I am [% me.name %] - -You can also do things like this to iterate through all the records -in a table. - - [% FOREACH uid = people.keys.sort; - person = people.$uid - %] - * [% person.id %] : [% person.name %] - [% END %] - -With the 'clobber' (or 'CLOBBER') option set you can update the record -and have those changes automatically permeated back into the database. - - [% people = DBI.tie('users', 'uid', clobber=1) %] - - [% people.abw.name = 'not a number' %] - - I am [% people.abw.name %] # I am a free man! - -And you can also add new records. - - [% people.newguy = { - name = 'Nobby Newguy' - ...other fields... - } - %] - -See L<Tie::DBI> for further information on the 'CLOBBER' option. - -=head2 quote($value, $type) - -Calls the quote() method on the underlying DBI handle to quote the value -specified in the appropriate manner for its type. - -=head2 dbh() - -Return the database handle currently in use by the plugin. - -=head2 disconnect() - -Disconnects the current database. - -=head1 AUTHORS - -The DBI plugin was originally written by Simon A Matthews, and -distributed as a separate module. It was integrated into the Template -Toolkit distribution for version 2.00 and includes contributions from -Andy Wardley, Craig Barratt, Dave Hodgkinson and Rafael Kitover. - -=head1 VERSION - -2.62, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - - - -=head1 COPYRIGHT - -Copyright (C) 1999-2001 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|Template::Plugin>, L<DBI|DBI>, L<Tie::DBI|Tie::DBI> - diff --git a/lib/Template/Plugin/Datafile.pm b/lib/Template/Plugin/Datafile.pm deleted file mode 100644 index 5cf53af..0000000 --- a/lib/Template/Plugin/Datafile.pm +++ /dev/null @@ -1,198 +0,0 @@ -#============================================================= -*-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@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Datafile.pm,v 2.66 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::Datafile; - -require 5.004; - -use strict; -use vars qw( @ISA $VERSION ); -use base qw( Template::Plugin ); -use Template::Plugin; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.66 $ =~ /(\d+)\.(\d+)/); - -sub new { - my ($class, $context, $filename, $params) = @_; - my ($delim, $line, @fields, @data, @results); - my $self = [ ]; - local *FD; - local $/ = "\n"; - - $params ||= { }; - $delim = $params->{'delim'} || ':'; - $delim = quotemeta($delim); - - return $class->fail("No filename specified") - unless $filename; - - open(FD, $filename) - || return $class->fail("$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->fail("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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 = '|') %] - - [% 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 INCLUDE_PATH). An -optional 'delim' parameter may also be provided to specify an alternate -delimiter character. - - [% 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@cre.canon.co.uk : 555-1234 - neilb : Neil Bowers : neilb@cre.canon.co.uk : 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 '#'. - -=head1 BUGS - -Should handle file names relative to INCLUDE_PATH. -Doesn't permit use of ':' in a field. Some escaping mechanism is required. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.66, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/Date.pm b/lib/Template/Plugin/Date.pm deleted file mode 100644 index 7351686..0000000 --- a/lib/Template/Plugin/Date.pm +++ /dev/null @@ -1,361 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::Date -# -# DESCRIPTION -# -# Plugin to generate formatted date strings. -# -# AUTHORS -# Thierry-Michel Barral <kktos@electron-libre.com> -# Andy Wardley <abw@cre.canon.co.uk> -# -# COPYRIGHT -# Copyright (C) 2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Date.pm,v 2.71 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::Date; - -use strict; -use vars qw( $VERSION $FORMAT @LOCALE_SUFFIX ); -use base qw( Template::Plugin ); -use Template::Plugin; - -use POSIX (); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.71 $ =~ /(\d+)\.(\d+)/); -$FORMAT = '%H:%M:%S %d-%b-%Y'; # default strftime() format -@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(); -} - - -#------------------------------------------------------------------------ -# 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(@_) || $params->{ time } || $self->{ time } - || $self->now(); - my $format = @_ ? shift(@_) - : ($params->{ format } || $self->{ format } || $FORMAT); - my $locale = @_ ? shift(@_) - : ($params->{ locale } || $self->{ locale }); - my $gmt = @_ ? shift(@_) - : ($params->{ gmt } || $self->{ gmt }); - my (@date, $datestr); - - if ($time =~ /^\d+$/) { - # $time is now in seconds since epoch - if ($gmt) { - @date = (gmtime($time))[0..6]; - } - else { - @date = (localtime($time))[0..6]; - } - } - else { - # if $time is numeric, then we assume it's seconds since the epoch - # otherwise, we try to parse it as a 'H:M:S D:M:Y' string - @date = (split(/(?:\/| |:|-)/, $time))[2,1,0,3..5]; - return (undef, Template::Exception->new('date', - "bad time/date string: expects 'h:m:s d:m:y' got: '$time'")) - unless @date >= 6 && defined $date[5]; - $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 ($locale) { - # format the date in a specific locale, saving and subsequently - # restoring the current locale. - my $old_locale = &POSIX::setlocale(&POSIX::LC_ALL); - - # some systems expect locales to have a particular suffix - for my $suffix ('', @LOCALE_SUFFIX) { - my $try_locale = $locale.$suffix; - my $setlocale = &POSIX::setlocale(&POSIX::LC_ALL, $try_locale); - if (defined $setlocale && $try_locale eq $setlocale) { - $locale = $try_locale; - last; - } - } - $datestr = &POSIX::strftime($format, @date); - &POSIX::setlocale(&POSIX::LC_ALL, $old_locale); - } - else { - $datestr = &POSIX::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 ); -use vars qw( $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 ); -use vars qw( $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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 'h:m:s d-m-y' string - [% date.format(960973980) %] - [% date.format('4:20:36 21/12/2000') %] - - # 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) %] - - # specify default format to plugin - [% USE date(format = '%H:%M:%S', locale = 'de_DE') %] - - [% date.format %] - ... - -=head1 DESCRIPTION - -The Date plugin provides an easy way to generate formatted time and date -strings by delegating to the POSIX strftime() routine. - -The plugin can be loaded via the familiar USE directive. - - [% USE date %] - -This creates a plugin object with the default name of 'date'. An alternate -name can be specified as such: - - [% USE myname = date %] - -The plugin provides the 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 ('%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 USE directive. - - [% USE date(format = '%a %d-%b-%Y', locale = 'fr_FR') %] - -When called without any parameters, the format() method returns a string -representing the current system time, formatted by strftime() according -to the default format and for the default locale (which may not be the -current one, if locale is set in the USE directive). - - [% date.format %] - -The plugin allows a time/date to be specified as seconds since the epoch, -as is returned by time(). - - File last modified: [% date.format(filemod_time) %] - -The time/date can also be specified as a string of the form 'h:m:s d/m/y'. -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 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 -'%Z' (time zone) in the format parameter will lead to an extremely -misleading result. - -Any or all of these parameters may be named. Positional parameters -should always be in the order ($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 now() method returns the current system time in seconds since the -epoch. - - [% date.format(date.now, '%A') %] - -The calc() method can be used to create an interface to the Date::Calc -module (if installed on your system). - - [% calc = date.calc %] - [% calc.Monday_of_Week(22, 2001).join('/') %] - -The manip() method can be used to create an interface to the 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 E<lt>kktos@electron-libre.comE<gt> wrote the original -plugin. - -Andy Wardley E<lt>abw@cre.canon.co.ukE<gt> provided some minor -fixups/enhancements, a test script and documentation. - -Mark D. Mills E<lt>mark@hostile.orgE<gt> cloned Date::Manip from the -cute Date::Calc sub-plugin. - -=head1 VERSION - -2.71, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - - - -=head1 COPYRIGHT - -Copyright (C) 2000 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|Template::Plugin>, L<POSIX|POSIX> - diff --git a/lib/Template/Plugin/Directory.pm b/lib/Template/Plugin/Directory.pm deleted file mode 100644 index ec6247e..0000000 --- a/lib/Template/Plugin/Directory.pm +++ /dev/null @@ -1,410 +0,0 @@ -#============================================================= -*-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@kfs.org>. -# -# COPYRIGHT -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -# REVISION -# $Id: Directory.pm,v 2.64 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::Directory; - -require 5.004; - -use strict; -use Cwd; -use File::Spec; -use Template::Plugin::File; -use vars qw( $VERSION ); -use base qw( Template::Plugin::File ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.64 $ =~ /(\d+)\.(\d+)/); - - -#------------------------------------------------------------------------ -# 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)); -} - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 Template::Plugin::File module and -uses Template::Plugin::File object instances to represent files within -a directory. Sub-directories within a directory are represented by -further 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 = dir.files %] - [% file.name %] - [% END %] - - # directories only - [% FOREACH file = dir.dirs %] - [% file.name %] - [% END %] - - # files and/or directories - [% FOREACH file = dir.list %] - [% file.name %] ([% file.isdir ? 'directory' : 'file' %]) - [% END %] - - [% USE Directory('foo/baz') %] - -The plugin constructor will throw a 'Directory' error if the specified -path does not exist, is not a directory or fails to stat() (see -L<Template::Plugin::File>). Otherwise, it will scan the directory and -create lists named 'files' containing files, 'dirs' containing -directories and 'list' containing both files and directories combined. -The 'nostat' option can be set to disable all file/directory checks -and directory scanning. - -Each file in the directory will be represented by a -Template::Plugin::File object instance, and each directory by another -Template::Plugin::Directory. If the 'recurse' flag is set, then those -directories will contain further nested entries, and so on. With the -'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 scan() method is explicitly called. The '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 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 'recurse' flag can be set (disabled by default) to cause the -constructor to automatically recurse down into all sub-directories, -creating a new 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 scan() method. - - [% USE dir = Directory(dirpath, recurse=1) %] - ... - - [% IF file.isdir -%] - * [% file.name %] - [% INCLUDE showdir dir=file FILTER indent(4) -%] - [% ELSE -%] - ... - -From version 2.01, the Template Toolkit provides support for views. -A view can be defined as a VIEW ... END block and should contain -BLOCK definitions for files ('file') and directories ('directory'). - - [% VIEW myview %] - [% BLOCK file %] - - [% item.name %] - [% END %] - - [% BLOCK directory %] - * [% item.name %] - [% item.content(myview) FILTER indent %] - [% END %] - [% END %] - -Then the view print() method can be called, passing the -Directory object as an argument. - - [% USE dir = Directory(dirpath, recurse=1) %] - [% myview.print(dir) %] - -When a directory is presented to a view, either as [% myview.print(dir) %] -or [% dir.present(view) %], then the 'directory' BLOCK within the 'myview' -VIEW is processed, with the 'item' variable set to alias the Directory object. - - [% BLOCK directory %] - * [% item.name %] - [% item.content(myview) FILTER indent %] - [% END %] - -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 'directory' block, and files -will be mapped to the 'file' block. - -With the recurse option disabled, as it is by default, the 'directory' -block should explicitly call a 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 TODO - -Might be nice to be able to specify accept/ignore options to catch -a subset of files. - -=head1 AUTHORS - -Michael Stevens E<lt>michael@etla.orgE<gt> wrote the original Directory plugin -on which this is based. Andy Wardley E<lt>abw@wardley.orgE<gt> split it into -separate File and Directory plugins, added some extra code and documentation -for VIEW support, and made a few other minor tweaks. - -=head1 VERSION - -2.64, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - - - -=head1 COPYRIGHT - -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|Template::Plugin>, L<Template::Plugin::File|Template::Plugin::File>, L<Template::View|Template::View> - diff --git a/lib/Template/Plugin/Dumper.pm b/lib/Template/Plugin/Dumper.pm deleted file mode 100644 index 5dbf1f6..0000000 --- a/lib/Template/Plugin/Dumper.pm +++ /dev/null @@ -1,179 +0,0 @@ -#============================================================================== -# -# Template::Plugin::Dumper -# -# DESCRIPTION -# -# A Template Plugin to provide a Template Interface to Data::Dumper -# -# AUTHOR -# Simon Matthews <sam@knowledgepool.com> -# -# 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. -# -#------------------------------------------------------------------------------ -# -# $Id: Dumper.pm,v 2.64 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================== - -package Template::Plugin::Dumper; - -require 5.004; - -use strict; -use Template::Plugin; -use Data::Dumper; - -use vars qw( $VERSION $DEBUG @DUMPER_ARGS $AUTOLOAD ); -use base qw( Template::Plugin ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.64 $ =~ /(\d+)\.(\d+)/); -$DEBUG = 0 unless defined $DEBUG; -@DUMPER_ARGS = qw( Indent Pad Varname Purity Useqq Terse Freezer - Toaster Deepcopy Quotekeys Bless Maxdepth ); - -#============================================================================== -# ----- CLASS METHODS ----- -#============================================================================== - -#------------------------------------------------------------------------ -# new($context, \@params) -#------------------------------------------------------------------------ - -sub new { - my ($class, $context, $params) = @_; - my ($key, $val); - $params ||= { }; - - - foreach my $arg (@DUMPER_ARGS) { - no strict 'refs'; - if (defined ($val = $params->{ lc $arg }) - or defined ($val = $params->{ $arg })) { - ${"Data\::Dumper\::$arg"} = $val; - } - } - - bless { - _CONTEXT => $context, - }, $class; -} - -sub dump { - my $self = shift; - my $content = Dumper @_; - return $content; -} - - -sub dump_html { - my $self = shift; - my $content = Dumper @_; - for ($content) { - s/&/&/g; - s/</</g; - s/>/>/g; - s/\n/<br>\n/g; - } - return $content; -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 Data::Dumper -module. A 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 Data::Dumper 'Pad', 'Indent' and '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 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 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@knowledgepool.comE<gt> - -=head1 VERSION - -2.64, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - - - -=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|Template::Plugin>, L<Data::Dumper|Data::Dumper> - diff --git a/lib/Template/Plugin/File.pm b/lib/Template/Plugin/File.pm deleted file mode 100644 index d1d542e..0000000 --- a/lib/Template/Plugin/File.pm +++ /dev/null @@ -1,416 +0,0 @@ -#============================================================= -*-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 -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -# REVISION -# $Id: File.pm,v 2.64 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::File; - -require 5.004; - -use strict; -use Cwd; -use File::Spec; -use File::Basename; -use Template::Plugin; - -use vars qw( $VERSION ); -use base qw( Template::Plugin ); -use vars qw( @STAT_KEYS ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.64 $ =~ /(\d+)\.(\d+)/); - -@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)); -} - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 'nostat' -option set, see below) as an absolute file when specified with as -leading '/' as per '/foo/bar/baz.html', or otherwise as one relative -to the current working directory. The constructor performs a 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 'user' and 'group' items are set to contain the user -and group names as returned by calls to getpwuid() and getgrgid() for -the file 'uid' and 'gid' elements, respectively. On Win32 platforms -on which getpwuid() and 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 'noid' option. - - [% USE File('/tmp/foo.html', noid=1) %] - [% File.uid %] # e.g. 500 - [% File.user %] # nothing - -The 'isdir' flag will be set if the file is a directory. - - [% USE File('/tmp') %] - [% File.isdir %] # 1 - -If the stat() on the file fails (e.g. file doesn't exists, bad -permission, etc) then the constructor will throw a 'File' exception. -This can be caught within a TRY...CATCH block. - - [% TRY %] - [% USE File('/tmp/myfile') %] - File exists! - [% CATCH File %] - File error: [% error.info %] - [% END %] - -Note the capitalisation of the exception type, 'File' to indicate an -error thrown by the 'File' plugin, to distinguish it from a regular -'file' exception thrown by the Template Toolkit. - -Note that the 'File' plugin can also be referenced by the lower case -name 'file'. However, exceptions are always thrown of the '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 'nostat' option can be specified to prevent the plugin constructor -from performing a 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 stat() will be set -empty. - - [% USE file('/some/where/over/the/rainbow.html', nostat=1) - [% file.mtime %] # nothing - -All File plugins, regardless of the nostat option, have set a number -of items relating to the original path specified. - -=over 4 - -=item path - -The full, original file path specified to the constructor. - - [% USE file('/foo/bar.html') %] - [% file.path %] # /foo/bar.html - -=item name - -The name of the file without any leading directories. - - [% USE file('/foo/bar.html') %] - [% file.name %] # bar.html - -=item dir - -The directory element of the path with the filename removed. - - [% USE file('/foo/bar.html') %] - [% file.name %] # /foo - -=item ext - -The file extension, if any, appearing at the end of the path following -a '.' (not included in the extension). - - [% USE file('/foo/bar.html') %] - [% file.ext %] # html - -=item home - -This contains a string of the form '../..' 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 %] # ../.. - -=item root - -The '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 - -=item abs - -This returns the absolute file path by constructing a path from the -'root' and 'path' options. - - [% USE file('foo/bar.html', root='/tmp') %] - [% file.path %] # foo/bar.html - [% file.root %] # /tmp - [% file.abs %] # /tmp/foo/bar.html - -=back - -In addition, the following method is provided: - -=over 4 - -=item 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 'home' -item. - - [% USE file('foo/bar/baz.html') %] - [% file.rel('wiz/waz.html') %] # ../../wiz/waz.html - -=back - -=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.abspath %] # /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.abspath %] # 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.abspath %] # 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.abspath %] # /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 E<lt>michael@etla.orgE<gt> wrote the original Directory plugin -on which this is based. Andy Wardley E<lt>abw@wardley.orgE<gt> split it into -separate File and Directory plugins, added some extra code and documentation -for VIEW support, and made a few other minor tweaks. - -=head1 VERSION - -2.64, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - - - -=head1 COPYRIGHT - -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|Template::Plugin>, L<Template::Plugin::Directory|Template::Plugin::Directory>, L<Template::View|Template::View> - diff --git a/lib/Template/Plugin/Filter.pm b/lib/Template/Plugin/Filter.pm deleted file mode 100644 index 38da7ba..0000000 --- a/lib/Template/Plugin/Filter.pm +++ /dev/null @@ -1,436 +0,0 @@ -#============================================================= -*-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@kfs.org> -# -# COPYRIGHT -# Copyright (C) 2001 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. -# -# REVISION -# $Id: Filter.pm,v 1.30 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::Filter; - -require 5.004; - -use strict; -use Template::Plugin; - -use base qw( Template::Plugin ); -use vars qw( $VERSION $DYNAMIC ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/); -$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; - - if ($self->{ _DYNAMIC }) { - return $self->{ _DYNAMIC_FILTER } ||= [ sub { - my ($context, @args) = @_; - my $config = ref $args[-1] eq 'HASH' ? pop(@args) : { }; - - return sub { - $self->filter(shift, \@args, $config); - }; - }, 1 ]; - } - else { - return $self->{ _STATIC_FILTER } ||= sub { - $self->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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 Template::Plugin::Filter class. - - package MyOrg::Template::Plugin::MyFilter; - - use Template::Plugin::Filter; - use base qw( Template::Plugin::Filter ); - -Then simply define your filter() method. When called, you get -passed a reference to your plugin object ($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 USE your plugin in the normal way. - - [% USE MyFilter %] - -The object returned is stored in the variable of the same name, -'MyFilter'. When you come to use it as a FILTER, you should add -a dollar prefix. This indicates that you want to use the filter -stored in the variable 'MyFilter' rather than the filter named -'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 -USE directive are stored internally in the object for inspection by -the filter() method (or indeed any other method). Positional -arguments are stored as a reference to a list in the _ARGS item while -named configuration parameters are stored as a reference to a hash -array in the _CONFIG item. - -For example, loading a plugin as shown here: - - [% USE blat = MyFilter 'foo' 'bar' baz = 'blam' %] - -would allow the 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 USE directive and re-used for all subsequent -FILTER operations. That means that any argument specified with -the FILTER directive are ignored. - -Dynamic filters, on the other hand, are re-created each time -they are used by a FILTER directive. This allows them to act -on any parameters passed from the FILTER directive and modify -their behaviour accordingly. - -There are two ways to create a dynamic filter. The first is to -define a $DYNAMIC class variable set to a true value. - - package MyOrg::Template::Plugin::MyFilter; - - use Template::Plugin::Filter; - use base qw( Template::Plugin::Filter ); - use vars qw( $DYNAMIC ); - - $DYNAMIC = 1; - -The other way is to set the internal _DYNAMIC value within the init() -method which gets called by the 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 filter() method -will now also get passed a reference to an array of postional -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 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 merge_args() and merge_config() methods to do a quick -and easy job of merging the local (e.g. FILTER) parameters with the -internal (e.g. 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 install_filter() method from the 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@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -1.30, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin>, L<Template::Filters|Template::Filters>, L<Template::Manual::Filters|Template::Manual::Filters> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/Format.pm b/lib/Template/Plugin/Format.pm deleted file mode 100644 index bba55d2..0000000 --- a/lib/Template/Plugin/Format.pm +++ /dev/null @@ -1,124 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::Format -# -# DESCRIPTION -# -# Simple Template Toolkit Plugin which creates formatting functions. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Format.pm,v 2.64 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::Format; - -require 5.004; - -use strict; -use vars qw( @ISA $VERSION ); -use base qw( Template::Plugin ); -use Template::Plugin; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.64 $ =~ /(\d+)\.(\d+)/); - - -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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 printf()-like format string. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.64, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Constants.pm b/lib/Template/Plugin/GD/Constants.pm deleted file mode 100644 index 6fc8e7c..0000000 --- a/lib/Template/Plugin/GD/Constants.pm +++ /dev/null @@ -1,138 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Constants -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD constants -# in the GD.pm module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: Constants.pm,v 1.55 2004/01/13 16:20:46 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Constants; - -require 5.004; - -use strict; -use GD qw(/^gd/ /^GD/); -use Template::Plugin; -use base qw( Template::Plugin ); -use vars qw( @ISA $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.55 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - my $self = { }; - bless $self, $class; - - # - # GD has exported various gd* and GD_* contstants. Find them. - # - foreach my $v ( keys(%Template::Plugin::GD::Constants::) ) { - $self->{$v} = eval($v) if ( $v =~ /^gd/ || $v =~ /^GD_/ ); - } - return $self; -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Constants - Interface to GD module constants - -=head1 SYNOPSIS - - [% USE gdc = GD.Constants %] - - # --> the constants gdc.gdBrushed, gdc.gdSmallFont, gdc.GD_CMP_IMAGE - # are now available - -=head1 EXAMPLES - - [% FILTER null; - USE gdc = GD.Constants; - USE im = GD.Image(200,100); - black = im.colorAllocate(0 ,0, 0); - red = im.colorAllocate(255,0, 0); - r = im.string(gdc.gdLargeFont, 10, 10, "Large Red Text", red); - im.png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Constants plugin provides access to the various GD module's -constants (such as gdBrushed, gdSmallFont, gdTransparent, GD_CMP_IMAGE -etc). When GD.pm is used in perl it exports various contstants -into the caller's namespace. This plugin makes those exported -constants available as template variables. - -See L<Template::Plugin::GD::Image> and L<GD> for further examples and -details. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -Lincoln D. Stein wrote the GD.pm interface to the GD library. - - -=head1 VERSION - -1.55, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -The GD.pm interface is copyright 1995-2000, Lincoln D. Stein. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Image|Template::Plugin::GD::Image>, L<Template::Plugin::GD::Polygon|Template::Plugin::GD::Polygon>, L<GD|GD> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Graph/area.pm b/lib/Template/Plugin/GD/Graph/area.pm deleted file mode 100644 index d09d024..0000000 --- a/lib/Template/Plugin/GD/Graph/area.pm +++ /dev/null @@ -1,148 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Graph::area -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Graph::area -# package in the GD::Graph.pm module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: area.pm,v 1.57 2004/01/13 16:20:51 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Graph::area; - -require 5.004; - -use strict; -use GD::Graph::area; -use Template::Plugin; -use base qw( GD::Graph::area Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.57 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - return $class->SUPER::new(@_); -} - -sub set -{ - my $self = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - $self->SUPER::set(@_); -} - - -sub set_legend -{ - my $self = shift; - - $self->SUPER::set_legend(ref $_[0] ? @{$_[0]} : @_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Graph::area - Create area graphs with axes and legends - -=head1 SYNOPSIS - - [% USE g = GD.Graph.area(x_size, y_size); %] - -=head1 EXAMPLES - - [% FILTER null; - data = [ - ["1st","2nd","3rd","4th","5th","6th","7th", "8th", "9th"], - [ 5, 12, 24, 33, 19, 8, 6, 15, 21], - [ -1, -2, -5, -6, -3, 1.5, 1, 1.3, 2] - ]; - - USE my_graph = GD.Graph.area(); - my_graph.set( - two_axes => 1, - zero_axis => 1, - transparent => 0, - ); - my_graph.set_legend('left axis', 'right axis' ); - my_graph.plot(data).png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Graph.area plugin provides an interface to the GD::Graph::area -class defined by the GD::Graph module. It allows one or more (x,y) data -sets to be plotted as lines with the area between the line and x-axis -shaded, in addition to axes and legends. - -See L<GD::Graph> for more details. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -The GD::Graph module was written by Martien Verbruggen. - - -=head1 VERSION - -1.57, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -GD::Graph is copyright 1999 Martien Verbruggen. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Graph::lines|Template::Plugin::GD::Graph::lines>, L<Template::Plugin::GD::Graph::lines3d|Template::Plugin::GD::Graph::lines3d>, L<Template::Plugin::GD::Graph::bars|Template::Plugin::GD::Graph::bars>, L<Template::Plugin::GD::Graph::bars3d|Template::Plugin::GD::Graph::bars3d>, L<Template::Plugin::GD::Graph::points|Template::Plugin::GD::Graph::points>, L<Template::Plugin::GD::Graph::linespoints|Template::Plugin::GD::Graph::linespoints>, L<Template::Plugin::GD::Graph::mixed|Template::Plugin::GD::Graph::mixed>, L<Template::Plugin::GD::Graph::pie|Template::Plugin::GD::Graph::pie>, L<Template::Plugin::GD::Graph::pie3d|Template::Plugin::GD::Graph::pie3d>, L<GD::Graph|GD::Graph> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Graph/bars.pm b/lib/Template/Plugin/GD/Graph/bars.pm deleted file mode 100644 index 9bc08c5..0000000 --- a/lib/Template/Plugin/GD/Graph/bars.pm +++ /dev/null @@ -1,191 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Graph::bars -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Graph::bars -# package in the GD::Graph.pm module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: bars.pm,v 1.57 2004/01/13 16:20:56 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Graph::bars; - -require 5.004; - -use strict; -use GD::Graph::bars; -use Template::Plugin; -use base qw( GD::Graph::bars Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.57 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - return $class->SUPER::new(@_); -} - -sub set -{ - my $self = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - $self->SUPER::set(@_); -} - - -sub set_legend -{ - my $self = shift; - - $self->SUPER::set_legend(ref $_[0] ? @{$_[0]} : @_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Graph::bars - Create bar graphs with axes and legends - -=head1 SYNOPSIS - - [% USE g = GD.Graph.bars(x_size, y_size); %] - -=head1 EXAMPLES - - [% FILTER null; - data = [ - ["1st","2nd","3rd","4th","5th","6th","7th", "8th", "9th"], - [ 1, 2, 5, 6, 3, 1.5, 1, 3, 4], - ]; - - USE my_graph = GD.Graph.bars(); - - my_graph.set( - x_label => 'X Label', - y_label => 'Y label', - title => 'A Simple Bar Chart', - y_max_value => 8, - y_tick_number => 8, - y_label_skip => 2, - - # shadows - bar_spacing => 8, - shadow_depth => 4, - shadowclr => 'dred', - - transparent => 0, - ); - my_graph.plot(data).png | stdout(1); - END; - -%] - - [% FILTER null; - data = [ - ["1st","2nd","3rd","4th","5th","6th","7th", "8th", "9th"], - [ 5, 12, 24, 33, 19, 8, 6, 15, 21], - [ 1, 2, 5, 6, 3, 1.5, 1, 3, 4], - ]; - - USE my_graph = GD.Graph.bars(); - - my_graph.set( - x_label => 'X Label', - y_label => 'Y label', - title => 'Two data sets', - - # shadows - bar_spacing => 8, - shadow_depth => 4, - shadowclr => 'dred', - - long_ticks => 1, - y_max_value => 40, - y_tick_number => 8, - y_label_skip => 2, - bar_spacing => 3, - - accent_treshold => 200, - - transparent => 0, - ); - my_graph.set_legend( 'Data set 1', 'Data set 2' ); - my_graph.plot(data).png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Graph.bars plugin provides an interface to the GD::Graph::bars -class defined by the GD::Graph module. It allows one or more (x,y) data -sets to be plotted with each point represented by a bar, in addition -to axes and legends. - -See L<GD::Graph> for more details. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -The GD::Graph module was written by Martien Verbruggen. - - -=head1 VERSION - -1.57, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -GD::Graph is copyright 1999 Martien Verbruggen. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Graph::lines|Template::Plugin::GD::Graph::lines>, L<Template::Plugin::GD::Graph::lines3d|Template::Plugin::GD::Graph::lines3d>, L<Template::Plugin::GD::Graph::bars3d|Template::Plugin::GD::Graph::bars3d>, L<Template::Plugin::GD::Graph::points|Template::Plugin::GD::Graph::points>, L<Template::Plugin::GD::Graph::linespoints|Template::Plugin::GD::Graph::linespoints>, L<Template::Plugin::GD::Graph::area|Template::Plugin::GD::Graph::area>, L<Template::Plugin::GD::Graph::mixed|Template::Plugin::GD::Graph::mixed>, L<Template::Plugin::GD::Graph::pie|Template::Plugin::GD::Graph::pie>, L<Template::Plugin::GD::Graph::pie3d|Template::Plugin::GD::Graph::pie3d>, L<GD::Graph|GD::Graph> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Graph/bars3d.pm b/lib/Template/Plugin/GD/Graph/bars3d.pm deleted file mode 100644 index 79a930b..0000000 --- a/lib/Template/Plugin/GD/Graph/bars3d.pm +++ /dev/null @@ -1,166 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Graph::bars3d -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Graph::bars3d -# package in the GD::Graph3D.pm module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: bars3d.pm,v 1.57 2004/01/13 16:20:56 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Graph::bars3d; - -require 5.004; - -use strict; -use GD::Graph::bars3d; -use Template::Plugin; -use base qw( GD::Graph::bars3d Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.57 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - return $class->SUPER::new(@_); -} - -sub set -{ - my $self = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - $self->SUPER::set(@_); -} - - -sub set_legend -{ - my $self = shift; - - $self->SUPER::set_legend(ref $_[0] ? @{$_[0]} : @_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Graph::bars3d - Create 3D bar graphs with axes and legends - -=head1 SYNOPSIS - - [% USE g = GD.Graph.bars3d(x_size, y_size); %] - -=head1 EXAMPLES - - [% FILTER null; - data = [ - ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", - "Sep", "Oct", "Nov", "Dec", ], - [-5, -4, -3, -3, -1, 0, 2, 1, 3, 4, 6, 7], - [4, 3, 5, 6, 3,1.5, -1, -3, -4, -6, -7, -8], - [1, 2, 2, 3, 4, 3, 1, -1, 0, 2, 3, 2], - ]; - - USE my_graph = GD.Graph.bars3d(); - - my_graph.set( - x_label => 'Month', - y_label => 'Measure of success', - title => 'A 3d Bar Chart', - - y_max_value => 8, - y_min_value => -8, - y_tick_number => 16, - y_label_skip => 2, - box_axis => 0, - line_width => 3, - zero_axis_only => 1, - x_label_position => 1, - y_label_position => 1, - - x_label_skip => 3, - x_tick_offset => 2, - - transparent => 0, - ); - my_graph.set_legend("Us", "Them", "Others"); - my_graph.plot(data).png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Graph.bars3d plugin provides an interface to the GD::Graph::bars3d -class defined by the GD::Graph3d module. It allows one or more (x,y) data -sets to be plotted as y versus x bars with a 3-dimensional appearance, -together with axes and legends. - -See L<GD::Graph3d> for more details. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -The GD::Graph3d module was written by Jeremy Wadsack. - - -=head1 VERSION - -1.57, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -GD::Graph3d is copyright (C) 1999,2000 Wadsack-Allen. 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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Graph::lines|Template::Plugin::GD::Graph::lines>, L<Template::Plugin::GD::Graph::lines3d|Template::Plugin::GD::Graph::lines3d>, L<Template::Plugin::GD::Graph::bars|Template::Plugin::GD::Graph::bars>, L<Template::Plugin::GD::Graph::points|Template::Plugin::GD::Graph::points>, L<Template::Plugin::GD::Graph::linespoints|Template::Plugin::GD::Graph::linespoints>, L<Template::Plugin::GD::Graph::area|Template::Plugin::GD::Graph::area>, L<Template::Plugin::GD::Graph::mixed|Template::Plugin::GD::Graph::mixed>, L<Template::Plugin::GD::Graph::pie|Template::Plugin::GD::Graph::pie>, L<Template::Plugin::GD::Graph::pie3d|Template::Plugin::GD::Graph::pie3d>, L<GD::Graph|GD::Graph>, L<GD::Graph3d|GD::Graph3d> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Graph/lines.pm b/lib/Template/Plugin/GD/Graph/lines.pm deleted file mode 100644 index 678cc64..0000000 --- a/lib/Template/Plugin/GD/Graph/lines.pm +++ /dev/null @@ -1,178 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Graph::lines -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Graph::lines -# package in the GD::Graph.pm module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: lines.pm,v 1.57 2004/01/13 16:20:56 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Graph::lines; - -require 5.004; - -use strict; -use GD::Graph::lines; -use Template::Plugin; -use base qw( GD::Graph::lines Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.57 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - return $class->SUPER::new(@_); -} - -sub set -{ - my $self = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - $self->SUPER::set(@_); -} - - -sub set_legend -{ - my $self = shift; - - $self->SUPER::set_legend(ref $_[0] ? @{$_[0]} : @_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Graph::lines - Create line graphs with axes and legends - -=head1 SYNOPSIS - - [% USE g = GD.Graph.lines(x_size, y_size); %] - -=head1 EXAMPLES - - [% FILTER null; - USE g = GD.Graph.lines(300,200); - x = [1, 2, 3, 4]; - y = [5, 4, 2, 3]; - g.set( - x_label => 'X Label', - y_label => 'Y label', - title => 'Title' - ); - g.plot([x, y]).png | stdout(1); - END; - -%] - - [% FILTER null; - data = [ - ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", - "Sep", "Oct", "Nov", "Dec", ], - [-5, -4, -3, -3, -1, 0, 2, 1, 3, 4, 6, 7], - [4, 3, 5, 6, 3,1.5, -1, -3, -4, -6, -7, -8], - [1, 2, 2, 3, 4, 3, 1, -1, 0, 2, 3, 2], - ]; - - USE my_graph = GD.Graph.lines(); - - my_graph.set( - x_label => 'Month', - y_label => 'Measure of success', - title => 'A Simple Line Graph', - - y_max_value => 8, - y_min_value => -8, - y_tick_number => 16, - y_label_skip => 2, - box_axis => 0, - line_width => 3, - zero_axis_only => 1, - x_label_position => 1, - y_label_position => 1, - - x_label_skip => 3, - x_tick_offset => 2, - - transparent => 0, - ); - my_graph.set_legend("Us", "Them", "Others"); - my_graph.plot(data).png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Graph.lines plugin provides an interface to the GD::Graph::lines -class defined by the GD::Graph module. It allows one or more (x,y) data -sets to be plotted as y versus x lines with axes and legends. - -See L<GD::Graph> for more details. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -The GD::Graph module was written by Martien Verbruggen. - - -=head1 VERSION - -1.57, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -GD::Graph is copyright 1999 Martien Verbruggen. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Graph::lines3d|Template::Plugin::GD::Graph::lines3d>, L<Template::Plugin::GD::Graph::bars|Template::Plugin::GD::Graph::bars>, L<Template::Plugin::GD::Graph::bars3d|Template::Plugin::GD::Graph::bars3d>, L<Template::Plugin::GD::Graph::points|Template::Plugin::GD::Graph::points>, L<Template::Plugin::GD::Graph::linespoints|Template::Plugin::GD::Graph::linespoints>, L<Template::Plugin::GD::Graph::area|Template::Plugin::GD::Graph::area>, L<Template::Plugin::GD::Graph::mixed|Template::Plugin::GD::Graph::mixed>, L<Template::Plugin::GD::Graph::pie|Template::Plugin::GD::Graph::pie>, L<Template::Plugin::GD::Graph::pie3d|Template::Plugin::GD::Graph::pie3d>, L<GD::Graph|GD::Graph> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Graph/lines3d.pm b/lib/Template/Plugin/GD/Graph/lines3d.pm deleted file mode 100644 index 1f12715..0000000 --- a/lib/Template/Plugin/GD/Graph/lines3d.pm +++ /dev/null @@ -1,166 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Graph::lines3d -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Graph::lines3d -# package in the GD::Graph3D.pm module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: lines3d.pm,v 1.57 2004/01/13 16:20:56 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Graph::lines3d; - -require 5.004; - -use strict; -use GD::Graph::lines3d; -use Template::Plugin; -use base qw( GD::Graph::lines3d Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.57 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - return $class->SUPER::new(@_); -} - -sub set -{ - my $self = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - $self->SUPER::set(@_); -} - - -sub set_legend -{ - my $self = shift; - - $self->SUPER::set_legend(ref $_[0] ? @{$_[0]} : @_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Graph::lines3d - Create 3D line graphs with axes and legends - -=head1 SYNOPSIS - - [% USE g = GD.Graph.lines3d(x_size, y_size); %] - -=head1 EXAMPLES - - [% FILTER null; - data = [ - ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", - "Sep", "Oct", "Nov", "Dec", ], - [-5, -4, -3, -3, -1, 0, 2, 1, 3, 4, 6, 7], - [4, 3, 5, 6, 3,1.5, -1, -3, -4, -6, -7, -8], - [1, 2, 2, 3, 4, 3, 1, -1, 0, 2, 3, 2], - ]; - - USE my_graph = GD.Graph.lines3d(); - - my_graph.set( - x_label => 'Month', - y_label => 'Measure of success', - title => 'A 3d Line Graph', - - y_max_value => 8, - y_min_value => -8, - y_tick_number => 16, - y_label_skip => 2, - box_axis => 0, - line_width => 3, - zero_axis_only => 1, - x_label_position => 1, - y_label_position => 1, - - x_label_skip => 3, - x_tick_offset => 2, - - transparent => 0, - ); - my_graph.set_legend("Us", "Them", "Others"); - my_graph.plot(data).png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Graph.lines3d plugin provides an interface to the GD::Graph::lines3d -class defined by the GD::Graph3d module. It allows one or more (x,y) data -sets to be plotted as y versus x lines with a 3-dimensional appearance, -together with axes and legends. - -See L<GD::Graph3d> for more details. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -The GD::Graph3d module was written by Jeremy Wadsack. - - -=head1 VERSION - -1.57, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -GD::Graph3d is copyright (C) 1999,2000 Wadsack-Allen. 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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Graph::lines|Template::Plugin::GD::Graph::lines>, L<Template::Plugin::GD::Graph::bars|Template::Plugin::GD::Graph::bars>, L<Template::Plugin::GD::Graph::bars3d|Template::Plugin::GD::Graph::bars3d>, L<Template::Plugin::GD::Graph::points|Template::Plugin::GD::Graph::points>, L<Template::Plugin::GD::Graph::linespoints|Template::Plugin::GD::Graph::linespoints>, L<Template::Plugin::GD::Graph::area|Template::Plugin::GD::Graph::area>, L<Template::Plugin::GD::Graph::mixed|Template::Plugin::GD::Graph::mixed>, L<Template::Plugin::GD::Graph::pie|Template::Plugin::GD::Graph::pie>, L<Template::Plugin::GD::Graph::pie3d|Template::Plugin::GD::Graph::pie3d>, L<GD::Graph|GD::Graph>, L<GD::Graph3d|GD::Graph3d> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Graph/linespoints.pm b/lib/Template/Plugin/GD/Graph/linespoints.pm deleted file mode 100644 index 8dc48d9..0000000 --- a/lib/Template/Plugin/GD/Graph/linespoints.pm +++ /dev/null @@ -1,158 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Graph::linespoints -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Graph::linespoints -# package in the GD::Graph.pm module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: linespoints.pm,v 1.57 2004/01/13 16:20:56 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Graph::linespoints; - -require 5.004; - -use strict; -use GD::Graph::linespoints; -use Template::Plugin; -use base qw( GD::Graph::linespoints Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.57 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - return $class->SUPER::new(@_); -} - -sub set -{ - my $self = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - $self->SUPER::set(@_); -} - - -sub set_legend -{ - my $self = shift; - - $self->SUPER::set_legend(ref $_[0] ? @{$_[0]} : @_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Graph::linespoints - Create line/point graphs with axes and legends - -=head1 SYNOPSIS - - [% USE g = GD.Graph.linespoints(x_size, y_size); %] - -=head1 EXAMPLES - - [% FILTER null; - data = [ - ["1st","2nd","3rd","4th","5th","6th","7th", "8th", "9th"], - [50, 52, 53, 54, 55, 56, 57, 58, 59], - [60, 61, 61, 63, 68, 66, 65, 61, 58], - [70, 72, 71, 74, 78, 73, 75, 71, 68], - ]; - - USE my_graph = GD.Graph.linespoints; - - my_graph.set( - x_label => 'X Label', - y_label => 'Y label', - title => 'A Lines and Points Graph', - y_max_value => 80, - y_tick_number => 6, - y_label_skip => 2, - y_long_ticks => 1, - x_tick_length => 2, - markers => [ 1, 5 ], - skip_undef => 1, - transparent => 0, - ); - my_graph.set_legend('data set 1', 'data set 2', 'data set 3'); - my_graph.plot(data).png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Graph.linespoints plugin provides an interface to the -GD::Graph::linespoints class defined by the GD::Graph module. It allows -one or more (x,y) data sets to be plotted as y versus x lines, plus -symbols placed at each point, in addition to axes and legends. - -See L<GD::Graph> for more details. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -The GD::Graph module was written by Martien Verbruggen. - - -=head1 VERSION - -1.57, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -GD::Graph is copyright 1999 Martien Verbruggen. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Graph::lines|Template::Plugin::GD::Graph::lines>, L<Template::Plugin::GD::Graph::lines3d|Template::Plugin::GD::Graph::lines3d>, L<Template::Plugin::GD::Graph::bars|Template::Plugin::GD::Graph::bars>, L<Template::Plugin::GD::Graph::bars3d|Template::Plugin::GD::Graph::bars3d>, L<Template::Plugin::GD::Graph::points|Template::Plugin::GD::Graph::points>, L<Template::Plugin::GD::Graph::area|Template::Plugin::GD::Graph::area>, L<Template::Plugin::GD::Graph::mixed|Template::Plugin::GD::Graph::mixed>, L<Template::Plugin::GD::Graph::pie|Template::Plugin::GD::Graph::pie>, L<Template::Plugin::GD::Graph::pie3d|Template::Plugin::GD::Graph::pie3d>, L<GD::Graph|GD::Graph> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Graph/mixed.pm b/lib/Template/Plugin/GD/Graph/mixed.pm deleted file mode 100644 index 10dd533..0000000 --- a/lib/Template/Plugin/GD/Graph/mixed.pm +++ /dev/null @@ -1,176 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Graph::mixed -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Graph::mixed -# package in the GD::Graph.pm module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: mixed.pm,v 1.57 2004/01/13 16:20:56 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Graph::mixed; - -require 5.004; - -use strict; -use GD::Graph::mixed; -use Template::Plugin; -use base qw( GD::Graph::mixed Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.57 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - return $class->SUPER::new(@_); -} - -sub set -{ - my $self = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - $self->SUPER::set(@_); -} - - -sub set_legend -{ - my $self = shift; - - $self->SUPER::set_legend(ref $_[0] ? @{$_[0]} : @_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Graph::mixed - Create mixed graphs with axes and legends - -=head1 SYNOPSIS - - [% USE g = GD.Graph.mixed(x_size, y_size); %] - -=head1 EXAMPLES - - [% FILTER null; - data = [ - ["1st","2nd","3rd","4th","5th","6th","7th", "8th", "9th"], - [ 1, 2, 5, 6, 3, 1.5, -1, -3, -4], - [ -4, -3, 1, 1, -3, -1.5, -2, -1, 0], - [ 9, 8, 9, 8.4, 7.1, 7.5, 8, 3, -3], - [ 0.1, 0.2, 0.5, 0.4, 0.3, 0.5, 0.1, 0, 0.4], - [ -0.1, 2, 5, 4, -3, 2.5, 3.2, 4, -4], - ]; - - USE my_graph = GD.Graph.mixed(); - - my_graph.set( - types => ['lines', 'lines', 'points', 'area', 'linespoints'], - default_type => 'points', - ); - - my_graph.set( - - x_label => 'X Label', - y_label => 'Y label', - title => 'A Mixed Type Graph', - - y_max_value => 10, - y_min_value => -5, - y_tick_number => 3, - y_label_skip => 0, - x_plot_values => 0, - y_plot_values => 0, - - long_ticks => 1, - x_ticks => 0, - - legend_marker_width => 24, - line_width => 3, - marker_size => 5, - - bar_spacing => 8, - - transparent => 0, - ); - - my_graph.set_legend('one', 'two', 'three', 'four', 'five', 'six'); - my_graph.plot(data).png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Graph.mixed plugin provides an interface to the GD::Graph::mixed -class defined by the GD::Graph module. It allows one or more (x,y) data -sets to be plotted with various styles (lines, points, bars, areas etc). - -See L<GD::Graph> for more details. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -The GD::Graph module was written by Martien Verbruggen. - - -=head1 VERSION - -1.57, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -GD::Graph is copyright 1999 Martien Verbruggen. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Graph::lines|Template::Plugin::GD::Graph::lines>, L<Template::Plugin::GD::Graph::lines3d|Template::Plugin::GD::Graph::lines3d>, L<Template::Plugin::GD::Graph::bars|Template::Plugin::GD::Graph::bars>, L<Template::Plugin::GD::Graph::bars3d|Template::Plugin::GD::Graph::bars3d>, L<Template::Plugin::GD::Graph::points|Template::Plugin::GD::Graph::points>, L<Template::Plugin::GD::Graph::linespoints|Template::Plugin::GD::Graph::linespoints>, L<Template::Plugin::GD::Graph::area|Template::Plugin::GD::Graph::area>, L<Template::Plugin::GD::Graph::pie|Template::Plugin::GD::Graph::pie>, L<Template::Plugin::GD::Graph::pie3d|Template::Plugin::GD::Graph::pie3d>, L<GD::Graph|GD::Graph> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Graph/pie.pm b/lib/Template/Plugin/GD/Graph/pie.pm deleted file mode 100644 index e72e26c..0000000 --- a/lib/Template/Plugin/GD/Graph/pie.pm +++ /dev/null @@ -1,141 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Graph::pie -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Graph::pie -# package in the GD::Graph.pm module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: pie.pm,v 1.55 2004/01/13 16:20:56 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Graph::pie; - -require 5.004; - -use strict; -use GD::Graph::pie; -use Template::Plugin; -use base qw( GD::Graph::pie Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.55 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - return $class->SUPER::new(@_); -} - -sub set -{ - my $self = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - $self->SUPER::set(@_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Graph::pie - Create pie charts with legends - -=head1 SYNOPSIS - - [% USE g = GD.Graph.pie(x_size, y_size); %] - -=head1 EXAMPLES - - [% FILTER null; - data = [ - ["1st","2nd","3rd","4th","5th","6th"], - [ 4, 2, 3, 4, 3, 3.5] - ]; - - USE my_graph = GD.Graph.pie( 250, 200 ); - - my_graph.set( - title => 'A Pie Chart', - label => 'Label', - axislabelclr => 'black', - pie_height => 36, - - transparent => 0, - ); - my_graph.plot(data).png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Graph.pie plugin provides an interface to the GD::Graph::pie -class defined by the GD::Graph module. It allows an (x,y) data set to -be plotted as a pie chart. The x values are typically strings. - -See L<GD::Graph> for more details. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -The GD::Graph module was written by Martien Verbruggen. - - -=head1 VERSION - -1.55, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -GD::Graph is copyright 1999 Martien Verbruggen. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Graph::lines|Template::Plugin::GD::Graph::lines>, L<Template::Plugin::GD::Graph::lines3d|Template::Plugin::GD::Graph::lines3d>, L<Template::Plugin::GD::Graph::bars|Template::Plugin::GD::Graph::bars>, L<Template::Plugin::GD::Graph::bars3d|Template::Plugin::GD::Graph::bars3d>, L<Template::Plugin::GD::Graph::points|Template::Plugin::GD::Graph::points>, L<Template::Plugin::GD::Graph::linespoints|Template::Plugin::GD::Graph::linespoints>, L<Template::Plugin::GD::Graph::area|Template::Plugin::GD::Graph::area>, L<Template::Plugin::GD::Graph::mixed|Template::Plugin::GD::Graph::mixed>, L<Template::Plugin::GD::Graph::pie3d|Template::Plugin::GD::Graph::pie3d>, L<GD::Graph|GD::Graph> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Graph/pie3d.pm b/lib/Template/Plugin/GD/Graph/pie3d.pm deleted file mode 100644 index 5f677e0..0000000 --- a/lib/Template/Plugin/GD/Graph/pie3d.pm +++ /dev/null @@ -1,145 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Graph::pie3d -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Graph::pie3d -# package in the GD::Graph3D.pm module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: pie3d.pm,v 1.55 2004/01/13 16:20:56 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Graph::pie3d; - -require 5.004; - -use strict; -use GD::Graph::pie3d; -use Template::Plugin; -use base qw( GD::Graph::pie3d Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.55 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - return $class->SUPER::new(@_); -} - -sub set -{ - my $self = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - $self->SUPER::set(@_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Graph::pie3d - Create 3D pie charts with legends - -=head1 SYNOPSIS - - [% USE g = GD.Graph.pie3d(x_size, y_size); %] - -=head1 EXAMPLES - - [% FILTER null; - data = [ - ["1st","2nd","3rd","4th","5th","6th"], - [ 4, 2, 3, 4, 3, 3.5] - ]; - - USE my_graph = GD.Graph.pie3d( 250, 200 ); - - my_graph.set( - title => 'A Pie Chart', - label => 'Label', - axislabelclr => 'black', - pie_height => 36, - - transparent => 0, - ); - my_graph.plot(data).png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Graph.pie3d plugin provides an interface to the GD::Graph::pie3d -class defined by the GD::Graph module. It allows an (x,y) data set to -be plotted as a 3d pie chart. The x values are typically strings. - -Note that GD::Graph::pie already produces a 3d effect, so GD::Graph::pie3d -is just a wrapper around GD::Graph::pie. Similarly, the plugin -GD.Graph.pie3d is effectively the same as the plugin GD.Graph.pie. - -See L<GD::Graph3d> for more details. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -The GD::Graph3d module was written by Jeremy Wadsack. The GD::Graph module was written by Martien Verbruggen. - - -=head1 VERSION - -1.55, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -GD::Graph3d is copyright (c) 1999,2000 Wadsack-Allen. All Rights Reserved. GD::Graph is copyright 1999 Martien Verbruggen. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Graph::lines|Template::Plugin::GD::Graph::lines>, L<Template::Plugin::GD::Graph::lines3d|Template::Plugin::GD::Graph::lines3d>, L<Template::Plugin::GD::Graph::bars|Template::Plugin::GD::Graph::bars>, L<Template::Plugin::GD::Graph::bars3d|Template::Plugin::GD::Graph::bars3d>, L<Template::Plugin::GD::Graph::points|Template::Plugin::GD::Graph::points>, L<Template::Plugin::GD::Graph::linespoints|Template::Plugin::GD::Graph::linespoints>, L<Template::Plugin::GD::Graph::area|Template::Plugin::GD::Graph::area>, L<Template::Plugin::GD::Graph::mixed|Template::Plugin::GD::Graph::mixed>, L<Template::Plugin::GD::Graph::pie|Template::Plugin::GD::Graph::pie>, L<GD::Graph|GD::Graph>, L<GD::Graph3d|GD::Graph3d> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Graph/points.pm b/lib/Template/Plugin/GD/Graph/points.pm deleted file mode 100644 index 97acf51..0000000 --- a/lib/Template/Plugin/GD/Graph/points.pm +++ /dev/null @@ -1,155 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Graph::points -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Graph::points -# package in the GD::Graph.pm module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: points.pm,v 1.57 2004/01/13 16:20:56 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Graph::points; - -require 5.004; - -use strict; -use GD::Graph::points; -use Template::Plugin; -use base qw( GD::Graph::points Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.57 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - return $class->SUPER::new(@_); -} - -sub set -{ - my $self = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - $self->SUPER::set(@_); -} - - -sub set_legend -{ - my $self = shift; - - $self->SUPER::set_legend(ref $_[0] ? @{$_[0]} : @_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Graph::points - Create point graphs with axes and legends - -=head1 SYNOPSIS - - [% USE g = GD.Graph.points(x_size, y_size); %] - -=head1 EXAMPLES - - [% FILTER null; - data = [ - ["1st","2nd","3rd","4th","5th","6th","7th", "8th", "9th"], - [ 5, 12, 24, 33, 19, 8, 6, 15, 21], - [ 1, 2, 5, 6, 3, 1.5, 2, 3, 4], - ]; - USE my_graph = GD.Graph.points(); - my_graph.set( - x_label => 'X Label', - y_label => 'Y label', - title => 'A Points Graph', - y_max_value => 40, - y_tick_number => 8, - y_label_skip => 2, - legend_placement => 'RC', - long_ticks => 1, - marker_size => 6, - markers => [ 1, 7, 5 ], - - transparent => 0, - ); - my_graph.set_legend('one', 'two'); - my_graph.plot(data).png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Graph.points plugin provides an interface to the GD::Graph::points -class defined by the GD::Graph module. It allows one or more (x,y) data -sets to be plotted as points, in addition to axes and legends. - -See L<GD::Graph> for more details. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -The GD::Graph module was written by Martien Verbruggen. - - -=head1 VERSION - -1.57, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -GD::Graph is copyright 1999 Martien Verbruggen. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Graph::lines|Template::Plugin::GD::Graph::lines>, L<Template::Plugin::GD::Graph::lines3d|Template::Plugin::GD::Graph::lines3d>, L<Template::Plugin::GD::Graph::bars|Template::Plugin::GD::Graph::bars>, L<Template::Plugin::GD::Graph::bars3d|Template::Plugin::GD::Graph::bars3d>, L<Template::Plugin::GD::Graph::linespoints|Template::Plugin::GD::Graph::linespoints>, L<Template::Plugin::GD::Graph::area|Template::Plugin::GD::Graph::area>, L<Template::Plugin::GD::Graph::mixed|Template::Plugin::GD::Graph::mixed>, L<Template::Plugin::GD::Graph::pie|Template::Plugin::GD::Graph::pie>, L<Template::Plugin::GD::Graph::pie3d|Template::Plugin::GD::Graph::pie3d>, L<GD::Graph|GD::Graph> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Image.pm b/lib/Template/Plugin/GD/Image.pm deleted file mode 100644 index 46a06d7..0000000 --- a/lib/Template/Plugin/GD/Image.pm +++ /dev/null @@ -1,184 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Image -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Image -# class in the GD.pm module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: Image.pm,v 1.55 2004/01/13 16:20:46 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Image; - -require 5.004; - -use strict; -use GD; -use Template::Plugin; -use base qw( GD Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.55 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - return new GD::Image(@_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Image - Interface to GD Graphics Library - -=head1 SYNOPSIS - - [% USE im = GD.Image(x_size, y_size) %] - -=head1 EXAMPLES - - [% FILTER null; - USE gdc = GD.Constants; - USE im = GD.Image(200,100); - black = im.colorAllocate(0 ,0, 0); - red = im.colorAllocate(255,0, 0); - r = im.string(gdc.gdLargeFont, 10, 10, "Large Red Text", red); - im.png | stdout(1); - END; - -%] - - [% FILTER null; - USE im = GD.Image(100,100); - # allocate some colors - black = im.colorAllocate(0, 0, 0); - red = im.colorAllocate(255,0, 0); - blue = im.colorAllocate(0, 0, 255); - # Draw a blue oval - im.arc(50,50,95,75,0,360,blue); - # And fill it with red - im.fill(50,50,red); - # Output binary image in PNG format - im.png | stdout(1); - END; - -%] - - [% FILTER null; - USE im = GD.Image(100,100); - USE c = GD.Constants; - USE poly = GD.Polygon; - - # allocate some colors - white = im.colorAllocate(255,255,255); - black = im.colorAllocate(0, 0, 0); - red = im.colorAllocate(255,0, 0); - blue = im.colorAllocate(0, 0,255); - green = im.colorAllocate(0, 255,0); - - # make the background transparent and interlaced - im.transparent(white); - im.interlaced('true'); - - # Put a black frame around the picture - im.rectangle(0,0,99,99,black); - - # Draw a blue oval - im.arc(50,50,95,75,0,360,blue); - - # And fill it with red - im.fill(50,50,red); - - # Draw a blue triangle - poly.addPt(50,0); - poly.addPt(99,99); - poly.addPt(0,99); - im.filledPolygon(poly, blue); - - # Output binary image in PNG format - im.png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Image plugin provides an interface to GD.pm's GD::Image class. -The GD::Image class is the main interface to GD.pm. - -It is very important that no extraneous template output appear before or -after the image. Since some methods return values that would otherwise -appear in the output, it is recommended that GD.Image code be wrapped in -a null filter. The methods that produce the final output (eg, png, jpeg, -gd etc) can then explicitly make their output appear by using the -stdout filter, with a non-zero argument to force binary mode (required -for non-modern operating systems). - -See L<GD> for a complete description of the GD library and all the -methods that can be called via the GD.Image plugin. -See L<Template::Plugin::GD::Constants> for a plugin that allows you -access to GD.pm's constants. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -Lincoln D. Stein wrote the GD.pm interface to the GD library. - - -=head1 VERSION - -1.55, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -The GD.pm interface is copyright 1995-2000, Lincoln D. Stein. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Polygon|Template::Plugin::GD::Polygon>, L<Template::Plugin::GD::Constants|Template::Plugin::GD::Constants>, L<GD|GD> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Polygon.pm b/lib/Template/Plugin/GD/Polygon.pm deleted file mode 100644 index 0d1d5c6..0000000 --- a/lib/Template/Plugin/GD/Polygon.pm +++ /dev/null @@ -1,155 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Polygon -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Polygon -# class in the GD.pm module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: Polygon.pm,v 1.55 2004/01/13 16:20:46 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Polygon; - -require 5.004; - -use strict; -use GD; -use Template::Plugin; -use base qw( Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.55 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - return new GD::Polygon(@_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Polygon - Interface to GD module Polygon class - -=head1 SYNOPSIS - - [% USE poly = GD.Polygon; - poly.addPt(50,0); - poly.addPt(99,99); - %] - -=head1 EXAMPLES - - [% FILTER null; - USE im = GD.Image(100,100); - USE c = GD.Constants; - - # allocate some colors - white = im.colorAllocate(255,255,255); - black = im.colorAllocate(0, 0, 0); - red = im.colorAllocate(255,0, 0); - blue = im.colorAllocate(0, 0,255); - green = im.colorAllocate(0, 255,0); - - # make the background transparent and interlaced - im.transparent(white); - im.interlaced('true'); - - # Put a black frame around the picture - im.rectangle(0,0,99,99,black); - - # Draw a blue oval - im.arc(50,50,95,75,0,360,blue); - - # And fill it with red - im.fill(50,50,red); - - # Draw a blue triangle by defining a polygon - USE poly = GD.Polygon; - poly.addPt(50,0); - poly.addPt(99,99); - poly.addPt(0,99); - im.filledPolygon(poly, blue); - - # Output binary image in PNG format - im.png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Polygon plugin provides an interface to GD.pm's GD::Polygon class. - -See L<GD> for a complete description of the GD library and all the -methods that can be called via the GD.Polygon plugin. -See L<Template::Plugin::GD::Image> for the main interface to the -GD functions. -See L<Template::Plugin::GD::Constants> for a plugin that allows you -access to GD.pm's constants. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -Lincoln D. Stein wrote the GD.pm interface to the GD library. - - -=head1 VERSION - -1.55, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -The GD.pm interface is copyright 1995-2000, Lincoln D. Stein. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Image|Template::Plugin::GD::Image>, L<Template::Plugin::GD::Constants|Template::Plugin::GD::Constants>, L<GD|GD> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Text.pm b/lib/Template/Plugin/GD/Text.pm deleted file mode 100644 index f18b2e0..0000000 --- a/lib/Template/Plugin/GD/Text.pm +++ /dev/null @@ -1,140 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Text -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Text -# module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: Text.pm,v 1.55 2004/01/13 16:20:46 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Text; - -require 5.004; - -use strict; -use GD::Text; -use Template::Plugin; -use base qw( GD::Text Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.55 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - return new GD::Text(@_); -} - -sub set -{ - my $self = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - $self->SUPER::set(@_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Text - Text utilities for use with GD - -=head1 SYNOPSIS - - [% USE gd_text = GD.Text %] - -=head1 EXAMPLES - - [% - USE gd_c = GD.Constants; - USE t = GD.Text; - x = t.set_text('Some text'); - r = t.get('width', 'height', 'char_up', 'char_down'); - r.join(":"); "\n"; # returns 54:13:13:0. - -%] - - [% - USE gd_c = GD.Constants; - USE t = GD.Text(text => 'FooBar Banana', font => gd_c.gdGiantFont); - t.get('width'); "\n"; # returns 117. - -%] - -=head1 DESCRIPTION - -The GD.Text plugin provides an interface to the GD::Text module. -It allows attributes of strings such as width and height in pixels -to be computed. - -See L<GD::Text> for more details. See -L<Template::Plugin::GD::Text::Align> and -L<Template::Plugin::GD::Text::Wrap> for plugins that -allow you to render aligned or wrapped text in GD images. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -The GD::Text module was written by Martien Verbruggen. - - -=head1 VERSION - -1.55, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -GD::Text is copyright 1999 Martien Verbruggen. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Text::Wrap|Template::Plugin::GD::Text::Wrap>, L<Template::Plugin::GD::Text::Align|Template::Plugin::GD::Text::Align>, L<GD|GD>, L<GD::Text|GD::Text> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Text/Align.pm b/lib/Template/Plugin/GD/Text/Align.pm deleted file mode 100644 index 8b79069..0000000 --- a/lib/Template/Plugin/GD/Text/Align.pm +++ /dev/null @@ -1,147 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Text::Align -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Text::Align -# module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: Align.pm,v 1.55 2004/01/13 16:21:46 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Text::Align; - -require 5.004; - -use strict; -use GD::Text::Align; -use Template::Plugin; -use base qw( GD::Text::Align Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.55 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - my $gd = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - return $class->SUPER::new($gd, @_); -} - -sub set -{ - my $self = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - $self->SUPER::set(@_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Text::Align - Draw aligned strings in GD images - -=head1 SYNOPSIS - - [% USE align = GD.Text.Align(gd_image); %] - -=head1 EXAMPLES - - [% FILTER null; - USE im = GD.Image(100,100); - USE gdc = GD.Constants; - # allocate some colors - black = im.colorAllocate(0, 0, 0); - red = im.colorAllocate(255,0, 0); - blue = im.colorAllocate(0, 0, 255); - # Draw a blue oval - im.arc(50,50,95,75,0,360,blue); - - USE a = GD.Text.Align(im); - a.set_font(gdc.gdLargeFont); - a.set_text("Hello"); - a.set(colour => red, halign => "center"); - a.draw(50,70,0); - - # Output image in PNG format - im.png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Text.Align plugin provides an interface to the GD::Text::Align -module. It allows text to be drawn in GD images with various alignments -and orientations. - -See L<GD::Text::Align> for more details. See -L<Template::Plugin::GD::Text::Wrap> for a plugin -that allow you to render wrapped text in GD images. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -The GD::Text module was written by Martien Verbruggen. - - -=head1 VERSION - -1.55, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -GD::Text is copyright 1999 Martien Verbruggen. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Text|Template::Plugin::GD::Text>, L<Template::Plugin::GD::Text::Wrap|Template::Plugin::GD::Text::Wrap>, L<GD|GD>, L<GD::Text::Align|GD::Text::Align> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/GD/Text/Wrap.pm b/lib/Template/Plugin/GD/Text/Wrap.pm deleted file mode 100644 index 0438599..0000000 --- a/lib/Template/Plugin/GD/Text/Wrap.pm +++ /dev/null @@ -1,183 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::GD::Text::Wrap -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the GD::Text::Wrap -# module. -# -# AUTHOR -# Craig Barratt <craig@arraycomm.com> -# -# COPYRIGHT -# Copyright (C) 2001 Craig Barratt. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#---------------------------------------------------------------------------- -# -# $Id: Wrap.pm,v 1.55 2004/01/13 16:21:46 abw Exp $ -# -#============================================================================ - -package Template::Plugin::GD::Text::Wrap; - -require 5.004; - -use strict; -use GD::Text::Wrap; -use Template::Plugin; -use base qw( GD::Text::Wrap Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.55 $ =~ /(\d+)\.(\d+)/); - -sub new -{ - my $class = shift; - my $context = shift; - my $gd = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - return $class->SUPER::new($gd, @_); -} - -sub set -{ - my $self = shift; - - push(@_, %{pop(@_)}) if ( @_ & 1 && ref($_[@_-1]) eq "HASH" ); - $self->SUPER::set(@_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::GD::Text::Wrap - Break and wrap strings in GD images - -=head1 SYNOPSIS - - [% USE align = GD.Text.Wrap(gd_image); %] - -=head1 EXAMPLES - - [% FILTER null; - USE gd = GD.Image(200,400); - USE gdc = GD.Constants; - black = gd.colorAllocate(0, 0, 0); - green = gd.colorAllocate(0, 255, 0); - txt = "This is some long text. " | repeat(10); - USE wrapbox = GD.Text.Wrap(gd, - line_space => 4, - color => green, - text => txt, - ); - wrapbox.set_font(gdc.gdMediumBoldFont); - wrapbox.set(align => 'center', width => 160); - wrapbox.draw(20, 20); - gd.png | stdout(1); - END; - -%] - - [% txt = BLOCK -%] - Lorem ipsum dolor sit amet, consectetuer adipiscing elit, - sed diam nonummy nibh euismod tincidunt ut laoreet dolore - magna aliquam erat volutpat. - [% END -%] - [% FILTER null; - # - # This example follows the example in GD::Text::Wrap, except - # we create a second image that is a copy just enough of the - # first image to hold the final text, plus a border. - # - USE gd = GD.Image(400,400); - USE gdc = GD.Constants; - green = gd.colorAllocate(0, 255, 0); - blue = gd.colorAllocate(0, 0, 255); - USE wrapbox = GD.Text.Wrap(gd, - line_space => 4, - color => green, - text => txt, - ); - wrapbox.set_font(gdc.gdMediumBoldFont); - wrapbox.set(align => 'center', width => 140); - rect = wrapbox.get_bounds(5, 5); - x0 = rect.0; - y0 = rect.1; - x1 = rect.2 + 9; - y1 = rect.3 + 9; - gd.filledRectangle(0, 0, x1, y1, blue); - gd.rectangle(0, 0, x1, y1, green); - wrapbox.draw(x0, y0); - nx = x1 + 1; - ny = y1 + 1; - USE gd2 = GD.Image(nx, ny); - gd2.copy(gd, 0, 0, 0, 0, x1, y1); - gd2.png | stdout(1); - END; - -%] - -=head1 DESCRIPTION - -The GD.Text.Wrap plugin provides an interface to the GD::Text::Wrap -module. It allows multiples line of text to be drawn in GD images with -various wrapping and alignment. - -See L<GD::Text::Wrap> for more details. See -L<Template::Plugin::GD::Text::Align> for a plugin -that allow you to draw text with various alignment -and orientation. - -=head1 AUTHOR - -Craig Barratt E<lt>craig@arraycomm.comE<gt> - - -The GD::Text module was written by Martien Verbruggen. - - -=head1 VERSION - -1.55, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - -Copyright (C) 2001 Craig Barratt E<lt>craig@arraycomm.comE<gt> - -GD::Text is copyright 1999 Martien Verbruggen. - -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|Template::Plugin>, L<Template::Plugin::GD|Template::Plugin::GD>, L<Template::Plugin::GD::Text::Align|Template::Plugin::GD::Text::Align>, L<GD|GD>, L<GD::Text::Wrap|GD::Text::Wrap> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/HTML.pm b/lib/Template/Plugin/HTML.pm deleted file mode 100644 index 5cb63e0..0000000 --- a/lib/Template/Plugin/HTML.pm +++ /dev/null @@ -1,197 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::HTML -# -# DESCRIPTION -# -# Template Toolkit plugin providing useful functionality for generating -# HTML. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -#---------------------------------------------------------------------------- -# -# $Id: HTML.pm,v 2.56 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::HTML; - -require 5.004; - -use strict; -use vars qw( $VERSION ); -use base qw( Template::Plugin ); -use Template::Plugin; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.56 $ =~ /(\d+)\.(\d+)/); - -sub new { - my ($class, $context, @args) = @_; - my $hash = ref $args[-1] eq 'HASH' ? pop @args : { }; - bless { - _SORTED => $hash->{ sorted } || 0, - }, $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 attributes { - my ($self, $hash) = @_; - return '' unless UNIVERSAL::isa($hash, 'HASH'); - - my @keys = keys %$hash; - @keys = sort @keys if $self->{ _SORTED }; - - join(' ', map { - "$_=\"" . $self->escape( $hash->{ $_ } ) . '"'; - } @keys); -} - -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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 HTML plugin is very new and 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 (as discussed recently on the mod_perl mailing list). - -=head1 METHODS - -=head2 escape(text) - -Returns the source text with any HTML reserved characters such as -E<lt>, E<gt>, etc., correctly esacped 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 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 'sorted' option as a constructor argument -which, when set to any true value, causes the attributes generated by -the attributes() method (either directly or via 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@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.56, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/Image.pm b/lib/Template/Plugin/Image.pm deleted file mode 100644 index 4eb509c..0000000 --- a/lib/Template/Plugin/Image.pm +++ /dev/null @@ -1,425 +0,0 @@ -#============================================================= -*-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. -# -# REVISION -# $Id: Image.pm,v 1.13 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::Image; - -require 5.004; - -use strict; -use Template::Exception; -use Template::Plugin; -use File::Spec; -#use Image::Info; -#use Image::Size; - -use base qw( Template::Plugin ); -use vars qw( $VERSION $AUTOLOAD ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/); - -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 = $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"; - - # do we want to check to see if file exists? - - bless { - 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(); - - if (%$options) { - while (my ($key, $val) = each %$options) { - $tag .= " $key=\"$val\""; - } - } - - $tag .= ' />'; - - return $tag; -} - - -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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 Image::Info or Image::Size -modules for determining the size of image files. - -You can specify the plugin name as either 'Image' or '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' %] - -You can also provide an alternate name for an Image plugin object. - - [% USE img1 = image 'foo.gif' %] - [% USE img2 = image 'bar.gif' %] - -The 'width' and 'height' methods return the width and height of the -image, respectively. The '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 'attr' method returns the height and width as HTML/XML attributes. - - [% USE image 'foo.gif' %] - [% image.attr %] - -Typical output: - - width="60" height="20" - -The '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" /> - -You can provide any additional attributes that should be added to the -XHTML tag. - - - [% USE image 'foo.gif' %] - [% image.tag(border=0, class="logo") %] - -Typical output: - - <img src="foo.gif" width="60" height="20" border="0" class="logo" /> - -The 'modtime' method returns the ctime of the file in question, suitable -for use with date.format: - - [% USE image 'foo.gif' %] - [% USE date %] - [% date.format(image.modtime, "%B, %e %Y") %] - -=head1 CATCHING ERRORS - -If the image file cannot be found then the above methods will throw an -'Image' error. You can enclose calls to these methods in a -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 Image::Info in preference to -Image::Size. If Image::Info is found, then some additional methods are -available, in addition to 'size', 'width', 'height', 'attr', and 'tag'. -These additional methods are named after the elements that Image::Info -retrieves from the image itself; see L<Image::Info> for more details --- the types of methods available depend on the type of image. -These additional methods will always include the following: - -=over 4 - -=item file_media_type - -This is the MIME type that is appropriate for the given file format. -The corresponding value is a string like: "image/png" or "image/jpeg". - -=item file_ext - -The is the suggested file name extention for a file of the given -file format. The value is a 3 letter, lowercase string like -"png", "jpg". - - -=item 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 "Indexed-" if the image is -composed of indexes into a palette. Of these, only "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 inpired term -instead.) - -=item 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 E<lt>resE<gt>, E<lt>xresE<gt> and E<lt>yresE<gt> fields are -numbers. The E<lt>unitE<gt> is a string like C<dpi>, C<dpm> or -C<dpcm> (denoting "dots per inch/cm/meter). - -=item 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>. - -=item 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>. - -=item Comment - -Textual comments found in the file. The value is a reference to an -array if there are multiple comments found. - -=item Interlace - -If the image is interlaced, then this tell which interlace method is -used. - -=item Compression - -This tell which compression algorithm is used. - -=item Gamma - -A number. - - -=back - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -1.13, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/Iterator.pm b/lib/Template/Plugin/Iterator.pm deleted file mode 100644 index 0f33b2f..0000000 --- a/lib/Template/Plugin/Iterator.pm +++ /dev/null @@ -1,118 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::Iterator -# -# DESCRIPTION -# -# Plugin to create a Template::Iterator from a list of items and optional -# configuration parameters. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Iterator.pm,v 2.62 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::Iterator; - -require 5.004; - -use strict; -use vars qw( $VERSION ); -use base qw( Template::Plugin ); -use Template::Plugin; -use Template::Iterator; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.62 $ =~ /(\d+)\.(\d+)/); - -#------------------------------------------------------------------------ -# new($context, \@data, \%args) -#------------------------------------------------------------------------ - -sub new { - my $class = shift; - my $context = shift; - Template::Iterator->new(@_); -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 Template::Iterator object -to iterate over a data set. An iterator is implicitly automatically by the -FOREACH directive. This plugin allows the iterator to be explicitly created -with a given name. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.62, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin>, L<Template::Iterator|Template::Iterator> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/Pod.pm b/lib/Template/Plugin/Pod.pm deleted file mode 100644 index e5f82c2..0000000 --- a/lib/Template/Plugin/Pod.pm +++ /dev/null @@ -1,116 +0,0 @@ -#============================================================================== -# -# Template::Plugin::Pod -# -# DESCRIPTION -# Pod parser and object model. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 2000 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. -# -# REVISION -# $Id: Pod.pm,v 2.62 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::Pod; - -require 5.004; - -use strict; -use Template::Plugin; -use vars qw( $VERSION ); -use base qw( Template::Plugin ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.62 $ =~ /(\d+)\.(\d+)/); - -use Pod::POM; - -#------------------------------------------------------------------------ -# new($context, \%config) -#------------------------------------------------------------------------ - -sub new { - my $class = shift; - my $context = shift; - - Pod::POM->new(@_); -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 Pod::POM module. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.62, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin>, L<Pod::POM|Pod::POM> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/Procedural.pm b/lib/Template/Plugin/Procedural.pm deleted file mode 100644 index 8601225..0000000 --- a/lib/Template/Plugin/Procedural.pm +++ /dev/null @@ -1,170 +0,0 @@ -#============================================================================== -# -# 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. -# -#------------------------------------------------------------------------------ -# -# $Id: Procedural.pm,v 1.11 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================== - -package Template::Plugin::Procedural; - -require 5.004; - -use strict; - -use vars qw( $VERSION $DEBUG $AUTOLOAD ); -use base qw( Template::Plugin ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/); -$DEBUG = 0 unless defined $DEBUG; - -#------------------------------------------------------------------------ -# 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"; - *{ $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. - *{ $proxy . "::new" } = - sub - { - my $this; - return bless \$this, $_[0]; - }; - - return $proxy; -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 - -B<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 -B<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|http://www.twoshortplanks.com> - - - - -=head1 VERSION - -1.11, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=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|Template>, L<Template::Plugin|Template::Plugin> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/String.pm b/lib/Template/Plugin/String.pm deleted file mode 100644 index 34dd007..0000000 --- a/lib/Template/Plugin/String.pm +++ /dev/null @@ -1,796 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::String -# -# DESCRIPTION -# Template Toolkit plugin to implement a basic String object. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 2001 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. -# -# REVISION -# $Id: String.pm,v 2.33 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::String; - -require 5.004; - -use strict; -use Template::Plugin; -use Template::Exception; - -use base qw( Template::Plugin ); -use vars qw( $VERSION $ERROR); -use overload q|""| => "text", - fallback => 1; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.33 $ =~ /(\d+)\.(\d+)/); -$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 } = substr($self->{ text }, 0, - $length - CORE::length($suffix)) . $suffix; - return $self; -} - - -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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 String class for doing stringy things to -text in an object-oriented way. - -You can create a String object via the USE directive, adding any -initial text value as an argument or as the named parameter 'text'. - - [% USE String %] - [% USE String 'initial text' %] - [% USE String text='initial text' %] - -The object created will be referenced as '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 String object, you can use it as a prototype to -create other String objects with the new() method. - - [% USE String %] - [% greeting = String.new('Hello World') %] - -The new() method also accepts an initial text string as an argument -or the named parameter 'text'. - - [% greeting = String.new( text => 'Hello World' ) %] - -You can also call copy() to create a new String as a copy of the -original. - - [% greet2 = greeting.copy %] - -The String object has a 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 text() method -automatically for you. - - [% greeting %] - -Thus, you can treat 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 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 String is returned which -causes the 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 CALL directive. - - [% foo = String.new('foo') %] - - [% foo.append('bar') %] # prints "foobar" - - [% CALL foo.append('bar') %] # nothing - -=head1 METHODS - -=head2 Construction Methods - -The following methods are used to create new String objects. - -=over 4 - -=item new() - -Creates a new string using an initial value passed as a positional -argument or the named parameter 'text'. - - [% USE String %] - [% msg = String.new('Hello World') %] - [% msg = String.new( text => 'Hello World' ) %] - -=item copy() - -Creates a new String object which contains a copy of the original string. - - [% msg2 = msg.copy %] - -=back - -=head2 Inspection Methods - -These methods are used to inspect the string content or other parameters -relevant to the string. - -=over 4 - -=item 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 %] - -=item length() - -Returns the length of the string. - - [% USE String("foo") %] - - [% String.length %] # => 3 - -=item search($pattern) - -Searches the string for the regular expression specified in $pattern -returning true if found or false otherwise. - - [% item = String.new('foo bar baz wiz waz woz') %] - - [% item.search('wiz') ? 'WIZZY! :-)' : 'not wizzy :-(' %] - -=item split($pattern, $limit) - -Splits the string based on the delimiter $pattern and optional $limit. -Delegates to Perl's internal split() so the parameters are exactly the same. - - [% FOREACH item.split %] - ... - [% END %] - - [% FOREACH item.split('baz|waz') %] - ... - [% END %] - -=back - -=head2 Mutation 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 the String 'str' is now '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 String object itself. This -has two important benefits. The first is that when used as above, the -String object 'str' returned by the append() method will be stringified -with a call to its 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 CALL. - - [% CALL str.append('.html') %] - -The other benefit of these methods returning a reference to the 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: - -=over 4 - -=item push($suffix, ...) / append($suffix, ...) - -Appends all arguments to the end of the string. The -append() method is provided as an alias for push(). - - [% msg.push('foo', 'bar') %] - [% msg.append('foo', 'bar') %] - -=item pop($suffix) - -Removes the suffix passed as an argument from the end of the String. - - [% USE String 'foo bar' %] - [% String.pop(' bar') %] # => 'foo' - -=item unshift($prefix, ...) / prepend($prefix, ...) - -Prepends all arguments to the beginning of the string. The -prepend() method is provided as an alias for unshift(). - - [% msg.unshift('foo ', 'bar ') %] - [% msg.prepend('foo ', 'bar ') %] - -=item shift($prefix) - -Removes the prefix passed as an argument from the start of the String. - - [% USE String 'foo bar' %] - [% String.shift('foo ') %] # => 'bar' - -=item left($pad) - -If the length of the string is less than $pad then the string is left -formatted and padded with spaces to $pad length. - - [% msg.left(20) %] - -=item right($pad) - -As per left() but right padding the String to a length of $pad. - - [% msg.right(20) %] - -=item center($pad) / centre($pad) - -As per left() and right() but formatting the String to be centered within -a space padded string of length $pad. The centre() method is provided as -an alias for center() to keep Yanks and Limeys happy. - - [% msg.center(20) %] # American spelling - [% msg.centre(20) %] # European spelling - -=item format($format) - -Apply a format in the style of sprintf() to the string. - - [% USE String("world") %] - [% String.format("Hello %s\n") %] # => "Hello World\n" - -=item upper() - -Converts the string to upper case. - - [% USE String("foo") %] - - [% String.upper %] # => 'FOO' - -=item lower() - -Converts the string to lower case - - [% USE String("FOO") %] - - [% String.lower %] # => 'foo' - -=item 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' - -=item chop() - -Removes the last character from the string. - - [% USE String("foop") %] - - [% String.chop %] # => 'foo' - -=item chomp() - -Removes the trailing newline from the string. - - [% USE String("foo\n") %] - - [% String.chomp %] # => 'foo' - -=item trim() - -Removes all leading and trailing whitespace from the string - - [% USE String(" foo \n\n ") %] - - [% String.trim %] # => 'foo' - -=item 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" - -=item truncate($length, $suffix) - -Truncates the string to $length characters. - - [% USE String('long string') %] - [% String.truncate(4) %] # => 'long' - -If $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 $length characters long. - - [% USE msg = String('Hello World') %] - [% msg.truncate(8, '...') %] # => 'Hello...' - -=item replace($search, $replace) - -Replaces all occurences of $search in the string with $replace. - - [% USE String('foo bar foo baz') %] - [% String.replace('foo', 'wiz') %] # => 'wiz bar wiz baz' - -=item remove($search) - -Remove all occurences of $search in the string. - - [% USE String('foo bar foo baz') %] - [% String.remove('foo ') %] # => 'bar baz' - -=item repeat($count) - -Repeats the string $count times. - - [% USE String('foo ') %] - [% String.repeat(3) %] # => 'foo foo foo ' - -=back - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.33, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/Table.pm b/lib/Template/Plugin/Table.pm deleted file mode 100644 index c1fd79a..0000000 --- a/lib/Template/Plugin/Table.pm +++ /dev/null @@ -1,464 +0,0 @@ -#============================================================= -*-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@kfs.org> -# -# COPYRIGHT -# Copyright (C) 2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Table.pm,v 2.64 2004/01/13 16:20:38 abw Exp $ -# -#============================================================================ - -package Template::Plugin::Table; - -require 5.004; - -use strict; -use vars qw( @ISA $VERSION $AUTOLOAD ); -use base qw( Template::Plugin ); -use Template::Plugin; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.64 $ =~ /(\d+)\.(\d+)/); - - -#------------------------------------------------------------------------ -# 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 subseqent 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 (UNIVERSAL::isa($data, '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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 = table.row(n) %] - [% item %] - [% END %] - - [% FOREACH item = table.col(n) %] - [% item %] - [% END %] - - [% FOREACH row = table.rows %] - [% FOREACH item = row %] - [% item %] - [% END %] - [% END %] - - [% FOREACH col = table.cols %] - [% col.first %] - [% col.last %] ([% col.size %] entries) - [% END %] - -=head1 DESCRIPTION - -The Table plugin allows you to format a list of data items into a -virtual table. When you create a Table plugin via the 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 '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 row(), -col(), rows() and cols() as if formatted into a simple two dimensional -table of n rows x n columns. Thus, if our sample 'alphabet' list -contained the letters 'a' to 'z', the above 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 row() and 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 [ 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 '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 rows() method returns all rows/columns in the table as a reference -to a list of rows (themselves list references). The row() methods -when called without any arguments calls rows() to return all rows in -the table. - -Ditto for cols() and col(). - - [% USE table(alphabet, cols=5) %] - [% FOREACH row = table.rows %] - [% FOREACH item = row %] - [% item %] - [% END %] - [% END %] - -The Template Toolkit provides the first(), last() and size() methods -that can be called on list references to return the first/last entry -or the number of entried. 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 join() list 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 '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 %] - - a b c - d e f - g h i - j . . - . - -In addition to a list reference, the Table plugin constructor may be -passed a reference to a Template::Iterator object or subclass thereof. -The 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@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.64, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/URL.pm b/lib/Template/Plugin/URL.pm deleted file mode 100644 index c2246b7..0000000 --- a/lib/Template/Plugin/URL.pm +++ /dev/null @@ -1,236 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::URL -# -# DESCRIPTION -# -# Template Toolkit Plugin for constructing URL's from a base stem -# and adaptable parameters. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: URL.pm,v 2.64 2004/01/13 16:20:39 abw Exp $ -# -#============================================================================ - -package Template::Plugin::URL; - -require 5.004; - -use strict; -use vars qw( @ISA $VERSION ); -use Template::Plugin; - -@ISA = qw( Template::Plugin ); -$VERSION = sprintf("%d.%02d", q$Revision: 2.64 $ =~ /(\d+)\.(\d+)/); - - -#------------------------------------------------------------------------ -# 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('&', -# map { "$_=" . escape($combo->{ $_ }) } - map { args($_, $combo->{ $_ }) } - grep { defined $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); - $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg; - return $toencode; -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 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 -Documents, this 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 - -Additional parameters may be also be specified: - - [% 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 CGI.pm. e.g. - - [% USE url('/cgi-bin/woz.pl') %] - [% url(name="Elrich von Benjy d'Weiro") %] - -Here the spaces and "'" character are escaped in the output: - - /cgi-bin/woz.pl?name=Elrich%20von%20Benjy%20d%27Weiro - -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) %] - -Note that in the following line, additional parameters are seperated -by '&', while common usage on the Web is to just use '&'. '&' -is actually the Right Way to do it. See this URL for more information: -http://ppewww.ph.gla.ac.uk/~flavell/www/formgetbyurl.html - - /cgi-bin/waz.pl?mode=browse&debug=1&test=1 - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.64, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/View.pm b/lib/Template/Plugin/View.pm deleted file mode 100644 index c22ba16..0000000 --- a/lib/Template/Plugin/View.pm +++ /dev/null @@ -1,127 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::View -# -# DESCRIPTION -# A user-definable view based on templates. Similar to the concept of -# a "Skin". -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 2000 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. -# -# REVISION -# $Id: View.pm,v 2.63 2004/01/13 16:20:39 abw Exp $ -# -#============================================================================ - -package Template::Plugin::View; - -require 5.004; - -use strict; -use Template::Plugin; -use vars qw( $VERSION ); -use base qw( Template::Plugin ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.63 $ =~ /(\d+)\.(\d+)/); - -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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 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@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.63, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin>, L<Template::View|Template::View> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/Wrap.pm b/lib/Template/Plugin/Wrap.pm deleted file mode 100644 index 96c600a..0000000 --- a/lib/Template/Plugin/Wrap.pm +++ /dev/null @@ -1,162 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::Wrap -# -# DESCRIPTION -# Plugin for wrapping text via the Text::Wrap module. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Wrap.pm,v 2.63 2004/01/13 16:20:40 abw Exp $ -# -#============================================================================ - -package Template::Plugin::Wrap; - -require 5.004; - -use strict; -use vars qw( @ISA $VERSION ); -use base qw( Template::Plugin ); -use Template::Plugin; -use Text::Wrap; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.63 $ =~ /(\d+)\.(\d+)/); - -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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 Text::Wrap module which -provides simple paragraph formatting. - -It defines a '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 'wrap' filter which accepts the same three optional -arguments but takes the input text directly via the filter input. - - [% FILTER bullet = wrap(40, '* ', ' ') -%] - First, attach the transmutex multiplier to the cross-wired quantum - homogeniser. - [%- END %] - - [% FILTER bullet -%] - Then remodulate the shield to match the harmonic frequency, taking - care to correct the phase difference. - [% END %] - -Output: - - * First, attach the transmutex - multiplier to the cross-wired quantum - homogeniser. - - * 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> - -The Text::Wrap module was written by David Muir Sharnoff -E<lt>muir@idiom.comE<gt> with help from Tim Pierce and many -others. - -=head1 VERSION - -2.63, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin>, L<Text::Wrap|Text::Wrap> - diff --git a/lib/Template/Plugin/XML/DOM.pm b/lib/Template/Plugin/XML/DOM.pm deleted file mode 100644 index 30bac3b..0000000 --- a/lib/Template/Plugin/XML/DOM.pm +++ /dev/null @@ -1,841 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::XML::DOM -# -# DESCRIPTION -# -# Simple Template Toolkit plugin interfacing to the XML::DOM.pm module. -# -# AUTHORS -# Andy Wardley <abw@kfs.org> -# Simon Matthews <sam@knowledgepool.com> -# -# COPYRIGHT -# Copyright (C) 2000 Andy Wardley, 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. -# -#---------------------------------------------------------------------------- -# -# $Id: DOM.pm,v 2.54 2004/01/13 16:21:50 abw Exp $ -# -#============================================================================ - -package Template::Plugin::XML::DOM; - -require 5.004; - -use strict; -use Template::Plugin; -use XML::DOM; - -use base qw( Template::Plugin ); -use vars qw( $VERSION $DEBUG ); - -$VERSION = 2.6; -$DEBUG = 0 unless defined $DEBUG; - - -#------------------------------------------------------------------------ -# new($context, \%config) -# -# Constructor method for XML::DOM plugin. Creates an XML::DOM::Parser -# object and initialise plugin configuration. -#------------------------------------------------------------------------ - -sub new { - my $class = shift; - my $context = shift; - my $args = ref $_[-1] eq 'HASH' ? pop(@_) : { }; - - my $parser ||= XML::DOM::Parser->new(%$args) - || return $class->_throw("failed to create XML::DOM::Parser\n"); - - # we've had to deprecate the old usage because it broke things big time - # with DOM trees never getting cleaned up. - return $class->_throw("XML::DOM usage has changed - you must now call parse()\n") - if @_; - - bless { - _PARSER => $parser, - _DOCS => [ ], - _CONTEXT => $context, - _PREFIX => $args->{ prefix } || '', - _SUFFIX => $args->{ suffix } || '', - _DEFAULT => $args->{ default } || '', - _VERBOSE => $args->{ verbose } || 0, - _NOSPACE => $args->{ nospace } || 0, - _DEEP => $args->{ deep } || 0, - }, $class; -} - - -#------------------------------------------------------------------------ -# parse($content, \%named_params) -# -# Parses an XML stream, provided as the first positional argument (assumed -# to be a filename unless it contains a '<' character) or specified in -# the named parameter hash as one of 'text', 'xml' (same as text), 'file' -# or 'filename'. -#------------------------------------------------------------------------ - -sub parse { - my $self = shift; - my $args = ref $_[-1] eq 'HASH' ? pop(@_) : { }; - my $parser = $self->{ _PARSER }; - my ($content, $about, $method, $doc); - - # determine the input source from a positional parameter (may be a - # filename or XML text if it contains a '<' character) or by using - # named parameters which may specify one of 'file', 'filename', 'text' - # or 'xml' - - if ($content = shift) { - if ($content =~ /\</) { - $about = 'xml text'; - $method = 'parse'; - } - else { - $about = "xml file $content"; - $method = 'parsefile'; - } - } - elsif ($content = $args->{ text } || $args->{ xml }) { - $about = 'xml text'; - $method = 'parse'; - } - elsif ($content = $args->{ file } || $args->{ filename }) { - $about = "xml file $content"; - $method = 'parsefile'; - } - else { - return $self->_throw('no filename or xml text specified'); - } - - # parse the input source using the appropriate method determined above - eval { $doc = $parser->$method($content) } and not $@ - or return $self->_throw("failed to parse $about: $@"); - - # update XML::DOM::Document _UserData to contain config details - $doc->[ XML::DOM::Node::_UserData ] = { - map { ( $_ => $self->{ $_ } ) } - qw( _CONTEXT _PREFIX _SUFFIX _VERBOSE _NOSPACE _DEEP _DEFAULT ), - }; - - # keep track of all DOM docs for subsequent dispose() -# print STDERR "DEBUG: $self adding doc: $doc\n" -# if $DEBUG; - - push(@{ $self->{ _DOCS } }, $doc); - - return $doc; -} - - -#------------------------------------------------------------------------ -# _throw($errmsg) -# -# Raised a Template::Exception of type XML.DOM via die(). -#------------------------------------------------------------------------ - -sub _throw { - my ($self, $error) = @_; - die (Template::Exception->new('XML.DOM', $error)); -} - - -#------------------------------------------------------------------------ -# DESTROY -# -# Cleanup method which calls dispose() on any and all DOM documents -# created by this object. Also breaks any circular references that -# may exist with the context object. -#------------------------------------------------------------------------ - -sub DESTROY { - my $self = shift; - - # call dispose() on each document produced by this parser - foreach my $doc (@{ $self->{ _DOCS } }) { -# print STDERR "DEBUG: $self destroying $doc\n" -# if $DEBUG; - if (ref $doc) { -# print STDERR "disposing of $doc\n"; - undef $doc->[ XML::DOM::Node::_UserData ]->{ _CONTEXT }; - $doc->dispose(); - } - } - delete $self->{ _CONTEXT }; - delete $self->{ _PARSER }; -} - - - -#======================================================================== -package XML::DOM::Node; -#======================================================================== - - -#------------------------------------------------------------------------ -# present($view) -# -# Method to present node via a view (supercedes all that messy toTemplate -# stuff below). -#------------------------------------------------------------------------ - -sub present { - my ($self, $view) = @_; - - if ($self->getNodeType() == XML::DOM::ELEMENT_NODE) { - # it's an element - $view->view($self->getTagName(), $self); - } - else { - my $text = $self->toString(); - $view->view('text', $text); - } -} - -sub content { - my ($self, $view) = @_; - my $output = ''; - foreach my $node (@{ $self->getChildNodes }) { - $output .= $node->present($view); - -# abw test passing args, Aug 2001 -# $output .= $view->print($node); - } - return $output; -} - - -#------------------------------------------------------------------------ -# toTemplate($prefix, $suffix, \%named_params) -# -# Process the current node as a template. -#------------------------------------------------------------------------ - -sub toTemplate { - my $self = shift; - _template_node($self, $self->_args(@_)); -} - - -#------------------------------------------------------------------------ -# childrenToTemplate($prefix, $suffix, \%named_params) -# -# Process all the current node's children as templates. -#------------------------------------------------------------------------ - -sub childrenToTemplate { - my $self = shift; - _template_kids($self, $self->_args(@_)); -} - - -#------------------------------------------------------------------------ -# allChildrenToTemplate($prefix, $suffix, \%named_params) -# -# Process all the current node's children, and their children, and -# their children, etc., etc., as templates. Same effect as calling the -# childrenToTemplate() method with the 'deep' option set. -#------------------------------------------------------------------------ - -sub allChildrenToTemplate { - my $self = shift; - my $args = $self->_args(@_); - $args->{ deep } = 1; - _template_kids($self, $args); -} - - -#------------------------------------------------------------------------ -# _args($prefix, $suffix, \%name_params) -# -# Reads the optional positional parameters, $prefix and $suffix, and -# also examines any named parameters hash to construct a set of -# current configuration parameters. Where not specified directly, the -# object defaults are used. -#------------------------------------------------------------------------ - -sub _args { - my $self = shift; - my $args = ref $_[-1] eq 'HASH' ? pop(@_) : { }; - my $doc = $self->getOwnerDocument() || $self; - my $data = $doc->[ XML::DOM::Node::_UserData ]; - - return { - prefix => @_ ? shift : $args->{ prefix } || $data->{ _PREFIX }, - suffix => @_ ? shift : $args->{ suffix } || $data->{ _SUFFIX }, - verbose => $args->{ verbose } || $data->{ _VERBOSE }, - nospace => $args->{ nospace } || $data->{ _NOSPACE }, - deep => $args->{ deep } || $data->{ _DEEP }, - default => $args->{ default } || $data->{ _DEFAULT }, - context => $data->{ _CONTEXT }, - }; -} - - - -#------------------------------------------------------------------------ -# _template_node($node, $args, $vars) -# -# Process a template for the current DOM node where the template name -# is taken from the node TagName, with any specified 'prefix' and/or -# 'suffix' applied. The 'default' argument can also be provided to -# specify a default template to be used when a specific template can't -# be found. The $args parameter referenced a hash array through which -# these configuration items are passed (see _args()). The current DOM -# node is made available to the template as the variable 'node', along -# with any other variables passed in the optional $vars hash reference. -# To permit the 'children' and 'prune' callbacks to be raised as node -# methods (see _template_kids() below), these items, if defined in the -# $vars hash, are copied into the node object where its AUTOLOAD method -# can find them. -#------------------------------------------------------------------------ - -sub _template_node { - my $node = shift || die "no XML::DOM::Node reference\n"; - my $args = shift || die "no XML::DOM args passed to _template_node\n"; - my $vars = shift || { }; - my $context = $args->{ context } || die "no context in XML::DOM args\n"; - my $template; - my $output = ''; - - # if this is not an element then it is text so output it - unless ($node->getNodeType() == XML::DOM::ELEMENT_NODE ) { - if ($args->{ verbose }) { - $output = $node->toString(); - $output =~ s/\s+$// if $args->{ nospace }; - } - } - else { - my $element = ( $args->{ prefix } || '' ) - . $node->getTagName() - . ( $args->{ suffix } || '' ); - - # locate a template by name built from prefix, tagname and suffix - # or fall back on any default template specified - eval { $template = $context->template($element) }; - eval { $template = $context->template($args->{ default }) } - if $@ && $args->{ default }; - $template = $element unless $template; - - # copy 'children' and 'prune' callbacks into node object (see AUTOLOAD) - my $doc = $node->getOwnerDocument() || $node; - my $data = $doc->[ XML::DOM::Node::_UserData ]; - - $data->{ _TT_CHILDREN } = $vars->{ children }; - $data->{ _TT_PRUNE } = $vars->{ prune }; - - # add node reference to existing vars hash - $vars->{ node } = $node; - - $output = $context->include($template, $vars); - - # break any circular references - delete $vars->{ node }; - delete $data->{ _TT_CHILDREN }; - delete $data->{ _TT_PRUNE }; - } - - return $output; -} - - -#------------------------------------------------------------------------ -# _template_kids($node, $args) -# -# Process all the children of the current node as templates, via calls -# to _template_node(). If the 'deep' argument is set, then the process -# will continue recursively. In this case, the node template is first -# processed, followed by any children of that node (i.e. depth first, -# parent before). A closure called 'children' is created and added -# to the Stash variables passed to _template_node(). This can be called -# from the parent template to process all child nodes at the current point. -# This then "prunes" the tree preventing the children from being processed -# after the parent template. A 'prune' callback is also added to prune -# the tree without processing the children. Note that _template_node() -# copies these callbacks into each parent node, allowing them to be called -# as [% node. -#------------------------------------------------------------------------ - -sub _template_kids { - my $node = shift || die "no XML::DOM::Node reference\n"; - my $args = shift || die "no XML::DOM args passed to _template_kids\n"; - my $context = $args->{ context } || die "no context in XML::DOM args\n"; - my $output = ''; - - foreach my $kid ( $node->getChildNodes() ) { - # define some callbacks to allow template to call [% content %] - # or [% prune %]. They are also inserted into each node reference - # so they can be called as [% node.content %] and [% node.prune %] - my $prune = 0; - my $vars = { }; - $vars->{ children } = sub { - $prune = 1; - _template_kids($kid, $args); - }; - $vars->{ prune } = sub { - $prune = 1; - return ''; - }; - - $output .= _template_node($kid, $args, $vars); - $output .= _template_kids($kid, $args) - if $args->{ deep } && ! $prune; - } - return $output; -} - - -#======================================================================== -package XML::DOM::Element; -#======================================================================== - -use vars qw( $AUTOLOAD ); - -sub AUTOLOAD { - my $self = shift; - my $method = $AUTOLOAD; - my $attrib; - - $method =~ s/.*:://; - return if $method eq 'DESTROY'; - - my $doc = $self->getOwnerDocument() || $self; - my $data = $doc->[ XML::DOM::Node::_UserData ]; - - # call 'content' or 'prune' callbacks, if defined (see _template_node()) - return &$attrib() - if ($method =~ /^children|prune$/) - && defined($attrib = $data->{ "_TT_\U$method" }) - && ref $attrib eq 'CODE'; - - return $attrib - if defined ($attrib = $self->getAttribute($method)); - - return ''; -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::XML::DOM - Plugin interface to XML::DOM - -=head1 SYNOPSIS - - # load plugin - [% USE dom = XML.DOM %] - - # also provide XML::Parser options - [% USE dom = XML.DOM(ProtocolEncoding =E<gt> 'ISO-8859-1') %] - - # parse an XML file - [% doc = dom.parse(filename) %] - [% doc = dom.parse(file => filename) %] - - # parse XML text - [% doc = dom.parse(xmltext) %] - [% doc = dom.parse(text => xmltext) %] - - # call any XML::DOM methods on document/element nodes - [% FOREACH node = doc.getElementsByTagName('report') %] - * [% node.getAttribute('title') %] # or just '[% node.title %]' - [% END %] - - # define VIEW to present node(s) - [% VIEW report notfound='xmlstring' %] - # handler block for a <report>...</report> element - [% BLOCK report %] - [% item.content(view) %] - [% END %] - - # handler block for a <section title="...">...</section> element - [% BLOCK section %] - <h1>[% item.title %]</h1> - [% item.content(view) %] - [% END %] - - # default template block converts item to string representation - [% BLOCK xmlstring; item.toString; END %] - - # block to generate simple text - [% BLOCK text; item; END %] - [% END %] - - # now present node (and children) via view - [% report.print(node) %] - - # or print node content via view - [% node.content(report) %] - - # following methods are soon to be deprecated in favour of views - [% node.toTemplate %] - [% node.childrenToTemplate %] - [% node.allChildrenToTemplate %] - -=head1 PRE-REQUISITES - -This plugin requires that the XML::Parser (2.19 or later) and XML::DOM -(1.27 or later) modules be installed. These are available from CPAN: - - http://www.cpan.org/modules/by-module/XML - -Note that the XML::DOM module is now distributed as part of the -'libxml-enno' bundle. - -=head1 DESCRIPTION - -This is a Template Toolkit plugin interfacing to the XML::DOM module. -The plugin loads the XML::DOM module and creates an XML::DOM::Parser -object which is stored internally. The parse() method can then be -called on the plugin to parse an XML stream into a DOM document. - - [% USE dom = XML.DOM %] - [% doc = dom.parse('/tmp/myxmlfile') %] - -NOTE: earlier versions of this XML::DOM plugin expected a filename to -be passed as an argument to the constructor. This is no longer -supported due to the fact that it caused a serious memory leak. We -apologise for the inconvenience but must insist that you change your -templates as shown: - - # OLD STYLE: now fails with a warning - [% USE dom = XML.DOM('tmp/myxmlfile') %] - - # NEW STYLE: do this instead - [% USE dom = XML.DOM %] - [% doc = dom.parse('tmp/myxmlfile') %] - -The root of the problem lies in XML::DOM creating massive circular -references in the object models it constructs. The dispose() method -must be called on each document to release the memory that it would -otherwise hold indefinately. The XML::DOM plugin object (i.e. 'dom' -in these examples) acts as a sentinel for the documents it creates -('doc' and any others). When the plugin object goes out of scope at -the end of the current template, it will automatically call dispose() -on any documents that it has created. Note that if you dispose of the -the plugin object before the end of the block (i.e. by assigning a -new value to the 'dom' variable) then the documents will also be -disposed at that point and should not be used thereafter. - - [% USE dom = XML.DOM %] - [% doc = dom.parse('/tmp/myfile') %] - [% dom = 'new value' %] # releases XML.DOM plugin and calls - # dispose() on 'doc', so don't use it! - -Any template processing parameters (see toTemplate() method and -friends, below) can be specified with the constructor and will be used -to define defaults for the object. - - [% USE dom = XML.DOM(prefix => 'theme1/') %] - -The plugin constructor will also accept configuration options destined -for the XML::Parser object: - - [% USE dom = XML.DOM(ProtocolEncoding => 'ISO-8859-1') %] - -=head1 METHODS - -=head2 parse() - -The parse() method accepts a positional parameter which contains a filename -or XML string. It is assumed to be a filename unless it contains a E<lt> -character. - - [% xmlfile = '/tmp/foo.xml' %] - [% doc = dom.parse(xmlfile) %] - - [% xmltext = BLOCK %] - <xml> - <blah><etc/></blah> - ... - </xml> - [% END %] - [% doc = dom.parse(xmltext) %] - -The named parameters 'file' (or 'filename') and 'text' (or 'xml') can also -be used: - - [% doc = dom.parse(file = xmlfile) %] - [% doc = dom.parse(text = xmltext) %] - -The parse() method returns an instance of the XML::DOM::Document object -representing the parsed document in DOM form. You can then call any -XML::DOM methods on the document node and other nodes that its methods -may return. See L<XML::DOM> for full details. - - [% FOREACH node = doc.getElementsByTagName('CODEBASE') %] - * [% node.getAttribute('href') %] - [% END %] - -This plugin also provides an AUTOLOAD method for XML::DOM::Node which -calls getAttribute() for any undefined methods. Thus, you can use the -short form of - - [% node.attrib %] - -in place of - - [% node.getAttribute('attrib') %] - -=head2 toTemplate() - -B<NOTE: This method will soon be deprecated in favour of the VIEW based -approach desribed below.> - -This method will process a template for the current node on which it is -called. The template name is constructed from the node TagName with any -optional 'prefix' and/or 'suffix' options applied. A 'default' template -can be named to be used when the specific template cannot be found. The -node object is available to the template as the 'node' variable. - -Thus, for this XML fragment: - - <page title="Hello World!"> - ... - </page> - -and this template definition: - - [% BLOCK page %] - Page: [% node.title %] - [% END %] - -the output of calling toTemplate() on the E<lt>pageE<gt> node would be: - - Page: Hello World! - -=head2 childrenToTemplate() - -B<NOTE: This method will soon be deprecated in favour of the VIEW based -approach desribed below.> - -Effectively calls toTemplate() for the current node and then for each of -the node's children. By default, the parent template is processed first, -followed by each of the children. The 'children' closure can be called -from within the parent template to have them processed and output -at that point. This then suppresses the children from being processed -after the parent template. - -Thus, for this XML fragment: - - <foo> - <bar id="1"/> - <bar id="2"/> - </foo> - -and these template definitions: - - [% BLOCK foo %] - start of foo - end of foo - [% END %] - - [% BLOCK bar %] - bar [% node.id %] - [% END %] - -the output of calling childrenToTemplate() on the parent E<lt>fooE<gt> node -would be: - - start of foo - end of foo - bar 1 - bar 2 - -Adding a call to [% children %] in the 'foo' template: - - [% BLOCK foo %] - start of foo - [% children %] - end of foo - [% END %] - -then creates output as: - - start of foo - bar 1 - bar 2 - end of foo - -The 'children' closure can also be called as a method of the node, if you -prefer: - - [% BLOCK foo %] - start of foo - [% node.children %] - end of foo - [% END %] - -The 'prune' closure is also defined and can be called as [% prune %] or -[% node.prune %]. It prunes the currrent node, preventing any descendants -from being further processed. - - [% BLOCK anynode %] - [% node.toString; node.prune %] - [% END %] - -=head2 allChildrenToTemplate() - -B<NOTE: This method will soon be deprecated in favour of the VIEW based -approach desribed below.> - -Similar to childrenToTemplate() but processing all descendants (i.e. children -of children and so on) recursively. This is identical to calling the -childrenToTemplate() method with the 'deep' flag set to any true value. - -=head1 PRESENTING DOM NODES USING VIEWS - -You can define a VIEW to present all or part of a DOM tree by automatically -mapping elements onto templates. Consider a source document like the -following: - - <report> - <section title="Introduction"> - <p> - Blah blah. - <ul> - <li>Item 1</li> - <li>item 2</li> - </ul> - </p> - </section> - <section title="The Gory Details"> - ... - </section> - </report> - -We can load it up via the XML::DOM plugin and fetch the node for the -E<lt>reportE<gt> element. - - [% USE dom = XML.DOM; - doc = dom.parse(file => filename); - report = doc.getElementsByTagName('report') - %] - -We can then define a VIEW as follows to present this document fragment in -a particular way. The L<Template::Manual::Views> documentation -contains further details on the VIEW directive and various configuration -options it supports. - - [% VIEW report_view notfound='xmlstring' %] - # handler block for a <report>...</report> element - [% BLOCK report %] - [% item.content(view) %] - [% END %] - - # handler block for a <section title="...">...</section> element - [% BLOCK section %] - <h1>[% item.title %]</h1> - [% item.content(view) %] - [% END %] - - # default template block converts item to string representation - [% BLOCK xmlstring; item.toString; END %] - - # block to generate simple text - [% BLOCK text; item; END %] - [% END %] - -Each BLOCK defined within the VIEW represents a presentation style for -a particular element or elements. The current node is available via the -'item' variable. Elements that contain other content can generate it -according to the current view by calling [% item.content(view) %]. -Elements that don't have a specific template defined are mapped to the -'xmlstring' template via the 'notfound' parameter specified in the VIEW -header. This replicates the node as an XML string, effectively allowing -general XML/XHTML markup to be passed through unmodified. - -To present the report node via the view, we simply call: - - [% report_view.print(report) %] - -The output from the above example would look something like this: - - <h1>Introduction</h1> - <p> - Blah blah. - <ul> - <li>Item 1</li> - <li>item 2</li> - </ul> - </p> - - <h1>The Gory Details</h1> - ... - -To print just the content of the report node (i.e. don't process the -'report' template for the report node), you can call: - - [% report.content(report_view) %] - -=head1 AUTHORS - -This plugin module was written by Andy Wardley E<lt>abw@wardley.orgE<gt> -and Simon Matthews E<lt>sam@knowledgepool.comE<gt>. - -The XML::DOM module is by Enno Derksen E<lt>enno@att.comE<gt> and Clark -Cooper E<lt>coopercl@sch.ge.comE<gt>. It extends the the XML::Parser -module, also by Clark Cooper which itself is built on James Clark's expat -library. - -=head1 VERSION - -2.6, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - - - -=head1 HISTORY - -Version 2.5 : updated for use with version 1.27 of the XML::DOM module. - -=over 4 - -=item * - -XML::DOM 1.27 now uses array references as the underlying data type -for DOM nodes instead of hash array references. User data is now -bound to the _UserData node entry instead of being forced directly -into the node hash. - -=back - -=head1 BUGS - -The childrenToTemplate() and allChildrenToTemplate() methods can easily -slip into deep recursion. - -The 'verbose' and 'nospace' options are not documented. They may -change in the near future. - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Andy Wardley, 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|Template::Plugin>, L<XML::DOM|XML::DOM>, L<XML::Parser|XML::Parser> - diff --git a/lib/Template/Plugin/XML/RSS.pm b/lib/Template/Plugin/XML/RSS.pm deleted file mode 100644 index 32da7d8..0000000 --- a/lib/Template/Plugin/XML/RSS.pm +++ /dev/null @@ -1,194 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::XML::RSS -# -# DESCRIPTION -# -# Template Toolkit plugin which interfaces to Jonathan Eisenzopf's XML::RSS -# module. RSS is the Rich Site Summary format. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: RSS.pm,v 2.64 2004/01/13 16:21:50 abw Exp $ -# -#============================================================================ - -package Template::Plugin::XML::RSS; - -require 5.004; - -use strict; -use vars qw( $VERSION ); -use base qw( Template::Plugin ); -use Template::Plugin; -use XML::RSS; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.64 $ =~ /(\d+)\.(\d+)/); - -sub load { - return $_[0]; -} - -sub new { - my ($class, $context, $filename) = @_; - - return $class->fail('No filename specified') - unless $filename; - - my $rss = XML::RSS->new - or return $class->fail('failed to create XML::RSS'); - - # Attempt to determine if $filename is an XML string or - # a filename. Based on code from the XML.XPath plugin. - eval { - if ($filename =~ /\</) { - $rss->parse($filename); - } - else { - $rss->parsefile($filename) - } - } and not $@ - or return $class->fail("failed to parse $filename: $@"); - - return $rss; -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::XML::RSS - Plugin interface to XML::RSS - -=head1 SYNOPSIS - - [% USE news = XML.RSS($filename) %] - - [% FOREACH item = news.items %] - [% item.title %] - [% item.link %] - [% END %] - -=head1 PRE-REQUISITES - -This plugin requires that the XML::Parser and XML::RSS modules be -installed. These are available from CPAN: - - http://www.cpan.org/modules/by-module/XML - -=head1 DESCRIPTION - -This Template Toolkit plugin provides a simple interface to the -XML::RSS module. - - [% USE news = XML.RSS('mysite.rdf') %] - -It creates an XML::RSS object, which is then used to parse the RSS -file specified as a parameter in the USE directive. A reference to -the XML::RSS object is then returned. - -An RSS (Rich Site Summary) file is typically used to store short news -'headlines' describing different links within a site. This example is -extracted from http://slashdot.org/slashdot.rdf. - - <?xml version="1.0"?><rdf:RDF - xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" - xmlns="http://my.netscape.com/rdf/simple/0.9/"> - - <channel> - <title>Slashdot:News for Nerds. Stuff that Matters.</title> - <link>http://slashdot.org</link> - <description>News for Nerds. Stuff that Matters</description> - </channel> - - <image> - <title>Slashdot</title> - <url>http://slashdot.org/images/slashdotlg.gif</url> - <link>http://slashdot.org</link> - </image> - - <item> - <title>DVD CCA Battle Continues Next Week</title> - <link>http://slashdot.org/article.pl?sid=00/01/12/2051208</link> - </item> - - <item> - <title>Matrox to fund DRI Development</title> - <link>http://slashdot.org/article.pl?sid=00/01/13/0718219</link> - </item> - - <item> - <title>Mike Shaver Leaving Netscape</title> - <link>http://slashdot.org/article.pl?sid=00/01/13/0711258</link> - </item> - - </rdf:RDF> - -The attributes of the channel and image elements can be retrieved directly -from the plugin object using the familiar dotted compound notation: - - [% news.channel.title %] - [% news.channel.link %] - [% news.channel.etc... %] - - [% news.image.title %] - [% news.image.url %] - [% news.image.link %] - [% news.image.etc... %] - -The list of news items can be retrieved using the 'items' method: - - [% FOREACH item = news.items %] - [% item.title %] - [% item.link %] - [% END %] - -=head1 AUTHORS - -This plugin was written by Andy Wardley E<lt>abw@wardley.orgE<gt>, -inspired by an article in Web Techniques by Randal Schwartz -E<lt>merlyn@stonehenge.comE<gt>. - -The XML::RSS module, which implements all of the functionality that -this plugin delegates to, was written by Jonathan Eisenzopf -E<lt>eisen@pobox.comE<gt>. - -=head1 VERSION - -2.64, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin>, L<XML::RSS|XML::RSS>, L<XML::Parser|XML::Parser> - diff --git a/lib/Template/Plugin/XML/Simple.pm b/lib/Template/Plugin/XML/Simple.pm deleted file mode 100644 index aaa4479..0000000 --- a/lib/Template/Plugin/XML/Simple.pm +++ /dev/null @@ -1,124 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::XML::Simple -# -# DESCRIPTION -# Template Toolkit plugin interfacing to the XML::Simple.pm module. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 2001 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Simple.pm,v 2.63 2004/01/13 16:21:50 abw Exp $ -# -#============================================================================ - -package Template::Plugin::XML::Simple; - -require 5.004; - -use strict; -use Template::Plugin; -use XML::Simple; - -use base qw( Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.63 $ =~ /(\d+)\.(\d+)/); - - -#------------------------------------------------------------------------ -# new($context, $file_or_text, \%config) -#------------------------------------------------------------------------ - -sub new { - my $class = shift; - my $context = shift; - my $input = shift; - my $args = ref $_[-1] eq 'HASH' ? pop(@_) : { }; - - XMLin($input, %$args); -} - - - -#------------------------------------------------------------------------ -# _throw($errmsg) -# -# Raise a Template::Exception of type XML.Simple via die(). -#------------------------------------------------------------------------ - -sub _throw { - my ($self, $error) = @_; - die (Template::Exception->new('XML.Simple', $error)); -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::XML::Simple - Plugin interface to XML::Simple - -=head1 SYNOPSIS - - # load plugin and specify XML file to parse - [% USE xml = XML.Simple(xml_file_or_text) %] - -=head1 DESCRIPTION - -This is a Template Toolkit plugin interfacing to the XML::Simple module. - -=head1 PRE-REQUISITES - -This plugin requires that the XML::Parser and XML::Simple modules be -installed. These are available from CPAN: - - http://www.cpan.org/modules/by-module/XML - -=head1 AUTHORS - -This plugin wrapper module was written by Andy Wardley -E<lt>abw@wardley.orgE<gt>. - -The XML::Simple module which implements all the core functionality -was written by Grant McLean E<lt>grantm@web.co.nzE<gt>. - -=head1 VERSION - -2.63, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin>, L<XML::Simple|XML::Simple>, L<XML::Parser|XML::Parser> - diff --git a/lib/Template/Plugin/XML/Style.pm b/lib/Template/Plugin/XML/Style.pm deleted file mode 100644 index 7613f2f..0000000 --- a/lib/Template/Plugin/XML/Style.pm +++ /dev/null @@ -1,357 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::XML::Style -# -# DESCRIPTION -# Template Toolkit plugin which performs some basic munging of XML -# to perform simple stylesheet like transformations. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 2001 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. -# -# REVISION -# $Id: Style.pm,v 2.34 2004/01/13 16:21:50 abw Exp $ -# -#============================================================================ - -package Template::Plugin::XML::Style; - -require 5.004; - -use strict; -use Template::Plugin::Filter; - -use base qw( Template::Plugin::Filter ); -use vars qw( $VERSION $DYNAMIC $FILTER_NAME ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.34 $ =~ /(\d+)\.(\d+)/); -$DYNAMIC = 1; -$FILTER_NAME = 'xmlstyle'; - - -#------------------------------------------------------------------------ -# new($context, \%config) -#------------------------------------------------------------------------ - -sub init { - my $self = shift; - my $name = $self->{ _ARGS }->[0] || $FILTER_NAME; - $self->install_filter($name); - return $self; -} - - -sub filter { - my ($self, $text, $args, $config) = @_; - - # munge start tags - $text =~ s/ < ([\w\.\:]+) ( \s+ [^>]+ )? > - / $self->start_tag($1, $2, $config) - /gsex; - - # munge end tags - $text =~ s/ < \/ ([\w\.\:]+) > - / $self->end_tag($1, $config) - /gsex; - - return $text; - -} - - -sub start_tag { - my ($self, $elem, $textattr, $config) = @_; - $textattr ||= ''; - my ($pre, $post); - - # look for an element match in the stylesheet - my $match = $config->{ $elem } - || $self->{ _CONFIG }->{ $elem } - || return "<$elem$textattr>"; - - # merge element attributes into copy of stylesheet attributes - my $attr = { %{ $match->{ attributes } || { } } }; - while ($textattr =~ / \s* ([\w\.\:]+) = " ([^"]+) " /gsx ) { - $attr->{ $1 } = $2; - } - $textattr = join(' ', map { "$_=\"$attr->{$_}\"" } keys %$attr); - $textattr = " $textattr" if $textattr; - - $elem = $match->{ element } || $elem; - $pre = $match->{ pre_start } || ''; - $post = $match->{ post_start } || ''; - - return "$pre<$elem$textattr>$post"; -} - - -sub end_tag { - my ($self, $elem, $config) = @_; - my ($pre, $post); - - # look for an element match in the stylesheet - my $match = $config->{ $elem } - || $self->{ _CONFIG }->{ $elem } - || return "</$elem>"; - - $elem = $match->{ element } || $elem; - $pre = $match->{ pre_end } || ''; - $post = $match->{ post_end } || ''; - - return "$pre</$elem>$post"; -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::XML::Style - Simple XML stylesheet transfomations - -=head1 SYNOPSIS - - [% USE xmlstyle - table = { - attributes = { - border = 0 - cellpadding = 4 - cellspacing = 1 - } - } - %] - - [% FILTER xmlstyle %] - <table> - <tr> - <td>Foo</td> <td>Bar</td> <td>Baz</td> - </tr> - </table> - [% END %] - -=head1 DESCRIPTION - -This plugin defines a filter for performing simple stylesheet based -transformations of XML text. - -Named parameters are used to define those XML elements which require -transformation. These may be specified with the USE directive when -the plugin is loaded and/or with the FILTER directive when the plugin -is used. - -This example shows how the default attributes C<border="0"> and -C<cellpadding="4"> can be added to E<lt>tableE<gt> elements. - - [% USE xmlstyle - table = { - attributes = { - border = 0 - cellpadding = 4 - } - } - %] - - [% FILTER xmlstyle %] - <table> - ... - </table> - [% END %] - -This produces the output: - - <table border="0" cellpadding="4"> - ... - </table> - -Parameters specified within the USE directive are applied automatically each -time the C<xmlstyle> FILTER is used. Additional parameters passed to the -FILTER directive apply for only that block. - - [% USE xmlstyle - table = { - attributes = { - border = 0 - cellpadding = 4 - } - } - %] - - [% FILTER xmlstyle - tr = { - attributes = { - valign="top" - } - } - %] - <table> - <tr> - ... - </tr> - </table> - [% END %] - -Of course, you may prefer to define your stylesheet structures once and -simply reference them by name. Passing a hash reference of named parameters -is just the same as specifying the named parameters as far as the Template -Toolkit is concerned. - - [% style_one = { - table = { ... } - tr = { ... } - } - style_two = { - table = { ... } - td = { ... } - } - style_three = { - th = { ... } - tv = { ... } - } - %] - - [% USE xmlstyle style_one %] - - [% FILTER xmlstyle style_two %] - # style_one and style_two applied here - [% END %] - - [% FILTER xmlstyle style_three %] - # style_one and style_three applied here - [% END %] - -Any attributes defined within the source tags will override those specified -in the style sheet. - - [% USE xmlstyle - div = { attributes = { align = 'left' } } - %] - - - [% FILTER xmlstyle %] - <div>foo</div> - <div align="right">bar</div> - [% END %] - -The output produced is: - - <div align="left">foo</div> - <div align="right">bar</div> - -The filter can also be used to change the element from one type to another. - - [% FILTER xmlstyle - th = { - element = 'td' - attributes = { bgcolor='red' } - } - %] - <tr> - <th>Heading</th> - </tr> - <tr> - <td>Value</td> - </tr> - [% END %] - -The output here is as follows. Notice how the end tag C<E<lt>/thE<gt>> is -changed to C<E<lt>/tdE<gt>> as well as the start tag. - - <tr> - <td bgcolor="red">Heading</td> - </tr> - <tr> - <td>Value</td> - </tr> - -You can also define text to be added immediately before or after the -start or end tags. For example: - - [% FILTER xmlstyle - table = { - pre_start = '<div align="center">' - post_end = '</div>' - } - th = { - element = 'td' - attributes = { bgcolor='red' } - post_start = '<b>' - pre_end = '</b>' - } - %] - <table> - <tr> - <th>Heading</th> - </tr> - <tr> - <td>Value</td> - </tr> - </table> - [% END %] - -The output produced is: - - <div align="center"> - <table> - <tr> - <td bgcolor="red"><b>Heading</b></td> - </tr> - <tr> - <td>Value</td> - </tr> - </table> - </div> - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.34, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Plugin/XML/XPath.pm b/lib/Template/Plugin/XML/XPath.pm deleted file mode 100644 index adf9292..0000000 --- a/lib/Template/Plugin/XML/XPath.pm +++ /dev/null @@ -1,284 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugin::XML::XPath -# -# DESCRIPTION -# -# Template Toolkit plugin interfacing to the XML::XPath.pm module. -# -# AUTHOR -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: XPath.pm,v 2.69 2004/01/13 16:21:50 abw Exp $ -# -#============================================================================ - -package Template::Plugin::XML::XPath; - -require 5.004; - -use strict; -use Template::Exception; -use Template::Plugin; -use XML::XPath; - -use base qw( Template::Plugin ); -use vars qw( $VERSION ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.69 $ =~ /(\d+)\.(\d+)/); - - -#------------------------------------------------------------------------ -# new($context, \%config) -# -# Constructor method for XML::XPath plugin. Creates an XML::XPath -# object and initialises plugin configuration. -#------------------------------------------------------------------------ - -sub new { - my $class = shift; - my $context = shift; - my $args = ref $_[-1] eq 'HASH' ? pop(@_) : { }; - my ($content, $about); - - # determine the input source from a positional parameter (may be a - # filename or XML text if it contains a '<' character) or by using - # named parameters which may specify one of 'file', 'filename', 'text' - # or 'xml' - - if ($content = shift) { - if ($content =~ /\</) { - $about = 'xml text'; - $args->{ xml } = $content; - } - else { - $about = "xml file $content"; - $args->{ filename } = $content; - } - } - elsif ($content = $args->{ text } || $args->{ xml }) { - $about = 'xml text'; - $args->{ xml } = $content; - } - elsif ($content = $args->{ file } || $args->{ filename }) { - $about = "xml file $content"; - $args->{ filename } = $content; - } - else { - return $class->_throw('no filename or xml text specified'); - } - - return XML::XPath->new(%$args) - or $class->_throw("failed to create XML::XPath::Parser\n"); -} - - - -#------------------------------------------------------------------------ -# _throw($errmsg) -# -# Raise a Template::Exception of type XML.XPath via die(). -#------------------------------------------------------------------------ - -sub _throw { - my ($self, $error) = @_; -# print STDERR "about to throw $error\n"; - die (Template::Exception->new('XML.XPath', $error)); -} - - -#======================================================================== -package XML::XPath::Node::Element; -#======================================================================== - -#------------------------------------------------------------------------ -# present($view) -# -# Method to present an element node via a view. -#------------------------------------------------------------------------ - -sub present { - my ($self, $view) = @_; - $view->view($self->getName(), $self); -} - -sub content { - my ($self, $view) = @_; - my $output = ''; - foreach my $node (@{ $self->getChildNodes }) { - $output .= $node->present($view); - } - return $output; -} - -#---------------------------------------------------------------------- -# starttag(), endtag() -# -# Methods to output the start & end tag, e.g. <foo bar="baz"> & </foo> -#---------------------------------------------------------------------- - -sub starttag { - my ($self) = @_; - my $output = "<". $self->getName(); - foreach my $attr ($self->getAttributes()) - { - $output .= $attr->toString(); - } - $output .= ">"; - return $output; -} - -sub endtag { - my ($self) = @_; - return "</". $self->getName() . ">"; -} - -#======================================================================== -package XML::XPath::Node::Text; -#======================================================================== - -#------------------------------------------------------------------------ -# present($view) -# -# Method to present a text node via a view. -#------------------------------------------------------------------------ - -sub present { - my ($self, $view) = @_; - $view->view('text', $self->string_value); -} - - -#======================================================================== -package XML::XPath::Node::Comment; -#======================================================================== - -sub present { return ''; } -sub starttag { return ''; } -sub endtag { return ''; } - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Plugin::XML::XPath - Plugin interface to XML::XPath - -=head1 SYNOPSIS - - # load plugin and specify XML file to parse - [% USE xpath = XML.XPath(xmlfile) %] - [% USE xpath = XML.XPath(file => xmlfile) %] - [% USE xpath = XML.XPath(filename => xmlfile) %] - - # load plugin and specify XML text to parse - [% USE xpath = XML.XPath(xmltext) %] - [% USE xpath = XML.XPath(xml => xmltext) %] - [% USE xpath = XML.XPath(text => xmltext) %] - - # then call any XPath methods (see XML::XPath docs) - [% FOREACH page = xpath.findnodes('/html/body/page') %] - [% page.getAttribute('title') %] - [% END %] - - # define VIEW to present node(s) - [% VIEW repview notfound='xmlstring' %] - # handler block for a <report>...</report> element - [% BLOCK report %] - [% item.content(view) %] - [% END %] - - # handler block for a <section title="...">...</section> element - [% BLOCK section %] - <h1>[% item.getAttribute('title') | html %]</h1> - [% item.content(view) %] - [% END %] - - # default template block passes tags through and renders - # out the children recursivly - [% BLOCK xmlstring; - item.starttag; item.content(view); item.endtag; - END %] - - # block to generate simple text - [% BLOCK text; item | html; END %] - [% END %] - - # now present node (and children) via view - [% repview.print(page) %] - - # or print node content via view - [% page.content(repview) %] - -=head1 PRE-REQUISITES - -This plugin requires that the XML::Parser and XML::XPath modules be -installed. These are available from CPAN: - - http://www.cpan.org/modules/by-module/XML - -=head1 DESCRIPTION - -This is a Template Toolkit plugin interfacing to the XML::XPath module. - -All methods implemented by the XML::XPath modules are available. In -addition, the XML::XPath::Node::Element module implements -present($view) and content($view) methods method for seamless -integration with Template Toolkit VIEWs. The XML::XPath::Node::Text -module is also adorned with a present($view) method which presents -itself via the view using the 'text' template. - -To aid the reconstruction of XML, methods starttag and endtag are -added to XML::XPath::Node::Element which return the start and -end tag for that element. This means that you can easily do: - - [% item.starttag %][% item.content(view) %][% item.endtag %] - -To render out the start tag, followed by the content rendered in the -view "view", followed by the end tag. - -=head1 AUTHORS - -This plugin module was written by Andy Wardley E<lt>abw@wardley.orgE<gt>. - -The XML::XPath module is by Matt Sergeant E<lt>matt@sergeant.orgE<gt>. - -=head1 VERSION - -2.69, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template::Plugin|Template::Plugin>, L<XML::XPath|XML::XPath>, L<XML::Parser|XML::Parser> - diff --git a/lib/Template/Plugins.pm b/lib/Template/Plugins.pm deleted file mode 100644 index 1904efc..0000000 --- a/lib/Template/Plugins.pm +++ /dev/null @@ -1,1041 +0,0 @@ -#============================================================= -*-Perl-*- -# -# Template::Plugins -# -# DESCRIPTION -# Plugin provider which handles the loading of plugin modules and -# instantiation of plugin objects. -# -# AUTHORS -# Andy Wardley <abw@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Plugins.pm,v 2.70 2004/01/13 16:19:15 abw Exp $ -# -#============================================================================ - -package Template::Plugins; - -require 5.004; - -use strict; -use base qw( Template::Base ); -use vars qw( $VERSION $DEBUG $STD_PLUGINS ); -use Template::Constants; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.70 $ =~ /(\d+)\.(\d+)/); - -$STD_PLUGINS = { - 'autoformat' => 'Template::Plugin::Autoformat', - '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', - 'pod' => 'Template::Plugin::Pod', - 'table' => 'Template::Plugin::Table', - 'url' => 'Template::Plugin::URL', - 'view' => 'Template::Plugin::View', - 'wrap' => 'Template::Plugin::Wrap', - '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 ||= { }; - if (ref $pbase ne 'ARRAY') { - $pbase = $pbase ? [ $pbase ] : [ ]; - } - push(@$pbase, 'Template::Plugin'); - - $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 }) { - # 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); - } -} - - -#------------------------------------------------------------------------ -# _dump() -# -# Debug method which constructs and returns text representing the current -# state of the object. -#------------------------------------------------------------------------ - -sub _dump { - my $self = shift; - my $output = "[Template::Plugins] {\n"; - my $format = " %-16s => %s\n"; - my $key; - - foreach $key (qw( TOLERANT LOAD_PERL )) { - $output .= sprintf($format, $key, $self->{ $key }); - } - - local $" = ', '; - my $fkeys = join(", ", keys %{$self->{ FACTORY }}); - my $plugins = $self->{ PLUGINS }; - $plugins = join('', map { - sprintf(" $format", $_, $plugins->{ $_ }); - } keys %$plugins); - $plugins = "{\n$plugins }"; - - $output .= sprintf($format, 'PLUGIN_BASE', "[ @{ $self->{ PLUGIN_BASE } } ]"); - $output .= sprintf($format, 'PLUGINS', $plugins); - $output .= sprintf($format, 'FACTORY', $fkeys); - $output .= '}'; - return $output; -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 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 -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 Template.pm front-end module creates a 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 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 load() class method called -to return the factory class name (usually the same package name) or a -factory object (a prototype). The 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 ($error, STATUS_ERROR) -on error. May also return (undef, STATUS_DECLINED) to decline to -serve the request. If TOLERANT is set then all errors will be -returned as declines. - -=head1 CONFIGURATION OPTIONS - -The following list details the configuration options that can be provided -to the Template::Plugins new() constructor. - -=over 4 - - - - -=item PLUGINS - -The 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. 'table', 'cgi', 'dbi', etc.) which map to -their corresponding Template::Plugin::* counterparts. These can be -redefined by values in the PLUGINS hash. - - my $plugins = Template::Plugins->new({ - PLUGINS => { - cgi => 'MyOrg::Template::Plugin::CGI', - foo => 'MyOrg::Template::Plugin::Foo', - bar => 'MyOrg::Template::Plugin::Bar', - }, - }); - -The USE directive is used to create plugin objects and does so by -calling the plugin() method on the current Template::Context object. -If the plugin name is defined in the PLUGINS hash then the -corresponding Perl module is loaded via require(). The context then -calls the load() class method which should return the class name -(default and general case) or a prototype object against which the -new() method can be called to instantiate individual plugin objects. - -If the plugin name is not defined in the PLUGINS hash then the PLUGIN_BASE -and/or LOAD_PERL options come into effect. - - - - - -=item PLUGIN_BASE - -If a plugin is not defined in the PLUGINS hash then the PLUGIN_BASE is used -to attempt to construct a correct Perl module name which can be successfully -loaded. - -The PLUGIN_BASE can be specified as a single value or as a reference -to an array of multiple values. The default PLUGIN_BASE value, -'Template::Plugin', is always added the the end of the PLUGIN_BASE -list (a single value is first converted to a list). Each value should -contain a Perl package name to which the requested plugin name is -appended. - -example 1: - - my $plugins = Template::Plugins->new({ - PLUGIN_BASE => 'MyOrg::Template::Plugin', - }); - - [% USE Foo %] # => MyOrg::Template::Plugin::Foo - or Template::Plugin::Foo - -example 2: - - my $plugins = Template::Plugins->new({ - PLUGIN_BASE => [ 'MyOrg::Template::Plugin', - 'YourOrg::Template::Plugin' ], - }); - - [% USE Foo %] # => MyOrg::Template::Plugin::Foo - or YourOrg::Template::Plugin::Foo - or Template::Plugin::Foo - - - - - - -=item LOAD_PERL - -If a plugin cannot be loaded using the PLUGINS or 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 -Template::Plugin or some other such namespace) to be loaded and used -as plugins. - -By default, the LOAD_PERL option is set to 0 and no attempt will be made -to load any Perl modules that aren't named explicitly in the PLUGINS -hash or reside in a package as named by one of the PLUGIN_BASE -components. - -Plugins loaded using the PLUGINS or PLUGIN_BASE receive a reference to -the current context object as the first argument to the new() -constructor. Modules loaded using LOAD_PERL are assumed to not -conform to the plugin interface. They must provide a 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 -load() class method (or inherit the default one from the -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, new() constructor convention then a simple plugin wrapper -can be written to interface to it. - - - - -=item TOLERANT - -The TOLERANT flag is used by the various Template Toolkit provider -modules (Template::Provider, Template::Plugins, 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 (template, plugin, filter) being denied and an exception -raised. When the TOLERANT flag is set to any true values, errors will -be silently ignored and the provider will instead return -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 'E<lt>resourceE<gt> not found' exception is raised. - - - - -=item DEBUG - -The DEBUG option can be used to enable debugging messages from the -Template::Plugins module by setting it to include the DEBUG_PLUGINS -value. - - use Template::Constants qw( :debug ); - - my $template = Template->new({ - DEBUG => DEBUG_FILTERS | DEBUG_PLUGINS, - }); - - - - -=back - - - -=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 Autoformat - -The Autoformat plugin is an interface to Damian Conway's Text::Autoformat -Perl module which provides advanced text wrapping and formatting. See -L<Template::Plugin::Autoformat> and L<Text::Autoformat> for further -details. - - [% USE autoformat(left=10, right=20) %] - [% autoformat(mytext) %] # call autoformat sub - [% mytext FILTER autoformat %] # or use autoformat filter - -The Text::Autoformat module is available from CPAN: - - http://www.cpan.org/modules/by-module/Text/ - -=head2 CGI - -The CGI plugin is a wrapper around Lincoln Stein's -E<lt>lstein@genome.wi.mit.eduE<gt> CGI.pm module. The plugin is -distributed with the Template Toolkit (see L<Template::Plugin::CGI>) -and the 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 int he 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 Date plugin provides an easy way to generate formatted time and date -strings by delegating to the POSIX 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 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 DBI plugin, developed by Simon Matthews -E<lt>sam@knowledgepool.comE<gt>, brings the full power of Tim Bunce's -E<lt>Tim.Bunce@ig.co.ukE<gt> database interface module (DBI) to your -templates. See L<Template::Plugin::DBI> and L<DBI> for further details. - - [% USE DBI('dbi:driver:database', 'user', 'pass') %] - - [% FOREACH user = DBI.query( 'SELECT * FROM users' ) %] - [% user.id %] [% user.name %] - [% END %] - -The DBI and relevant DBD modules are available from CPAN: - - http://www.cpan.org/modules/by-module/DBI/ - -=head2 Dumper - -The Dumper plugin provides an interface to the Data::Dumper module. See -L<Template::Plugin::Dumper> and L<Data::Dumper> for futher details. - - [% USE dumper(indent=0, pad="<br>") %] - [% dumper.dump(myvar, yourvar) %] - -=head2 File - -The 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; - } - - # 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 Format plugin provides a simple way to format text according to a -printf()-like format. See L<Template::Plugin::Format> for further -details. - - [% USE bold = format('<b>%s</b>') %] - [% bold('Hello') %] - -=head2 GD::Image, GD::Polygon, GD::Constants - -These plugins provide access to the GD graphics library via Lincoln -D. Stein's GD.pm interface. These plugins allow PNG, JPEG and other -graphical formats to be generated. - - [% FILTER null; - USE im = GD.Image(100,100); - # allocate some colors - black = im.colorAllocate(0, 0, 0); - red = im.colorAllocate(255,0, 0); - blue = im.colorAllocate(0, 0, 255); - # Draw a blue oval - im.arc(50,50,95,75,0,360,blue); - # And fill it with red - im.fill(50,50,red); - # Output image in PNG format - im.png | stdout(1); - END; - -%] - -See L<Template::Plugin::GD::Image> for further details. - -=head2 GD::Text, GD::Text::Align, GD::Text::Wrap - -These plugins provide access to Martien Verbruggen's GD::Text, -GD::Text::Align and GD::Text::Wrap modules. These plugins allow the -layout, alignment and wrapping of text when drawing text in GD images. - - [% FILTER null; - USE gd = GD.Image(200,400); - USE gdc = GD.Constants; - black = gd.colorAllocate(0, 0, 0); - green = gd.colorAllocate(0, 255, 0); - txt = "This is some long text. " | repeat(10); - USE wrapbox = GD.Text.Wrap(gd, - line_space => 4, - color => green, - text => txt, - ); - wrapbox.set_font(gdc.gdMediumBoldFont); - wrapbox.set(align => 'center', width => 160); - wrapbox.draw(20, 20); - gd.png | stdout(1); - END; - -%] - -See L<Template::Plugin::GD::Text>, L<Template::Plugin::GD::Text::Align> -and L<Template::Plugin::GD::Text::Wrap> for further details. - -=head2 GD::Graph::lines, GD::Graph::bars, GD::Graph::points, GD::Graph::linespoin -ts, GD::Graph::area, GD::Graph::mixed, GD::Graph::pie - -These plugins provide access to Martien Verbruggen's GD::Graph module -that allows graphs, plots and charts to be created. These plugins allow -graphs, plots and charts to be generated in PNG, JPEG and other -graphical formats. - - [% FILTER null; - data = [ - ["1st","2nd","3rd","4th","5th","6th"], - [ 4, 2, 3, 4, 3, 3.5] - ]; - USE my_graph = GD.Graph.pie(250, 200); - my_graph.set( - title => 'A Pie Chart', - label => 'Label', - axislabelclr => 'black', - pie_height => 36, - transparent => 0, - ); - my_graph.plot(data).png | stdout(1); - END; - -%] - -See -L<Template::Plugin::GD::Graph::lines>, -L<Template::Plugin::GD::Graph::bars>, -L<Template::Plugin::GD::Graph::points>, -L<Template::Plugin::GD::Graph::linespoints>, -L<Template::Plugin::GD::Graph::area>, -L<Template::Plugin::GD::Graph::mixed>, -L<Template::Plugin::GD::Graph::pie>, and -L<GD::Graph>, -for more details. - -=head2 GD::Graph::bars3d, GD::Graph::lines3d, GD::Graph::pie3d - -These plugins provide access to Jeremy Wadsack's GD::Graph3d -module. This allows 3D bar charts and 3D lines plots to -be generated. - - [% FILTER null; - data = [ - ["1st","2nd","3rd","4th","5th","6th","7th", "8th", "9th"], - [ 1, 2, 5, 6, 3, 1.5, 1, 3, 4], - ]; - USE my_graph = GD.Graph.bars3d(); - my_graph.set( - x_label => 'X Label', - y_label => 'Y label', - title => 'A 3d Bar Chart', - y_max_value => 8, - y_tick_number => 8, - y_label_skip => 2, - # shadows - bar_spacing => 8, - shadow_depth => 4, - shadowclr => 'dred', - transparent => 0, - my_graph.plot(data).png | stdout(1); - END; - -%] - -See -L<Template::Plugin::GD::Graph::lines3d>, -L<Template::Plugin::GD::Graph::bars3d>, and -L<Template::Plugin::GD::Graph::pie3d> -for more details. - -=head2 HTML - -The HTML plugin is very new and 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 (as discussed recently on the mod_perl mailing list). - - [% 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 Iterator plugin provides a way to create a Template::Iterator -object to iterate over a data set. An iterator is created -automatically by the FOREACH directive and is aliased to the 'loop' -variable. This plugin allows an iterator to be explicitly created -with a given name, or the default plugin name, '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 String - -The 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 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 URL plugin provides a simple way of contructing 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 Wrap plugin uses the Text::Wrap module by David Muir Sharnoff -E<lt>muir@idiom.comE<gt> (with help from Tim Pierce and many many others) -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 Text::Wrap module is available from CPAN: - - http://www.cpan.org/modules/by-module/Text/ - -=head2 XML::DOM - -The XML::DOM plugin gives access to the XML Document Object Module via -Clark Cooper E<lt>cooper@sch.ge.comE<gt> and Enno Derksen's -E<lt>enno@att.comE<gt> XML::DOM module. See L<Template::Plugin::XML::DOM> -and L<XML::DOM> for further details. - - [% USE dom = XML.DOM %] - [% doc = dom.parse(filename) %] - - [% FOREACH node = doc.getElementsByTagName('CODEBASE') %] - * [% node.getAttribute('href') %] - [% END %] - -The plugin requires the XML::DOM module, available from CPAN: - - http://www.cpan.org/modules/by-module/XML/ - -=head2 XML::RSS - -The XML::RSS plugin is a simple interface to Jonathan Eisenzopf's -E<lt>eisen@pobox.comE<gt> XML::RSS module. A RSS (Rich Site Summary) -file is typically used to store short news 'headlines' describing -different links within a site. This plugin allows you to parse RSS -files and format the contents accordingly using templates. -See L<Template::Plugin::XML::RSS> and L<XML::RSS> for further details. - - [% USE news = XML.RSS(filename) %] - - [% FOREACH item = news.items %] - <a href="[% item.link %]">[% item.title %]</a> - [% END %] - -The XML::RSS module is available from CPAN: - - http://www.cpan.org/modules/by-module/XML/ - -=head2 XML::Simple - -This plugin implements an interface to the L<XML::Simple|XML::Simple> -module. - - [% USE xml = XML.Simple(xml_file_or_text) %] - - [% xml.head.title %] - -See L<Template::Plugin::XML::Simple> for further details. - -=head2 XML::Style - -This plugin defines a filter for performing simple stylesheet based -transformations of XML text. - - [% USE xmlstyle - table = { - attributes = { - border = 0 - cellpadding = 4 - cellspacing = 1 - } - } - %] - - [% FILTER xmlstyle %] - <table> - <tr> - <td>Foo</td> <td>Bar</td> <td>Baz</td> - </tr> - </table> - [% END %] - -See L<Template::Plugin::XML::Style> for further details. - -=head2 XML::XPath - -The XML::XPath plugin provides an interface to Matt Sergeant's -E<lt>matt@sergeant.orgE<gt> XML::XPath module. See -L<Template::Plugin::XML::XPath> and L<XML::XPath> for further details. - - [% USE xpath = XML.XPath(xmlfile) %] - [% FOREACH page = xpath.findnodes('/html/body/page') %] - [% page.getAttribute('title') %] - [% END %] - -The plugin requires the XML::XPath module, available from CPAN: - - http://www.cpan.org/modules/by-module/XML/ - - - - -=head1 BUGS / ISSUES - -=over 4 - -=item * - -It might be worthwhile being able to distinguish between absolute -module names and those which should be applied relative to PLUGIN_BASE -directories. For example, use 'MyNamespace::MyModule' to denote -absolute module names (e.g. LOAD_PERL), and 'MyNamespace.MyModule' to -denote relative to PLUGIN_BASE. - -=back - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.70, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template>, L<Template::Plugin|Template::Plugin>, L<Template::Context|Template::Context> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Provider.pm b/lib/Template/Provider.pm deleted file mode 100644 index 0826a18..0000000 --- a/lib/Template/Provider.pm +++ /dev/null @@ -1,1449 +0,0 @@ -#============================================================= -*-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. -# -# AUTHOR -# Andy Wardley <abw@wardley.org> -# -# COPYRIGHT -# Copyright (C) 1996-2003 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. -# -# TODO: -# * optional provider prefix (e.g. 'http:') -# * fold ABSOLUTE and RELATIVE test cases into one regex? -# -#---------------------------------------------------------------------------- -# -# $Id: Provider.pm,v 2.79 2004/01/13 16:19:16 abw Exp $ -# -#============================================================================ - -package Template::Provider; - -require 5.004; - -use strict; -use vars qw( $VERSION $DEBUG $ERROR $DOCUMENT $STAT_TTL $MAX_DIRS ); -use base qw( Template::Base ); -use Template::Config; -use Template::Constants; -use Template::Document; -use File::Basename; -use File::Spec; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.79 $ =~ /(\d+)\.(\d+)/); - -# name of document class -$DOCUMENT = 'Template::Document' unless defined $DOCUMENT; - -# maximum time between performing stat() on file to check staleness -$STAT_TTL = 1 unless defined $STAT_TTL; - -# maximum number of directories in an INCLUDE_PATH, to prevent runaways -$MAX_DIRS = 64 unless defined $MAX_DIRS; - -use constant PREV => 0; -use constant NAME => 1; -use constant DATA => 2; -use constant LOAD => 3; -use constant NEXT => 4; -use constant STAT => 5; - -$DEBUG = 0 unless defined $DEBUG; - -#======================================================================== -# -- 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[^\.+/]) { - # 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); - } - -# $self->_dump_cache() -# if $DEBUG > 1; - - return ($data, $error); -} - - -#------------------------------------------------------------------------ -# store($name, $data) -# -# Store a compiled template ($data) in the cached as $name. -#------------------------------------------------------------------------ - -sub store { - my ($self, $name, $data) = @_; - $self->_store($name, { - data => $data, - load => 0, - }); -} - - -#------------------------------------------------------------------------ -# 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[^\.+/]) { - # 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 = "$dir/$name"; - last INCPATH - if -f $path; - } - undef $path; # not found - } - } - - if (defined $path && ! $error) { - local $/ = undef; # slurp files in one go - local *FH; - if (open(FH, $path)) { - $data = <FH>; - close(FH); - } - else { - $error = "$name: $!"; - } - } - - 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 (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 = ($^O eq 'MSWin32') ? ':(?!\\/)' : ':'; - } - - # 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) { - -# Stas' hack -# # this is a hack to solve the problem with INCLUDE_PATH using -# # relative dirs -# my $segments = 0; -# for (@$path) { -# my $c = 0; -# $c++ while m|\.\.|g; -# $segments = $c if $c > $segments; -# } -# $cdir .= "/".join "/",('hack') x $segments if $segments; -# - - require File::Path; - foreach my $dir (@$path) { - next if ref $dir; - my $wdir = $dir; - $wdir =~ s[:][]g if $^O eq 'MSWin32'; - $wdir =~ /(.*)/; # untaint - &File::Path::mkpath(File::Spec->catfile($cdir, $1)); - } - } - - $self->{ LOOKUP } = { }; - $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->{ PREFIX } = $params->{ PREFIX }; - $self->{ PARAMS } = $params; - - return $self; -} - - -#------------------------------------------------------------------------ -# _fetch($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. -#------------------------------------------------------------------------ - -sub _fetch { - my ($self, $name) = @_; - my $size = $self->{ SIZE }; - my ($slot, $data, $error); - - $self->debug("_fetch($name)") if $self->{ DEBUG }; - - my $compiled = $self->_compiled_filename($name); - - if (defined $size && ! $size) { - # caching disabled so load and compile but don't cache - if ($compiled && -f $compiled - && (stat($name))[9] <= (stat($compiled))[9]) { - $data = $self->_load_compiled($compiled); - $error = $self->error() unless $data; - } - else { - ($data, $error) = $self->_load($name); - ($data, $error) = $self->_compile($data, $compiled) - unless $error; - $data = $data->{ data } - unless $error; - } - } - elsif ($slot = $self->{ LOOKUP }->{ $name }) { - # cached entry exists, so refresh slot and extract data - ($data, $error) = $self->_refresh($slot); - $data = $slot->[ DATA ] - unless $error; - } - else { - # nothing in cache so try to load, compile and cache - if ($compiled && -f $compiled - && (stat($name))[9] <= (stat($compiled))[9]) { - $data = $self->_load_compiled($compiled); - $error = $self->error() unless $data; - $self->store($name, $data) unless $error; - } - else { - ($data, $error) = $self->_load($name); - ($data, $error) = $self->_compile($data, $compiled) - unless $error; - $data = $self->_store($name, $data) - unless $error; - } - } - - return ($data, $error); -} - - -#------------------------------------------------------------------------ -# _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) = @_; - my ($size, $compext, $compdir) = - @$self{ qw( SIZE COMPILE_EXT COMPILE_DIR ) }; - my ($dir, $paths, $path, $compiled, $slot, $data, $error); - local *FH; - - $self->debug("_fetch_path($name)") if $self->{ DEBUG }; - - # caching is enabled if $size is defined and non-zero or undefined - my $caching = (! defined $size || $size); - - INCLUDE: { - - # the template may have been stored using a non-filename name - if ($caching && ($slot = $self->{ LOOKUP }->{ $name })) { - # cached entry exists, so refresh slot and extract data - ($data, $error) = $self->_refresh($slot); - $data = $slot->[ DATA ] - unless $error; - last INCLUDE; - } - - $paths = $self->paths() || do { - $error = Template::Constants::STATUS_ERROR; - $data = $self->error(); - last INCLUDE; - }; - - # search the INCLUDE_PATH for the file, in cache or on disk - foreach $dir (@$paths) { - $path = File::Spec->catfile($dir, $name); - - $self->debug("searching path: $path\n") if $self->{ DEBUG }; - - if ($caching && ($slot = $self->{ LOOKUP }->{ $path })) { - # cached entry exists, so refresh slot and extract data - ($data, $error) = $self->_refresh($slot); - $data = $slot->[ DATA ] - unless $error; - last INCLUDE; - } - elsif (-f $path) { - $compiled = $self->_compiled_filename($path) - if $compext || $compdir; - - if ($compiled && -f $compiled - && (stat($path))[9] <= (stat($compiled))[9]) { - if ($data = $self->_load_compiled($compiled)) { - # store in cache - $data = $self->store($path, $data); - $error = Template::Constants::STATUS_OK; - last INCLUDE; - } - else { - warn($self->error(), "\n"); - } - } - # $compiled is set if an attempt to write the compiled - # template to disk should be made - - ($data, $error) = $self->_load($path, $name); - ($data, $error) = $self->_compile($data, $compiled) - unless $error; - $data = $self->_store($path, $data) - unless $error || ! $caching; - $data = $data->{ data } if ! $caching; - # all done if $error is OK or ERROR - last INCLUDE if ! $error - || $error == Template::Constants::STATUS_ERROR; - } - } - # template not found, so look for a DEFAULT template - my $default; - if (defined ($default = $self->{ DEFAULT }) && $name ne $default) { - $name = $default; - redo INCLUDE; - } - ($data, $error) = (undef, Template::Constants::STATUS_DECLINED); - } # INCLUDE - - return ($data, $error); -} - - - -sub _compiled_filename { - my ($self, $file) = @_; - my ($compext, $compdir) = @$self{ qw( COMPILE_EXT COMPILE_DIR ) }; - my ($path, $compiled); - - return undef - unless $compext || $compdir; - - $path = $file; - $path =~ /^(.+)$/s or die "invalid filename: $path"; - $path =~ s[:][]g if $^O eq 'MSWin32'; - - $compiled = "$path$compext"; - $compiled = File::Spec->catfile($compdir, $compiled) if length $compdir; - - return $compiled; -} - - -sub _load_compiled { - my ($self, $file) = @_; - 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{ $file }; - eval { $compiled = require $file; }; - 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; - local $/ = undef; # slurp files in one go - local *FH; - - $alias = $name unless defined $alias or ref $name; - - $self->debug("_load($name, ", defined $alias ? $alias : '<no alias>', - ')') if $self->{ DEBUG }; - - LOAD: { - if (ref $name eq 'SCALAR') { - # $name can be a SCALAR reference to the input text... - $data = { - name => defined $alias ? $alias : 'input text', - text => $$name, - time => $now, - load => 0, - }; - } - elsif (ref $name) { - # ...or a GLOB or file handle... - my $text = <$name>; - $data = { - name => defined $alias ? $alias : 'input file handle', - text => $text, - time => $now, - load => 0, - }; - } - elsif (-f $name) { - if (open(FH, $name)) { - my $text = <FH>; - $data = { - name => $alias, - path => $name, - text => $text, - time => (stat $name)[9], - load => $now, - }; - } - elsif ($tolerant) { - ($data, $error) = (undef, Template::Constants::STATUS_DECLINED); - } - else { - $data = "$alias: $!"; - $error = Template::Constants::STATUS_ERROR; - } - } - else { - ($data, $error) = (undef, Template::Constants::STATUS_DECLINED); - } - } - - $data->{ path } = $data->{ name } - if $data and ! defined $data->{ path }; - - return ($data, $error); -} - - -#------------------------------------------------------------------------ -# _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 upated since it was compiled, then -# it is re-loaded from disk and re-compiled. -#------------------------------------------------------------------------ - -sub _refresh { - my ($self, $slot) = @_; - 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 - if ( (time - $slot->[ STAT ]) > $STAT_TTL && stat $slot->[ NAME ] ) { - $slot->[ STAT ] = time; - - if ( (stat(_))[9] != $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; - - unless ($error) { - $slot->[ DATA ] = $data->{ data }; - $slot->[ LOAD ] = $data->{ time }; - } - } - } - - 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. -#------------------------------------------------------------------------ - -sub _store { - my ($self, $name, $data, $compfile) = @_; - my $size = $self->{ SIZE }; - my ($slot, $head); - - # extract the load time and compiled template from the data -# my $load = $data->{ load }; - my $load = (stat($name))[9]; - $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); - $basedir =~ /(.*)/; - $basedir = $1; - &File::Path::mkpath($basedir) unless -d $basedir; - - 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) = $compfile =~ /^(.+)$/s or do { - return("invalid filename: $compfile", - Template::Constants::STATUS_ERROR); - }; - - my ($ctime) = $data->{ time } =~ /^(\d+)$/; - unless ($ctime || $ctime eq 0) { - return("invalid time: $ctime", - Template::Constants::STATUS_ERROR); - } - utime($ctime, $ctime, $cfile); - } - } - - 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) -} - - -#------------------------------------------------------------------------ -# _dump() -# -# Debug method which returns a string representing the internal object -# state. -#------------------------------------------------------------------------ - -sub _dump { - my $self = shift; - my $size = $self->{ SIZE }; - my $parser = $self->{ PARSER }; - $parser = $parser ? $parser->_dump() : '<no parser>'; - $parser =~ s/\n/\n /gm; - $size = 'unlimited' unless defined $size; - - my $output = "[Template::Provider] {\n"; - my $format = " %-16s => %s\n"; - my $key; - - $output .= sprintf($format, 'INCLUDE_PATH', - '[ ' . join(', ', @{ $self->{ INCLUDE_PATH } }) . ' ]'); - $output .= sprintf($format, 'CACHE_SIZE', $size); - - foreach $key (qw( ABSOLUTE RELATIVE TOLERANT DELIMITER - COMPILE_EXT COMPILE_DIR )) { - $output .= sprintf($format, $key, $self->{ $key }); - } - $output .= sprintf($format, 'PARSER', $parser); - - - local $" = ', '; - my $lookup = $self->{ LOOKUP }; - $lookup = join('', map { - sprintf(" $format", $_, defined $lookup->{ $_ } - ? ('[ ' . join(', ', map { defined $_ ? $_ : '<undef>' } - @{ $lookup->{ $_ } }) . ' ]') : '<undef>'); - } sort keys %$lookup); - $lookup = "{\n$lookup }"; - - $output .= sprintf($format, LOOKUP => $lookup); - - $output .= '}'; - return $output; -} - - -#------------------------------------------------------------------------ -# _dump_cache() -# -# Debug method which prints the current state of the cache to STDERR. -#------------------------------------------------------------------------ - -sub _dump_cache { - my $self = shift; - my ($node, $lut, $count); - - $count = 0; - if ($node = $self->{ HEAD }) { - while ($node) { - $lut->{ $node } = $count++; - $node = $node->[ NEXT ]; - } - $node = $self->{ HEAD }; - print STDERR "CACHE STATE:\n"; - print STDERR " HEAD: ", $self->{ HEAD }->[ NAME ], "\n"; - print STDERR " TAIL: ", $self->{ TAIL }->[ NAME ], "\n"; - while ($node) { - my ($prev, $name, $data, $load, $next) = @$node; -# $name = '...' . substr($name, -10) if length $name > 10; - $prev = $prev ? "#$lut->{ $prev }<-": '<undef>'; - $next = $next ? "->#$lut->{ $next }": '<undef>'; - print STDERR " #$lut->{ $node } : [ $prev, $name, $data, $load, $next ]\n"; - $node = $node->[ NEXT ]; - } - } -} - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 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 Template::Context objects maintain a list of Template::Provider -objects which are polled in turn (via fetch()) to return a requested -template. Each may return a compiled template, raise an error, or -decline to serve the reqest, giving subsequent providers a chance to -do so. - -This is the "Chain of Responsiblity" pattern. See 'Design Patterns' for -further information. - -This documentation needs work. - -=head1 PUBLIC METHODS - -=head2 new(\%options) - -Constructor method which instantiates and returns a new Template::Provider -object. The optional parameter may be a hash reference containing any of -the following items: - -=over 4 - - - - -=item INCLUDE_PATH - -The 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 BLOCK, each of the 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 ':'. - - my $provider = Template::Provider->new({ - INCLUDE_PATH => '/usr/local/templates', - }); - - my $provider = Template::Provider->new({ - INCLUDE_PATH => '/usr/local/templates:/tmp/my/templates', - }); - - my $provider = Template::Provider->new({ - INCLUDE_PATH => [ '/usr/local/templates', - '/tmp/my/templates' ], - }); - -On Win32 systems, a little extra magic is invoked, ignoring delimiters -that have ':' followed by a '/' or '\'. This avoids confusion when using -directory names like 'C:\Blah Blah'. - -When specified as a list, the INCLUDE_PATH path can contain elements -which dynamically generate a list of INCLUDE_PATH directories. These -generator elements can be specified as a reference to a subroutine or -an object which implements a paths() method. - - my $provider = Template::Provider->new({ - INCLUDE_PATH => [ '/usr/local/templates', - \&incpath_generator, - My::IncPath::Generator->new( ... ) ], - }); - -Each time a template is requested and the 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 die(). Generator objects should return undef and make an -error available via its 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; - - - - - -=item DELIMITER - -Used to provide an alternative delimiter character sequence for -separating paths specified in the INCLUDE_PATH. The default -value for DELIMITER is ':'. - - # tolerate Silly Billy's file system conventions - my $provider = Template::Provider->new({ - DELIMITER => '; ', - INCLUDE_PATH => 'C:/HERE/NOW; D:/THERE/THEN', - }); - - # better solution: install Linux! :-) - -On Win32 systems, the default delimiter is a little more intelligent, -splitting paths only on ':' characters that aren't followed by a '/'. -This means that the following should work as planned, splitting the -INCLUDE_PATH into 2 separate directories, C:/foo and C:/bar. - - # on Win32 only - my $provider = Template::Provider->new({ - INCLUDE_PATH => 'C:/Foo:C:/Bar' - }); - -However, if you're using Win32 then it's recommended that you -explicitly set the DELIMITER character to something else (e.g. ';') -rather than rely on this subtle magic. - - - - -=item ABSOLUTE - -The ABSOLUTE flag is used to indicate if templates specified with -absolute filenames (e.g. '/foo/bar') should be processed. It is -disabled by default and any attempt to load a template by such a -name will cause a 'file' exception to be raised. - - my $provider = Template::Provider->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 - - - - - - -=item RELATIVE - -The RELATIVE flag is used to indicate if templates specified with -filenames relative to the current directory (e.g. './foo/bar' or -'../../some/where/else') should be loaded. It is also disabled by -default, and will raise a 'file' error if such template names are -encountered. - - my $provider = Template::Provider->new({ - RELATIVE => 1, - }); - - [% INCLUDE ../logs/error.log %] - - - - - -=item DEFAULT - -The DEFAULT option can be used to specify a default template which should -be used whenever a specified template can't be found in the INCLUDE_PATH. - - my $provider = Template::Provider->new({ - DEFAULT => 'notfound.html', - }); - -If a non-existant template is requested through the Template process() -method, or by an INCLUDE, PROCESS or WRAPPER directive, then the -DEFAULT template will instead be processed, if defined. Note that the -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. - - - - - -=item CACHE_SIZE - -The Template::Provider module caches compiled templates to avoid the need -to re-parse template files or blocks each time they are used. The CACHE_SIZE -option is used to limit the number of compiled templates that the module -should cache. - -By default, the 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 == CACHE_SIZE), the least recently used compiled template -is discarded to make room for the new one. - -The CACHE_SIZE can be set to 0 to disable caching altogether. - - my $provider = Template::Provider->new({ - CACHE_SIZE => 64, # only cache 64 compiled templates - }); - - my $provider = Template::Provider->new({ - CACHE_SIZE => 0, # don't cache any compiled templates - }); - - - - - - -=item 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 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 $provider = Template::Provider->new({ - COMPILE_EXT => '.ttc', - }); - -If COMPILE_EXT is defined (and COMPILE_DIR isn't, see below) then compiled -template files with the 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 COMPILE_EXT or 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 require(), leaving Perl to handle -all the parsing and compilation. This is a Good Thing. - -=item COMPILE_DIR - -The 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', - }); - -The COMPILE_EXT option may also be specified to have a consistent file -extension added to these files. - - my $provider1 = Template::Provider->new({ - COMPILE_DIR => '/tmp/ttc', - COMPILE_EXT => '.ttc1', - }); - - my $provider2 = Template::Provider->new({ - COMPILE_DIR => '/tmp/ttc', - COMPILE_EXT => '.ttc2', - }); - - -When 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 INCLUDE_PATH is replicated in full beneath the -COMPILE_DIR directory. This example: - - my $provider = Template::Provider->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 INCLUDE_PATH directories will have their -compiled forms save in the relevant 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 COMPILE_DIR value(s) to prevent illegal filename being generated. -Any colon in COMPILE_DIR elements will be left intact. For example: - - # Win32 only - my $provider = Template::Provider->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 - - - - -=item TOLERANT - -The TOLERANT flag is used by the various Template Toolkit provider -modules (Template::Provider, Template::Plugins, 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 (template, plugin, filter) being denied and an exception -raised. When the TOLERANT flag is set to any true values, errors will -be silently ignored and the provider will instead return -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 'E<lt>resourceE<gt> not found' exception is raised. - - - - - - -=item PARSER - -The 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 -Template::Provider whenever a template is loaded and requires -compilation. The PARSER option can be used to provide a reference to -an alternate parser object. - - my $provider = Template::Provider->new({ - PARSER => MyOrg::Template::Parser->new({ ... }), - }); - - - -=item DEBUG - -The DEBUG option can be used to enable debugging messages from the -Template::Provider module by setting it to include the DEBUG_PROVIDER -value. - - use Template::Constants qw( :debug ); - - my $template = Template->new({ - DEBUG => DEBUG_PROVIDER, - }); - - - -=back - -=head2 fetch($name) - -Returns a compiled template for the name specified. If the template -cannot be found then (undef, STATUS_DECLINED) is returned. If an error -occurs (e.g. read error, parse error) then ($error, STATUS_ERROR) is -returned, where $error is the error message generated. If the TOLERANT -flag is set the the method returns (undef, STATUS_DECLINED) instead of -returning an error. - -=head2 store($name, $template) - -Stores the compiled template, $template, in the cache under the name, -$name. Susbequent calls to fetch($name) will return this template in -preference to any disk-based file. - -=head2 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. - -=head2 paths() - -This method generates a copy of the INCLUDE_PATH list. Any elements in the -list which are dynamic generators (e.g. references to subroutines or objects -implementing a 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 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 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.79, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template>, L<Template::Parser|Template::Parser>, L<Template::Context|Template::Context> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Service.pm b/lib/Template/Service.pm deleted file mode 100644 index fb5590a..0000000 --- a/lib/Template/Service.pm +++ /dev/null @@ -1,775 +0,0 @@ -#============================================================= -*-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@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Service.pm,v 2.75 2004/01/13 16:19:16 abw Exp $ -# -#============================================================================ - -package Template::Service; - -require 5.004; - -use strict; -use vars qw( $VERSION $DEBUG $ERROR ); -use base qw( Template::Base ); -use Template::Base; -use Template::Config; -use Template::Exception; -use Template::Constants; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.75 $ =~ /(\d+)\.(\d+)/); -$DEBUG = 0 unless defined $DEBUG; - - -#======================================================================== -# ----- 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 ||= { }; - $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 (ref $$error); - - # 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; -} - - - -#------------------------------------------------------------------------ -# _dump() -# -# Debug method which return a string representing the internal object -# state. -#------------------------------------------------------------------------ - -sub _dump { - my $self = shift; - my $context = $self->{ CONTEXT }->_dump(); - $context =~ s/\n/\n /gm; - - my $error = $self->{ ERROR }; - $error = join('', - "{\n", - (map { " $_ => $error->{ $_ }\n" } - keys %$error), - "}\n") - if ref $error; - - local $" = ', '; - return <<EOF; -$self -PRE_PROCESS => [ @{ $self->{ PRE_PROCESS } } ] -POST_PROCESS => [ @{ $self->{ POST_PROCESS } } ] -ERROR => $error -CONTEXT => $context -EOF -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 Template::Service module implements an object class for providing -a consistent template processing service. - -Standard header (PRE_PROCESS) and footer (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 -INCLUDEd or PROCESSed from within). An 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 Template::Service object is created by the Template module. -Any Template::Service options may be passed to the Template new() -constructor method and will be forwarded to the Template::Service -constructor. - - use Template; - - my $template = Template->new({ - PRE_PROCESS => 'header', - POST_PROCESS => 'footer', - }); - -Similarly, the Template::Service constructor will forward all configuration -parameters onto other default objects (e.g. Template::Context) that it may -need to instantiate. - -A Template::Service object (or subclass/derivative) can be explicitly -instantiated and passed to the Template new() constructor method as -the 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 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 Template module uses the Template::Config service() factory method -to create a default service object when required. The -$Template::Config::SERVICE package variable may be set to specify an -alternate service module. This will be loaded automatically and its -new() constructor method called by the 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 new() constructor method is called to instantiate a Template::Service -object. Configuration parameters may be specified as a HASH reference or -as a list of (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 new() method returns a Template::Service object (or sub-class) or -undef on error. In the latter case, a relevant error message can be -retrieved by the error() class method or directly from the -$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; - -The following configuration items may be specified: - -=over 4 - - - - -=item PRE_PROCESS, POST_PROCESS - -These values may be set to contain the name(s) of template files -(relative to 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 INCLUDE, -PROCESS, 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', - }; - -Alternately, multiple template may be specified as a single string, -delimited by ':'. This delimiter string can be changed via the -DELIMITER option. - - my $service = Template::Service->new({ - PRE_PROCESS => 'config:header', - POST_PROCESS => 'footer', - }; - -The PRE_PROCESS and 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 Template::Document object representing the main template being processed -is available within PRE_PROCESS and POST_PROCESS templates as the 'template' -variable. Metadata items defined via the META directive may be accessed -accordingly. - - $service->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 %]"> - - - - - - - - - - - - - - -=item PROCESS - -The PROCESS option may be set to contain the name(s) of template files -(relative to INCLUDE_PATH) which should be processed instead of the -main template passed to the Template::Service process() method. This can -be used to apply consistent wrappers around all templates, similar to -the use of PRE_PROCESS and 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 'template' -variable. Metadata items can be inspected and the template can be -processed by specifying it as a variable reference (i.e. prefixed by -'$') to an INCLUDE, PROCESS or WRAPPER directive. - -content: - - <html> - <head> - <title>[% template.title %]</title> - </head> - - <body> - [% PROCESS $template %] - <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> - <h1>The Foo Page</h1> - Welcome to the Foo Page, blah blah blah - <hr> - © Copyright 2000 Fred Foo - </body> - </html> - - - - - - - -=item ERROR - -The ERROR (or 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 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 'default' template may be provided for the general -case. Note that 'ERROR' can be pluralised to 'ERRORS' if you find -it more appropriate in this case. - - my $service = Template::Service->new({ - ERRORS => { - user => 'user/index.html', - dbi => 'error/database', - default => 'error/default', - }, - }); - -In this example, any 'user' exceptions thrown will cause the -'user/index.html' template to be processed, 'dbi' errors are handled -by 'error/database' and all others by the 'error/default' template. -Any PRE_PROCESS and/or POST_PROCESS templates will also be applied -to these error templates. - -Note that exception types are hierarchical and a 'foo' handler will -catch all 'foo.*' errors (e.g. foo.bar, 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 'user'.'passwd'). - - my $service = Template::Service->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 $service object, or -other templates or code called from within, can raise a 'user.login' -exception and have the service redirect to the 'user/login.html' -template. Similarly, a 'user.passwd' exception has a specific -handling template, 'user/badpasswd.html', while all other 'user' or -'user.*' exceptions cause a redirection to the 'user/index.html' page. -All other exception types are handled by 'error/default'. - - -Exceptions can be raised in a template using the THROW directive, - - [% THROW user.login 'no user id: please login' %] - -or by calling the throw() method on the current Template::Context object, - - $context->throw('user.passwd', 'Incorrect Password'); - $context->throw('Incorrect Password'); # type 'undef' - -or from Perl code by calling die() with a Template::Exception object, - - die (Template::Exception->new('user.denied', 'Invalid User ID')); - -or by simply calling die() with an error string. This is -automagically caught and converted to an exception of 'undef' -type which can then be handled in the usual way. - - die "I'm sorry Dave, I can't do that"; - - - - - - - -=item AUTO_RESET - -The AUTO_RESET option is set by default and causes the local BLOCKS -cache for the Template::Context object to be reset on each call to the -Template process() method. This ensures that any BLOCKs defined -within a template will only persist until that template is finished -processing. This prevents BLOCKs defined in one processing request -from interfering with other independent requests subsequently -processed by the same context object. - -The BLOCKS item may be used to specify a default set of block definitions -for the Template::Context object. Subsequent BLOCK definitions in templates -will over-ride these but they will be reinstated on each reset if AUTO_RESET -is enabled (default), or if the Template::Context reset() method is called. - - - - - - - -=item DEBUG - -The DEBUG option can be used to enable debugging messages from the -Template::Service module by setting it to include the DEBUG_SERVICE -value. - - use Template::Constants qw( :debug ); - - my $template = Template->new({ - DEBUG => DEBUG_SERVICE, - }); - - - - -=back - -=head2 process($input, \%replace) - -The process() method is called to process a template specified as the first -parameter, $input. This may be a file name, file handle (e.g. GLOB or 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 PRE_PROCESS or POST_PROCESS -templates defined, and returns the output text. An uncaught exception thrown -by the template will be handled by a relevant ERROR handler if defined. -Errors that occur in the PRE_PROCESS or POST_PROCESS templates, or those that -occur in the main input template and aren't handled, cause the method to -return undef to indicate failure. The appropriate error message can be -retrieved via the 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 Template::Context class. - -=head2 error() - -Returns the most recent error message. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.79, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template>, L<Template::Context|Template::Context> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Stash.pm b/lib/Template/Stash.pm deleted file mode 100644 index 64553fe..0000000 --- a/lib/Template/Stash.pm +++ /dev/null @@ -1,1040 +0,0 @@ -#============================================================= -*-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-2003 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Stash.pm,v 2.85 2004/01/30 17:51:01 abw Exp $ -# -#============================================================================ - -package Template::Stash; - -require 5.004; - -use strict; -use vars qw( $VERSION $DEBUG $ROOT_OPS $SCALAR_OPS $HASH_OPS $LIST_OPS ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.85 $ =~ /(\d+)\.(\d+)/); - - -#======================================================================== -# -- PACKAGE VARIABLES AND SUBS -- -#======================================================================== - -#------------------------------------------------------------------------ -# Definitions of various pseudo-methods. ROOT_OPS are merged into all -# new Template::Stash objects, and are thus default global functions. -# SCALAR_OPS are methods that can be called on a scalar, and ditto -# respectively for LIST_OPS and HASH_OPS -#------------------------------------------------------------------------ - -$ROOT_OPS = { - 'inc' => sub { local $^W = 0; my $item = shift; ++$item }, - 'dec' => sub { local $^W = 0; my $item = shift; --$item }, -# import => \&hash_import, - defined $ROOT_OPS ? %$ROOT_OPS : (), -}; - -$SCALAR_OPS = { - 'item' => sub { $_[0] }, - 'list' => sub { [ $_[0] ] }, - 'hash' => sub { { value => $_[0] } }, - 'length' => sub { length $_[0] }, - 'size' => sub { return 1 }, - 'defined' => sub { return 1 }, - 'repeat' => sub { - my ($str, $count) = @_; - $str = '' unless defined $str; - return '' unless $count; - $count ||= 1; - return $str x $count; - }, - 'search' => sub { - my ($str, $pattern) = @_; - return $str unless defined $str and defined $pattern; - return $str =~ /$pattern/; - }, - 'replace' => sub { - my ($str, $search, $replace) = @_; - $replace = '' unless defined $replace; - return $str unless defined $str and defined $search; - $str =~ s/$search/$replace/g; -# print STDERR "s [ $search ] [ $replace ] g\n"; -# eval "\$str =~ s$search$replaceg"; - return $str; - }, - 'match' => sub { - my ($str, $search) = @_; - return $str unless defined $str and defined $search; - my @matches = ($str =~ /$search/); - return @matches ? \@matches : ''; - }, - 'split' => sub { - my ($str, $split, @args) = @_; - $str = '' unless defined $str; - return [ defined $split ? split($split, $str, @args) - : split(' ', $str, @args) ]; - }, - 'chunk' => sub { - 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; - }, - - - defined $SCALAR_OPS ? %$SCALAR_OPS : (), -}; - -$HASH_OPS = { - 'item' => sub { - my ($hash, $item) = @_; - $item = '' unless defined $item; - return if $item =~ /^[_.]/; - $hash->{ $item }; - }, - 'hash' => sub { $_[0] }, - 'size' => sub { scalar keys %{$_[0]} }, - 'keys' => sub { [ keys %{ $_[0] } ] }, - 'values' => sub { [ values %{ $_[0] } ] }, - 'each' => sub { [ %{ $_[0] } ] }, - 'list' => sub { - my ($hash, $what) = @_; $what ||= ''; - return ($what eq 'keys') ? [ keys %$hash ] - : ($what eq 'values') ? [ values %$hash ] - : ($what eq 'each') ? [ %$hash ] - : [ map { { key => $_ , value => $hash->{ $_ } } } - keys %$hash ]; - }, - 'exists' => sub { exists $_[0]->{ $_[1] } }, - 'defined' => sub { defined $_[0]->{ $_[1] } }, - 'import' => \&hash_import, - 'sort' => sub { - my ($hash) = @_; - [ sort { lc $hash->{$a} cmp lc $hash->{$b} } (keys %$hash) ]; - }, - 'nsort' => sub { - my ($hash) = @_; - [ sort { $hash->{$a} <=> $hash->{$b} } (keys %$hash) ]; - }, - defined $HASH_OPS ? %$HASH_OPS : (), -}; - -$LIST_OPS = { - 'item' => sub { $_[0]->[ $_[1] || 0 ] }, - 'list' => sub { $_[0] }, - 'hash' => sub { my $list = shift; my $n = 0; - return { map { ($n++, $_) } @$list }; }, - 'push' => sub { my $list = shift; push(@$list, shift); return '' }, - 'pop' => sub { my $list = shift; pop(@$list) }, - 'unshift' => sub { my $list = shift; unshift(@$list, shift); return '' }, - 'shift' => sub { my $list = shift; shift(@$list) }, - 'max' => sub { local $^W = 0; my $list = shift; $#$list; }, - 'size' => sub { local $^W = 0; my $list = shift; $#$list + 1; }, - 'first' => sub { - my $list = shift; - return $list->[0] unless @_; - return [ @$list[0..$_[0]-1] ]; - }, - 'last' => sub { - my $list = shift; - return $list->[-1] unless @_; - return [ @$list[-$_[0]..-1] ]; - }, - 'reverse' => sub { my $list = shift; [ reverse @$list ] }, - 'grep' => sub { - my ($list, $pattern) = @_; - $pattern ||= ''; - return [ grep /$pattern/, @$list ]; - }, - 'join' => sub { - my ($list, $joint) = @_; - join(defined $joint ? $joint : ' ', - map { defined $_ ? $_ : '' } @$list) - }, - 'sort' => sub { - $^W = 0; - my ($list, $field) = @_; - return $list unless @$list > 1; # no need to sort 1 item lists - return $field # Schwartzian Transform - ? map { $_->[0] } # for case insensitivity - sort { $a->[1] cmp $b->[1] } - map { [ $_, lc(ref($_) eq 'HASH' - ? $_->{ $field } : - UNIVERSAL::can($_, $field) - ? $_->$field() : $_) ] } - @$list - : map { $_->[0] } - sort { $a->[1] cmp $b->[1] } - map { [ $_, lc $_ ] } - @$list - }, - 'nsort' => sub { - my ($list, $field) = @_; - return $list unless $#$list; # no need to sort 1 item lists - return $field # Schwartzian Transform - ? map { $_->[0] } # for case insensitivity - sort { $a->[1] <=> $b->[1] } - map { [ $_, lc(ref($_) eq 'HASH' - ? $_->{ $field } : - UNIVERSAL::can($_, $field) - ? $_->$field() : $_) ] } - @$list - : map { $_->[0] } - sort { $a->[1] <=> $b->[1] } - map { [ $_, lc $_ ] } - @$list - }, - 'unique' => sub { my %u; [ grep { ++$u{$_} == 1 } @{$_[0]} ] }, - 'merge' => sub { - my $list = shift; - return [ @$list, grep defined, map ref eq 'ARRAY' ? @$_ : undef, @_ ]; - }, - 'slice' => sub { - my ($list, $from, $to) = @_; - $from ||= 0; - $to = $#$list unless defined $to; - return [ @$list[$from..$to] ]; - }, - 'splice' => sub { - 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) ]; - } - }, - - defined $LIST_OPS ? %$LIST_OPS : (), -}; - -sub hash_import { - my ($hash, $imp) = @_; - $imp = {} unless ref $imp eq 'HASH'; - @$hash{ keys %$imp } = values %$imp; - return ''; -} - - -#------------------------------------------------------------------------ -# 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 =~ /^scalar|item$/) { - $op = $SCALAR_OPS; - } - elsif ($type eq 'hash') { - $op = $HASH_OPS; - } - elsif ($type =~ /^list|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 (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) { - $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; -} - - -#------------------------------------------------------------------------ -# 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); - return ''; -} - - -#======================================================================== -# ----- 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 = ($root eq $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 - # or if an attempt is made to access a private member, starting _ or . - return undef - unless defined($root) and defined($item) and $item !~ /^[\._]/; - - 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 - # (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 ($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. - - 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. - eval { @result = $root->$item(@$args); }; - - if ($@) { - # temporary hack - required to propogate 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 - - die $@ if ref($@) || ($@ !~ /Can't locate object method/); - - # failed to call object method, so try some fallbacks -# patch from Stephen Howard -# -- remove from here... -- - if (UNIVERSAL::isa($root, 'HASH') - && defined($value = $root->{ $item })) { - return $value unless ref $value eq 'CODE'; ## RETURN - @result = &$value(@$args); - } -# -- and replace with this... -- -# if (UNIVERSAL::isa($root, '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); -# } -# } -# -- remove from here... -- - elsif (UNIVERSAL::isa($root, 'ARRAY') - && ($value = $LIST_OPS->{ $item })) { - @result = &$value($root, @$args); - } -# -- and replace with this... -- -# elsif (UNIVERSAL::isa($root, '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 -# } -# } -# -- end -- - 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; - -# 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' || $atroot) { -# if ($item eq 'IMPORT' && UNIVERSAL::isa($value, 'HASH')) { -# # import hash entries into root hash -# @$root{ keys %$value } = values %$value; -# return ''; ## RETURN -# } - # 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 - 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; -} - - -#------------------------------------------------------------------------ -# _dump() -# -# Debug method which returns a string representing the internal state -# of the object. The method calls itself recursively to dump sub-hashes. -#------------------------------------------------------------------------ - -sub _dump { - my $self = shift; - return "[Template::Stash] " . $self->_dump_frame(2); -} - -sub _dump_frame { - my ($self, $indent) = @_; - $indent ||= 1; - my $buffer = ' '; - my $pad = $buffer x $indent; - my $text = "{\n"; - local $" = ', '; - - my ($key, $value); - - return $text . "...excessive recursion, terminating\n" - if $indent > 32; - - foreach $key (keys %$self) { - $value = $self->{ $key }; - $value = '<undef>' unless defined $value; - next if $key =~ /^\./; - if (ref($value) eq 'ARRAY') { - $value = '[ ' . join(', ', map { defined $_ ? $_ : '<undef>' } - @$value) . ' ]'; - } - elsif (ref $value eq 'HASH') { - $value = _dump_frame($value, $indent + 1); - } - - $text .= sprintf("$pad%-16s => $value\n", $key); - } - $text .= $buffer x ($indent - 1) . '}'; - return $text; -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 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 get() and 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 clone() and 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 new() constructor method creates and returns a reference to a new -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 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 0 if none. - - [% foo.bar(10).baz(20) %] - - $stash->get([ 'foo', 0, 'bar', [ 10 ], 'baz', [ 20 ] ]); - -=head2 set($variable, $value, $default) - -The 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 get() above. - - [% foo.bar = 30 %] - - $stash->set([ 'foo', 0, 'bar', 0 ], 30); - -The magical variable '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: foo = baz, wiz = waz - $stash->set('IMPORT', $stash->get('foo')); - -=head2 clone(\%params) - -The clone() method creates and returns a new Template::Stash object which -represents a localised copy of the parent stash. Variables can be -freely updated in the cloned stash and when declone() is called, the -original stash is returned with all its members intact and in the -same state as they were before clone() was called. - -For convenience, a hash of parameters may be passed into clone() which -is used to update any simple variable (i.e. those that don't contain any -namespace elements like 'foo' and 'bar' but not 'foo.bar') variables while -cloning the stash. For adding and updating complex variables, the set() -method should be used after calling 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 '_PARENT' member. - -=head2 declone() - -The declone() method returns the '_PARENT' reference and can be used to -restore the state of a stash as described above. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.85, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template>, L<Template::Context|Template::Context> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Stash/Context.pm b/lib/Template/Stash/Context.pm deleted file mode 100644 index 975dc79..0000000 --- a/lib/Template/Stash/Context.pm +++ /dev/null @@ -1,791 +0,0 @@ -#============================================================= -*-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-2001 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Context.pm,v 1.58 2004/01/13 16:21:52 abw Exp $ -# -#============================================================================ - -package Template::Stash::Context; - -require 5.004; - -use strict; -use Template::Stash; -use vars qw( $VERSION $DEBUG $ROOT_OPS $SCALAR_OPS $HASH_OPS $LIST_OPS ); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.58 $ =~ /(\d+)\.(\d+)/); - - -#======================================================================== -# -- PACKAGE VARIABLES AND SUBS -- -#======================================================================== - -#------------------------------------------------------------------------ -# copy virtual methods from those in the regular Template::Stash -#------------------------------------------------------------------------ - -$ROOT_OPS = { - %$Template::Stash::ROOT_OPS, - defined $ROOT_OPS ? %$ROOT_OPS : (), -}; - -$SCALAR_OPS = { - %$Template::Stash::SCALAR_OPS, - 'array' => sub { return [$_[0]] }, - defined $SCALAR_OPS ? %$SCALAR_OPS : (), -}; - -$LIST_OPS = { - %$Template::Stash::LIST_OPS, - 'array' => sub { return $_[0] }, - defined $LIST_OPS ? %$LIST_OPS : (), -}; - -$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, - }; - - 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 : ''; -} - - -#------------------------------------------------------------------------ -# 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 __PACKAGE__ || $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 __PACKAGE__) { -# if ($item eq 'IMPORT' && UNIVERSAL::isa($value, 'HASH')) { -# # import hash entries into root hash -# @$root{ keys %$value } = values %$value; -# return ''; ## RETURN -# } - # 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; -} - - -#------------------------------------------------------------------------ -# _dump() -# -# Debug method which returns a string representing the internal state -# of the object. The method calls itself recursively to dump sub-hashes. -#------------------------------------------------------------------------ - -sub _dump { - my $self = shift; - my $indent = shift || 1; - my $buffer = ' '; - my $pad = $buffer x $indent; - my $text = ''; - local $" = ', '; - - my ($key, $value); - - - return $text . "...excessive recursion, terminating\n" - if $indent > 32; - - foreach $key (keys %$self) { - - $value = $self->{ $key }; - $value = '<undef>' unless defined $value; - - if (ref($value) eq 'ARRAY') { - $value = "$value [@$value]"; - } - $text .= sprintf("$pad%-8s => $value\n", $key); - next if $key =~ /^\./; - if (UNIVERSAL::isa($value, 'HASH')) { - $text .= _dump($value, $indent + 1); - } - } - $text; -} - - -1; - -__END__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -1.58, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=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: diff --git a/lib/Template/Stash/XS.pm b/lib/Template/Stash/XS.pm deleted file mode 100644 index 2cfb543..0000000 --- a/lib/Template/Stash/XS.pm +++ /dev/null @@ -1,176 +0,0 @@ -#============================================================= -*-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 Template; -use Template::Stash; - -BEGIN { - require DynaLoader; - @Template::Stash::XS::ISA = qw( DynaLoader Template::Stash ); - - eval { - bootstrap Template::Stash::XS $Template::VERSION; - }; - if ($@) { - die "Couldn't load Template::Stash::XS $Template::VERSION:\n\n$@\n"; - } -} - - -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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Stash::XS - Experimetal high-speed stash written in XS - -=head1 SYNOPSIS - - use Template; - use Template::Stash::XS; - - my $stash = Template::Stash::XS->new(\%vars); - my $tt2 = Template->new({ STASH => $stash }); - -=head1 DESCRIPTION - -This module loads the XS version of Template::Stash::XS. It should -behave very much like the old one, but run about twice as fast. -See the synopsis above for usage information. - -Only a few methods (such as get and set) have been implemented in XS. -The others are inherited from Template::Stash. - -=head1 NOTE - -To always use the XS version of Stash, modify the Template/Config.pm -module near line 45: - - $STASH = 'Template::Stash::XS'; - -If you make this change, then there is no need to explicitly create -an instance of Template::Stash::XS as seen in the SYNOPSIS above. Just -use Template as normal. - -Alternatively, in your code add this line before creating a Template -object: - - $Template::Config::STASH = 'Template::Stash::XS'; - -To use the original, pure-perl version restore this line in -Template/Config.pm: - - $STASH = 'Template::Stash'; - -Or in your code: - - $Template::Config::STASH = 'Template::Stash'; - -You can elect to have this performed once for you at installation -time by answering 'y' or 'n' to the question that asks if you want -to make the XS Stash the default. - -=head1 BUGS - -Please report bugs to the Template Toolkit mailing list -templates@template-toolkit.org - -As of version 2.05 of the Template Toolkit, use of the XS Stash is -known to have 2 potentially troublesome side effects. The first -problem is that accesses to tied hashes (e.g. Apache::Session) may not -work as expected. This should be fixed in an imminent release. If -you are using tied hashes then it is suggested that you use the -regular Stash by default, or write a thin wrapper around your tied -hashes to enable the XS Stash to access items via regular method -calls. - -The second potential problem is that enabling the XS Stash causes all -the Template Toolkit modules to be installed in an architecture -dependant library, e.g. in - - /usr/lib/perl5/site_perl/5.6.0/i386-linux/Template - -instead of - - /usr/lib/perl5/site_perl/5.6.0/Template - -At the time of writing, we're not sure why this is happening but it's -likely that this is either a bug or intentional feature in the Perl -ExtUtils::MakeMaker module. As far as I know, Perl always checks the -architecture dependant directories before the architecture independant -ones. Therefore, a newer version of the Template Toolkit installed -with the XS Stash enabled should be used by Perl in preference to any -existing version using the regular stash. However, if you install a -future version of the Template Toolkit with the XS Stash disabled, you -may find that Perl continues to use the older version with XS Stash -enabled in preference. - -=head1 AUTHORS - -Andy Wardley E<lt>abw@tt2.orgE<gt> - -Doug Steinwand E<lt>dsteinwand@citysearch.comE<gt> - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - - - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=head1 SEE ALSO - -L<Template::Stash|Template::Stash> - diff --git a/lib/Template/Test.pm b/lib/Template/Test.pm deleted file mode 100644 index 9413d68..0000000 --- a/lib/Template/Test.pm +++ /dev/null @@ -1,711 +0,0 @@ -#============================================================= -*-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@kfs.org> -# -# COPYRIGHT -# Copyright (C) 1996-2000 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. -# -#---------------------------------------------------------------------------- -# -# $Id: Test.pm,v 2.69 2004/01/13 16:19:16 abw Exp $ -# -#============================================================================ - -package Template::Test; - -require 5.004; - -use strict; -use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS - $VERSION $DEBUG $EXTRA $PRESERVE $REASON $NO_FLUSH - $loaded %callsign); -use Template qw( :template ); -use Exporter; - -$VERSION = sprintf("%d.%02d", q$Revision: 2.69 $ =~ /(\d+)\.(\d+)/); -$DEBUG = 0; -@ISA = qw( Exporter ); -@EXPORT = qw( ntests ok is match flush skip_all test_expect callsign banner ); -@EXPORT_OK = ( 'assert' ); -%EXPORT_TAGS = ( all => [ @EXPORT_OK, @EXPORT ] ); -$| = 1; - -$REASON = 'not applicable on this platform'; -$NO_FLUSH = 0; -$EXTRA = 0; # any extra tests to come after test_expect() -$PRESERVE = 0 # don't mangle newlines in output/expect - unless defined $PRESERVE; - -# always set binmode on Win32 machines so that any output generated -# is true to what we expect -$Template::BINMODE = ($^O eq '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 # skipped: $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"; - } - - # 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*\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); - } - - ok($match, $match ? "$name matched expected" : "$name 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__ - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 Template::Test module defines the test_expect() and other related -subroutines which can be used to automate test scripts for the -Template Toolkit. See the numerous tests in the 't' sub-directory of -the distribution for examples of use. - -The 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 "ok/not -ok" output compatible with Test::Harness. - -The test input should be specified as a text string or a reference to -a filehandle (e.g. GLOB or IO::Handle) from which it can be read. In -particular, this allows the test input to be placed after the __END__ -marker and read via the 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 '#' is treated as a comment and is ignored. - -The second and third parameters to 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 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 Template -configuration. - - test_expect(\*DATA, undef, $replace); - -For testing the output of different Template configurations, a -reference to a list of named 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 the '-- use $name --' marker. This should immediately -follow a '-- 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 test_expect() sub counts the number of tests, and then calls ntests() -to generate the familiar "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 test_expect() by calling ok(). -These test results are cached until ntests() is called and the final -number of tests can be calculated. Then, the "1..$ntests" line is -output, along with "ok $n" / "not ok $n" lines for each of the cached -test result. Subsequent calls to 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 test_expect() is called then these -should be pre-declared by setting the $EXTRA package variable. This -value (default: 0) is added to the grand total calculated by ntests(). -The results of the additional tests are also registered by calling 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 test_expect() at all then you can call -ntests($n) to declare the number of tests and generate the test -header line. After that, simply call 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 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 '-- start --' and '-- stop --' markers. Anything before the -first '-- start --' is ignored, along with anything after the next -'-- 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 -- - - ... - -For historical reasons and general utility, the module also defines a -'callsign' subroutine which returns a hash mapping a..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()); - -A banner() subroutine is also provided which prints a simple banner -including any text passed as parameters, if $DEBUG is set. - - banner('Testing something-or-other'); - -example output: - - #------------------------------------------------------------ - # Testing something-or-other (27 tests completed) - #------------------------------------------------------------ - -The $DEBUG package variable can be set to enable debugging mode. - -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 t/texpect.pl script. It -was cleaned up to became the Template::Test module some time around -version 0.29. It underwent further cosmetic surgery for version 2.00 -but still retains some rear-end resemblances. - -=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 --- this -- that aren't supposed to be special markers. So don't do that. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.69, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<Template|Template> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Tools/tpage.pod b/lib/Template/Tools/tpage.pod deleted file mode 100644 index e2b20fa..0000000 --- a/lib/Template/Tools/tpage.pod +++ /dev/null @@ -1,76 +0,0 @@ - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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 - -See L<Template> for general information about the Perl Template -Toolkit and the template language and features. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -2.69, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=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: diff --git a/lib/Template/Tools/ttree.pod b/lib/Template/Tools/ttree.pod deleted file mode 100644 index 8984c51..0000000 --- a/lib/Template/Tools/ttree.pod +++ /dev/null @@ -1,332 +0,0 @@ - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=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. - - $ tree -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@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - -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 VERSION - -2.69, distributed as part of the -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - -=head1 SEE ALSO - -L<tpage|Template::Tools::tpage> - diff --git a/lib/Template/Tutorial.pod b/lib/Template/Tutorial.pod deleted file mode 100644 index b6c894f..0000000 --- a/lib/Template/Tutorial.pod +++ /dev/null @@ -1,109 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Tutorial -# -# DESCRIPTION -# This section includes tutorials on using the Template Toolkit. -# Subjects currently include an general overview of the Template -# Toolkit, showing users how to get quickly up to speed building web -# content, and a tutorial on generating and using data files, with -# particular reference to XML. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Tutorial - Template Toolkit Tutorials - -=head1 DESCRIPTION - -This section includes tutorials on using the Template Toolkit. Subjects -currently include an general overview of the Template Toolkit, showing -users how to get quickly up to speed building web content, and a -tutorial on generating and using data files, with particular reference -to XML. - -=over 4 - -=item L<Template::Tutorial::Web|Template::Tutorial::Web> - -Generating Web Content Using the Template Toolkit - -This tutorial provides an introduction to the Template Toolkit and a -"quick start" guide to getting up to speed. Its primarily focus is on -using the Template Toolkit to build web content and it covers 4 basic -areas: using tpage and ttree; using the Template.pm module in CGI -scripts; writing Apache/mod_perl handlers; and extending the toolkit by -writing plugins. - -=item L<Template::Tutorial::Datafile|Template::Tutorial::Datafile> - -Creating Data Output Files Using the Template Toolkit - -This tutorial gives an overview of the Template Toolkit, showing in -particular how to use it to read and write data files in various -different formats and styles. It was written by Dave Cross and first -appeared as a lead article at http://www.perl.com/ earlier in the year -(2001). - - - -=back - -=head1 AUTHOR - -Andy Wardley E<lt>abw@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Tutorial/Datafile.pod b/lib/Template/Tutorial/Datafile.pod deleted file mode 100644 index 652f79d..0000000 --- a/lib/Template/Tutorial/Datafile.pod +++ /dev/null @@ -1,461 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Tutorial::Datafile -# -# DESCRIPTION -# This tutorial gives an overview of the Template Toolkit, showing in -# particular how to use it to read and write data files in various -# different formats and styles. It was written by Dave Cross and -# first appeared as a lead article at http://www.perl.com/ earlier in -# the year (2001). -# -# AUTHOR -# Dave Cross <dave@dave.org.uk> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Tutorial::Datafile - Creating Data Output Files Using the Template Toolkit - -=head1 DESCRIPTION - -This tutorial gives an overview of the Template Toolkit, showing in -particular how to use it to read and write data files in various -different formats and styles. It was written by Dave Cross and first -appeared as a lead article at http://www.perl.com/ earlier in the year -(2001). - -=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 -togther 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 w -hich 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.13, released on 30 January 2004. - -=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: diff --git a/lib/Template/Tutorial/Web.pod b/lib/Template/Tutorial/Web.pod deleted file mode 100644 index a5ed9bb..0000000 --- a/lib/Template/Tutorial/Web.pod +++ /dev/null @@ -1,801 +0,0 @@ -#============================================================= -*-perl-*- -# -# Template::Tutorial::Web -# -# DESCRIPTION -# This tutorial provides an introduction to the Template Toolkit and -# a "quick start" guide to getting up to speed. Its primarily focus -# is on using the Template Toolkit to build web content and it covers -# 4 basic areas: using tpage and ttree; using the Template.pm module -# in CGI scripts; writing Apache/mod_perl handlers; and extending the -# toolkit by writing plugins. -# -# AUTHOR -# Andy Wardley <abw@andywardley.com> -# -# COPYRIGHT -# Copyright (C) 1996-2001 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. -# -# REVISION -# -# -#======================================================================== - - -#------------------------------------------------------------------------ -# IMPORTANT NOTE -# This documentation is generated automatically from source -# templates. Any changes you make here may be lost. -# -# The 'docsrc' documentation source bundle is available for download -# from http://www.template-toolkit.org/docs.html and contains all -# the source templates, XML files, scripts, etc., from which the -# documentation for the Template Toolkit is built. -#------------------------------------------------------------------------ - -=head1 NAME - -Template::Tutorial::Web - Generating Web Content Using the Template Toolkit - -=head1 DESCRIPTION - -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 now also distributed in HTML format (or rather, -in the form of HTML templates). See the 'docs' sub-directory of the -distribution for further information on building the HTML documentation. - -If you're already reading this as part of the HTML documentation, then -you don't need to worry about all that. You can have a seat, sit back. - back and enjoy the rest of the tutorial... - -=head1 INTRODUCTION - -The Template Toolkit is a set of Perl modules which collectively -implement a template processing system. In this context, a template -is a text document containing special markup tags called 'directives'. -A directive is an instruction for the template processor to perform -some action and substitute the result into the document in place of -the original directive. Directives include those to define or insert -a variable value, iterate through a list of values (FOREACH), declare -a conditional block (IF/UNLESS/ELSE), include and process another template -file (INCLUDE) and so on. - -In all other respects, the document is a plain text file and may -contain any other content (e.g. HTML, XML, RTF, LaTeX, etc). Directives -are inserted in the document within the special markup tags which are -'[%' and '%]' by default, but can be changed via the module -configuration options. Here's an example of an HTML document with -additional Template Toolkit directives. - - [% INCLUDE header - title = 'This is an HTML example' - %] - - <h1>Some Interesting Links</h1> - - [% webpages = [ - { url => 'http://foo.org', title => 'The Foo Organisation' } - { url => 'http://bar.org', title => 'The Bar Organisation' } - ] - %] - - Links: - <ul> - [% FOREACH link = webpages %] - <li><a href="[% link.url %]">[% link.title %]</a> - [% END %] - </ul> - - [% INCLUDE footer %] - -This example shows how the INCLUDE directive is used to load and process -separate 'header' and 'footer' template files, including the output in -the current document. These files might look like this: - -header: - - <html> - <head> - <title>[% title %]</title> - </head> - - <body bgcolor="#ffffff"> - -footer: - - <hr> - - <center> - © Copyright 2000 Me, Myself, I - </center> - - </body> - </html> - -The example also uses the FOREACH directive to iterate through the -'webpages' 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 'url' and 'title' member. The FOREACH directive -iterates through the list, aliasing 'link' to each item (hash ref). -The B<[% link.url %]> and B<[% link.title %]> directives then access -the individual values in the hash and insert them into the document. - -The following sections show other ways in which data can be defined for -use in a template. - -=head1 GENERATING STATIC PAGES - -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 -F<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 'mypage.html', you would run -the command: - - tpage mypage.html - -This will process the template file, sending the output to 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 such as '.atml' (for 'Another Template Markup -Language', perhaps?) and the regular '.html' for the output files -(assuming you're creating HTML, that is). Alternatively, you might -redirect the output to another directory. e.g. - - tpage mypage.atml > mypage.html - tpage templates/mypage.html > html/mypage.html - -The B<tpage> script is very basic and only really intended to give you -an easy way to process a template without having to write any Perl code. -A much more flexible tool is B<ttree>, described below, but for now let's -look at the output generated by processing the above example (some -whitespace removed for brevity): - - <html> - <head> - <title>This is an HTML example</title> - </head> - - <body bgcolor="#ffffff"> - - <h1>Some Interesting Links</h1> - - Links: - <ul> - <li><a href="http://foo.org">The Foo Organsiation</a> - <li><a href="http://bar.org">The Bar Organsiation</a> - </ul> - - <hr> - - <center> - © Copyright 2000 Me, Myself, I - </center> - - </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. - -The F<ttree> script, also distributed as part of the Template Toolkit, -provides a more flexible way to process template documents. The first -time you run the script, it will ask you if it should create a -configuration file, usually called '.ttreerc' in your home directory. -Answer 'y' to have it create the file. - -The F<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. - - perldoc ttree - ttree -h - -In brief, the configuration file describes the directories in which -template files are to be found (src), where the corresponding output -should be written to (dest), and any other directories (lib) that may -contain template files that you plan to INCLUDE into your source -documents. You can also specify processing options (such as 'verbose' -and 'recurse') and provide regular expression to match files that you -don't want to process (ignore, accept) or should be copied instead of -processed (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 'cfg' option, shown above. You then -add the C<-f filename> option to F<ttree> to have it read that file. - -When you run the script, it compares all the files in the 'src' directory -(including those in sub-directories if the 'recurse' option is set), with -those in the '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 'lib' directory, -but it does add it to the INCLUDE_PATH for the template processor so -that it can locate these files via an INCLUDE or PROCESS directive. -Thus, the '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 B<ttree> documentation and help summary (C<ttree -h>) -for full details. e.g. - -$HOME/.ttreerc: - pre_process = config - interpolate - post_chomp - -The 'pre_process' option allows you to specify a template file which -should be processed before each file. Unsurprisingly, there's also a -'post_process' option to add a template after each file. In the -fragment above, we have specified that the 'config' template should be -used as a prefix template. We can create this file in the '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 '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 'header' and 'footer' files from the -earlier example into your 'lib' directory, you can now start to create -web pages like the following in your 'src' directory and process them -with F<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. '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 B<ttree>, you should see output similar to the following -(assuming you have the verbose flag set). - - ttree 1.14 (Template Toolkit version 1.02a) - - 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 '+' before 'newpage.html' 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 '-' and giving a reason why the file wasn't processed. - - - newpage.html (not modified) - -It has detected a '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 F<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 bgcolor="#ffffff"> - - <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> - - <hr> - - <center> - © Copyright 2000 Me, Myself, I - </center> - - </body> - </html> - -You can add as many documents as you like to the 'src' directory and -F<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|Template> module provides a simple front-end to the Template -Toolkit for use in CGI scripts and Apache/mod_perl handlers. Simply -'use' the Template module, create an object instance with the new() -method and then call the 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 -w - - use strict; - 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 'config' file as a 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 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 -CGI object and a 'get_user_projects' sub-routine. - - #!/usr/bin/perl -w - - use strict; - 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 = 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) which 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 Apache::Template module is now available from CPAN -and provides a simple and easy to use Apache/mod_perl interface to the -Template Toolkit. It's only in it's first release (0.01) at the time -of writing and it currently only offers a fairly basic facility, but -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 Template module can be used in a similar way 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 '/user/bin' to which all requests will -be forwarded to the handler() method of the MyOrg::Apache::User -module. That module might look something like this: - - package MyOrg::Apache::User; - - use strict; - use vars qw( $VERSION ); - use Apache::Constants qw( :common ); - use Template qw( :template ); - use CGI; - - $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 'websrc_root' -value from the config file. This is then used to define an INCLUDE_PATH -for a new Template object. The URI is extracted from the request and a -CGI object is created. These are both defined as template variables. - -The name of the template file itself is taken from the PATH_INFO element -of the request. In this case, it would comprise the part of the URL -coming after '/user/bin', e.g for '/user/bin/edit', the template file -would be 'edit' located in "$websrc/src/user". The headers are sent -and the template file is processed. All output is sent directly to the -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 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 -F<tpage> or F<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 DBI plugin written by Simon -Matthews E<lt>sam@knowledgepool.comE<gt>. You can create this -template in your 'src' directory and process it using F<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 = 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 -F<Template::Plugin> module. - -Here's an example which defines some data items ('foo' and 'people') -and also an object method ('bar'). We'll call the plugin 'FooBar' for -want of a better name and create it in the 'MyOrg::Template::Plugin::FooBar' -package. We've added a 'MyOrg' to the regular 'Template::Plugin::*' package -to avoid any conflict with existing plugins. - -You can create a module stub using the Perl utlity F<h2xs>: - - h2xs -A -X -n MyOrg::Template::Plugin::FooBar - -This will create a directory structure representing the package name -along with a set of files comprising your new module. You can then -edit FooBar.pm to look something like this: - - package MyOrg::Template::Plugin::FooBar; - - use Template::Plugin; - use vars qw( $VERSION ); - use base qw( Template::Plugin ); - - $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 new() receives the class name as the first -parameter, as is usual in Perl, followed by a reference to something -called a 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 '_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, 'foo' and '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, 'dbi:mSQL:mydbname', -that we used in the earlier DBI example. - -If you used F<h2xs> to create the module stub then you'll already -have a Makefile.PL and you can incite the familiar incantation to -build and install it. Don't forget to add some tests to test.pl! - - perl Makefile.PL - make - make test - make install - -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 F<ttree> then you can add the following line to your -configuration file instead. This has the effect of add '/path/to/modules' -to the @INC array to a similar end. - -$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 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 'foo', 'bar' and '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@andywardley.comE<gt> - -L<http://www.andywardley.com/|http://www.andywardley.com/> - - - - -=head1 VERSION - -Template Toolkit version 2.13, released on 30 January 2004. - -=head1 COPYRIGHT - - Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. - Copyright (C) 1998-2002 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. - - - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: diff --git a/lib/Template/View.pm b/lib/Template/View.pm deleted file mode 100644 index 6de8d42..0000000 --- a/lib/Template/View.pm +++ /dev/null @@ -1,752 +0,0 @@ -#============================================================= -*-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 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, { }) %] -# -# REVISION -# $Id: View.pm,v 2.9 2004/01/30 18:36:11 abw Exp $ -# -#============================================================================ - -package Template::View; - -require 5.004; - -use strict; -use vars qw( $VERSION $DEBUG $AUTOLOAD @BASEARGS $MAP ); -use base qw( Template::Base ); - -$VERSION = sprintf("%d.%02d", q$Revision: 2.9 $ =~ /(\d+)\.(\d+)/); -$DEBUG = 0 unless defined $DEBUG; -@BASEARGS = qw( context ); -$MAP = { - HASH => 'hash', - ARRAY => 'list', - TEXT => 'text', - default => '', -}; - -$DEBUG = 0; - -#------------------------------------------------------------------------ -# _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 } || ''; - } - - # 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 datat 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 approriate 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 ( UNIVERSAL::isa($item, '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'; - - if ($item =~ /^[\._]/) { - 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 indcate 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@kfs.orgE<gt> - -=head1 REVISION - -$Revision: 2.9 $ - -=head1 COPYRIGHT - -Copyright (C) 2000 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|Template::Plugin>, - -=cut - - - - - diff --git a/lib/Text/Wrap.pm b/lib/Text/Wrap.pm deleted file mode 100644 index 72574f6..0000000 --- a/lib/Text/Wrap.pm +++ /dev/null @@ -1,106 +0,0 @@ -package Text::Wrap; - -require Exporter; - -@ISA = qw(Exporter); -@EXPORT = qw(wrap fill); -@EXPORT_OK = qw($columns $break $huge); - -$VERSION = 2001.09291; - -use vars qw($VERSION $columns $debug $break $huge $unexpand $tabstop - $separator); -use strict; - -BEGIN { - $columns = 76; # <= screen width - $debug = 0; - $break = '\s'; - $huge = 'wrap'; # alternatively: 'die' or 'overflow' - $unexpand = 1; - $tabstop = 8; - $separator = "\n"; -} - -use Text::Tabs qw(expand unexpand); - -sub wrap -{ - my ($ip, $xp, @t) = @_; - - local($Text::Tabs::tabstop) = $tabstop; - my $r = ""; - my $tail = pop(@t); - my $t = expand(join("", (map { /\s+\z/ ? ( $_ ) : ($_, ' ') } @t), $tail)); - my $lead = $ip; - my $ll = $columns - length(expand($ip)) - 1; - $ll = 0 if $ll < 0; - my $nll = $columns - length(expand($xp)) - 1; - my $nl = ""; - my $remainder = ""; - - use re 'taint'; - - pos($t) = 0; - while ($t !~ /\G\s*\Z/gc) { - if ($t =~ /\G([^\n]{0,$ll})($break|\z)/xmgc) { - $r .= $unexpand - ? unexpand($nl . $lead . $1) - : $nl . $lead . $1; - $remainder = $2; - } elsif ($huge eq 'wrap' && $t =~ /\G([^\n]{$ll})/gc) { - $r .= $unexpand - ? unexpand($nl . $lead . $1) - : $nl . $lead . $1; - $remainder = $separator; - } elsif ($huge eq 'overflow' && $t =~ /\G([^\n]*?)($break|\z)/xmgc) { - $r .= $unexpand - ? unexpand($nl . $lead . $1) - : $nl . $lead . $1; - $remainder = $2; - } elsif ($huge eq 'die') { - die "couldn't wrap '$t'"; - } else { - die "This shouldn't happen"; - } - - $lead = $xp; - $ll = $nll; - $nl = $separator; - } - $r .= $remainder; - - print "-----------$r---------\n" if $debug; - - print "Finish up with '$lead'\n" if $debug; - - $r .= $lead . substr($t, pos($t), length($t)-pos($t)) - if pos($t) ne length($t); - - print "-----------$r---------\n" if $debug;; - - return $r; -} - -sub fill -{ - my ($ip, $xp, @raw) = @_; - my @para; - my $pp; - - for $pp (split(/\n\s+/, join("\n",@raw))) { - $pp =~ s/\s+/ /g; - my $x = wrap($ip, $xp, $pp); - push(@para, $x); - } - - # if paragraph_indent is the same as line_indent, - # separate paragraphs with blank lines - - my $ps = ($ip eq $xp) ? "\n\n" : "\n"; - return join ($ps, @para); -} - -1; -__END__ - diff --git a/lib/URI.pm b/lib/URI.pm deleted file mode 100644 index 5114ae4..0000000 --- a/lib/URI.pm +++ /dev/null @@ -1,1019 +0,0 @@ -package URI; - -use strict; -use vars qw($VERSION); -$VERSION = "1.35"; # $Date: 2004/11/05 14:17:33 $ - -use vars qw($ABS_REMOTE_LEADING_DOTS $ABS_ALLOW_RELATIVE_SCHEME); - -my %implements; # mapping from scheme to implementor class - -# Some "official" character classes - -use vars qw($reserved $mark $unreserved $uric $scheme_re); -$reserved = q(;/?:@&=+$,[]); -$mark = q(-_.!~*'()); #'; emacs -$unreserved = "A-Za-z0-9\Q$mark\E"; -$uric = quotemeta($reserved) . $unreserved . "%"; - -$scheme_re = '[a-zA-Z][a-zA-Z0-9.+\-]*'; - -use Carp (); -use URI::Escape (); - -use overload ('""' => sub { ${$_[0]} }, - '==' => sub { overload::StrVal($_[0]) eq - overload::StrVal($_[1]) - }, - fallback => 1, - ); - -sub new -{ - my($class, $uri, $scheme) = @_; - - $uri = defined ($uri) ? "$uri" : ""; # stringify - # Get rid of potential wrapping - $uri =~ s/^<(?:URL:)?(.*)>$/$1/; # - $uri =~ s/^"(.*)"$/$1/; - $uri =~ s/^\s+//; - $uri =~ s/\s+$//; - - my $impclass; - if ($uri =~ m/^($scheme_re):/so) { - $scheme = $1; - } - else { - if (($impclass = ref($scheme))) { - $scheme = $scheme->scheme; - } - elsif ($scheme && $scheme =~ m/^($scheme_re)(?::|$)/o) { - $scheme = $1; - } - } - $impclass ||= implementor($scheme) || - do { - require URI::_foreign; - $impclass = 'URI::_foreign'; - }; - - return $impclass->_init($uri, $scheme); -} - - -sub new_abs -{ - my($class, $uri, $base) = @_; - $uri = $class->new($uri, $base); - $uri->abs($base); -} - - -sub _init -{ - my $class = shift; - my($str, $scheme) = @_; - $str =~ s/([^$uric\#])/$URI::Escape::escapes{$1}/go; - $str = "$scheme:$str" unless $str =~ /^$scheme_re:/o || - $class->_no_scheme_ok; - my $self = bless \$str, $class; - $self; -} - - -sub implementor -{ - my($scheme, $impclass) = @_; - if (!$scheme || $scheme !~ /\A$scheme_re\z/o) { - require URI::_generic; - return "URI::_generic"; - } - - $scheme = lc($scheme); - - if ($impclass) { - # Set the implementor class for a given scheme - my $old = $implements{$scheme}; - $impclass->_init_implementor($scheme); - $implements{$scheme} = $impclass; - return $old; - } - - my $ic = $implements{$scheme}; - return $ic if $ic; - - # scheme not yet known, look for internal or - # preloaded (with 'use') implementation - $ic = "URI::$scheme"; # default location - - # turn scheme into a valid perl identifier by a simple tranformation... - $ic =~ s/\+/_P/g; - $ic =~ s/\./_O/g; - $ic =~ s/\-/_/g; - - no strict 'refs'; - # check we actually have one for the scheme: - unless (@{"${ic}::ISA"}) { - # Try to load it - eval "require $ic"; - die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/; - return unless @{"${ic}::ISA"}; - } - - $ic->_init_implementor($scheme); - $implements{$scheme} = $ic; - $ic; -} - - -sub _init_implementor -{ - my($class, $scheme) = @_; - # Remember that one implementor class may actually - # serve to implement several URI schemes. -} - - -sub clone -{ - my $self = shift; - my $other = $$self; - bless \$other, ref $self; -} - - -sub _no_scheme_ok { 0 } - -sub _scheme -{ - my $self = shift; - - unless (@_) { - return unless $$self =~ /^($scheme_re):/o; - return $1; - } - - my $old; - my $new = shift; - if (defined($new) && length($new)) { - Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o; - $old = $1 if $$self =~ s/^($scheme_re)://o; - my $newself = URI->new("$new:$$self"); - $$self = $$newself; - bless $self, ref($newself); - } - else { - if ($self->_no_scheme_ok) { - $old = $1 if $$self =~ s/^($scheme_re)://o; - Carp::carp("Oops, opaque part now look like scheme") - if $^W && $$self =~ m/^$scheme_re:/o - } - else { - $old = $1 if $$self =~ m/^($scheme_re):/o; - } - } - - return $old; -} - -sub scheme -{ - my $scheme = shift->_scheme(@_); - return unless defined $scheme; - lc($scheme); -} - - -sub opaque -{ - my $self = shift; - - unless (@_) { - $$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die; - return $1; - } - - $$self =~ /^($scheme_re:)? # optional scheme - ([^\#]*) # opaque - (\#.*)? # optional fragment - $/sx or die; - - my $old_scheme = $1; - my $old_opaque = $2; - my $old_frag = $3; - - my $new_opaque = shift; - $new_opaque = "" unless defined $new_opaque; - $new_opaque =~ s/([^$uric])/$URI::Escape::escapes{$1}/go; - - $$self = defined($old_scheme) ? $old_scheme : ""; - $$self .= $new_opaque; - $$self .= $old_frag if defined $old_frag; - - $old_opaque; -} - -*path = \&opaque; # alias - - -sub fragment -{ - my $self = shift; - unless (@_) { - return unless $$self =~ /\#(.*)/s; - return $1; - } - - my $old; - $old = $1 if $$self =~ s/\#(.*)//s; - - my $new_frag = shift; - if (defined $new_frag) { - $new_frag =~ s/([^$uric])/$URI::Escape::escapes{$1}/go; - $$self .= "#$new_frag"; - } - $old; -} - - -sub as_string -{ - my $self = shift; - $$self; -} - - -sub canonical -{ - # Make sure scheme is lowercased, that we don't escape unreserved chars, - # and that we use upcase escape sequences. - - my $self = shift; - my $scheme = $self->_scheme || ""; - my $uc_scheme = $scheme =~ /[A-Z]/; - my $esc = $$self =~ /%[a-fA-F0-9]{2}/; - return $self unless $uc_scheme || $esc; - - my $other = $self->clone; - if ($uc_scheme) { - $other->_scheme(lc $scheme); - } - if ($esc) { - $$other =~ s{%([0-9a-fA-F]{2})} - { my $a = chr(hex($1)); - $a =~ /^[$unreserved]\z/o ? $a : "%\U$1" - }ge; - } - return $other; -} - -# Compare two URIs, subclasses will provide a more correct implementation -sub eq { - my($self, $other) = @_; - $self = URI->new($self, $other) unless ref $self; - $other = URI->new($other, $self) unless ref $other; - ref($self) eq ref($other) && # same class - $self->canonical->as_string eq $other->canonical->as_string; -} - -# generic-URI transformation methods -sub abs { $_[0]; } -sub rel { $_[0]; } - -# help out Storable -sub STORABLE_freeze { - my($self, $cloning) = @_; - return $$self; -} - -sub STORABLE_thaw { - my($self, $cloning, $str) = @_; - $$self = $str; -} - -1; - -__END__ - -=head1 NAME - -URI - Uniform Resource Identifiers (absolute and relative) - -=head1 SYNOPSIS - - $u1 = URI->new("http://www.perl.com"); - $u2 = URI->new("foo", "http"); - $u3 = $u2->abs($u1); - $u4 = $u3->clone; - $u5 = URI->new("HTTP://WWW.perl.com:80")->canonical; - - $str = $u->as_string; - $str = "$u"; - - $scheme = $u->scheme; - $opaque = $u->opaque; - $path = $u->path; - $frag = $u->fragment; - - $u->scheme("ftp"); - $u->host("ftp.perl.com"); - $u->path("cpan/"); - -=head1 DESCRIPTION - -This module implements the C<URI> class. Objects of this class -represent "Uniform Resource Identifier references" as specified in RFC -2396 (and updated by RFC 2732). - -A Uniform Resource Identifier is a compact string of characters that -identifies an abstract or physical resource. A Uniform Resource -Identifier can be further classified as either a Uniform Resource Locator -(URL) or a Uniform Resource Name (URN). The distinction between URL -and URN does not matter to the C<URI> class interface. A -"URI-reference" is a URI that may have additional information attached -in the form of a fragment identifier. - -An absolute URI reference consists of three parts: a I<scheme>, a -I<scheme-specific part> and a I<fragment> identifier. A subset of URI -references share a common syntax for hierarchical namespaces. For -these, the scheme-specific part is further broken down into -I<authority>, I<path> and I<query> components. These URIs can also -take the form of relative URI references, where the scheme (and -usually also the authority) component is missing, but implied by the -context of the URI reference. The three forms of URI reference -syntax are summarized as follows: - - <scheme>:<scheme-specific-part>#<fragment> - <scheme>://<authority><path>?<query>#<fragment> - <path>?<query>#<fragment> - -The components into which a URI reference can be divided depend on the -I<scheme>. The C<URI> class provides methods to get and set the -individual components. The methods available for a specific -C<URI> object depend on the scheme. - -=head1 CONSTRUCTORS - -The following methods construct new C<URI> objects: - -=over 4 - -=item $uri = URI->new( $str ) - -=item $uri = URI->new( $str, $scheme ) - -Constructs a new URI object. The string -representation of a URI is given as argument, together with an optional -scheme specification. Common URI wrappers like "" and <>, as well as -leading and trailing white space, are automatically removed from -the $str argument before it is processed further. - -The constructor determines the scheme, maps this to an appropriate -URI subclass, constructs a new object of that class and returns it. - -The $scheme argument is only used when $str is a -relative URI. It can be either a simple string that -denotes the scheme, a string containing an absolute URI reference, or -an absolute C<URI> object. If no $scheme is specified for a relative -URI $str, then $str is simply treated as a generic URI (no scheme-specific -methods available). - -The set of characters available for building URI references is -restricted (see L<URI::Escape>). Characters outside this set are -automatically escaped by the URI constructor. - -=item $uri = URI->new_abs( $str, $base_uri ) - -Constructs a new absolute URI object. The $str argument can -denote a relative or absolute URI. If relative, then it is -absolutized using $base_uri as base. The $base_uri must be an absolute -URI. - -=item $uri = URI::file->new( $filename ) - -=item $uri = URI::file->new( $filename, $os ) - -Constructs a new I<file> URI from a file name. See L<URI::file>. - -=item $uri = URI::file->new_abs( $filename ) - -=item $uri = URI::file->new_abs( $filename, $os ) - -Constructs a new absolute I<file> URI from a file name. See -L<URI::file>. - -=item $uri = URI::file->cwd - -Returns the current working directory as a I<file> URI. See -L<URI::file>. - -=item $uri->clone - -Returns a copy of the $uri. - -=back - -=head1 COMMON METHODS - -The methods described in this section are available for all C<URI> -objects. - -Methods that give access to components of a URI always return the -old value of the component. The value returned is C<undef> if the -component was not present. There is generally a difference between a -component that is empty (represented as C<"">) and a component that is -missing (represented as C<undef>). If an accessor method is given an -argument, it updates the corresponding component in addition to -returning the old value of the component. Passing an undefined -argument removes the component (if possible). The description of -each accessor method indicates whether the component is passed as -an escaped or an unescaped string. A component that can be further -divided into sub-parts are usually passed escaped, as unescaping might -change its semantics. - -The common methods available for all URI are: - -=over 4 - -=item $uri->scheme - -=item $uri->scheme( $new_scheme ) - -Sets and returns the scheme part of the $uri. If the $uri is -relative, then $uri->scheme returns C<undef>. If called with an -argument, it updates the scheme of $uri, possibly changing the -class of $uri, and returns the old scheme value. The method croaks -if the new scheme name is illegal; a scheme name must begin with a -letter and must consist of only US-ASCII letters, numbers, and a few -special marks: ".", "+", "-". This restriction effectively means -that the scheme must be passed unescaped. Passing an undefined -argument to the scheme method makes the URI relative (if possible). - -Letter case does not matter for scheme names. The string -returned by $uri->scheme is always lowercase. If you want the scheme -just as it was written in the URI in its original case, -you can use the $uri->_scheme method instead. - -=item $uri->opaque - -=item $uri->opaque( $new_opaque ) - -Sets and returns the scheme-specific part of the $uri -(everything between the scheme and the fragment) -as an escaped string. - -=item $uri->path - -=item $uri->path( $new_path ) - -Sets and returns the same value as $uri->opaque unless the URI -supports the generic syntax for hierarchical namespaces. -In that case the generic method is overridden to set and return -the part of the URI between the I<host name> and the I<fragment>. - -=item $uri->fragment - -=item $uri->fragment( $new_frag ) - -Returns the fragment identifier of a URI reference -as an escaped string. - -=item $uri->as_string - -Returns a URI object to a plain string. URI objects are -also converted to plain strings automatically by overloading. This -means that $uri objects can be used as plain strings in most Perl -constructs. - -=item $uri->canonical - -Returns a normalized version of the URI. The rules -for normalization are scheme-dependent. They usually involve -lowercasing the scheme and Internet host name components, -removing the explicit port specification if it matches the default port, -uppercasing all escape sequences, and unescaping octets that can be -better represented as plain characters. - -For efficiency reasons, if the $uri is already in normalized form, -then a reference to it is returned instead of a copy. - -=item $uri->eq( $other_uri ) - -=item URI::eq( $first_uri, $other_uri ) - -Tests whether two URI references are equal. URI references -that normalize to the same string are considered equal. The method -can also be used as a plain function which can also test two string -arguments. - -If you need to test whether two C<URI> object references denote the -same object, use the '==' operator. - -=item $uri->abs( $base_uri ) - -Returns an absolute URI reference. If $uri is already -absolute, then a reference to it is simply returned. If the $uri -is relative, then a new absolute URI is constructed by combining the -$uri and the $base_uri, and returned. - -=item $uri->rel( $base_uri ) - -Returns a relative URI reference if it is possible to -make one that denotes the same resource relative to $base_uri. -If not, then $uri is simply returned. - -=back - -=head1 GENERIC METHODS - -The following methods are available to schemes that use the -common/generic syntax for hierarchical namespaces. The descriptions of -schemes below indicate which these are. Unknown schemes are -assumed to support the generic syntax, and therefore the following -methods: - -=over 4 - -=item $uri->authority - -=item $uri->authority( $new_authority ) - -Sets and returns the escaped authority component -of the $uri. - -=item $uri->path - -=item $uri->path( $new_path ) - -Sets and returns the escaped path component of -the $uri (the part between the host name and the query or fragment). -The path can never be undefined, but it can be the empty string. - -=item $uri->path_query - -=item $uri->path_query( $new_path_query ) - -Sets and returns the escaped path and query -components as a single entity. The path and the query are -separated by a "?" character, but the query can itself contain "?". - -=item $uri->path_segments - -=item $uri->path_segments( $segment, ... ) - -Sets and returns the path. In a scalar context, it returns -the same value as $uri->path. In a list context, it returns the -unescaped path segments that make up the path. Path segments that -have parameters are returned as an anonymous array. The first element -is the unescaped path segment proper; subsequent elements are escaped -parameter strings. Such an anonymous array uses overloading so it can -be treated as a string too, but this string does not include the -parameters. - -Note that absolute paths have the empty string as their first -I<path_segment>, i.e. the I<path> C</foo/bar> have 3 -I<path_segments>; "", "foo" and "bar". - -=item $uri->query - -=item $uri->query( $new_query ) - -Sets and returns the escaped query component of -the $uri. - -=item $uri->query_form - -=item $uri->query_form( $key1 => $val1, $key2 => $val2, ... ) - -=item $uri->query_form( \@key_value_pairs ) - -=item $uri->query_form( \%hash ) - -Sets and returns query components that use the -I<application/x-www-form-urlencoded> format. Key/value pairs are -separated by "&", and the key is separated from the value by a "=" -character. - -The form can be set either by passing separate key/value pairs, or via -an array or hash reference. Passing an empty array or an empty hash -removes the query component, whereas passing no arguments at all leaves -the component unchanged. The order of keys is undefined if a hash -reference is passed. The old value is always returned as a list of -separate key/value pairs. Assigning this list to a hash is unwise as -the keys returned might repeat. - -The values passed when setting the form can be plain strings or -references to arrays of strings. Passing an array of values has the -same effect as passing the key repeatedly with one value at a time. -All the following statements have the same effect: - - $uri->query_form(foo => 1, foo => 2); - $uri->query_form(foo => [1, 2]); - $uri->query_form([ foo => 1, foo => 2 ]); - $uri->query_form([ foo => [1, 2] ]); - $uri->query_form({ foo => [1, 2] }); - -The C<URI::QueryParam> module can be loaded to add further methods to -manipulate the form of a URI. See L<URI::QueryParam> for details. - -=item $uri->query_keywords - -=item $uri->query_keywords( $keywords, ... ) - -=item $uri->query_keywords( \@keywords ) - -Sets and returns query components that use the -keywords separated by "+" format. - -The keywords can be set either by passing separate keywords directly -or by passing a reference to an array of keywords. Passing an empty -array removes the query component, whereas passing no arguments at -all leaves the component unchanged. The old value is always returned -as a list of separate words. - -=back - -=head1 SERVER METHODS - -For schemes where the I<authority> component denotes an Internet host, -the following methods are available in addition to the generic -methods. - -=over 4 - -=item $uri->userinfo - -=item $uri->userinfo( $new_userinfo ) - -Sets and returns the escaped userinfo part of the -authority component. - -For some schemes this is a user name and a password separated by -a colon. This practice is not recommended. Embedding passwords in -clear text (such as URI) has proven to be a security risk in almost -every case where it has been used. - -=item $uri->host - -=item $uri->host( $new_host ) - -Sets and returns the unescaped hostname. - -If the $new_host string ends with a colon and a number, then this -number also sets the port. - -=item $uri->port - -=item $uri->port( $new_port ) - -Sets and returns the port. The port is a simple integer -that should be greater than 0. - -If a port is not specified explicitly in the URI, then the URI scheme's default port -is returned. If you don't want the default port -substituted, then you can use the $uri->_port method instead. - -=item $uri->host_port - -=item $uri->host_port( $new_host_port ) - -Sets and returns the host and port as a single -unit. The returned value includes a port, even if it matches the -default port. The host part and the port part are separated by a -colon: ":". - -=item $uri->default_port - -Returns the default port of the URI scheme to which $uri -belongs. For I<http> this is the number 80, for I<ftp> this -is the number 21, etc. The default port for a scheme can not be -changed. - -=back - -=head1 SCHEME-SPECIFIC SUPPORT - -Scheme-specific support is provided for the following URI schemes. For C<URI> -objects that do not belong to one of these, you can only use the common and -generic methods. - -=over 4 - -=item B<data>: - -The I<data> URI scheme is specified in RFC 2397. It allows inclusion -of small data items as "immediate" data, as if it had been included -externally. - -C<URI> objects belonging to the data scheme support the common methods -and two new methods to access their scheme-specific components: -$uri->media_type and $uri->data. See L<URI::data> for details. - -=item B<file>: - -An old specification of the I<file> URI scheme is found in RFC 1738. -A new RFC 2396 based specification in not available yet, but file URI -references are in common use. - -C<URI> objects belonging to the file scheme support the common and -generic methods. In addition, they provide two methods for mapping file URIs -back to local file names; $uri->file and $uri->dir. See L<URI::file> -for details. - -=item B<ftp>: - -An old specification of the I<ftp> URI scheme is found in RFC 1738. A -new RFC 2396 based specification in not available yet, but ftp URI -references are in common use. - -C<URI> objects belonging to the ftp scheme support the common, -generic and server methods. In addition, they provide two methods for -accessing the userinfo sub-components: $uri->user and $uri->password. - -=item B<gopher>: - -The I<gopher> URI scheme is specified in -<draft-murali-url-gopher-1996-12-04> and will hopefully be available -as a RFC 2396 based specification. - -C<URI> objects belonging to the gopher scheme support the common, -generic and server methods. In addition, they support some methods for -accessing gopher-specific path components: $uri->gopher_type, -$uri->selector, $uri->search, $uri->string. - -=item B<http>: - -The I<http> URI scheme is specified in RFC 2616. -The scheme is used to reference resources hosted by HTTP servers. - -C<URI> objects belonging to the http scheme support the common, -generic and server methods. - -=item B<https>: - -The I<https> URI scheme is a Netscape invention which is commonly -implemented. The scheme is used to reference HTTP servers through SSL -connections. Its syntax is the same as http, but the default -port is different. - -=item B<ldap>: - -The I<ldap> URI scheme is specified in RFC 2255. LDAP is the -Lightweight Directory Access Protocol. An ldap URI describes an LDAP -search operation to perform to retrieve information from an LDAP -directory. - -C<URI> objects belonging to the ldap scheme support the common, -generic and server methods as well as ldap-specific methods: $uri->dn, -$uri->attributes, $uri->scope, $uri->filter, $uri->extensions. See -L<URI::ldap> for details. - -=item B<ldapi>: - -Like the I<ldap> URI scheme, but uses a UNIX domain socket. The -server methods are not supported, and the local socket path is -available as $uri->un_path. The I<ldapi> scheme is used by the -OpenLDAP package. There is no real specification for it, but it is -mentioned in various OpenLDAP manual pages. - -=item B<ldaps>: - -Like the I<ldap> URI scheme, but uses an SSL connection. This -scheme is deprecated, as the preferred way is to use the I<start_tls> -mechanism. - -=item B<mailto>: - -The I<mailto> URI scheme is specified in RFC 2368. The scheme was -originally used to designate the Internet mailing address of an -individual or service. It has (in RFC 2368) been extended to allow -setting of other mail header fields and the message body. - -C<URI> objects belonging to the mailto scheme support the common -methods and the generic query methods. In addition, they support the -following mailto-specific methods: $uri->to, $uri->headers. - -=item B<mms>: - -The I<mms> URL specification can be found at L<http://sdp.ppona.com/> -C<URI> objects belonging to the mms scheme support the common, -generic, and server methods, with the exception of userinfo and -query-related sub-components. - -=item B<news>: - -The I<news>, I<nntp> and I<snews> URI schemes are specified in -<draft-gilman-news-url-01> and will hopefully be available as an RFC -2396 based specification soon. - -C<URI> objects belonging to the news scheme support the common, -generic and server methods. In addition, they provide some methods to -access the path: $uri->group and $uri->message. - -=item B<nntp>: - -See I<news> scheme. - -=item B<pop>: - -The I<pop> URI scheme is specified in RFC 2384. The scheme is used to -reference a POP3 mailbox. - -C<URI> objects belonging to the pop scheme support the common, generic -and server methods. In addition, they provide two methods to access the -userinfo components: $uri->user and $uri->auth - -=item B<rlogin>: - -An old specification of the I<rlogin> URI scheme is found in RFC -1738. C<URI> objects belonging to the rlogin scheme support the -common, generic and server methods. - -=item B<rtsp>: - -The I<rtsp> URL specification can be found in section 3.2 of RFC 2326. -C<URI> objects belonging to the rtsp scheme support the common, -generic, and server methods, with the exception of userinfo and -query-related sub-components. - -=item B<rtspu>: - -The I<rtspu> URI scheme is used to talk to RTSP servers over UDP -instead of TCP. The syntax is the same as rtsp. - -=item B<rsync>: - -Information about rsync is available from http://rsync.samba.org. -C<URI> objects belonging to the rsync scheme support the common, -generic and server methods. In addition, they provide methods to -access the userinfo sub-components: $uri->user and $uri->password. - -=item B<sip>: - -The I<sip> URI specification is described in sections 19.1 and 25 -of RFC 3261. C<URI> objects belonging to the sip scheme support the -common, generic, and server methods with the exception of path related -sub-components. In addition, they provide two methods to get and set -I<sip> parameters: $uri->params_form and $uri->params. - -=item B<sips>: - -See I<sip> scheme. Its syntax is the same as sip, but the default -port is different. - -=item B<snews>: - -See I<news> scheme. Its syntax is the same as news, but the default -port is different. - -=item B<telnet>: - -An old specification of the I<telnet> URI scheme is found in RFC -1738. C<URI> objects belonging to the telnet scheme support the -common, generic and server methods. - -=item B<tn3270>: - -These URIs are used like I<telnet> URIs but for connections to IBM -mainframes. C<URI> objects belonging to the tn3270 scheme support the -common, generic and server methods. - -=item B<ssh>: - -Information about ssh is available at http://www.openssh.com/. -C<URI> objects belonging to the ssh scheme support the common, -generic and server methods. In addition, they provide methods to -access the userinfo sub-components: $uri->user and $uri->password. - -=item B<urn>: - -The syntax of Uniform Resource Names is specified in RFC 2141. C<URI> -objects belonging to the urn scheme provide the common methods, and also the -methods $uri->nid and $uri->nss, which return the Namespace Identifier -and the Namespace-Specific String respectively. - -The Namespace Identifier basically works like the Scheme identifier of -URIs, and further divides the URN namespace. Namespace Identifier -assignments are maintained at -<http://www.iana.org/assignments/urn-namespaces>. - -Letter case is not significant for the Namespace Identifier. It is -always returned in lower case by the $uri->nid method. The $uri->_nid -method can be used if you want it in its original case. - -=item B<urn>:B<isbn>: - -The C<urn:isbn:> namespace contains International Standard Book -Numbers (ISBNs) and is described in RFC 3187. A C<URI> object belonging -to this namespace has the following extra methods (if the -Business::ISBN module is available): $uri->isbn, -$uri->isbn_publisher_code, $uri->isbn_country_code, $uri->isbn_as_ean. - -=item B<urn>:B<oid>: - -The C<urn:oid:> namespace contains Object Identifiers (OIDs) and is -described in RFC 3061. An object identifier consists of sequences of digits -separated by dots. A C<URI> object belonging to this namespace has an -additional method called $uri->oid that can be used to get/set the oid -value. In a list context, oid numbers are returned as separate elements. - -=back - -=head1 CONFIGURATION VARIABLES - -The following configuration variables influence how the class and its -methods behave: - -=over 4 - -=item $URI::ABS_ALLOW_RELATIVE_SCHEME - -Some older parsers used to allow the scheme name to be present in the -relative URL if it was the same as the base URL scheme. RFC 2396 says -that this should be avoided, but you can enable this old behaviour by -setting the $URI::ABS_ALLOW_RELATIVE_SCHEME variable to a TRUE value. -The difference is demonstrated by the following examples: - - URI->new("http:foo")->abs("http://host/a/b") - ==> "http:foo" - - local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1; - URI->new("http:foo")->abs("http://host/a/b") - ==> "http:/host/a/foo" - - -=item $URI::ABS_REMOTE_LEADING_DOTS - -You can also have the abs() method ignore excess ".." -segments in the relative URI by setting $URI::ABS_REMOTE_LEADING_DOTS -to a TRUE value. The difference is demonstrated by the following -examples: - - URI->new("../../../foo")->abs("http://host/a/b") - ==> "http://host/../../foo" - - local $URI::ABS_REMOTE_LEADING_DOTS = 1; - URI->new("../../../foo")->abs("http://host/a/b") - ==> "http://host/foo" - -=back - -=head1 BUGS - -Using regexp variables like $1 directly as arguments to the URI methods -does not work too well with current perl implementations. I would argue -that this is actually a bug in perl. The workaround is to quote -them. Example: - - /(...)/ || die; - $u->query("$1"); - -=head1 PARSING URIs WITH REGEXP - -As an alternative to this module, the following (official) regular -expression can be used to decode a URI: - - my($scheme, $authority, $path, $query, $fragment) = - $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; - -The C<URI::Split> module provides the function uri_split() as a -readable alternative. - -=head1 SEE ALSO - -L<URI::file>, L<URI::WithBase>, L<URI::QueryParam>, L<URI::Escape>, -L<URI::Split>, L<URI::Heuristic> - -RFC 2396: "Uniform Resource Identifiers (URI): Generic Syntax", -Berners-Lee, Fielding, Masinter, August 1998. - -http://www.iana.org/assignments/uri-schemes - -http://www.iana.org/assignments/urn-namespaces - -http://www.w3.org/Addressing/ - -=head1 COPYRIGHT - -Copyright 1995-2003 Gisle Aas. - -Copyright 1995 Martijn Koster. - -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHORS / ACKNOWLEDGMENTS - -This module is based on the C<URI::URL> module, which in turn was -(distantly) based on the C<wwwurl.pl> code in the libwww-perl for -perl4 developed by Roy Fielding, as part of the Arcadia project at the -University of California, Irvine, with contributions from Brooks -Cutter. - -C<URI::URL> was developed by Gisle Aas, Tim Bunce, Roy Fielding and -Martijn Koster with input from other people on the libwww-perl mailing -list. - -C<URI> and related subclasses was developed by Gisle Aas. - -=cut diff --git a/lib/URI/Escape.pm b/lib/URI/Escape.pm deleted file mode 100644 index 5f0de55..0000000 --- a/lib/URI/Escape.pm +++ /dev/null @@ -1,218 +0,0 @@ -# -# $Id: Escape.pm,v 3.28 2004/11/05 13:58:31 gisle Exp $ -# - -package URI::Escape; -use strict; - -=head1 NAME - -URI::Escape - Escape and unescape unsafe characters - -=head1 SYNOPSIS - - use URI::Escape; - $safe = uri_escape("10% is enough\n"); - $verysafe = uri_escape("foo", "\0-\377"); - $str = uri_unescape($safe); - -=head1 DESCRIPTION - -This module provides functions to escape and unescape URI strings as -defined by RFC 2396 (and updated by RFC 2732). -A URI consists of a restricted set of characters, -denoted as C<uric> in RFC 2396. The restricted set of characters -consists of digits, letters, and a few graphic symbols chosen from -those common to most of the character encodings and input facilities -available to Internet users: - - "A" .. "Z", "a" .. "z", "0" .. "9", - ";", "/", "?", ":", "@", "&", "=", "+", "$", ",", "[", "]", # reserved - "-", "_", ".", "!", "~", "*", "'", "(", ")" - -In addition, any byte (octet) can be represented in a URI by an escape -sequence: a triplet consisting of the character "%" followed by two -hexadecimal digits. A byte can also be represented directly by a -character, using the US-ASCII character for that octet (iff the -character is part of C<uric>). - -Some of the C<uric> characters are I<reserved> for use as delimiters -or as part of certain URI components. These must be escaped if they are -to be treated as ordinary data. Read RFC 2396 for further details. - -The functions provided (and exported by default) from this module are: - -=over 4 - -=item uri_escape( $string ) - -=item uri_escape( $string, $unsafe ) - -Replaces each unsafe character in the $string with the corresponding -escape sequence and returns the result. The $string argument should -be a string of bytes. The uri_escape() function will croak if given a -characters with code above 255. Use uri_escape_utf8() if you know you -have such chars or/and want chars in the 128 .. 255 range treated as -UTF-8. - -The uri_escape() function takes an optional second argument that -overrides the set of characters that are to be escaped. The set is -specified as a string that can be used in a regular expression -character class (between [ ]). E.g.: - - "\x00-\x1f\x7f-\xff" # all control and hi-bit characters - "a-z" # all lower case characters - "^A-Za-z" # everything not a letter - -The default set of characters to be escaped is all those which are -I<not> part of the C<uric> character class shown above as well as the -reserved characters. I.e. the default is: - - "^A-Za-z0-9\-_.!~*'()" - -=item uri_escape_utf8( $string ) - -=item uri_escape_utf8( $string, $unsafe ) - -Works like uri_escape(), but will encode chars as UTF-8 before -escaping them. This makes this function able do deal with characters -with code above 255 in $string. Note that chars in the 128 .. 255 -range will be escaped differently by this function compared to what -uri_escape() would. For chars in the 0 .. 127 range there is no -difference. - -The call: - - $uri = uri_escape_utf8($string); - -will be the same as: - - use Encode qw(encode); - $uri = uri_escape(encode("UTF-8", $string)); - -but will even work for perl-5.6 for chars in the 128 .. 255 range. - -Note: Javascript has a function called escape() that produce the -sequence "%uXXXX" for chars in the 256 .. 65535 range. This function -has really nothing to do with URI escaping but some folks got confused -since it "does the right thing" in the 0 .. 255 range. Because of -this you sometimes see "URIs" with these kind of escapes. The -JavaScript encodeURI() function is similar to uri_escape_utf8(). - -=item uri_unescape($string,...) - -Returns a string with each %XX sequence replaced with the actual byte -(octet). - -This does the same as: - - $string =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; - -but does not modify the string in-place as this RE would. Using the -uri_unescape() function instead of the RE might make the code look -cleaner and is a few characters less to type. - -In a simple benchmark test I did, -calling the function (instead of the inline RE above) if a few chars -were unescaped was something like 40% slower, and something like 700% slower if none were. If -you are going to unescape a lot of times it might be a good idea to -inline the RE. - -If the uri_unescape() function is passed multiple strings, then each -one is returned unescaped. - -=back - -The module can also export the C<%escapes> hash, which contains the -mapping from all 256 bytes to the corresponding escape codes. Lookup -in this hash is faster than evaluating C<sprintf("%%%02X", ord($byte))> -each time. - -=head1 SEE ALSO - -L<URI> - - -=head1 COPYRIGHT - -Copyright 1995-2004 Gisle Aas. - -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); -use vars qw(%escapes); - -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(uri_escape uri_unescape); -@EXPORT_OK = qw(%escapes uri_escape_utf8); -$VERSION = sprintf("%d.%02d", q$Revision: 3.28 $ =~ /(\d+)\.(\d+)/); - -use Carp (); - -# Build a char->hex map -for (0..255) { - $escapes{chr($_)} = sprintf("%%%02X", $_); -} - -my %subst; # compiled patternes - -sub uri_escape -{ - my($text, $patn) = @_; - return undef unless defined $text; - if (defined $patn){ - unless (exists $subst{$patn}) { - # Because we can't compile the regex we fake it with a cached sub - (my $tmp = $patn) =~ s,/,\\/,g; - eval "\$subst{\$patn} = sub {\$_[0] =~ s/([$tmp])/\$escapes{\$1} || _fail_hi(\$1)/ge; }"; - Carp::croak("uri_escape: $@") if $@; - } - &{$subst{$patn}}($text); - } else { - # Default unsafe characters. RFC 2732 ^(uric - reserved) - $text =~ s/([^A-Za-z0-9\-_.!~*'()])/$escapes{$1} || _fail_hi($1)/ge; - } - $text; -} - -sub _fail_hi { - my $chr = shift; - Carp::croak(sprintf "Can't escape \\x{%04X}, try uri_escape_utf8() instead", ord($chr)); -} - -sub uri_escape_utf8 -{ - my $text = shift; - if ($] < 5.008) { - $text =~ s/([^\0-\x7F])/do {my $o = ord($1); sprintf("%c%c", 0xc0 | ($o >> 6), 0x80 | ($o & 0x3f)) }/ge; - } - else { - utf8::encode($text); - } - - return uri_escape($text, @_); -} - -sub uri_unescape -{ - # Note from RFC1630: "Sequences which start with a percent sign - # but are not followed by two hexadecimal characters are reserved - # for future extension" - my $str = shift; - if (@_ && wantarray) { - # not executed for the common case of a single argument - my @str = ($str, @_); # need to copy - foreach (@str) { - s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; - } - return @str; - } - $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $str; - $str; -} - -1; diff --git a/lib/URI/Heuristic.pm b/lib/URI/Heuristic.pm deleted file mode 100644 index e39c6c9..0000000 --- a/lib/URI/Heuristic.pm +++ /dev/null @@ -1,224 +0,0 @@ -package URI::Heuristic; - -# $Id: Heuristic.pm,v 4.17 2004/01/14 13:33:44 gisle Exp $ - -=head1 NAME - -URI::Heuristic - Expand URI using heuristics - -=head1 SYNOPSIS - - use URI::Heuristic qw(uf_uristr); - $u = uf_uristr("perl"); # http://www.perl.com - $u = uf_uristr("www.sol.no/sol"); # http://www.sol.no/sol - $u = uf_uristr("aas"); # http://www.aas.no - $u = uf_uristr("ftp.funet.fi"); # ftp://ftp.funet.fi - $u = uf_uristr("/etc/passwd"); # file:/etc/passwd - -=head1 DESCRIPTION - -This module provides functions that expand strings into real absolute -URIs using some built-in heuristics. Strings that already represent -absolute URIs (i.e. that start with a C<scheme:> part) are never modified -and are returned unchanged. The main use of these functions is to -allow abbreviated URIs similar to what many web browsers allow for URIs -typed in by the user. - -The following functions are provided: - -=over 4 - -=item uf_uristr($str) - -Tries to make the argument string -into a proper absolute URI string. The "uf_" prefix stands for "User -Friendly". Under MacOS, it assumes that any string with a common URL -scheme (http, ftp, etc.) is a URL rather than a local path. So don't name -your volumes after common URL schemes and expect uf_uristr() to construct -valid file: URL's on those volumes for you, because it won't. - -=item uf_uri($str) - -Works the same way as uf_uristr() but -returns a C<URI> object. - -=back - -=head1 ENVIRONMENT - -If the hostname portion of a URI does not contain any dots, then -certain qualified guesses are made. These guesses are governed by -the following two environment variables: - -=over 10 - -=item COUNTRY - -The two-letter country code (ISO 3166) for your location. If -the domain name of your host ends with two letters, then it is taken -to be the default country. See also L<Locale::Country>. - -=item URL_GUESS_PATTERN - -Contains a space-separated list of URL patterns to try. The string -"ACME" is for some reason used as a placeholder for the host name in -the URL provided. Example: - - URL_GUESS_PATTERN="www.ACME.no www.ACME.se www.ACME.com" - export URL_GUESS_PATTERN - -Specifying URL_GUESS_PATTERN disables any guessing rules based on -country. An empty URL_GUESS_PATTERN disables any guessing that -involves host name lookups. - -=back - -=head1 COPYRIGHT - -Copyright 1997-1998, Gisle Aas - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut - -use strict; - -use vars qw(@EXPORT_OK $VERSION $MY_COUNTRY %LOCAL_GUESSING $DEBUG); - -require Exporter; -*import = \&Exporter::import; -@EXPORT_OK = qw(uf_uri uf_uristr uf_url uf_urlstr); -$VERSION = sprintf("%d.%02d", q$Revision: 4.17 $ =~ /(\d+)\.(\d+)/); - -sub MY_COUNTRY() { - for ($MY_COUNTRY) { - return $_ if defined; - - # First try the environment. - $_ = $ENV{COUNTRY}; - return $_ if defined; - - # Could use LANG, LC_ALL, etc at this point, but probably too - # much of a wild guess. (Catalan != Canada, etc.) - # - - # Last bit of domain name. This may access the network. - require Net::Domain; - my $fqdn = Net::Domain::hostfqdn(); - $_ = lc($1) if $fqdn =~ /\.([a-zA-Z]{2})$/; - return $_ if defined; - - # Give up. Defined but false. - return ($_ = 0); - } -} - -%LOCAL_GUESSING = -( - 'us' => [qw(www.ACME.gov www.ACME.mil)], - 'uk' => [qw(www.ACME.co.uk www.ACME.org.uk www.ACME.ac.uk)], - 'au' => [qw(www.ACME.com.au www.ACME.org.au www.ACME.edu.au)], - 'il' => [qw(www.ACME.co.il www.ACME.org.il www.ACME.net.il)], - # send corrections and new entries to <gisle@aas.no> -); - - -sub uf_uristr ($) -{ - local($_) = @_; - print STDERR "uf_uristr: resolving $_\n" if $DEBUG; - return unless defined; - - s/^\s+//; - s/\s+$//; - - if (/^(www|web|home)\./) { - $_ = "http://$_"; - - } elsif (/^(ftp|gopher|news|wais|http|https)\./) { - $_ = "$1://$_"; - - } elsif ($^O ne "MacOS" && - (m,^/, || # absolute file name - m,^\.\.?/, || # relative file name - m,^[a-zA-Z]:[/\\],) # dosish file name - ) - { - $_ = "file:$_"; - - } elsif ($^O eq "MacOS" && m/:/) { - # potential MacOS file name - unless (m/^(ftp|gopher|news|wais|http|https|mailto):/) { - require URI::file; - my $a = URI::file->new($_)->as_string; - $_ = ($a =~ m/^file:/) ? $a : "file:$a"; - } - } elsif (/^\w+([\.\-]\w+)*\@(\w+\.)+\w{2,3}$/) { - $_ = "mailto:$_"; - - } elsif (!/^[a-zA-Z][a-zA-Z0-9.+\-]*:/) { # no scheme specified - if (s/^([-\w]+(?:\.[-\w]+)*)([\/:\?\#]|$)/$2/) { - my $host = $1; - - if ($host !~ /\./ && $host ne "localhost") { - my @guess; - if (exists $ENV{URL_GUESS_PATTERN}) { - @guess = map { s/\bACME\b/$host/; $_ } - split(' ', $ENV{URL_GUESS_PATTERN}); - } else { - if (MY_COUNTRY()) { - my $special = $LOCAL_GUESSING{MY_COUNTRY()}; - if ($special) { - my @special = @$special; - push(@guess, map { s/\bACME\b/$host/; $_ } - @special); - } else { - push(@guess, 'www.$host.' . MY_COUNTRY()); - } - } - push(@guess, map "www.$host.$_", - "com", "org", "net", "edu", "int"); - } - - - my $guess; - for $guess (@guess) { - print STDERR "uf_uristr: gethostbyname('$guess.')..." - if $DEBUG; - if (gethostbyname("$guess.")) { - print STDERR "yes\n" if $DEBUG; - $host = $guess; - last; - } - print STDERR "no\n" if $DEBUG; - } - } - $_ = "http://$host$_"; - - } else { - # pure junk, just return it unchanged... - - } - } - print STDERR "uf_uristr: ==> $_\n" if $DEBUG; - - $_; -} - -sub uf_uri ($) -{ - require URI; - URI->new(uf_uristr($_[0])); -} - -# legacy -*uf_urlstr = \*uf_uristr; - -sub uf_url ($) -{ - require URI::URL; - URI::URL->new(uf_uristr($_[0])); -} - -1; diff --git a/lib/URI/QueryParam.pm b/lib/URI/QueryParam.pm deleted file mode 100644 index 225ca6e..0000000 --- a/lib/URI/QueryParam.pm +++ /dev/null @@ -1,200 +0,0 @@ -package URI::QueryParam; - -use strict; - -sub URI::_query::query_param { - my $self = shift; - my @old = $self->query_form; - - if (@_ == 0) { - # get keys - my %seen; - my @keys; - for (my $i = 0; $i < @old; $i += 2) { - push(@keys, $old[$i]) unless $seen{$old[$i]}++; - } - return @keys; - } - - my $key = shift; - my @i; - - for (my $i = 0; $i < @old; $i += 2) { - push(@i, $i) if $old[$i] eq $key; - } - - if (@_) { - my @new = @old; - my @new_i = @i; - my @vals = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_; - #print "VALS:@vals [@i]\n"; - while (@new_i > @vals) { - #print "REMOVE $new_i[-1]\n"; - splice(@new, pop(@new_i), 2); - } - while (@vals > @new_i) { - my $i = @new_i ? $new_i[-1] + 2 : @new; - #print "SPLICE $i\n"; - splice(@new, $i, 0, $key => pop(@vals)); - } - for (@vals) { - #print "SET $new_i[0]\n"; - $new[shift(@new_i)+1] = $_; - } - - $self->query_form(\@new); - } - - return wantarray ? @old[map $_+1, @i] : @i ? $old[$i[0]+1] : undef; -} - -sub URI::_query::query_param_append { - my $self = shift; - my $key = shift; - $self->query_form($self->query_form, $key => \@_); # XXX - return; -} - -sub URI::_query::query_param_delete { - my $self = shift; - my $key = shift; - my @old = $self->query_form; - my @vals; - - for (my $i = @old - 2; $i >= 0; $i -= 2) { - next if $old[$i] ne $key; - push(@vals, (splice(@old, $i, 2))[1]); - } - $self->query_form(\@old) if @vals; - return wantarray ? reverse @vals : $vals[-1]; -} - -sub URI::_query::query_form_hash { - my $self = shift; - my @old = $self->query_form; - if (@_) { - $self->query_form(@_ == 1 ? %{shift(@_)} : @_); - } - my %hash; - while (my($k, $v) = splice(@old, 0, 2)) { - if (exists $hash{$k}) { - for ($hash{$k}) { - $_ = [$_] unless ref($_) eq "ARRAY"; - push(@$_, $v); - } - } - else { - $hash{$k} = $v; - } - } - return \%hash; -} - -1; - -__END__ - -=head1 NAME - -URI::QueryParam - Additional query methods for URIs - -=head1 SYNOPSIS - - use URI; - use URI::QueryParam; - - $u = URI->new("", "http"); - $u->query_param(foo => 1, 2, 3); - print $u->query; # prints foo=1&foo=2&foo=3 - - for my $key ($u->query_param) { - print "$key: ", join(", ", $u->query_param($key)), "\n"; - } - -=head1 DESCRIPTION - -Loading the C<URI::QueryParam> module adds some extra methods to -URIs that support query methods. These methods provide an alternative -interface to the $u->query_form data. - -The query_param_* methods have deliberately been made identical to the -interface of the corresponding C<CGI.pm> methods. - -The following additional methods are made available: - -=over - -=item @keys = $u->query_param - -=item @values = $u->query_param( $key ) - -=item $first_value = $u->query_param( $key ) - -=item $u->query_param( $key, $value,... ) - -If $u->query_param is called with no arguments, it returns all the -distinct parameter keys of the URI. In a scalar context it returns the -number of distinct keys. - -When a $key argument is given, the method returns the parameter values with the -given key. In a scalar context, only the first parameter value is -returned. - -If additional arguments are given, they are used to update successive -parameters with the given key. If any of the values provided are -array references, then the array is dereferenced to get the actual -values. - -=item $u->query_param_append($key, $value,...) - -Adds new parameters with the given -key without touching any old parameters with the same key. It -can be explained as a more efficient version of: - - $u->query_param($key, - $u->query_param($key), - $value,...); - -One difference is that this expression would return the old values -of $key, whereas the query_param_append() method does not. - -=item @values = $u->query_param_delete($key) - -=item $first_value = $u->query_param_delete($key) - -Deletes all key/value pairs with the given key. -The old values are returned. In a scalar context, only the first value -is returned. - -Using the query_param_delete() method is slightly more efficient than -the equivalent: - - $u->query_param($key, []); - -=item $hashref = $u->query_form_hash - -=item $u->query_form_hash( \%new_form ) - -Returns a reference to a hash that represents the -query form's key/value pairs. If a key occurs multiple times, then the hash -value becomes an array reference. - -Note that sequence information is lost. This means that: - - $u->query_form_hash($u->query_form_hash) - -is not necessarily a no-op, as it may reorder the key/value pairs. -The values returned by the query_param() method should stay the same -though. - -=back - -=head1 SEE ALSO - -L<URI>, L<CGI> - -=head1 COPYRIGHT - -Copyright 2002 Gisle Aas. - -=cut diff --git a/lib/URI/Split.pm b/lib/URI/Split.pm deleted file mode 100644 index 63bb62b..0000000 --- a/lib/URI/Split.pm +++ /dev/null @@ -1,96 +0,0 @@ -package URI::Split; - -use strict; - -use vars qw(@ISA @EXPORT_OK); -require Exporter; -@ISA = qw(Exporter); -@EXPORT_OK = qw(uri_split uri_join); - -use URI::Escape (); - -sub uri_split { - return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,; -} - -sub uri_join { - my($scheme, $auth, $path, $query, $frag) = @_; - my $uri = defined($scheme) ? "$scheme:" : ""; - $path = "" unless defined $path; - if (defined $auth) { - $auth =~ s,([/?\#]),$URI::Escape::escapes{$1},g; - $uri .= "//$auth"; - $path = "/$path" if length($path) && $path !~ m,^/,; - } - elsif ($path =~ m,^//,) { - $uri .= "//"; # XXX force empty auth - } - unless (length $uri) { - $path =~ s,(:),$URI::Escape::escapes{$1}, while $path =~ m,^[^:/?\#]+:,; - } - $path =~ s,([?\#]),$URI::Escape::escapes{$1},g; - $uri .= $path; - if (defined $query) { - $query =~ s,(\#),$URI::Escape::escapes{$1},g; - $uri .= "?$query"; - } - $uri .= "#$frag" if defined $frag; - $uri; -} - -1; - -__END__ - -=head1 NAME - -URI::Split - Parse and compose URI strings - -=head1 SYNOPSIS - - use URI::Split qw(uri_split uri_join); - ($scheme, $auth, $path, $query, $frag) = uri_split($uri); - $uri = uri_join($scheme, $auth, $path, $query, $frag); - -=head1 DESCRIPTION - -Provides functions to parse and compose URI -strings. The following functions are provided: - -=over - -=item ($scheme, $auth, $path, $query, $frag) = uri_split($uri) - -Breaks up a URI string into its component -parts. An C<undef> value is returned for those parts that are not -present. The $path part is always present (but can be the empty -string) and is thus never returned as C<undef>. - -No sensible value is returned if this function is called in a scalar -context. - -=item $uri = uri_join($scheme, $auth, $path, $query, $frag) - -Puts together a URI string from its parts. -Missing parts are signaled by passing C<undef> for the corresponding -argument. - -Minimal escaping is applied to parts that contain reserved chars -that would confuse a parser. For instance, any occurrence of '?' or '#' -in $path is always escaped, as it would otherwise be parsed back -as a query or fragment. - -=back - -=head1 SEE ALSO - -L<URI>, L<URI::Escape> - -=head1 COPYRIGHT - -Copyright 2003, Gisle Aas - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/lib/URI/URL.pm b/lib/URI/URL.pm deleted file mode 100644 index 7735448..0000000 --- a/lib/URI/URL.pm +++ /dev/null @@ -1,305 +0,0 @@ -package URI::URL; - -require URI::WithBase; -@ISA=qw(URI::WithBase); - -use strict; -use vars qw(@EXPORT $VERSION); - -$VERSION = "5.03"; - -# Provide as much as possible of the old URI::URL interface for backwards -# compatibility... - -require Exporter; -*import = \&Exporter::import; -@EXPORT = qw(url); - -# Easy to use constructor -sub url ($;$) { URI::URL->new(@_); } - -use URI::Escape qw(uri_unescape); - -sub new -{ - my $class = shift; - my $self = $class->SUPER::new(@_); - $self->[0] = $self->[0]->canonical; - $self; -} - -sub newlocal -{ - my $class = shift; - require URI::file; - bless [URI::file->new_abs(shift)], $class; -} - -{package URI::_foreign; - sub _init # hope it is not defined - { - my $class = shift; - die "Unknown URI::URL scheme $_[1]:" if $URI::URL::STRICT; - $class->SUPER::_init(@_); - } -} - -sub strict -{ - my $old = $URI::URL::STRICT; - $URI::URL::STRICT = shift if @_; - $old; -} - -sub print_on -{ - my $self = shift; - require Data::Dumper; - print STDERR Data::Dumper::Dumper($self); -} - -sub _try -{ - my $self = shift; - my $method = shift; - scalar(eval { $self->$method(@_) }); -} - -sub crack -{ - # should be overridden by subclasses - my $self = shift; - (scalar($self->scheme), - $self->_try("user"), - $self->_try("password"), - $self->_try("host"), - $self->_try("port"), - $self->_try("path"), - $self->_try("params"), - $self->_try("query"), - scalar($self->fragment), - ) -} - -sub full_path -{ - my $self = shift; - my $path = $self->path_query; - $path = "/" unless length $path; - $path; -} - -sub netloc -{ - shift->authority(@_); -} - -sub epath -{ - my $path = shift->SUPER::path(@_); - $path =~ s/;.*//; - $path; -} - -sub eparams -{ - my $self = shift; - my @p = $self->path_segments; - return unless ref($p[-1]); - @p = @{$p[-1]}; - shift @p; - join(";", @p); -} - -sub params { shift->eparams(@_); } - -sub path { - my $self = shift; - my $old = $self->epath(@_); - return unless defined wantarray; - return '/' if !defined($old) || !length($old); - Carp::croak("Path components contain '/' (you must call epath)") - if $old =~ /%2[fF]/ and !@_; - $old = "/$old" if $old !~ m|^/| && defined $self->netloc; - return uri_unescape($old); -} - -sub path_components { - shift->path_segments(@_); -} - -sub query { - my $self = shift; - my $old = $self->equery(@_); - if (defined(wantarray) && defined($old)) { - if ($old =~ /%(?:26|2[bB]|3[dD])/) { # contains escaped '=' '&' or '+' - my $mess; - for ($old) { - $mess = "Query contains both '+' and '%2B'" - if /\+/ && /%2[bB]/; - $mess = "Form query contains escaped '=' or '&'" - if /=/ && /%(?:3[dD]|26)/; - } - if ($mess) { - Carp::croak("$mess (you must call equery)"); - } - } - # Now it should be safe to unescape the string without loosing - # information - return uri_unescape($old); - } - undef; - -} - -sub abs -{ - my $self = shift; - my $base = shift; - my $allow_scheme = shift; - $allow_scheme = $URI::URL::ABS_ALLOW_RELATIVE_SCHEME - unless defined $allow_scheme; - local $URI::ABS_ALLOW_RELATIVE_SCHEME = $allow_scheme; - local $URI::ABS_REMOTE_LEADING_DOTS = $URI::URL::ABS_REMOTE_LEADING_DOTS; - $self->SUPER::abs($base); -} - -sub frag { shift->fragment(@_); } -sub keywords { shift->query_keywords(@_); } - -# file: -sub local_path { shift->file; } -sub unix_path { shift->file("unix"); } -sub dos_path { shift->file("dos"); } -sub mac_path { shift->file("mac"); } -sub vms_path { shift->file("vms"); } - -# mailto: -sub address { shift->to(@_); } -sub encoded822addr { shift->to(@_); } -sub URI::mailto::authority { shift->to(@_); } # make 'netloc' method work - -# news: -sub groupart { shift->_group(@_); } -sub article { shift->message(@_); } - -1; - -__END__ - -=head1 NAME - -URI::URL - Uniform Resource Locators - -=head1 SYNOPSIS - - $u1 = URI::URL->new($str, $base); - $u2 = $u1->abs; - -=head1 DESCRIPTION - -This module is provided for backwards compatibility with modules that -depend on the interface provided by the C<URI::URL> class that used to -be distributed with the libwww-perl library. - -The following differences exist compared to the C<URI> class interface: - -=over 3 - -=item * - -The URI::URL module exports the url() function as an alternate -constructor interface. - -=item * - -The constructor takes an optional $base argument. The C<URI::URL> -class is a subclass of C<URI::WithBase>. - -=item * - -The URI::URL->newlocal class method is the same as URI::file->new_abs. - -=item * - -URI::URL::strict(1) - -=item * - -$url->print_on method - -=item * - -$url->crack method - -=item * - -$url->full_path: same as ($uri->abs_path || "/") - -=item * - -$url->netloc: same as $uri->authority - -=item * - -$url->epath, $url->equery: same as $uri->path, $uri->query - -=item * - -$url->path and $url->query pass unescaped strings. - -=item * - -$url->path_components: same as $uri->path_segments (if you don't -consider path segment parameters) - -=item * - -$url->params and $url->eparams methods - -=item * - -$url->base method. See L<URI::WithBase>. - -=item * - -$url->abs and $url->rel have an optional $base argument. See -L<URI::WithBase>. - -=item * - -$url->frag: same as $uri->fragment - -=item * - -$url->keywords: same as $uri->query_keywords - -=item * - -$url->localpath and friends map to $uri->file. - -=item * - -$url->address and $url->encoded822addr: same as $uri->to for mailto URI - -=item * - -$url->groupart method for news URI - -=item * - -$url->article: same as $uri->message - -=back - - - -=head1 SEE ALSO - -L<URI>, L<URI::WithBase> - -=head1 COPYRIGHT - -Copyright 1998-2000 Gisle Aas. - -=cut diff --git a/lib/URI/WithBase.pm b/lib/URI/WithBase.pm deleted file mode 100644 index 0337c6b..0000000 --- a/lib/URI/WithBase.pm +++ /dev/null @@ -1,171 +0,0 @@ -package URI::WithBase; - -use strict; -use vars qw($AUTOLOAD $VERSION); -use URI; - -$VERSION = "2.19"; - -use overload '""' => "as_string", fallback => 1; - -sub as_string; # help overload find it - -sub new -{ - my($class, $uri, $base) = @_; - my $ibase = $base; - if ($base && ref($base) && UNIVERSAL::isa($base, __PACKAGE__)) { - $base = $base->abs; - $ibase = $base->[0]; - } - bless [URI->new($uri, $ibase), $base], $class; -} - -sub new_abs -{ - my $class = shift; - my $self = $class->new(@_); - $self->abs; -} - -sub _init -{ - my $class = shift; - my($str, $scheme) = @_; - bless [URI->new($str, $scheme), undef], $class; -} - -sub eq -{ - my($self, $other) = @_; - $other = $other->[0] if UNIVERSAL::isa($other, __PACKAGE__); - $self->[0]->eq($other); -} - -sub AUTOLOAD -{ - my $self = shift; - my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); - return if $method eq "DESTROY"; - $self->[0]->$method(@_); -} - -sub can { # override UNIVERSAL::can - my $self = shift; - $self->SUPER::can(@_) || ( - ref($self) - ? $self->[0]->can(@_) - : undef - ) -} - -sub base { - my $self = shift; - my $base = $self->[1]; - - if (@_) { # set - my $new_base = shift; - # ensure absoluteness - $new_base = $new_base->abs if ref($new_base) && $new_base->isa(__PACKAGE__); - $self->[1] = $new_base; - } - return unless defined wantarray; - - # The base attribute supports 'lazy' conversion from URL strings - # to URL objects. Strings may be stored but when a string is - # fetched it will automatically be converted to a URL object. - # The main benefit is to make it much cheaper to say: - # URI::WithBase->new($random_url_string, 'http:') - if (defined($base) && !ref($base)) { - $base = ref($self)->new($base); - $self->[1] = $base unless @_; - } - $base; -} - -sub clone -{ - my $self = shift; - my $base = $self->[1]; - $base = $base->clone if ref($base); - bless [$self->[0]->clone, $base], ref($self); -} - -sub abs -{ - my $self = shift; - my $base = shift || $self->base || return $self->clone; - $base = $base->as_string if ref($base); - bless [$self->[0]->abs($base, @_), $base], ref($self); -} - -sub rel -{ - my $self = shift; - my $base = shift || $self->base || return $self->clone; - $base = $base->as_string if ref($base); - bless [$self->[0]->rel($base, @_), $base], ref($self); -} - -1; - -__END__ - -=head1 NAME - -URI::WithBase - URIs which remember their base - -=head1 SYNOPSIS - - $u1 = URI::WithBase->new($str, $base); - $u2 = $u1->abs; - - $base = $u1->base; - $u1->base( $new_base ) - -=head1 DESCRIPTION - -This module provides the C<URI::WithBase> class. Objects of this class -are like C<URI> objects, but can keep their base too. The base -represents the context where this URI was found and can be used to -absolutize or relativize the URI. All the methods described in L<URI> -are supported for C<URI::WithBase> objects. - -The methods provided in addition to or modified from those of C<URI> are: - -=over 4 - -=item $uri = URI::WithBase->new($str, [$base]) - -The constructor takes an optional base URI as the second argument. -If provided, this argument initializes the base attribute. - -=item $uri->base( [$new_base] ) - -Can be used to get or set the value of the base attribute. -The return value, which is the old value, is a URI object or C<undef>. - -=item $uri->abs( [$base_uri] ) - -The $base_uri argument is now made optional as the object carries its -base with it. A new object is returned even if $uri is already -absolute (while plain URI objects simply return themselves in -that case). - -=item $uri->rel( [$base_uri] ) - -The $base_uri argument is now made optional as the object carries its -base with it. A new object is always returned. - -=back - - -=head1 SEE ALSO - -L<URI> - -=head1 COPYRIGHT - -Copyright 1998-2002 Gisle Aas. - -=cut diff --git a/lib/URI/_foreign.pm b/lib/URI/_foreign.pm deleted file mode 100644 index 075f0fd..0000000 --- a/lib/URI/_foreign.pm +++ /dev/null @@ -1,6 +0,0 @@ -package URI::_foreign; - -require URI::_generic; -@ISA=qw(URI::_generic); - -1; diff --git a/lib/URI/_generic.pm b/lib/URI/_generic.pm deleted file mode 100644 index 5aa6ca9..0000000 --- a/lib/URI/_generic.pm +++ /dev/null @@ -1,249 +0,0 @@ -package URI::_generic; -require URI; -require URI::_query; -@ISA=qw(URI URI::_query); - -use strict; -use URI::Escape qw(uri_unescape); -use Carp (); - -my $ACHAR = $URI::uric; $ACHAR =~ s,\\[/?],,g; -my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g; - -sub _no_scheme_ok { 1 } - -sub authority -{ - my $self = shift; - $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die; - - if (@_) { - my $auth = shift; - $$self = $1; - my $rest = $3; - if (defined $auth) { - $auth =~ s/([^$ACHAR])/$URI::Escape::escapes{$1}/go; - $$self .= "//$auth"; - } - _check_path($rest, $$self); - $$self .= $rest; - } - $2; -} - -sub path -{ - my $self = shift; - $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die; - - if (@_) { - $$self = $1; - my $rest = $3; - my $new_path = shift; - $new_path = "" unless defined $new_path; - $new_path =~ s/([^$PCHAR])/$URI::Escape::escapes{$1}/go; - _check_path($new_path, $$self); - $$self .= $new_path . $rest; - } - $2; -} - -sub path_query -{ - my $self = shift; - $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die; - - if (@_) { - $$self = $1; - my $rest = $3; - my $new_path = shift; - $new_path = "" unless defined $new_path; - $new_path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; - _check_path($new_path, $$self); - $$self .= $new_path . $rest; - } - $2; -} - -sub _check_path -{ - my($path, $pre) = @_; - my $prefix; - if ($pre =~ m,/,) { # authority present - $prefix = "/" if length($path) && $path !~ m,^[/?\#],; - } - else { - if ($path =~ m,^//,) { - Carp::carp("Path starting with double slash is confusing") - if $^W; - } - elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) { - Carp::carp("Path might look like scheme, './' prepended") - if $^W; - $prefix = "./"; - } - } - substr($_[0], 0, 0) = $prefix if defined $prefix; -} - -sub path_segments -{ - my $self = shift; - my $path = $self->path; - if (@_) { - my @arg = @_; # make a copy - for (@arg) { - if (ref($_)) { - my @seg = @$_; - $seg[0] =~ s/%/%25/g; - for (@seg) { s/;/%3B/g; } - $_ = join(";", @seg); - } - else { - s/%/%25/g; s/;/%3B/g; - } - s,/,%2F,g; - } - $self->path(join("/", @arg)); - } - return $path unless wantarray; - map {/;/ ? $self->_split_segment($_) - : uri_unescape($_) } - split('/', $path, -1); -} - - -sub _split_segment -{ - my $self = shift; - require URI::_segment; - URI::_segment->new(@_); -} - - -sub abs -{ - my $self = shift; - my $base = shift || Carp::croak("Missing base argument"); - - if (my $scheme = $self->scheme) { - return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME; - $base = URI->new($base) unless ref $base; - return $self unless $scheme eq $base->scheme; - } - - $base = URI->new($base) unless ref $base; - my $abs = $self->clone; - $abs->scheme($base->scheme); - return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o; - $abs->authority($base->authority); - - my $path = $self->path; - return $abs if $path =~ m,^/,; - - if (!length($path)) { - my $abs = $base->clone; - my $query = $self->query; - $abs->query($query) if defined $query; - $abs->fragment($self->fragment); - return $abs; - } - - my $p = $base->path; - $p =~ s,[^/]+$,,; - $p .= $path; - my @p = split('/', $p, -1); - shift(@p) if @p && !length($p[0]); - my $i = 1; - while ($i < @p) { - #print "$i ", join("/", @p), " ($p[$i])\n"; - if ($p[$i-1] eq ".") { - splice(@p, $i-1, 1); - $i-- if $i > 1; - } - elsif ($p[$i] eq ".." && $p[$i-1] ne "..") { - splice(@p, $i-1, 2); - if ($i > 1) { - $i--; - push(@p, "") if $i == @p; - } - } - else { - $i++; - } - } - $p[-1] = "" if @p && $p[-1] eq "."; # trailing "/." - if ($URI::ABS_REMOTE_LEADING_DOTS) { - shift @p while @p && $p[0] =~ /^\.\.?$/; - } - $abs->path("/" . join("/", @p)); - $abs; -} - -# The oposite of $url->abs. Return a URI which is as relative as possible -sub rel { - my $self = shift; - my $base = shift || Carp::croak("Missing base argument"); - my $rel = $self->clone; - $base = URI->new($base) unless ref $base; - - #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)}; - my $scheme = $rel->scheme; - my $auth = $rel->canonical->authority; - my $path = $rel->path; - - if (!defined($scheme) && !defined($auth)) { - # it is already relative - return $rel; - } - - #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)}; - my $bscheme = $base->scheme; - my $bauth = $base->canonical->authority; - my $bpath = $base->path; - - for ($bscheme, $bauth, $auth) { - $_ = '' unless defined - } - - unless ($scheme eq $bscheme && $auth eq $bauth) { - # different location, can't make it relative - return $rel; - } - - for ($path, $bpath) { $_ = "/$_" unless m,^/,; } - - # Make it relative by eliminating scheme and authority - $rel->scheme(undef); - $rel->authority(undef); - - # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>. - # First we calculate common initial path components length ($li). - my $li = 1; - while (1) { - my $i = index($path, '/', $li); - last if $i < 0 || - $i != index($bpath, '/', $li) || - substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li); - $li=$i+1; - } - # then we nuke it from both paths - substr($path, 0,$li) = ''; - substr($bpath,0,$li) = ''; - - if ($path eq $bpath && - defined($rel->fragment) && - !defined($rel->query)) { - $rel->path(""); - } - else { - # Add one "../" for each path component left in the base path - $path = ('../' x $bpath =~ tr|/|/|) . $path; - $path = "./" if $path eq ""; - $rel->path($path); - } - - $rel; -} - -1; diff --git a/lib/URI/_ldap.pm b/lib/URI/_ldap.pm deleted file mode 100644 index 608dbd3..0000000 --- a/lib/URI/_ldap.pm +++ /dev/null @@ -1,140 +0,0 @@ -# Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package URI::_ldap; - -use strict; - -use vars qw($VERSION); -$VERSION = "1.10"; - -use URI::Escape qw(uri_unescape); - -sub _ldap_elem { - my $self = shift; - my $elem = shift; - my $query = $self->query; - my @bits = (split(/\?/,defined($query) ? $query : ""),("")x4); - my $old = $bits[$elem]; - - if (@_) { - my $new = shift; - $new =~ s/\?/%3F/g; - $bits[$elem] = $new; - $query = join("?",@bits); - $query =~ s/\?+$//; - $query = undef unless length($query); - $self->query($query); - } - - $old; -} - -sub dn { - my $old = shift->path(@_); - $old =~ s:^/::; - uri_unescape($old); -} - -sub attributes { - my $self = shift; - my $old = _ldap_elem($self,0, @_ ? join(",", map { my $tmp = $_; $tmp =~ s/,/%2C/g; $tmp } @_) : ()); - return $old unless wantarray; - map { uri_unescape($_) } split(/,/,$old); -} - -sub _scope { - my $self = shift; - my $old = _ldap_elem($self,1, @_); - return unless defined wantarray && defined $old; - uri_unescape($old); -} - -sub scope { - my $old = &_scope; - $old = "base" unless length $old; - $old; -} - -sub _filter { - my $self = shift; - my $old = _ldap_elem($self,2, @_); - return unless defined wantarray && defined $old; - uri_unescape($old); # || "(objectClass=*)"; -} - -sub filter { - my $old = &_filter; - $old = "(objectClass=*)" unless length $old; - $old; -} - -sub extensions { - my $self = shift; - my @ext; - while (@_) { - my $key = shift; - my $value = shift; - push(@ext, join("=", map { $_="" unless defined; s/,/%2C/g; $_ } $key, $value)); - } - @ext = join(",", @ext) if @ext; - my $old = _ldap_elem($self,3, @ext); - return $old unless wantarray; - map { uri_unescape($_) } map { /^([^=]+)=(.*)$/ } split(/,/,$old); -} - -sub canonical -{ - my $self = shift; - my $other = $self->_nonldap_canonical; - - # The stuff below is not as efficient as one might hope... - - $other = $other->clone if $other == $self; - - $other->dn(_normalize_dn($other->dn)); - - # Should really know about mixed case "postalAddress", etc... - $other->attributes(map lc, $other->attributes); - - # Lowecase scope, remove default - my $old_scope = $other->scope; - my $new_scope = lc($old_scope); - $new_scope = "" if $new_scope eq "base"; - $other->scope($new_scope) if $new_scope ne $old_scope; - - # Remove filter if default - my $old_filter = $other->filter; - $other->filter("") if lc($old_filter) eq "(objectclass=*)" || - lc($old_filter) eq "objectclass=*"; - - # Lowercase extensions types and deal with known extension values - my @ext = $other->extensions; - for (my $i = 0; $i < @ext; $i += 2) { - my $etype = $ext[$i] = lc($ext[$i]); - if ($etype =~ /^!?bindname$/) { - $ext[$i+1] = _normalize_dn($ext[$i+1]); - } - } - $other->extensions(@ext) if @ext; - - $other; -} - -sub _normalize_dn # RFC 2253 -{ - my $dn = shift; - - return $dn; - # The code below will fail if the "+" or "," is embedding in a quoted - # string or simply escaped... - - my @dn = split(/([+,])/, $dn); - for (@dn) { - s/^([a-zA-Z]+=)/lc($1)/e; - } - join("", @dn); -} - -1; diff --git a/lib/URI/_login.pm b/lib/URI/_login.pm deleted file mode 100644 index 4583f20..0000000 --- a/lib/URI/_login.pm +++ /dev/null @@ -1,10 +0,0 @@ -package URI::_login; - -require URI::_server; -require URI::_userpass; -@ISA = qw(URI::_server URI::_userpass); - -# Generic terminal logins. This is used as a base class for 'telnet', -# 'tn3270', and 'rlogin' URL schemes. - -1; diff --git a/lib/URI/_query.pm b/lib/URI/_query.pm deleted file mode 100644 index 9323893..0000000 --- a/lib/URI/_query.pm +++ /dev/null @@ -1,81 +0,0 @@ -package URI::_query; - -use strict; -use URI (); -use URI::Escape qw(uri_unescape); - -sub query -{ - my $self = shift; - $$self =~ m,^([^?\#]*)(?:\?([^\#]*))?(.*)$,s or die; - - if (@_) { - my $q = shift; - $$self = $1; - if (defined $q) { - $q =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; - $$self .= "?$q"; - } - $$self .= $3; - } - $2; -} - -# Handle ...?foo=bar&bar=foo type of query -sub query_form { - my $self = shift; - my $old = $self->query; - if (@_) { - # Try to set query string - my @new = @_; - if (@new == 1) { - my $n = $new[0]; - if (ref($n) eq "ARRAY") { - @new = @$n; - } - elsif (ref($n) eq "HASH") { - @new = %$n; - } - } - my @query; - while (my($key,$vals) = splice(@new, 0, 2)) { - $key = '' unless defined $key; - $key =~ s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g; - $key =~ s/ /+/g; - $vals = [ref($vals) eq "ARRAY" ? @$vals : $vals]; - for my $val (@$vals) { - $val = '' unless defined $val; - $val =~ s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g; - $val =~ s/ /+/g; - push(@query, "$key=$val"); - } - } - $self->query(@query ? join('&', @query) : undef); - } - return if !defined($old) || !length($old) || !defined(wantarray); - return unless $old =~ /=/; # not a form - map { s/\+/ /g; uri_unescape($_) } - map { /=/ ? split(/=/, $_, 2) : ($_ => '')} split(/&/, $old); -} - -# Handle ...?dog+bones type of query -sub query_keywords -{ - my $self = shift; - my $old = $self->query; - if (@_) { - # Try to set query string - my @copy = @_; - @copy = @{$copy[0]} if @copy == 1 && ref($copy[0]) eq "ARRAY"; - for (@copy) { s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g; } - $self->query(@copy ? join('+', @copy) : undef); - } - return if !defined($old) || !defined(wantarray); - return if $old =~ /=/; # not keywords, but a form - map { uri_unescape($_) } split(/\+/, $old, -1); -} - -# Some URI::URL compatibility stuff -*equery = \&query; - -1; diff --git a/lib/URI/_segment.pm b/lib/URI/_segment.pm deleted file mode 100644 index c91b696..0000000 --- a/lib/URI/_segment.pm +++ /dev/null @@ -1,20 +0,0 @@ -package URI::_segment; - -# Represents a generic path_segment so that it can be treated as -# a string too. - -use strict; -use URI::Escape qw(uri_unescape); - -use overload '""' => sub { $_[0]->[0] }, - fallback => 1; - -sub new -{ - my $class = shift; - my @segment = split(';', shift, -1); - $segment[0] = uri_unescape($segment[0]); - bless \@segment, $class; -} - -1; diff --git a/lib/URI/_server.pm b/lib/URI/_server.pm deleted file mode 100644 index 10059f0..0000000 --- a/lib/URI/_server.pm +++ /dev/null @@ -1,106 +0,0 @@ -package URI::_server; -require URI::_generic; -@ISA=qw(URI::_generic); - -use strict; -use URI::Escape qw(uri_unescape); - -sub userinfo -{ - my $self = shift; - my $old = $self->authority; - - if (@_) { - my $new = $old; - $new = "" unless defined $new; - $new =~ s/.*@//; # remove old stuff - my $ui = shift; - if (defined $ui) { - $ui =~ s/@/%40/g; # protect @ - $new = "$ui\@$new"; - } - $self->authority($new); - } - return undef if !defined($old) || $old !~ /(.*)@/; - return $1; -} - -sub host -{ - my $self = shift; - my $old = $self->authority; - if (@_) { - my $tmp = $old; - $tmp = "" unless defined $tmp; - my $ui = ($tmp =~ /(.*@)/) ? $1 : ""; - my $port = ($tmp =~ /(:\d+)$/) ? $1 : ""; - my $new = shift; - $new = "" unless defined $new; - if (length $new) { - $new =~ s/[@]/%40/g; # protect @ - $port = $1 if $new =~ s/(:\d+)$//; - } - $self->authority("$ui$new$port"); - } - return undef unless defined $old; - $old =~ s/.*@//; - $old =~ s/:\d+$//; - return uri_unescape($old); -} - -sub _port -{ - my $self = shift; - my $old = $self->authority; - if (@_) { - my $new = $old; - $new =~ s/:\d*$//; - my $port = shift; - $new .= ":$port" if defined $port; - $self->authority($new); - } - return $1 if defined($old) && $old =~ /:(\d*)$/; - return; -} - -sub port -{ - my $self = shift; - my $port = $self->_port(@_); - $port = $self->default_port if !defined($port) || $port eq ""; - $port; -} - -sub host_port -{ - my $self = shift; - my $old = $self->authority; - $self->host(shift) if @_; - return undef unless defined $old; - $old =~ s/.*@//; # zap userinfo - $old =~ s/:$//; # empty port does not could - $old .= ":" . $self->port unless $old =~ /:/; - $old; -} - - -sub default_port { undef } - -sub canonical -{ - my $self = shift; - my $other = $self->SUPER::canonical; - my $host = $other->host || ""; - my $port = $other->_port; - my $uc_host = $host =~ /[A-Z]/; - my $def_port = defined($port) && ($port eq "" || - $port == $self->default_port); - if ($uc_host || $def_port) { - $other = $other->clone if $other == $self; - $other->host(lc $host) if $uc_host; - $other->port(undef) if $def_port; - } - $other; -} - -1; diff --git a/lib/URI/_userpass.pm b/lib/URI/_userpass.pm deleted file mode 100644 index a0361ae..0000000 --- a/lib/URI/_userpass.pm +++ /dev/null @@ -1,51 +0,0 @@ -package URI::_userpass; - -use strict; -use URI::Escape qw(uri_unescape); - -sub user -{ - my $self = shift; - my $info = $self->userinfo; - if (@_) { - my $new = shift; - my $pass = defined($info) ? $info : ""; - $pass =~ s/^[^:]*//; - - if (!defined($new) && !length($pass)) { - $self->userinfo(undef); - } else { - $new = "" unless defined($new); - $new =~ s/%/%25/g; - $new =~ s/:/%3A/g; - $self->userinfo("$new$pass"); - } - } - return unless defined $info; - $info =~ s/:.*//; - uri_unescape($info); -} - -sub password -{ - my $self = shift; - my $info = $self->userinfo; - if (@_) { - my $new = shift; - my $user = defined($info) ? $info : ""; - $user =~ s/:.*//; - - if (!defined($new) && !length($user)) { - $self->userinfo(undef); - } else { - $new = "" unless defined($new); - $new =~ s/%/%25/g; - $self->userinfo("$user:$new"); - } - } - return unless defined $info; - return unless $info =~ s/^[^:]*://; - uri_unescape($info); -} - -1; diff --git a/lib/URI/data.pm b/lib/URI/data.pm deleted file mode 100644 index 3c44df1..0000000 --- a/lib/URI/data.pm +++ /dev/null @@ -1,139 +0,0 @@ -package URI::data; # RFC 2397 - -require URI; -@ISA=qw(URI); - -use strict; - -use MIME::Base64 qw(encode_base64 decode_base64); -use URI::Escape qw(uri_unescape); - -sub media_type -{ - my $self = shift; - my $opaque = $self->opaque; - $opaque =~ /^([^,]*),?/ or die; - my $old = $1; - my $base64; - $base64 = $1 if $old =~ s/(;base64)$//i; - if (@_) { - my $new = shift; - $new = "" unless defined $new; - $new =~ s/%/%25/g; - $new =~ s/,/%2C/g; - $base64 = "" unless defined $base64; - $opaque =~ s/^[^,]*,?/$new$base64,/; - $self->opaque($opaque); - } - return uri_unescape($old) if $old; # media_type can't really be "0" - "text/plain;charset=US-ASCII"; # default type -} - -sub data -{ - my $self = shift; - my($enc, $data) = split(",", $self->opaque, 2); - unless (defined $data) { - $data = ""; - $enc = "" unless defined $enc; - } - my $base64 = ($enc =~ /;base64$/i); - if (@_) { - $enc =~ s/;base64$//i if $base64; - my $new = shift; - $new = "" unless defined $new; - my $uric_count = _uric_count($new); - my $urienc_len = $uric_count + (length($new) - $uric_count) * 3; - my $base64_len = int((length($new)+2) / 3) * 4; - $base64_len += 7; # because of ";base64" marker - if ($base64_len < $urienc_len || $_[0]) { - $enc .= ";base64"; - $new = encode_base64($new, ""); - } else { - $new =~ s/%/%25/g; - } - $self->opaque("$enc,$new"); - } - return unless defined wantarray; - return $base64 ? decode_base64($data) : uri_unescape($data); -} - -# I could not find a better way to interpolate the tr/// chars from -# a variable. -my $ENC = $URI::uric; -$ENC =~ s/%//; - -eval <<EOT; die $@ if $@; -sub _uric_count -{ - \$_[0] =~ tr/$ENC//; -} -EOT - -1; - -__END__ - -=head1 NAME - -URI::data - URI that contains immediate data - -=head1 SYNOPSIS - - use URI; - - $u = URI->new("data:"); - $u->media_type("image/gif"); - $u->data(scalar(`cat camel.gif`)); - print "$u\n"; - open(XV, "|xv -") and print XV $u->data; - -=head1 DESCRIPTION - -The C<URI::data> class supports C<URI> objects belonging to the I<data> -URI scheme. The I<data> URI scheme is specified in RFC 2397. It -allows inclusion of small data items as "immediate" data, as if it had -been included externally. Examples: - - data:,Perl%20is%20good - - data:image/gif;base64,R0lGODdhIAAgAIAAAAAAAPj8+CwAAAAAI - AAgAAAClYyPqcu9AJyCjtIKc5w5xP14xgeO2tlY3nWcajmZZdeJcG - Kxrmimms1KMTa1Wg8UROx4MNUq1HrycMjHT9b6xKxaFLM6VRKzI+p - KS9XtXpcbdun6uWVxJXA8pNPkdkkxhxc21LZHFOgD2KMoQXa2KMWI - JtnE2KizVUkYJVZZ1nczBxXlFopZBtoJ2diXGdNUymmJdFMAADs= - - - -C<URI> objects belonging to the data scheme support the common methods -(described in L<URI>) and the following two scheme-specific methods: - -=over 4 - -=item $uri->media_type( [$new_media_type] ) - -Can be used to get or set the media type specified in the -URI. If no media type is specified, then the default -C<"text/plain;charset=US-ASCII"> is returned. - -=item $uri->data( [$new_data] ) - -Can be used to get or set the data contained in the URI. -The data is passed unescaped (in binary form). The decision about -whether to base64 encode the data in the URI is taken automatically, -based on the encoding that produces the shorter URI string. - -=back - -=head1 SEE ALSO - -L<URI> - -=head1 COPYRIGHT - -Copyright 1995-1998 Gisle Aas. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/lib/URI/file.pm b/lib/URI/file.pm deleted file mode 100644 index 3f3f1f6..0000000 --- a/lib/URI/file.pm +++ /dev/null @@ -1,329 +0,0 @@ -package URI::file; - -use strict; -use vars qw(@ISA $VERSION $DEFAULT_AUTHORITY %OS_CLASS); - -require URI::_generic; -@ISA = qw(URI::_generic); -$VERSION = sprintf("%d.%02d", q$Revision: 4.19 $ =~ /(\d+)\.(\d+)/); - -use URI::Escape qw(uri_unescape); - -$DEFAULT_AUTHORITY = ""; - -# Map from $^O values to implementation classes. The Unix -# class is the default. -%OS_CLASS = ( - os2 => "OS2", - mac => "Mac", - MacOS => "Mac", - MSWin32 => "Win32", - win32 => "Win32", - msdos => "FAT", - dos => "FAT", - qnx => "QNX", -); - -sub os_class -{ - my($OS) = shift || $^O; - - my $class = "URI::file::" . ($OS_CLASS{$OS} || "Unix"); - no strict 'refs'; - unless (%{"$class\::"}) { - eval "require $class"; - die $@ if $@; - } - $class; -} - -sub path { shift->path_query(@_) } -sub host { uri_unescape(shift->authority(@_)) } - -sub new -{ - my($class, $path, $os) = @_; - os_class($os)->new($path); -} - -sub new_abs -{ - my $class = shift; - my $file = $class->new(@_); - return $file->abs($class->cwd) unless $$file =~ /^file:/; - $file; -} - -sub cwd -{ - my $class = shift; - require Cwd; - my $cwd = Cwd::cwd(); - $cwd = VMS::Filespec::unixpath($cwd) if $^O eq 'VMS'; - $cwd = $class->new($cwd); - $cwd .= "/" unless substr($cwd, -1, 1) eq "/"; - $cwd; -} - -sub canonical { - my $self = shift; - my $other = $self->SUPER::canonical; - - my $scheme = $other->scheme; - my $auth = $other->authority; - return $other if !defined($scheme) && !defined($auth); # relative - - if (!defined($auth) || - $auth eq "" || - lc($auth) eq "localhost" || - (defined($DEFAULT_AUTHORITY) && lc($auth) eq lc($DEFAULT_AUTHORITY)) - ) - { - # avoid cloning if $auth already match - if ((defined($auth) || defined($DEFAULT_AUTHORITY)) && - (!defined($auth) || !defined($DEFAULT_AUTHORITY) || $auth ne $DEFAULT_AUTHORITY) - ) - { - $other = $other->clone if $self == $other; - $other->authority($DEFAULT_AUTHORITY); - } - } - - $other; -} - -sub file -{ - my($self, $os) = @_; - os_class($os)->file($self); -} - -sub dir -{ - my($self, $os) = @_; - os_class($os)->dir($self); -} - -1; - -__END__ - -=head1 NAME - -URI::file - URI that maps to local file names - -=head1 SYNOPSIS - - use URI::file; - - $u1 = URI->new("file:/foo/bar"); - $u2 = URI->new("foo/bar", "file"); - - $u3 = URI::file->new($path); - $u4 = URI::file->new("c:\\windows\\", "win32"); - - $u1->file; - $u1->file("mac"); - -=head1 DESCRIPTION - -The C<URI::file> class supports C<URI> objects belonging to the I<file> -URI scheme. This scheme allows us to map the conventional file names -found on various computer systems to the URI name space. An old -specification of the I<file> URI scheme is found in RFC 1738. Some -older background information is also in RFC 1630. There are no newer -specifications as far as I know. - -If you simply want to construct I<file> URI objects from URI strings, -use the normal C<URI> constructor. If you want to construct I<file> -URI objects from the actual file names used by various systems, then -use one of the following C<URI::file> constructors: - -=over 4 - -=item $u = URI::file->new( $filename, [$os] ) - -Maps a file name to the I<file:> URI name space, creates a URI object -and returns it. The $filename is interpreted as belonging to the -indicated operating system ($os), which defaults to the value of the -$^O variable. The $filename can be either absolute or relative, and -the corresponding type of URI object for $os is returned. - -=item $u = URI::file->new_abs( $filename, [$os] ) - -Same as URI::file->new, but makes sure that the URI returned -represents an absolute file name. If the $filename argument is -relative, then the name is resolved relative to the current directory, -i.e. this constructor is really the same as: - - URI::file->new($filename)->abs(URI::file->cwd); - -=item $u = URI::file->cwd - -Returns a I<file> URI that represents the current working directory. -See L<Cwd>. - -=back - -The following methods are supported for I<file> URI (in addition to -the common and generic methods described in L<URI>): - -=over 4 - -=item $u->file( [$os] ) - -Returns a file name. It maps from the URI name space -to the file name space of the indicated operating system. - -It might return C<undef> if the name can not be represented in the -indicated file system. - -=item $u->dir( [$os] ) - -Some systems use a different form for names of directories than for plain -files. Use this method if you know you want to use the name for -a directory. - -=back - -The C<URI::file> module can be used to map generic file names to names -suitable for the current system. As such, it can work as a nice -replacement for the C<File::Spec> module. For instance, the following -code translates the UNIX-style file name F<Foo/Bar.pm> to a name -suitable for the local system: - - $file = URI::file->new("Foo/Bar.pm", "unix")->file; - die "Can't map filename Foo/Bar.pm for $^O" unless defined $file; - open(FILE, $file) || die "Can't open '$file': $!"; - # do something with FILE - -=head1 MAPPING NOTES - -Most computer systems today have hierarchically organized file systems. -Mapping the names used in these systems to the generic URI syntax -allows us to work with relative file URIs that behave as they should -when resolved using the generic algorithm for URIs (specified in RFC -2396). Mapping a file name to the generic URI syntax involves mapping -the path separator character to "/" and encoding any reserved -characters that appear in the path segments of the file name. If -path segments consisting of the strings "." or ".." have a -different meaning than what is specified for generic URIs, then these -must be encoded as well. - -If the file system has device, volume or drive specifications as -the root of the name space, then it makes sense to map them to the -authority field of the generic URI syntax. This makes sure that -relative URIs can not be resolved "above" them, i.e. generally how -relative file names work in those systems. - -Another common use of the authority field is to encode the host on which -this file name is valid. The host name "localhost" is special and -generally has the same meaning as a missing or empty authority -field. This use is in conflict with using it as a device -specification, but can often be resolved for device specifications -having characters not legal in plain host names. - -File name to URI mapping in normally not one-to-one. There are -usually many URIs that map to any given file name. For instance, an -authority of "localhost" maps the same as a URI with a missing or empty -authority. - -Example 1: The Mac uses ":" as path separator, but not in the same way -as a generic URI. ":foo" is a relative name. "foo:bar" is an absolute -name. Also, path segments can contain the "/" character as well as the -literal "." or "..". So the mapping looks like this: - - Mac URI - ---------- ------------------- - :foo:bar <==> foo/bar - : <==> ./ - ::foo:bar <==> ../foo/bar - ::: <==> ../../ - foo:bar <==> file:/foo/bar - foo:bar: <==> file:/foo/bar/ - .. <==> %2E%2E - <undef> <== / - foo/ <== file:/foo%2F - ./foo.txt <== file:/.%2Ffoo.txt - -Note that if you want a relative URL, you *must* begin the path with a :. Any -path that begins with [^:] is treated as absolute. - -Example 2: The UNIX file system is easy to map, as it uses the same path -separator as URIs, has a single root, and segments of "." and ".." -have the same meaning. URIs that have the character "\0" or "/" as -part of any path segment can not be turned into valid UNIX file names. - - UNIX URI - ---------- ------------------ - foo/bar <==> foo/bar - /foo/bar <==> file:/foo/bar - /foo/bar <== file://localhost/foo/bar - file: ==> ./file: - <undef> <== file:/fo%00/bar - / <==> file:/ - -=cut - - -RFC 1630 - - [...] - - There is clearly a danger of confusion that a link made to a local - file should be followed by someone on a different system, with - unexpected and possibly harmful results. Therefore, the convention - is that even a "file" URL is provided with a host part. This allows - a client on another system to know that it cannot access the file - system, or perhaps to use some other local mechanism to access the - file. - - The special value "localhost" is used in the host field to indicate - that the filename should really be used on whatever host one is. - This for example allows links to be made to files which are - distribted on many machines, or to "your unix local password file" - subject of course to consistency across the users of the data. - - A void host field is equivalent to "localhost". - -=head1 CONFIGURATION VARIABLES - -The following configuration variables influence how the class and its -methods behave: - -=over - -=item %URI::file::OS_CLASS - -This hash maps OS identifiers to implementation classes. You might -want to add or modify this if you want to plug in your own file -handler class. Normally the keys should match the $^O values in use. - -If there is no mapping then the "Unix" implementation is used. - -=item $URI::file::DEFAULT_AUTHORITY - -This determine what "authority" string to include in absolute file -URIs. It defaults to "". If you prefer verbose URIs you might set it -to be "localhost". - -Setting this value to C<undef> force behaviour compatible to URI v1.31 -and earlier. In this mode host names in UNC paths and drive letters -are mapped to the authority component on Windows, while we produce -authority-less URIs on Unix. - -=back - - -=head1 SEE ALSO - -L<URI>, L<File::Spec>, L<perlport> - -=head1 COPYRIGHT - -Copyright 1995-1998,2004 Gisle Aas. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/lib/URI/file/Base.pm b/lib/URI/file/Base.pm deleted file mode 100644 index 51030c2..0000000 --- a/lib/URI/file/Base.pm +++ /dev/null @@ -1,80 +0,0 @@ -package URI::file::Base; - -use strict; -use URI::Escape qw(); - -sub new -{ - my $class = shift; - my $path = shift; - $path = "" unless defined $path; - - my($auth, $escaped_auth, $escaped_path); - - ($auth, $escaped_auth) = $class->_file_extract_authority($path); - ($path, $escaped_path) = $class->_file_extract_path($path); - - if (defined $auth) { - $auth =~ s,%,%25,g unless $escaped_auth; - $auth =~ s,([/?\#]),$URI::Escape::escapes{$1},g; - $auth = "//$auth"; - if (defined $path) { - $path = "/$path" unless substr($path, 0, 1) eq "/"; - } else { - $path = ""; - } - } else { - return undef unless defined $path; - $auth = ""; - } - - $path =~ s,([%;?]),$URI::Escape::escapes{$1},g unless $escaped_path; - $path =~ s/\#/%23/g; - - my $uri = $auth . $path; - $uri = "file:$uri" if substr($uri, 0, 1) eq "/"; - - URI->new($uri, "file"); -} - -sub _file_extract_authority -{ - my($class, $path) = @_; - return undef unless $class->_file_is_absolute($path); - return $URI::file::DEFAULT_AUTHORITY; -} - -sub _file_extract_path -{ - return undef; -} - -sub _file_is_absolute -{ - return 0; -} - -sub _file_is_localhost -{ - shift; # class - my $host = lc(shift); - return 1 if $host eq "localhost"; - eval { - require Net::Domain; - lc(Net::Domain::hostfqdn()) eq $host || - lc(Net::Domain::hostname()) eq $host; - }; -} - -sub file -{ - undef; -} - -sub dir -{ - my $self = shift; - $self->file(@_); -} - -1; diff --git a/lib/URI/file/FAT.pm b/lib/URI/file/FAT.pm deleted file mode 100644 index 328169b..0000000 --- a/lib/URI/file/FAT.pm +++ /dev/null @@ -1,23 +0,0 @@ -package URI::file::FAT; - -require URI::file::Win32; -@ISA=qw(URI::file::Win32); - -sub fix_path -{ - shift; # class - for (@_) { - # turn it into 8.3 names - my @p = map uc, split(/\./, $_, -1); - return if @p > 2; # more than 1 dot is not allowed - @p = ("") unless @p; # split bug? (returns nothing when splitting "") - $_ = substr($p[0], 0, 8); - if (@p > 1) { - my $ext = substr($p[1], 0, 3); - $_ .= ".$ext" if length $ext; - } - } - 1; # ok -} - -1; diff --git a/lib/URI/file/Mac.pm b/lib/URI/file/Mac.pm deleted file mode 100644 index 8eef34b..0000000 --- a/lib/URI/file/Mac.pm +++ /dev/null @@ -1,120 +0,0 @@ -package URI::file::Mac; - -require URI::file::Base; -@ISA=qw(URI::file::Base); - -use strict; -use URI::Escape qw(uri_unescape); - - - -sub _file_extract_path -{ - my $class = shift; - my $path = shift; - - my @pre; - if ($path =~ s/^(:+)//) { - if (length($1) == 1) { - @pre = (".") unless length($path); - } else { - @pre = ("..") x (length($1) - 1); - } - } else { #absolute - $pre[0] = ""; - } - - my $isdir = ($path =~ s/:$//); - $path =~ s,([%/;]),$URI::Escape::escapes{$1},g; - - my @path = split(/:/, $path, -1); - for (@path) { - if ($_ eq "." || $_ eq "..") { - $_ = "%2E" x length($_); - } - $_ = ".." unless length($_); - } - push (@path,"") if $isdir; - (join("/", @pre, @path), 1); -} - - -sub file -{ - my $class = shift; - my $uri = shift; - my @path; - - my $auth = $uri->authority; - if (defined $auth) { - if (lc($auth) ne "localhost" && $auth ne "") { - my $u_auth = uri_unescape($auth); - if (!$class->_file_is_localhost($u_auth)) { - # some other host (use it as volume name) - @path = ("", $auth); - # XXX or just return to make it illegal; - } - } - } - my @ps = split("/", $uri->path, -1); - shift @ps if @path; - push(@path, @ps); - - my $pre = ""; - if (!@path) { - return; # empty path; XXX return ":" instead? - } elsif ($path[0] eq "") { - # absolute - shift(@path); - if (@path == 1) { - return if $path[0] eq ""; # not root directory - push(@path, ""); # volume only, effectively append ":" - } - @ps = @path; - @path = (); - my $part; - for (@ps) { #fix up "." and "..", including interior, in relatives - next if $_ eq "."; - $part = $_ eq ".." ? "" : $_; - push(@path,$part); - } - if ($ps[-1] eq "..") { #if this happens, we need another : - push(@path,""); - } - - } else { - $pre = ":"; - @ps = @path; - @path = (); - my $part; - for (@ps) { #fix up "." and "..", including interior, in relatives - next if $_ eq "."; - $part = $_ eq ".." ? "" : $_; - push(@path,$part); - } - if ($ps[-1] eq "..") { #if this happens, we need another : - push(@path,""); - } - - } - return unless $pre || @path; - for (@path) { - s/;.*//; # get rid of parameters - #return unless length; # XXX - $_ = uri_unescape($_); - return if /\0/; - return if /:/; # Should we? - } - $pre . join(":", @path); -} - -sub dir -{ - my $class = shift; - my $path = $class->file(@_); - return unless defined $path; - $path .= ":" unless $path =~ /:$/; - $path; -} - -1; diff --git a/lib/URI/file/OS2.pm b/lib/URI/file/OS2.pm deleted file mode 100644 index ad0a78e..0000000 --- a/lib/URI/file/OS2.pm +++ /dev/null @@ -1,28 +0,0 @@ -package URI::file::OS2; - -require URI::file::Win32; -@ISA=qw(URI::file::Win32); - -# The Win32 version translates k:/foo to file://k:/foo (?!) -# We add an empty host - -sub _file_extract_authority -{ - my $class = shift; - return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC - return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too? - - if ($_[0] =~ m#^[a-zA-Z]{1,2}:#) { # allow for ab: drives - return ""; - } - return; -} - -sub file { - my $p = &URI::file::Win32::file; - return unless defined $p; - $p =~ s,\\,/,g; - $p; -} - -1; diff --git a/lib/URI/file/QNX.pm b/lib/URI/file/QNX.pm deleted file mode 100644 index 93a4983..0000000 --- a/lib/URI/file/QNX.pm +++ /dev/null @@ -1,18 +0,0 @@ -package URI::file::QNX; - -require URI::file::Unix; -@ISA=qw(URI::file::Unix); - -use strict; - -sub _file_extract_path -{ - my($class, $path) = @_; - # tidy path - $path =~ s,(.)//+,$1/,g; # ^// is correct - $path =~ s,(/\.)+/,/,g; - $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:" - $path; -} - -1; diff --git a/lib/URI/file/Unix.pm b/lib/URI/file/Unix.pm deleted file mode 100644 index 5f8aaae..0000000 --- a/lib/URI/file/Unix.pm +++ /dev/null @@ -1,55 +0,0 @@ -package URI::file::Unix; - -require URI::file::Base; -@ISA=qw(URI::file::Base); - -use strict; -use URI::Escape qw(uri_unescape); - -sub _file_extract_path -{ - my($class, $path) = @_; - - # tidy path - $path =~ s,//+,/,g; - $path =~ s,(/\.)+/,/,g; - $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:" - - return $path; -} - -sub _file_is_absolute { - my($class, $path) = @_; - return $path =~ m,^/,; -} - -sub file -{ - my $class = shift; - my $uri = shift; - my @path; - - my $auth = $uri->authority; - if (defined($auth)) { - if (lc($auth) ne "localhost" && $auth ne "") { - $auth = uri_unescape($auth); - unless ($class->_file_is_localhost($auth)) { - push(@path, "", "", $auth); - } - } - } - - my @ps = $uri->path_segments; - shift @ps if @path; - push(@path, @ps); - - for (@path) { - # Unix file/directory names are not allowed to contain '\0' or '/' - return undef if /\0/; - return undef if /\//; # should we really? - } - - return join("/", @path); -} - -1; diff --git a/lib/URI/file/Win32.pm b/lib/URI/file/Win32.pm deleted file mode 100644 index 0459386..0000000 --- a/lib/URI/file/Win32.pm +++ /dev/null @@ -1,84 +0,0 @@ -package URI::file::Win32; - -require URI::file::Base; -@ISA=qw(URI::file::Base); - -use strict; -use URI::Escape qw(uri_unescape); - -sub _file_extract_authority -{ - my $class = shift; - - return $class->SUPER::_file_extract_authority($_[0]) - if defined $URI::file::DEFAULT_AUTHORITY; - - return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC - return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too? - - if ($_[0] =~ s,^([a-zA-Z]:),,) { - my $auth = $1; - $auth .= "relative" if $_[0] !~ m,^[\\/],; - return $auth; - } - return undef; -} - -sub _file_extract_path -{ - my($class, $path) = @_; - $path =~ s,\\,/,g; - #$path =~ s,//+,/,g; - $path =~ s,(/\.)+/,/,g; - - if (defined $URI::file::DEFAULT_AUTHORITY) { - $path =~ s,^([a-zA-Z]:),/$1,; - } - - return $path; -} - -sub _file_is_absolute { - my($class, $path) = @_; - return $path =~ m,^[a-zA-Z]:, || $path =~ m,^[/\\],; -} - -sub file -{ - my $class = shift; - my $uri = shift; - my $auth = $uri->authority; - my $rel; # is filename relative to drive specified in authority - if (defined $auth) { - $auth = uri_unescape($auth); - if ($auth =~ /^([a-zA-Z])[:|](relative)?/) { - $auth = uc($1) . ":"; - $rel++ if $2; - } elsif (lc($auth) eq "localhost") { - $auth = ""; - } elsif (length $auth) { - $auth = "\\\\" . $auth; # UNC - } - } else { - $auth = ""; - } - - my @path = $uri->path_segments; - for (@path) { - return undef if /\0/; - return undef if /\//; - #return undef if /\\/; # URLs with "\" is not uncommon - } - return undef unless $class->fix_path(@path); - - my $path = join("\\", @path); - $path =~ s/^\\// if $rel; - $path = $auth . $path; - $path =~ s,^\\([a-zA-Z])[:|],\u$1:,; - - return $path; -} - -sub fix_path { 1; } - -1; diff --git a/lib/URI/ftp.pm b/lib/URI/ftp.pm deleted file mode 100644 index 89aeb07..0000000 --- a/lib/URI/ftp.pm +++ /dev/null @@ -1,45 +0,0 @@ -package URI::ftp; - -require URI::_server; -require URI::_userpass; -@ISA=qw(URI::_server URI::_userpass); - -use strict; - -sub default_port { 21 } - -sub path { shift->path_query(@_) } # XXX - -sub _user { shift->SUPER::user(@_); } -sub _password { shift->SUPER::password(@_); } - -sub user -{ - my $self = shift; - my $user = $self->_user(@_); - $user = "anonymous" unless defined $user; - $user; -} - -sub password -{ - my $self = shift; - my $pass = $self->_password(@_); - unless (defined $pass) { - my $user = $self->user; - if ($user eq 'anonymous' || $user eq 'ftp') { - # anonymous ftp login password - # If there is no ftp anonymous password specified - # then we'll just use 'anonymous@' - # We don't try to send the read e-mail address because: - # - We want to remain anonymous - # - We want to stop SPAM - # - We don't want to let ftp sites to discriminate by the user, - # host, country or ftp client being used. - $pass = 'anonymous@'; - } - } - $pass; -} - -1; diff --git a/lib/URI/gopher.pm b/lib/URI/gopher.pm deleted file mode 100644 index ae66904..0000000 --- a/lib/URI/gopher.pm +++ /dev/null @@ -1,94 +0,0 @@ -package URI::gopher; # <draft-murali-url-gopher>, Dec 4, 1996 - -require URI::_server; -@ISA=qw(URI::_server); - -use strict; -use URI::Escape qw(uri_unescape); - -# A Gopher URL follows the common internet scheme syntax as defined in -# section 4.3 of [RFC-URL-SYNTAX]: -# -# gopher://<host>[:<port>]/<gopher-path> -# -# where -# -# <gopher-path> := <gopher-type><selector> | -# <gopher-type><selector>%09<search> | -# <gopher-type><selector>%09<search>%09<gopher+_string> -# -# <gopher-type> := '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' -# '8' | '9' | '+' | 'I' | 'g' | 'T' -# -# <selector> := *pchar Refer to RFC 1808 [4] -# <search> := *pchar -# <gopher+_string> := *uchar Refer to RFC 1738 [3] -# -# If the optional port is omitted, the port defaults to 70. - -sub default_port { 70 } - -sub _gopher_type -{ - my $self = shift; - my $path = $self->path_query; - $path =~ s,^/,,; - my $gtype = $1 if $path =~ s/^(.)//s; - if (@_) { - my $new_type = shift; - if (defined($new_type)) { - Carp::croak("Bad gopher type '$new_type'") - unless length($new_type) == 1; - substr($path, 0, 0) = $new_type; - $self->path_query($path); - } else { - Carp::croak("Can't delete gopher type when selector is present") - if length($path); - $self->path_query(undef); - } - } - return $gtype; -} - -sub gopher_type -{ - my $self = shift; - my $gtype = $self->_gopher_type(@_); - $gtype = "1" unless defined $gtype; - $gtype; -} - -*gtype = \&gopher_type; # URI::URL compatibility - -sub selector { shift->_gfield(0, @_) } -sub search { shift->_gfield(1, @_) } -sub string { shift->_gfield(2, @_) } - -sub _gfield -{ - my $self = shift; - my $fno = shift; - my $path = $self->path_query; - - # not according to spec., but many popular browsers accept - # gopher URLs with a '?' before the search string. - $path =~ s/\?/\t/; - $path = uri_unescape($path); - $path =~ s,^/,,; - my $gtype = $1 if $path =~ s,^(.),,s; - my @path = split(/\t/, $path, 3); - if (@_) { - # modify - my $new = shift; - $path[$fno] = $new; - pop(@path) while @path && !defined($path[-1]); - for (@path) { $_="" unless defined } - $path = $gtype; - $path = "1" unless defined $path; - $path .= join("\t", @path); - $self->path_query($path); - } - $path[$fno]; -} - -1; diff --git a/lib/URI/http.pm b/lib/URI/http.pm deleted file mode 100644 index cb69822..0000000 --- a/lib/URI/http.pm +++ /dev/null @@ -1,25 +0,0 @@ -package URI::http; - -require URI::_server; -@ISA=qw(URI::_server); - -use strict; - -sub default_port { 80 } - -sub canonical -{ - my $self = shift; - my $other = $self->SUPER::canonical; - - my $slash_path = defined($other->authority) && - !length($other->path) && !defined($other->query); - - if ($slash_path) { - $other = $other->clone if $other == $self; - $other->path("/"); - } - $other; -} - -1; diff --git a/lib/URI/https.pm b/lib/URI/https.pm deleted file mode 100644 index c39c67b..0000000 --- a/lib/URI/https.pm +++ /dev/null @@ -1,7 +0,0 @@ -package URI::https; -require URI::http; -@ISA=qw(URI::http); - -sub default_port { 443 } - -1; diff --git a/lib/URI/ldap.pm b/lib/URI/ldap.pm deleted file mode 100644 index 8af504b..0000000 --- a/lib/URI/ldap.pm +++ /dev/null @@ -1,122 +0,0 @@ -# Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package URI::ldap; - -use strict; - -use vars qw(@ISA $VERSION); -$VERSION = "1.11"; - -require URI::_server; -require URI::_ldap; -@ISA=qw(URI::_ldap URI::_server); - -sub default_port { 389 } - -sub _nonldap_canonical { - my $self = shift; - $self->URI::_server::canonical(@_); -} - -1; - -__END__ - -=head1 NAME - -URI::ldap - LDAP Uniform Resource Locators - -=head1 SYNOPSIS - - use URI; - - $uri = URI->new("ldap:$uri_string"); - $dn = $uri->dn; - $filter = $uri->filter; - @attr = $uri->attributes; - $scope = $uri->scope; - %extn = $uri->extensions; - - $uri = URI->new("ldap:"); # start empty - $uri->host("ldap.itd.umich.edu"); - $uri->dn("o=University of Michigan,c=US"); - $uri->attributes(qw(postalAddress)); - $uri->scope('sub'); - $uri->filter('(cn=Babs Jensen)'); - print $uri->as_string,"\n"; - -=head1 DESCRIPTION - -C<URI::ldap> provides an interface to parse an LDAP URI into its -constituent parts and also to build a URI as described in -RFC 2255. - -=head1 METHODS - -C<URI::ldap> supports all the generic and server methods defined by -L<URI>, plus the following. - -Each of the following methods can be used to set or get the value in -the URI. The values are passed in unescaped form. None of these -return undefined values, but elements without a default can be empty. -If arguments are given, then a new value is set for the given part -of the URI. - -=over 4 - -=item $uri->dn( [$new_dn] ) - -Sets or gets the I<Distinguished Name> part of the URI. The DN -identifies the base object of the LDAP search. - -=item $uri->attributes( [@new_attrs] ) - -Sets or gets the list of attribute names which are -returned by the search. - -=item $uri->scope( [$new_scope] ) - -Sets or gets the scope to be used by the search. The value can be one of -C<"base">, C<"one"> or C<"sub">. If none is given in the URI then the -return value defaults to C<"base">. - -=item $uri->_scope( [$new_scope] ) - -Same as scope(), but does not default to anything. - -=item $uri->filter( [$new_filter] ) - -Sets or gets the filter to be used by the search. If none is given in -the URI then the return value defaults to C<"(objectClass=*)">. - -=item $uri->_filter( [$new_filter] ) - -Same as filter(), but does not default to anything. - -=item $uri->extensions( [$etype => $evalue,...] ) - -Sets or gets the extensions used for the search. The list passed should -be in the form etype1 => evalue1, etype2 => evalue2,... This is also -the form of list that is returned. - -=back - -=head1 SEE ALSO - -L<RFC-2255|http://www.cis.ohio-state.edu/htbin/rfc/rfc2255.html> - -=head1 AUTHOR - -Graham Barr E<lt>F<gbarr@pobox.com>E<gt> - -Slightly modified by Gisle Aas to fit into the URI distribution. - -=head1 COPYRIGHT - -Copyright (c) 1998 Graham Barr. All rights reserved. This program is -free software; you can redistribute it and/or modify it under the same -terms as Perl itself. - -=cut diff --git a/lib/URI/ldapi.pm b/lib/URI/ldapi.pm deleted file mode 100644 index d92b13f..0000000 --- a/lib/URI/ldapi.pm +++ /dev/null @@ -1,30 +0,0 @@ -package URI::ldapi; - -use strict; - -use vars qw(@ISA); - -require URI::_generic; -require URI::_ldap; -@ISA=qw(URI::_ldap URI::_generic); - -require URI::Escape; - -sub un_path { - my $self = shift; - my $old = URI::Escape::uri_unescape($self->authority); - if (@_) { - my $p = shift; - $p =~ s/:/%3A/g; - $p =~ s/\@/%40/g; - $self->authority($p); - } - return $old; -} - -sub _nonldap_canonical { - my $self = shift; - $self->URI::_generic::canonical(@_); -} - -1; diff --git a/lib/URI/ldaps.pm b/lib/URI/ldaps.pm deleted file mode 100644 index 20180d5..0000000 --- a/lib/URI/ldaps.pm +++ /dev/null @@ -1,7 +0,0 @@ -package URI::ldaps; -require URI::ldap; -@ISA=qw(URI::ldap); - -sub default_port { 636 } - -1; diff --git a/lib/URI/mailto.pm b/lib/URI/mailto.pm deleted file mode 100644 index 1408fc6..0000000 --- a/lib/URI/mailto.pm +++ /dev/null @@ -1,72 +0,0 @@ -package URI::mailto; # RFC 2368 - -require URI; -require URI::_query; -@ISA=qw(URI URI::_query); - -use strict; - -sub to -{ - my $self = shift; - my @old = $self->headers; - if (@_) { - my @new = @old; - # get rid of any other to: fields - for (my $i = 0; $i < @new; $i += 2) { - if (lc($new[$i]) eq "to") { - splice(@new, $i, 2); - redo; - } - } - - my $to = shift; - $to = "" unless defined $to; - unshift(@new, "to" => $to); - $self->headers(@new); - } - return unless defined wantarray; - - my @to; - while (@old) { - my $h = shift @old; - my $v = shift @old; - push(@to, $v) if lc($h) eq "to"; - } - join(",", @to); -} - - -sub headers -{ - my $self = shift; - - # The trick is to just treat everything as the query string... - my $opaque = "to=" . $self->opaque; - $opaque =~ s/\?/&/; - - if (@_) { - my @new = @_; - - # strip out any "to" fields - my @to; - for (my $i=0; $i < @new; $i += 2) { - if (lc($new[$i]) eq "to") { - push(@to, (splice(@new, $i, 2))[1]); # remove header - redo; - } - } - - my $new = join(",",@to); - $new =~ s/%/%25/g; - $new =~ s/\?/%3F/g; - $self->opaque($new); - $self->query_form(@new) if @new; - } - return unless defined wantarray; - - # I am lazy today... - URI->new("mailto:?$opaque")->query_form; -} - -1; diff --git a/lib/URI/mms.pm b/lib/URI/mms.pm deleted file mode 100644 index 2f1015b..0000000 --- a/lib/URI/mms.pm +++ /dev/null @@ -1,8 +0,0 @@ -package URI::mms; - -require URI::http; -@ISA=qw(URI::http); - -sub default_port { 1755 } - -1; diff --git a/lib/URI/news.pm b/lib/URI/news.pm deleted file mode 100644 index 1ffb419..0000000 --- a/lib/URI/news.pm +++ /dev/null @@ -1,68 +0,0 @@ -package URI::news; # draft-gilman-news-url-01 - -require URI::_server; -@ISA=qw(URI::_server); - -use strict; -use URI::Escape qw(uri_unescape); -use Carp (); - -sub default_port { 119 } - -# newsURL = scheme ":" [ news-server ] [ refbygroup | message ] -# scheme = "news" | "snews" | "nntp" -# news-server = "//" server "/" -# refbygroup = group [ "/" messageno [ "-" messageno ] ] -# message = local-part "@" domain - -sub _group -{ - my $self = shift; - my $old = $self->path; - if (@_) { - my($group,$from,$to) = @_; - if ($group =~ /\@/) { - $group =~ s/^<(.*)>$/$1/; # "<" and ">" should not be part of it - } - $group =~ s,%,%25,g; - $group =~ s,/,%2F,g; - my $path = $group; - if (defined $from) { - $path .= "/$from"; - $path .= "-$to" if defined $to; - } - $self->path($path); - } - - $old =~ s,^/,,; - if ($old !~ /\@/ && $old =~ s,/(.*),, && wantarray) { - my $extra = $1; - return (uri_unescape($old), split(/-/, $extra)); - } - uri_unescape($old); -} - - -sub group -{ - my $self = shift; - if (@_) { - Carp::croak("Group name can't contain '\@'") if $_[0] =~ /\@/; - } - my @old = $self->_group(@_); - return if $old[0] =~ /\@/; - wantarray ? @old : $old[0]; -} - -sub message -{ - my $self = shift; - if (@_) { - Carp::croak("Message must contain '\@'") unless $_[0] =~ /\@/; - } - my $old = $self->_group(@_); - return unless $old =~ /\@/; - return $old; -} - -1; diff --git a/lib/URI/nntp.pm b/lib/URI/nntp.pm deleted file mode 100644 index af61e03..0000000 --- a/lib/URI/nntp.pm +++ /dev/null @@ -1,6 +0,0 @@ -package URI::nntp; # draft-gilman-news-url-01 - -require URI::news; -@ISA=qw(URI::news); - -1; diff --git a/lib/URI/pop.pm b/lib/URI/pop.pm deleted file mode 100644 index 50b8d6d..0000000 --- a/lib/URI/pop.pm +++ /dev/null @@ -1,68 +0,0 @@ -package URI::pop; # RFC 2384 - -require URI::_server; -@ISA=qw(URI::_server); - -use strict; -use URI::Escape qw(uri_unescape); - -sub default_port { 110 } - -#pop://<user>;auth=<auth>@<host>:<port> - -sub user -{ - my $self = shift; - my $old = $self->userinfo; - - if (@_) { - my $new_info = $old; - $new_info = "" unless defined $new_info; - $new_info =~ s/^[^;]*//; - - my $new = shift; - if (!defined($new) && !length($new_info)) { - $self->userinfo(undef); - } else { - $new = "" unless defined $new; - $new =~ s/%/%25/g; - $new =~ s/;/%3B/g; - $self->userinfo("$new$new_info"); - } - } - - return unless defined $old; - $old =~ s/;.*//; - return uri_unescape($old); -} - -sub auth -{ - my $self = shift; - my $old = $self->userinfo; - - if (@_) { - my $new = $old; - $new = "" unless defined $new; - $new =~ s/(^[^;]*)//; - my $user = $1; - $new =~ s/;auth=[^;]*//i; - - - my $auth = shift; - if (defined $auth) { - $auth =~ s/%/%25/g; - $auth =~ s/;/%3B/g; - $new = ";AUTH=$auth$new"; - } - $self->userinfo("$user$new"); - - } - - return unless defined $old; - $old =~ s/^[^;]*//; - return uri_unescape($1) if $old =~ /;auth=(.*)/i; - return; -} - -1; diff --git a/lib/URI/rlogin.pm b/lib/URI/rlogin.pm deleted file mode 100644 index 18bb762..0000000 --- a/lib/URI/rlogin.pm +++ /dev/null @@ -1,7 +0,0 @@ -package URI::rlogin; -require URI::_login; -@ISA = qw(URI::_login); - -sub default_port { 513 } - -1; diff --git a/lib/URI/rsync.pm b/lib/URI/rsync.pm deleted file mode 100644 index 160d9d0..0000000 --- a/lib/URI/rsync.pm +++ /dev/null @@ -1,12 +0,0 @@ -package URI::rsync; # http://rsync.samba.org/ - -# rsync://[USER@]HOST[:PORT]/SRC - -require URI::_server; -require URI::_userpass; - -@ISA=qw(URI::_server URI::_userpass); - -sub default_port { 873 } - -1; diff --git a/lib/URI/rtsp.pm b/lib/URI/rtsp.pm deleted file mode 100644 index 982ca5e..0000000 --- a/lib/URI/rtsp.pm +++ /dev/null @@ -1,8 +0,0 @@ -package URI::rtsp; - -require URI::http; -@ISA=qw(URI::http); - -sub default_port { 554 } - -1; diff --git a/lib/URI/rtspu.pm b/lib/URI/rtspu.pm deleted file mode 100644 index dbcf12b..0000000 --- a/lib/URI/rtspu.pm +++ /dev/null @@ -1,8 +0,0 @@ -package URI::rtspu; - -require URI::rtsp; -@ISA=qw(URI::rtsp); - -sub default_port { 554 } - -1; diff --git a/lib/URI/sip.pm b/lib/URI/sip.pm deleted file mode 100644 index fae5d8e..0000000 --- a/lib/URI/sip.pm +++ /dev/null @@ -1,86 +0,0 @@ -# -# Written by Ryan Kereliuk <ryker@ryker.org>. This file may be -# distributed under the same terms as Perl itself. -# -# The RFC 3261 sip URI is <scheme>:<authority>;<params>?<query>. -# - -package URI::sip; - -require URI::_server; -require URI::_userpass; -@ISA=qw(URI::_server URI::_userpass); - -use strict; -use vars qw(@ISA $VERSION); -use URI::Escape qw(uri_unescape); - -$VERSION = "0.10"; - -sub default_port { 5060 } - -sub authority -{ - my $self = shift; - $$self =~ m,^($URI::scheme_re:)?([^;?]*)(.*)$,os or die; - my $old = $2; - - if (@_) { - my $auth = shift; - $$self = defined($1) ? $1 : ""; - my $rest = $3; - if (defined $auth) { - $auth =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; - $$self .= "$auth"; - } - $$self .= $rest; - } - $old; -} - -sub params_form -{ - my $self = shift; - $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die; - my $paramstr = $3; - - if (@_) { - my @args = @_; - $$self = $1 . $2; - my $rest = $4; - my @new; - for (my $i=0; $i < @args; $i += 2) { - push(@new, "$args[$i]=$args[$i+1]"); - } - $paramstr = join(";", @new); - $$self .= ";" . $paramstr . $rest; - } - $paramstr =~ s/^;//o; - return split(/[;=]/, $paramstr); -} - -sub params -{ - my $self = shift; - $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die; - my $paramstr = $3; - - if (@_) { - my $new = shift; - $$self = $1 . $2; - my $rest = $4; - $$self .= $paramstr . $rest; - } - $paramstr =~ s/^;//o; - return $paramstr; -} - -# Inherited methods that make no sense for a SIP URI. -sub path {} -sub path_query {} -sub path_segments {} -sub abs { shift } -sub rel { shift } -sub query_keywords {} - -1; diff --git a/lib/URI/sips.pm b/lib/URI/sips.pm deleted file mode 100644 index b32e105..0000000 --- a/lib/URI/sips.pm +++ /dev/null @@ -1,7 +0,0 @@ -package URI::sips; -require URI::sip; -@ISA=qw(URI::sip); - -sub default_port { 5061 } - -1; diff --git a/lib/URI/snews.pm b/lib/URI/snews.pm deleted file mode 100644 index 7e5b037..0000000 --- a/lib/URI/snews.pm +++ /dev/null @@ -1,8 +0,0 @@ -package URI::snews; # draft-gilman-news-url-01 - -require URI::news; -@ISA=qw(URI::news); - -sub default_port { 563 } - -1; diff --git a/lib/URI/ssh.pm b/lib/URI/ssh.pm deleted file mode 100644 index 5cd30fc..0000000 --- a/lib/URI/ssh.pm +++ /dev/null @@ -1,9 +0,0 @@ -package URI::ssh; -require URI::_login; -@ISA=qw(URI::_login); - -# ssh://[USER@]HOST[:PORT]/SRC - -sub default_port { 22 } - -1; diff --git a/lib/URI/telnet.pm b/lib/URI/telnet.pm deleted file mode 100644 index 5f842d3..0000000 --- a/lib/URI/telnet.pm +++ /dev/null @@ -1,7 +0,0 @@ -package URI::telnet; -require URI::_login; -@ISA = qw(URI::_login); - -sub default_port { 23 } - -1; diff --git a/lib/URI/tn3270.pm b/lib/URI/tn3270.pm deleted file mode 100644 index dd1e648..0000000 --- a/lib/URI/tn3270.pm +++ /dev/null @@ -1,7 +0,0 @@ -package URI::tn3270; -require URI::_login; -@ISA = qw(URI::_login); - -sub default_port { 23 } - -1; diff --git a/lib/URI/urn.pm b/lib/URI/urn.pm deleted file mode 100644 index 12d40b2..0000000 --- a/lib/URI/urn.pm +++ /dev/null @@ -1,97 +0,0 @@ -package URI::urn; # RFC 2141 - -require URI; -@ISA=qw(URI); - -use strict; -use Carp qw(carp); - -use vars qw(%implementor); - -sub _init { - my $class = shift; - my $self = $class->SUPER::_init(@_); - my $nid = $self->nid; - - my $impclass = $implementor{$nid}; - return $impclass->_urn_init($self, $nid) if $impclass; - - $impclass = "URI::urn"; - if ($nid =~ /^[A-Za-z\d][A-Za-z\d\-]*\z/) { - my $id = $nid; - # make it a legal perl identifier - $id =~ s/-/_/g; - $id = "_$id" if $id =~ /^\d/; - - $impclass = "URI::urn::$id"; - no strict 'refs'; - unless (@{"${impclass}::ISA"}) { - # Try to load it - eval "require $impclass"; - die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/; - $impclass = "URI::urn" unless @{"${impclass}::ISA"}; - } - } - else { - carp("Illegal namespace identifier '$nid' for URN '$self'") if $^W; - } - $implementor{$nid} = $impclass; - - return $impclass->_urn_init($self, $nid); -} - -sub _urn_init { - my($class, $self, $nid) = @_; - bless $self, $class; -} - -sub _nid { - my $self = shift; - my $opaque = $self->opaque; - if (@_) { - my $v = $opaque; - my $new = shift; - $v =~ s/[^:]*/$new/; - $self->opaque($v); - # XXX possible rebless - } - $opaque =~ s/:.*//s; - return $opaque; -} - -sub nid { # namespace identifier - my $self = shift; - my $nid = $self->_nid(@_); - $nid = lc($nid) if defined($nid); - return $nid; -} - -sub nss { # namespace specific string - my $self = shift; - my $opaque = $self->opaque; - if (@_) { - my $v = $opaque; - my $new = shift; - if (defined $new) { - $v =~ s/(:|\z).*/:$new/; - } - else { - $v =~ s/:.*//s; - } - $self->opaque($v); - } - return undef unless $opaque =~ s/^[^:]*://; - return $opaque; -} - -sub canonical { - my $self = shift; - my $nid = $self->_nid; - my $new = $self->SUPER::canonical; - return $new if $nid !~ /[A-Z]/ || $nid =~ /%/; - $new = $new->clone if $new == $self; - $new->nid(lc($nid)); - return $new; -} - -1; diff --git a/lib/URI/urn/isbn.pm b/lib/URI/urn/isbn.pm deleted file mode 100644 index 622b56c..0000000 --- a/lib/URI/urn/isbn.pm +++ /dev/null @@ -1,58 +0,0 @@ -package URI::urn::isbn; # RFC 3187 - -require URI::urn; -@ISA=qw(URI::urn); - -use strict; -use Business::ISBN (); - - -sub _isbn { - my $nss = shift; - $nss = $nss->nss if ref($nss); - my $isbn = Business::ISBN->new($nss); - $isbn = undef if $isbn && !$isbn->is_valid; - return $isbn; -} - -sub _nss_isbn { - my $self = shift; - my $nss = $self->nss(@_); - my $isbn = _isbn($nss); - $isbn = $isbn->as_string if $isbn; - return($nss, $isbn); -} - -sub isbn { - my $self = shift; - my $isbn; - (undef, $isbn) = $self->_nss_isbn(@_); - return $isbn; -} - -sub isbn_publisher_code { - my $isbn = shift->_isbn || return undef; - return $isbn->publisher_code; -} - -sub isbn_country_code { - my $isbn = shift->_isbn || return undef; - return $isbn->country_code; -} - -sub isbn_as_ean { - my $isbn = shift->_isbn || return undef; - return $isbn->as_ean; -} - -sub canonical { - my $self = shift; - my($nss, $isbn) = $self->_nss_isbn; - my $new = $self->SUPER::canonical; - return $new unless $nss && $isbn && $nss ne $isbn; - $new = $new->clone if $new == $self; - $new->nss($isbn); - return $new; -} - -1; diff --git a/lib/URI/urn/oid.pm b/lib/URI/urn/oid.pm deleted file mode 100644 index 301b2bc..0000000 --- a/lib/URI/urn/oid.pm +++ /dev/null @@ -1,18 +0,0 @@ -package URI::urn::oid; # RFC 2061 - -require URI::urn; -@ISA=qw(URI::urn); - -use strict; - -sub oid { - my $self = shift; - my $old = $self->nss; - if (@_) { - $self->nss(join(".", @_)); - } - return split(/\./, $old) if wantarray; - return $old; -} - -1; diff --git a/lib/XML/Dumper.pm b/lib/XML/Dumper.pm deleted file mode 100644 index 2d9f740..0000000 --- a/lib/XML/Dumper.pm +++ /dev/null @@ -1,897 +0,0 @@ -# ============================================================ -# XML:: -# ____ -# | _ \ _ _ _ __ ___ _ __ ___ _ __ -# | | | | | | | '_ ` _ \| '_ \ / _ \ '__| -# | |_| | |_| | | | | | | |_) | __/ | -# |____/ \__,_|_| |_| |_| .__/ \___|_| -# |_| -# Perl module for dumping Perl objects from/to XML -# ============================================================ - -=head1 NAME - -XML::Dumper - Perl module for dumping Perl objects from/to XML - -=head1 SYNOPSIS - - # ===== OO-way - use XML::Dumper; - $dump = new XML::Dumper; - - $xml = $dump->pl2xml( $perl ); - $perl = $dump->xml2pl( $xml ); - $dump->pl2xml( $perl, "my_perl_data.xml.gz" ); - - # ===== Functional way - use XML::Dumper; - - $xml = pl2xml( $perl ); - $perl = xml2pl( $xml ); - -=head1 EXTENDED SYNOPSIS - - use XML::Dumper; - my $dump = new XML::Dumper; - - my $perl = ''; - my $xml = ''; - - # ===== Convert Perl code to XML - $perl = [ - { - fname => 'Fred', - lname => 'Flintstone', - residence => 'Bedrock' - }, - { - fname => 'Barney', - lname => 'Rubble', - residence => 'Bedrock' - } - ]; - $xml = $dump->pl2xml( $perl ); - - # ===== Dump to a file - my $file = "dump.xml"; - $dump->pl2xml( $perl, $file ); - - # ===== Convert XML to Perl code - $xml = q| - <perldata> - <arrayref> - <item key="0"> - <hashref> - <item key="fname">Fred</item> - <item key="lname">Flintstone</item> - <item key="residence">Bedrock</item> - </hashref> - </item> - <item key="1"> - <hashref> - <item key="fname">Barney</item> - <item key="lname">Rubble</item> - <item key="residence">Bedrock</item> - </hashref> - </item> - </arrayref> - </perldata> - |; - - my $perl = $dump->xml2pl( $xml ); - - # ===== Convert an XML file to Perl code - my $perl = $dump->xml2pl( $file ); - - # ===== And serialize Perl code to an XML file - $dump->pl2xml( $perl, $file ); - - # ===== USE COMPRESSION - $dump->pl2xml( $perl, $file.".gz" ); - - # ===== INCLUDE AN IN-DOCUMENT DTD - $dump->dtd; - my $xml_with_dtd = $dump->pl2xml( $perl ); - - # ===== USE EXTERNAL DTD - $dump->dtd( $file, $url ); - my $xml_with_link_to_dtd = $dump->pl2xml( $perl ); - -=head1 DESCRIPTION - -XML::Dumper dumps Perl data to XML format. XML::Dumper can also read XML data -that was previously dumped by the module and convert it back to Perl. You can -use the module read the XML from a file and write the XML to a file. Perl -objects are blessed back to their original packaging; if the modules are -installed on the system where the perl objects are reconstituted from xml, they -will behave as expected. Intuitively, if the perl objects are converted and -reconstituted in the same environment, all should be well. And it is. - -Additionally, because XML benefits so nicely from compression, XML::Dumper -understands gzipped XML files. It does so with an optional dependency on -Compress::Zlib. So, if you dump a Perl variable with a file that has an -extension of '.xml.gz', it will store and compress the file in gzipped format. -Likewise, if you read a file with the extension '.xml.gz', it will uncompress -the file in memory before parsing the XML back into a Perl variable. - -Another fine challenge that this module rises to meet is that it understands -circular definitions and multiple references to a single object. This includes -doubly-linked lists, circular references, and the so-called 'Flyweight' pattern of -Object Oriented programming. So it can take the gnarliest of your perl data, and -should do just fine. - -=head2 FUNCTIONS AND METHODS - -=over 4 - -=cut - -package XML::Dumper; - -require 5.005_62; -use strict; -use warnings; - -require Exporter; -use XML::Parser; -use overload; - -our @ISA = qw( Exporter ); -our %EXPORT_TAGS = ( ); -our @EXPORT_OK = ( ); -our @EXPORT = qw( xml2pl pl2xml xml_compare xml_identity ); -our $VERSION = '0.79'; - -our $COMPRESSION_AVAILABLE; - -BEGIN { - eval { require Compress::Zlib; }; - if( $@ ) { - $COMPRESSION_AVAILABLE = 0; - } else { - $COMPRESSION_AVAILABLE = 1; - } -} - -our $dump = new XML::Dumper; - -# ============================================================ -sub new { -# ============================================================ - -=item * new() - XML::Dumper constructor. - -Creates a lean, mean, XML dumping machine. It's also completely -at your disposal. - -=cut - -# ------------------------------------------------------------ - my ($class) = map { ref || $_ } shift; - my $self = bless {}, $class; - - $self->init; - - return $self; -} - -# ============================================================ -sub init { -# ============================================================ - my $self = shift; - $self->{ perldata } = {}; - $self->{ xml } = {}; - 1; -} - -# ============================================================ -sub dtd { -# ============================================================ - -=item * dtd - - -Generates a Document Type Dictionary for the 'perldata' data -type. The default behaviour is to embed the DTD in the XML, -thereby creating valid XML. Given a filename, the DTD will be -written out to that file and the XML document for your Perl data -will link to the file. Given a filename and an URL, the DTD will -be written out the file and the XML document will link to the URL. -XML::Dumper doesn't try really hard to determine where your DTD's -ought to go or relative paths or anything, so be careful with -what arguments you supply this method, or just go with the default -with the embedded DTD. Between DTD's and Schemas, the potential -for more free-form data to be imported and exported becomes -feasible. - -Usage: - - dtd(); # Causes XML to include embedded DTD - dtd( $file ); # DTD saved to $file; XML will link to $file - dtd( $file, $url ); # DTD saved to $file; XML will link to $url - dtd( 0 ); # Prevents XML from including embedded DTD - -=cut - -# ------------------------------------------------------------ - my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/ ) ? shift : $dump; - my $file = shift; - my $url = shift; - - my $dtd = qq{<!ELEMENT scalar (#PCDATA)> -<!ELEMENT scalarref (#PCDATA)> -<!ATTLIST scalarref - blessed_package CDATA #IMPLIED - memory_address CDATA #IMPLIED> -<!ELEMENT arrayref (item*)> -<!ATTLIST arrayref - blessed_package CDATA #IMPLIED - memory_address CDATA #IMPLIED> -<!ELEMENT hashref (item*)> -<!ATTLIST hashref - blessed_package CDATA #IMPLIED - memory_address CDATA #IMPLIED> -<!ELEMENT item (#PCDATA|scalar|scalarref|arrayref|hashref)*> -<!ATTLIST item - key CDATA #REQUIRED - defined CDATA #IMPLIED> -<!ELEMENT perldata (scalar|scalarref|arrayref|hashref)*> -}; - - if( defined $file && $file ) { - open DTD, ">$file" or die $!; - print DTD $dtd; - close DTD; - $url = defined $url ? $url : $file; - $self->{ dtd } = qq{ -<!DOCTYPE perldata SYSTEM "$url"> -}; - } elsif( not defined $file ) { - $self->{ dtd } = join( "\n", - "<?xml version=\"1.0\"?>", - "<!DOCTYPE perldata [", - ( map { /^\t/ ? $_ : " $_" } split /\n/, $dtd ), - ']>', - ''); - } else { - delete $self->{ dtd }; - return; - } - - $self->{ dtd }; -} - -# ============================================================ -sub dump { -# ============================================================ - my $self = shift; - my $ref = shift; - my $indent = shift; - - my $string = ''; - - # ===== HANDLE REFERENCE DUMPING - if( ref $ref ) { - no warnings; - local $_ = ref( $ref ); - my $class = ''; - my $address = ''; - my $reused = ''; - - # ===== HANDLE THE VARIETY OF THINGS A PERL REFERENCE CAN REFER TO - REFERENCE: { - # ---------------------------------------- - OBJECT: { - # ---------------------------------------- - last OBJECT if /^(?:SCALAR|HASH|ARRAY)$/; - $class = $_; - $class = xml_escape( $class ); - ($_,$address) = overload::StrVal( $ref ) =~ /$class=([^(]+)\(([x0-9A-Fa-f]+)\)/; - } - - # ---------------------------------------- - HAS_MEMORY_ADDRESS: { - # ---------------------------------------- - # References which refer to the same memory space point to the - # same thing - last HAS_MEMORY_ADDRESS if( $class ); - ($_,$address) = overload::StrVal( $ref ) =~ /([^(]+)\(([x0-9A-Fa-f]+)\)/; - } - - $reused = exists( $self->{ xml }{ $address } ); - - # ---------------------------------------- - if( /^SCALAR$/ ) { - # ---------------------------------------- - my $type = - "<scalarref". - ($class ? " blessed_package=\"$class\"" : '' ) . - ($address ? " memory_address=\"$address\"" : '' ) . - ( defined $$ref ? '' : " defined=\"false\"" ) . - ">"; - $self->{ xml }{ $address }++ if( $address ); - $string = "\n" . " " x $indent . $type . ($reused ? '' : xml_escape($$ref)) . "</scalarref>"; - last REFERENCE; - } - - # ---------------------------------------- - if( /^HASH$/ ) { - # ---------------------------------------- - $self->{ xml }{ $address }++ if( $address ); - my $type = - "<hashref". - ($class ? " blessed_package=\"$class\"" : '' ). - ($address && $self->{ xml }{ $address } ? " memory_address=\"$address\"" : '' ). - ">"; - $string = "\n" . " " x $indent . $type; - if( not $reused ) { - $indent++; - foreach my $key (sort keys(%$ref)) { - my $type = - "<item " . - "key=\"" . xml_escape( $key ) . "\"" . - ( defined $ref->{ $key } ? '' : " defined=\"false\"" ) . - ">"; - $string .= "\n" . " " x $indent . $type; - if (ref($ref->{$key})) { - $string .= $self->dump( $ref->{$key}, $indent+1); - $string .= "\n" . " " x $indent . "</item>"; - } else { - $string .= xml_escape($ref->{$key}) . "</item>"; - } - } - $indent--; - } - $string .= "\n" . " " x $indent . "</hashref>"; - last REFERENCE; - } - - # ---------------------------------------- - if( /^ARRAY$/ ) { - # ---------------------------------------- - my $type = - "<arrayref". - ($class ? " blessed_package=\"$class\"" : '' ). - ($address ? " memory_address=\"$address\"" : '' ). - ">"; - $string .= "\n" . " " x $indent . $type; - $self->{ xml }{ $address }++ if( $address ); - if( not $reused ) { - $indent++; - for (my $i=0; $i < @$ref; $i++) { - my $defined; - my $type = - "<item " . - "key=\"" . xml_escape( $i ) . "\"" . - ( defined $ref->[ $i ] ? '' : " defined=\"false\"" ) . - ">"; - - $string .= "\n" . " " x $indent . $type; - if (ref($ref->[$i])) { - $string .= $self->dump($ref->[$i], $indent+1); - $string .= "\n" . " " x $indent . "</item>"; - } else { - $string .= xml_escape($ref->[$i]) . "</item>"; - } - } - $indent--; - } - $string .= "\n" . " " x $indent . "</arrayref>"; - last REFERENCE; - } - - } - - # ===== HANDLE SCALAR DUMPING - } else { - my $type = - "<scalar". - ( defined $ref ? '' : " defined=\"false\"" ) . - ">"; - - $string .= "\n" . " " x $indent . $type . xml_escape( $ref ) . "</scalar>"; - } - - return( $string ); -} - -# ============================================================ -sub perl2xml { -# ============================================================ - pl2xml( @_ ); -} - -# ============================================================ -sub pl2xml { -# ============================================================ - -=item * pl2xml( $xml, [ $file ] ) - - -(Also perl2xml(), for those who enjoy readability over brevity). - -Converts Perl data to XML. If a second argument is given, then the Perl data -will be stored to disk as XML, using the second argument as a filename. - -Usage: See Synopsis - -=cut - -# ------------------------------------------------------------ - my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/ ) ? shift : $dump; - my $ref = shift; - my $file = shift; - - $self->init; - - my $xml = - ( defined $self->{ dtd } ? $self->{ dtd } : '' ) . - "<perldata>" . $self->dump( $ref, 1 ) . "\n</perldata>\n"; - - if( defined $file ) { - if( $file =~ /\.xml\.gz$/i ) { - if( $COMPRESSION_AVAILABLE ) { - my $compressed_xml = Compress::Zlib::memGzip( $xml ) or die "Failed to compress xml $!"; - open FILE, ">:utf8", $file or die "Can't open '$file' for writing $!"; - binmode FILE; - print FILE $compressed_xml; - close FILE; - - } else { - my $uncompressed_file = $file; - $uncompressed_file =~ s/\.gz$//i; - warn "Compress::Zlib not installed. Saving '$file' as '$uncompressed_file'\n"; - - open FILE, ">:utf8", $uncompressed_file or die "Can't open '$uncompressed_file' for writing $!"; - print FILE $xml; - close FILE; - } - } else { - no warnings; # to shut Perl up about Wide characters for UTF8 output - open FILE, ">$file" or die "Can't open '$file' for writing $!"; - print FILE $xml; - close FILE; - } - } - return $xml; -} - -# ============================================================ -sub undump { -# ============================================================ -# undump -# Takes the XML generated by pl2xml, and recursively undumps it to -# create a data structure in memory. The top-level object is a scalar, -# a reference to a scalar, a hash, or an array. Hashes and arrays may -# themselves contain scalars, or references to scalars, or references to -# hashes or arrays, with the exception that scalar values are never -# "undef" because there's currently no way to represent undef in the -# dumped data. -# -# The key to understanding undump is to understand XML::Parser's -# Tree parsing format: -# -# <tag name>, [ { <attributes }, '0', <[text]>, <[children tag-array pair value(s)]...> ] -# ------------------------------------------------------------ - my $self = shift; - my $tree = shift; - my $callback = shift; - - my $ref = undef; - my $item; - - # make Perl stop whining about deep recursion and soft references - no warnings; - - TREE: for (my $i = 1; $i < $#$tree; $i+=2) { - local $_ = lc( $tree->[ $i ] ); - my $class = ''; - my $address = ''; - - PERL_TYPES: { - # ---------------------------------------- - if( /^scalar$/ ) { - # ---------------------------------------- - $ref = defined $tree->[ $i+1 ][ 2 ] ? $tree->[ $i +1 ][ 2 ] : ''; - if( exists $tree->[ $i+1 ][ 0 ]{ 'defined' } ) { - if( $tree->[ $i +1 ][ 0 ]{ 'defined' } =~ /false/i ) { - $ref = undef; - } - } - last TREE; - } - - # ===== FIND PACKAGE - if( $tree->[ $i+1 ] && ref( $tree->[ $i +1 ] ) eq 'ARRAY' ) { - if( exists $tree->[ $i+1 ][0]{ blessed_package } ) { - $class = $tree->[ $i+1 ][ 0 ]{ blessed_package }; - } - } - - # ===== FIND MEMORY ADDRESS - if( $tree->[ $i+1 ] && ref( $tree->[ $i +1 ] ) eq 'ARRAY' ) { - if( exists $tree->[ $i+1 ][0]{ memory_address } ) { - $address = $tree->[ $i+1 ][ 0 ]{ memory_address }; - } - } - - ALREADY_EXISTS_IN_MEMORY: { - if( exists $self->{ perldata }{ $address } ) { - $ref = $self->{ perldata }{ $address }; - last TREE; - } - } - - # ---------------------------------------- - if( /^scalarref/ ) { - # ---------------------------------------- - $ref = defined $tree->[ $i+1 ][ 2 ] ? \ $tree->[ $i +1 ][ 2 ] : \''; - if( exists $tree->[ $i+1 ][ 0 ]{ 'defined' } ) { - if( $tree->[ $i +1 ][ 0 ]{ 'defined' } =~ /false/i ) { - $ref = \ undef; - } - } - - $self->{ perldata }{ $address } = $ref if( $address ); - if( $class ) { - # Check class name for nasty stuff... - $class =~ m/^[\w-]+(?:::[\w-]+)*$/ - or die "Refusing to load unsafe class name '$class'\n"; - - unless( int( eval( "\%$class"."::")) ) { - eval "require $class;"; - if( $@ ) { - warn $@; - } - } - - bless $ref, $class; - if( defined $callback && $ref->can( $callback ) ) { - $ref->$callback(); - } - } - last TREE; - } - - # ---------------------------------------- - if( /^hash(?:ref)?/ ) { - # ---------------------------------------- - $ref = {}; - $self->{ perldata }{ $address } = $ref if( $address ); - for (my $j = 1; $j < $#{$tree->[$i+1]}; $j+=2) { - next unless $tree->[$i+1][$j] eq 'item'; - my $item_tree = $tree->[$i+1][$j+1]; - if( exists $item_tree->[0]{ key } ) { - my $key = $item_tree->[ 0 ]{ key }; - if( exists $item_tree->[ 0 ]{ 'defined' } ) { - if( $item_tree->[ 0 ]{ 'defined' } =~ /false/ ) { - $ref->{ $key } = undef; - next; - } - } - # ===== XML::PARSER IGNORES ZERO-LENGTH STRINGS - # It indicates the presence of a zero-length string by - # not having the array portion of the tag-name/array pair - # values be of length 1. (Which is to say it captures only - # the attributes of the tag and acknowledges that the tag - # is an empty one. - if( int( @{ $item_tree } ) == 1 ) { - $ref->{ $key } = ''; - next; - } - $ref->{ $key } = $self->undump( $item_tree, $callback ); - } - } - if( $class ) { - # Check class name for nasty stuff... - $class =~ m/^[\w-]+(?:::[\w-]+)*$/ - or die "Refusing to load unsafe class name '$class'\n"; - - unless( int( eval( "\%$class"."::")) ) { - eval "require $class;"; - if( $@ ) { - warn $@; - } - } - - bless $ref, $class; - if( defined $callback && $ref->can( $callback ) ) { - $ref->$callback(); - } - } - last TREE; - } - - # ---------------------------------------- - if( /^arrayref/ ) { - # ---------------------------------------- - $ref = []; - $self->{ perldata }{ $address } = $ref if( $address ); - for (my $j = 1; $j < $#{$tree->[$i+1]}; $j+=2) { - next unless $tree->[$i+1][$j] eq 'item'; - my $item_tree = $tree->[$i+1][$j+1]; - if( exists $item_tree->[0]{ key } ) { - my $key = $item_tree->[0]{ key }; - if( exists $item_tree->[ 0 ]{ 'defined' } ) { - if( $item_tree->[ 0 ]{ 'defined' } =~ /false/ ) { - $ref->[ $key ] = undef; - next; - } - } - # ===== XML::PARSER IGNORES ZERO-LENGTH STRINGS - # See note above. - if( int( @{ $item_tree } ) == 1 ) { - $ref->[ $key ] = ''; - next; - } - $ref->[ $key ] = $self->undump( $item_tree, $callback ); - } - } - if( $class ) { - # Check class name for nasty stuff... - $class =~ m/^[\w-]+(?:::[\w-]+)*$/ - or die "Refusing to load unsafe class name '$class'\n"; - - unless( int( eval( "\%$class"."::")) ) { - eval "require $class;"; - if( $@ ) { - warn $@; - } - } - - bless $ref, $class; - if( defined $callback && $ref->can( $callback ) ) { - $ref->$callback(); - } - } - last TREE; - } - - # ---------------------------------------- - if( /^0$/ ) { # SIMPLE SCALAR - # ---------------------------------------- - $item = $tree->[$i + 1]; - } - } - } - - ## If $ref is not set at this point, it means we've just - ## encountered a scalar value directly inside the item tag. - - $ref = $item unless defined( $ref ); - - return ($ref); -} - -# ============================================================ -sub xml_escape { -# ============================================================ -# Transforms and filters input characters to acceptable XML characters -# (or filters them out completely). There's probably a better -# implementation of this in another module, by now. -# ------------------------------------------------------------ - local $_ = shift; - return $_ if not defined $_; - s/&/&/g; - s/</</g; - s/>/>/g; - s/[\0\ca\cb\cc\cd\ce\cf\cg\ch\ck\cl\cn\co\cp\cq\cr\cs\ct\cu\cv\cw\cx\cy\cz\c[\c\\c]\c^\c_]//g; - s/'/'/g; - s/"/"/g; - return $_; -} - -# ============================================================ -sub xml2perl { -# ============================================================ - xml2pl( @_ ); -} - -# ============================================================ -sub xml2pl { -# ============================================================ - -=item * xml2pl( $xml_or_filename, [ $callback ] ) - - -(Also xml2perl(), for those who enjoy readability over brevity.) - -Converts XML to a Perl datatype. If this method is given a second argument, -XML::Dumper will use the second argument as a callback (if possible). If -the first argument isn't XML and exists as a file, that file will be read -and its contents will be used as the input XML. - -Currently, the only supported invocation of callbacks is through soft -references. That is to say, the callback argument ought to be a string -that matches the name of a callable method for your classes. If you have -a congruent interface, this should work like a peach. If your class -interface doesn't have such a named method, it won't be called. - -=cut - -# ------------------------------------------------------------ - my $self = ( ref $_[0] && (ref $_[0]) =~ /XML::Dumper/) ? shift : $dump; - my $xml = shift; - my $callback = shift; - - $self->init; - - if( $xml !~ /\</ ) { - my $file = $xml; - if( -e $file ) { - my $gzip_header_signature = pack "H4", "1f8b"; - my $first_two_bytes; - - open FILE, "<". $file or die "Can't open '$file' for reading $!"; - defined read FILE, $first_two_bytes, 2 or die "Can't read first two bytes of '$file' $!"; - close FILE; - - if( $first_two_bytes eq $gzip_header_signature ) { - if( $COMPRESSION_AVAILABLE ) { - my $gz = Compress::Zlib::gzopen( $file, "rb" ); - my @xml; - my $buffer; - while( $gz->gzread( $buffer ) > 0 ) { - push @xml, $buffer; - } - $gz->gzclose(); - $xml = join "", @xml; - - } else { - die "Compress::Zlib is not installed. Cannot read gzipped file '$file'"; - } - } else { - - open FILE, $file or die "Can't open file '$file' for reading $!"; - my @xml = <FILE>; - close FILE; - $xml = join "", @xml; - } - - } else { - die "'$file' does not exist as a file and is not XML.\n"; - } - } - - my $parser = new XML::Parser(Style => 'Tree'); - my $tree = $parser->parse($xml); - - # Skip enclosing "perldata" level - my $topItem = $tree->[1]; - my $ref = $self->undump($topItem, $callback); - - return($ref); -} - -# ============================================================ -sub xml_compare { -# ============================================================ - -=item * xml_compare( $xml1, $xml2 ) - Compares xml for content - -Compares two dumped Perl data structures (that is, compares the xml) for -identity in content. Use this function rather than perl's built-in string -comparison. This function will return true for any two perl data that are -either deep clones of each other, or identical. This method is exported -by default. - -=cut - -# ------------------------------------------------------------ - my $self = shift; - my $xml1 = shift; - my $xml2 = shift; - - my $class = ref $self; - if( $class ne 'XML::Dumper' ) { - $xml2 = $xml1; - $xml1 = $self; - } - - $xml1 =~ s/(<[^>]*)\smemory_address="\dx[A-Za-z0-9]+"([^<]*>)/$1$2/g; - $xml2 =~ s/(<[^>]*)\smemory_address="\dx[A-Za-z0-9]+"([^<]*>)/$1$2/g; - $xml1 =~ s/(<[^>]*)\sdefined=\"false\"([^<]>)/$1$2/g; # For backwards - $xml2 =~ s/(<[^>]*)\sdefined=\"false\"([^<]>)/$1$2/g; # compatibility - $xml1 =~ s/<\?xml .*>//; # Ignore XML declaration - $xml2 =~ s/<\?xml .*>//; - $xml1 =~ s/<\!DOCTYPE perldata \[.*\]>//s; # Remove DTD - $xml2 =~ s/<\!DOCTYPE perldata \[.*\]>//s; - $xml1 =~ s/^\s*</</; # Remove empty space - $xml2 =~ s/^\s*</</; - $xml1 =~ s/>\s*</></g; - $xml2 =~ s/>\s*</></g; - $xml1 =~ s/>\s*$/>/; - $xml2 =~ s/>\s*$/>/; - - return $xml1 eq $xml2; -} - -# ============================================================ -sub xml_identity { -# ============================================================ - -=item * xml_identity( $xml1, $xml2 ) - Compares xml for identity - -Compares two dumped Perl data structures (that is, compares the xml) for -identity in instantiation. This function will return true for any two -perl data that are identical, but not for deep clones of each other. This -method is also exported by default. - -=cut - -# ------------------------------------------------------------ - my $self = shift; - my $xml1 = shift; - my $xml2 = shift; - - my $class = ref $self; - if( $class ne 'XML::Dumper' ) { - $xml2 = $xml1; - $xml1 = $self; - } - - return ( $xml1 eq $xml2 ); -} - -1; -__END__ - -=back - -=head1 EXPORTS - -By default, the following methods are exported: - - xml2pl, pl2xml, xml_compare, xml_identity - -=head1 BUGS AND DEPENDENCIES - -XML::Dumper has changed API since 0.4, as a response to a bug report -from PerlMonks. I felt it was necessary, as the functions simply didn't -work as advertised. That is, xml2pl really didnt accept xml as an -argument; what it wanted was an XML Parse tree. To correct for the -API change, simply don't parse the XML before feeding it to XML::Dumper. - -XML::Dumper also has no understanding of typeglobs (references or not), -references to regular expressions, or references to Perl subroutines. -Turns out that Data::Dumper doesn't do references to Perl subroutines, -either, so at least I'm in somewhat good company. - -XML::Dumper requires one perl module, available from CPAN - - XML::Parser - -XML::Parser itself relies on Clark Cooper's Expat implementation in Perl, -which in turn requires James Clark's expat package itself. See the -documentation for XML::Parser for more information. - -=head1 REVISIONS AND CREDITS - -The list of credits got so long that I had to move it to the Changes -file. Thanks to all those who've contributed with bug reports and -suggested features! Keep 'em coming! - -I've had ownership of the module since June of 2002, and very much -appreciate requests on how to make the module better. It has served me -well, both as a learning tool on how I can repay my debt to the Perl -Community, and as a practical module that is useful. I'm thrilled to -be able to offer this bit of code. So, if you have suggestions, bug -reports, or feature requests, please let me know and I'll do my best -to make this a better module. - -=head1 CURRENT MAINTAINER - -Mike Wong E<lt>mike_w3@pacbell.netE<gt> - -XML::Dumper is free software. You can redistribute it and/or -modify it under the same terms as Perl itself. - -=head1 ORIGINAL AUTHOR - -Jonathan Eisenzopf E<lt>eisen@pobox.comE<gt> - -=head1 SEE ALSO - -perl(1) -Compress::Zlib(3) -XML::Parser(3) -Data::DumpXML(3) - -=cut diff --git a/lib/XML/Simple.pm b/lib/XML/Simple.pm deleted file mode 100644 index e2216be..0000000 --- a/lib/XML/Simple.pm +++ /dev/null @@ -1,3041 +0,0 @@ -# $Id: Simple.pm,v 1.23 2005/01/29 04:16:10 grantm Exp $ - -package XML::Simple; - -=head1 NAME - -XML::Simple - Easy API to maintain XML (esp config files) - -=head1 SYNOPSIS - - use XML::Simple; - - my $ref = XMLin([<xml file or string>] [, <options>]); - - my $xml = XMLout($hashref [, <options>]); - -Or the object oriented way: - - require XML::Simple; - - my $xs = new XML::Simple(options); - - my $ref = $xs->XMLin([<xml file or string>] [, <options>]); - - my $xml = $xs->XMLout($hashref [, <options>]); - -(or see L<"SAX SUPPORT"> for 'the SAX way'). - -To catch common errors: - - use XML::Simple qw(:strict); - -(see L<"STRICT MODE"> for more details). - -=cut - -# See after __END__ for more POD documentation - - -# Load essentials here, other modules loaded on demand later - -use strict; -use Carp; -require Exporter; - - -############################################################################## -# Define some constants -# - -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $PREFERRED_PARSER); - -@ISA = qw(Exporter); -@EXPORT = qw(XMLin XMLout); -@EXPORT_OK = qw(xml_in xml_out); -$VERSION = '2.14'; -$PREFERRED_PARSER = undef; - -my $StrictMode = 0; -my %CacheScheme = ( - storable => [ \&StorableSave, \&StorableRestore ], - memshare => [ \&MemShareSave, \&MemShareRestore ], - memcopy => [ \&MemCopySave, \&MemCopyRestore ] - ); - -my @KnownOptIn = qw(keyattr keeproot forcecontent contentkey noattr - searchpath forcearray cache suppressempty parseropts - grouptags nsexpand datahandler varattr variables - normalisespace normalizespace valueattr); - -my @KnownOptOut = qw(keyattr keeproot contentkey noattr - rootname xmldecl outputfile noescape suppressempty - grouptags nsexpand handler noindent attrindent nosort - valueattr numericescape); - -my @DefKeyAttr = qw(name key id); -my $DefRootName = qq(opt); -my $DefContentKey = qq(content); -my $DefXmlDecl = qq(<?xml version='1.0' standalone='yes'?>); - -my $xmlns_ns = 'http://www.w3.org/2000/xmlns/'; -my $bad_def_ns_jcn = '{' . $xmlns_ns . '}'; # LibXML::SAX workaround - - -############################################################################## -# Globals for use by caching routines -# - -my %MemShareCache = (); -my %MemCopyCache = (); - - -############################################################################## -# Wrapper for Exporter - handles ':strict' -# - -sub import { - - # Handle the :strict tag - - $StrictMode = 1 if grep(/^:strict$/, @_); - - # Pass everything else to Exporter.pm - - __PACKAGE__->export_to_level(1, grep(!/^:strict$/, @_)); -} - - -############################################################################## -# Constructor for optional object interface. -# - -sub new { - my $class = shift; - - if(@_ % 2) { - croak "Default options must be name=>value pairs (odd number supplied)"; - } - - my %known_opt; - @known_opt{@KnownOptIn, @KnownOptOut} = (undef) x 100; - - my %raw_opt = @_; - my %def_opt; - while(my($key, $val) = each %raw_opt) { - my $lkey = lc($key); - $lkey =~ s/_//g; - croak "Unrecognised option: $key" unless(exists($known_opt{$lkey})); - $def_opt{$lkey} = $val; - } - my $self = { def_opt => \%def_opt }; - - return(bless($self, $class)); -} - - -############################################################################## -# Sub/Method: XMLin() -# -# Exported routine for slurping XML into a hashref - see pod for info. -# -# May be called as object method or as a plain function. -# -# Expects one arg for the source XML, optionally followed by a number of -# name => value option pairs. -# - -sub XMLin { - - # If this is not a method call, create an object - - my $self; - if($_[0] and UNIVERSAL::isa($_[0], 'XML::Simple')) { - $self = shift; - } - else { - $self = new XML::Simple(); - } - - - my $string = shift; - - $self->handle_options('in', @_); - - - # If no XML or filename supplied, look for scriptname.xml in script directory - - unless(defined($string)) { - - # Translate scriptname[.suffix] to scriptname.xml - - require File::Basename; - - my($ScriptName, $ScriptDir, $Extension) = - File::Basename::fileparse($0, '\.[^\.]+'); - - $string = $ScriptName . '.xml'; - - - # Add script directory to searchpath - - if($ScriptDir) { - unshift(@{$self->{opt}->{searchpath}}, $ScriptDir); - } - } - - - # Are we parsing from a file? If so, is there a valid cache available? - - my($filename, $scheme); - unless($string =~ m{<.*?>}s or ref($string) or $string eq '-') { - - require File::Basename; - require File::Spec; - - $filename = $self->find_xml_file($string, @{$self->{opt}->{searchpath}}); - - if($self->{opt}->{cache}) { - foreach $scheme (@{$self->{opt}->{cache}}) { - croak "Unsupported caching scheme: $scheme" - unless($CacheScheme{$scheme}); - - my $opt = $CacheScheme{$scheme}->[1]->($filename); - return($opt) if($opt); - } - } - } - else { - delete($self->{opt}->{cache}); - if($string eq '-') { - # Read from standard input - - local($/) = undef; - $string = <STDIN>; - } - } - - - # Parsing is required, so let's get on with it - - my $tree = $self->build_tree($filename, $string); - - - # Now work some magic on the resulting parse tree - - my($ref); - if($self->{opt}->{keeproot}) { - $ref = $self->collapse({}, @$tree); - } - else { - $ref = $self->collapse(@{$tree->[1]}); - } - - if($self->{opt}->{cache}) { - $CacheScheme{$self->{opt}->{cache}->[0]}->[0]->($ref, $filename); - } - - return($ref); -} - - -############################################################################## -# Method: build_tree() -# -# This routine will be called if there is no suitable pre-parsed tree in a -# cache. It parses the XML and returns an XML::Parser 'Tree' style data -# structure (summarised in the comments for the collapse() routine below). -# -# XML::Simple requires the services of another module that knows how to -# parse XML. If XML::SAX is installed, the default SAX parser will be used, -# otherwise XML::Parser will be used. -# -# This routine expects to be passed a 'string' as argument 1 or a filename as -# argument 2. The 'string' might be a string of XML or it might be a -# reference to an IO::Handle. (This non-intuitive mess results in part from -# the way XML::Parser works but that's really no excuse). -# - -sub build_tree { - my $self = shift; - my $filename = shift; - my $string = shift; - - - my $preferred_parser = $PREFERRED_PARSER; - unless(defined($preferred_parser)) { - $preferred_parser = $ENV{XML_SIMPLE_PREFERRED_PARSER} || ''; - } - if($preferred_parser eq 'XML::Parser') { - return($self->build_tree_xml_parser($filename, $string)); - } - - eval { require XML::SAX; }; # We didn't need it until now - if($@) { # No XML::SAX - fall back to XML::Parser - if($preferred_parser) { # unless a SAX parser was expressly requested - croak "XMLin() could not load XML::SAX"; - } - return($self->build_tree_xml_parser($filename, $string)); - } - - $XML::SAX::ParserPackage = $preferred_parser if($preferred_parser); - - my $sp = XML::SAX::ParserFactory->parser(Handler => $self); - - $self->{nocollapse} = 1; - my($tree); - if($filename) { - $tree = $sp->parse_uri($filename); - } - else { - if(ref($string)) { - $tree = $sp->parse_file($string); - } - else { - $tree = $sp->parse_string($string); - } - } - - return($tree); -} - - -############################################################################## -# Method: build_tree_xml_parser() -# -# This routine will be called if XML::SAX is not installed, or if XML::Parser -# was specifically requested. It takes the same arguments as build_tree() and -# returns the same data structure (XML::Parser 'Tree' style). -# - -sub build_tree_xml_parser { - my $self = shift; - my $filename = shift; - my $string = shift; - - - eval { - local($^W) = 0; # Suppress warning from Expat.pm re File::Spec::load() - require XML::Parser; # We didn't need it until now - }; - if($@) { - croak "XMLin() requires either XML::SAX or XML::Parser"; - } - - if($self->{opt}->{nsexpand}) { - carp "'nsexpand' option requires XML::SAX"; - } - - my $xp = new XML::Parser(Style => 'Tree', @{$self->{opt}->{parseropts}}); - my($tree); - if($filename) { - # $tree = $xp->parsefile($filename); # Changed due to prob w/mod_perl - local(*XML_FILE); - open(XML_FILE, '<', $filename) || croak qq($filename - $!); - $tree = $xp->parse(*XML_FILE); - close(XML_FILE); - } - else { - $tree = $xp->parse($string); - } - - return($tree); -} - - -############################################################################## -# Sub: StorableSave() -# -# Wrapper routine for invoking Storable::nstore() to cache a parsed data -# structure. -# - -sub StorableSave { - my($data, $filename) = @_; - - my $cachefile = $filename; - $cachefile =~ s{(\.xml)?$}{.stor}; - - require Storable; # We didn't need it until now - - if ('VMS' eq $^O) { - Storable::nstore($data, $cachefile); - } - else { - # If the following line fails for you, your Storable.pm is old - upgrade - Storable::lock_nstore($data, $cachefile); - } - -} - - -############################################################################## -# Sub: StorableRestore() -# -# Wrapper routine for invoking Storable::retrieve() to read a cached parsed -# data structure. Only returns cached data if the cache file exists and is -# newer than the source XML file. -# - -sub StorableRestore { - my($filename) = @_; - - my $cachefile = $filename; - $cachefile =~ s{(\.xml)?$}{.stor}; - - return unless(-r $cachefile); - return unless((stat($cachefile))[9] > (stat($filename))[9]); - - require Storable; # We didn't need it until now - - if ('VMS' eq $^O) { - return(Storable::retrieve($cachefile)); - } - else { - return(Storable::lock_retrieve($cachefile)); - } - -} - - -############################################################################## -# Sub: MemShareSave() -# -# Takes the supplied data structure reference and stores it away in a global -# hash structure. -# - -sub MemShareSave { - my($data, $filename) = @_; - - $MemShareCache{$filename} = [time(), $data]; -} - - -############################################################################## -# Sub: MemShareRestore() -# -# Takes a filename and looks in a global hash for a cached parsed version. -# - -sub MemShareRestore { - my($filename) = @_; - - return unless($MemShareCache{$filename}); - return unless($MemShareCache{$filename}->[0] > (stat($filename))[9]); - - return($MemShareCache{$filename}->[1]); - -} - - -############################################################################## -# Sub: MemCopySave() -# -# Takes the supplied data structure and stores a copy of it in a global hash -# structure. -# - -sub MemCopySave { - my($data, $filename) = @_; - - require Storable; # We didn't need it until now - - $MemCopyCache{$filename} = [time(), Storable::dclone($data)]; -} - - -############################################################################## -# Sub: MemCopyRestore() -# -# Takes a filename and looks in a global hash for a cached parsed version. -# Returns a reference to a copy of that data structure. -# - -sub MemCopyRestore { - my($filename) = @_; - - return unless($MemCopyCache{$filename}); - return unless($MemCopyCache{$filename}->[0] > (stat($filename))[9]); - - return(Storable::dclone($MemCopyCache{$filename}->[1])); - -} - - -############################################################################## -# Sub/Method: XMLout() -# -# Exported routine for 'unslurping' a data structure out to XML. -# -# Expects a reference to a data structure and an optional list of option -# name => value pairs. -# - -sub XMLout { - - # If this is not a method call, create an object - - my $self; - if($_[0] and UNIVERSAL::isa($_[0], 'XML::Simple')) { - $self = shift; - } - else { - $self = new XML::Simple(); - } - - croak "XMLout() requires at least one argument" unless(@_); - my $ref = shift; - - $self->handle_options('out', @_); - - - # If namespace expansion is set, XML::NamespaceSupport is required - - if($self->{opt}->{nsexpand}) { - require XML::NamespaceSupport; - $self->{nsup} = XML::NamespaceSupport->new(); - $self->{ns_prefix} = 'aaa'; - } - - - # Wrap top level arrayref in a hash - - if(UNIVERSAL::isa($ref, 'ARRAY')) { - $ref = { anon => $ref }; - } - - - # Extract rootname from top level hash if keeproot enabled - - if($self->{opt}->{keeproot}) { - my(@keys) = keys(%$ref); - if(@keys == 1) { - $ref = $ref->{$keys[0]}; - $self->{opt}->{rootname} = $keys[0]; - } - } - - # Ensure there are no top level attributes if we're not adding root elements - - elsif($self->{opt}->{rootname} eq '') { - if(UNIVERSAL::isa($ref, 'HASH')) { - my $refsave = $ref; - $ref = {}; - foreach (keys(%$refsave)) { - if(ref($refsave->{$_})) { - $ref->{$_} = $refsave->{$_}; - } - else { - $ref->{$_} = [ $refsave->{$_} ]; - } - } - } - } - - - # Encode the hashref and write to file if necessary - - $self->{_ancestors} = []; - my $xml = $self->value_to_xml($ref, $self->{opt}->{rootname}, ''); - delete $self->{_ancestors}; - - if($self->{opt}->{xmldecl}) { - $xml = $self->{opt}->{xmldecl} . "\n" . $xml; - } - - if($self->{opt}->{outputfile}) { - if(ref($self->{opt}->{outputfile})) { - return($self->{opt}->{outputfile}->print($xml)); - } - else { - local(*OUT); - open(OUT, '>', "$self->{opt}->{outputfile}") || - croak "open($self->{opt}->{outputfile}): $!"; - binmode(OUT, ':utf8') if($] >= 5.008); - print OUT $xml || croak "print: $!"; - close(OUT); - } - } - elsif($self->{opt}->{handler}) { - require XML::SAX; - my $sp = XML::SAX::ParserFactory->parser( - Handler => $self->{opt}->{handler} - ); - return($sp->parse_string($xml)); - } - else { - return($xml); - } -} - - -############################################################################## -# Method: handle_options() -# -# Helper routine for both XMLin() and XMLout(). Both routines handle their -# first argument and assume all other args are options handled by this routine. -# Saves a hash of options in $self->{opt}. -# -# If default options were passed to the constructor, they will be retrieved -# here and merged with options supplied to the method call. -# -# First argument should be the string 'in' or the string 'out'. -# -# Remaining arguments should be name=>value pairs. Sets up default values -# for options not supplied. Unrecognised options are a fatal error. -# - -sub handle_options { - my $self = shift; - my $dirn = shift; - - - # Determine valid options based on context - - my %known_opt; - if($dirn eq 'in') { - @known_opt{@KnownOptIn} = @KnownOptIn; - } - else { - @known_opt{@KnownOptOut} = @KnownOptOut; - } - - - # Store supplied options in hashref and weed out invalid ones - - if(@_ % 2) { - croak "Options must be name=>value pairs (odd number supplied)"; - } - my %raw_opt = @_; - my $opt = {}; - $self->{opt} = $opt; - - while(my($key, $val) = each %raw_opt) { - my $lkey = lc($key); - $lkey =~ s/_//g; - croak "Unrecognised option: $key" unless($known_opt{$lkey}); - $opt->{$lkey} = $val; - } - - - # Merge in options passed to constructor - - foreach (keys(%known_opt)) { - unless(exists($opt->{$_})) { - if(exists($self->{def_opt}->{$_})) { - $opt->{$_} = $self->{def_opt}->{$_}; - } - } - } - - - # Set sensible defaults if not supplied - - if(exists($opt->{rootname})) { - unless(defined($opt->{rootname})) { - $opt->{rootname} = ''; - } - } - else { - $opt->{rootname} = $DefRootName; - } - - if($opt->{xmldecl} and $opt->{xmldecl} eq '1') { - $opt->{xmldecl} = $DefXmlDecl; - } - - if(exists($opt->{contentkey})) { - if($opt->{contentkey} =~ m{^-(.*)$}) { - $opt->{contentkey} = $1; - $opt->{collapseagain} = 1; - } - } - else { - $opt->{contentkey} = $DefContentKey; - } - - unless(exists($opt->{normalisespace})) { - $opt->{normalisespace} = $opt->{normalizespace}; - } - $opt->{normalisespace} = 0 unless(defined($opt->{normalisespace})); - - # Cleanups for values assumed to be arrays later - - if($opt->{searchpath}) { - unless(ref($opt->{searchpath})) { - $opt->{searchpath} = [ $opt->{searchpath} ]; - } - } - else { - $opt->{searchpath} = [ ]; - } - - if($opt->{cache} and !ref($opt->{cache})) { - $opt->{cache} = [ $opt->{cache} ]; - } - if($opt->{cache}) { - $_ = lc($_) foreach (@{$opt->{cache}}); - } - - if(exists($opt->{parseropts})) { - if($^W) { - carp "Warning: " . - "'ParserOpts' is deprecated, contact the author if you need it"; - } - } - else { - $opt->{parseropts} = [ ]; - } - - - # Special cleanup for {forcearray} which could be regex, arrayref or boolean - # or left to default to 0 - - if(exists($opt->{forcearray})) { - if(ref($opt->{forcearray}) eq 'Regexp') { - $opt->{forcearray} = [ $opt->{forcearray} ]; - } - - if(ref($opt->{forcearray}) eq 'ARRAY') { - my @force_list = @{$opt->{forcearray}}; - if(@force_list) { - $opt->{forcearray} = {}; - foreach my $tag (@force_list) { - if(ref($tag) eq 'Regexp') { - push @{$opt->{forcearray}->{_regex}}, $tag; - } - else { - $opt->{forcearray}->{$tag} = 1; - } - } - } - else { - $opt->{forcearray} = 0; - } - } - else { - $opt->{forcearray} = ( $opt->{forcearray} ? 1 : 0 ); - } - } - else { - if($StrictMode and $dirn eq 'in') { - croak "No value specified for 'ForceArray' option in call to XML$dirn()"; - } - $opt->{forcearray} = 0; - } - - - # Special cleanup for {keyattr} which could be arrayref or hashref or left - # to default to arrayref - - if(exists($opt->{keyattr})) { - if(ref($opt->{keyattr})) { - if(ref($opt->{keyattr}) eq 'HASH') { - - # Make a copy so we can mess with it - - $opt->{keyattr} = { %{$opt->{keyattr}} }; - - - # Convert keyattr => { elem => '+attr' } - # to keyattr => { elem => [ 'attr', '+' ] } - - foreach my $el (keys(%{$opt->{keyattr}})) { - if($opt->{keyattr}->{$el} =~ /^(\+|-)?(.*)$/) { - $opt->{keyattr}->{$el} = [ $2, ($1 ? $1 : '') ]; - if($StrictMode and $dirn eq 'in') { - next if($opt->{forcearray} == 1); - next if(ref($opt->{forcearray}) eq 'HASH' - and $opt->{forcearray}->{$el}); - croak "<$el> set in KeyAttr but not in ForceArray"; - } - } - else { - delete($opt->{keyattr}->{$el}); # Never reached (famous last words?) - } - } - } - else { - if(@{$opt->{keyattr}} == 0) { - delete($opt->{keyattr}); - } - } - } - else { - $opt->{keyattr} = [ $opt->{keyattr} ]; - } - } - else { - if($StrictMode) { - croak "No value specified for 'KeyAttr' option in call to XML$dirn()"; - } - $opt->{keyattr} = [ @DefKeyAttr ]; - } - - - # Special cleanup for {valueattr} which could be arrayref or hashref - - if(exists($opt->{valueattr})) { - if(ref($opt->{valueattr}) eq 'ARRAY') { - $opt->{valueattrlist} = {}; - $opt->{valueattrlist}->{$_} = 1 foreach(@{ delete $opt->{valueattr} }); - } - } - - # make sure there's nothing weird in {grouptags} - - if($opt->{grouptags} and !UNIVERSAL::isa($opt->{grouptags}, 'HASH')) { - croak "Illegal value for 'GroupTags' option - expected a hashref"; - } - - - # Check the {variables} option is valid and initialise variables hash - - if($opt->{variables} and !UNIVERSAL::isa($opt->{variables}, 'HASH')) { - croak "Illegal value for 'Variables' option - expected a hashref"; - } - - if($opt->{variables}) { - $self->{_var_values} = { %{$opt->{variables}} }; - } - elsif($opt->{varattr}) { - $self->{_var_values} = {}; - } - -} - - -############################################################################## -# Method: find_xml_file() -# -# Helper routine for XMLin(). -# Takes a filename, and a list of directories, attempts to locate the file in -# the directories listed. -# Returns a full pathname on success; croaks on failure. -# - -sub find_xml_file { - my $self = shift; - my $file = shift; - my @search_path = @_; - - - my($filename, $filedir) = - File::Basename::fileparse($file); - - if($filename ne $file) { # Ignore searchpath if dir component - return($file) if(-e $file); - } - else { - my($path); - foreach $path (@search_path) { - my $fullpath = File::Spec->catfile($path, $file); - return($fullpath) if(-e $fullpath); - } - } - - # If user did not supply a search path, default to current directory - - if(!@search_path) { - return($file) if(-e $file); - croak "File does not exist: $file"; - } - - croak "Could not find $file in ", join(':', @search_path); -} - - -############################################################################## -# Method: collapse() -# -# Helper routine for XMLin(). This routine really comprises the 'smarts' (or -# value add) of this module. -# -# Takes the parse tree that XML::Parser produced from the supplied XML and -# recurses through it 'collapsing' unnecessary levels of indirection (nested -# arrays etc) to produce a data structure that is easier to work with. -# -# Elements in the original parser tree are represented as an element name -# followed by an arrayref. The first element of the array is a hashref -# containing the attributes. The rest of the array contains a list of any -# nested elements as name+arrayref pairs: -# -# <element name>, [ { <attribute hashref> }, <element name>, [ ... ], ... ] -# -# The special element name '0' (zero) flags text content. -# -# This routine cuts down the noise by discarding any text content consisting of -# only whitespace and then moves the nested elements into the attribute hash -# using the name of the nested element as the hash key and the collapsed -# version of the nested element as the value. Multiple nested elements with -# the same name will initially be represented as an arrayref, but this may be -# 'folded' into a hashref depending on the value of the keyattr option. -# - -sub collapse { - my $self = shift; - - - # Start with the hash of attributes - - my $attr = shift; - if($self->{opt}->{noattr}) { # Discard if 'noattr' set - $attr = {}; - } - elsif($self->{opt}->{normalisespace} == 2) { - while(my($key, $value) = each %$attr) { - $attr->{$key} = $self->normalise_space($value) - } - } - - - # Do variable substitutions - - if(my $var = $self->{_var_values}) { - while(my($key, $val) = each(%$attr)) { - $val =~ s{\$\{(\w+)\}}{ $self->get_var($1) }ge; - $attr->{$key} = $val; - } - } - - - # Roll up 'value' attributes (but only if no nested elements) - - if(!@_ and keys %$attr == 1) { - my($k) = keys %$attr; - if($self->{opt}->{valueattrlist} and $self->{opt}->{valueattrlist}->{$k}) { - return $attr->{$k}; - } - } - - - # Add any nested elements - - my($key, $val); - while(@_) { - $key = shift; - $val = shift; - - if(ref($val)) { - $val = $self->collapse(@$val); - next if(!defined($val) and $self->{opt}->{suppressempty}); - } - elsif($key eq '0') { - next if($val =~ m{^\s*$}s); # Skip all whitespace content - - $val = $self->normalise_space($val) - if($self->{opt}->{normalisespace} == 2); - - # do variable substitutions - - if(my $var = $self->{_var_values}) { - $val =~ s{\$\{(\w+)\}}{ $self->get_var($1) }ge; - } - - - # look for variable definitions - - if(my $var = $self->{opt}->{varattr}) { - if(exists $attr->{$var}) { - $self->set_var($attr->{$var}, $val); - } - } - - - # Collapse text content in element with no attributes to a string - - if(!%$attr and !@_) { - return($self->{opt}->{forcecontent} ? - { $self->{opt}->{contentkey} => $val } : $val - ); - } - $key = $self->{opt}->{contentkey}; - } - - - # Combine duplicate attributes into arrayref if required - - if(exists($attr->{$key})) { - if(UNIVERSAL::isa($attr->{$key}, 'ARRAY')) { - push(@{$attr->{$key}}, $val); - } - else { - $attr->{$key} = [ $attr->{$key}, $val ]; - } - } - elsif(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) { - $attr->{$key} = [ $val ]; - } - else { - if( $key ne $self->{opt}->{contentkey} - and ( - ($self->{opt}->{forcearray} == 1) - or ( - (ref($self->{opt}->{forcearray}) eq 'HASH') - and ( - $self->{opt}->{forcearray}->{$key} - or (grep $key =~ $_, @{$self->{opt}->{forcearray}->{_regex}}) - ) - ) - ) - ) { - $attr->{$key} = [ $val ]; - } - else { - $attr->{$key} = $val; - } - } - - } - - - # Turn arrayrefs into hashrefs if key fields present - - if($self->{opt}->{keyattr}) { - while(($key,$val) = each %$attr) { - if(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) { - $attr->{$key} = $self->array_to_hash($key, $val); - } - } - } - - - # disintermediate grouped tags - - if($self->{opt}->{grouptags}) { - while(my($key, $val) = each(%$attr)) { - next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1)); - next unless(exists($self->{opt}->{grouptags}->{$key})); - - my($child_key, $child_val) = %$val; - - if($self->{opt}->{grouptags}->{$key} eq $child_key) { - $attr->{$key}= $child_val; - } - } - } - - - # Fold hashes containing a single anonymous array up into just the array - - my $count = scalar keys %$attr; - if($count == 1 - and exists $attr->{anon} - and UNIVERSAL::isa($attr->{anon}, 'ARRAY') - ) { - return($attr->{anon}); - } - - - # Do the right thing if hash is empty, otherwise just return it - - if(!%$attr and exists($self->{opt}->{suppressempty})) { - if(defined($self->{opt}->{suppressempty}) and - $self->{opt}->{suppressempty} eq '') { - return(''); - } - return(undef); - } - - - # Roll up named elements with named nested 'value' attributes - - if($self->{opt}->{valueattr}) { - while(my($key, $val) = each(%$attr)) { - next unless($self->{opt}->{valueattr}->{$key}); - next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1)); - my($k) = keys %$val; - next unless($k eq $self->{opt}->{valueattr}->{$key}); - $attr->{$key} = $val->{$k}; - } - } - - return($attr) - -} - - -############################################################################## -# Method: set_var() -# -# Called when a variable definition is encountered in the XML. (A variable -# definition looks like <element attrname="name">value</element> where attrname -# matches the varattr setting). -# - -sub set_var { - my($self, $name, $value) = @_; - - $self->{_var_values}->{$name} = $value; -} - - -############################################################################## -# Method: get_var() -# -# Called during variable substitution to get the value for the named variable. -# - -sub get_var { - my($self, $name) = @_; - - my $value = $self->{_var_values}->{$name}; - return $value if(defined($value)); - - return '${' . $name . '}'; -} - - -############################################################################## -# Method: normalise_space() -# -# Strips leading and trailing whitespace and collapses sequences of whitespace -# characters to a single space. -# - -sub normalise_space { - my($self, $text) = @_; - - $text =~ s/^\s+//s; - $text =~ s/\s+$//s; - $text =~ s/\s\s+/ /sg; - - return $text; -} - - -############################################################################## -# Method: array_to_hash() -# -# Helper routine for collapse(). -# Attempts to 'fold' an array of hashes into an hash of hashes. Returns a -# reference to the hash on success or the original array if folding is -# not possible. Behaviour is controlled by 'keyattr' option. -# - -sub array_to_hash { - my $self = shift; - my $name = shift; - my $arrayref = shift; - - my $hashref = {}; - - my($i, $key, $val, $flag); - - - # Handle keyattr => { .... } - - if(ref($self->{opt}->{keyattr}) eq 'HASH') { - return($arrayref) unless(exists($self->{opt}->{keyattr}->{$name})); - ($key, $flag) = @{$self->{opt}->{keyattr}->{$name}}; - for($i = 0; $i < @$arrayref; $i++) { - if(UNIVERSAL::isa($arrayref->[$i], 'HASH') and - exists($arrayref->[$i]->{$key}) - ) { - $val = $arrayref->[$i]->{$key}; - if(ref($val)) { - if($StrictMode) { - croak "<$name> element has non-scalar '$key' key attribute"; - } - if($^W) { - carp "Warning: <$name> element has non-scalar '$key' key attribute"; - } - return($arrayref); - } - $val = $self->normalise_space($val) - if($self->{opt}->{normalisespace} == 1); - $hashref->{$val} = { %{$arrayref->[$i]} }; - $hashref->{$val}->{"-$key"} = $hashref->{$val}->{$key} if($flag eq '-'); - delete $hashref->{$val}->{$key} unless($flag eq '+'); - } - else { - croak "<$name> element has no '$key' key attribute" if($StrictMode); - carp "Warning: <$name> element has no '$key' key attribute" if($^W); - return($arrayref); - } - } - } - - - # Or assume keyattr => [ .... ] - - else { - ELEMENT: for($i = 0; $i < @$arrayref; $i++) { - return($arrayref) unless(UNIVERSAL::isa($arrayref->[$i], 'HASH')); - - foreach $key (@{$self->{opt}->{keyattr}}) { - if(defined($arrayref->[$i]->{$key})) { - $val = $arrayref->[$i]->{$key}; - return($arrayref) if(ref($val)); - $val = $self->normalise_space($val) - if($self->{opt}->{normalisespace} == 1); - $hashref->{$val} = { %{$arrayref->[$i]} }; - delete $hashref->{$val}->{$key}; - next ELEMENT; - } - } - - return($arrayref); # No keyfield matched - } - } - - # collapse any hashes which now only have a 'content' key - - if($self->{opt}->{collapseagain}) { - $hashref = $self->collapse_content($hashref); - } - - return($hashref); -} - - -############################################################################## -# Method: collapse_content() -# -# Helper routine for array_to_hash -# -# Arguments expected are: -# - an XML::Simple object -# - a hasref -# the hashref is a former array, turned into a hash by array_to_hash because -# of the presence of key attributes -# at this point collapse_content avoids over-complicated structures like -# dir => { libexecdir => { content => '$exec_prefix/libexec' }, -# localstatedir => { content => '$prefix' }, -# } -# into -# dir => { libexecdir => '$exec_prefix/libexec', -# localstatedir => '$prefix', -# } - -sub collapse_content { - my $self = shift; - my $hashref = shift; - - my $contentkey = $self->{opt}->{contentkey}; - - # first go through the values,checking that they are fit to collapse - foreach my $val (values %$hashref) { - return $hashref unless ( (ref($val) eq 'HASH') - and (keys %$val == 1) - and (exists $val->{$contentkey}) - ); - } - - # now collapse them - foreach my $key (keys %$hashref) { - $hashref->{$key}= $hashref->{$key}->{$contentkey}; - } - - return $hashref; -} - - -############################################################################## -# Method: value_to_xml() -# -# Helper routine for XMLout() - recurses through a data structure building up -# and returning an XML representation of that structure as a string. -# -# Arguments expected are: -# - the data structure to be encoded (usually a reference) -# - the XML tag name to use for this item -# - a string of spaces for use as the current indent level -# - -sub value_to_xml { - my $self = shift;; - - - # Grab the other arguments - - my($ref, $name, $indent) = @_; - - my $named = (defined($name) and $name ne '' ? 1 : 0); - - my $nl = "\n"; - - my $is_root = $indent eq '' ? 1 : 0; # Warning, dirty hack! - if($self->{opt}->{noindent}) { - $indent = ''; - $nl = ''; - } - - - # Convert to XML - - if(ref($ref)) { - croak "circular data structures not supported" - if(grep($_ == $ref, @{$self->{_ancestors}})); - push @{$self->{_ancestors}}, $ref; - } - else { - if($named) { - return(join('', - $indent, '<', $name, '>', - ($self->{opt}->{noescape} ? $ref : $self->escape_value($ref)), - '</', $name, ">", $nl - )); - } - else { - return("$ref$nl"); - } - } - - - # Unfold hash to array if possible - - if(UNIVERSAL::isa($ref, 'HASH') # It is a hash - and keys %$ref # and it's not empty - and $self->{opt}->{keyattr} # and folding is enabled - and !$is_root # and its not the root element - ) { - $ref = $self->hash_to_array($name, $ref); - } - - - my @result = (); - my($key, $value); - - - # Handle hashrefs - - if(UNIVERSAL::isa($ref, 'HASH')) { - - # Reintermediate grouped values if applicable - - if($self->{opt}->{grouptags}) { - $ref = $self->copy_hash($ref); - while(my($key, $val) = each %$ref) { - if($self->{opt}->{grouptags}->{$key}) { - $ref->{$key} = { $self->{opt}->{grouptags}->{$key} => $val }; - } - } - } - - - # Scan for namespace declaration attributes - - my $nsdecls = ''; - my $default_ns_uri; - if($self->{nsup}) { - $ref = $self->copy_hash($ref); - $self->{nsup}->push_context(); - - # Look for default namespace declaration first - - if(exists($ref->{xmlns})) { - $self->{nsup}->declare_prefix('', $ref->{xmlns}); - $nsdecls .= qq( xmlns="$ref->{xmlns}"); - delete($ref->{xmlns}); - } - $default_ns_uri = $self->{nsup}->get_uri(''); - - - # Then check all the other keys - - foreach my $qname (keys(%$ref)) { - my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname); - if($uri) { - if($uri eq $xmlns_ns) { - $self->{nsup}->declare_prefix($lname, $ref->{$qname}); - $nsdecls .= qq( xmlns:$lname="$ref->{$qname}"); - delete($ref->{$qname}); - } - } - } - - # Translate any remaining Clarkian names - - foreach my $qname (keys(%$ref)) { - my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname); - if($uri) { - if($default_ns_uri and $uri eq $default_ns_uri) { - $ref->{$lname} = $ref->{$qname}; - delete($ref->{$qname}); - } - else { - my $prefix = $self->{nsup}->get_prefix($uri); - unless($prefix) { - # $self->{nsup}->declare_prefix(undef, $uri); - # $prefix = $self->{nsup}->get_prefix($uri); - $prefix = $self->{ns_prefix}++; - $self->{nsup}->declare_prefix($prefix, $uri); - $nsdecls .= qq( xmlns:$prefix="$uri"); - } - $ref->{"$prefix:$lname"} = $ref->{$qname}; - delete($ref->{$qname}); - } - } - } - } - - - my @nested = (); - my $text_content = undef; - if($named) { - push @result, $indent, '<', $name, $nsdecls; - } - - if(keys %$ref) { - my $first_arg = 1; - foreach my $key ($self->sorted_keys($name, $ref)) { - my $value = $ref->{$key}; - next if(substr($key, 0, 1) eq '-'); - if(!defined($value)) { - next if $self->{opt}->{suppressempty}; - unless(exists($self->{opt}->{suppressempty}) - and !defined($self->{opt}->{suppressempty}) - ) { - carp 'Use of uninitialized value' if($^W); - } - if($key eq $self->{opt}->{contentkey}) { - $text_content = ''; - } - else { - $value = exists($self->{opt}->{suppressempty}) ? {} : ''; - } - } - - if(!ref($value) - and $self->{opt}->{valueattr} - and $self->{opt}->{valueattr}->{$key} - ) { - $value = { $self->{opt}->{valueattr}->{$key} => $value }; - } - - if(ref($value) or $self->{opt}->{noattr}) { - push @nested, - $self->value_to_xml($value, $key, "$indent "); - } - else { - $value = $self->escape_value($value) unless($self->{opt}->{noescape}); - if($key eq $self->{opt}->{contentkey}) { - $text_content = $value; - } - else { - push @result, "\n$indent " . ' ' x length($name) - if($self->{opt}->{attrindent} and !$first_arg); - push @result, ' ', $key, '="', $value , '"'; - $first_arg = 0; - } - } - } - } - else { - $text_content = ''; - } - - if(@nested or defined($text_content)) { - if($named) { - push @result, ">"; - if(defined($text_content)) { - push @result, $text_content; - $nested[0] =~ s/^\s+// if(@nested); - } - else { - push @result, $nl; - } - if(@nested) { - push @result, @nested, $indent; - } - push @result, '</', $name, ">", $nl; - } - else { - push @result, @nested; # Special case if no root elements - } - } - else { - push @result, " />", $nl; - } - $self->{nsup}->pop_context() if($self->{nsup}); - } - - - # Handle arrayrefs - - elsif(UNIVERSAL::isa($ref, 'ARRAY')) { - foreach $value (@$ref) { - if(!ref($value)) { - push @result, - $indent, '<', $name, '>', - ($self->{opt}->{noescape} ? $value : $self->escape_value($value)), - '</', $name, ">$nl"; - } - elsif(UNIVERSAL::isa($value, 'HASH')) { - push @result, $self->value_to_xml($value, $name, $indent); - } - else { - push @result, - $indent, '<', $name, ">$nl", - $self->value_to_xml($value, 'anon', "$indent "), - $indent, '</', $name, ">$nl"; - } - } - } - - else { - croak "Can't encode a value of type: " . ref($ref); - } - - - pop @{$self->{_ancestors}} if(ref($ref)); - - return(join('', @result)); -} - - -############################################################################## -# Method: sorted_keys() -# -# Returns the keys of the referenced hash sorted into alphabetical order, but -# with the 'key' key (as in KeyAttr) first, if there is one. -# - -sub sorted_keys { - my($self, $name, $ref) = @_; - - return keys %$ref if $self->{opt}->{nosort}; - - my %hash = %$ref; - my $keyattr = $self->{opt}->{keyattr}; - - my @key; - - if(ref $keyattr eq 'HASH') { - if(exists $keyattr->{$name} and exists $hash{$keyattr->{$name}->[0]}) { - push @key, $keyattr->{$name}->[0]; - delete $hash{$keyattr->{$name}->[0]}; - } - } - elsif(ref $keyattr eq 'ARRAY') { - foreach (@{$keyattr}) { - if(exists $hash{$_}) { - push @key, $_; - delete $hash{$_}; - last; - } - } - } - - return(@key, sort keys %hash); -} - -############################################################################## -# Method: escape_value() -# -# Helper routine for automatically escaping values for XMLout(). -# Expects a scalar data value. Returns escaped version. -# - -sub escape_value { - my($self, $data) = @_; - - return '' unless(defined($data)); - - $data =~ s/&/&/sg; - $data =~ s/</</sg; - $data =~ s/>/>/sg; - $data =~ s/"/"/sg; - - my $level = $self->{opt}->{numericescape} or return $data; - - return $self->numeric_escape($data, $level); -} - -sub numeric_escape { - my($self, $data, $level) = @_; - - use utf8; # required for 5.6 - - if($self->{opt}->{numericescape} eq '2') { - $data =~ s/([^\x00-\x7F])/'&#' . ord($1) . ';'/gse; - } - else { - $data =~ s/([^\x00-\xFF])/'&#' . ord($1) . ';'/gse; - } - - return $data; -} - - -############################################################################## -# Method: hash_to_array() -# -# Helper routine for value_to_xml(). -# Attempts to 'unfold' a hash of hashes into an array of hashes. Returns a -# reference to the array on success or the original hash if unfolding is -# not possible. -# - -sub hash_to_array { - my $self = shift; - my $parent = shift; - my $hashref = shift; - - my $arrayref = []; - - my($key, $value); - - my @keys = $self->{opt}->{nosort} ? keys %$hashref : sort keys %$hashref; - foreach $key (@keys) { - $value = $hashref->{$key}; - return($hashref) unless(UNIVERSAL::isa($value, 'HASH')); - - if(ref($self->{opt}->{keyattr}) eq 'HASH') { - return($hashref) unless(defined($self->{opt}->{keyattr}->{$parent})); - push @$arrayref, $self->copy_hash( - $value, $self->{opt}->{keyattr}->{$parent}->[0] => $key - ); - } - else { - push(@$arrayref, { $self->{opt}->{keyattr}->[0] => $key, %$value }); - } - } - - return($arrayref); -} - - -############################################################################## -# Method: copy_hash() -# -# Helper routine for hash_to_array(). When unfolding a hash of hashes into -# an array of hashes, we need to copy the key from the outer hash into the -# inner hash. This routine makes a copy of the original hash so we don't -# destroy the original data structure. You might wish to override this -# method if you're using tied hashes and don't want them to get untied. -# - -sub copy_hash { - my($self, $orig, @extra) = @_; - - return { @extra, %$orig }; -} - -############################################################################## -# Methods required for building trees from SAX events -############################################################################## - -sub start_document { - my $self = shift; - - $self->handle_options('in') unless($self->{opt}); - - $self->{lists} = []; - $self->{curlist} = $self->{tree} = []; -} - - -sub start_element { - my $self = shift; - my $element = shift; - - my $name = $element->{Name}; - if($self->{opt}->{nsexpand}) { - $name = $element->{LocalName} || ''; - if($element->{NamespaceURI}) { - $name = '{' . $element->{NamespaceURI} . '}' . $name; - } - } - my $attributes = {}; - if($element->{Attributes}) { # Might be undef - foreach my $attr (values %{$element->{Attributes}}) { - if($self->{opt}->{nsexpand}) { - my $name = $attr->{LocalName} || ''; - if($attr->{NamespaceURI}) { - $name = '{' . $attr->{NamespaceURI} . '}' . $name - } - $name = 'xmlns' if($name eq $bad_def_ns_jcn); - $attributes->{$name} = $attr->{Value}; - } - else { - $attributes->{$attr->{Name}} = $attr->{Value}; - } - } - } - my $newlist = [ $attributes ]; - push @{ $self->{lists} }, $self->{curlist}; - push @{ $self->{curlist} }, $name => $newlist; - $self->{curlist} = $newlist; -} - - -sub characters { - my $self = shift; - my $chars = shift; - - my $text = $chars->{Data}; - my $clist = $self->{curlist}; - my $pos = $#$clist; - - if ($pos > 0 and $clist->[$pos - 1] eq '0') { - $clist->[$pos] .= $text; - } - else { - push @$clist, 0 => $text; - } -} - - -sub end_element { - my $self = shift; - - $self->{curlist} = pop @{ $self->{lists} }; -} - - -sub end_document { - my $self = shift; - - delete($self->{curlist}); - delete($self->{lists}); - - my $tree = $self->{tree}; - delete($self->{tree}); - - - # Return tree as-is to XMLin() - - return($tree) if($self->{nocollapse}); - - - # Or collapse it before returning it to SAX parser class - - if($self->{opt}->{keeproot}) { - $tree = $self->collapse({}, @$tree); - } - else { - $tree = $self->collapse(@{$tree->[1]}); - } - - if($self->{opt}->{datahandler}) { - return($self->{opt}->{datahandler}->($self, $tree)); - } - - return($tree); -} - -*xml_in = \&XMLin; -*xml_out = \&XMLout; - -1; - -__END__ - -=head1 QUICK START - -Say you have a script called B<foo> and a file of configuration options -called B<foo.xml> containing this: - - <config logdir="/var/log/foo/" debugfile="/tmp/foo.debug"> - <server name="sahara" osname="solaris" osversion="2.6"> - <address>10.0.0.101</address> - <address>10.0.1.101</address> - </server> - <server name="gobi" osname="irix" osversion="6.5"> - <address>10.0.0.102</address> - </server> - <server name="kalahari" osname="linux" osversion="2.0.34"> - <address>10.0.0.103</address> - <address>10.0.1.103</address> - </server> - </config> - -The following lines of code in B<foo>: - - use XML::Simple; - - my $config = XMLin(); - -will 'slurp' the configuration options into the hashref $config (because no -arguments are passed to C<XMLin()> the name and location of the XML file will -be inferred from name and location of the script). You can dump out the -contents of the hashref using Data::Dumper: - - use Data::Dumper; - - print Dumper($config); - -which will produce something like this (formatting has been adjusted for -brevity): - - { - 'logdir' => '/var/log/foo/', - 'debugfile' => '/tmp/foo.debug', - 'server' => { - 'sahara' => { - 'osversion' => '2.6', - 'osname' => 'solaris', - 'address' => [ '10.0.0.101', '10.0.1.101' ] - }, - 'gobi' => { - 'osversion' => '6.5', - 'osname' => 'irix', - 'address' => '10.0.0.102' - }, - 'kalahari' => { - 'osversion' => '2.0.34', - 'osname' => 'linux', - 'address' => [ '10.0.0.103', '10.0.1.103' ] - } - } - } - -Your script could then access the name of the log directory like this: - - print $config->{logdir}; - -similarly, the second address on the server 'kalahari' could be referenced as: - - print $config->{server}->{kalahari}->{address}->[1]; - -What could be simpler? (Rhetorical). - -For simple requirements, that's really all there is to it. If you want to -store your XML in a different directory or file, or pass it in as a string or -even pass it in via some derivative of an IO::Handle, you'll need to check out -L<"OPTIONS">. If you want to turn off or tweak the array folding feature (that -neat little transformation that produced $config->{server}) you'll find options -for that as well. - -If you want to generate XML (for example to write a modified version of -$config back out as XML), check out C<XMLout()>. - -If your needs are not so simple, this may not be the module for you. In that -case, you might want to read L<"WHERE TO FROM HERE?">. - -=head1 DESCRIPTION - -The XML::Simple module provides a simple API layer on top of an underlying XML -parsing module (either XML::Parser or one of the SAX2 parser modules). Two -functions are exported: C<XMLin()> and C<XMLout()>. Note: you can explicity -request the lower case versions of the function names: C<xml_in()> and -C<xml_out()>. - -The simplest approach is to call these two functions directly, but an -optional object oriented interface (see L<"OPTIONAL OO INTERFACE"> below) -allows them to be called as methods of an B<XML::Simple> object. The object -interface can also be used at either end of a SAX pipeline. - -=head2 XMLin() - -Parses XML formatted data and returns a reference to a data structure which -contains the same information in a more readily accessible form. (Skip -down to L<"EXAMPLES"> below, for more sample code). - -C<XMLin()> accepts an optional XML specifier followed by zero or more 'name => -value' option pairs. The XML specifier can be one of the following: - -=over 4 - -=item A filename - -If the filename contains no directory components C<XMLin()> will look for the -file in each directory in the SearchPath (see L<"OPTIONS"> below) or in the -current directory if the SearchPath option is not defined. eg: - - $ref = XMLin('/etc/params.xml'); - -Note, the filename '-' can be used to parse from STDIN. - -=item undef - -If there is no XML specifier, C<XMLin()> will check the script directory and -each of the SearchPath directories for a file with the same name as the script -but with the extension '.xml'. Note: if you wish to specify options, you -must specify the value 'undef'. eg: - - $ref = XMLin(undef, ForceArray => 1); - -=item A string of XML - -A string containing XML (recognised by the presence of '<' and '>' characters) -will be parsed directly. eg: - - $ref = XMLin('<opt username="bob" password="flurp" />'); - -=item An IO::Handle object - -An IO::Handle object will be read to EOF and its contents parsed. eg: - - $fh = new IO::File('/etc/params.xml'); - $ref = XMLin($fh); - -=back - -=head2 XMLout() - -Takes a data structure (generally a hashref) and returns an XML encoding of -that structure. If the resulting XML is parsed using C<XMLin()>, it should -return a data structure equivalent to the original (see caveats below). - -The C<XMLout()> function can also be used to output the XML as SAX events -see the C<Handler> option and L<"SAX SUPPORT"> for more details). - -When translating hashes to XML, hash keys which have a leading '-' will be -silently skipped. This is the approved method for marking elements of a -data structure which should be ignored by C<XMLout>. (Note: If these items -were not skipped the key names would be emitted as element or attribute names -with a leading '-' which would not be valid XML). - -=head2 Caveats - -Some care is required in creating data structures which will be passed to -C<XMLout()>. Hash keys from the data structure will be encoded as either XML -element names or attribute names. Therefore, you should use hash key names -which conform to the relatively strict XML naming rules: - -Names in XML must begin with a letter. The remaining characters may be -letters, digits, hyphens (-), underscores (_) or full stops (.). It is also -allowable to include one colon (:) in an element name but this should only be -used when working with namespaces (B<XML::Simple> can only usefully work with -namespaces when teamed with a SAX Parser). - -You can use other punctuation characters in hash values (just not in hash -keys) however B<XML::Simple> does not support dumping binary data. - -If you break these rules, the current implementation of C<XMLout()> will -simply emit non-compliant XML which will be rejected if you try to read it -back in. (A later version of B<XML::Simple> might take a more proactive -approach). - -Note also that although you can nest hashes and arrays to arbitrary levels, -circular data structures are not supported and will cause C<XMLout()> to die. - -If you wish to 'round-trip' arbitrary data structures from Perl to XML and back -to Perl, then you should probably disable array folding (using the KeyAttr -option) both with C<XMLout()> and with C<XMLin()>. If you still don't get the -expected results, you may prefer to use L<XML::Dumper> which is designed for -exactly that purpose. - -Refer to L<"WHERE TO FROM HERE?"> if C<XMLout()> is too simple for your needs. - - -=head1 OPTIONS - -B<XML::Simple> supports a number of options (in fact as each release of -B<XML::Simple> adds more options, the module's claim to the name 'Simple' -becomes increasingly tenuous). If you find yourself repeatedly having to -specify the same options, you might like to investigate L<"OPTIONAL OO -INTERFACE"> below. - -If you can't be bothered reading the documentation, refer to -L<"STRICT MODE"> to automatically catch common mistakes. - -Because there are so many options, it's hard for new users to know which ones -are important, so here are the two you really need to know about: - -=over 4 - -=item * - -check out C<ForceArray> because you'll almost certainly want to turn it on - -=item * - -make sure you know what the C<KeyAttr> option does and what its default value is -because it may surprise you otherwise (note in particular that 'KeyAttr' -affects both C<XMLin> and C<XMLout>) - -=back - -The option name headings below have a trailing 'comment' - a hash followed by -two pieces of metadata: - -=over 4 - -=item * - -Options are marked with 'I<in>' if they are recognised by C<XMLin()> and -'I<out>' if they are recognised by C<XMLout()>. - -=item * - -Each option is also flagged to indicate whether it is: - - 'important' - don't use the module until you understand this one - 'handy' - you can skip this on the first time through - 'advanced' - you can skip this on the second time through - 'SAX only' - don't worry about this unless you're using SAX (or - alternatively if you need this, you also need SAX) - 'seldom used' - you'll probably never use this unless you were the - person that requested the feature - -=back - -The options are listed alphabetically: - -Note: option names are no longer case sensitive so you can use the mixed case -versions shown here; all lower case as required by versions 2.03 and earlier; -or you can add underscores between the words (eg: key_attr). - - -=head2 AttrIndent => 1 I<# out - handy> - -When you are using C<XMLout()>, enable this option to have attributes printed -one-per-line with sensible indentation rather than all on one line. - -=head2 Cache => [ cache schemes ] I<# in - advanced> - -Because loading the B<XML::Parser> module and parsing an XML file can consume a -significant number of CPU cycles, it is often desirable to cache the output of -C<XMLin()> for later reuse. - -When parsing from a named file, B<XML::Simple> supports a number of caching -schemes. The 'Cache' option may be used to specify one or more schemes (using -an anonymous array). Each scheme will be tried in turn in the hope of finding -a cached pre-parsed representation of the XML file. If no cached copy is -found, the file will be parsed and the first cache scheme in the list will be -used to save a copy of the results. The following cache schemes have been -implemented: - -=over 4 - -=item storable - -Utilises B<Storable.pm> to read/write a cache file with the same name as the -XML file but with the extension .stor - -=item memshare - -When a file is first parsed, a copy of the resulting data structure is retained -in memory in the B<XML::Simple> module's namespace. Subsequent calls to parse -the same file will return a reference to this structure. This cached version -will persist only for the life of the Perl interpreter (which in the case of -mod_perl for example, may be some significant time). - -Because each caller receives a reference to the same data structure, a change -made by one caller will be visible to all. For this reason, the reference -returned should be treated as read-only. - -=item memcopy - -This scheme works identically to 'memshare' (above) except that each caller -receives a reference to a new data structure which is a copy of the cached -version. Copying the data structure will add a little processing overhead, -therefore this scheme should only be used where the caller intends to modify -the data structure (or wishes to protect itself from others who might). This -scheme uses B<Storable.pm> to perform the copy. - -=back - -Warning! The memory-based caching schemes compare the timestamp on the file to -the time when it was last parsed. If the file is stored on an NFS filesystem -(or other network share) and the clock on the file server is not exactly -synchronised with the clock where your script is run, updates to the source XML -file may appear to be ignored. - -=head2 ContentKey => 'keyname' I<# in+out - seldom used> - -When text content is parsed to a hash value, this option let's you specify a -name for the hash key to override the default 'content'. So for example: - - XMLin('<opt one="1">Text</opt>', ContentKey => 'text') - -will parse to: - - { 'one' => 1, 'text' => 'Text' } - -instead of: - - { 'one' => 1, 'content' => 'Text' } - -C<XMLout()> will also honour the value of this option when converting a hashref -to XML. - -You can also prefix your selected key name with a '-' character to have -C<XMLin()> try a little harder to eliminate unnecessary 'content' keys after -array folding. For example: - - XMLin( - '<opt><item name="one">First</item><item name="two">Second</item></opt>', - KeyAttr => {item => 'name'}, - ForceArray => [ 'item' ], - ContentKey => '-content' - ) - -will parse to: - - { - 'item' => { - 'one' => 'First' - 'two' => 'Second' - } - } - -rather than this (without the '-'): - - { - 'item' => { - 'one' => { 'content' => 'First' } - 'two' => { 'content' => 'Second' } - } - } - -=head2 DataHandler => code_ref I<# in - SAX only> - -When you use an B<XML::Simple> object as a SAX handler, it will return a -'simple tree' data structure in the same format as C<XMLin()> would return. If -this option is set (to a subroutine reference), then when the tree is built the -subroutine will be called and passed two arguments: a reference to the -B<XML::Simple> object and a reference to the data tree. The return value from -the subroutine will be returned to the SAX driver. (See L<"SAX SUPPORT"> for -more details). - -=head2 ForceArray => 1 I<# in - important> - -This option should be set to '1' to force nested elements to be represented -as arrays even when there is only one. Eg, with ForceArray enabled, this -XML: - - <opt> - <name>value</name> - </opt> - -would parse to this: - - { - 'name' => [ - 'value' - ] - } - -instead of this (the default): - - { - 'name' => 'value' - } - -This option is especially useful if the data structure is likely to be written -back out as XML and the default behaviour of rolling single nested elements up -into attributes is not desirable. - -If you are using the array folding feature, you should almost certainly enable -this option. If you do not, single nested elements will not be parsed to -arrays and therefore will not be candidates for folding to a hash. (Given that -the default value of 'KeyAttr' enables array folding, the default value of this -option should probably also have been enabled too - sorry). - -=head2 ForceArray => [ names ] I<# in - important> - -This alternative (and preferred) form of the 'ForceArray' option allows you to -specify a list of element names which should always be forced into an array -representation, rather than the 'all or nothing' approach above. - -It is also possible (since version 2.05) to include compiled regular -expressions in the list - any element names which match the pattern will be -forced to arrays. If the list contains only a single regex, then it is not -necessary to enclose it in an arrayref. Eg: - - ForceArray => qr/_list$/ - -=head2 ForceContent => 1 I<# in - seldom used> - -When C<XMLin()> parses elements which have text content as well as attributes, -the text content must be represented as a hash value rather than a simple -scalar. This option allows you to force text content to always parse to -a hash value even when there are no attributes. So for example: - - XMLin('<opt><x>text1</x><y a="2">text2</y></opt>', ForceContent => 1) - -will parse to: - - { - 'x' => { 'content' => 'text1' }, - 'y' => { 'a' => 2, 'content' => 'text2' } - } - -instead of: - - { - 'x' => 'text1', - 'y' => { 'a' => 2, 'content' => 'text2' } - } - -=head2 GroupTags => { grouping tag => grouped tag } I<# in+out - handy> - -You can use this option to eliminate extra levels of indirection in your Perl -data structure. For example this XML: - - <opt> - <searchpath> - <dir>/usr/bin</dir> - <dir>/usr/local/bin</dir> - <dir>/usr/X11/bin</dir> - </searchpath> - </opt> - -Would normally be read into a structure like this: - - { - searchpath => { - dir => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ] - } - } - -But when read in with the appropriate value for 'GroupTags': - - my $opt = XMLin($xml, GroupTags => { searchpath => 'dir' }); - -It will return this simpler structure: - - { - searchpath => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ] - } - -The grouping element (C<< <searchpath> >> in the example) must not contain any -attributes or elements other than the grouped element. - -You can specify multiple 'grouping element' to 'grouped element' mappings in -the same hashref. If this option is combined with C<KeyAttr>, the array -folding will occur first and then the grouped element names will be eliminated. - -C<XMLout> will also use the grouptag mappings to re-introduce the tags around -the grouped elements. Beware though that this will occur in all places that -the 'grouping tag' name occurs - you probably don't want to use the same name -for elements as well as attributes. - -=head2 Handler => object_ref I<# out - SAX only> - -Use the 'Handler' option to have C<XMLout()> generate SAX events rather than -returning a string of XML. For more details see L<"SAX SUPPORT"> below. - -Note: the current implementation of this option generates a string of XML -and uses a SAX parser to translate it into SAX events. The normal encoding -rules apply here - your data must be UTF8 encoded unless you specify an -alternative encoding via the 'XMLDecl' option; and by the time the data reaches -the handler object, it will be in UTF8 form regardless of the encoding you -supply. A future implementation of this option may generate the events -directly. - -=head2 KeepRoot => 1 I<# in+out - handy> - -In its attempt to return a data structure free of superfluous detail and -unnecessary levels of indirection, C<XMLin()> normally discards the root -element name. Setting the 'KeepRoot' option to '1' will cause the root element -name to be retained. So after executing this code: - - $config = XMLin('<config tempdir="/tmp" />', KeepRoot => 1) - -You'll be able to reference the tempdir as -C<$config-E<gt>{config}-E<gt>{tempdir}> instead of the default -C<$config-E<gt>{tempdir}>. - -Similarly, setting the 'KeepRoot' option to '1' will tell C<XMLout()> that the -data structure already contains a root element name and it is not necessary to -add another. - -=head2 KeyAttr => [ list ] I<# in+out - important> - -This option controls the 'array folding' feature which translates nested -elements from an array to a hash. It also controls the 'unfolding' of hashes -to arrays. - -For example, this XML: - - <opt> - <user login="grep" fullname="Gary R Epstein" /> - <user login="stty" fullname="Simon T Tyson" /> - </opt> - -would, by default, parse to this: - - { - 'user' => [ - { - 'login' => 'grep', - 'fullname' => 'Gary R Epstein' - }, - { - 'login' => 'stty', - 'fullname' => 'Simon T Tyson' - } - ] - } - -If the option 'KeyAttr => "login"' were used to specify that the 'login' -attribute is a key, the same XML would parse to: - - { - 'user' => { - 'stty' => { - 'fullname' => 'Simon T Tyson' - }, - 'grep' => { - 'fullname' => 'Gary R Epstein' - } - } - } - -The key attribute names should be supplied in an arrayref if there is more -than one. C<XMLin()> will attempt to match attribute names in the order -supplied. C<XMLout()> will use the first attribute name supplied when -'unfolding' a hash into an array. - -Note 1: The default value for 'KeyAttr' is ['name', 'key', 'id']. If you do -not want folding on input or unfolding on output you must setting this option -to an empty list to disable the feature. - -Note 2: If you wish to use this option, you should also enable the -C<ForceArray> option. Without 'ForceArray', a single nested element will be -rolled up into a scalar rather than an array and therefore will not be folded -(since only arrays get folded). - -=head2 KeyAttr => { list } I<# in+out - important> - -This alternative (and preferred) method of specifiying the key attributes -allows more fine grained control over which elements are folded and on which -attributes. For example the option 'KeyAttr => { package => 'id' } will cause -any package elements to be folded on the 'id' attribute. No other elements -which have an 'id' attribute will be folded at all. - -Note: C<XMLin()> will generate a warning (or a fatal error in L<"STRICT MODE">) -if this syntax is used and an element which does not have the specified key -attribute is encountered (eg: a 'package' element without an 'id' attribute, to -use the example above). Warnings will only be generated if B<-w> is in force. - -Two further variations are made possible by prefixing a '+' or a '-' character -to the attribute name: - -The option 'KeyAttr => { user => "+login" }' will cause this XML: - - <opt> - <user login="grep" fullname="Gary R Epstein" /> - <user login="stty" fullname="Simon T Tyson" /> - </opt> - -to parse to this data structure: - - { - 'user' => { - 'stty' => { - 'fullname' => 'Simon T Tyson', - 'login' => 'stty' - }, - 'grep' => { - 'fullname' => 'Gary R Epstein', - 'login' => 'grep' - } - } - } - -The '+' indicates that the value of the key attribute should be copied rather -than moved to the folded hash key. - -A '-' prefix would produce this result: - - { - 'user' => { - 'stty' => { - 'fullname' => 'Simon T Tyson', - '-login' => 'stty' - }, - 'grep' => { - 'fullname' => 'Gary R Epstein', - '-login' => 'grep' - } - } - } - -As described earlier, C<XMLout> will ignore hash keys starting with a '-'. - -=head2 NoAttr => 1 I<# in+out - handy> - -When used with C<XMLout()>, the generated XML will contain no attributes. -All hash key/values will be represented as nested elements instead. - -When used with C<XMLin()>, any attributes in the XML will be ignored. - -=head2 NoEscape => 1 I<# out - seldom used> - -By default, C<XMLout()> will translate the characters 'E<lt>', 'E<gt>', '&' and -'"' to '<', '>', '&' and '"' respectively. Use this option to -suppress escaping (presumably because you've already escaped the data in some -more sophisticated manner). - -=head2 NoIndent => 1 I<# out - seldom used> - -Set this option to 1 to disable C<XMLout()>'s default 'pretty printing' mode. -With this option enabled, the XML output will all be on one line (unless there -are newlines in the data) - this may be easier for downstream processing. - -=head2 NoSort => 1 I<# out - seldom used> - -Newer versions of XML::Simple sort elements and attributes alphabetically (*), -by default. Enable this option to suppress the sorting - possibly for -backwards compatibility. - -* Actually, sorting is alphabetical but 'key' attribute or element names (as in -'KeyAttr') sort first. Also, when a hash of hashes is 'unfolded', the elements -are sorted alphabetically by the value of the key field. - -=head2 NormaliseSpace => 0 | 1 | 2 I<# in - handy> - -This option controls how whitespace in text content is handled. Recognised -values for the option are: - -=over 4 - -=item * - -0 = (default) whitespace is passed through unaltered (except of course for the -normalisation of whitespace in attribute values which is mandated by the XML -recommendation) - -=item * - -1 = whitespace is normalised in any value used as a hash key (normalising means -removing leading and trailing whitespace and collapsing sequences of whitespace -characters to a single space) - -=item * - -2 = whitespace is normalised in all text content - -=back - -Note: you can spell this option with a 'z' if that is more natural for you. - -=head2 NSExpand => 1 I<# in+out handy - SAX only> - -This option controls namespace expansion - the translation of element and -attribute names of the form 'prefix:name' to '{uri}name'. For example the -element name 'xsl:template' might be expanded to: -'{http://www.w3.org/1999/XSL/Transform}template'. - -By default, C<XMLin()> will return element names and attribute names exactly as -they appear in the XML. Setting this option to 1 will cause all element and -attribute names to be expanded to include their namespace prefix. - -I<Note: You must be using a SAX parser for this option to work (ie: it does not -work with XML::Parser)>. - -This option also controls whether C<XMLout()> performs the reverse translation -from '{uri}name' back to 'prefix:name'. The default is no translation. If -your data contains expanded names, you should set this option to 1 otherwise -C<XMLout> will emit XML which is not well formed. - -I<Note: You must have the XML::NamespaceSupport module installed if you want -C<XMLout()> to translate URIs back to prefixes>. - -=head2 NumericEscape => 0 | 1 | 2 I<# out - handy> - -Use this option to have 'high' (non-ASCII) characters in your Perl data -structure converted to numeric entities (eg: €) in the XML output. Three -levels are possible: - -0 - default: no numeric escaping (OK if you're writing out UTF8) - -1 - only characters above 0xFF are escaped (ie: characters in the 0x80-FF range are not escaped), possibly useful with ISO8859-1 output - -2 - all characters above 0x7F are escaped (good for plain ASCII output) - -=head2 OutputFile => <file specifier> I<# out - handy> - -The default behaviour of C<XMLout()> is to return the XML as a string. If you -wish to write the XML to a file, simply supply the filename using the -'OutputFile' option. - -This option also accepts an IO handle object - especially useful in Perl 5.8.0 -and later for output using an encoding other than UTF-8, eg: - - open my $fh, '>:encoding(iso-8859-1)', $path or die "open($path): $!"; - XMLout($ref, OutputFile => $fh); - -=head2 ParserOpts => [ XML::Parser Options ] I<# in - don't use this> - -I<Note: This option is now officially deprecated. If you find it useful, email -the author with an example of what you use it for. Do not use this option to -set the ProtocolEncoding, that's just plain wrong - fix the XML>. - -This option allows you to pass parameters to the constructor of the underlying -XML::Parser object (which of course assumes you're not using SAX). - -=head2 RootName => 'string' I<# out - handy> - -By default, when C<XMLout()> generates XML, the root element will be named -'opt'. This option allows you to specify an alternative name. - -Specifying either undef or the empty string for the RootName option will -produce XML with no root elements. In most cases the resulting XML fragment -will not be 'well formed' and therefore could not be read back in by C<XMLin()>. -Nevertheless, the option has been found to be useful in certain circumstances. - -=head2 SearchPath => [ list ] I<# in - handy> - -If you pass C<XMLin()> a filename, but the filename include no directory -component, you can use this option to specify which directories should be -searched to locate the file. You might use this option to search first in the -user's home directory, then in a global directory such as /etc. - -If a filename is provided to C<XMLin()> but SearchPath is not defined, the -file is assumed to be in the current directory. - -If the first parameter to C<XMLin()> is undefined, the default SearchPath -will contain only the directory in which the script itself is located. -Otherwise the default SearchPath will be empty. - -=head2 SuppressEmpty => 1 | '' | undef I<# in+out - handy> - -This option controls what C<XMLin()> should do with empty elements (no -attributes and no content). The default behaviour is to represent them as -empty hashes. Setting this option to a true value (eg: 1) will cause empty -elements to be skipped altogether. Setting the option to 'undef' or the empty -string will cause empty elements to be represented as the undefined value or -the empty string respectively. The latter two alternatives are a little -easier to test for in your code than a hash with no keys. - -The option also controls what C<XMLout()> does with undefined values. Setting -the option to undef causes undefined values to be output as empty elements -(rather than empty attributes), it also suppresses the generation of warnings -about undefined values. Setting the option to a true value (eg: 1) causes -undefined values to be skipped altogether on output. - -=head2 ValueAttr => [ names ] I<# in - handy> - -Use this option to deal elements which always have a single attribute and no -content. Eg: - - <opt> - <colour value="red" /> - <size value="XXL" /> - </opt> - -Setting C<< ValueAttr => [ 'value' ] >> will cause the above XML to parse to: - - { - colour => 'red', - size => 'XXL' - } - -instead of this (the default): - - { - colour => { value => 'red' }, - size => { value => 'XXL' } - } - -Note: This form of the ValueAttr option is not compatible with C<XMLout()> - -since the attribute name is discarded at parse time, the original XML cannot be -reconstructed. - -=head2 ValueAttr => { element => attribute, ... } I<# in+out - handy> - -This (preferred) form of the ValueAttr option requires you to specify both -the element and the attribute names. This is not only safer, it also allows -the original XML to be reconstructed by C<XMLout()>. - -Note: You probably don't want to use this option and the NoAttr option at the -same time. - -=head2 Variables => { name => value } I<# in - handy> - -This option allows variables in the XML to be expanded when the file is read. -(there is no facility for putting the variable names back if you regenerate -XML using C<XMLout>). - -A 'variable' is any text of the form C<${name}> which occurs in an attribute -value or in the text content of an element. If 'name' matches a key in the -supplied hashref, C<${name}> will be replaced with the corresponding value from -the hashref. If no matching key is found, the variable will not be replaced. - -=head2 VarAttr => 'attr_name' I<# in - handy> - -In addition to the variables defined using C<Variables>, this option allows -variables to be defined in the XML. A variable definition consists of an -element with an attribute called 'attr_name' (the value of the C<VarAttr> -option). The value of the attribute will be used as the variable name and the -text content of the element will be used as the value. A variable defined in -this way will override a variable defined using the C<Variables> option. For -example: - - XMLin( '<opt> - <dir name="prefix">/usr/local/apache</dir> - <dir name="exec_prefix">${prefix}</dir> - <dir name="bindir">${exec_prefix}/bin</dir> - </opt>', - VarAttr => 'name', ContentKey => '-content' - ); - -produces the following data structure: - - { - dir => { - prefix => '/usr/local/apache', - exec_prefix => '/usr/local/apache', - bindir => '/usr/local/apache/bin', - } - } - -=head2 XMLDecl => 1 or XMLDecl => 'string' I<# out - handy> - -If you want the output from C<XMLout()> to start with the optional XML -declaration, simply set the option to '1'. The default XML declaration is: - - <?xml version='1.0' standalone='yes'?> - -If you want some other string (for example to declare an encoding value), set -the value of this option to the complete string you require. - - -=head1 OPTIONAL OO INTERFACE - -The procedural interface is both simple and convenient however there are a -couple of reasons why you might prefer to use the object oriented (OO) -interface: - -=over 4 - -=item * - -to define a set of default values which should be used on all subsequent calls -to C<XMLin()> or C<XMLout()> - -=item * - -to override methods in B<XML::Simple> to provide customised behaviour - -=back - -The default values for the options described above are unlikely to suit -everyone. The OO interface allows you to effectively override B<XML::Simple>'s -defaults with your preferred values. It works like this: - -First create an XML::Simple parser object with your preferred defaults: - - my $xs = new XML::Simple(ForceArray => 1, KeepRoot => 1); - -then call C<XMLin()> or C<XMLout()> as a method of that object: - - my $ref = $xs->XMLin($xml); - my $xml = $xs->XMLout($ref); - -You can also specify options when you make the method calls and these values -will be merged with the values specified when the object was created. Values -specified in a method call take precedence. - -Overriding methods is a more advanced topic but might be useful if for example -you wished to provide an alternative routine for escaping character data (the -escape_value method) or for building the initial parse tree (the build_tree -method). - -Note: when called as methods, the C<XMLin()> and C<XMLout()> routines may be -called as C<xml_in()> or C<xml_out()>. The method names are aliased so the -only difference is the aesthetics. - -=head1 STRICT MODE - -If you import the B<XML::Simple> routines like this: - - use XML::Simple qw(:strict); - -the following common mistakes will be detected and treated as fatal errors - -=over 4 - -=item * - -Failing to explicitly set the C<KeyAttr> option - if you can't be bothered -reading about this option, turn it off with: KeyAttr => [ ] - -=item * - -Failing to explicitly set the C<ForceArray> option - if you can't be bothered -reading about this option, set it to the safest mode with: ForceArray => 1 - -=item * - -Setting ForceArray to an array, but failing to list all the elements from the -KeyAttr hash. - -=item * - -Data error - KeyAttr is set to say { part => 'partnum' } but the XML contains -one or more E<lt>partE<gt> elements without a 'partnum' attribute (or nested -element). Note: if strict mode is not set but -w is, this condition triggers a -warning. - -=item * - -Data error - as above, but value of key attribute (eg: partnum) is not a -scalar string (due to nested elements etc). This will also trigger a warning -if strict mode is not enabled. - -=back - -=head1 SAX SUPPORT - -From version 1.08_01, B<XML::Simple> includes support for SAX (the Simple API -for XML) - specifically SAX2. - -In a typical SAX application, an XML parser (or SAX 'driver') module generates -SAX events (start of element, character data, end of element, etc) as it parses -an XML document and a 'handler' module processes the events to extract the -required data. This simple model allows for some interesting and powerful -possibilities: - -=over 4 - -=item * - -Applications written to the SAX API can extract data from huge XML documents -without the memory overheads of a DOM or tree API. - -=item * - -The SAX API allows for plug and play interchange of parser modules without -having to change your code to fit a new module's API. A number of SAX parsers -are available with capabilities ranging from extreme portability to blazing -performance. - -=item * - -A SAX 'filter' module can implement both a handler interface for receiving -data and a generator interface for passing modified data on to a downstream -handler. Filters can be chained together in 'pipelines'. - -=item * - -One filter module might split a data stream to direct data to two or more -downstream handlers. - -=item * - -Generating SAX events is not the exclusive preserve of XML parsing modules. -For example, a module might extract data from a relational database using DBI -and pass it on to a SAX pipeline for filtering and formatting. - -=back - -B<XML::Simple> can operate at either end of a SAX pipeline. For example, -you can take a data structure in the form of a hashref and pass it into a -SAX pipeline using the 'Handler' option on C<XMLout()>: - - use XML::Simple; - use Some::SAX::Filter; - use XML::SAX::Writer; - - my $ref = { - .... # your data here - }; - - my $writer = XML::SAX::Writer->new(); - my $filter = Some::SAX::Filter->new(Handler => $writer); - my $simple = XML::Simple->new(Handler => $filter); - $simple->XMLout($ref); - -You can also put B<XML::Simple> at the opposite end of the pipeline to take -advantage of the simple 'tree' data structure once the relevant data has been -isolated through filtering: - - use XML::SAX; - use Some::SAX::Filter; - use XML::Simple; - - my $simple = XML::Simple->new(ForceArray => 1, KeyAttr => ['partnum']); - my $filter = Some::SAX::Filter->new(Handler => $simple); - my $parser = XML::SAX::ParserFactory->parser(Handler => $filter); - - my $ref = $parser->parse_uri('some_huge_file.xml'); - - print $ref->{part}->{'555-1234'}; - -You can build a filter by using an XML::Simple object as a handler and setting -its DataHandler option to point to a routine which takes the resulting tree, -modifies it and sends it off as SAX events to a downstream handler: - - my $writer = XML::SAX::Writer->new(); - my $filter = XML::Simple->new( - DataHandler => sub { - my $simple = shift; - my $data = shift; - - # Modify $data here - - $simple->XMLout($data, Handler => $writer); - } - ); - my $parser = XML::SAX::ParserFactory->parser(Handler => $filter); - - $parser->parse_uri($filename); - -I<Note: In this last example, the 'Handler' option was specified in the call to -C<XMLout()> but it could also have been specified in the constructor>. - -=head1 ENVIRONMENT - -If you don't care which parser module B<XML::Simple> uses then skip this -section entirely (it looks more complicated than it really is). - -B<XML::Simple> will default to using a B<SAX> parser if one is available or -B<XML::Parser> if SAX is not available. - -You can dictate which parser module is used by setting either the environment -variable 'XML_SIMPLE_PREFERRED_PARSER' or the package variable -$XML::Simple::PREFERRED_PARSER to contain the module name. The following rules -are used: - -=over 4 - -=item * - -The package variable takes precedence over the environment variable if both are defined. To force B<XML::Simple> to ignore the environment settings and use -its default rules, you can set the package variable to an empty string. - -=item * - -If the 'preferred parser' is set to the string 'XML::Parser', then -L<XML::Parser> will be used (or C<XMLin()> will die if L<XML::Parser> is not -installed). - -=item * - -If the 'preferred parser' is set to some other value, then it is assumed to be -the name of a SAX parser module and is passed to L<XML::SAX::ParserFactory.> -If L<XML::SAX> is not installed, or the requested parser module is not -installed, then C<XMLin()> will die. - -=item * - -If the 'preferred parser' is not defined at all (the normal default -state), an attempt will be made to load L<XML::SAX>. If L<XML::SAX> is -installed, then a parser module will be selected according to -L<XML::SAX::ParserFactory>'s normal rules (which typically means the last SAX -parser installed). - -=item * - -if the 'preferred parser' is not defined and B<XML::SAX> is not -installed, then B<XML::Parser> will be used. C<XMLin()> will die if -L<XML::Parser> is not installed. - -=back - -Note: The B<XML::SAX> distribution includes an XML parser written entirely in -Perl. It is very portable but it is not very fast. You should consider -installing L<XML::LibXML> or L<XML::SAX::Expat> if they are available for your -platform. - -=head1 ERROR HANDLING - -The XML standard is very clear on the issue of non-compliant documents. An -error in parsing any single element (for example a missing end tag) must cause -the whole document to be rejected. B<XML::Simple> will die with an appropriate -message if it encounters a parsing error. - -If dying is not appropriate for your application, you should arrange to call -C<XMLin()> in an eval block and look for errors in $@. eg: - - my $config = eval { XMLin() }; - PopUpMessage($@) if($@); - -Note, there is a common misconception that use of B<eval> will significantly -slow down a script. While that may be true when the code being eval'd is in a -string, it is not true of code like the sample above. - -=head1 EXAMPLES - -When C<XMLin()> reads the following very simple piece of XML: - - <opt username="testuser" password="frodo"></opt> - -it returns the following data structure: - - { - 'username' => 'testuser', - 'password' => 'frodo' - } - -The identical result could have been produced with this alternative XML: - - <opt username="testuser" password="frodo" /> - -Or this (although see 'ForceArray' option for variations): - - <opt> - <username>testuser</username> - <password>frodo</password> - </opt> - -Repeated nested elements are represented as anonymous arrays: - - <opt> - <person firstname="Joe" lastname="Smith"> - <email>joe@smith.com</email> - <email>jsmith@yahoo.com</email> - </person> - <person firstname="Bob" lastname="Smith"> - <email>bob@smith.com</email> - </person> - </opt> - - { - 'person' => [ - { - 'email' => [ - 'joe@smith.com', - 'jsmith@yahoo.com' - ], - 'firstname' => 'Joe', - 'lastname' => 'Smith' - }, - { - 'email' => 'bob@smith.com', - 'firstname' => 'Bob', - 'lastname' => 'Smith' - } - ] - } - -Nested elements with a recognised key attribute are transformed (folded) from -an array into a hash keyed on the value of that attribute (see the C<KeyAttr> -option): - - <opt> - <person key="jsmith" firstname="Joe" lastname="Smith" /> - <person key="tsmith" firstname="Tom" lastname="Smith" /> - <person key="jbloggs" firstname="Joe" lastname="Bloggs" /> - </opt> - - { - 'person' => { - 'jbloggs' => { - 'firstname' => 'Joe', - 'lastname' => 'Bloggs' - }, - 'tsmith' => { - 'firstname' => 'Tom', - 'lastname' => 'Smith' - }, - 'jsmith' => { - 'firstname' => 'Joe', - 'lastname' => 'Smith' - } - } - } - - -The <anon> tag can be used to form anonymous arrays: - - <opt> - <head><anon>Col 1</anon><anon>Col 2</anon><anon>Col 3</anon></head> - <data><anon>R1C1</anon><anon>R1C2</anon><anon>R1C3</anon></data> - <data><anon>R2C1</anon><anon>R2C2</anon><anon>R2C3</anon></data> - <data><anon>R3C1</anon><anon>R3C2</anon><anon>R3C3</anon></data> - </opt> - - { - 'head' => [ - [ 'Col 1', 'Col 2', 'Col 3' ] - ], - 'data' => [ - [ 'R1C1', 'R1C2', 'R1C3' ], - [ 'R2C1', 'R2C2', 'R2C3' ], - [ 'R3C1', 'R3C2', 'R3C3' ] - ] - } - -Anonymous arrays can be nested to arbirtrary levels and as a special case, if -the surrounding tags for an XML document contain only an anonymous array the -arrayref will be returned directly rather than the usual hashref: - - <opt> - <anon><anon>Col 1</anon><anon>Col 2</anon></anon> - <anon><anon>R1C1</anon><anon>R1C2</anon></anon> - <anon><anon>R2C1</anon><anon>R2C2</anon></anon> - </opt> - - [ - [ 'Col 1', 'Col 2' ], - [ 'R1C1', 'R1C2' ], - [ 'R2C1', 'R2C2' ] - ] - -Elements which only contain text content will simply be represented as a -scalar. Where an element has both attributes and text content, the element -will be represented as a hashref with the text content in the 'content' key -(see the C<ContentKey> option): - - <opt> - <one>first</one> - <two attr="value">second</two> - </opt> - - { - 'one' => 'first', - 'two' => { 'attr' => 'value', 'content' => 'second' } - } - -Mixed content (elements which contain both text content and nested elements) -will be not be represented in a useful way - element order and significant -whitespace will be lost. If you need to work with mixed content, then -XML::Simple is not the right tool for your job - check out the next section. - -=head1 WHERE TO FROM HERE? - -B<XML::Simple> is able to present a simple API because it makes some -assumptions on your behalf. These include: - -=over 4 - -=item * - -You're not interested in text content consisting only of whitespace - -=item * - -You don't mind that when things get slurped into a hash the order is lost - -=item * - -You don't want fine-grained control of the formatting of generated XML - -=item * - -You would never use a hash key that was not a legal XML element name - -=item * - -You don't need help converting between different encodings - -=back - -In a serious XML project, you'll probably outgrow these assumptions fairly -quickly. This section of the document used to offer some advice on chosing a -more powerful option. That advice has now grown into the 'Perl-XML FAQ' -document which you can find at: L<http://perl-xml.sourceforge.net/faq/> - -The advice in the FAQ boils down to a quick explanation of tree versus -event based parsers and then recommends: - -For event based parsing, use SAX (do not set out to write any new code for -XML::Parser's handler API - it is obselete). - -For tree-based parsing, you could choose between the 'Perlish' approach of -L<XML::Twig> and more standards based DOM implementations - preferably one with -XPath support. - - -=head1 SEE ALSO - -B<XML::Simple> requires either L<XML::Parser> or L<XML::SAX>. - -To generate documents with namespaces, L<XML::NamespaceSupport> is required. - -The optional caching functions require L<Storable>. - -Answers to Frequently Asked Questions about XML::Simple are bundled with this -distribution as: L<XML::Simple::FAQ> - -=head1 COPYRIGHT - -Copyright 1999-2004 Grant McLean E<lt>grantm@cpan.orgE<gt> - -This library is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -=cut - - diff --git a/lib/XML/Stream.pm b/lib/XML/Stream.pm deleted file mode 100644 index f95f784..0000000 --- a/lib/XML/Stream.pm +++ /dev/null @@ -1,3268 +0,0 @@ -############################################################################## -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Library General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Library General Public License for more details. -# -# You should have received a copy of the GNU Library General Public -# License along with this library; if not, write to the -# Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. -# -# Jabber -# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ -# -############################################################################## - -package XML::Stream; - -=head1 NAME - -XML::Stream - Creates and XML Stream connection and parses return data - -=head1 SYNOPSIS - - XML::Stream is an attempt at solidifying the use of XML via streaming. - -=head1 DESCRIPTION - - This module provides the user with methods to connect to a remote - server, send a stream of XML to the server, and receive/parse an XML - stream from the server. It is primarily based work for the Etherx XML - router developed by the Jabber Development Team. For more information - about this project visit http://etherx.jabber.org/stream/. - - XML::Stream gives the user the ability to define a central callback - that will be used to handle the tags received from the server. These - tags are passed in the format defined at instantiation time. - the closing tag of an object is seen, the tree is finished and passed - to the call back function. What the user does with it from there is up - to them. - - For a detailed description of how this module works, and about the data - structure that it returns, please view the source of Stream.pm and - look at the detailed description at the end of the file. - - - NOTE: The parser that XML::Stream::Parser provides, as are most Perl - parsers, is synchronous. If you are in the middle of parsing a - packet and call a user defined callback, the Parser is blocked until - your callback finishes. This means you cannot be operating on a - packet, send out another packet and wait for a response to that packet. - It will never get to you. Threading might solve this, but as we all - know threading in Perl is not quite up to par yet. This issue will be - revisted in the future. - - - -=head1 METHODS - - new(debug=>string, - creates the XML::Stream object. debug - debugfh=>FileHandle, should be set to the path for the debug log - debuglevel=>0|1|N, to be written. If set to "stdout" then the - debugtime=>0|1, debug will go there. Also, you can specify - style=>string) a filehandle that already exists byt using - debugfh. debuglevel determines the amount - of debug to generate. 0 is the least, 1 is - a little more, N is the limit you want. - debugtime determines wether a timestamp - should be preappended to the entry. style - defines the way the data structure is - returned. The two available styles are: - - tree - XML::Parser Tree format - node - XML::Stream::Node format - - For more information see the respective man - pages. - - Connect(hostname=>string, - opens a tcp connection to the - port=>integer, specified server and sends the proper - to=>string, opening XML Stream tag. hostname, - from=>string, port, and namespace are required. - myhostname=>string, namespaces allows you to use - namespace=>string, XML::Stream::Namespace objects. - namespaces=>array, to is needed if you want the stream - connectiontype=>string, to attribute to be something other - ssl=>0|1, than the hostname you are connecting - srv=>string) to. from is needed if you want the - stream from attribute to be something - other than the hostname you are - connecting from. myhostname should - not be needed but if the module - cannot determine your hostname - properly (check the debug log), set - this to the correct value, or if you - want the other side of the stream to - think that you are someone else. The - type determines the kind of - connection that is made: - "tcpip" - TCP/IP (default) - "stdinout" - STDIN/STDOUT - "http" - HTTP - HTTP recognizes proxies if the ENV - variables http_proxy or https_proxy - are set. ssl specifies if an SLL - socket should be used for encrypted - communications. This function - returns the same hash from GetRoot() - below. Make sure you get the SID - (Session ID) since you have to use it - to call most other functions in here. - - If srv is specified AND Net::DNS is - installed and can be loaded, then - an SRV query is sent to srv.hostname - and the results processed to replace - the hostname and port. If the lookup - fails, or Net::DNS cannot be loaded, - then hostname and port are left alone - as the defaults. - - - OpenFile(string) - opens a filehandle to the argument specified, and - pretends that it is a stream. It will ignore the - outer tag, and not check if it was a - <stream:stream/>. This is useful for writing a - program that has to parse any XML file that is - basically made up of small packets (like RDF). - - Disconnect(sid) - sends the proper closing XML tag and closes the - specified socket down. - - Process(integer) - waits for data to be available on the socket. If - a timeout is specified then the Process function - waits that period of time before returning nothing. - If a timeout period is not specified then the - function blocks until data is received. The - function returns a hash with session ids as the key, - and status values or data as the hash values. - - SetCallBacks(node=>function, - sets the callback that should be - update=>function) called in various situations. node - is used to handle the data structures - that are built for each top level tag. - Update is used for when Process is - blocking waiting for data, but you - want your original code to be updated. - - GetRoot(sid) - returns the attributes that the stream:stream tag sent - by the other end listed in a hash for the specified - session. - - GetSock(sid) - returns a pointer to the IO::Socket object for the - specified session. - - Send(sid, - sends the string over the specified connection as is. - string) This does no checking if valid XML was sent or not. - Best behavior when sending information. - - GetErrorCode(sid) - returns a string for the specified session that - will hopefully contain some useful information - about why Process or Connect returned an undef - to you. - - XPath(node,path) - returns an array of results that match the xpath. - node can be any of the three types (Tree, Node). - -=head1 VARIABLES - - $NONBLOCKING - tells the Parser to enter into a nonblocking state. This - might cause some funky behavior since you can get nested - callbacks while things are waiting. 1=on, 0=off(default). - -=head1 EXAMPLES - - ########################## - # simple example - - use XML::Stream qw( Tree ); - - $stream = new XML::Stream; - - my $status = $stream->Connect(hostname => "jabber.org", - port => 5222, - namespace => "jabber:client"); - - if (!defined($status)) { - print "ERROR: Could not connect to server\n"; - print " (",$stream->GetErrorCode(),")\n"; - exit(0); - } - - while($node = $stream->Process()) { - # do something with $node - } - - $stream->Disconnect(); - - - ########################### - # example using a handler - - use XML::Stream qw( Tree ); - - $stream = new XML::Stream; - $stream->SetCallBacks(node=>\&noder); - $stream->Connect(hostname => "jabber.org", - port => 5222, - namespace => "jabber:client", - timeout => undef) || die $!; - - # Blocks here forever, noder is called for incoming - # packets when they arrive. - while(defined($stream->Process())) { } - - print "ERROR: Stream died (",$stream->GetErrorCode(),")\n"; - - sub noder - { - my $sid = shift; - my $node = shift; - # do something with $node - } - -=head1 AUTHOR - -Tweaked, tuned, and brightness changes by Ryan Eatmon, reatmon@ti.com -in May of 2000. -Colorized, and Dolby Surround sound added by Thomas Charron, -tcharron@jabber.org -By Jeremie in October of 1999 for http://etherx.jabber.org/streams/ - -=head1 COPYRIGHT - -This module is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -use 5.006_001; -use strict; -use Sys::Hostname; -use IO::Socket; -use IO::Select; -use FileHandle; -use Carp; -use POSIX; -use Authen::SASL; -use MIME::Base64; -use utf8; -use Encode; - -$SIG{PIPE} = "IGNORE"; - -use vars qw($VERSION $PAC $SSL $NONBLOCKING %HANDLERS $NETDNS %XMLNS ); - -############################################################################## -# Define the namespaces in an easy/constant manner. -#----------------------------------------------------------------------------- -# 0.9 -#----------------------------------------------------------------------------- -$XMLNS{'stream'} = "http://etherx.jabber.org/streams"; - -#----------------------------------------------------------------------------- -# 1.0 -#----------------------------------------------------------------------------- -$XMLNS{'xmppstreams'} = "urn:ietf:params:xml:ns:xmpp-streams"; -$XMLNS{'xmpp-bind'} = "urn:ietf:params:xml:ns:xmpp-bind"; -$XMLNS{'xmpp-sasl'} = "urn:ietf:params:xml:ns:xmpp-sasl"; -$XMLNS{'xmpp-session'} = "urn:ietf:params:xml:ns:xmpp-session"; -$XMLNS{'xmpp-tls'} = "urn:ietf:params:xml:ns:xmpp-tls"; -############################################################################## - - -if (eval "require Net::DNS;" ) -{ - require Net::DNS; - import Net::DNS; - $NETDNS = 1; -} -else -{ - $NETDNS = 0; -} - - -$VERSION = "1.22"; -$NONBLOCKING = 0; - -use XML::Stream::Namespace; -use XML::Stream::Parser; -use XML::Stream::XPath; - -############################################################################## -# -# Setup the exportable objects -# -############################################################################## -require Exporter; -my @ISA = qw(Exporter); -my @EXPORT_OK = qw(Tree Node); - -sub import -{ - my $class = shift; - - foreach my $module (@_) - { - eval "use XML::Stream::$module;"; - die($@) if ($@); - - my $lc = lc($module); - - eval("\$HANDLERS{\$lc}->{startElement} = \\&XML::Stream::${module}::_handle_element;"); - eval("\$HANDLERS{\$lc}->{endElement} = \\&XML::Stream::${module}::_handle_close;"); - eval("\$HANDLERS{\$lc}->{characters} = \\&XML::Stream::${module}::_handle_cdata;"); - } -} - - -sub new -{ - my $proto = shift; - my $self = { }; - - bless($self,$proto); - - my %args; - while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } - - $self->{DATASTYLE} = "tree"; - $self->{DATASTYLE} = delete($args{style}) if exists($args{style}); - - if ((($self->{DATASTYLE} eq "tree") && !defined($XML::Stream::Tree::LOADED)) || - (($self->{DATASTYLE} eq "node") && !defined($XML::Stream::Node::LOADED)) - ) - { - croak("The style that you have chosen was not defined when you \"use\"d the module.\n"); - } - - $self->{DEBUGARGS} = \%args; - - $self->{DEBUGTIME} = 0; - $self->{DEBUGTIME} = $args{debugtime} if exists($args{debugtime}); - - $self->{DEBUGLEVEL} = 0; - $self->{DEBUGLEVEL} = $args{debuglevel} if exists($args{debuglevel}); - - $self->{DEBUGFILE} = ""; - - if (exists($args{debugfh}) && ($args{debugfh} ne "")) - { - $self->{DEBUGFILE} = $args{debugfh}; - $self->{DEBUG} = 1; - } - if ((exists($args{debugfh}) && ($args{debugfh} eq "")) || - (exists($args{debug}) && ($args{debug} ne ""))) - { - $self->{DEBUG} = 1; - if (lc($args{debug}) eq "stdout") - { - $self->{DEBUGFILE} = new FileHandle(">&STDERR"); - $self->{DEBUGFILE}->autoflush(1); - } - else - { - if (-e $args{debug}) - { - if (-w $args{debug}) - { - $self->{DEBUGFILE} = new FileHandle(">$args{debug}"); - $self->{DEBUGFILE}->autoflush(1); - } - else - { - print "WARNING: debug file ($args{debug}) is not writable by you\n"; - print " No debug information being saved.\n"; - $self->{DEBUG} = 0; - } - } - else - { - $self->{DEBUGFILE} = new FileHandle(">$args{debug}"); - if (defined($self->{DEBUGFILE})) - { - $self->{DEBUGFILE}->autoflush(1); - } - else - { - print "WARNING: debug file ($args{debug}) does not exist \n"; - print " and is not writable by you.\n"; - print " No debug information being saved.\n"; - $self->{DEBUG} = 0; - } - } - } - } - - my $hostname = hostname(); - my $address = gethostbyname($hostname) || 'localhost'; - my $fullname = gethostbyaddr($address,AF_INET) || $hostname; - - $self->debug(1,"new: hostname = ($fullname)"); - - #--------------------------------------------------------------------------- - # Setup the defaults that the module will work with. - #--------------------------------------------------------------------------- - $self->{SIDS}->{default}->{hostname} = ""; - $self->{SIDS}->{default}->{port} = ""; - $self->{SIDS}->{default}->{sock} = 0; - $self->{SIDS}->{default}->{ssl} = (exists($args{ssl}) ? $args{ssl} : 0); - $self->{SIDS}->{default}->{namespace} = ""; - $self->{SIDS}->{default}->{myhostname} = $fullname; - $self->{SIDS}->{default}->{derivedhostname} = $fullname; - $self->{SIDS}->{default}->{id} = ""; - - #--------------------------------------------------------------------------- - # We are only going to use one callback, let the user call other callbacks - # on his own. - #--------------------------------------------------------------------------- - $self->SetCallBacks(node=>sub { $self->_node(@_) }); - - $self->{IDCOUNT} = 0; - - return $self; -} - - - - -############################################################################## -#+---------------------------------------------------------------------------- -#| -#| Incoming Connection Functions -#| -#+---------------------------------------------------------------------------- -############################################################################## - -############################################################################## -# -# Listen - starts the stream by listening on a port for someone to connect, -# and send the opening stream tag, and then sending a response based -# on if the received header was correct for this stream. Server -# name, port, and namespace are required otherwise we don't know -# where to listen and what namespace to accept. -# -############################################################################## -sub Listen -{ - my $self = shift; - my %args; - while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } - - my $serverid = "server$args{port}"; - - return if exists($self->{SIDS}->{$serverid}); - - push(@{$self->{SIDS}->{server}},$serverid); - - foreach my $key (keys(%{$self->{SIDS}->{default}})) - { - $self->{SIDS}->{$serverid}->{$key} = $self->{SIDS}->{default}->{$key}; - } - - foreach my $key (keys(%args)) - { - $self->{SIDS}->{$serverid}->{$key} = $args{$key}; - } - - $self->debug(1,"Listen: start"); - - if ($self->{SIDS}->{$serverid}->{namespace} eq "") - { - $self->SetErrorCode($serverid,"Namespace not specified"); - return; - } - - #--------------------------------------------------------------------------- - # Check some things that we have to know in order get the connection up - # and running. Server hostname, port number, namespace, etc... - #--------------------------------------------------------------------------- - if ($self->{SIDS}->{$serverid}->{hostname} eq "") - { - $self->SetErrorCode("$serverid","Server hostname not specified"); - return; - } - if ($self->{SIDS}->{$serverid}->{port} eq "") - { - $self->SetErrorCode("$serverid","Server port not specified"); - return; - } - if ($self->{SIDS}->{$serverid}->{myhostname} eq "") - { - $self->{SIDS}->{$serverid}->{myhostname} = $self->{SIDS}->{$serverid}->{derivedhostname}; - } - - #------------------------------------------------------------------------- - # Open the connection to the listed server and port. If that fails then - # abort ourselves and let the user check $! on his own. - #------------------------------------------------------------------------- - - while($self->{SIDS}->{$serverid}->{sock} == 0) - { - $self->{SIDS}->{$serverid}->{sock} = - new IO::Socket::INET(LocalHost=>$self->{SIDS}->{$serverid}->{hostname}, - LocalPort=>$self->{SIDS}->{$serverid}->{port}, - Reuse=>1, - Listen=>10, - Proto=>'tcp'); - select(undef,undef,undef,.1); - } - $self->{SIDS}->{$serverid}->{status} = 1; - $self->nonblock($self->{SIDS}->{$serverid}->{sock}); - $self->{SIDS}->{$serverid}->{sock}->autoflush(1); - - $self->{SELECT} = - new IO::Select($self->{SIDS}->{$serverid}->{sock}); - $self->{SIDS}->{$serverid}->{select} = - new IO::Select($self->{SIDS}->{$serverid}->{sock}); - - $self->{SOCKETS}->{$self->{SIDS}->{$serverid}->{sock}} = "$serverid"; - - return $serverid; -} - - -############################################################################## -# -# ConnectionAccept - accept an incoming connection. -# -############################################################################## -sub ConnectionAccept -{ - my $self = shift; - my $serverid = shift; - - my $sid = $self->NewSID(); - - $self->debug(1,"ConnectionAccept: sid($sid)"); - - $self->{SIDS}->{$sid}->{sock} = $self->{SIDS}->{$serverid}->{sock}->accept(); - - $self->nonblock($self->{SIDS}->{$sid}->{sock}); - $self->{SIDS}->{$sid}->{sock}->autoflush(1); - - $self->debug(3,"ConnectionAccept: sid($sid) client($self->{SIDS}->{$sid}->{sock}) server($self->{SIDS}->{$serverid}->{sock})"); - - $self->{SELECT}->add($self->{SIDS}->{$sid}->{sock}); - - #------------------------------------------------------------------------- - # Create the XML::Stream::Parser and register our callbacks - #------------------------------------------------------------------------- - $self->{SIDS}->{$sid}->{parser} = - new XML::Stream::Parser(%{$self->{DEBUGARGS}}, - nonblocking=>$NONBLOCKING, - sid=>$sid, - style=>$self->{DATASTYLE}, - Handlers=>{ - startElement=>sub{ $self->_handle_root(@_) }, - endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) }, - characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) }, - } - ); - - $self->{SIDS}->{$sid}->{select} = - new IO::Select($self->{SIDS}->{$sid}->{sock}); - $self->{SIDS}->{$sid}->{connectiontype} = "tcpip"; - $self->{SOCKETS}->{$self->{SIDS}->{$sid}->{sock}} = $sid; - - $self->InitConnection($sid,$serverid); - - #--------------------------------------------------------------------------- - # Grab the init time so that we can check if we get data in the timeout - # period or not. - #--------------------------------------------------------------------------- - $self->{SIDS}->{$sid}->{activitytimeout} = time; - - return $sid; -} - - -############################################################################## -# -# Respond - If this is a listening socket then we need to respond to the -# opening <stream:stream/>. -# -############################################################################## -sub Respond -{ - my $self = shift; - my $sid = shift; - my $serverid = $self->{SIDS}->{$sid}->{serverid}; - - my $root = $self->GetRoot($sid); - - if ($root->{xmlns} ne $self->{SIDS}->{$serverid}->{namespace}) - { - my $error = $self->StreamError($sid,"invalid-namespace","Invalid namespace specified"); - $self->Send($sid,$error); - - $self->{SIDS}->{$sid}->{sock}->flush(); - select(undef,undef,undef,1); - $self->Disconnect($sid); - } - - #--------------------------------------------------------------------------- - # Next, we build the opening handshake. - #--------------------------------------------------------------------------- - my %stream_args; - - $stream_args{from} = - (exists($self->{SIDS}->{$serverid}->{from}) ? - $self->{SIDS}->{$serverid}->{from} : - $self->{SIDS}->{$serverid}->{hostname} - ); - - $stream_args{to} = $self->GetRoot($sid)->{from}; - $stream_args{id} = $sid; - $stream_args{namespaces} = $self->{SIDS}->{$serverid}->{namespaces}; - - my $stream = - $self->StreamHeader( - xmlns=>$self->{SIDS}->{$serverid}->{namespace}, - xmllang=>"en", - %stream_args - ); - - #--------------------------------------------------------------------------- - # Then we send the opening handshake. - #--------------------------------------------------------------------------- - $self->Send($sid,$stream); - delete($self->{SIDS}->{$sid}->{activitytimeout}); -} - - - - -############################################################################## -#+---------------------------------------------------------------------------- -#| -#| Outgoing Connection Functions -#| -#+---------------------------------------------------------------------------- -############################################################################## - -############################################################################## -# -# Connect - starts the stream by connecting to the server, sending the opening -# stream tag, and then waiting for a response and verifying that it -# is correct for this stream. Server name, port, and namespace are -# required otherwise we don't know where to send the stream to... -# -############################################################################## -sub Connect -{ - my $self = shift; - - foreach my $key (keys(%{$self->{SIDS}->{default}})) - { - $self->{SIDS}->{newconnection}->{$key} = $self->{SIDS}->{default}->{$key}; - } - while($#_ >= 0) { $self->{SIDS}->{newconnection}->{ lc pop(@_) } = pop(@_); } - - my $timeout = exists($self->{SIDS}->{newconnection}->{timeout}) ? - delete($self->{SIDS}->{newconnection}->{timeout}) : - ""; - - $self->debug(4,"Connect: timeout($timeout)"); - - - if (exists($self->{SIDS}->{newconnection}->{srv})) - { - $self->debug(1,"Connect: srv requested"); - if ($NETDNS) - { - my $res = new Net::DNS::Resolver(); - my $query = $res->query($self->{SIDS}->{newconnection}->{srv}.".".$self->{SIDS}->{newconnection}->{hostname},"SRV"); - - if ($query) - { - $self->{SIDS}->{newconnection}->{hostname} = ($query->answer)[0]->target(); - $self->{SIDS}->{newconnection}->{port} = ($query->answer)[0]->port(); - $self->debug(1,"Connect: srv host: $self->{SIDS}->{newconnection}->{hostname}"); - $self->debug(1,"Connect: srv post: $self->{SIDS}->{newconnection}->{port}"); - } - else - { - $self->debug(1,"Connect: srv query failed"); - } - } - else - { - $self->debug(1,"Connect: srv query failed"); - } - delete($self->{SIDS}->{newconnection}->{srv}); - } - - $self->{SIDS}->{newconnection}->{connectiontype} = "tcpip" - unless exists($self->{SIDS}->{newconnection}->{connectiontype}); - - $self->debug(1,"Connect: type($self->{SIDS}->{newconnection}->{connectiontype})"); - - if ($self->{SIDS}->{newconnection}->{namespace} eq "") - { - $self->SetErrorCode("newconnection","Namespace not specified"); - return; - } - - #--------------------------------------------------------------------------- - # TCP/IP - #--------------------------------------------------------------------------- - if ($self->{SIDS}->{newconnection}->{connectiontype} eq "tcpip") - { - #----------------------------------------------------------------------- - # Check some things that we have to know in order get the connection up - # and running. Server hostname, port number, namespace, etc... - #----------------------------------------------------------------------- - if ($self->{SIDS}->{newconnection}->{hostname} eq "") - { - $self->SetErrorCode("newconnection","Server hostname not specified"); - return; - } - if ($self->{SIDS}->{newconnection}->{port} eq "") - { - $self->SetErrorCode("newconnection","Server port not specified"); - return; - } - if ($self->{SIDS}->{newconnection}->{myhostname} eq "") - { - $self->{SIDS}->{newconnection}->{myhostname} = $self->{SIDS}->{newconnection}->{derivedhostname}; - } - - #----------------------------------------------------------------------- - # Open the connection to the listed server and port. If that fails then - # abort ourselves and let the user check $! on his own. - #----------------------------------------------------------------------- - $self->{SIDS}->{newconnection}->{sock} = - new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{hostname}, - PeerPort=>$self->{SIDS}->{newconnection}->{port}, - Proto=>"tcp", - (($timeout ne "") ? ( Timeout=>$timeout ) : ()), - ); - return unless $self->{SIDS}->{newconnection}->{sock}; - - if ($self->{SIDS}->{newconnection}->{ssl} == 1) - { - $self->debug(1,"Connect: Convert normal socket to SSL"); - $self->debug(1,"Connect: sock($self->{SIDS}->{newconnection}->{sock})"); - $self->LoadSSL(); - $self->{SIDS}->{newconnection}->{sock} = - IO::Socket::SSL::socketToSSL($self->{SIDS}->{newconnection}->{sock}, - {SSL_verify_mode=>0x00}); - $self->debug(1,"Connect: ssl_sock($self->{SIDS}->{newconnection}->{sock})"); - $self->debug(1,"Connect: SSL: We are secure") if ($self->{SIDS}->{newconnection}->{sock}); - } - return unless $self->{SIDS}->{newconnection}->{sock}; - } - - #--------------------------------------------------------------------------- - # STDIN/OUT - #--------------------------------------------------------------------------- - if ($self->{SIDS}->{newconnection}->{connectiontype} eq "stdinout") - { - $self->{SIDS}->{newconnection}->{sock} = - new FileHandle(">&STDOUT"); - } - - #--------------------------------------------------------------------------- - # HTTP - #--------------------------------------------------------------------------- - if ($self->{SIDS}->{newconnection}->{connectiontype} eq "http") - { - #----------------------------------------------------------------------- - # Check some things that we have to know in order get the connection up - # and running. Server hostname, port number, namespace, etc... - #----------------------------------------------------------------------- - if ($self->{SIDS}->{newconnection}->{hostname} eq "") - { - $self->SetErrorCode("newconnection","Server hostname not specified"); - return; - } - if ($self->{SIDS}->{newconnection}->{port} eq "") - { - $self->SetErrorCode("newconnection","Server port not specified"); - return; - } - if ($self->{SIDS}->{newconnection}->{myhostname} eq "") - { - $self->{SIDS}->{newconnection}->{myhostname} = $self->{SIDS}->{newconnection}->{derivedhostname}; - } - - if (!defined($PAC)) - { - eval("use HTTP::ProxyAutoConfig;"); - if ($@) - { - $PAC = 0; - } - else - { - require HTTP::ProxyAutoConfig; - $PAC = new HTTP::ProxyAutoConfig(); - } - } - - if ($PAC eq "0") { - if (exists($ENV{"http_proxy"})) - { - my($host,$port) = ($ENV{"http_proxy"} =~ /^(\S+)\:(\d+)$/); - $self->{SIDS}->{newconnection}->{httpproxyhostname} = $host; - $self->{SIDS}->{newconnection}->{httpproxyport} = $port; - $self->{SIDS}->{newconnection}->{httpproxyhostname} =~ s/^http\:\/\///; - } - if (exists($ENV{"https_proxy"})) - { - my($host,$port) = ($ENV{"https_proxy"} =~ /^(\S+)\:(\d+)$/); - $self->{SIDS}->{newconnection}->{httpsproxyhostname} = $host; - $self->{SIDS}->{newconnection}->{httpsproxyport} = $port; - $self->{SIDS}->{newconnection}->{httpsproxyhostname} =~ s/^https?\:\/\///; - } - } - else - { - my $proxy = $PAC->FindProxy("http://".$self->{SIDS}->{newconnection}->{hostname}); - if ($proxy ne "DIRECT") - { - ($self->{SIDS}->{newconnection}->{httpproxyhostname},$self->{SIDS}->{newconnection}->{httpproxyport}) = ($proxy =~ /^PROXY ([^:]+):(\d+)$/); - } - - $proxy = $PAC->FindProxy("https://".$self->{SIDS}->{newconnection}->{hostname}); - - if ($proxy ne "DIRECT") - { - ($self->{SIDS}->{newconnection}->{httpsproxyhostname},$self->{SIDS}->{newconnection}->{httpsproxyport}) = ($proxy =~ /^PROXY ([^:]+):(\d+)$/); - } - } - - $self->debug(1,"Connect: http_proxy($self->{SIDS}->{newconnection}->{httpproxyhostname}:$self->{SIDS}->{newconnection}->{httpproxyport})") - if (exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) && - defined($self->{SIDS}->{newconnection}->{httpproxyhostname}) && - exists($self->{SIDS}->{newconnection}->{httpproxyport}) && - defined($self->{SIDS}->{newconnection}->{httpproxyport})); - $self->debug(1,"Connect: https_proxy($self->{SIDS}->{newconnection}->{httpsproxyhostname}:$self->{SIDS}->{newconnection}->{httpsproxyport})") - if (exists($self->{SIDS}->{newconnection}->{httpsproxyhostname}) && - defined($self->{SIDS}->{newconnection}->{httpsproxyhostname}) && - exists($self->{SIDS}->{newconnection}->{httpsproxyport}) && - defined($self->{SIDS}->{newconnection}->{httpsproxyport})); - - #----------------------------------------------------------------------- - # Open the connection to the listed server and port. If that fails then - # abort ourselves and let the user check $! on his own. - #----------------------------------------------------------------------- - my $connect = "CONNECT $self->{SIDS}->{newconnection}->{hostname}:$self->{SIDS}->{newconnection}->{port} HTTP/1.1\r\nHost: $self->{SIDS}->{newconnection}->{hostname}\r\n\r\n"; - my $put = "PUT http://$self->{SIDS}->{newconnection}->{hostname}:$self->{SIDS}->{newconnection}->{port} HTTP/1.1\r\nHost: $self->{SIDS}->{newconnection}->{hostname}\r\nProxy-Connection: Keep-Alive\r\n\r\n"; - - my $connected = 0; - #----------------------------------------------------------------------- - # Combo #0 - The user didn't specify a proxy - #----------------------------------------------------------------------- - if (!exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) && - !exists($self->{SIDS}->{newconnection}->{httpsproxyhostname})) - { - - $self->debug(1,"Connect: Combo #0: User did not specify a proxy... connecting DIRECT"); - - $self->debug(1,"Connect: Combo #0: Create normal socket"); - $self->{SIDS}->{newconnection}->{sock} = - new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{hostname}, - PeerPort=>$self->{SIDS}->{newconnection}->{port}, - Proto=>"tcp", - (($timeout ne "") ? ( Timeout=>$timeout ) : ()), - ); - $connected = defined($self->{SIDS}->{newconnection}->{sock}); - $self->debug(1,"Connect: Combo #0: connected($connected)"); - # if ($connected) - # { - # $self->{SIDS}->{newconnection}->{sock}->syswrite($put,length($put),0); - # my $buff; - # $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ); - # my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/); - # $self->debug(1,"Connect: Combo #1: buff($buff)"); - # $connected = 0 if ($code !~ /2\d\d/); - # } - # $self->debug(1,"Connect: Combo #0: connected($connected)"); - } - - #----------------------------------------------------------------------- - # Combo #1 - PUT through http_proxy - #----------------------------------------------------------------------- - if (!$connected && - exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) && - ($self->{SIDS}->{newconnection}->{ssl} == 0)) - { - - $self->debug(1,"Connect: Combo #1: PUT through http_proxy"); - $self->{SIDS}->{newconnection}->{sock} = - new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpproxyhostname}, - PeerPort=>$self->{SIDS}->{newconnection}->{httpproxyport}, - Proto=>"tcp", - (($timeout ne "") ? ( Timeout=>$timeout ) : ()), - ); - $connected = defined($self->{SIDS}->{newconnection}->{sock}); - $self->debug(1,"Connect: Combo #1: connected($connected)"); - if ($connected) - { - $self->debug(1,"Connect: Combo #1: send($put)"); - $self->{SIDS}->{newconnection}->{sock}->syswrite($put,length($put),0); - my $buff; - $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ); - my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/); - $self->debug(1,"Connect: Combo #1: buff($buff)"); - $connected = 0 if ($code !~ /2\d\d/); - } - $self->debug(1,"Connect: Combo #1: connected($connected)"); - } - #----------------------------------------------------------------------- - # Combo #2 - CONNECT through http_proxy - #----------------------------------------------------------------------- - if (!$connected && - exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) && - ($self->{SIDS}->{newconnection}->{ssl} == 0)) - { - - $self->debug(1,"Connect: Combo #2: CONNECT through http_proxy"); - $self->{SIDS}->{newconnection}->{sock} = - new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpproxyhostname}, - PeerPort=>$self->{SIDS}->{newconnection}->{httpproxyport}, - Proto=>"tcp", - (($timeout ne "") ? ( Timeout=>$timeout ) : ()), - ); - $connected = defined($self->{SIDS}->{newconnection}->{sock}); - $self->debug(1,"Connect: Combo #2: connected($connected)"); - if ($connected) - { - $self->{SIDS}->{newconnection}->{sock}->syswrite($connect,length($connect),0); - my $buff; - $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ); - my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/); - $self->debug(1,"Connect: Combo #2: buff($buff)"); - $connected = 0 if ($code !~ /2\d\d/); - } - $self->debug(1,"Connect: Combo #2: connected($connected)"); - } - - #----------------------------------------------------------------------- - # Combo #3 - CONNECT through https_proxy - #----------------------------------------------------------------------- - if (!$connected && - exists($self->{SIDS}->{newconnection}->{httpsproxyhostname})) - { - $self->debug(1,"Connect: Combo #3: CONNECT through https_proxy"); - $self->{SIDS}->{newconnection}->{sock} = - new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpsproxyhostname}, - PeerPort=>$self->{SIDS}->{newconnection}->{httpsproxyport}, - Proto=>"tcp"); - $connected = defined($self->{SIDS}->{newconnection}->{sock}); - $self->debug(1,"Connect: Combo #3: connected($connected)"); - if ($connected) - { - $self->{SIDS}->{newconnection}->{sock}->syswrite($connect,length($connect),0); - my $buff; - $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ); - my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/); - $self->debug(1,"Connect: Combo #3: buff($buff)"); - $connected = 0 if ($code !~ /2\d\d/); - } - $self->debug(1,"Connect: Combo #3: connected($connected)"); - } - - #----------------------------------------------------------------------- - # We have failed - #----------------------------------------------------------------------- - if (!$connected) - { - $self->debug(1,"Connect: No connection... I have failed... I.. must... end it all..."); - $self->SetErrorCode("newconnection","Unable to open a connection to destination. Please check your http_proxy and/or https_proxy environment variables."); - return; - } - - return unless $self->{SIDS}->{newconnection}->{sock}; - - $self->debug(1,"Connect: We are connected"); - - if (($self->{SIDS}->{newconnection}->{ssl} == 1) && - (ref($self->{SIDS}->{newconnection}->{sock}) eq "IO::Socket::INET")) - { - $self->debug(1,"Connect: Convert normal socket to SSL"); - $self->debug(1,"Connect: sock($self->{SIDS}->{newconnection}->{sock})"); - $self->LoadSSL(); - $self->{SIDS}->{newconnection}->{sock} = - IO::Socket::SSL::socketToSSL($self->{SIDS}->{newconnection}->{sock}, - {SSL_verify_mode=>0x00}); - $self->debug(1,"Connect: ssl_sock($self->{SIDS}->{newconnection}->{sock})"); - $self->debug(1,"Connect: SSL: We are secure") if ($self->{SIDS}->{newconnection}->{sock}); - } - return unless $self->{SIDS}->{newconnection}->{sock}; - } - - $self->debug(1,"Connect: Got a connection"); - - $self->{SIDS}->{newconnection}->{sock}->autoflush(1); - - return $self->OpenStream("newconnection",$timeout); -} - - -############################################################################## -# -# OpenStream - Send the opening stream and save the root element info. -# -############################################################################## -sub OpenStream -{ - my $self = shift; - my $currsid = shift; - my $timeout = shift; - $timeout = "" unless defined($timeout); - - $self->InitConnection($currsid,$currsid); - - #--------------------------------------------------------------------------- - # Next, we build the opening handshake. - #--------------------------------------------------------------------------- - my %stream_args; - - if (($self->{SIDS}->{$currsid}->{connectiontype} eq "tcpip") || - ($self->{SIDS}->{$currsid}->{connectiontype} eq "http")) - { - $stream_args{to}= $self->{SIDS}->{$currsid}->{hostname} - unless exists($self->{SIDS}->{$currsid}->{to}); - - $stream_args{to} = $self->{SIDS}->{$currsid}->{to} - if exists($self->{SIDS}->{$currsid}->{to}); - - $stream_args{from} = $self->{SIDS}->{$currsid}->{myhostname} - if (!exists($self->{SIDS}->{$currsid}->{from}) && - ($self->{SIDS}->{$currsid}->{myhostname} ne "") - ); - - $stream_args{from} = $self->{SIDS}->{$currsid}->{from} - if exists($self->{SIDS}->{$currsid}->{from}); - - $stream_args{id} = $self->{SIDS}->{$currsid}->{id} - if (exists($self->{SIDS}->{$currsid}->{id}) && - ($self->{SIDS}->{$currsid}->{id} ne "") - ); - - $stream_args{namespaces} = $self->{SIDS}->{$currsid}->{namespaces}; - } - - my $stream = - $self->StreamHeader( - xmlns=>$self->{SIDS}->{$currsid}->{namespace}, - xmllang=>"en", - %stream_args - ); - - #--------------------------------------------------------------------------- - # Create the XML::Stream::Parser and register our callbacks - #--------------------------------------------------------------------------- - $self->{SIDS}->{$currsid}->{parser} = - new XML::Stream::Parser(%{$self->{DEBUGARGS}}, - nonblocking=>$NONBLOCKING, - sid=>$currsid, - style=>$self->{DATASTYLE}, - Handlers=>{ - startElement=>sub{ $self->_handle_root(@_) }, - endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) }, - characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) }, - } - ); - - $self->{SIDS}->{$currsid}->{select} = - new IO::Select($self->{SIDS}->{$currsid}->{sock}); - - if (($self->{SIDS}->{$currsid}->{connectiontype} eq "tcpip") || - ($self->{SIDS}->{$currsid}->{connectiontype} eq "http")) - { - $self->{SELECT} = new IO::Select($self->{SIDS}->{$currsid}->{sock}); - $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = "newconnection"; - } - - if ($self->{SIDS}->{$currsid}->{connectiontype} eq "stdinout") - { - $self->{SELECT} = new IO::Select(*STDIN); - $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $currsid; - $self->{SOCKETS}->{*STDIN} = $currsid; - $self->{SIDS}->{$currsid}->{select}->add(*STDIN); - } - - $self->{SIDS}->{$currsid}->{status} = 0; - - #--------------------------------------------------------------------------- - # Then we send the opening handshake. - #--------------------------------------------------------------------------- - $self->Send($currsid,$stream) || return; - - #--------------------------------------------------------------------------- - # Before going on let's make sure that the server responded with a valid - # root tag and that the stream is open. - #--------------------------------------------------------------------------- - my $buff = ""; - my $timeEnd = ($timeout eq "") ? "" : time + $timeout; - while($self->{SIDS}->{$currsid}->{status} == 0) - { - my $now = time; - my $wait = (($timeEnd eq "") || ($timeEnd - $now > 10)) ? 10 : - $timeEnd - $now; - - $self->debug(5,"Connect: can_read(",join(",",$self->{SIDS}->{$currsid}->{select}->can_read(0)),")"); - if ($self->{SIDS}->{$currsid}->{select}->can_read($wait)) - { - $self->{SIDS}->{$currsid}->{status} = -1 - unless defined($buff = $self->Read($currsid)); - return unless($self->{SIDS}->{$currsid}->{status} == 0); - return unless($self->ParseStream($currsid,$buff) == 1); - } - else - { - if ($timeout ne "") - { - if (time >= $timeEnd) - { - $self->SetErrorCode($currsid,"Timeout limit reached"); - return; - } - } - } - - return if($self->{SIDS}->{$currsid}->{select}->has_exception(0)); - } - return if($self->{SIDS}->{$currsid}->{status} != 1); - - $self->debug(3,"Connect: status($self->{SIDS}->{$currsid}->{status})"); - - my $sid = $self->GetRoot($currsid)->{id}; - $| = 1; - foreach my $key (keys(%{$self->{SIDS}->{$currsid}})) - { - $self->{SIDS}->{$sid}->{$key} = $self->{SIDS}->{$currsid}->{$key}; - } - $self->{SIDS}->{$sid}->{parser}->setSID($sid); - - if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") || - ($self->{SIDS}->{$sid}->{connectiontype} eq "http")) - { - $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $sid; - } - - if ($self->{SIDS}->{$sid}->{connectiontype} eq "stdinout") - { - $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $sid; - $self->{SOCKETS}->{*STDIN} = $sid; - } - - delete($self->{SIDS}->{$currsid}); - - if (exists($self->GetRoot($sid)->{version}) && - ($self->GetRoot($sid)->{version} ne "")) - { - while(!$self->ReceivedStreamFeatures($sid)) - { - $self->Process(1); - } - } - - return $self->GetRoot($sid); -} - - -############################################################################## -# -# OpenFile - starts the stream by opening a file and setting it up so that -# Process reads from the filehandle to get the incoming stream. -# -############################################################################## -sub OpenFile -{ - my $self = shift; - my $file = shift; - - $self->debug(1,"OpenFile: file($file)"); - - $self->{SIDS}->{newconnection}->{connectiontype} = "file"; - - $self->{SIDS}->{newconnection}->{sock} = new FileHandle($file); - $self->{SIDS}->{newconnection}->{sock}->autoflush(1); - - $self->RegisterPrefix("newconnection",&ConstXMLNS("stream"),"stream"); - - #--------------------------------------------------------------------------- - # Create the XML::Stream::Parser and register our callbacks - #--------------------------------------------------------------------------- - $self->{SIDS}->{newconnection}->{parser} = - new XML::Stream::Parser(%{$self->{DEBUGARGS}}, - nonblocking=>$NONBLOCKING, - sid=>"newconnection", - style=>$self->{DATASTYLE}, - Handlers=>{ - startElement=>sub{ $self->_handle_root(@_) }, - endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) }, - characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) }, - } - ); - - $self->{SIDS}->{newconnection}->{select} = - new IO::Select($self->{SIDS}->{newconnection}->{sock}); - - $self->{SELECT} = new IO::Select($self->{SIDS}->{newconnection}->{sock}); - - $self->{SIDS}->{newconnection}->{status} = 0; - - my $buff = ""; - while($self->{SIDS}->{newconnection}->{status} == 0) - { - $self->debug(5,"OpenFile: can_read(",join(",",$self->{SIDS}->{newconnection}->{select}->can_read(0)),")"); - if ($self->{SIDS}->{newconnection}->{select}->can_read(0)) - { - $self->{SIDS}->{newconnection}->{status} = -1 - unless defined($buff = $self->Read("newconnection")); - return unless($self->{SIDS}->{newconnection}->{status} == 0); - return unless($self->ParseStream("newconnection",$buff) == 1); - } - - return if($self->{SIDS}->{newconnection}->{select}->has_exception(0) && - $self->{SIDS}->{newconnection}->{sock}->error()); - } - return if($self->{SIDS}->{newconnection}->{status} != 1); - - - my $sid = $self->NewSID(); - foreach my $key (keys(%{$self->{SIDS}->{newconnection}})) - { - $self->{SIDS}->{$sid}->{$key} = $self->{SIDS}->{newconnection}->{$key}; - } - $self->{SIDS}->{$sid}->{parser}->setSID($sid); - - $self->{SOCKETS}->{$self->{SIDS}->{newconnection}->{sock}} = $sid; - - delete($self->{SIDS}->{newconnection}); - - return $sid; -} - - - - -############################################################################## -#+---------------------------------------------------------------------------- -#| -#| Common Functions -#| -#+---------------------------------------------------------------------------- -############################################################################## - -############################################################################## -# -# Disconnect - sends the closing XML tag and shuts down the socket. -# -############################################################################## -sub Disconnect -{ - my $self = shift; - my $sid = shift; - - $self->Send($sid,"</stream:stream>"); - close($self->{SIDS}->{$sid}->{sock}) - if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") || - ($self->{SIDS}->{$sid}->{connectiontype} eq "http")); - delete($self->{SOCKETS}->{$self->{SIDS}->{$sid}->{sock}}); - foreach my $key (keys(%{$self->{SIDS}->{$sid}})) - { - delete($self->{SIDS}->{$sid}->{$key}); - } - delete($self->{SIDS}->{$sid}); -} - - -############################################################################## -# -# InitConnection - Initialize the connection data structure -# -############################################################################## -sub InitConnection -{ - my $self = shift; - my $sid = shift; - my $serverid = shift; - - #--------------------------------------------------------------------------- - # Set the default STATUS so that we can keep track of it throughout the - # session. - # 1 = no errors - # 0 = no data has been received yet - # -1 = error from handlers - # -2 = error but keep the connection alive so that we can send some info. - #--------------------------------------------------------------------------- - $self->{SIDS}->{$sid}->{status} = 0; - - #--------------------------------------------------------------------------- - # A storage place for when we don't have a callback registered and we need - # to stockpile the nodes we receive until Process is called and we return - # them. - #--------------------------------------------------------------------------- - $self->{SIDS}->{$sid}->{nodes} = (); - - #--------------------------------------------------------------------------- - # If there is an error on the stream, then we need a place to indicate that. - #--------------------------------------------------------------------------- - $self->{SIDS}->{$sid}->{streamerror} = {}; - - #--------------------------------------------------------------------------- - # Grab the init time so that we can keep the connection alive by sending " " - #--------------------------------------------------------------------------- - $self->{SIDS}->{$sid}->{keepalive} = time; - - #--------------------------------------------------------------------------- - # Keep track of the "server" we are connected to so we can check stuff - # later. - #--------------------------------------------------------------------------- - $self->{SIDS}->{$sid}->{serverid} = $serverid; - - #--------------------------------------------------------------------------- - # Mark the stream:features as MIA. - #--------------------------------------------------------------------------- - $self->{SIDS}->{$sid}->{streamfeatures}->{received} = 0; - - #--------------------------------------------------------------------------- - # First acitivty is the connection... duh. =) - #--------------------------------------------------------------------------- - $self->MarkActivity($sid); -} - - -############################################################################## -# -# ParseStream - takes the incoming stream and makes sure that only full -# XML tags gets passed to the parser. If a full tag has not -# read yet, then the Stream saves the incomplete part and -# sends the rest to the parser. -# -############################################################################## -sub ParseStream -{ - my $self = shift; - my $sid = shift; - my $stream = shift; - - $stream = "" unless defined($stream); - - $self->debug(3,"ParseStream: sid($sid) stream($stream)"); - - $self->{SIDS}->{$sid}->{parser}->parse($stream); - - if (exists($self->{SIDS}->{$sid}->{streamerror}->{type})) - { - $self->debug(3,"ParseStream: ERROR($self->{SIDS}->{$sid}->{streamerror}->{type})"); - $self->SetErrorCode($sid,$self->{SIDS}->{$sid}->{streamerror}); - return 0; - } - - return 1; -} - - -############################################################################## -# -# Process - checks for data on the socket and returns a status code depending -# on if there was data or not. If a timeout is not defined in the -# call then the timeout defined in Connect() is used. If a timeout -# of 0 is used then the call blocks until it gets some data, -# otherwise it returns after the timeout period. -# -############################################################################## -sub Process -{ - my $self = shift; - my $timeout = shift; - $timeout = "" unless defined($timeout); - - $self->debug(4,"Process: timeout($timeout)"); - #--------------------------------------------------------------------------- - # We need to keep track of what's going on in the function and tell the - # outside world about it so let's return something useful. We track this - # information based on sid: - # -1 connection closed and error - # 0 connection open but no data received. - # 1 connection open and data received. - # array connection open and the data that has been collected - # over time (No CallBack specified) - #--------------------------------------------------------------------------- - my %status; - foreach my $sid (keys(%{$self->{SIDS}})) - { - next if ($sid eq "default"); - $self->debug(5,"Process: initialize sid($sid) status to 0"); - $status{$sid} = 0; - } - - #--------------------------------------------------------------------------- - # Either block until there is data and we have parsed it all, or wait a - # certain period of time and then return control to the user. - #--------------------------------------------------------------------------- - my $block = 1; - my $timeEnd = ($timeout eq "") ? "" : time + $timeout; - while($block == 1) - { - $self->debug(4,"Process: let's wait for data"); - - my $now = time; - my $wait = (($timeEnd eq "") || ($timeEnd - $now > 10)) ? 10 : - $timeEnd - $now; - - foreach my $connection ($self->{SELECT}->can_read($wait)) - { - $self->debug(4,"Process: connection($connection)"); - $self->debug(4,"Process: sid($self->{SOCKETS}->{$connection})"); - $self->debug(4,"Process: connection_status($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status})"); - - next unless (($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status} == 1) || - exists($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{activitytimeout})); - - my $processit = 1; - if (exists($self->{SIDS}->{server})) - { - foreach my $serverid (@{$self->{SIDS}->{server}}) - { - if (exists($self->{SIDS}->{$serverid}->{sock}) && - ($connection == $self->{SIDS}->{$serverid}->{sock})) - { - my $sid = $self->ConnectionAccept($serverid); - $status{$sid} = 0; - $processit = 0; - last; - } - } - } - if ($processit == 1) - { - my $sid = $self->{SOCKETS}->{$connection}; - $self->debug(4,"Process: there's something to read"); - $self->debug(4,"Process: connection($connection) sid($sid)"); - my $buff; - $self->debug(4,"Process: read"); - $status{$sid} = 1; - $self->{SIDS}->{$sid}->{status} = -1 - if (!defined($buff = $self->Read($sid))); - $buff = "" unless defined($buff); - $self->debug(4,"Process: connection_status($self->{SIDS}->{$sid}->{status})"); - $status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1); - $self->debug(4,"Process: parse($buff)"); - $status{$sid} = -1 unless($self->ParseStream($sid,$buff) == 1); - } - $block = 0; - } - - if ($timeout ne "") - { - if (time >= $timeEnd) - { - $self->debug(4,"Process: Everyone out of the pool! Time to stop blocking."); - $block = 0; - } - } - - $self->debug(4,"Process: timeout($timeout)"); - - if (exists($self->{CB}->{update})) - { - $self->debug(4,"Process: Calling user defined update function"); - &{$self->{CB}->{update}}(); - } - - $block = 1 if $self->{SELECT}->can_read(0); - - #--------------------------------------------------------------------- - # Check for connections that need to be kept alive - #--------------------------------------------------------------------- - $self->debug(4,"Process: check for keepalives"); - foreach my $sid (keys(%{$self->{SIDS}})) - { - next if ($sid eq "default"); - next if ($sid =~ /^server/); - next if ($status{$sid} == -1); - if ((time - $self->{SIDS}->{$sid}->{keepalive}) > 10) - { - $self->IgnoreActivity($sid,1); - $self->{SIDS}->{$sid}->{status} = -1 - if !defined($self->Send($sid," ")); - $status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1); - if ($status{$sid} == -1) - { - $self->debug(2,"Process: Keep-Alive failed. What the hell happened?!?!"); - $self->debug(2,"Process: connection_status($self->{SIDS}->{$sid}->{status})"); - } - $self->IgnoreActivity($sid,0); - } - } - #--------------------------------------------------------------------- - # Check for connections that have timed out. - #--------------------------------------------------------------------- - $self->debug(4,"Process: check for timeouts"); - foreach my $sid (keys(%{$self->{SIDS}})) - { - next if ($sid eq "default"); - next if ($sid =~ /^server/); - - if (exists($self->{SIDS}->{$sid}->{activitytimeout})) - { - $self->debug(4,"Process: sid($sid) time(",time,") timeout($self->{SIDS}->{$sid}->{activitytimeout})"); - } - else - { - $self->debug(4,"Process: sid($sid) time(",time,") timeout(undef)"); - } - - $self->Respond($sid) - if (exists($self->{SIDS}->{$sid}->{activitytimeout}) && - defined($self->GetRoot($sid))); - $self->Disconnect($sid) - if (exists($self->{SIDS}->{$sid}->{activitytimeout}) && - ((time - $self->{SIDS}->{$sid}->{activitytimeout}) > 10) && - ($self->{SIDS}->{$sid}->{status} != 1)); - } - - - #--------------------------------------------------------------------- - # If any of the connections have status == -1 then return so that the - # user can handle it. - #--------------------------------------------------------------------- - foreach my $sid (keys(%status)) - { - if ($status{$sid} == -1) - { - $self->debug(4,"Process: sid($sid) is broken... let's tell someone and watch it hit the fan... =)"); - $block = 0; - } - } - - $self->debug(2,"Process: block($block)"); - } - - #--------------------------------------------------------------------------- - # If the Select has an error then shut this party down. - #--------------------------------------------------------------------------- - foreach my $connection ($self->{SELECT}->has_exception(0)) - { - $self->debug(4,"Process: has_exception sid($self->{SOCKETS}->{$connection})"); - $status{$self->{SOCKETS}->{$connection}} = -1; - } - - #--------------------------------------------------------------------------- - # If there are data structures that have not been collected return - # those, otherwise return the status which indicates if nodes were read or - # not. - #--------------------------------------------------------------------------- - foreach my $sid (keys(%status)) - { - $status{$sid} = $self->{SIDS}->{$sid}->{nodes} - if (($status{$sid} == 1) && - ($#{$self->{SIDS}->{$sid}->{nodes}} > -1)); - } - - return %status; -} - - -############################################################################## -# -# Read - Takes the data from the server and returns a string -# -############################################################################## -sub Read -{ - my $self = shift; - my $sid = shift; - my $buff; - my $status = 1; - - $self->debug(3,"Read: sid($sid)"); - $self->debug(3,"Read: connectionType($self->{SIDS}->{$sid}->{connectiontype})"); - $self->debug(3,"Read: socket($self->{SIDS}->{$sid}->{sock})"); - - return if ($self->{SIDS}->{$sid}->{status} == -1); - - if (!defined($self->{SIDS}->{$sid}->{sock})) - { - $self->{SIDS}->{$sid}->{status} = -1; - $self->SetErrorCode($sid,"Socket does not defined."); - return; - } - - $self->{SIDS}->{$sid}->{sock}->flush(); - - $status = $self->{SIDS}->{$sid}->{sock}->sysread($buff,4*POSIX::BUFSIZ) - if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") || - ($self->{SIDS}->{$sid}->{connectiontype} eq "http") || - ($self->{SIDS}->{$sid}->{connectiontype} eq "file")); - $status = sysread(STDIN,$buff,1024) - if ($self->{SIDS}->{$sid}->{connectiontype} eq "stdinout"); - - $buff =~ s/^HTTP[\S\s]+\n\n// if ($self->{SIDS}->{$sid}->{connectiontype} eq "http"); - $self->debug(1,"Read: buff($buff)"); - $self->debug(3,"Read: status($status)") if defined($status); - $self->debug(3,"Read: status(undef)") unless defined($status); - $self->{SIDS}->{$sid}->{keepalive} = time - unless (($buff eq "") || !defined($status) || ($status == 0)); - if (defined($status) && ($status != 0)) - { - $buff = Encode::decode_utf8($buff); - return $buff; - } - #return $buff unless (!defined($status) || ($status == 0)); - $self->debug(1,"Read: ERROR"); - return; -} - - -############################################################################## -# -# Send - Takes the data string and sends it to the server -# -############################################################################## -sub Send -{ - my $self = shift; - my $sid = shift; - $self->debug(1,"Send: (@_)"); - $self->debug(3,"Send: sid($sid)"); - $self->debug(3,"Send: status($self->{SIDS}->{$sid}->{status})"); - - $self->{SIDS}->{$sid}->{keepalive} = time; - - return if ($self->{SIDS}->{$sid}->{status} == -1); - - if (!defined($self->{SIDS}->{$sid}->{sock})) - { - $self->debug(3,"Send: socket not defined"); - $self->{SIDS}->{$sid}->{status} = -1; - $self->SetErrorCode($sid,"Socket not defined."); - return; - } - else - { - $self->debug(3,"Send: socket($self->{SIDS}->{$sid}->{sock})"); - } - - $self->{SIDS}->{$sid}->{sock}->flush(); - - if ($self->{SIDS}->{$sid}->{select}->can_write(0)) - { - $self->debug(3,"Send: can_write"); - - $self->{SENDSTRING} = Encode::encode_utf8(join("",@_)); - - $self->{SENDWRITTEN} = 0; - $self->{SENDOFFSET} = 0; - $self->{SENDLENGTH} = length($self->{SENDSTRING}); - while ($self->{SENDLENGTH}) - { - $self->{SENDWRITTEN} = $self->{SIDS}->{$sid}->{sock}->syswrite($self->{SENDSTRING},$self->{SENDLENGTH},$self->{SENDOFFSET}); - - if (!defined($self->{SENDWRITTEN})) - { - $self->debug(4,"Send: SENDWRITTEN(undef)"); - $self->debug(4,"Send: Ok... what happened? Did we lose the connection?"); - $self->{SIDS}->{$sid}->{status} = -1; - $self->SetErrorCode($sid,"Socket died for an unknown reason."); - return; - } - - $self->debug(4,"Send: SENDWRITTEN($self->{SENDWRITTEN})"); - - $self->{SENDLENGTH} -= $self->{SENDWRITTEN}; - $self->{SENDOFFSET} += $self->{SENDWRITTEN}; - } - } - else - { - $self->debug(3,"Send: can't write..."); - } - - return if($self->{SIDS}->{$sid}->{select}->has_exception(0)); - - $self->debug(3,"Send: no exceptions"); - - $self->{SIDS}->{$sid}->{keepalive} = time; - - $self->MarkActivity($sid); - - return 1; -} - - - - -############################################################################## -#+---------------------------------------------------------------------------- -#| -#| Feature Functions -#| -#+---------------------------------------------------------------------------- -############################################################################## - -############################################################################## -# -# ProcessStreamFeatures - process the <stream:featutres/> block. -# -############################################################################## -sub ProcessStreamFeatures -{ - my $self = shift; - my $sid = shift; - my $node = shift; - - $self->{SIDS}->{$sid}->{streamfeatures}->{received} = 1; - - #------------------------------------------------------------------------- - # SASL - 1.0 - #------------------------------------------------------------------------- - my @sasl = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-sasl').'"]'); - if ($#sasl > -1) - { - if (&XPath($sasl[0],"name()") eq "mechanisms") - { - my @mechanisms = &XPath($sasl[0],"mechanism/text()"); - $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-sasl'} = \@mechanisms; - } - } - - #------------------------------------------------------------------------- - # XMPP-TLS - 1.0 - #------------------------------------------------------------------------- - my @tls = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-tls').'"]'); - if ($#tls > -1) - { - if (&XPath($tls[0],"name()") eq "starttls") - { - $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = 1; - my @required = &XPath($tls[0],"required"); - if ($#required > -1) - { - $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = "required"; - } - } - } - - #------------------------------------------------------------------------- - # XMPP-Bind - 1.0 - #------------------------------------------------------------------------- - my @bind = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-bind').'"]'); - if ($#bind > -1) - { - $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-bind'} = 1; - } - - #------------------------------------------------------------------------- - # XMPP-Session - 1.0 - #------------------------------------------------------------------------- - my @session = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-session').'"]'); - if ($#session > -1) - { - $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-session'} = 1; - } - -} - - -############################################################################## -# -# GetStreamFeature - Return the value of the stream feature (if any). -# -############################################################################## -sub GetStreamFeature -{ - my $self = shift; - my $sid = shift; - my $feature = shift; - - return unless exists($self->{SIDS}->{$sid}->{streamfeatures}->{$feature}); - return $self->{SIDS}->{$sid}->{streamfeatures}->{$feature}; -} - - -############################################################################## -# -# ReceivedStreamFeatures - Have we received the stream:features yet? -# -############################################################################## -sub ReceivedStreamFeatures -{ - my $self = shift; - my $sid = shift; - my $feature = shift; - - return $self->{SIDS}->{$sid}->{streamfeatures}->{received}; -} - - - - -############################################################################## -#+---------------------------------------------------------------------------- -#| -#| TLS Functions -#| -#+---------------------------------------------------------------------------- -############################################################################## - -############################################################################## -# -# ProcessTLSPacket - process a TLS based packet. -# -############################################################################## -sub ProcessTLSPacket -{ - my $self = shift; - my $sid = shift; - my $node = shift; - - my $tag = &XPath($node,"name()"); - - if ($tag eq "failure") - { - $self->TLSClientFailure($sid,$node); - } - - if ($tag eq "proceed") - { - $self->TLSClientProceed($sid,$node); - } -} - - -############################################################################## -# -# StartTLS - client function to have the socket start TLS. -# -############################################################################## -sub StartTLS -{ - my $self = shift; - my $sid = shift; - my $timeout = shift; - $timeout = 120 unless defined($timeout); - $timeout = 120 if ($timeout eq ""); - - $self->TLSStartTLS($sid); - - my $endTime = time + $timeout; - while(!$self->TLSClientDone($sid) && ($endTime >= time)) - { - $self->Process(1); - } - - if (!$self->TLSClientSecure($sid)) - { - return; - } - - return $self->OpenStream($sid,$timeout); -} - - -############################################################################## -# -# TLSStartTLS - send a <starttls/> in the TLS namespace. -# -############################################################################## -sub TLSStartTLS -{ - my $self = shift; - my $sid = shift; - - $self->Send($sid,"<starttls xmlns='".&ConstXMLNS('xmpp-tls')."'/>"); -} - - -############################################################################## -# -# TLSClientProceed - handle a <proceed/> packet. -# -############################################################################## -sub TLSClientProceed -{ - my $self = shift; - my $sid = shift; - my $node = shift; - - $self->debug(1,"TLSClientProceed: Convert normal socket to SSL"); - $self->debug(1,"TLSClientProceed: sock($self->{SIDS}->{$sid}->{sock})"); - if (!$self->LoadSSL()) - { - $self->{SIDS}->{$sid}->{tls}->{error} = "Could not load IO::Socket::SSL."; - $self->{SIDS}->{$sid}->{tls}->{done} = 1; - return; - } - - IO::Socket::SSL->start_SSL($self->{SIDS}->{$sid}->{sock},{SSL_verify_mode=>0x00}); - - $self->debug(1,"TLSClientProceed: ssl_sock($self->{SIDS}->{$sid}->{sock})"); - $self->debug(1,"TLSClientProceed: SSL: We are secure") - if ($self->{SIDS}->{$sid}->{sock}); - - $self->{SIDS}->{$sid}->{tls}->{done} = 1; - $self->{SIDS}->{$sid}->{tls}->{secure} = 1; -} - - -############################################################################## -# -# TLSClientSecure - return 1 if the socket is secure, 0 otherwise. -# -############################################################################## -sub TLSClientSecure -{ - my $self = shift; - my $sid = shift; - - return $self->{SIDS}->{$sid}->{tls}->{secure}; -} - - -############################################################################## -# -# TLSClientDone - return 1 if the TLS process is done -# -############################################################################## -sub TLSClientDone -{ - my $self = shift; - my $sid = shift; - - return $self->{SIDS}->{$sid}->{tls}->{done}; -} - - -############################################################################## -# -# TLSClientError - return the TLS error if any -# -############################################################################## -sub TLSClientError -{ - my $self = shift; - my $sid = shift; - - return $self->{SIDS}->{$sid}->{tls}->{error}; -} - - -############################################################################## -# -# TLSClientFailure - handle a <failure/> -# -############################################################################## -sub TLSClientFailure -{ - my $self = shift; - my $sid = shift; - my $node = shift; - - my $type = &XPath($node,"*/name()"); - - $self->{SIDS}->{$sid}->{tls}->{error} = $type; - $self->{SIDS}->{$sid}->{tls}->{done} = 1; -} - - -############################################################################## -# -# TLSFailure - Send a <failure/> in the TLS namespace -# -############################################################################## -sub TLSFailure -{ - my $self = shift; - my $sid = shift; - my $type = shift; - - $self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-tls')."'><${type}/></failure>"); -} - - - - -############################################################################## -#+---------------------------------------------------------------------------- -#| -#| SASL Functions -#| -#+---------------------------------------------------------------------------- -############################################################################## - -############################################################################## -# -# ProcessSASLPacket - process a SASL based packet. -# -############################################################################## -sub ProcessSASLPacket -{ - my $self = shift; - my $sid = shift; - my $node = shift; - - my $tag = &XPath($node,"name()"); - - if ($tag eq "challenge") - { - $self->SASLAnswerChallenge($sid,$node); - } - - if ($tag eq "failure") - { - $self->SASLClientFailure($sid,$node); - } - - if ($tag eq "success") - { - $self->SASLClientSuccess($sid,$node); - } -} - - -############################################################################## -# -# SASLAnswerChallenge - when we get a <challenge/> we need to do the grunt -# work to return a <response/>. -# -############################################################################## -sub SASLAnswerChallenge -{ - my $self = shift; - my $sid = shift; - my $node = shift; - - my $challenge64 = &XPath($node,"text()"); - my $challenge = MIME::Base64::decode_base64($challenge64); - - #------------------------------------------------------------------------- - # As far as I can tell, if the challenge contains rspauth, then we authed. - # If you try to send that to Authen::SASL, it will spew warnings about - # the missing qop, nonce, etc... However, in order for jabberd2 to think - # that you answered, you have to send back an empty response. Not sure - # which approach is right... So let's hack for now. - #------------------------------------------------------------------------- - my $response = ""; - if ($challenge !~ /rspauth\=/) - { - $response = $self->{SIDS}->{$sid}->{sasl}->{client}->client_step($challenge); - } - - my $response64 = MIME::Base64::encode_base64($response,""); - $self->SASLResponse($sid,$response64); -} - - -############################################################################## -# -# SASLAuth - send an <auth/> in the SASL namespace -# -############################################################################## -sub SASLAuth -{ - my $self = shift; - my $sid = shift; - - my $first_step = $self->{SIDS}->{$sid}->{sasl}->{client}->client_start(); - my $first_step64 = MIME::Base64::encode_base64($first_step,""); - - $self->Send($sid,"<auth xmlns='".&ConstXMLNS('xmpp-sasl')."' mechanism='".$self->{SIDS}->{$sid}->{sasl}->{client}->mechanism()."'>".$first_step64."</auth>"); -} - - -############################################################################## -# -# SASLChallenge - Send a <challenge/> in the SASL namespace -# -############################################################################## -sub SASLChallenge -{ - my $self = shift; - my $sid = shift; - my $challenge = shift; - - $self->Send($sid,"<challenge xmlns='".&ConstXMLNS('xmpp-sasl')."'>${challenge}</challenge>"); -} - - -############################################################################### -# -# SASLClient - This is a helper function to perform all of the required steps -# for doing SASL with the server. -# -############################################################################### -sub SASLClient -{ - my $self = shift; - my $sid = shift; - my $username = shift; - my $password = shift; - - my $mechanisms = $self->GetStreamFeature($sid,"xmpp-sasl"); - - return unless defined($mechanisms); - - my $sasl = new Authen::SASL(mechanism=>join(" ",@{$mechanisms}), - callback=>{ - authname => $username."@".$self->{SIDS}->{$sid}->{hostname}, - - user => $username, - pass => $password - } - ); - - $self->{SIDS}->{$sid}->{sasl}->{client} = $sasl->client_new(); - $self->{SIDS}->{$sid}->{sasl}->{username} = $username; - $self->{SIDS}->{$sid}->{sasl}->{password} = $password; - $self->{SIDS}->{$sid}->{sasl}->{authed} = 0; - $self->{SIDS}->{$sid}->{sasl}->{done} = 0; - - $self->SASLAuth($sid); -} - - -############################################################################## -# -# SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise -# -############################################################################## -sub SASLClientAuthed -{ - my $self = shift; - my $sid = shift; - - return $self->{SIDS}->{$sid}->{sasl}->{authed}; -} - - -############################################################################## -# -# SASLClientDone - return 1 if the SASL process is finished -# -############################################################################## -sub SASLClientDone -{ - my $self = shift; - my $sid = shift; - - return $self->{SIDS}->{$sid}->{sasl}->{done}; -} - - -############################################################################## -# -# SASLClientError - return the error if any -# -############################################################################## -sub SASLClientError -{ - my $self = shift; - my $sid = shift; - - return $self->{SIDS}->{$sid}->{sasl}->{error}; -} - - -############################################################################## -# -# SASLClientFailure - handle a received <failure/> -# -############################################################################## -sub SASLClientFailure -{ - my $self = shift; - my $sid = shift; - my $node = shift; - - my $type = &XPath($node,"*/name()"); - - $self->{SIDS}->{$sid}->{sasl}->{error} = $type; - $self->{SIDS}->{$sid}->{sasl}->{done} = 1; -} - - -############################################################################## -# -# SASLClientSuccess - handle a received <success/> -# -############################################################################## -sub SASLClientSuccess -{ - my $self = shift; - my $sid = shift; - my $node = shift; - - $self->{SIDS}->{$sid}->{sasl}->{authed} = 1; - $self->{SIDS}->{$sid}->{sasl}->{done} = 1; -} - - -############################################################################## -# -# SASLFailure - Send a <failure/> tag in the SASL namespace -# -############################################################################## -sub SASLFailure -{ - my $self = shift; - my $sid = shift; - my $type = shift; - - $self->Send($sid,"<failure xmlns='".&ConstXMLNS('xmpp-sasl')."'><${type}/></failure>"); -} - - -############################################################################## -# -# SASLResponse - Send a <response/> tag in the SASL namespace -# -############################################################################## -sub SASLResponse -{ - my $self = shift; - my $sid = shift; - my $response = shift; - - $self->Send($sid,"<response xmlns='".&ConstXMLNS('xmpp-sasl')."'>${response}</response>"); -} - - - - -############################################################################## -#+---------------------------------------------------------------------------- -#| -#| Packet Handlers -#| -#+---------------------------------------------------------------------------- -############################################################################## - - -############################################################################## -# -# ProcessStreamPacket - process the <stream:XXXX/> packet -# -############################################################################## -sub ProcessStreamPacket -{ - my $self = shift; - my $sid = shift; - my $node = shift; - - my $tag = &XPath($node,"name()"); - my $stream_prefix = $self->StreamPrefix($sid); - my ($type) = ($tag =~ /^${stream_prefix}\:(.+)$/); - - $self->ProcessStreamError($sid,$node) if ($type eq "error"); - $self->ProcessStreamFeatures($sid,$node) if ($type eq "features"); -} - - -############################################################################## -# -# _handle_root - handles a root tag and checks that it is a stream:stream tag -# with the proper namespace. If not then it sets the STATUS -# to -1 and let's the outer code know that an error occurred. -# Then it changes the Start tag handlers to the methond listed -# in $self->{DATASTYLE} -# -############################################################################## -sub _handle_root -{ - my $self = shift; - my ($sax, $tag, %att) = @_; - my $sid = $sax->getSID(); - - $self->debug(2,"_handle_root: sid($sid) sax($sax) tag($tag) att(",%att,")"); - - $self->{SIDS}->{$sid}->{rootTag} = $tag; - - if ($self->{SIDS}->{$sid}->{connectiontype} ne "file") - { - #--------------------------------------------------------------------- - # Make sure we are receiving a valid stream on the same namespace. - #--------------------------------------------------------------------- - - $self->debug(3,"_handle_root: ($self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})"); - $self->{SIDS}->{$sid}->{status} = - ((($tag eq "stream:stream") && - exists($att{'xmlns'}) && - ($att{'xmlns'} eq $self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace}) - ) ? - 1 : - -1 - ); - $self->debug(3,"_handle_root: status($self->{SIDS}->{$sid}->{status})"); - } - else - { - $self->{SIDS}->{$sid}->{status} = 1; - } - - #------------------------------------------------------------------------- - # Get the root tag attributes and save them for later. You never know when - # you'll need to check the namespace or the from attributes sent by the - # server. - #------------------------------------------------------------------------- - $self->{SIDS}->{$sid}->{root} = \%att; - - #------------------------------------------------------------------------- - # Run through the various xmlns:*** attributes and register the namespace - # to prefix map. - #------------------------------------------------------------------------- - foreach my $key (keys(%att)) - { - if ($key =~ /^xmlns\:(.+?)$/) - { - $self->debug(5,"_handle_root: RegisterPrefix: prefix($att{$key}) ns($1)"); - $self->RegisterPrefix($sid,$att{$key},$1); - } - } - - #------------------------------------------------------------------------- - # Sometimes we will get an error, so let's parse the tag assuming that we - # got a stream:error - #------------------------------------------------------------------------- - my $stream_prefix = $self->StreamPrefix($sid); - $self->debug(5,"_handle_root: stream_prefix($stream_prefix)"); - - if ($tag eq $stream_prefix.":error") - { - &XML::Stream::Tree::_handle_element($self,$sax,$tag,%att) - if ($self->{DATASTYLE} eq "tree"); - &XML::Stream::Node::_handle_element($self,$sax,$tag,%att) - if ($self->{DATASTYLE} eq "node"); - } - - #--------------------------------------------------------------------------- - # Now that we have gotten a root tag, let's look for the tags that make up - # the stream. Change the handler for a Start tag to another function. - #--------------------------------------------------------------------------- - $sax->setHandlers(startElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{startElement}}($self,@_) }, - endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) }, - characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) }, - ); -} - - -############################################################################## -# -# _node - internal callback for nodes. All it does is place the nodes in a -# list so that Process() can return them later. -# -############################################################################## -sub _node -{ - my $self = shift; - my $sid = shift; - my @node = shift; - - if (ref($node[0]) eq "XML::Stream::Node") - { - push(@{$self->{SIDS}->{$sid}->{nodes}},$node[0]); - } - else - { - push(@{$self->{SIDS}->{$sid}->{nodes}},\@node); - } -} - - - - -############################################################################## -#+---------------------------------------------------------------------------- -#| -#| Error Functions -#| -#+---------------------------------------------------------------------------- -############################################################################## - -############################################################################## -# -# GetErrorCode - if you are returned an undef, you can call this function -# and hopefully learn more information about the problem. -# -############################################################################## -sub GetErrorCode -{ - my $self = shift; - my $sid = shift; - - $sid = "newconnection" unless defined($sid); - - $self->debug(3,"GetErrorCode: sid($sid)"); - return ((exists($self->{SIDS}->{$sid}->{errorcode}) && - (ref($self->{SIDS}->{$sid}->{errorcode}) eq "HASH")) ? - $self->{SIDS}->{$sid}->{errorcode} : - { type=>"system", - text=>$!, - } - ); -} - - -############################################################################## -# -# SetErrorCode - sets the error code so that the caller can find out more -# information about the problem -# -############################################################################## -sub SetErrorCode -{ - my $self = shift; - my $sid = shift; - my $errorcode = shift; - - $self->{SIDS}->{$sid}->{errorcode} = $errorcode; -} - - -############################################################################## -# -# ProcessStreamError - Take the XML packet and extract out the error. -# -############################################################################## -sub ProcessStreamError -{ - my $self = shift; - my $sid = shift; - my $node = shift; - - $self->{SIDS}->{$sid}->{streamerror}->{type} = "unknown"; - $self->{SIDS}->{$sid}->{streamerror}->{node} = $node; - - #------------------------------------------------------------------------- - # Check for older 0.9 streams and handle the errors for them. - #------------------------------------------------------------------------- - if (!exists($self->{SIDS}->{$sid}->{root}->{version}) || - ($self->{SIDS}->{$sid}->{root}->{version} eq "") || - ($self->{SIDS}->{$sid}->{root}->{version} < 1.0) - ) - { - $self->{SIDS}->{$sid}->{streamerror}->{text} = - &XPath($node,"text()"); - return; - } - - #------------------------------------------------------------------------- - # Otherwise we are in XMPP land with real stream errors. - #------------------------------------------------------------------------- - my @errors = &XPath($node,'*[@xmlns="'.&ConstXMLNS("xmppstreams").'"]'); - - my $type; - my $text; - foreach my $error (@errors) - { - if (&XPath($error,"name()") eq "text") - { - $self->{SIDS}->{$sid}->{streamerror}->{text} = - &XPath($error,"text()"); - } - else - { - $self->{SIDS}->{$sid}->{streamerror}->{type} = - &XPath($error,"name()"); - } - } -} - - -############################################################################## -# -# StreamError - Given a type and text, generate a <stream:error/> packet to -# send back to the other side. -# -############################################################################## -sub StreamError -{ - my $self = shift; - my $sid = shift; - my $type = shift; - my $text = shift; - - my $root = $self->GetRoot($sid); - my $stream_base = $self->StreamPrefix($sid); - my $error = "<${stream_base}:error>"; - - if (exists($root->{version}) && ($root->{version} ne "")) - { - $error .= "<${type} xmlns='".&ConstXMLNS('xmppstreams')."'/>"; - if (defined($text)) - { - $error .= "<text xmlns='".&ConstXMLNS('xmppstreams')."'>"; - $error .= $text; - $error .= "</text>"; - } - } - else - { - $error .= $text; - } - - $error .= "</${stream_base}:error>"; - - return $error; -} - - - - -############################################################################## -#+---------------------------------------------------------------------------- -#| -#| Activity Monitoring Functions -#| -#+---------------------------------------------------------------------------- -############################################################################## - -############################################################################## -# -# IgnoreActivity - Set the flag that will ignore the activity monitor. -# -############################################################################## -sub IgnoreActivity -{ - my $self = shift; - my $sid = shift; - my $ignoreActivity = shift; - $ignoreActivity = 1 unless defined($ignoreActivity); - - $self->debug(3,"IgnoreActivity: ignoreActivity($ignoreActivity)"); - $self->debug(4,"IgnoreActivity: sid($sid)"); - - $self->{SIDS}->{$sid}->{ignoreActivity} = $ignoreActivity; -} - - -############################################################################## -# -# LastActivity - Return the time of the last activity. -# -############################################################################## -sub LastActivity -{ - my $self = shift; - my $sid = shift; - - $self->debug(3,"LastActivity: sid($sid)"); - $self->debug(1,"LastActivity: lastActivity($self->{SIDS}->{$sid}->{lastActivity})"); - - return $self->{SIDS}->{$sid}->{lastActivity}; -} - - -############################################################################## -# -# MarkActivity - Record the current time for this sid. -# -############################################################################## -sub MarkActivity -{ - my $self = shift; - my $sid = shift; - - return if (exists($self->{SIDS}->{$sid}->{ignoreActivity}) && - ($self->{SIDS}->{$sid}->{ignoreActivity} == 1)); - - $self->debug(3,"MarkActivity: sid($sid)"); - - $self->{SIDS}->{$sid}->{lastActivity} = time; -} - - - - -############################################################################## -#+---------------------------------------------------------------------------- -#| -#| XML Node Interface functions -#| -#| These are generic wrappers around the Tree and Node data types. The -#| problem being that the Tree class cannot support methods. -#| -#+---------------------------------------------------------------------------- -############################################################################## - -############################################################################## -# -# SetXMLData - takes a host of arguments and sets a portion of the specified -# data strucure with that data. The function works in two -# modes "single" or "multiple". "single" denotes that the -# function should locate the current tag that matches this -# data and overwrite it's contents with data passed in. -# "multiple" denotes that a new tag should be created even if -# others exist. -# -# type - single or multiple -# XMLTree - pointer to XML::Stream data object (tree or node) -# tag - name of tag to create/modify (if blank assumes -# working with top level tag) -# data - CDATA to set for tag -# attribs - attributes to ADD to tag -# -############################################################################## -sub SetXMLData -{ - return &XML::Stream::Node::SetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node"); - return &XML::Stream::Tree::SetXMLData(@_) if (ref($_[1]) eq "ARRAY"); -} - - -############################################################################## -# -# GetXMLData - takes a host of arguments and returns various data structures -# that match them. -# -# type - "existence" - returns 1 or 0 if the tag exists in the -# top level. -# "value" - returns either the CDATA of the tag, or the -# value of the attribute depending on which is -# sought. This ignores any mark ups to the data -# and just returns the raw CDATA. -# "value array" - returns an array of strings representing -# all of the CDATA in the specified tag. -# This ignores any mark ups to the data -# and just returns the raw CDATA. -# "tree" - returns a data structure that represents the -# XML with the specified tag as the root tag. -# Depends on the format that you are working with. -# "tree array" - returns an array of data structures each -# with the specified tag as the root tag. -# "child array" - returns a list of all children nodes -# not including CDATA nodes. -# "attribs" - returns a hash with the attributes, and -# their values, for the things that match -# the parameters -# "count" - returns the number of things that match -# the arguments -# "tag" - returns the root tag of this tree -# XMLTree - pointer to XML::Stream data structure -# tag - tag to pull data from. If blank then the top level -# tag is accessed. -# attrib - attribute value to retrieve. Ignored for types -# "value array", "tree", "tree array". If paired -# with value can be used to filter tags based on -# attributes and values. -# value - only valid if an attribute is supplied. Used to -# filter for tags that only contain this attribute. -# Useful to search through multiple tags that all -# reference different name spaces. -# -############################################################################## -sub GetXMLData -{ - return &XML::Stream::Node::GetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node"); - return &XML::Stream::Tree::GetXMLData(@_) if (ref($_[1]) eq "ARRAY"); -} - - -############################################################################## -# -# XPath - run an xpath query on a node and return back the result. -# -############################################################################## -sub XPath -{ - my $tree = shift; - my $path = shift; - - my $query = new XML::Stream::XPath::Query($path); - my $result = $query->execute($tree); - if ($result->check()) - { - my %attribs = $result->getAttribs(); - return %attribs if (scalar(keys(%attribs)) > 0); - - my @values = $result->getValues(); - @values = $result->getList() unless ($#values > -1); - return @values if wantarray; - return $values[0]; - } - return; -} - - -############################################################################## -# -# XPathCheck - run an xpath query on a node and return 1 or 0 if the path is -# valid. -# -############################################################################## -sub XPathCheck -{ - my $tree = shift; - my $path = shift; - - my $query = new XML::Stream::XPath::Query($path); - my $result = $query->execute($tree); - return $result->check(); -} - - -############################################################################## -# -# XML2Config - takes an XML data tree and turns it into a hash of hashes. -# This only works for certain kinds of XML trees like this: -# -# <foo> -# <bar>1</bar> -# <x> -# <y>foo</y> -# </x> -# <z>5</z> -# <z>6</z> -# </foo> -# -# The resulting hash would be: -# -# $hash{bar} = 1; -# $hash{x}->{y} = "foo"; -# $hash{z}->[0] = 5; -# $hash{z}->[1] = 6; -# -# Good for config files. -# -############################################################################## -sub XML2Config -{ - return &XML::Stream::Node::XML2Config(@_) if (ref($_[0]) eq "XML::Stream::Node"); - return &XML::Stream::Tree::XML2Config(@_) if (ref($_[0]) eq "ARRAY"); -} - - -############################################################################## -# -# Config2XML - takes a hash and produces an XML string from it. If the hash -# looks like this: -# -# $hash{bar} = 1; -# $hash{x}->{y} = "foo"; -# $hash{z}->[0] = 5; -# $hash{z}->[1] = 6; -# -# The resulting xml would be: -# -# <foo> -# <bar>1</bar> -# <x> -# <y>foo</y> -# </x> -# <z>5</z> -# <z>6</z> -# </foo> -# -# Good for config files. -# -############################################################################## -sub Config2XML -{ - my ($tag,$hash,$indent) = @_; - $indent = "" unless defined($indent); - - my $xml; - - if (ref($hash) eq "ARRAY") - { - foreach my $item (@{$hash}) - { - $xml .= &XML::Stream::Config2XML($tag,$item,$indent); - } - } - else - { - if ((ref($hash) eq "HASH") && ((scalar keys(%{$hash})) == 0)) - { - $xml .= "$indent<$tag/>\n"; - } - else - { - if (ref($hash) eq "") - { - if ($hash eq "") - { - return "$indent<$tag/>\n"; - } - else - { - return "$indent<$tag>$hash</$tag>\n"; - } - } - else - { - $xml .= "$indent<$tag>\n"; - foreach my $item (sort {$a cmp $b} keys(%{$hash})) - { - $xml .= &XML::Stream::Config2XML($item,$hash->{$item}," $indent"); - } - $xml .= "$indent</$tag>\n"; - } - } - } - return $xml; -} - - -############################################################################## -# -# EscapeXML - Simple function to make sure that no bad characters make it into -# in the XML string that might cause the string to be -# misinterpreted. -# -############################################################################## -sub EscapeXML -{ - my $data = shift; - - if (defined($data)) - { - $data =~ s/&/&/g; - $data =~ s/</</g; - $data =~ s/>/>/g; - $data =~ s/\"/"/g; - $data =~ s/\'/'/g; - } - - return $data; -} - - -############################################################################## -# -# UnescapeXML - Simple function to take an escaped string and return it to -# normal. -# -############################################################################## -sub UnescapeXML -{ - my $data = shift; - - if (defined($data)) - { - $data =~ s/&/&/g; - $data =~ s/</</g; - $data =~ s/>/>/g; - $data =~ s/"/\"/g; - $data =~ s/'/\'/g; - } - - return $data; -} - - -############################################################################## -# -# BuildXML - takes one of the data formats that XML::Stream supports and call -# the proper BuildXML_xxx function on it. -# -############################################################################## -sub BuildXML -{ - return &XML::Stream::Node::BuildXML(@_) if (ref($_[0]) eq "XML::Stream::Node"); - return &XML::Stream::Tree::BuildXML(@_) if (ref($_[0]) eq "ARRAY"); - return &XML::Stream::Tree::BuildXML(@_) if (ref($_[1]) eq "ARRAY"); -} - - - -############################################################################## -#+---------------------------------------------------------------------------- -#| -#| Namespace/Prefix Functions -#| -#+---------------------------------------------------------------------------- -############################################################################## - -############################################################################## -# -# ConstXMLNS - Return the namespace from the constant string. -# -############################################################################## -sub ConstXMLNS -{ - my $const = shift; - - return $XMLNS{$const}; -} - - -############################################################################## -# -# StreamPrefix - Return the prefix of the <stream:stream/> -# -############################################################################## -sub StreamPrefix -{ - my $self = shift; - my $sid = shift; - - return $self->ns2prefix($sid,&ConstXMLNS("stream")); -} - - -############################################################################## -# -# RegisterPrefix - setup the map for namespace to prefix -# -############################################################################## -sub RegisterPrefix -{ - my $self = shift; - my $sid = shift; - my $ns = shift; - my $prefix = shift; - - $self->{SIDS}->{$sid}->{ns2prefix}->{$ns} = $prefix; -} - - -############################################################################## -# -# ns2prefix - for a stream, return the prefix for the given namespace -# -############################################################################## -sub ns2prefix -{ - my $self = shift; - my $sid = shift; - my $ns = shift; - - return $self->{SIDS}->{$sid}->{ns2prefix}->{$ns}; -} - - - - -############################################################################## -#+---------------------------------------------------------------------------- -#| -#| Helper Functions -#| -#+---------------------------------------------------------------------------- -############################################################################## - -############################################################################## -# -# GetRoot - returns the hash of attributes for the root <stream:stream/> tag -# so that any attributes returned can be accessed. from and any -# xmlns:foobar might be important. -# -############################################################################## -sub GetRoot -{ - my $self = shift; - my $sid = shift; - return unless exists($self->{SIDS}->{$sid}->{root}); - return $self->{SIDS}->{$sid}->{root}; -} - - -############################################################################## -# -# GetSock - returns the Socket so that an outside function can access it if -# desired. -# -############################################################################## -sub GetSock -{ - my $self = shift; - my $sid = shift; - return $self->{SIDS}->{$sid}->{sock}; -} - - -############################################################################## -# -# LoadSSL - simple call to set everything up for SSL one time. -# -############################################################################## -sub LoadSSL -{ - my $self = shift; - - $self->debug(1,"LoadSSL: Load the IO::Socket::SSL module"); - - if (defined($SSL) && ($SSL == 1)) - { - $self->debug(1,"LoadSSL: Success"); - return 1; - } - - if (defined($SSL) && ($SSL == 0)) - { - $self->debug(1,"LoadSSL: Failure"); - return; - } - - my $SSL_Version = "0.81"; - eval "use IO::Socket::SSL $SSL_Version"; - if ($@) - { - croak("You requested that XML::Stream turn the socket into an SSL socket, but you don't have the correct version of IO::Socket::SSL v$SSL_Version."); - } - IO::Socket::SSL::context_init({SSL_verify_mode=>0x00}); - $SSL = 1; - - $self->debug(1,"LoadSSL: Success"); - return 1; -} - - -############################################################################## -# -# Host2SID - For a server this allows you to lookup the SID of a stream server -# based on the hostname that is is listening on. -# -############################################################################## -sub Host2SID -{ - my $self = shift; - my $hostname = shift; - - foreach my $sid (keys(%{$self->{SIDS}})) - { - next if ($sid eq "default"); - next if ($sid =~ /^server/); - - return $sid if ($self->{SIDS}->{$sid}->{hostname} eq $hostname); - } - return; -} - - -############################################################################## -# -# NewSID - returns a session ID to send to an incoming stream in the return -# header. By default it just increments a counter and returns that, -# or you can define a function and set it using the SetCallBacks -# function. -# -############################################################################## -sub NewSID -{ - my $self = shift; - return &{$self->{CB}->{sid}}() if (exists($self->{CB}->{sid}) && - defined($self->{CB}->{sid})); - return $$.time.$self->{IDCOUNT}++; -} - - -########################################################################### -# -# SetCallBacks - Takes a hash with top level tags to look for as the keys -# and pointers to functions as the values. -# -########################################################################### -sub SetCallBacks -{ - my $self = shift; - while($#_ >= 0) { - my $func = pop(@_); - my $tag = pop(@_); - if (($tag eq "node") && !defined($func)) - { - $self->SetCallBacks(node=>sub { $self->_node(@_) }); - } - else - { - $self->debug(1,"SetCallBacks: tag($tag) func($func)"); - $self->{CB}->{$tag} = $func; - } - } -} - - -############################################################################## -# -# StreamHeader - Given the arguments, return the opening stream header. -# -############################################################################## -sub StreamHeader -{ - my $self = shift; - my (%args) = @_; - - my $stream; - $stream .= "<?xml version='1.0'?>"; - $stream .= "<stream:stream "; - $stream .= "version='1.0' "; - $stream .= "xmlns:stream='".&ConstXMLNS("stream")."' "; - $stream .= "xmlns='$args{xmlns}' "; - $stream .= "to='$args{to}' " if exists($args{to}); - $stream .= "from='$args{from}' " if exists($args{from}); - $stream .= "xml:lang='$args{xmllang}' " if exists($args{xmllang}); - - foreach my $ns (@{$args{namespaces}}) - { - $stream .= " ".$ns->GetStream(); - } - - $stream .= ">"; - - return $stream; -} - - -########################################################################### -# -# debug - prints the arguments to the debug log if debug is turned on. -# -########################################################################### -sub debug -{ - return if ($_[1] > $_[0]->{DEBUGLEVEL}); - my $self = shift; - my ($limit,@args) = @_; - return if ($self->{DEBUGFILE} eq ""); - my $fh = $self->{DEBUGFILE}; - if ($self->{DEBUGTIME} == 1) - { - my ($sec,$min,$hour) = localtime(time); - print $fh sprintf("[%02d:%02d:%02d] ",$hour,$min,$sec); - } - print $fh "XML::Stream: @args\n"; -} - - -############################################################################## -# -# nonblock - set the socket to be non-blocking. -# -############################################################################## -sub nonblock -{ - my $self = shift; - my $socket = shift; - - #-------------------------------------------------------------------------- - # Code copied from POE::Wheel::SocketFactory... - # Win32 does things one way... - #-------------------------------------------------------------------------- - if ($^O eq "MSWin32") - { - ioctl( $socket, 0x80000000 | (4 << 16) | (ord('f') << 8) | 126, 1) || - croak("Can't make socket nonblocking (win32): $!"); - return; - } - - #-------------------------------------------------------------------------- - # And UNIX does them another - #-------------------------------------------------------------------------- - my $flags = fcntl($socket, F_GETFL, 0) - or die "Can't get flags for socket: $!\n"; - fcntl($socket, F_SETFL, $flags | O_NONBLOCK) - or die "Can't make socket nonblocking: $!\n"; -} - - -############################################################################## -# -# printData - debugging function to print out any data structure in an -# organized manner. Very useful for debugging XML::Parser::Tree -# objects. This is a private function that will only exist in -# in the development version. -# -############################################################################## -sub printData -{ - print &sprintData(@_); -} - - -############################################################################## -# -# sprintData - debugging function to build a string out of any data structure -# in an organized manner. Very useful for debugging -# XML::Parser::Tree objects and perl hashes of hashes. -# -# This is a private function. -# -############################################################################## -sub sprintData -{ - my ($preString,$data) = @_; - - my $outString = ""; - - if (ref($data) eq "HASH") - { - my $key; - foreach $key (sort { $a cmp $b } keys(%{$data})) - { - if (ref($$data{$key}) eq "") - { - my $value = defined($$data{$key}) ? $$data{$key} : ""; - $outString .= $preString."{'$key'} = \"".$value."\";\n"; - } - else - { - if (ref($$data{$key}) =~ /Net::Jabber/) - { - $outString .= $preString."{'$key'} = ".ref($$data{$key}).";\n"; - } - else - { - $outString .= $preString."{'$key'};\n"; - $outString .= &sprintData($preString."{'$key'}->",$$data{$key}); - } - } - } - } - else - { - if (ref($data) eq "ARRAY") - { - my $index; - foreach $index (0..$#{$data}) - { - if (ref($$data[$index]) eq "") - { - $outString .= $preString."[$index] = \"$$data[$index]\";\n"; - } - else - { - if (ref($$data[$index]) =~ /Net::Jabber/) - { - $outString .= $preString."[$index] = ".ref($$data[$index]).";\n"; - } - else - { - $outString .= $preString."[$index];\n"; - $outString .= &sprintData($preString."[$index]->",$$data[$index]); - } - } - } - } - else - { - if (ref($data) eq "REF") - { - $outString .= &sprintData($preString."->",$$data); - } - else - { - if (ref($data) eq "") - { - $outString .= $preString." = \"$data\";\n"; - } - else - { - $outString .= $preString." = ".ref($data).";\n"; - } - } - } - } - - return $outString; -} - - -1; diff --git a/lib/XML/Stream/Namespace.pm b/lib/XML/Stream/Namespace.pm deleted file mode 100644 index a9aee25..0000000 --- a/lib/XML/Stream/Namespace.pm +++ /dev/null @@ -1,190 +0,0 @@ -############################################################################## -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Library General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Library General Public License for more details. -# -# You should have received a copy of the GNU Library General Public -# License along with this library; if not, write to the -# Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. -# -# Jabber -# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ -# -############################################################################## - -package XML::Stream::Namespace; - -=head1 NAME - -XML::Stream::Namespace - Object to make defining Namespaces easier in - XML::Stream. - -=head1 SYNOPSIS - -XML::Stream::Namespace is a helper package to XML::Stream. It provides -a clean way of defining Namespaces for XML::Stream to use when connecting. - -=head1 DESCRIPTION - - This module allows you to set and read elements from an XML::Stream - Namespace. - -=head1 METHODS - - SetNamespace("mynamespace"); - SetXMLNS("http://www.mynamespace.com/xmlns"); - SetAttributes(attrib1=>"value1", - attrib2=>"value2"); - - GetNamespace() returns "mynamespace" - GetXMLNS() returns "http://www.mynamespace.com/xmlns" - GetAttributes() returns a hash ( attrib1=>"value1",attrib2=>"value2") - GetStream() returns the following string: - "xmlns:mynamespace='http://www.nynamespace.com/xmlns' - mynamespace:attrib1='value1' - mynamespace:attrib2='value2'" - -=head1 EXAMPLES - - - $myNamespace = new XML::Stream::Namespace("mynamspace"); - $myNamespace->SetXMLNS("http://www.mynamespace.org/xmlns"); - $myNamespace->SetAttributes(foo=>"bar", - bob=>"vila"); - - $stream = new XML::Stream; - $stream->Connect(name=>"foo.bar.org", - port=>1234, - namespace=>"foo:bar", - namespaces=>[ $myNamespace ]); - - # - # The above Connect will send the following as the opening string - # of the stream to foo.bar.org:1234... - # - # <stream:stream - # xmlns:stream="http://etherx.jabber.org/streams" - # to="foo.bar.org" - # xmlns="foo:bar" - # xmlns:mynamespace="http://www.mynamespace.org/xmlns" - # mynamespace:foo="bar" - # mynamespace:bob="vila"> - # - - -=head1 AUTHOR - -Written by Ryan Eatmon in February 2000 -Idea By Thomas Charron in January of 2000 for http://etherx.jabber.org/streams/ - -=head1 COPYRIGHT - -This module is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -use strict; -use Carp; -use vars qw( $VERSION ); - -$VERSION = "1.22"; - -sub new -{ - my $proto = shift; - my $self = { }; - - ($self->{Namespace}) = @_ if ($#_ > -1); - - $self->{Attributes} = {}; - - bless($self,$proto); - return $self; -} - - -sub SetNamespace -{ - my $self = shift; - my ($namespace) = @_; - - $self->{Namespace} = $namespace; -} - - -sub SetXMLNS -{ - my $self = shift; - my ($xmlns) = @_; - - $self->{XMLNS} = $xmlns; -} - - -sub SetAttributes -{ - my $self = shift; - my %att = @_; - - my $key; - foreach $key (keys(%att)) - { - $self->{Attributes}->{$key} = $att{$key}; - } -} - - -sub GetNamespace -{ - my $self = shift; - - return $self->{Namespace}; -} - -sub GetXMLNS -{ - my $self = shift; - - return $self->{XMLNS}; -} - -sub GetAttributes -{ - my $self = shift; - my ($attrib) = @_; - - return $self->{Attributes} if ($attrib eq ""); - return $self->{Attributes}->{$attrib}; -} - - -sub GetStream -{ - my $self = shift; - - my $string = ""; - - $string .= "xmlns:".$self->GetNamespace(); - $string .= "='".$self->GetXMLNS()."'"; - my $attrib; - foreach $attrib (keys(%{$self->GetAttributes()})) - { - $string .= " ".$self->GetNamespace().":"; - $string .= $attrib; - $string .= "='".$self->GetAttributes($attrib)."'"; - } - - return $string; -} - -1; - diff --git a/lib/XML/Stream/Node.pm b/lib/XML/Stream/Node.pm deleted file mode 100644 index 4dca834..0000000 --- a/lib/XML/Stream/Node.pm +++ /dev/null @@ -1,944 +0,0 @@ -############################################################################## -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Library General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Library General Public License for more details. -# -# You should have received a copy of the GNU Library General Public -# License along with this library; if not, write to the -# Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. -# -# Jabber -# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ -# -############################################################################## - -package XML::Stream::Node; - -=head1 NAME - -XML::Stream::Node - Functions to make building and parsing the tree easier -to work with. - -=head1 SYNOPSIS - - Just a collection of functions that do not need to be in memory if you -choose one of the other methods of data storage. - - This creates a hierarchy of Perl objects and provides various methods -to manipulate the structure of the tree. It is much like the C library -libxml. - -=head1 FORMAT - -The result of parsing: - - <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo> - -would be: - - [ tag: foo - att: {} - children: [ tag: head - att: {id=>"a"} - children: [ tag: "__xmlstream__:node:cdata" - children: "Hello " - ] - [ tag: em - children: [ tag: "__xmlstream__:node:cdata" - children: "there" - ] - ] - ] - [ tag: bar - children: [ tag: "__xmlstream__:node:cdata" - children: "Howdy " - ] - [ tag: ref - ] - ] - [ tag: "__xmlstream__:node:cdata" - children: "do" - ] - ] - -=head1 METHODS - - new() - creates a new node. If you specify tag, then the root - new(tag) tag is set. If you specify data, then cdata is added - new(tag,cdata) to the node as well. Returns the created node. - - get_tag() - returns the root tag of the node. - - set_tag(tag) - set the root tag of the node to tag. - - add_child(node) - adds the specified node as a child to the current - add_child(tag) node, or creates a new node with the specified tag - add_child(tag,cdata) as the root node. Returns the node added. - - remove_child(node) - removes the child node from the current node. - - remove_cdata() - removes all of the cdata children from the current node. - - add_cdata(string) - adds the string as cdata onto the current nodes - child list. - - get_cdata() - returns all of the cdata children concatenated together - into one string. - - get_attrib(attrib) - returns the value of the attrib if it is valid, - or returns undef is attrib is not a real - attribute. - - put_attrib(hash) - for each key/value pair specified, create an - attribute in the node. - - remove_attrib(attrib) - remove the specified attribute from the node. - - add_raw_xml(string,[string,...]) - directly add a string into the XML - packet as the last child, with no - translation. - - get_raw_xml() - return all of the XML in a single string, undef if there - is no raw XML to include. - - remove_raw_xml() - remove all raw XML strings. - - children() - return all of the children of the node in a list. - - attrib() - returns a hash containing all of the attributes on this - node. - - copy() - return a recursive copy of the node. - - XPath(path) - run XML::Stream::XPath on this node. - - XPathCheck(path) - run XML::Stream::XPath on this node and return 1 or 0 - to see if it matches or not. - - GetXML() - return the node in XML string form. - -=head1 AUTHOR - -By Ryan Eatmon in June 2002 for http://jabber.org/ - -=head1 COPYRIGHT - -This module is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -use vars qw( $VERSION $LOADED ); - -$VERSION = "1.22"; -$LOADED = 1; - -sub new -{ - my $proto = shift; - my $class = ref($proto) || $proto; - - if (ref($_[0]) eq "XML::Stream::Node") - { - return $_[0]; - } - - my $self = {}; - bless($self, $proto); - - my ($tag,$data) = @_; - - $self->set_tag($tag) if defined($tag); - $self->add_cdata($data) if defined($data); - $self->remove_raw_xml(); - - return $self; -} - - -sub debug -{ - my $self = shift; - my ($indent) = @_; - - $indent = "" unless defined($indent); - - if ($self->{TAG} eq "__xmlstream__:node:cdata") - { - print $indent,"cdata(",join("",@{$self->{CHILDREN}}),")\n"; - } - else - { - print $indent,"packet($self):\n"; - print $indent,"tag: <$self->{TAG}\n"; - if (scalar(keys(%{$self->{ATTRIBS}})) > 0) - { - print $indent,"attribs:\n"; - foreach my $key (sort {$a cmp $b} keys(%{$self->{ATTRIBS}})) - { - print $indent," $key = '$self->{ATTRIBS}->{$key}'\n"; - } - } - if ($#{$self->{CHILDREN}} == -1) - { - print $indent," />\n"; - } - else - { - print $indent," >\n"; - print $indent,"children:\n"; - foreach my $child (@{$self->{CHILDREN}}) - { - $child->debug($indent." "); - } - } - print $indent," </$self->{TAG}>\n"; - } -} - - -sub children -{ - my $self = shift; - - return () unless exists($self->{CHILDREN}); - return @{$self->{CHILDREN}}; -} - - -sub add_child -{ - my $self = shift; - - my $child = new XML::Stream::Node(@_); - push(@{$self->{CHILDREN}},$child); - return $child; -} - - -sub remove_child -{ - my $self = shift; - my $child = shift; - - foreach my $index (0..$#{$self->{CHILDREN}}) - { - if ($child == $self->{CHILDREN}->[$index]) - { - splice(@{$self->{CHILDREN}},$index,1); - last; - } - } -} - - -sub add_cdata -{ - my $self = shift; - my $child = new XML::Stream::Node("__xmlstream__:node:cdata"); - foreach my $cdata (@_) - { - push(@{$child->{CHILDREN}},$cdata); - } - push(@{$self->{CHILDREN}},$child); - return $child; -} - - -sub get_cdata -{ - my $self = shift; - - my $cdata = ""; - foreach my $child (@{$self->{CHILDREN}}) - { - $cdata .= join("",$child->children()) - if ($child->get_tag() eq "__xmlstream__:node:cdata"); - } - - return $cdata; -} - - -sub remove_cdata -{ - my $self = shift; - - my @remove = (); - foreach my $index (0..$#{$self->{CHILDREN}}) - { - if ($self->{CHILDREN}->[$index]->get_tag() eq "__xmlstream__:node:cdata") - { - - unshift(@remove,$index); - } - } - foreach my $index (@remove) - { - splice(@{$self->{CHILDREN}},$index,1); - } -} - - -sub attrib -{ - my $self = shift; - return () unless exists($self->{ATTRIBS}); - return %{$self->{ATTRIBS}}; -} - - -sub get_attrib -{ - my $self = shift; - my ($key) = @_; - - return unless exists($self->{ATTRIBS}->{$key}); - return $self->{ATTRIBS}->{$key}; -} - - -sub put_attrib -{ - my $self = shift; - my (%att) = @_; - - foreach my $key (keys(%att)) - { - $self->{ATTRIBS}->{$key} = $att{$key}; - } -} - - -sub remove_attrib -{ - my $self = shift; - my ($key) = @_; - - return unless exists($self->{ATTRIBS}->{$key}); - delete($self->{ATTRIBS}->{$key}); -} - - -sub add_raw_xml -{ - my $self = shift; - my (@raw) = @_; - - push(@{$self->{RAWXML}},@raw); -} - -sub get_raw_xml -{ - my $self = shift; - - return if ($#{$self->{RAWXML}} == -1); - return join("",@{$self->{RAWXML}}); -} - - -sub remove_raw_xml -{ - my $self = shift; - $self->{RAWXML} = []; -} - - -sub get_tag -{ - my $self = shift; - - return $self->{TAG}; -} - - -sub set_tag -{ - my $self = shift; - my ($tag) = @_; - - $self->{TAG} = $tag; -} - - -sub XPath -{ - my $self = shift; - my @results = &XML::Stream::XPath($self,@_); - return unless ($#results > -1); - return $results[0] unless wantarray; - return @results; -} - - -sub XPathCheck -{ - my $self = shift; - return &XML::Stream::XPathCheck($self,@_); -} - - -sub GetXML -{ - my $self = shift; - - return &BuildXML($self,@_); -} - - -sub copy -{ - my $self = shift; - - my $new_node = new XML::Stream::Node(); - $new_node->set_tag($self->get_tag()); - $new_node->put_attrib($self->attrib()); - - foreach my $child ($self->children()) - { - if ($child->get_tag() eq "__xmlstream__:node:cdata") - { - $new_node->add_cdata($self->get_cdata()); - } - else - { - $new_node->add_child($child->copy()); - } - } - - return $new_node; -} - - - - - -############################################################################## -# -# _handle_element - handles the main tag elements sent from the server. -# On an open tag it creates a new XML::Parser::Node so -# that _handle_cdata and _handle_element can add data -# and tags to it later. -# -############################################################################## -sub _handle_element -{ - my $self; - $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser"); - $self = shift unless (ref($_[0]) eq "XML::Stream::Parser"); - my ($sax, $tag, %att) = @_; - my $sid = $sax->getSID(); - - $self->debug(2,"Node: _handle_element: sid($sid) sax($sax) tag($tag) att(",%att,")"); - - my $node = new XML::Stream::Node($tag); - $node->put_attrib(%att); - - $self->debug(2,"Node: _handle_element: check(",$#{$self->{SIDS}->{$sid}->{node}},")"); - - if ($#{$self->{SIDS}->{$sid}->{node}} >= 0) - { - $self->{SIDS}->{$sid}->{node}->[$#{$self->{SIDS}->{$sid}->{node}}]-> - add_child($node); - } - - push(@{$self->{SIDS}->{$sid}->{node}},$node); -} - - -############################################################################## -# -# _handle_cdata - handles the CDATA that is encountered. Also, in the -# spirit of XML::Parser::Node it combines any sequential -# CDATA into one tag. -# -############################################################################## -sub _handle_cdata -{ - my $self; - $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser"); - $self = shift unless (ref($_[0]) eq "XML::Stream::Parser"); - my ($sax, $cdata) = @_; - my $sid = $sax->getSID(); - - $self->debug(2,"Node: _handle_cdata: sid($sid) sax($sax) cdata($cdata)"); - - return if ($#{$self->{SIDS}->{$sid}->{node}} == -1); - - $self->debug(2,"Node: _handle_cdata: sax($sax) cdata($cdata)"); - - $self->{SIDS}->{$sid}->{node}->[$#{$self->{SIDS}->{$sid}->{node}}]-> - add_cdata($cdata); -} - - -############################################################################## -# -# _handle_close - when we see a close tag we need to pop the last element -# from the list and push it onto the end of the previous -# element. This is how we build our hierarchy. -# -############################################################################## -sub _handle_close -{ - my $self; - $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser"); - $self = shift unless (ref($_[0]) eq "XML::Stream::Parser"); - my ($sax, $tag) = @_; - my $sid = $sax->getSID(); - - $self->debug(2,"Node: _handle_close: sid($sid) sax($sax) tag($tag)"); - - $self->debug(2,"Node: _handle_close: check(",$#{$self->{SIDS}->{$sid}->{node}},")"); - - if ($#{$self->{SIDS}->{$sid}->{node}} == -1) - { - $self->debug(2,"Node: _handle_close: rootTag($self->{SIDS}->{$sid}->{rootTag}) tag($tag)"); - if ($self->{SIDS}->{$sid}->{rootTag} ne $tag) - { - $self->{SIDS}->{$sid}->{streamerror} = "Root tag mis-match: <$self->{SIDS}->{$sid}->{rootTag}> ... </$tag>\n"; - } - return; - } - - my $CLOSED = pop @{$self->{SIDS}->{$sid}->{node}}; - - $self->debug(2,"Node: _handle_close: check2(",$#{$self->{SIDS}->{$sid}->{node}},")"); - - if($#{$self->{SIDS}->{$sid}->{node}} == -1) - { - push @{$self->{SIDS}->{$sid}->{node}}, $CLOSED; - - if (ref($self) ne "XML::Stream::Parser") - { - my $stream_prefix = $self->StreamPrefix($sid); - - if(defined($self->{SIDS}->{$sid}->{node}->[0]) && - ($self->{SIDS}->{$sid}->{node}->[0]->get_tag() =~ /^${stream_prefix}\:/)) - { - my $node = $self->{SIDS}->{$sid}->{node}->[0]; - $self->{SIDS}->{$sid}->{node} = []; - $self->ProcessStreamPacket($sid,$node); - } - else - { - my $node = $self->{SIDS}->{$sid}->{node}->[0]; - $self->{SIDS}->{$sid}->{node} = []; - - my @special = - &XML::Stream::XPath( - $node, - '[@xmlns="'.&XML::Stream::ConstXMLNS("xmpp-sasl").'" or @xmlns="'.&XML::Stream::ConstXMLNS("xmpp-tls").'"]' - ); - if ($#special > -1) - { - my $xmlns = $node->get_attrib("xmlns"); - - $self->ProcessSASLPacket($sid,$node) - if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-sasl")); - $self->ProcessTLSPacket($sid,$node) - if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-tls")); - } - else - { - &{$self->{CB}->{node}}($sid,$node); - } - } - } - } -} - - -############################################################################## -# -# SetXMLData - takes a host of arguments and sets a portion of the specified -# XML::Parser::Node object with that data. The function works -# in two modes "single" or "multiple". "single" denotes that -# the function should locate the current tag that matches this -# data and overwrite it's contents with data passed in. -# "multiple" denotes that a new tag should be created even if -# others exist. -# -# type - single or multiple -# XMLTree - pointer to XML::Stream Node object -# tag - name of tag to create/modify (if blank assumes -# working with top level tag) -# data - CDATA to set for tag -# attribs - attributes to ADD to tag -# -############################################################################## -sub SetXMLData -{ - my ($type,$XMLTree,$tag,$data,$attribs) = @_; - - if ($tag ne "") - { - if ($type eq "single") - { - foreach my $child ($XMLTree->children()) - { - if ($$XMLTree[1]->[$child] eq $tag) - { - $XMLTree->remove_child($child); - - my $newChild = $XMLTree->add_child($tag); - $newChild->put_attrib(%{$attribs}); - $newChild->add_cdata($data) if ($data ne ""); - return; - } - } - } - my $newChild = $XMLTree->add_child($tag); - $newChild->put_attrib(%{$attribs}); - $newChild->add_cdata($data) if ($data ne ""); - } - else - { - $XMLTree->put_attrib(%{$attribs}); - $XMLTree->add_cdata($data) if ($data ne ""); - } -} - - -############################################################################## -# -# GetXMLData - takes a host of arguments and returns various data structures -# that match them. -# -# type - "existence" - returns 1 or 0 if the tag exists in the -# top level. -# "value" - returns either the CDATA of the tag, or the -# value of the attribute depending on which is -# sought. This ignores any mark ups to the data -# and just returns the raw CDATA. -# "value array" - returns an array of strings representing -# all of the CDATA in the specified tag. -# This ignores any mark ups to the data -# and just returns the raw CDATA. -# "tree" - returns an XML::Parser::Node object with the -# specified tag as the root tag. -# "tree array" - returns an array of XML::Parser::Node -# objects each with the specified tag as -# the root tag. -# "child array" - returns a list of all children nodes -# not including CDATA nodes. -# "attribs" - returns a hash with the attributes, and -# their values, for the things that match -# the parameters -# "count" - returns the number of things that match -# the arguments -# "tag" - returns the root tag of this tree -# XMLTree - pointer to XML::Parser::Node object -# tag - tag to pull data from. If blank then the top level -# tag is accessed. -# attrib - attribute value to retrieve. Ignored for types -# "value array", "tree", "tree array". If paired -# with value can be used to filter tags based on -# attributes and values. -# value - only valid if an attribute is supplied. Used to -# filter for tags that only contain this attribute. -# Useful to search through multiple tags that all -# reference different name spaces. -# -############################################################################## -sub GetXMLData -{ - my ($type,$XMLTree,$tag,$attrib,$value) = @_; - - $tag = "" if !defined($tag); - $attrib = "" if !defined($attrib); - $value = "" if !defined($value); - - my $skipthis = 0; - - #------------------------------------------------------------------------- - # Check if a child tag in the root tag is being requested. - #------------------------------------------------------------------------- - if ($tag ne "") - { - my $count = 0; - my @array; - foreach my $child ($XMLTree->children()) - { - if (($child->get_tag() eq $tag) || ($tag eq "*")) - { - #------------------------------------------------------------- - # Filter out tags that do not contain the attribute and value. - #------------------------------------------------------------- - next if (($value ne "") && ($attrib ne "") && $child->get_attrib($attrib) && ($XMLTree->get_attrib($attrib) ne $value)); - next if (($attrib ne "") && !$child->get_attrib($attrib)); - - #------------------------------------------------------------- - # Check for existence - #------------------------------------------------------------- - if ($type eq "existence") - { - return 1; - } - #------------------------------------------------------------- - # Return the raw CDATA value without mark ups, or the value of - # the requested attribute. - #------------------------------------------------------------- - if ($type eq "value") - { - if ($attrib eq "") - { - my $str = $child->get_cdata(); - return $str; - } - return $XMLTree->get_attrib($attrib) - if defined($XMLTree->get_attrib($attrib)); - } - #------------------------------------------------------------- - # Return an array of values that represent the raw CDATA without - # mark up tags for the requested tags. - #------------------------------------------------------------- - if ($type eq "value array") - { - if ($attrib eq "") - { - my $str = $child->get_cdata(); - push(@array,$str); - } - else - { - push(@array, $XMLTree->get_attrib($attrib)) - if defined($XMLTree->get_attrib($attrib)); - } - } - #------------------------------------------------------------- - # Return a pointer to a new XML::Parser::Tree object that has - # the requested tag as the root tag. - #------------------------------------------------------------- - if ($type eq "tree") - { - return $child; - } - #------------------------------------------------------------- - # Return an array of pointers to XML::Parser::Tree objects - # that have the requested tag as the root tags. - #------------------------------------------------------------- - if ($type eq "tree array") - { - push(@array,$child); - } - #------------------------------------------------------------- - # Return an array of pointers to XML::Parser::Tree objects - # that have the requested tag as the root tags. - #------------------------------------------------------------- - if ($type eq "child array") - { - push(@array,$child) if ($child->get_tag() ne "__xmlstream__:node:cdata"); - } - #------------------------------------------------------------- - # Return a count of the number of tags that match - #------------------------------------------------------------- - if ($type eq "count") - { - $count++; - } - #------------------------------------------------------------- - # Return the attribute hash that matches this tag - #------------------------------------------------------------- - if ($type eq "attribs") - { - return $XMLTree->attrib(); - } - } - } - #--------------------------------------------------------------------- - # If we are returning arrays then return array. - #--------------------------------------------------------------------- - if (($type eq "tree array") || ($type eq "value array") || - ($type eq "child array")) - { - return @array; - } - - #--------------------------------------------------------------------- - # If we are returning then count, then do so - #--------------------------------------------------------------------- - if ($type eq "count") - { - return $count; - } - } - else - { - #--------------------------------------------------------------------- - # This is the root tag, so handle things a level up. - #--------------------------------------------------------------------- - - #--------------------------------------------------------------------- - # Return the raw CDATA value without mark ups, or the value of the - # requested attribute. - #--------------------------------------------------------------------- - if ($type eq "value") - { - if ($attrib eq "") - { - my $str = $XMLTree->get_cdata(); - return $str; - } - return $XMLTree->get_attrib($attrib) - if $XMLTree->get_attrib($attrib); - } - #--------------------------------------------------------------------- - # Return a pointer to a new XML::Parser::Tree object that has the - # requested tag as the root tag. - #--------------------------------------------------------------------- - if ($type eq "tree") - { - return $XMLTree; - } - - #--------------------------------------------------------------------- - # Return the 1 if the specified attribute exists in the root tag. - #--------------------------------------------------------------------- - if ($type eq "existence") - { - if ($attrib ne "") - { - return ($XMLTree->get_attrib($attrib) eq $value) if ($value ne ""); - return defined($XMLTree->get_attrib($attrib)); - } - return 0; - } - - #--------------------------------------------------------------------- - # Return the attribute hash that matches this tag - #--------------------------------------------------------------------- - if ($type eq "attribs") - { - return $XMLTree->attrib(); - } - #--------------------------------------------------------------------- - # Return the tag of this node - #--------------------------------------------------------------------- - if ($type eq "tag") - { - return $XMLTree->get_tag(); - } - } - #------------------------------------------------------------------------- - # Return 0 if this was a request for existence, or "" if a request for - # a "value", or [] for "tree", "value array", and "tree array". - #------------------------------------------------------------------------- - return 0 if ($type eq "existence"); - return "" if ($type eq "value"); - return []; -} - - -############################################################################## -# -# BuildXML - takes an XML::Parser::Tree object and builds the XML string -# that it represents. -# -############################################################################## -sub BuildXML -{ - my ($node,$rawXML) = @_; - - my $str = "<".$node->get_tag(); - - my %attrib = $node->attrib(); - - foreach my $att (sort {$a cmp $b} keys(%attrib)) - { - $str .= " ".$att."='".&XML::Stream::EscapeXML($attrib{$att})."'"; - } - - my @children = $node->children(); - if (($#children > -1) || - (defined($rawXML) && ($rawXML ne "")) || - (defined($node->get_raw_xml()) && ($node->get_raw_xml() ne "")) - ) - { - $str .= ">"; - foreach my $child (@children) - { - if ($child->get_tag() eq "__xmlstream__:node:cdata") - { - $str .= &XML::Stream::EscapeXML(join("",$child->children())); - } - else - { - $str .= &XML::Stream::Node::BuildXML($child); - } - } - $str .= $node->get_raw_xml() - if (defined($node->get_raw_xml()) && - ($node->get_raw_xml() ne "") - ); - $str .= $rawXML if (defined($rawXML) && ($rawXML ne "")); - $str .= "</".$node->get_tag().">"; - } - else - { - $str .= "/>"; - } - - return $str; -} - - -############################################################################## -# -# XML2Config - takes an XML data tree and turns it into a hash of hashes. -# This only works for certain kinds of XML trees like this: -# -# <foo> -# <bar>1</bar> -# <x> -# <y>foo</y> -# </x> -# <z>5</z> -# </foo> -# -# The resulting hash would be: -# -# $hash{bar} = 1; -# $hash{x}->{y} = "foo"; -# $hash{z} = 5; -# -# Good for config files. -# -############################################################################## -sub XML2Config -{ - my ($XMLTree) = @_; - - my %hash; - foreach my $tree (&XML::Stream::GetXMLData("tree array",$XMLTree,"*")) - { - if ($tree->get_tag() eq "__xmlstream__:node:cdata") - { - my $str = join("",$tree->children()); - return $str unless ($str =~ /^\s*$/); - } - else - { - if (&XML::Stream::GetXMLData("count",$XMLTree,$tree->get_tag()) > 1) - { - push(@{$hash{$tree->get_tag()}},&XML::Stream::XML2Config($tree)); - } - else - { - $hash{$tree->get_tag()} = &XML::Stream::XML2Config($tree); - } - } - } - return \%hash; -} - - -1; diff --git a/lib/XML/Stream/Parser.pm b/lib/XML/Stream/Parser.pm deleted file mode 100644 index 9ca7832..0000000 --- a/lib/XML/Stream/Parser.pm +++ /dev/null @@ -1,567 +0,0 @@ -############################################################################## -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Library General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Library General Public License for more details. -# -# You should have received a copy of the GNU Library General Public -# License along with this library; if not, write to the -# Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. -# -# Jabber -# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ -# -############################################################################## - -package XML::Stream::Parser; - -=head1 NAME - - XML::Stream::Parser - SAX XML Parser for XML Streams - -=head1 SYNOPSIS - - Light weight XML parser that builds XML::Parser::Tree objects from the - incoming stream and passes them to a function to tell whoever is using - it that there are new packets. - -=head1 DESCRIPTION - - This module provides a very light weight parser - -=head1 METHODS - -=head1 EXAMPLES - -=head1 AUTHOR - -By Ryan Eatmon in January of 2001 for http://jabber.org/ - -=head1 COPYRIGHT - -This module is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -use strict; -use vars qw( $VERSION ); - -$VERSION = "1.22"; - -sub new -{ - my $self = { }; - - bless($self); - - my %args; - while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } - - $self->{PARSING} = 0; - $self->{DOC} = 0; - $self->{XML} = ""; - $self->{CNAME} = (); - $self->{CURR} = 0; - - $args{nonblocking} = 0 unless exists($args{nonblocking}); - - $self->{NONBLOCKING} = delete($args{nonblocking}); - - $self->{DEBUGTIME} = 0; - $self->{DEBUGTIME} = $args{debugtime} if exists($args{debugtime}); - - $self->{DEBUGLEVEL} = 0; - $self->{DEBUGLEVEL} = $args{debuglevel} if exists($args{debuglevel}); - - $self->{DEBUGFILE} = ""; - - if (exists($args{debugfh}) && ($args{debugfh} ne "")) - { - $self->{DEBUGFILE} = $args{debugfh}; - $self->{DEBUG} = 1; - } - - if ((exists($args{debugfh}) && ($args{debugfh} eq "")) || - (exists($args{debug}) && ($args{debug} ne ""))) - { - $self->{DEBUG} = 1; - if (lc($args{debug}) eq "stdout") - { - $self->{DEBUGFILE} = new FileHandle(">&STDERR"); - $self->{DEBUGFILE}->autoflush(1); - } - else - { - if (-e $args{debug}) - { - if (-w $args{debug}) - { - $self->{DEBUGFILE} = new FileHandle(">$args{debug}"); - $self->{DEBUGFILE}->autoflush(1); - } - else - { - print "WARNING: debug file ($args{debug}) is not writable by you\n"; - print " No debug information being saved.\n"; - $self->{DEBUG} = 0; - } - } - else - { - $self->{DEBUGFILE} = new FileHandle(">$args{debug}"); - if (defined($self->{DEBUGFILE})) - { - $self->{DEBUGFILE}->autoflush(1); - } - else - { - print "WARNING: debug file ($args{debug}) does not exist \n"; - print " and is not writable by you.\n"; - print " No debug information being saved.\n"; - $self->{DEBUG} = 0; - } - } - } - } - - $self->{SID} = exists($args{sid}) ? $args{sid} : "__xmlstream__:sid"; - - $self->{STYLE} = (exists($args{style}) ? lc($args{style}) : "tree"); - $self->{DTD} = (exists($args{dtd}) ? lc($args{dtd}) : 0); - - if ($self->{STYLE} eq "tree") - { - $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); }; - $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); }; - $self->{HANDLER}->{startElement} = sub{ &XML::Stream::Tree::_handle_element(@_); }; - $self->{HANDLER}->{endElement} = sub{ &XML::Stream::Tree::_handle_close(@_); }; - $self->{HANDLER}->{characters} = sub{ &XML::Stream::Tree::_handle_cdata(@_); }; - } - elsif ($self->{STYLE} eq "node") - { - $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); }; - $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); }; - $self->{HANDLER}->{startElement} = sub{ &XML::Stream::Node::_handle_element(@_); }; - $self->{HANDLER}->{endElement} = sub{ &XML::Stream::Node::_handle_close(@_); }; - $self->{HANDLER}->{characters} = sub{ &XML::Stream::Node::_handle_cdata(@_); }; - } - $self->setHandlers(%{$args{handlers}}); - - $self->{XMLONHOLD} = ""; - - return $self; -} - - -########################################################################### -# -# debug - prints the arguments to the debug log if debug is turned on. -# -########################################################################### -sub debug -{ - return if ($_[1] > $_[0]->{DEBUGLEVEL}); - my $self = shift; - my ($limit,@args) = @_; - return if ($self->{DEBUGFILE} eq ""); - my $fh = $self->{DEBUGFILE}; - if ($self->{DEBUGTIME} == 1) - { - my ($sec,$min,$hour) = localtime(time); - print $fh sprintf("[%02d:%02d:%02d] ",$hour,$min,$sec); - } - print $fh "XML::Stream::Parser: $self->{STYLE}: @args\n"; -} - - -sub setSID -{ - my $self = shift; - my $sid = shift; - $self->{SID} = $sid; -} - - -sub getSID -{ - my $self = shift; - return $self->{SID}; -} - - -sub setHandlers -{ - my $self = shift; - my (%handlers) = @_; - - foreach my $handler (keys(%handlers)) - { - $self->{HANDLER}->{$handler} = $handlers{$handler}; - } -} - - -sub parse -{ - my $self = shift; - my $xml = shift; - - return unless defined($xml); - return if ($xml eq ""); - - if ($self->{XMLONHOLD} ne "") - { - $self->{XML} = $self->{XMLONHOLD}; - $self->{XMLONHOLD} = ""; - } - - # XXX change this to not use regex? - while($xml =~ s/<\!--.*?-->//gs) {} - - $self->{XML} .= $xml; - - return if ($self->{PARSING} == 1); - - $self->{PARSING} = 1; - - if(!$self->{DOC} == 1) - { - my $start = index($self->{XML},"<"); - - if ((substr($self->{XML},$start,3) eq "<?x") || - (substr($self->{XML},$start,3) eq "<?X")) - { - my $close = index($self->{XML},"?>"); - if ($close == -1) - { - $self->{PARSING} = 0; - return; - } - $self->{XML} = substr($self->{XML},$close+2,length($self->{XML})-$close-2); - } - - &{$self->{HANDLER}->{startDocument}}($self); - $self->{DOC} = 1; - } - - while(1) - { - if (length($self->{XML}) == 0) - { - $self->{PARSING} = 0; - return $self->returnData(0); - } - my $eclose = -1; - $eclose = index($self->{XML},"</".$self->{CNAME}->[$self->{CURR}].">") - if ($#{$self->{CNAME}} > -1); - - if ($eclose == 0) - { - $self->{XML} = substr($self->{XML},length($self->{CNAME}->[$self->{CURR}])+3,length($self->{XML})-length($self->{CNAME}->[$self->{CURR}])-3); - - $self->{PARSING} = 0 if ($self->{NONBLOCKING} == 1); - &{$self->{HANDLER}->{endElement}}($self,$self->{CNAME}->[$self->{CURR}]); - $self->{PARSING} = 1 if ($self->{NONBLOCKING} == 1); - - $self->{CURR}--; - if ($self->{CURR} == 0) - { - $self->{DOC} = 0; - $self->{PARSING} = 0; - &{$self->{HANDLER}->{endDocument}}($self); - return $self->returnData(0); - } - next; - } - - my $estart = index($self->{XML},"<"); - my $cdatastart = index($self->{XML},"<![CDATA["); - if (($estart == 0) && ($cdatastart != 0)) - { - my $close = index($self->{XML},">"); - if ($close == -1) - { - $self->{PARSING} = 0; - return $self->returnData(0); - } - my $empty = (substr($self->{XML},$close-1,1) eq "/"); - my $starttag = substr($self->{XML},1,$close-($empty ? 2 : 1)); - my $nextspace = index($starttag," "); - my $attribs; - my $name; - if ($nextspace != -1) - { - $name = substr($starttag,0,$nextspace); - $attribs = substr($starttag,$nextspace+1,length($starttag)-$nextspace-1); - } - else - { - $name = $starttag; - } - - my %attribs = $self->attribution($attribs); - if (($self->{DTD} == 1) && (exists($attribs{xmlns}))) - { - } - - &{$self->{HANDLER}->{startElement}}($self,$name,%attribs); - - if($empty == 1) - { - &{$self->{HANDLER}->{endElement}}($self,$name); - } - else - { - $self->{CURR}++; - $self->{CNAME}->[$self->{CURR}] = $name; - } - - $self->{XML} = substr($self->{XML},$close+1,length($self->{XML})-$close-1); - next; - } - - if ($cdatastart == 0) - { - my $cdataclose = index($self->{XML},"]]>"); - if ($cdataclose == -1) - { - $self->{PARSING} = 0; - return $self->returnData(0); - } - - &{$self->{HANDLER}->{characters}}($self,substr($self->{XML},9,$cdataclose-9)); - - $self->{XML} = substr($self->{XML},$cdataclose+3,length($self->{XML})-$cdataclose-3); - next; - } - - if ($estart == -1) - { - $self->{XMLONHOLD} = $self->{XML}; - $self->{XML} = ""; - } - elsif (($cdatastart == -1) || ($cdatastart > $estart)) - { - &{$self->{HANDLER}->{characters}}($self,$self->entityCheck(substr($self->{XML},0,$estart))); - $self->{XML} = substr($self->{XML},$estart,length($self->{XML})-$estart); - } - } -} - - -sub attribution -{ - my $self = shift; - my $str = shift; - - $str = "" unless defined($str); - - my %attribs; - - while(1) - { - my $eq = index($str,"="); - if((length($str) == 0) || ($eq == -1)) - { - return %attribs; - } - - my $ids; - my $id; - my $id1 = index($str,"\'"); - my $id2 = index($str,"\""); - if((($id1 < $id2) && ($id1 != -1)) || ($id2 == -1)) - { - $ids = $id1; - $id = "\'"; - } - if((($id2 < $id1) && ($id1 == -1)) || ($id2 != -1)) - { - $ids = $id2; - $id = "\""; - } - - my $nextid = index($str,$id,$ids+1); - my $val = substr($str,$ids+1,$nextid-$ids-1); - my $key = substr($str,0,$eq); - - while($key =~ s/\s//) {} - - $attribs{$key} = $self->entityCheck($val); - $str = substr($str,$nextid+1,length($str)-$nextid-1); - } - - return %attribs; -} - - -sub entityCheck -{ - my $self = shift; - my $str = shift; - - while($str =~ s/\<\;/\</) {} - while($str =~ s/\>\;/\>/) {} - while($str =~ s/\"\;/\"/) {} - while($str =~ s/\&apos\;/\'/) {} - while($str =~ s/\&\;/\&/) {} - - return $str; -} - - -sub parsefile -{ - my $self = shift; - my $fileName = shift; - - open(FILE,"<",$fileName); - my $file; - while(<FILE>) { $file .= $_; } - $self->parse($file); - close(FILE); - - return $self->returnData(); -} - - -sub returnData -{ - my $self = shift; - my $clearData = shift; - $clearData = 1 unless defined($clearData); - - my $sid = $self->{SID}; - - if ($self->{STYLE} eq "tree") - { - return unless exists($self->{SIDS}->{$sid}->{tree}); - my @tree = @{$self->{SIDS}->{$sid}->{tree}}; - delete($self->{SIDS}->{$sid}->{tree}) if ($clearData == 1); - return ( \@tree ); - } - if ($self->{STYLE} eq "node") - { - return unless exists($self->{SIDS}->{$sid}->{node}); - my $node = $self->{SIDS}->{$sid}->{node}->[0]; - delete($self->{SIDS}->{$sid}->{node}) if ($clearData == 1); - return $node; - } -} - - -sub startDocument -{ - my $self = shift; -} - - -sub endDocument -{ - my $self = shift; -} - - -sub startElement -{ - my $self = shift; - my ($sax, $tag, %att) = @_; - - return unless ($self->{DOC} == 1); - - if ($self->{STYLE} eq "debug") - { - print "$self->{DEBUGHEADER} \\\\ (",join(" ",%att),")\n"; - $self->{DEBUGHEADER} .= $tag." "; - } - else - { - my @NEW; - if($#{$self->{TREE}} < 0) - { - push @{$self->{TREE}}, $tag; - } - else - { - push @{ $self->{TREE}[ $#{$self->{TREE}}]}, $tag; - } - push @NEW, \%att; - push @{$self->{TREE}}, \@NEW; - } -} - - -sub characters -{ - my $self = shift; - my ($sax, $cdata) = @_; - - return unless ($self->{DOC} == 1); - - if ($self->{STYLE} eq "debug") - { - my $str = $cdata; - $str =~ s/\n/\#10\;/g; - print "$self->{DEBUGHEADER} || $str\n"; - } - else - { - return if ($#{$self->{TREE}} == -1); - - my $pos = $#{$self->{TREE}}; - - if ($pos > 0 && $self->{TREE}[$pos - 1] eq "0") - { - $self->{TREE}[$pos - 1] .= $cdata; - } - else - { - push @{$self->{TREE}[$#{$self->{TREE}}]}, 0; - push @{$self->{TREE}[$#{$self->{TREE}}]}, $cdata; - } - } -} - - -sub endElement -{ - my $self = shift; - my ($sax, $tag) = @_; - - return unless ($self->{DOC} == 1); - - if ($self->{STYLE} eq "debug") - { - $self->{DEBUGHEADER} =~ s/\S+\ $//; - print "$self->{DEBUGHEADER} //\n"; - } - else - { - my $CLOSED = pop @{$self->{TREE}}; - - if($#{$self->{TREE}} < 1) - { - push @{$self->{TREE}}, $CLOSED; - - if($self->{TREE}->[0] eq "stream:error") - { - $self->{STREAMERROR} = $self->{TREE}[1]->[2]; - } - } - else - { - push @{$self->{TREE}[$#{$self->{TREE}}]}, $CLOSED; - } - } -} - - -1; diff --git a/lib/XML/Stream/Parser/DTD.pm b/lib/XML/Stream/Parser/DTD.pm deleted file mode 100644 index 25dc888..0000000 --- a/lib/XML/Stream/Parser/DTD.pm +++ /dev/null @@ -1,769 +0,0 @@ -############################################################################## -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Library General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Library General Public License for more details. -# -# You should have received a copy of the GNU Library General Public -# License along with this library; if not, write to the -# Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. -# -# Jabber -# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ -# -############################################################################## - -package XML::Stream::Parser::DTD; - -=head1 NAME - - XML::Stream::Parser::DTD - XML DTD Parser and Verifier - -=head1 SYNOPSIS - - This is a work in progress. I had need for a DTD parser and verifier - and so am working on it here. If you are reading this then you are - snooping. =) - -=head1 DESCRIPTION - - This module provides the initial code for a DTD parser and verifier. - -=head1 METHODS - -=head1 EXAMPLES - -=head1 AUTHOR - -By Ryan Eatmon in February of 2001 for http://jabber.org/ - -=head1 COPYRIGHT - -This module is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -use strict; -use vars qw( $VERSION ); - -$VERSION = "1.22"; - -sub new -{ - my $self = { }; - - bless($self); - - my %args; - while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } - - $self->{URI} = $args{uri}; - - $self->{PARSING} = 0; - $self->{DOC} = 0; - $self->{XML} = ""; - $self->{CNAME} = (); - $self->{CURR} = 0; - - $self->{ENTITY}->{"<"} = "<"; - $self->{ENTITY}->{">"} = ">"; - $self->{ENTITY}->{"""} = "\""; - $self->{ENTITY}->{"'"} = "'"; - $self->{ENTITY}->{"&"} = "&"; - - $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); }; - $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); }; - $self->{HANDLER}->{startElement} = sub{ $self->startElement(@_); }; - $self->{HANDLER}->{endElement} = sub{ $self->endElement(@_); }; - - $self->{STYLE} = "debug"; - - open(DTD,$args{uri}); - my $dtd = join("",<DTD>); - close(DTD); - - $self->parse($dtd); - - return $self; -} - - -sub parse -{ - my $self = shift; - my $xml = shift; - - while($xml =~ s/<\!--.*?-->//gs) {} - while($xml =~ s/\n//g) {} - - $self->{XML} .= $xml; - - return if ($self->{PARSING} == 1); - - $self->{PARSING} = 1; - - if(!$self->{DOC} == 1) - { - my $start = index($self->{XML},"<"); - - if (substr($self->{XML},$start,3) =~ /^<\?x$/i) - { - my $close = index($self->{XML},"?>"); - if ($close == -1) - { - $self->{PARSING} = 0; - return; - } - $self->{XML} = substr($self->{XML},$close+2,length($self->{XML})-$close-2); - } - - &{$self->{HANDLER}->{startDocument}}($self); - $self->{DOC} = 1; - } - - while(1) - { - - if (length($self->{XML}) == 0) - { - $self->{PARSING} = 0; - return; - } - - my $estart = index($self->{XML},"<"); - if ($estart == -1) - { - $self->{PARSING} = 0; - return; - } - - my $close = index($self->{XML},">"); - my $dtddata = substr($self->{XML},$estart+1,$close-1); - my $nextspace = index($dtddata," "); - my $attribs; - - my $type = substr($dtddata,0,$nextspace); - $dtddata = substr($dtddata,$nextspace+1,length($dtddata)-$nextspace-1); - $nextspace = index($dtddata," "); - - if ($type eq "!ENTITY") - { - $self->entity($type,$dtddata); - } - else - { - my $tag = substr($dtddata,0,$nextspace); - $dtddata = substr($dtddata,$nextspace+1,length($dtddata)-$nextspace-1); - $nextspace = index($dtddata," "); - - $self->element($type,$tag,$dtddata) if ($type eq "!ELEMENT"); - $self->attlist($type,$tag,$dtddata) if ($type eq "!ATTLIST"); - } - - $self->{XML} = substr($self->{XML},$close+1,length($self->{XML})-$close-1); - next; - } -} - - -sub startDocument -{ - my $self = shift; -} - - -sub endDocument -{ - my $self = shift; -} - - -sub entity -{ - my $self = shift; - my ($type, $data) = @_; - - foreach my $entity (keys(%{$self->{ENTITY}})) - { - $data =~ s/$entity/$self->{ENTITY}->{$entity}/g; - } - - my ($symbol,$tag,undef,$string) = ($data =~ /^\s*(\S+)\s+(\S+)\s+(\"|\')([^\3]*)\3\s*$/); - $self->{ENTITY}->{"${symbol}${tag}\;"} = $string; -} - -sub element -{ - my $self = shift; - my ($type, $tag, $data) = @_; - - foreach my $entity (keys(%{$self->{ENTITY}})) - { - $data =~ s/$entity/$self->{ENTITY}->{$entity}/g; - } - - $self->{COUNTER}->{$tag} = 0 unless exists($self->{COUNTER}->{$tag}); - - $self->parsegrouping($tag,\$self->{ELEMENT}->{$tag},$data); - $self->flattendata(\$self->{ELEMENT}->{$tag}); - -} - - -sub flattendata -{ - my $self = shift; - my $dstr = shift; - - if ($$dstr->{type} eq "list") - { - foreach my $index (0..$#{$$dstr->{list}}) - { - $self->flattendata(\$$dstr->{list}->[$index]); - } - - if (!exists($$dstr->{repeat}) && ($#{$$dstr->{list}} == 0)) - { - $$dstr = $$dstr->{list}->[0]; - } - } -} - -sub parsegrouping -{ - my $self = shift; - my ($tag,$dstr,$data) = @_; - - $data =~ s/^\s*//; - $data =~ s/\s*$//; - - if ($data =~ /[\*\+\?]$/) - { - ($$dstr->{repeat}) = ($data =~ /(.)$/); - $data =~ s/.$//; - } - - if ($data =~ /^\(.*\)$/) - { - my ($seperator) = ($data =~ /^\(\s*\S+\s*(\,|\|)/); - $$dstr->{ordered} = "yes" if ($seperator eq ","); - $$dstr->{ordered} = "no" if ($seperator eq "|"); - - my $count = 0; - $$dstr->{type} = "list"; - foreach my $grouping ($self->groupinglist($data,$seperator)) - { - $self->parsegrouping($tag,\$$dstr->{list}->[$count],$grouping); - $count++; - } - } - else - { - $$dstr->{type} = "element"; - $$dstr->{element} = $data; - $self->{COUNTER}->{$data} = 0 unless exists($self->{COUNTER}->{$data}); - $self->{COUNTER}->{$data}++; - $self->{CHILDREN}->{$tag}->{$data} = 1; - } -} - - -sub attlist -{ - my $self = shift; - my ($type, $tag, $data) = @_; - - foreach my $entity (keys(%{$self->{ENTITY}})) - { - $data =~ s/$entity/$self->{ENTITY}->{$entity}/g; - } - - while($data ne "") - { - my ($att) = ($data =~ /^\s*(\S+)/); - $data =~ s/^\s*\S+\s*//; - - my $value; - if ($data =~ /^\(/) - { - $value = $self->getgrouping($data); - $data = substr($data,length($value)+1,length($data)); - $data =~ s/^\s*//; - $self->{ATTLIST}->{$tag}->{$att}->{type} = "list"; - foreach my $val (split(/\s*\|\s*/,substr($value,1,length($value)-2))) { -$self->{ATTLIST}->{$tag}->{$att}->{value}->{$val} = 1; - } - } - else - { - ($value) = ($data =~ /^(\S+)/); - $data =~ s/^\S+\s*//; - $self->{ATTLIST}->{$tag}->{$att}->{type} = $value; - } - - my $default; - if ($data =~ /^\"|^\'/) - { - my($sq,$val) = ($data =~ /^(\"|\')([^\"\']*)\1/); - $default = $val; - $data =~ s/^$sq$val$sq\s*//; - } - else - { - ($default) = ($data =~ /^(\S+)/); - $data =~ s/^\S+\s*//; - } - - $self->{ATTLIST}->{$tag}->{$att}->{default} = $default; - } -} - - - -sub getgrouping -{ - my $self = shift; - my ($data) = @_; - - my $count = 0; - my $parens = 0; - foreach my $char (split("",$data)) - { - $parens++ if ($char eq "("); - $parens-- if ($char eq ")"); - $count++; - last if ($parens == 0); - } - return substr($data,0,$count); -} - - -sub groupinglist -{ - my $self = shift; - my ($grouping,$seperator) = @_; - - my @list; - my $item = ""; - my $parens = 0; - my $word = ""; - $grouping = substr($grouping,1,length($grouping)-2) if ($grouping =~ /^\(/); - foreach my $char (split("",$grouping)) - { - $parens++ if ($char eq "("); - $parens-- if ($char eq ")"); - if (($parens == 0) && ($char eq $seperator)) - { - push(@list,$word); - $word = ""; - } - else - { - $word .= $char; - } - } - push(@list,$word) unless ($word eq ""); - return @list; -} - - -sub root -{ - my $self = shift; - my $tag = shift; - my @root; - foreach my $tag (keys(%{$self->{COUNTER}})) - { - push(@root,$tag) if ($self->{COUNTER}->{$tag} == 0); - } - - print "ERROR: Too many root tags... Check the DTD...\n" - if ($#root > 0); - return $root[0]; -} - - -sub children -{ - my $self = shift; - my ($tag,$tree) = @_; - - return unless exists ($self->{CHILDREN}->{$tag}); - return if (exists($self->{CHILDREN}->{$tag}->{EMPTY})); - if (defined($tree)) - { - my @current; - foreach my $current (&XML::Stream::GetXMLData("tree array",$tree,"*","","")) - { - push(@current,$$current[0]); - } - return $self->allowedchildren($self->{ELEMENT}->{$tag},\@current); - } - return $self->allowedchildren($self->{ELEMENT}->{$tag}); -} - - -sub allowedchildren -{ - my $self = shift; - my ($dstr,$current) = @_; - - my @allowed; - - if ($dstr->{type} eq "element") - { - my $test = (defined($current) && $#{@{$current}} > -1) ? $$current[0] : ""; - shift(@{$current}) if ($dstr->{element} eq $test); - if ($self->repeatcheck($dstr,$test) == 1) - { - return $dstr->{element}; - } - } - else - { - foreach my $index (0..$#{$dstr->{list}}) - { - push(@allowed,$self->allowedchildren($dstr->{list}->[$index],$current)); - } - } - - return @allowed; -} - - -sub repeatcheck -{ - my $self = shift; - my ($dstr,$tag) = @_; - - $dstr = $self->{ELEMENT}->{$dstr} if exists($self->{ELEMENT}->{$dstr}); - -# print "repeatcheck: tag($tag)\n"; -# print "repeatcheck: repeat($dstr->{repeat})\n" -# if exists($dstr->{repeat}); - - my $return = 0; - $return = ((!defined($tag) || - ($tag eq $dstr->{element})) ? - 0 : - 1) - if (!exists($dstr->{repeat}) || - ($dstr->{repeat} eq "?")); - $return = ((defined($tag) || - (exists($dstr->{ordered}) && - ($dstr->{ordered} eq "yes"))) ? - 1 : - 0) - if (exists($dstr->{repeat}) && - (($dstr->{repeat} eq "+") || - ($dstr->{repeat} eq "*"))); - -# print "repeatcheck: return($return)\n"; - return $return; -} - - -sub required -{ - my $self = shift; - my ($dstr,$tag,$count) = @_; - - $dstr = $self->{ELEMENT}->{$dstr} if exists($self->{ELEMENT}->{$dstr}); - - if ($dstr->{type} eq "element") - { - return 0 if ($dstr->{element} ne $tag); - return 1 if !exists($dstr->{repeat}); - return 1 if (($dstr->{repeat} eq "+") && ($count == 1)) ; - } - else - { - return 0 if (($dstr->{repeat} eq "*") || ($dstr->{repeat} eq "?")); - my $test = 0; - foreach my $index (0..$#{$dstr->{list}}) - { - $test = $test | $self->required($dstr->{list}->[$index],$tag,$count); - } - return $test; - } - return 0; -} - - -sub addchild -{ - my $self = shift; - my ($tag,$child,$tree) = @_; - -# print "addchild: tag($tag) child($child)\n"; - - my @current; - if (defined($tree)) - { -# &Net::Jabber::printData("\$tree",$tree); - - @current = &XML::Stream::GetXMLData("index array",$tree,"*","",""); - -# &Net::Jabber::printData("\$current",\@current); - } - - my @newBranch = $self->addchildrecurse($self->{ELEMENT}->{$tag},$child,\@current); - - return $tree unless ("@newBranch" ne ""); - -# &Net::Jabber::printData("\$newBranch",\@newBranch); - - my $location = shift(@newBranch); - - if ($location eq "end") - { - splice(@{$$tree[1]},@{$$tree[1]},0,@newBranch); - } - else - { - splice(@{$$tree[1]},$location,0,@newBranch); - } - return $tree; -} - - -sub addcdata -{ - my $self = shift; - my ($tag,$child,$tree) = @_; - -# print "addchild: tag($tag) child($child)\n"; - - my @current; - if (defined($tree)) - { -# &Net::Jabber::printData("\$tree",$tree); - - @current = &XML::Stream::GetXMLData("index array",$tree,"*","",""); - -# &Net::Jabber::printData("\$current",\@current); - } - - my @newBranch = $self->addchildrecurse($self->{ELEMENT}->{$tag},$child,\@current); - - return $tree unless ("@newBranch" ne ""); - -# &Net::Jabber::printData("\$newBranch",\@newBranch); - - my $location = shift(@newBranch); - - if ($location eq "end") - { - splice(@{$$tree[1]},@{$$tree[1]},0,@newBranch); - } - else - { - splice(@{$$tree[1]},$location,0,@newBranch); - } - return $tree; -} - - -sub addchildrecurse -{ - my $self = shift; - my ($dstr,$child,$current) = @_; - -# print "addchildrecurse: child($child) type($dstr->{type})\n"; - - if ($dstr->{type} eq "element") - { -# print "addchildrecurse: tag($dstr->{element})\n"; - my $count = 0; - while(($#{@{$current}} > -1) && ($dstr->{element} eq $$current[0])) - { - shift(@{$current}); - shift(@{$current}); - $count++; - } - if (($dstr->{element} eq $child) && - ($self->repeatcheck($dstr,(($count > 0) ? $child : "")) == 1)) - { - my @return = ( "end" , $self->newbranch($child)); - @return = ($$current[1], $self->newbranch($child)) - if ($#{@{$current}} > -1); -# print "addchildrecurse: Found the spot! (",join(",",@return),")\n"; - - return @return; - } - } - else - { - foreach my $index (0..$#{$dstr->{list}}) - { - my @newBranch = $self->addchildrecurse($dstr->{list}->[$index],$child,$current); - return @newBranch if ("@newBranch" ne ""); - } - } -# print "Let's blow....\n"; - return; -} - - -sub deletechild -{ - my $self = shift; - my ($tag,$parent,$parenttree,$tree) = @_; - - return $tree unless exists($self->{ELEMENT}->{$tag}); - return $tree if $self->required($parent,$tag,&XML::Stream::GetXMLData("count",$parenttree,$tag)); - - return []; -} - - - -sub newbranch -{ - my $self = shift; - my $tag = shift; - - $tag = $self->root() unless defined($tag); - - my @tree = (); - - return ("0","") if ($tag eq "#PCDATA"); - - push(@tree,$tag); - push(@tree,[ {} ]); - - foreach my $att ($self->attribs($tag)) - { - $tree[1]->[0]->{$att} = "" - if (($self->{ATTLIST}->{$tag}->{$att}->{default} eq "#REQUIRED") && - ($self->{ATTLIST}->{$tag}->{$att}->{type} eq "CDATA")); - } - - push(@{$tree[1]},$self->recursebranch($self->{ELEMENT}->{$tag})); - return @tree; -} - - -sub recursebranch -{ - my $self = shift; - my $dstr = shift; - - my @tree; - if (($dstr->{type} eq "element") && - ($dstr->{element} ne "EMPTY")) - { - @tree = $self->newbranch($dstr->{element}) - if (!exists($dstr->{repeat}) || - ($dstr->{repeat} eq "+")); - } - else - { - foreach my $index (0..$#{$dstr->{list}}) - { - push(@tree,$self->recursebranch($dstr->{list}->[$index])) -if (!exists($dstr->{repeat}) || - ($dstr->{repeat} eq "+")); - } - } - return @tree; -} - - -sub attribs -{ - my $self = shift; - my ($tag,$tree) = @_; - - return unless exists ($self->{ATTLIST}->{$tag}); - - if (defined($tree)) - { - my %current = &XML::Stream::GetXMLData("attribs",$tree,"","",""); - return $self->allowedattribs($tag,\%current); - } - return $self->allowedattribs($tag); -} - - -sub allowedattribs -{ - my $self = shift; - my ($tag,$current) = @_; - - my %allowed; - foreach my $att (keys(%{$self->{ATTLIST}->{$tag}})) - { - $allowed{$att} = 1 unless (defined($current) && - exists($current->{$att})); - } - return sort {$a cmp $b} keys(%allowed); -} - - -sub attribvalue -{ - my $self = shift; - my $tag = shift; - my $att = shift; - - return $self->{ATTLIST}->{$tag}->{$att}->{type} - if ($self->{ATTLIST}->{$tag}->{$att}->{type} ne "list"); - return sort {$a cmp $b} keys(%{$self->{ATTLIST}->{$tag}->{$att}->{value}}); -} - - -sub addattrib -{ - my $self = shift; - my ($tag,$att,$tree) = @_; - - return $tree unless exists($self->{ATTLIST}->{$tag}); - return $tree unless exists($self->{ATTLIST}->{$tag}->{$att}); - - my $default = $self->{ATTLIST}->{$tag}->{$att}->{default}; - $default = "" if ($default eq "#REQUIRED"); - $default = "" if ($default eq "#IMPLIED"); - - $$tree[1]->[0]->{$att} = $default; - - return $tree; -} - - -sub attribrequired -{ - my $self = shift; - my ($tag,$att) = @_; - - return 0 unless exists($self->{ATTLIST}->{$tag}); - return 0 unless exists($self->{ATTLIST}->{$tag}->{$att}); - - return 1 if ($self->{ATTLIST}->{$tag}->{$att}->{default} eq "#REQUIRED"); - return 0; -} - - -sub deleteattrib -{ - my $self = shift; - my ($tag,$att,$tree) = @_; - - return $tree unless exists($self->{ATTLIST}->{$tag}); - return $tree unless exists($self->{ATTLIST}->{$tag}->{$att}); - - return if $self->attribrequired($tag,$att); - - delete($$tree[1]->[0]->{$att}); - - return $tree; -} - diff --git a/lib/XML/Stream/Tree.pm b/lib/XML/Stream/Tree.pm deleted file mode 100644 index b52269c..0000000 --- a/lib/XML/Stream/Tree.pm +++ /dev/null @@ -1,682 +0,0 @@ -############################################################################## -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Library General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Library General Public License for more details. -# -# You should have received a copy of the GNU Library General Public -# License along with this library; if not, write to the -# Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. -# -# Jabber -# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ -# -############################################################################## - -package XML::Stream::Tree; - -=head1 NAME - -XML::Stream::Tree - Functions to make building and parsing the tree easier -to work with. - -=head1 SYNOPSIS - - Just a collection of functions that do not need to be in memory if you -choose one of the other methods of data storage. - -=head1 FORMAT - -The result of parsing: - - <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo> - -would be: - Tag Content - ================================================================== - [foo, [{}, - head, [{id => "a"}, - 0, "Hello ", - em, [{}, - 0, "there" - ] - ], - bar, [{}, - 0, "Howdy", - ref, [{}] - ], - 0, "do" - ] - ] - -The above was copied from the XML::Parser man page. Many thanks to -Larry and Clark. - -=head1 AUTHOR - -By Ryan Eatmon in March 2001 for http://jabber.org/ - -=head1 COPYRIGHT - -This module is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -use vars qw( $VERSION $LOADED ); - -$VERSION = "1.22"; -$LOADED = 1; - -############################################################################## -# -# _handle_element - handles the main tag elements sent from the server. -# On an open tag it creates a new XML::Parser::Tree so -# that _handle_cdata and _handle_element can add data -# and tags to it later. -# -############################################################################## -sub _handle_element -{ - my $self; - $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser"); - $self = shift unless (ref($_[0]) eq "XML::Stream::Parser"); - my ($sax, $tag, %att) = @_; - my $sid = $sax->getSID(); - - $self->debug(2,"_handle_element: sid($sid) sax($sax) tag($tag) att(",%att,")"); - - my @NEW; - if($#{$self->{SIDS}->{$sid}->{tree}} < 0) - { - push @{$self->{SIDS}->{$sid}->{tree}}, $tag; - } - else - { - push @{ $self->{SIDS}->{$sid}->{tree}[ $#{$self->{SIDS}->{$sid}->{tree}}]}, $tag; - } - push @NEW, \%att; - push @{$self->{SIDS}->{$sid}->{tree}}, \@NEW; -} - - -############################################################################## -# -# _handle_cdata - handles the CDATA that is encountered. Also, in the -# spirit of XML::Parser::Tree it combines any sequential -# CDATA into one tag. -# -############################################################################## -sub _handle_cdata -{ - my $self; - $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser"); - $self = shift unless (ref($_[0]) eq "XML::Stream::Parser"); - my ($sax, $cdata) = @_; - my $sid = $sax->getSID(); - - $self->debug(2,"_handle_cdata: sid($sid) sax($sax) cdata($cdata)"); - - return if ($#{$self->{SIDS}->{$sid}->{tree}} == -1); - - $self->debug(2,"_handle_cdata: sax($sax) cdata($cdata)"); - - my $pos = $#{$self->{SIDS}->{$sid}->{tree}}; - $self->debug(2,"_handle_cdata: pos($pos)"); - - if ($pos > 0 && $self->{SIDS}->{$sid}->{tree}[$pos - 1] eq "0") - { - $self->debug(2,"_handle_cdata: append cdata"); - $self->{SIDS}->{$sid}->{tree}[$pos - 1] .= $cdata; - } - else - { - $self->debug(2,"_handle_cdata: new cdata"); - push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, 0; - push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, $cdata; - } -} - - -############################################################################## -# -# _handle_close - when we see a close tag we need to pop the last element -# from the list and push it onto the end of the previous -# element. This is how we build our hierarchy. -# -############################################################################## -sub _handle_close -{ - my $self; - $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser"); - $self = shift unless (ref($_[0]) eq "XML::Stream::Parser"); - my ($sax, $tag) = @_; - my $sid = $sax->getSID(); - - $self->debug(2,"_handle_close: sid($sid) sax($sax) tag($tag)"); - - my $CLOSED = pop @{$self->{SIDS}->{$sid}->{tree}}; - - $self->debug(2,"_handle_close: check(",$#{$self->{SIDS}->{$sid}->{tree}},")"); - - if ($#{$self->{SIDS}->{$sid}->{tree}} == -1) - { - if ($self->{SIDS}->{$sid}->{rootTag} ne $tag) - { - $self->{SIDS}->{$sid}->{streamerror} = "Root tag mis-match: <$self->{SIDS}->{$sid}->{rootTag}> ... </$tag>\n"; - } - return; - } - - if($#{$self->{SIDS}->{$sid}->{tree}} < 1) - { - - push @{$self->{SIDS}->{$sid}->{tree}}, $CLOSED; - - if (ref($self) ne "XML::Stream::Parser") - { - my $stream_prefix = $self->StreamPrefix($sid); - - if(defined($self->{SIDS}->{$sid}->{tree}->[0]) && - ($self->{SIDS}->{$sid}->{tree}->[0] =~ /^${stream_prefix}\:/)) - { - my @tree = @{$self->{SIDS}->{$sid}->{tree}}; - $self->{SIDS}->{$sid}->{tree} = []; - $self->ProcessStreamPacket($sid,\@tree); - } - else - { - my @tree = @{$self->{SIDS}->{$sid}->{tree}}; - $self->{SIDS}->{$sid}->{tree} = []; - - my @special = - &XML::Stream::XPath( - \@tree, - '[@xmlns="'.&XML::Stream::ConstXMLNS("xmpp-sasl").'" or @xmlns="'.&XML::Stream::ConstXMLNS("xmpp-tls").'"]' - ); - if ($#special > -1) - { - my $xmlns = &GetXMLData("value",\@tree,"","xmlns"); - - $self->ProcessSASLPacket($sid,\@tree) - if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-sasl")); - $self->ProcessTLSPacket($sid,\@tree) - if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-tls")); - } - else - { - &{$self->{CB}->{node}}($sid,\@tree); - } - } - } - } - else - { - push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, $CLOSED; - } -} - - -############################################################################## -# -# SetXMLData - takes a host of arguments and sets a portion of the specified -# XML::Parser::Tree object with that data. The function works -# in two modes "single" or "multiple". "single" denotes that -# the function should locate the current tag that matches this -# data and overwrite it's contents with data passed in. -# "multiple" denotes that a new tag should be created even if -# others exist. -# -# type - single or multiple -# XMLTree - pointer to XML::Stream Tree object -# tag - name of tag to create/modify (if blank assumes -# working with top level tag) -# data - CDATA to set for tag -# attribs - attributes to ADD to tag -# -############################################################################## -sub SetXMLData -{ - my ($type,$XMLTree,$tag,$data,$attribs) = @_; - my ($key); - - if ($tag ne "") - { - if ($type eq "single") - { - my ($child); - foreach $child (1..$#{$$XMLTree[1]}) - { - if ($$XMLTree[1]->[$child] eq $tag) - { - if ($data ne "") - { - #todo: add code to handle writing the cdata again and appending it. - $$XMLTree[1]->[$child+1]->[1] = 0; - $$XMLTree[1]->[$child+1]->[2] = $data; - } - foreach $key (keys(%{$attribs})) - { - $$XMLTree[1]->[$child+1]->[0]->{$key} = $$attribs{$key}; - } - return; - } - } - } - $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = $tag; - $$XMLTree[1]->[($#{$$XMLTree[1]}+1)]->[0] = {}; - foreach $key (keys(%{$attribs})) - { - $$XMLTree[1]->[$#{$$XMLTree[1]}]->[0]->{$key} = $$attribs{$key}; - } - if ($data ne "") - { - $$XMLTree[1]->[$#{$$XMLTree[1]}]->[1] = 0; - $$XMLTree[1]->[$#{$$XMLTree[1]}]->[2] = $data; - } - } - else - { - foreach $key (keys(%{$attribs})) - { - $$XMLTree[1]->[0]->{$key} = $$attribs{$key}; - } - if ($data ne "") - { - if (($#{$$XMLTree[1]} > 0) && - ($$XMLTree[1]->[($#{$$XMLTree[1]}-1)] eq "0")) - { - $$XMLTree[1]->[$#{$$XMLTree[1]}] .= $data; - } - else - { - $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = 0; - $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = $data; - } - } - } -} - - -############################################################################## -# -# GetXMLData - takes a host of arguments and returns various data structures -# that match them. -# -# type - "existence" - returns 1 or 0 if the tag exists in the -# top level. -# "value" - returns either the CDATA of the tag, or the -# value of the attribute depending on which is -# sought. This ignores any mark ups to the data -# and just returns the raw CDATA. -# "value array" - returns an array of strings representing -# all of the CDATA in the specified tag. -# This ignores any mark ups to the data -# and just returns the raw CDATA. -# "tree" - returns an XML::Parser::Tree object with the -# specified tag as the root tag. -# "tree array" - returns an array of XML::Parser::Tree -# objects each with the specified tag as -# the root tag. -# "child array" - returns a list of all children nodes -# not including CDATA nodes. -# "attribs" - returns a hash with the attributes, and -# their values, for the things that match -# the parameters -# "count" - returns the number of things that match -# the arguments -# "tag" - returns the root tag of this tree -# XMLTree - pointer to XML::Parser::Tree object -# tag - tag to pull data from. If blank then the top level -# tag is accessed. -# attrib - attribute value to retrieve. Ignored for types -# "value array", "tree", "tree array". If paired -# with value can be used to filter tags based on -# attributes and values. -# value - only valid if an attribute is supplied. Used to -# filter for tags that only contain this attribute. -# Useful to search through multiple tags that all -# reference different name spaces. -# -############################################################################## -sub GetXMLData -{ - my ($type,$XMLTree,$tag,$attrib,$value) = @_; - - $tag = "" if !defined($tag); - $attrib = "" if !defined($attrib); - $value = "" if !defined($value); - - my $skipthis = 0; - - #--------------------------------------------------------------------------- - # Check if a child tag in the root tag is being requested. - #--------------------------------------------------------------------------- - if ($tag ne "") - { - my $count = 0; - my @array; - foreach my $child (1..$#{$$XMLTree[1]}) - { - next if (($child/2) !~ /\./); - if (($$XMLTree[1]->[$child] eq $tag) || ($tag eq "*")) - { - next if (ref($$XMLTree[1]->[$child]) eq "ARRAY"); - - #--------------------------------------------------------------------- - # Filter out tags that do not contain the attribute and value. - #--------------------------------------------------------------------- - next if (($value ne "") && ($attrib ne "") && exists($$XMLTree[1]->[$child+1]->[0]->{$attrib}) && ($$XMLTree[1]->[$child+1]->[0]->{$attrib} ne $value)); - next if (($attrib ne "") && ((ref($$XMLTree[1]->[$child+1]) ne "ARRAY") || !exists($$XMLTree[1]->[$child+1]->[0]->{$attrib}))); - - #--------------------------------------------------------------------- - # Check for existence - #--------------------------------------------------------------------- - if ($type eq "existence") - { - return 1; - } - - #--------------------------------------------------------------------- - # Return the raw CDATA value without mark ups, or the value of the - # requested attribute. - #--------------------------------------------------------------------- - if ($type eq "value") - { - if ($attrib eq "") - { - my $str = ""; - my $next = 0; - my $index; - foreach $index (1..$#{$$XMLTree[1]->[$child+1]}) { - if ($next == 1) { $next = 0; next; } - if ($$XMLTree[1]->[$child+1]->[$index] eq "0") { - $str .= $$XMLTree[1]->[$child+1]->[$index+1]; - $next = 1; - } - } - return $str; - } - return $$XMLTree[1]->[$child+1]->[0]->{$attrib} - if (exists $$XMLTree[1]->[$child+1]->[0]->{$attrib}); - } - #--------------------------------------------------------------------- - # Return an array of values that represent the raw CDATA without - # mark up tags for the requested tags. - #--------------------------------------------------------------------- - if ($type eq "value array") - { - if ($attrib eq "") - { - my $str = ""; - my $next = 0; - my $index; - foreach $index (1..$#{$$XMLTree[1]->[$child+1]}) - { - if ($next == 1) { $next = 0; next; } - if ($$XMLTree[1]->[$child+1]->[$index] eq "0") - { - $str .= $$XMLTree[1]->[$child+1]->[$index+1]; - $next = 1; - } - } - push(@array,$str); - } - else - { - push(@array,$$XMLTree[1]->[$child+1]->[0]->{$attrib}) - if (exists $$XMLTree[1]->[$child+1]->[0]->{$attrib}); - } - } - #--------------------------------------------------------------------- - # Return a pointer to a new XML::Parser::Tree object that has the - # requested tag as the root tag. - #--------------------------------------------------------------------- - if ($type eq "tree") - { - my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] ); - return @tree; - } - #--------------------------------------------------------------------- - # Return an array of pointers to XML::Parser::Tree objects that have - # the requested tag as the root tags. - #--------------------------------------------------------------------- - if ($type eq "tree array") - { - my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] ); - push(@array,\@tree); - } - #--------------------------------------------------------------------- - # Return a count of the number of tags that match - #--------------------------------------------------------------------- - if ($type eq "count") - { - if ($$XMLTree[1]->[$child] eq "0") - { - $skipthis = 1; - next; - } - if ($skipthis == 1) - { - $skipthis = 0; - next; - } - $count++; - } - #--------------------------------------------------------------------- - # Return a count of the number of tags that match - #--------------------------------------------------------------------- - if ($type eq "child array") - { - my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] ); - push(@array,\@tree) if ($tree[0] ne "0"); - } - #--------------------------------------------------------------------- - # Return the attribute hash that matches this tag - #--------------------------------------------------------------------- - if ($type eq "attribs") - { - return (%{$$XMLTree[1]->[$child+1]->[0]}); - } - } - } - #------------------------------------------------------------------------- - # If we are returning arrays then return array. - #------------------------------------------------------------------------- - if (($type eq "tree array") || ($type eq "value array") || - ($type eq "child array")) - { - return @array; - } - - #------------------------------------------------------------------------- - # If we are returning then count, then do so - #------------------------------------------------------------------------- - if ($type eq "count") - { - return $count; - } - } - else - { - #------------------------------------------------------------------------- - # This is the root tag, so handle things a level up. - #------------------------------------------------------------------------- - - #------------------------------------------------------------------------- - # Return the raw CDATA value without mark ups, or the value of the - # requested attribute. - #------------------------------------------------------------------------- - if ($type eq "value") - { - if ($attrib eq "") - { - my $str = ""; - my $next = 0; - my $index; - foreach $index (1..$#{$$XMLTree[1]}) - { - if ($next == 1) { $next = 0; next; } - if ($$XMLTree[1]->[$index] eq "0") - { - $str .= $$XMLTree[1]->[$index+1]; - $next = 1; - } - } - return $str; - } - return $$XMLTree[1]->[0]->{$attrib} - if (exists $$XMLTree[1]->[0]->{$attrib}); - } - #------------------------------------------------------------------------- - # Return a pointer to a new XML::Parser::Tree object that has the - # requested tag as the root tag. - #------------------------------------------------------------------------- - if ($type eq "tree") - { - my @tree = @{$$XMLTree}; - return @tree; - } - - #------------------------------------------------------------------------- - # Return the 1 if the specified attribute exists in the root tag. - #------------------------------------------------------------------------- - if ($type eq "existence") - { - return 1 if (($attrib ne "") && (exists($$XMLTree[1]->[0]->{$attrib}))); - } - - #------------------------------------------------------------------------- - # Return the attribute hash that matches this tag - #------------------------------------------------------------------------- - if ($type eq "attribs") - { - return %{$$XMLTree[1]->[0]}; - } - #------------------------------------------------------------------------- - # Return the tag of this node - #------------------------------------------------------------------------- - if ($type eq "tag") - { - return $$XMLTree[0]; - } - } - #--------------------------------------------------------------------------- - # Return 0 if this was a request for existence, or "" if a request for - # a "value", or [] for "tree", "value array", and "tree array". - #--------------------------------------------------------------------------- - return 0 if ($type eq "existence"); - return "" if ($type eq "value"); - return []; -} - - -############################################################################## -# -# BuildXML - takes an XML::Parser::Tree object and builds the XML string -# that it represents. -# -############################################################################## -sub BuildXML -{ - my ($parseTree,$rawXML) = @_; - - return "" if $#{$parseTree} == -1; - - my $str = ""; - if (ref($parseTree->[0]) eq "") - { - if ($parseTree->[0] eq "0") - { - return &XML::Stream::EscapeXML($parseTree->[1]); - } - - $str = "<".$parseTree->[0]; - foreach my $att (sort {$a cmp $b} keys(%{$parseTree->[1]->[0]})) - { - $str .= " ".$att."='".&XML::Stream::EscapeXML($parseTree->[1]->[0]->{$att})."'"; - } - - if (($#{$parseTree->[1]} > 0) || (defined($rawXML) && ($rawXML ne ""))) - { - $str .= ">"; - - my $index = 1; - while($index <= $#{$parseTree->[1]}) - { - my @newTree = ( $parseTree->[1]->[$index], $parseTree->[1]->[$index+1] ); - $str .= &XML::Stream::Tree::BuildXML(\@newTree); - $index += 2; - } - - $str .= $rawXML if defined($rawXML); - $str .= "</".$parseTree->[0].">"; - } - else - { - $str .= "/>"; - } - - } - - return $str; -} - - -############################################################################## -# -# XML2Config - takes an XML data tree and turns it into a hash of hashes. -# This only works for certain kinds of XML trees like this: -# -# <foo> -# <bar>1</bar> -# <x> -# <y>foo</y> -# </x> -# <z>5</z> -# </foo> -# -# The resulting hash would be: -# -# $hash{bar} = 1; -# $hash{x}->{y} = "foo"; -# $hash{z} = 5; -# -# Good for config files. -# -############################################################################## -sub XML2Config -{ - my ($XMLTree) = @_; - - my %hash; - foreach my $tree (&XML::Stream::GetXMLData("tree array",$XMLTree,"*")) - { - if ($tree->[0] eq "0") - { - return $tree->[1] unless ($tree->[1] =~ /^\s*$/); - } - else - { - if (&XML::Stream::GetXMLData("count",$XMLTree,$tree->[0]) > 1) - { - push(@{$hash{$tree->[0]}},&XML::Stream::XML2Config($tree)); - } - else - { - $hash{$tree->[0]} = &XML::Stream::XML2Config($tree); - } - } - } - return \%hash; -} - - -1; diff --git a/lib/XML/Stream/XPath.pm b/lib/XML/Stream/XPath.pm deleted file mode 100644 index 164a7a7..0000000 --- a/lib/XML/Stream/XPath.pm +++ /dev/null @@ -1,50 +0,0 @@ -############################################################################## -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Library General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Library General Public License for more details. -# -# You should have received a copy of the GNU Library General Public -# License along with this library; if not, write to the -# Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. -# -# Jabber -# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ -# -############################################################################## - -package XML::Stream::XPath; - -use 5.006_001; -use strict; -use vars qw( $VERSION %FUNCTIONS ); - -$VERSION = "1.22"; - -use XML::Stream::XPath::Value; -use XML::Stream::XPath::Op; -use XML::Stream::XPath::Query; - -sub AddFunction -{ - my $function = shift; - my $code = shift; - if (!defined($code)) - { - delete($FUNCTIONS{$code}); - return; - } - - $FUNCTIONS{$function} = $code; -} - - -1; - diff --git a/lib/XML/Stream/XPath/Op.pm b/lib/XML/Stream/XPath/Op.pm deleted file mode 100644 index 4209a5c..0000000 --- a/lib/XML/Stream/XPath/Op.pm +++ /dev/null @@ -1,919 +0,0 @@ -############################################################################## -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Library General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Library General Public License for more details. -# -# You should have received a copy of the GNU Library General Public -# License along with this library; if not, write to the -# Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. -# -# Jabber -# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ -# -############################################################################## - - -############################################################################## -# -# Op - Base Op class -# -############################################################################## -package XML::Stream::XPath::Op; - -use 5.006_001; -use strict; -use vars qw( $VERSION ); - -$VERSION = "1.22"; - -sub new -{ - my $proto = shift; - return &allocate($proto,@_); -} - -sub allocate -{ - my $proto = shift; - my $self = { }; - - bless($self,$proto); - - $self->{TYPE} = shift; - $self->{VALUE} = shift; - - return $self; -} - -sub getValue -{ - my $self = shift; - return $self->{VALUE}; -} - -sub calcStr -{ - my $self = shift; - return $self->{VALUE}; -} - -sub getType -{ - my $self = shift; - return $self->{TYPE}; -} - - -sub isValid -{ - my $self = shift; - my $ctxt = shift; - return 1; -} - -sub display -{ - my $self = shift; - my $space = shift; - $space = "" unless defined($space); - - print $space,"OP: type($self->{TYPE}) value($self->{VALUE})\n"; -} - - - -############################################################################## -# -# PositionOp - class to handle [0] ops -# -############################################################################## -package XML::Stream::XPath::PositionOp; - -use vars qw (@ISA); -@ISA = ( "XML::Stream::XPath::Op" ); - -sub new -{ - my $proto = shift; - my $self = $proto->allocate("POSITION",""); - $self->{POS} = shift; - - return $self; -} - - -sub isValid -{ - my $self = shift; - my $ctxt = shift; - - my @elems = $$ctxt->getList(); - my @valid_elems; - if ($#elems+1 < $self->{POS}) - { - return; - } - - push(@valid_elems, $elems[$self->{POS}-1]); - - $$ctxt->setList(@valid_elems); - - return 1; -} - - - -############################################################################## -# -# ContextOp - class to handle [...] ops -# -############################################################################## -package XML::Stream::XPath::ContextOp; - -use vars qw (@ISA); -@ISA = ( "XML::Stream::XPath::Op" ); - -sub new -{ - my $proto = shift; - my $self = $proto->allocate("CONTEXT",""); - $self->{OP} = shift; - return $self; -} - - -sub isValid -{ - my $self = shift; - my $ctxt = shift; - - my @elems = $$ctxt->getList(); - my @valid_elems; - foreach my $elem (@elems) - { - my $tmp_ctxt = new XML::Stream::XPath::Value($elem); - $tmp_ctxt->in_context(1); - if ($self->{OP}->isValid(\$tmp_ctxt)) - { - push(@valid_elems,$elem); - } - } - - $$ctxt->setList(@valid_elems); - - if ($#valid_elems == -1) - { - return; - } - - return 1; -} - - -sub display -{ - my $self = shift; - my $space = shift; - $space = "" unless defined($space); - - print "${space}OP: type(CONTEXT) op: \n"; - $self->{OP}->display("$space "); -} - - - - -############################################################################## -# -# AllOp - class to handle // ops -# -############################################################################## -package XML::Stream::XPath::AllOp; - -use vars qw (@ISA); -@ISA = ( "XML::Stream::XPath::Op" ); - -sub new -{ - my $proto = shift; - my $name = shift; - my $self = $proto->allocate("ALL",$name); - return $self; -} - - -sub isValid -{ - my $self = shift; - my $ctxt = shift; - - my @elems = $$ctxt->getList(); - - if ($#elems == -1) - { - return; - } - - my @valid_elems; - - foreach my $elem (@elems) - { - push(@valid_elems,$self->descend($elem)); - } - - $$ctxt->setList(@valid_elems); - - if ($#valid_elems == -1) - { - return; - } - - return 1; -} - - -sub descend -{ - my $self = shift; - my $elem = shift; - - my @valid_elems; - - if (($self->{VALUE} eq "*") || (&XML::Stream::GetXMLData("tag",$elem) eq $self->{VALUE})) - { - push(@valid_elems,$elem); - } - - foreach my $child (&XML::Stream::GetXMLData("child array",$elem,"*")) - { - push(@valid_elems,$self->descend($child)); - } - - return @valid_elems; -} - - - -############################################################################## -# -# NodeOp - class to handle ops based on node names -# -############################################################################## -package XML::Stream::XPath::NodeOp; - -use vars qw (@ISA); -@ISA = ( "XML::Stream::XPath::Op" ); - -sub new -{ - my $proto = shift; - my $name = shift; - my $is_root = shift; - $is_root = 0 unless defined($is_root); - my $self = $proto->allocate("NODE",$name); - $self->{ISROOT} = $is_root; - return $self; -} - - -sub isValid -{ - my $self = shift; - my $ctxt = shift; - - if ($self->{ISROOT}) - { - my $elem = $$ctxt->getFirstElem(); - if (&XML::Stream::GetXMLData("tag",$elem) ne $self->{VALUE}) - { - return; - } - return 1; - } - - my @valid_elems; - - foreach my $elem ($$ctxt->getList()) - { - my $valid = 0; - - foreach my $child (&XML::Stream::GetXMLData("child array",$elem,"*")) - { - if (($self->{VALUE} eq "*") || - (&XML::Stream::GetXMLData("tag",$child) eq $self->{VALUE})) - { - if ($$ctxt->in_context()) - { - $valid = 1; - } - else - { - push(@valid_elems,$child); - } - } - } - if ($valid) - { - push(@valid_elems,$elem); - } - } - - $$ctxt->setList(@valid_elems); - - if ($#valid_elems == -1) - { - return; - } - - return 1; -} - - -sub calcStr -{ - my $self = shift; - my $elem = shift; - return &XML::Stream::GetXMLData("value",$elem); -} - - -############################################################################## -# -# EqualOp - class to handle [ x = y ] ops -# -############################################################################## -package XML::Stream::XPath::EqualOp; - -use vars qw (@ISA); -@ISA = ( "XML::Stream::XPath::Op" ); - -sub new -{ - my $proto = shift; - my $self = $proto->allocate("EQUAL",""); - $self->{OP_L} = shift; - $self->{OP_R} = shift; - return $self; -} - - -sub isValid -{ - my $self = shift; - my $ctxt = shift; - - my $tmp_ctxt = new XML::Stream::XPath::Value(); - $tmp_ctxt->setList($$ctxt->getList()); - $tmp_ctxt->in_context(0); - - if (!$self->{OP_L}->isValid(\$tmp_ctxt) || !$self->{OP_R}->isValid(\$tmp_ctxt)) - { - return; - } - - my @valid_elems; - foreach my $elem ($tmp_ctxt->getList) - { - if ($self->{OP_L}->calcStr($elem) eq $self->{OP_R}->calcStr($elem)) - { - push(@valid_elems,$elem); - } - } - - if ( $#valid_elems > -1) - { - @valid_elems = $$ctxt->getList(); - } - - $$ctxt->setList(@valid_elems); - - if ($#valid_elems == -1) - { - return; - } - - return 1; -} - - -sub display -{ - my $self = shift; - my $space = shift; - $space = "" unless defined($space); - - print $space,"OP: type(EQUAL)\n"; - print $space," op_l: "; - $self->{OP_L}->display($space." "); - - print $space," op_r: "; - $self->{OP_R}->display($space." "); -} - - - -############################################################################## -# -# NotEqualOp - class to handle [ x != y ] ops -# -############################################################################## -package XML::Stream::XPath::NotEqualOp; - -use vars qw (@ISA); -@ISA = ( "XML::Stream::XPath::Op" ); - -sub new -{ - my $proto = shift; - my $self = $proto->allocate("NOTEQUAL",""); - $self->{OP_L} = shift; - $self->{OP_R} = shift; - return $self; -} - - -sub isValid -{ - my $self = shift; - my $ctxt = shift; - - my $tmp_ctxt = new XML::Stream::XPath::Value(); - $tmp_ctxt->setList($$ctxt->getList()); - $tmp_ctxt->in_context(0); - - if (!$self->{OP_L}->isValid(\$tmp_ctxt) || !$self->{OP_R}->isValid(\$tmp_ctxt)) - { - return; - } - - my @valid_elems; - foreach my $elem ($tmp_ctxt->getList) - { - if ($self->{OP_L}->calcStr($elem) ne $self->{OP_R}->calcStr($elem)) - { - push(@valid_elems,$elem); - } - } - - if ( $#valid_elems > -1) - { - @valid_elems = $$ctxt->getList(); - } - - $$ctxt->setList(@valid_elems); - - if ($#valid_elems == -1) - { - return; - } - - return 1; -} - - -sub display -{ - my $self = shift; - my $space = shift; - $space = "" unless defined($space); - - print $space,"OP: type(NOTEQUAL)\n"; - print $space," op_l: "; - $self->{OP_L}->display($space." "); - - print $space," op_r: "; - $self->{OP_R}->display($space." "); -} - - - -############################################################################## -# -# AttributeOp - class to handle @foo ops. -# -############################################################################## -package XML::Stream::XPath::AttributeOp; - -use vars qw (@ISA); -@ISA = ( "XML::Stream::XPath::Op" ); - -sub new -{ - my $proto = shift; - my $name = shift; - my $self = $proto->allocate("ATTRIBUTE",$name); - return $self; -} - - -sub isValid -{ - my $self = shift; - my $ctxt = shift; - - my @elems = $$ctxt->getList(); - my @valid_elems; - my @values; - my %attribs; - - foreach my $elem (@elems) - { - if ($self->{VALUE} ne "*") - { - if (&XML::Stream::GetXMLData("value",$elem,"",$self->{VALUE})) - { - $self->{VAL} = $self->calcStr($elem); - push(@valid_elems,$elem); - push(@values,$self->{VAL}); - } - } - else - { - my %attrib = &XML::Stream::GetXMLData("attribs",$elem); - if (scalar(keys(%attrib)) > 0) - { - push(@valid_elems,$elem); - foreach my $key (keys(%attrib)) - { - $attribs{$key} = $attrib{$key}; - } - } - } - } - - $$ctxt->setList(@valid_elems); - $$ctxt->setValues(@values); - $$ctxt->setAttribs(%attribs); - - if ($#valid_elems == -1) - { - return; - } - - return 1; -} - - -sub getValue -{ - my $self = shift; - return $self->{VAL}; -} - - -sub calcStr -{ - my $self = shift; - my $elem = shift; - return &XML::Stream::GetXMLData("value",$elem,"",$self->{VALUE}); -} - - - - -############################################################################## -# -# AndOp - class to handle [ .... and .... ] ops -# -############################################################################## -package XML::Stream::XPath::AndOp; - -use vars qw (@ISA); -@ISA = ( "XML::Stream::XPath::Op" ); - -sub new -{ - my $proto = shift; - my $self = $proto->allocate("AND","and"); - $self->{OP_L} = shift; - $self->{OP_R} = shift; - return $self; -} - - -sub isValid -{ - my $self = shift; - my $ctxt = shift; - - my $opl = $self->{OP_L}->isValid($ctxt); - my $opr = $self->{OP_R}->isValid($ctxt); - - if ($opl && $opr) - { - return 1; - } - else - { - return; - } -} - - -sub display -{ - my $self = shift; - my $space = shift; - $space = "" unless defined($space); - - print $space,"OP: type(AND)\n"; - print $space," op_l: \n"; - $self->{OP_L}->display($space." "); - - print $space," op_r: \n"; - $self->{OP_R}->display($space." "); -} - - - -############################################################################## -# -# OrOp - class to handle [ .... or .... ] ops -# -############################################################################## -package XML::Stream::XPath::OrOp; - -use vars qw (@ISA); -@ISA = ( "XML::Stream::XPath::Op" ); - -sub new -{ - my $proto = shift; - my $self = $proto->allocate("OR","or"); - $self->{OP_L} = shift; - $self->{OP_R} = shift; - return $self; -} - - -sub isValid -{ - my $self = shift; - my $ctxt = shift; - - my @elems = $$ctxt->getList(); - my @valid_elems; - - foreach my $elem (@elems) - { - my $tmp_ctxt_l = new XML::Stream::XPath::Value($elem); - $tmp_ctxt_l->in_context(1); - my $tmp_ctxt_r = new XML::Stream::XPath::Value($elem); - $tmp_ctxt_r->in_context(1); - - my $opl = $self->{OP_L}->isValid(\$tmp_ctxt_l); - my $opr = $self->{OP_R}->isValid(\$tmp_ctxt_r); - - if ($opl || $opr) - { - push(@valid_elems,$elem); - } - } - - $$ctxt->setList(@valid_elems); - - if ($#valid_elems == -1) - { - return; - } - - return 1; -} - - -sub display -{ - my $self = shift; - my $space = shift; - $space = "" unless defined($space); - - print "${space}OP: type(OR)\n"; - print "$space op_l: "; - $self->{OP_L}->display("$space "); - - print "$space op_r: "; - $self->{OP_R}->display("$space "); -} - - - -############################################################################## -# -# FunctionOp - class to handle xxxx(...) ops -# -############################################################################## -package XML::Stream::XPath::FunctionOp; - -use vars qw (@ISA); -@ISA = ( "XML::Stream::XPath::Op" ); - -sub new -{ - my $proto = shift; - my $function = shift; - my $self = $proto->allocate("FUNCTION",$function); - $self->{CLOSED} = 0; - return $self; -} - - -sub addArg -{ - my $self = shift; - my $arg = shift; - - push(@{$self->{ARGOPS}},$arg); -} - - -sub isValid -{ - my $self = shift; - my $ctxt = shift; - - my $result; - eval("\$result = &{\$XML::Stream::XPath::FUNCTIONS{\$self->{VALUE}}}(\$ctxt,\@{\$self->{ARGOPS}});"); - return $result; -} - - -sub calcStr -{ - my $self = shift; - my $elem = shift; - - my $result; - eval("\$result = &{\$XML::Stream::XPath::VALUES{\$self->{VALUE}}}(\$elem);"); - return $result; - -} - - -sub display -{ - my $self = shift; - my $space = shift; - $space = "" unless defined($space); - - print $space,"OP: type(FUNCTION)\n"; - print $space," $self->{VALUE}(\n"; - foreach my $arg (@{$self->{ARGOPS}}) - { - print $arg,"\n"; - $arg->display($space." "); - } - print "$space )\n"; -} - - -sub function_name -{ - my $ctxt = shift; - my (@args) = @_; - - my @elems = $$ctxt->getList(); - my @valid_elems; - my @valid_values; - foreach my $elem (@elems) - { - my $text = &value_name($elem); - if (defined($text)) - { - push(@valid_elems,$elem); - push(@valid_values,$text); - } - } - - $$ctxt->setList(@valid_elems); - $$ctxt->setValues(@valid_values); - - if ($#valid_elems == -1) - { - return; - } - - return 1; -} - - -sub function_not -{ - my $ctxt = shift; - my (@args) = @_; - - my @elems = $$ctxt->getList(); - my @valid_elems; - foreach my $elem (@elems) - { - my $tmp_ctxt = new XML::Stream::XPath::Value($elem); - $tmp_ctxt->in_context(1); - if (!($args[0]->isValid(\$tmp_ctxt))) - { - push(@valid_elems,$elem); - } - } - - $$ctxt->setList(@valid_elems); - - if ($#valid_elems == -1) - { - return; - } - - return 1; -} - - -sub function_text -{ - my $ctxt = shift; - my (@args) = @_; - - my @elems = $$ctxt->getList(); - my @valid_elems; - my @valid_values; - foreach my $elem (@elems) - { - my $text = &value_text($elem); - if (defined($text)) - { - push(@valid_elems,$elem); - push(@valid_values,$text); - } - } - - $$ctxt->setList(@valid_elems); - $$ctxt->setValues(@valid_values); - - if ($#valid_elems == -1) - { - return; - } - - return 1; -} - - -sub function_startswith -{ - my $ctxt = shift; - my (@args) = @_; - - my @elems = $$ctxt->getList(); - my @valid_elems; - foreach my $elem (@elems) - { - my $val1 = $args[0]->calcStr($elem); - my $val2 = $args[1]->calcStr($elem); - - if (substr($val1,0,length($val2)) eq $val2) - { - push(@valid_elems,$elem); - } - } - - $$ctxt->setList(@valid_elems); - - if ($#valid_elems == -1) - { - return; - } - - return 1; -} - - -sub value_name -{ - my $elem = shift; - return &XML::Stream::GetXMLData("tag",$elem); -} - - -sub value_text -{ - my $elem = shift; - return &XML::Stream::GetXMLData("value",$elem); -} - - - -$XML::Stream::XPath::FUNCTIONS{'name'} = \&function_name; -$XML::Stream::XPath::FUNCTIONS{'not'} = \&function_not; -$XML::Stream::XPath::FUNCTIONS{'text'} = \&function_text; -$XML::Stream::XPath::FUNCTIONS{'starts-with'} = \&function_startswith; - -$XML::Stream::XPath::VALUES{'name'} = \&value_name; -$XML::Stream::XPath::VALUES{'text'} = \&value_text; - -1; - - diff --git a/lib/XML/Stream/XPath/Query.pm b/lib/XML/Stream/XPath/Query.pm deleted file mode 100644 index c4831fe..0000000 --- a/lib/XML/Stream/XPath/Query.pm +++ /dev/null @@ -1,374 +0,0 @@ -############################################################################## -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Library General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Library General Public License for more details. -# -# You should have received a copy of the GNU Library General Public -# License along with this library; if not, write to the -# Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. -# -# Jabber -# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ -# -############################################################################## - -package XML::Stream::XPath::Query; - -use 5.006_001; -use strict; -use Carp; -use vars qw( $VERSION ); - -$VERSION = "1.22"; - -sub new -{ - my $proto = shift; - my $self = { }; - - bless($self,$proto); - - $self->{TOKENS} = [ '/','[',']','@','"',"'",'=','!','(',')',':',' ',',']; - $self->{QUERY} = shift; - - if (!defined($self->{QUERY}) || ($self->{QUERY} eq "")) - { - confess("No query string specified"); - } - - $self->parseQuery(); - - return $self; -} - - -sub getNextToken -{ - my $self = shift; - my $pos = shift; - - my @toks = grep{ $_ eq substr($self->{QUERY},$$pos,1)} @{$self->{TOKENS}}; - while( $#toks == -1 ) - { - $$pos++; - if ($$pos > length($self->{QUERY})) - { - $$pos = length($self->{QUERY}); - return 0; - } - @toks = grep{ $_ eq substr($self->{QUERY},$$pos,1)} @{$self->{TOKENS}}; - } - - return $toks[0]; -} - - -sub getNextIdentifier -{ - my $self = shift; - my $pos = shift; - my $sp = $$pos; - $self->getNextToken($pos); - return substr($self->{QUERY},$sp,$$pos-$sp); -} - - -sub getOp -{ - my $self = shift; - my $pos = shift; - my $in_context = shift; - $in_context = 0 unless defined($in_context); - - my $ret_op; - - my $loop = 1; - while( $loop ) - { - my $pos_start = $$pos; - - my $token = $self->getNextToken($pos); - if (($token eq "0") && $in_context) - { - return; - } - - my $token_start = ++$$pos; - my $ident; - - if (defined($token)) - { - - if ($pos_start != ($token_start-1)) - { - $$pos = $pos_start; - my $temp_ident = $self->getNextIdentifier($pos); - $ret_op = new XML::Stream::XPath::NodeOp($temp_ident,"0"); - } - elsif ($token eq "/") - { - if (substr($self->{QUERY},$token_start,1) eq "/") - { - $$pos++; - my $temp_ident = $self->getNextIdentifier($pos); - $ret_op = new XML::Stream::XPath::AllOp($temp_ident); - } - else - { - my $temp_ident = $self->getNextIdentifier($pos); - if ($temp_ident ne "") - { - $ret_op = new XML::Stream::XPath::NodeOp($temp_ident,($pos_start == 0 ? "1" : "0")); - } - } - } - elsif ($token eq "\@") - { - $ret_op = new XML::Stream::XPath::AttributeOp($self->getNextIdentifier($pos)); - } - elsif ($token eq "]") - { - if ($in_context eq "[") - { - $ret_op = pop(@{$self->{OPS}}); - $in_context = 0; - } - else - { - confess("Found ']' but not in context"); - return; - } - } - elsif (($token eq "\"") || ($token eq "\'")) - { - $$pos = index($self->{QUERY},$token,$token_start); - $ret_op = new XML::Stream::XPath::Op("LITERAL",substr($self->{QUERY},$token_start,$$pos-$token_start)); - $$pos++; - } - elsif ($token eq " ") - { - $ident = $self->getNextIdentifier($pos); - if ($ident eq "and") - { - $$pos++; - my $tmp_op = $self->getOp($pos,$in_context); - if (!defined($tmp_op)) - { - confess("Invalid 'and' operation"); - return; - } - $ret_op = new XML::Stream::XPath::AndOp($self->{OPS}->[$#{$self->{OPS}}],$tmp_op); - $in_context = 0; - pop(@{$self->{OPS}}); - } - elsif ($ident eq "or") - { - $$pos++; - my $tmp_op = $self->getOp($pos,$in_context); - if (!defined($tmp_op)) - { - confess("Invalid 'or' operation"); - return; - } - $ret_op = new XML::Stream::XPath::OrOp($self->{OPS}->[$#{$self->{OPS}}],$tmp_op); - $in_context = 0; - pop(@{$self->{OPS}}); - } - } - elsif ($token eq "[") - { - if ($self->getNextToken($pos) eq "]") - { - if ($$pos == $token_start) - { - confess("Nothing in the []"); - return; - } - - $$pos = $token_start; - my $val = $self->getNextIdentifier($pos); - if ($val =~ /^\d+$/) - { - $ret_op = new XML::Stream::XPath::PositionOp($val); - $$pos++; - } - else - { - $$pos = $pos_start + 1; - $ret_op = new XML::Stream::XPath::ContextOp($self->getOp($pos,$token)); - } - } - else - { - $$pos = $pos_start + 1; - $ret_op = new XML::Stream::XPath::ContextOp($self->getOp($pos,$token)); - } - } - elsif ($token eq "(") - { - #------------------------------------------------------------- - # The function name would have been mistaken for a NodeOp. - # Pop it off the back and get the function name. - #------------------------------------------------------------- - my $op = pop(@{$self->{OPS}}); - if ($op->getType() ne "NODE") - { - confess("No function name specified."); - } - my $function = $op->getValue(); - if (!exists($XML::Stream::XPath::FUNCTIONS{$function})) - { - confess("Undefined function \"$function\""); - } - $ret_op = new XML::Stream::XPath::FunctionOp($function); - - my $op_pos = $#{$self->{OPS}} + 1; - - $self->getOp($pos,$token); - - foreach my $arg ($op_pos..$#{$self->{OPS}}) - { - $ret_op->addArg($self->{OPS}->[$arg]); - } - - splice(@{$self->{OPS}},$op_pos); - - } - elsif ($token eq ")") - { - if ($in_context eq "(") - { - $ret_op = undef; - $in_context = 0; - } - else - { - confess("Found ')' but not in context"); - } - } - elsif ($token eq ",") - { - if ($in_context ne "(") - { - confess("Found ',' but not in a function"); - } - - } - elsif ($token eq "=") - { - my $tmp_op; - while(!defined($tmp_op)) - { - $tmp_op = $self->getOp($pos); - } - $ret_op = new XML::Stream::XPath::EqualOp($self->{OPS}->[$#{$self->{OPS}}],$tmp_op); - pop(@{$self->{OPS}}); - } - elsif ($token eq "!") - { - if (substr($self->{QUERY},$token_start,1) ne "=") - { - confess("Badly formed !="); - } - $$pos++; - - my $tmp_op; - while(!defined($tmp_op)) - { - $tmp_op = $self->getOp($pos); - } - $ret_op = new XML::Stream::XPath::NotEqualOp($self->{OPS}->[$#{$self->{OPS}}],$tmp_op); - pop(@{$self->{OPS}}); - } - else - { - confess("Unhandled \"$token\""); - } - - if ($in_context) - { - if (defined($ret_op)) - { - push(@{$self->{OPS}},$ret_op); - } - $ret_op = undef; - } - } - else - { - confess("Token undefined"); - } - - $loop = 0 unless $in_context; - } - - return $ret_op; -} - - -sub parseQuery -{ - my $self = shift; - my $query = shift; - - my $op; - my $pos = 0; - while($pos < length($self->{QUERY})) - { - $op = $self->getOp(\$pos); - if (defined($op)) - { - push(@{$self->{OPS}},$op); - } - } - - #foreach my $op (@{$self->{OPS}}) - #{ - # $op->display(); - #} - - return 1; -} - - -sub execute -{ - my $self = shift; - my $root = shift; - - my $ctxt = new XML::Stream::XPath::Value($root); - - foreach my $op (@{$self->{OPS}}) - { - if (!$op->isValid(\$ctxt)) - { - $ctxt->setValid(0); - return $ctxt; - } - } - - $ctxt->setValid(1); - return $ctxt; -} - - -sub check -{ - my $self = shift; - my $root = shift; - - my $ctxt = $self->execute($root); - return $ctxt->check(); -} - - -1; - diff --git a/lib/XML/Stream/XPath/Value.pm b/lib/XML/Stream/XPath/Value.pm deleted file mode 100644 index 425e183..0000000 --- a/lib/XML/Stream/XPath/Value.pm +++ /dev/null @@ -1,153 +0,0 @@ -############################################################################## -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Library General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Library General Public License for more details. -# -# You should have received a copy of the GNU Library General Public -# License along with this library; if not, write to the -# Free Software Foundation, Inc., 59 Temple Place - Suite 330, -# Boston, MA 02111-1307, USA. -# -# Jabber -# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ -# -############################################################################## - -package XML::Stream::XPath::Value; - -use 5.006_001; -use strict; -use vars qw( $VERSION ); - -$VERSION = "1.22"; - -sub new -{ - my $proto = shift; - my $self = { }; - - bless($self,$proto); - - $self->setList(@_); - $self->setValues(); - $self->setAttribs(); - $self->setValid(0); - $self->in_context(0); - - return $self; -} - - -sub setList -{ - my $self = shift; - my (@values) = @_; - $self->{LIST} = \@values; -} - - -sub getList -{ - my $self = shift; - return unless ($#{$self->{LIST}} > -1); - return @{$self->{LIST}}; -} - - -sub getFirstElem -{ - my $self = shift; - return unless ($#{$self->{LIST}} > -1); - return $self->{LIST}->[0]; -} - - -sub setValues -{ - my $self = shift; - my (@values) = @_; - $self->{VALUES} = \@values; -} - - -sub getValues -{ - my $self = shift; - return unless ($#{$self->{VALUES}} > -1); - return $self->{VALUES}->[0] if !wantarray; - return @{$self->{VALUES}}; -} - - -sub setAttribs -{ - my $self = shift; - my (%attribs) = @_; - $self->{ATTRIBS} = \%attribs; -} - - -sub getAttribs -{ - my $self = shift; - return unless (scalar(keys(%{$self->{ATTRIBS}})) > 0); - return %{$self->{ATTRIBS}}; -} - - -sub setValid -{ - my $self = shift; - my $valid = shift; - $self->{VALID} = $valid; -} - - -sub check -{ - my $self = shift; - return $self->{VALID}; -} - - -sub in_context -{ - my $self = shift; - my $in_context = shift; - - if (defined($in_context)) - { - $self->{INCONTEXT} = $in_context; - } - return $self->{INCONTEXT}; -} - - -sub display -{ - my $self = shift; - if (0) - { - print "VALUE: list(",join(",",@{$self->{LIST}}),")\n"; - } - else - { - print "VALUE: list(\n"; - foreach my $elem (@{$self->{LIST}}) - { - print "VALUE: ",$elem->GetXML(),"\n"; - } - print "VALUE: )\n"; - } - print "VALUE: values(",join(",",@{$self->{VALUES}}),")\n"; -} - -1; - diff --git a/lib/XXV/MODULES/CONFIG.pm b/lib/XXV/MODULES/CONFIG.pm index c2289dc..213cd6d 100644 --- a/lib/XXV/MODULES/CONFIG.pm +++ b/lib/XXV/MODULES/CONFIG.pm @@ -13,7 +13,7 @@ sub module { my $args = { Name => 'CONFIG', Prereq => { - # 'Perl::Module' => 'Description', + 'Module::Reload' => 'Reload %INC files when updated on disk ', }, Description => gettext('This module edits, writes and saves the configuration.'), Version => (split(/ /, '$Revision$'))[1], diff --git a/lib/XXV/MODULES/TELNET.pm b/lib/XXV/MODULES/TELNET.pm index 90fcfe1..7e8572c 100644 --- a/lib/XXV/MODULES/TELNET.pm +++ b/lib/XXV/MODULES/TELNET.pm @@ -15,7 +15,6 @@ sub module { Name => 'TELNET', Prereq => { 'IO::Socket::INET' => 'Object interface for AF_INET domain sockets ', - 'Module::Reload' => 'Reload %INC files when updated on disk ', }, Description => gettext('This module is a multisession telnet server.'), Version => (split(/ /, '$Revision$'))[1], @@ -196,7 +195,7 @@ sub init { ); # welcome - $client->print(sprintf(gettext("Welcome to xxv system version: %s.\r\nThis is session %s.\r\n"),$obj->{MOD}->{Version},$channel)); + $client->print(sprintf(gettext("Welcome to xxv system version: %s.\r\nThis is session %s.\r\n"),main::getVersion(),$channel)); my $userMod = main::getModule('USER'); unless(exists $console->{USER} or $userMod->{active} ne 'y') { diff --git a/lib/XXV/OUTPUT/Console.pm b/lib/XXV/OUTPUT/Console.pm index a450227..dca6ee5 100644 --- a/lib/XXV/OUTPUT/Console.pm +++ b/lib/XXV/OUTPUT/Console.pm @@ -4,13 +4,11 @@ BEGIN{ $ENV{PERL_RL} = 'Perl' }; -use Locale::gettext; -use Term::ReadLine; - use strict; +use Locale::gettext; +use Term::ReadLine; use Tools; -use Pod::Text; use vars qw($AUTOLOAD); # This module method must exist for XXV @@ -21,8 +19,9 @@ sub module { my $args = { Name => 'Telnet', Prereq => { - 'XML::Simple' => 'Easy API to maintain XML (esp config files)', + 'Pod::Text' => 'Convert POD data to formatted ASCII text ', 'Text::ASCIITable' => 'Create a nice formatted table using ASCII characters.', +# 'Term::ReadLine' => 'Perl interface to various readline packages.', 'Term::ReadLine::Perl' => 'a quick implementation of the minimal interface to Readline', }, Description => gettext('This receives and sends ASCII messages'), diff --git a/lib/XXV/OUTPUT/Html.pm b/lib/XXV/OUTPUT/Html.pm index fc7cdba..32b946c 100644 --- a/lib/XXV/OUTPUT/Html.pm +++ b/lib/XXV/OUTPUT/Html.pm @@ -2,16 +2,13 @@ package XXV::OUTPUT::Html; use strict; -#use Template; use vars qw($AUTOLOAD); use Locale::gettext; use Tools; use XXV::OUTPUT::HTML::WAIT; use File::Path; use File::Basename; -use Pod::Html; use Fcntl; -#use Thread; $SIG{CHLD} = 'IGNORE'; @@ -23,6 +20,9 @@ sub module { my $args = { Name => 'Html', Prereq => { + 'Pod::Html' => 'Module to convert pod files to HTML ', +# 'Template' => 'Front-end module to the Template Toolkit', +# 'Compress::Zlib' => 'Interface to zlib compression library', 'HTML::TextToHTML' => 'convert plain text file to HTML. ', }, Description => gettext('This receives and sends HTML messages.'), diff --git a/lib/XXV/OUTPUT/Wml.pm b/lib/XXV/OUTPUT/Wml.pm index 2e6e417..7349ab5 100644 --- a/lib/XXV/OUTPUT/Wml.pm +++ b/lib/XXV/OUTPUT/Wml.pm @@ -16,7 +16,7 @@ sub module { my $args = { Name => 'Wml', Prereq => { - 'Template' => 'Front-end module to the Template Toolkit ', + 'Template' => 'Front-end module to the Template Toolkit', }, Description => gettext('This receives and sends WAP messages.'), Version => (split(/ /, '$Revision$'))[1], |