Created
March 21, 2013 12:13
-
-
Save sawamur/5212601 to your computer and use it in GitHub Desktop.
10年以上まえに書いたperlのコードをひろったので
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| package Perltag; | |
| ##################################################################### | |
| #use strict 'subs'; | |
| use vars qw($tmpl $Perltagscript $Script $Package $error | |
| $default_kcode $default_TraceVars $ENCODING $MIMETYPE | |
| $glob @glob %glob $n $VERSION $seed $LANG $CONTENT_LENGTH); | |
| $MIMETYPE = 'text/html'; | |
| $ENCODING = 'Shift_JIS'; # or euc-jp/iso-2022-jp/iso-8859-1 etc.. | |
| #$LANG = 'ja'; # 'ja' activates japanese mode | |
| $LANG = 'en'; | |
| $default_TraceVars = 1; #to set 0 notrace | |
| $CONTENT_LENGTH = 1; # to set 0 if you don't want add content_length header | |
| ##################################################################### | |
| require 'jcode.pl' if $LANG eq 'ja'; | |
| ##################################################################### | |
| $VERSION = "2.94"; #last modified : 26 Mar 2002 | |
| *load = *new; | |
| sub is_japanese{ | |
| my $oj = shift; | |
| return 1 if $oj->{lang} eq 'ja' || $LANG eq 'ja'; | |
| } | |
| sub new{ | |
| my ($pkg,$file,$encoding,$attr) = @_; | |
| my $oj; | |
| local ($Package,$Script) = caller(); | |
| $oj->{encoding} = $encoding ? &kcode2encoding($encoding) : | |
| ( $default_kcode ? &kcode2encoding($default_kcode) : '' ); | |
| $oj->{TraceVars} = $attr->{TraceVars} ? $attr->{TraceVars} : $default_TraceVars; | |
| $oj->{RequireParam} = @{$attr->{RequireParam}} if $attr->{RequireParam}; | |
| $oj->{perl} = $pkg->tmpl2script("$file") or return; | |
| my $tmpl = _evalit ($oj->{perl}) or return; | |
| $tmpl =~s/<half>([^\000]+?)<\/half>/_halfkana($oj,$1)/eg; | |
| $oj->{page} = $tmpl; | |
| $oj->{symbols} = _tracevars(); | |
| $oj->{internal_encoding} = 'euc-jp' if is_japanese(); | |
| $oj->{content_length} = $CONTENT_LENGTH; | |
| bless $oj,$pkg; | |
| $oj; | |
| } | |
| sub _evalit{ | |
| local $Perltagscript = shift; | |
| local($tmpl); | |
| eval($Perltagscript); | |
| if($@){ _evalerror($Perltagscript); return;} | |
| $tmpl; | |
| } | |
| sub _evalerror{ | |
| $_ = shift; | |
| $error = qq(<h2>TEMPLATE ERROR</h2>\n<B>$@</B>\n<HR>\n__script__\n); | |
| $error .= join "", | |
| map{ $n++; $n = sprintf("%02d",$n); | |
| qq($n| $_\n);} split /\n/,$_; | |
| $error; | |
| } | |
| sub _tracevars{ | |
| my $ret; | |
| my %symb = _symbols(); | |
| $ret = qq(\n<!------ symbols ------\n you can use them in template\n); | |
| $ret .= qq( package $Package \n\n); | |
| foreach my $a (sort keys %symb){ | |
| $ret .= qq( $a $symb{$a} \n); | |
| } | |
| $ret .= qq(\n version $VERSION\n--------->\n\n); | |
| $ret; | |
| } | |
| sub _symbols{ | |
| my %symb; | |
| my ($a,$b); | |
| while(($a,$b) = each (%{"main::$Package::"})){ | |
| next unless $a =~/^[a-zA-Z]/; | |
| *glob = $b; | |
| if(defined $glob){ | |
| $symb{"\$$a "} = $glob if ref $glob; | |
| $symb{"\$$a "} = undef unless ref $glob; | |
| } elsif(defined @glob){ | |
| $symb{"\@$a"} = undef; | |
| } elsif(defined %glob){ | |
| next if $b =~/::$/; | |
| $symb{"%$a"} = undef; | |
| } else { | |
| # print "&$a 'what's this?\n"; | |
| } | |
| } | |
| %symb; | |
| } | |
| *mime_type = *mimetype; | |
| sub mimetype{ | |
| my $oj = shift; | |
| if(@_){ | |
| if( ref $oj ){ | |
| $oj->{mimetype} = shift; | |
| } else { | |
| $MIMETYPE = shift; | |
| } | |
| } | |
| $oj->{mimetype} ? $oj->{mimetype} : $MIMETYPE; | |
| } | |
| sub ssi_exec{ | |
| my $oj = shift; | |
| $oj->{page} =~s/<!--\#exec +cmd=\"(.+)\"-->/qx{$1}/eig; | |
| $oj; | |
| } | |
| sub ssi_include{ | |
| my $oj = shift; | |
| $oj->{page} =~s/<!--\#include +file=\"(.+)\"-->/_openfile($1) or "[$error]"/eig; | |
| $oj; | |
| } | |
| sub ssi{ | |
| my $oj = shift; | |
| $oj->ssi_include(); | |
| $oj->ssi_exec(); | |
| } | |
| sub browserout{ | |
| my $oj = shift; | |
| my @cookie = @_; | |
| my $encoding = $oj->{encoding} ? $oj->{encoding} : $default_kcode ? | |
| &kcode2encoding($default_kcode) : $ENCODING; | |
| return unless $oj->{page}; | |
| foreach (grep /=/,@cookie){ | |
| print "Set-Cookie: $_\n"; | |
| } | |
| print "Content-type: "; | |
| print $oj->{mimetype} ? $oj->{mimetype} : $MIMETYPE; | |
| print ";charset=$encoding\n"; | |
| if( $oj->is_japanese() ){ | |
| &jcode::convert(\$oj->{page}, | |
| encoding2kcode($encoding), | |
| encoding2kcode($oj->{internal_encoding})) | |
| unless $oj->{internal_encoding} =~ /$encoding/i; | |
| } | |
| $oj->{internal_encoding} = $encoding; | |
| my $add = length($oj->{symbols}) if $oj->{TraceVars}; | |
| print "Content-length: ",( length( $oj->{page}) + $add ),"\n" if $oj->{content_length}; | |
| print "\n"; | |
| print $oj->{page}; | |
| print $oj->{symbols} if $oj->{TraceVars}; | |
| 1; | |
| } | |
| *writefile = *fileout; | |
| sub fileout{ | |
| my $oj = shift; | |
| my @files = @_; | |
| my $ok = 0; | |
| my $encoding = $oj->{encoding} ? $oj->{encoding} : $default_kcode ? | |
| &kcode2encoding($default_kcode) : $ENCODING; | |
| if( $oj->is_japanese() ){ | |
| &jcode::convert(\$oj->{page}, | |
| &encoding2kcode($encoding), | |
| &encoding2kcode($oj->{internal_encoding})) | |
| unless $oj->{internal_encoding} =~ /$encoding/i; | |
| } | |
| $oj->{internal_encoding} = $encoding; | |
| foreach (@files){ | |
| open(FILE,">$_") or do { $oj->{error} = "write failed ($_): $!"; return; }; | |
| return if $oj->{error}; | |
| print FILE $oj->{page}; | |
| print FILE $oj->{symbols} if $oj->{TraceVars}; | |
| close(FILE); | |
| $ok ++; | |
| } | |
| $ok; | |
| } | |
| sub fetch{ | |
| my $oj = shift; | |
| my $ret; | |
| my $encoding = $oj->{encoding} ? $oj->{encoding} : $default_kcode ? | |
| &kcode2encoding($default_kcode) : $ENCODING; | |
| if( $oj->is_japanese() ){ | |
| &jcode::convert(\$oj->{page}, | |
| &encoding2kcode($encoding), | |
| &encoding2kcode($oj->{internal_encoding})) | |
| unless $oj->{internal_encoding} =~ /$encoding/i; | |
| } | |
| $oj->{internal_encoding} = $encoding; | |
| $ret = $oj->{page}; | |
| $ret .= $oj->{symbols} if $oj->{TraceVars}; | |
| $ret; | |
| } | |
| sub tracemode{ | |
| my $oj = shift; | |
| @_ ? $oj->{TraceVars} = shift : return $oj->{TraceVars}; | |
| } | |
| sub notrace{ | |
| my $oj = shift; | |
| unless(ref $oj){ | |
| $default_TraceVars = 0; | |
| return; | |
| } | |
| $oj->{TraceVars} = undef; | |
| } | |
| sub set_baseurl{ | |
| my $oj = shift; | |
| my $base = shift; | |
| my $target = shift; | |
| $oj->{page} =~s/<base href=(\"|\')[^>]+\1>//i; | |
| $target = $target ? qq(target="$target") : undef; | |
| my $i = $oj->{page} =~s/<html>/<html><base href="$base" $target>/i; | |
| unless( $i){ | |
| $oj->{page} = qq(<base href="$base" $target>).$oj->{page}; | |
| } | |
| } | |
| *addp = *add_param; | |
| sub add_param{ | |
| my $oj = shift; | |
| my %param = @_; | |
| foreach (keys %param){ | |
| $oj->{page} =~s/<form([^>]+)>/_do_add_param($1,$_,$param{$_})/eig; | |
| } | |
| 1; | |
| } | |
| sub _do_add_param{ | |
| my ($form,$key,$val) = @_; | |
| $form =~s/^ +//; | |
| unless(ref $val){ | |
| return qq(<form $form>\n<input type="hidden" name="$key" value="$val">); | |
| } else { | |
| my $fname = $2 if $form =~/name=(\"|\')(\w+)\1/i; | |
| $key = '' if $key eq '-'; | |
| if($fname eq $key){ | |
| return join "\n",qq(<form $form>\n), | |
| map { qq(<input type="hidden" name="$_" value="$val->{$_}">); } | |
| keys %$val; | |
| } | |
| } | |
| qq(<form $form>); | |
| } | |
| *requirep = *require_param; | |
| sub require_param{ | |
| my $oj = shift; | |
| my @fields = @_; | |
| my @inpage = $oj->paramname(); | |
| my $f; | |
| my @nof; | |
| $oj->{RequireParam} = @fields; | |
| foreach $f (@fields){ | |
| my $ok = undef; | |
| map { $ok = 1 if $_ eq $f} @inpage; | |
| next if $ok; | |
| push @nof,$f; | |
| } | |
| if(@nof){ | |
| $oj->{error} = join "\n",map {qq(required param [$_]is missing.);} @nof; | |
| return; | |
| } | |
| 1; | |
| } | |
| sub paramname{ | |
| my $oj = shift; | |
| my @fs; | |
| $_ = $oj->{page}; | |
| my $tmp; | |
| foreach $tmp(/<(input|select|textarea) ([^>]+)>/i){ | |
| push @fs,$1 if $tmp =~/name="(.+?)"/i; | |
| push @fs,$1 if $tmp =~/name='(.+?)'/i; | |
| } | |
| @fs; | |
| } | |
| sub error{ | |
| my $oj = shift; | |
| return $oj->{error} ? $oj->{error} : $error; | |
| } | |
| sub errout{ | |
| my $oj = shift; | |
| print "Content-type: text/html;charset=euc-jp\n\n"; | |
| my $err = $oj->error(); | |
| my $msg; | |
| ($msg,$_) = split/__script__+/,$err; | |
| do{ s/>/>/g; s/</</g; s/( |\t)/ /g; | |
| s/\n/<BR>\n/g; | |
| } if $ENV{HTTP_USER_AGENT}; | |
| print $msg; | |
| print; | |
| exit 0; | |
| } | |
| sub no_content_length{ | |
| my $oj = shift; | |
| if( ref $oj){ | |
| $oj->{content_length} = 0; | |
| } else { | |
| $CONTENT_LENGTH = 0; | |
| } | |
| } | |
| sub lang{ | |
| my $oj = shift; | |
| if(@_){ | |
| if(ref $oj){ | |
| $oj->{lang} = shift; | |
| } else { | |
| $LANG = shift; | |
| } | |
| } | |
| $oj->{lang} ? $oj->{lang} : $LANG; | |
| } | |
| sub encoding{ | |
| my $oj = shift; | |
| if(ref $oj){ | |
| $oj->{encoding} = shift if @_; | |
| } else { | |
| $ENCODING = shift if @_; | |
| } | |
| return $oj->{encoding} || $ENCODING; | |
| } | |
| sub kcode{ | |
| my $oj = shift; | |
| if(@_){ | |
| $oj->encoding( &kcode2encoding( @_ ) ); | |
| } | |
| &encoding2kcode($oj->{encoding} || $ENCODING); | |
| } | |
| sub euc{ my $oj = shift; $oj->kcode('euc'); $oj; } | |
| sub sjis{ my $oj = shift; $oj->kcode('sjis'); $oj;} | |
| sub jis{ my $oj = shift; $oj->kcode('jis'); $oj;} | |
| sub tmpl2script{ | |
| my $pkg = shift; | |
| my $file = shift; | |
| local $seed = int rand 10000; | |
| my $tmpl = _openfile($file) or return; | |
| $tmpl =~s/<\?include\s+src=\s*(\"|\')([\w.\/\$@\:{}-]+)\1(?:\s+onCondition=(\"|\')(.+?)\3)*\s*>/_openfile( eval qq{package $Package; "$2";},$4) or "[$error]"/ieg; | |
| $tmpl =~s/@/\\@/g; | |
| $tmpl =~s/<perl:\{(.+)\}>/_inline($1)/eg; | |
| $tmpl =~s/<perl:([^>]+)>/_inline($1)/eg; | |
| $tmpl =~s/<\/perl:([^>]+)>/<perl> } <\/perl>/g; | |
| $tmpl =~s/<perl>([^\000]+?)<\/perl>/_scriptize($1)/eg; | |
| return qq(package $Package;\n\$Perltag::tmpl =<<__ENDOFPERLTAG${seed}__;\n$tmpl\n__ENDOFPERLTAG${seed}__\n); | |
| } | |
| sub _openfile{ | |
| my $file = shift; | |
| my $condition = shift; | |
| my $go; | |
| if($condition){ | |
| return ' ' unless eval qq{ package $Package; 1 if ($condition); }; | |
| } | |
| open(TMPL,"$file") or | |
| do {$error = "cannot open template! ($file)"; | |
| $error = "'$file' is not exists" unless -f $file; | |
| return; }; | |
| while(<TMPL>){ $go .= $_; } | |
| close(TMPL); | |
| &jcode::convert(\$go,'euc') if &is_japanese; | |
| $go =~s/\r\n/\n/g; | |
| $go =~s/\r/\n/g; | |
| $go; | |
| } | |
| sub _inline{ | |
| my $in = shift; | |
| if($in =~/^=\w+/){ | |
| return qq(<perl>\n$in\n</perl>); | |
| } | |
| $in =~s/</</g; | |
| $in =~s/>/>/g; | |
| $in .= '{' unless $in=~s/\/$/;/; | |
| qq(<perl>$in\n</perl>); | |
| } | |
| sub _scriptize{ | |
| my $script = shift; | |
| my $begin = qq(\n__ENDOFPERLTAG${seed}__\n chomp \$Perltag::tmpl; \n); | |
| my $end = qq(\n\$Perltag::tmpl .=<<__ENDOFPERLTAG${seed}__;\n); | |
| $script =~s/\bPerltag::_print\b/\\Perltag::_print/g; | |
| $script =~s/([^\w\$@%\\])print\b/$1Perltag::_print/g; | |
| $script =~s/\\@/\@/g; | |
| return qq($begin $script $end); | |
| } | |
| sub _print{ #this function replace print at template | |
| my $tmp = join '',@_; | |
| $tmp =~s/([^\\])Perltag::_print/$1print/g; | |
| $tmp =~s/\\Perltag::_print/Perltag::print/g; | |
| $Perltag::tmpl .= $tmp; | |
| } | |
| sub concat{ | |
| my $oj = shift; | |
| my @con = @_; | |
| foreach my $con (@con){ | |
| if((ref $con) eq (ref $oj)){ | |
| if( $oj->{internal_encoding} ne $con->{internal_encoding} ){ | |
| &jcode::convert(\$con->{page}, | |
| encoding2kcode($oj->{internal_encoding}), | |
| encoding2kcode($con->{internal_encoding})); | |
| } | |
| $oj->{page} .= $con->{page}; | |
| } else { | |
| &jcode::convert(\$cont,'euc') if $LANG eq 'ja'; | |
| $oj->{page} .= $con; | |
| } | |
| } | |
| 1; | |
| } | |
| my %k2e_table = ( sjis => 'Shift_JIS', | |
| euc => 'euc-jp', | |
| jis => 'iso-2022-jp'); | |
| my %e2k_table = ( 'Shift_JIS' => 'sjis', | |
| 'euc-jp' => 'euc', | |
| 'iso-2022-jp' => 'jis' ); | |
| sub kcode2encoding{ | |
| my $k = shift; | |
| return $k2e_table{$k} ? $k2e_table{$k} : $k; | |
| } | |
| sub encoding2kcode{ | |
| my $k = shift; | |
| foreach (keys %e2k_table){ | |
| return $e2k_table{$_} if /$k/i; | |
| } | |
| } | |
| sub affect{ | |
| my $oj = shift; | |
| my $sub = shift; | |
| $oj->{page} = &$sub($oj->{page}); | |
| } | |
| sub _halfkana{ | |
| my $oj = shift; | |
| my $in = shift; | |
| &jcode::z2h_euc(\$in); | |
| $in; | |
| } | |
| sub z2h{ | |
| my $oj = shift; | |
| &jcode::z2h_euc(\$oj->{page}); | |
| $oj; | |
| } | |
| 1; | |
| __END__ | |
| ############################################################################ | |
| =head1 NAME | |
| Perltag -- loading html template which have perl code | |
| =head1 SYNOPSIS | |
| use Perltag; | |
| my $page = Perltag->load("template.html") | |
| or Perltag->errout(); | |
| $page->browserout(); | |
| $page->fileout("/bar/foo/out.html"); | |
| =head1 DESCRIPTION | |
| This module aimed to sepalate cgi script into logical and presentation | |
| section.Template can have any perl variables and codes. | |
| =head1 EXAMPLES | |
| I would show you typical example.Theory is ; | |
| Programer write logic and prepare all variables template need. | |
| Then designer layout them and do some compution. | |
| convention of variable should have been fixed before start coding. | |
| =head2 SCRIPT | |
| #!/usr/bin/perl | |
| use Perltag; | |
| $name = 'john'; | |
| $age = 17; | |
| $family = { dad => { name => 'geroge', | |
| born => 1950, | |
| job => 'painter' }, | |
| mon => { name => 'linda', | |
| born => 1949} | |
| }; | |
| @dogs = qw(boo goo laa ree); | |
| $sample = Perltag->load("sample.tmpl") or Perltag->errout(); | |
| $sample->browserout(); | |
| =head2 TEMPLATE | |
| <html> | |
| <head><title>Welcome to $name 's homepage</title> | |
| <body bgcolor=white> | |
| <h1>my name is $name</h1> | |
| <p> | |
| i am $age years old | |
| </p> | |
| let me introduce my parent. | |
| my father's name is $fammily->{dad}{name} | |
| he is <perl> | |
| my($sec,$min,$hr,$day,$yr) = localtime(time); | |
| $yr = 1900 + $yr; | |
| $age_of_dad = $yr - $family->{dad}{born}; | |
| print $age_of_dad; | |
| </perl> years old. | |
| my mother's name is $family->{mom}{name}. | |
| i have dogs | |
| <perl> | |
| foreach (@dogs){ | |
| print "<LI>$_"; | |
| } | |
| </perl> | |
| I love them all | |
| </body></html> | |
| =cut | |
| =head1 CONFIGURATION | |
| modify these variable placed top of Perltag.pm | |
| $LANG = 'ja'; | |
| language default is 'japanese'.you can set 'en' etc.If you set japanese, | |
| you can use japanese sepecific feature (see section below ) with famous | |
| 'jcode.pl' libraly. | |
| $ENCODING = 'Shift_JIS'; | |
| Encoding setting.Default is 'Shift_JIS'.You can set 'euc-jp','iso-2022-jp' | |
| or 'iso-8859-1'. (NOTE that previos version of this module has $default_kcode | |
| variable defining output encoding.That have disapered.Some backward compatibility | |
| is implemented ) | |
| $default_TraceVars = 1; | |
| You can set 0 if you don't want to see variable tracing attached to output. | |
| =head1 METHODS | |
| This module have object-oriented style. | |
| There might be pecurior part,since i am a newbee though. | |
| =over 4 | |
| =cut | |
| =head2 CONSTRACTOR | |
| =item $page = Perltag->load('template'[,kcode[,\%attr]]); | |
| loading template and evaluate it.return object. | |
| Second augument defines kanji-code (euc/sjis/jis) optionally. | |
| Default is sjis (you can change default by editing this .pm file). | |
| Third would be attributes. | |
| =cut | |
| =head2 METHODS | |
| =item $page->browserout([@cookies]); | |
| Print out proccessed page for browser. | |
| For browser print http-header and body. | |
| Optionaly you can set cookies.like this | |
| $page->browserout('foo=bar','faa=hee;path=/;expire=sat-12-12-2001 GMT;'); | |
| Notice:I don't know how to write expire value on cookie.This | |
| example said you must have fixed cookie string before pass to method. | |
| Maybe famous CGI module will help you. | |
| Notice:This module show you which variables you can use in template.See html | |
| source of generated page.(To restrain this do notirace() method). | |
| =item $page->fileout('outfile',[,'outfile2',,]); | |
| write to one or more files.return how many files was made. | |
| =item $page->fetch(); | |
| return the page to print out.The code below behave most like browserout() method. | |
| print "Content-type:text/html\n\n",$page->fetch(); | |
| =item $page->errout(); | |
| print out error message to STDOUT. | |
| That is becouse this method aimed to display syntax error | |
| in template file on browser. | |
| Print out error message with HTTP-header to STDOUT. | |
| This method also can be used as class-method, | |
| so recommeded way to invoke constractor is | |
| $page = Perltag->load("template") or Perltag->errout(); | |
| if you want to print out to STDERR use error() below. | |
| =item $page->error(); | |
| return error message.not print. | |
| $page->fileout('/foo/bar.html') or die $page->error(); | |
| =item $page->reqiure_param(@parametaer_name); | |
| if template have specified parameters,return true. | |
| To check template have correct form. | |
| $page->reqire_param('name','email','id') or $page->errout(); | |
| reqiurep() is the alias | |
| =item $page->add_param(%hash); | |
| add hidden parameter. | |
| $page->add_param('ctl' => 'register','bar' => 'foo') | |
| add fields in the page to be printed | |
| <input type="hidden" name="ctl" value="register"> | |
| <input type="hidden" name="bar" value="foo"> | |
| this method returnes true if scceed | |
| addp() is the alias | |
| If you have two or more forms in the template, | |
| you would want to add hidden parameter respectively, | |
| Do like this. | |
| $page->add_param( FORMNAME => \%hiddenparam, | |
| MOREFORM => \%moreparam ); | |
| Passing hash has keys of form name and | |
| values of hash-ref of hiddenparam. | |
| i think,require_param() and add_param() would be useful | |
| when diffelent person write script and template. | |
| =item $page->notrace(); | |
| Eliminate trace variable. | |
| =item $page->ssi_exec(); | |
| emulate server-side-include exec tag. | |
| =item $page->ssi_include(); | |
| emulate server-side-include include tag. | |
| =item $page->ssi(); | |
| do both ssi_exec() and ssi_include() | |
| =item $page->set_baseurl('http://www.anywhere.dom/bar/foo/'[,target]); | |
| set baseURL of relative anchor.Just adding (or overriding) <base href="">. | |
| optionally target window can be defined. | |
| =item $page->mimetype( mime_type ); | |
| set mimetype ('text/html' is default),if you need.Maybe, $page->mimetype('text/x-hdml'); | |
| =item $page->affect( \&subroutin ); | |
| *NEW* | |
| You can pass your subroution to affect on page.Passing subroutin must be | |
| written in | |
| $after = mysub( $before ); | |
| format. | |
| For exsample,if you want to replace all \n to <br>,prepare | |
| sub nl2brtag{ | |
| my $t = shift; | |
| $t =~ s/\n/<br>/g; | |
| return $t; | |
| } | |
| and affect on page | |
| $page->affect( \&nl2brtag ); | |
| Off cause,you can write that another way | |
| $page->affect( sub { $_ = shift; s/\n/<br>/g; $_; } ); | |
| =item $page->no_content_length(); | |
| *NEW* | |
| Do not add Content-Length header when browserout(). | |
| After ver2.91,content-length header is automaticaly attached. | |
| There might be problem,if you did print after browserout. | |
| Invoking from class,no content-length will be attached | |
| on every browser out in the script | |
| Perltag->no_content_length(); | |
| =item $page->concat( $another_page [,$more,'string'] ); | |
| concat two or more Perltag object or string. | |
| for example | |
| $one = Perltag->load("first.tmpl"); | |
| $two = Perltag->load("next.tmpl"); | |
| $three = Perltag->load("third.tmpl"); | |
| $one->concat( $two , $three ); | |
| $one->browserout(); | |
| or you can add plain string like copy right | |
| $page->concat('(c) your name 2002'); | |
| =head2 CLASS METHODS | |
| =item Perltag->tmpl2script(templatefile) | |
| this method returns script which is made from template. | |
| =item Perltag->notrace | |
| restrain trace for entire procedure after this. | |
| =cut | |
| =back | |
| =cut | |
| =head1 HOW TO WRITE TEMPLATE | |
| Template is template that is your favarite html file. | |
| you can write any variable in template | |
| <HTML> | |
| <HEAD> | |
| <TITLE>$title</TITLE> | |
| </HEAD> | |
| <BODY BGCOLOR=$color> | |
| <H1> $title </h1> | |
| $text | |
| <A HREF="mailto:$email"> $email </a> | |
| </BODY> | |
| </HTML> | |
| off cause you can use any hash,reference in template | |
| if you have hash-referennce like this (in script maybe), | |
| $color = { bg => '#ffffff', | |
| text => '#000000', | |
| link => '#0000ff' }; | |
| now you can write BODY tag as follows | |
| <BODY BGCOLOR="$color->{bg}" TEXT="$color->{text}" LINK="$color->{link}"> | |
| there are not this module matter.Guinue Perl matter. | |
| You can write perl code between <perl> and </perl>. | |
| to print out use print function. | |
| <html> | |
| today is | |
| <perl> | |
| ($sec,$min,$hr,$day,$mon,$year) = localtime(time); | |
| print sprintf("%04d-%02d-%02d",$year,$mon,$day); | |
| </perl> | |
| </html> | |
| NOTICE: read MISC section below. | |
| If you want including other file,use ?include tag | |
| <?include src="/home/somewhere/include.tmpl"> | |
| File would be included BEFORE evaluation. | |
| Path should be full path (not url). | |
| If you want to use relative path, | |
| remember current directory is | |
| the directory main script is (not parent template). | |
| addtinally you can define when it would be include by onCondition argument. | |
| <?include src="/foo/bar.tmpl" onCondition="$foo < 20"> | |
| Note that variable in onCondition argument must be defined in script | |
| not in template since the file would be included BEFORE evaluation. | |
| =head1 JAPANESE SPECIFIC FEATURE | |
| you can write template EUC or SJIS and | |
| newline could be LF,CR and CRLF. | |
| But do NOT use any halfsize katakana. | |
| halfsize katakana will cause | |
| misrecognision of charactor code. | |
| If you want to diplay half-kana | |
| as result (maybe for i-mode or so), | |
| please write fullsize(2byte) kana in <half></half> tag. | |
| This module will transform them | |
| when evaluate code. | |
| =head1 INLINE STYLE | |
| NOTICE:THIS IS *EXPERIMENTAL*. | |
| If you want,you can write perl loop in tag. | |
| <perl:foreach $bar (@foo)> | |
| loop this text. | |
| html mode | |
| </perl:foreach> | |
| tag element (i.e < and > ) cold not be | |
| written in tag.escape < and > | |
| or brase like | |
| <perl:{for($i = 0;$i < 20;$i++)}> | |
| looop loop loop <perl> print $i; </perl> | |
| </perl:for> | |
| text between these inline perltag are just html | |
| not perl.so you can wrete <perl></perl> tag in loop. | |
| ..but I am so anxicias about confusion.Simple <perl> philosoly | |
| might be destroid by this. | |
| B<COMMENTOUT> | |
| you can comment out pod style. | |
| <perl:=comemntout> | |
| this area are totally ommited | |
| <perl:=cut> | |
| that's what you benefits | |
| =head1 NOTICE | |
| =head2 VARIABLES / PACKAGE | |
| Template would be evaluate as the package caller belongs (usualy main package). | |
| To refer variables in another package you can do $Bar::foo. | |
| You cannot refer lexical variable (my $foo) in template though. | |
| To localize variable you want to pass to template | |
| use "local $foo;" instead. (so you must use vars if you use strict). | |
| As you guess just '$' must be written \$. | |
| =head2 MISC | |
| To print '$_' you cannot omitt $_.Do | |
| print $_; | |
| Because print function is replaced by Perltag::_print | |
| sub-roution. | |
| =head1 PROBLEMS | |
| Fist of all,module name itself.I want to name more adequate kind.How do you think? | |
| =head1 HISTORY | |
| 1.4 (15 Feb 2001) add <?include> tag and jis() method | |
| 1.41 (16 Feb 2001) fix bug | |
| 1.5 (19 Feb 2001) Template blongs the package where the script belongs | |
| 1.51 (19 Feb 2001) fix symbol tracing | |
| 1.52 (19 Feb 2001) fix little more.. | |
| 1.55 (15 Mar 2001) fix mojibake after repeateing out-kind methods | |
| 1.6 (9 Apr 2001) add class method notrace.restrain trace for entire procedure | |
| 1.61 (8 May 2001) fix bug | |
| 1.7 (25 May 2001) updating add_param() method for multiple forms | |
| 1.8 (29 May 2001) add methods ssi_exec(),ssi_include() and ssi() | |
| 2.0 (7 Jun 2001) inline style support | |
| 2.1 (14 Jun 2001) add method set_baseurl() | |
| 2.50 (24 Jul 2001) change "print" procession | |
| 2.7 (1 Nov 2001) pod sytle commnetout | |
| 2.9 (22 Jan 2002) change encoding scheme,add affect method | |
| 2.91 (18 Feb 2002) add Content-Length header | |
| 2.92 (18 Feb 2002) bug-fixed of 2.91, add no_content_length method | |
| 2.93 (19 Feb 2002) bug-fixed of 2.92, add concat method | |
| 2.94 (26 Mar 2002) bug-fixed of 2.93, fix bug of object concat | |
| =head1 ACKONOWLEDGEMENTS | |
| walkerplus.com,Trabox team. | |
| =head1 COPYRIGHT | |
| Masaki SAWAMURA <sawamur@iTheremin.org> 2001 | |
| This module is free software ; you can redistribute it and/or | |
| modify it under the same terms as Perl itself. | |
| =cut | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment