./PaxHeaders.14966/Embperl-2.5.00000644000000000000000000000005012323454054014173 xustar000000000000000020 atime=1397643307 20 ctime=1397643308 Embperl-2.5.0/0000755000000000000000000000000012323454054013104 5ustar00rootroot00000000000000Embperl-2.5.0/PaxHeaders.14966/epcfg.h0000644000000000000000000000005012023276645015355 xustar000000000000000020 atime=1397643257 20 ctime=1397643307 Embperl-2.5.0/epcfg.h0000644000076400000000000001007412023276645015046 0ustar00richterroot00000000000000#undef SEPARATOR #ifdef WIN32 #define SEPARATOR ";" #else #define SEPARATOR ":;" #endif #ifdef EPCFG_COMPONENT /* tComponentConfig */ EPCFG_STR (ComponentConfig, char *, sPackage, PACKAGE) EPCFG_INTOPT (ComponentConfig, unsigned, bDebug, DEBUG) EPCFG_INTOPT (ComponentConfig, unsigned, bOptions, OPTIONS) EPCFG_INTOPT (ComponentConfig, int , nEscMode, ESCMODE) EPCFG_INTOPT (ComponentConfig, int , nInputEscMode, INPUT_ESCMODE) EPCFG_STR (ComponentConfig, char *, sInputCharset, INPUT_CHARSET) EPCFG_STR (ComponentConfig, char *, sCacheKey, CACHE_KEY) EPCFG_INT (ComponentConfig, unsigned, bCacheKeyOptions, CACHE_KEY_OPTIONS) EPCFG_CV (ComponentConfig, CV * , pExpiredFunc, EXPIRES_FUNC) EPCFG_CV (ComponentConfig, CV * , pCacheKeyFunc, CACHE_KEY_FUNC) EPCFG_INT (ComponentConfig, int , nExpiresIn, EXPIRES_IN) EPCFG_STR (ComponentConfig, char *, sExpiresFilename, EXPIRES_FILENAME) EPCFG_STR (ComponentConfig, char *, sSyntax, SYNTAX) EPCFG_SV (ComponentConfig, SV *, pRecipe, RECIPE) EPCFG_STR (ComponentConfig, char *, sXsltstylesheet, XSLTSTYLESHEET) EPCFG_STR (ComponentConfig, char *, sXsltproc, XSLTPROC) EPCFG_STR (ComponentConfig, char *, sCompartment, COMPARTMENT) EPCFG_STR (ComponentConfig, char *, sTopInclude, TOP_INCLUDE) #endif #ifdef EPCFG_REQ /* tReqConfig */ EPCFG_REGEX(ReqConfig, CV *, pAllow, ALLOW) EPCFG_REGEX(ReqConfig, CV *, pUriMatch, URIMATCH) EPCFG_CHAR(ReqConfig, char , cMultFieldSep, MULTFIELDSEP ) EPCFG_AV (ReqConfig, AV *, pPathAV, PATH, SEPARATOR) EPCFG_INTOPT (ReqConfig, unsigned, bDebug, DEBUG) EPCFG_INTOPT (ReqConfig, unsigned, bOptions, OPTIONS) EPCFG_INTOPT (ReqConfig, int , nSessionMode, SESSION_MODE) EPCFG_INTOPT (ReqConfig, int , nOutputMode, OUTPUT_MODE) EPCFG_INTOPT (ReqConfig, int , nOutputEscCharset, OUTPUT_ESC_CHARSET) #endif #ifdef EPCFG_APP /* tAppConfig */ EPCFG_STR(AppConfig, char *, sAppName, APPNAME) EPCFG_STR(AppConfig, char *, sAppHandlerClass, APP_HANDLER_CLASS) EPCFG_STR(AppConfig, char *, sSessionHandlerClass, SESSION_HANDLER_CLASS) EPCFG_HV (AppConfig, HV *, pSessionArgs, SESSION_ARGS) EPCFG_AV (AppConfig, AV *, pSessionClasses, SESSION_CLASSES, " ,") EPCFG_STR(AppConfig, char *, sSessionConfig, SESSION_CONFIG) EPCFG_STR(AppConfig, char *, sCookieName, COOKIE_NAME) EPCFG_STR(AppConfig, char *, sCookieDomain, COOKIE_DOMAIN) EPCFG_STR(AppConfig, char *, sCookiePath, COOKIE_PATH) EPCFG_EXPIRES(AppConfig, char *, sCookieExpires, COOKIE_EXPIRES) EPCFG_BOOL(AppConfig, bool, bCookieSecure, COOKIE_SECURE) EPCFG_STR(AppConfig, char *, sLog, LOG) EPCFG_INTOPT(AppConfig, unsigned,bDebug, DEBUG) EPCFG_BOOL(AppConfig, bool, bMaildebug, MAILDEBUG) EPCFG_STR(AppConfig, char *, sMailhost, MAILHOST) EPCFG_STR(AppConfig, char *, sMailhelo, MAILHELO) EPCFG_STR(AppConfig, char *, sMailfrom, MAILFROM) EPCFG_STR(AppConfig, char *, sMailErrorsTo, MAIL_ERRORS_TO) EPCFG_INT(AppConfig, int, nMailErrorsLimit, MAIL_ERRORS_LIMIT) EPCFG_INT(AppConfig, int, nMailErrorsResetTime, MAIL_ERRORS_RESET_TIME) EPCFG_INT(AppConfig, int, nMailErrorsResendTime, MAIL_ERRORS_RESEND_TIME) EPCFG_STR(AppConfig, char *, sObjectBase, OBJECT_BASE) EPCFG_STR(AppConfig, char *, sObjectApp, OBJECT_APP) EPCFG_AV (AppConfig, AV *, pObjectAddpathAV, OBJECT_ADDPATH, SEPARATOR) EPCFG_AV (AppConfig, AV *, pObjectReqpathAV, OBJECT_REQPATH, SEPARATOR) EPCFG_STR(AppConfig, char *, sObjectStopdir, OBJECT_STOPDIR) EPCFG_STR(AppConfig, char *, sObjectFallback, OBJECT_FALLBACK) EPCFG_STR(AppConfig, char *, sObjectHandlerClass, OBJECT_HANDLER_CLASS) #endif Embperl-2.5.0/PaxHeaders.14966/epmain.c0000644000000000000000000000005012311327004015517 xustar000000000000000020 atime=1397643253 20 ctime=1397643307 Embperl-2.5.0/epmain.c0000644000000000000000000015270112311327004014516 0ustar00rootroot00000000000000/*################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # For use with Apache httpd and mod_perl, see also Apache copyright. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: epmain.c 1578075 2014-03-16 14:01:14Z richter $ # ###################################################################################*/ #include "ep.h" #include "epmacro.h" /*--------------------------------------------------------------------------- * DoLogError */ /*! * * \_en * Logs the occurence of an error to the embperl logfile and the httpd error log * * @param r the request object (maybe NULL) * @param a the application object (maybe NULL) * @param rc the error code * @param errdat1 addtional information * @param errdat2 addtional information * \endif * * \_de * logged das auftreten eines Fehler in das Embperl Logfile und den httpd * error log * * @param r das Requestobjekt (kann NULL sein) * @param a das Applikationobjekt (kann NULL sein) * @param rc Fehlercode * @param errdat1 Zusätzliche Informationen * @param errdat2 Zusätzliche Informationen * \endif * * ------------------------------------------------------------------------ */ static char * DoLogError (/*i/o*/ struct tReq * r, /*i/o*/ struct tApp * a, /*in*/ int rc, /*in*/ const char * errdat1, /*in*/ const char * errdat2) { const char * msg ; char * sText ; SV * pSV ; SV * pSVLine = NULL ; STRLEN l ; pid_t nPid ; #ifdef PERL_IMPLICIT_CONTEXT pTHX ; if (r) aTHX = r -> pPerlTHX ; else if (a) aTHX = a -> pPerlTHX ; else aTHX = PERL_GET_THX ; #endif if (r) { r -> errdat1 [sizeof (r -> errdat1) - 1] = '\0' ; r -> errdat2 [sizeof (r -> errdat2) - 1] = '\0' ; GetLineNo (r) ; errdat1 = r -> errdat1 ; errdat2 = r -> errdat2 ; if (rc != rcPerlWarn) r -> bError = 1 ; nPid = r -> pThread -> nPid ; a = r -> pApp ; } else if (a) { nPid = a -> pThread -> nPid ; } else nPid = getpid() ; if (!errdat1) errdat1 = "" ; if (!errdat2) errdat2 = "" ; switch (rc) { case ok: msg ="[%d]ERR: %d: %s ok%s%s" ; break ; case rcStackOverflow: msg ="[%d]ERR: %d: %s Stack Overflow%s%s" ; break ; case rcArgStackOverflow: msg ="[%d]ERR: %d: %s Argumnet Stack Overflow (%s)%s" ; break ; case rcStackUnderflow: msg ="[%d]ERR: %d: %s Stack Underflow%s%s" ; break ; case rcEndifWithoutIf: msg ="[%d]ERR: %d: %s endif without if%s%s" ; break ; case rcElseWithoutIf: msg ="[%d]ERR: %d: %s else without if%s%s" ; break ; case rcEndwhileWithoutWhile: msg ="[%d]ERR: %d: %s endwhile without while%s%s" ; break ; case rcEndtableWithoutTable: msg ="[%d]ERR: %d: %s blockend <%s> does not match blockstart <%s>" ; break ; case rcTablerowOutsideOfTable: msg ="[%d]ERR: %d: %s outside of table%s%s" ; break ; case rcCmdNotFound: msg ="[%d]ERR: %d: %s Unknown Command %s%s" ; break ; case rcOutOfMemory: msg ="[%d]ERR: %d: %s Out of memory %s %s" ; break ; case rcPerlVarError: msg ="[%d]ERR: %d: %s Perl variable error %s%s" ; break ; case rcHashError: msg ="[%d]ERR: %d: %s Perl hash error, %%%s does not exist%s" ; break ; case rcArrayError: msg ="[%d]ERR: %d: %s Perl array error , @%s does not exist%s" ; break ; case rcFileOpenErr: msg ="[%d]ERR: %d: %s File %s open error: %s" ; break ; case rcLogFileOpenErr: msg ="[%d]ERR: %d: %s Logfile %s open error: %s" ; break ; case rcMissingRight: msg ="[%d]ERR: %d: %s Missing right %s%s" ; break ; case rcNoRetFifo: msg ="[%d]ERR: %d: %s No Return Fifo%s%s" ; break ; case rcMagicError: msg ="[%d]ERR: %d: %s Perl Magic Error%s%s" ; break ; case rcWriteErr: msg ="[%d]ERR: %d: %s File write Error%s%s" ; break ; case rcUnknownNameSpace: msg ="[%d]ERR: %d: %s Namespace %s unknown%s" ; break ; case rcInputNotSupported: msg ="[%d]ERR: %d: %s Input not supported in mod_perl mode%s%s" ; break ; case rcCannotUsedRecursive: msg ="[%d]ERR: %d: %s Cannot be called recursivly in mod_perl mode%s%s" ; break ; case rcEndtableWithoutTablerow: msg ="[%d]ERR: %d: %s without %s%s" ; break ; case rcEndtextareaWithoutTextarea: msg ="[%d]ERR: %d: %s without The C [* return $ctrlid ; *] [$endsub$] [# --------------------------------------------------------------------------- # # show_control_readonly - output the control as readonly #] [$ sub show_control_readonly ($self, $req, $value, $class) $] [- $value //= $fdat{$self -> {name}} ; $value =~ s/\s*$// ; $value =~ s/^\s*// ; @value = split (/\n/, $value) ; $i = 0 ; -][$ foreach my $val (@value) $] [$ if $val =~ /^\s*$/ $]
[$else$] [- $self -> SUPER::show_control_readonly ($req, $val, $class) -][# $ if ($i < @value - 1) $]
[$endif$ #] [$endif$] [$endforeach$] [$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::textarea - A textarea input control inside an Embperl Form =head1 SYNOPSIS { type => 'textarea', text => 'blabla', name => 'foo', id => 'id_foo', rows => 10, cols => 80, } =head1 DESCRIPTION Used to create an input control inside an Embperl Form. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be 'textarea' =head3 text Will be used as label for the text input control =head3 name Will be used as field name for the text input control =head3 name Will be used as id of the text input control =head3 cols Number of columns =head3 rows Number of rows =head1 Author G. Richter (richter at embperl dot org) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/input.pm0000644000000000000000000000005012311326120021506 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/input.pm0000755000076400000000000000413212311326120021200 0ustar00richterroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::input ; use strict ; use base 'Embperl::Form::Control' ; use Embperl::Inline ; 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show_control - output the control #] [$ sub show_control ($self, $req) #$self -> {size} ||= 80 / ($self -> {width} || 2) ; my $class = $self -> {class} ; $] get_std_control_attr($req) } +] [$if $self -> {size} $]size="[+ $self->{size} +]"[$endif$] [$if $self -> {maxlength} $]maxlength="[+ $self->{maxlength} +]"[$endif$] > [$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::input - A text input control inside an Embperl Form =head1 SYNOPSIS { type => 'input', text => 'blabla', name => 'foo', size => 10, maxlength => 50, } =head1 DESCRIPTION Used to create an input control inside an Embperl Form. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be 'input' =head3 name Specifies the name of the control =head3 text Will be used as label for the text input control =head3 size Gives the size in characters =head3 maxlength Gives the maximum possible input length in characters =head3 class Alternative CSS class name =head1 Author G. Richter (richter at embperl dot org) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/number.pm0000644000000000000000000000005012311326120021637 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/number.pm0000755000000000000000000000660412311326120020641 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::number ; use strict ; use base 'Embperl::Form::Control::input' ; use Embperl::Inline ; # ------------------------------------------------------------------------------------------ sub get_std_control_attr { my ($self, $req, $id, $type, $addclass) = @_ ; return $self -> SUPER::get_std_control_attr ($req, $id, $type, $type eq 'readonly'?'ef-control-number-readonly':$addclass) ; } # --------------------------------------------------------------------------- # # show_control_readonly - output the control as readonly # sub show_control_readonly { my ($self, $req, $value) = @_ ; my $unit = $self->{unit} ; my $unittext = !$unit?'':$self -> form -> convert_text ($self, ($unit =~ /:/)?$unit:'unit:' . lc($unit), $unit, $req) ; $unittext =~ s/^unit:// ; $value = $self -> {value} || $Embperl::fdat{$self -> {name}} if (!defined($value)) ; $value .= $unittext if ($unit && $value ne '') ; $self -> SUPER::show_control_readonly ($req, $value) ; } # --------------------------------------------------------------------------- # # get_validate_auto_rules - get rules for validation, in case user did # not specify any # sub get_validate_auto_rules { my ($self, $req) = @_ ; return [ $self -> {required}?(required => 1):(emptyok => 1), -type => 'PosInteger' ] ; } 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show_control - output the control #] [$ sub show_control ($self, $req) $self->{size} ||= 10 ; my $unit = $self->{unit} ; my $unittext = !$unit?'':$self -> form -> convert_text ($self, ($unit =~ /:/)?$unit:'unit:' . lc($unit), $unit, $req) ; $unittext =~ s/^unit:// ; $] [- $self -> SUPER::show_control ; -] [$if ($unit) $][+ $unittext +][$endif$] [$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::number - A numeric input control with optional unit inside an Embperl Form =head1 SYNOPSIS { type => 'input', text => 'blabla', name => 'foo', unit => 'sec', } =head1 DESCRIPTION Used to create a numeric input control inside an Embperl Form. Optionaly it can display an unit after the input field. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be 'number' =head3 name Specifies the name of the control =head3 text Will be used as label for the numeric input control =head3 size Gives the size in characters. (Default: 10) =head3 maxlength Gives the maximun length in characters =head3 unit Gives a string that should be displayed right of the input field. =head1 Author G. Richter (richter at embperl dot org) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/info.pm0000644000000000000000000000005012311326120021302 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/info.pm0000644000000000000000000000420312311326120020272 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::info ; use strict ; use base 'Embperl::Form::Control' ; use Embperl::Inline ; 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show - output the control #] [$ sub show ($self, $req) my $span = ($self->{width_percent}); my $state = $self -> {state} ; $state =~ s/[^-a-zA-Z0-9_]/_/g ; $]
get_std_control_attr($req, undef, 'readonly', 'ef-control-info') } +] >[$ if $self -> {image} $][$endif$][+ $self -> {showtext}?($self->{text}):$self -> form -> convert_text ($self, undef, undef, $req) +] 
[$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::blank - A info area inside an Embperl Form =head1 SYNOPSIS { type => 'info', text => 'blabla', image => '/images/symbol.png' } =head1 DESCRIPTION Used to create a info area with optional text inside an Embperl Form. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be 'info' =head3 text (optional) Could be used to give a text that should be displayed inside the blank area =head3 image (optional) Add image to start of info area =head3 class css class =head1 Author G. Richter (richter at embperl dot org) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/checkboxes.pm0000644000000000000000000000005012311326120022465 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/checkboxes.pm0000755000000000000000000001635212311326120021470 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::checkboxes ; use strict ; use vars qw{%fdat} ; use base 'Embperl::Form::ControlMultValue' ; use Embperl::Inline ; # --------------------------------------------------------------------------- # # show_control_readonly - output readonly control # sub show_control_readonly { my ($self, $req) = @_ ; my $name = $self -> {name} ; my @values = split (/\t/, $fdat{$name}) ; $self -> show_control ($req, "^(?:" . join ('|', map { "\Q$_\E" } @values) . ")\$") ; } # --------------------------------------------------------------------------- sub show_control_addons { my ($self, $req) = @_ ; } # ------------------------------------------------------------------------------------------ # # init_data - daten aufteilen # sub init_data { my ($self, $req) = @_ ; my $fdat = $req -> {docdata} || \%fdat ; my $name = $self->{name} ; if (ref $fdat -> {$name}) { $fdat -> {$name} = join ("\t", @{$fdat -> {$name}}) ; } } 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show_control - output the control #] [$ sub show_control ($self, $req, $filter) my $name = $self -> {name} ; $filter ||= $self -> {filter} ; my $val ; my $i = 0 ; my ($values, $options) = $self -> get_all_values ($req) ; my ($ctlattrs, $ctlid, $ctlname) = $self -> get_std_control_attr($req) ; my $tab = $self -> {tab} ; $] [$if $tab $]<[# #]table style="width: 100%">[$ endif $] [* $i = 0 ; *] [$ foreach $val (@$values) $] [$if !defined ($filter) || ($val =~ /$filter/i) $] [$ if $tab $][$ if $colcnt == 0 $]<[# #]tr>[- $colcnt = $tab -][$endif$][$endif$] {trigger}) $]_ef_attach="ef_checkbox"[$endif$] > [$ if $tab $][$endif$] [+ $options ->[$i] || $val +] [- $vert = $self -> {vert} -][$while $vert-- > 0 $]
[$endwhile$] [$ if $tab $][$ if $colcnt-- < 1 $]<[# #]/tr>[$endif$][$endif$] [$endif$] [* $i++ ; *] [$endforeach$] [$if $tab $]<[# #]/table>[$ endif $] [$endsub$] [$ sub xxshow_control ($self, $req, $filter) my ($values, $options) = $self -> get_values ($req) ; my $name = $self -> {name} ; $filter ||= $self -> {filter} ; my $addtop = $self -> {addtop} || [] ; my $addbottom= $self -> {addbottom} || [] ; my $max = @$values ; my $set = !defined ($fdat{$name})?1:0 ; my $tab = $self -> {tab} ; my $colcnt = 0 ; push @{$self -> form -> {fields2empty}}, $name ; my $val ; my $i = 0 ; $] [$if $tab $]<[# #]table width=100% style="width: 100%" >[$ endif $] [$ foreach $val (@$addtop) $] [$if !defined ($filter) || ($val->[0] =~ /$filter/i) $] [$ if $tab $][$ if $colcnt == 0 $]<[# #]tr>[- $colcnt = $tab -][$endif$][$endif$] [#- $fdat{$name} = $val -> [0], $set = 0 if ($set) ; -#] [$ if $tab $][$endif$] [+ $val ->[1] || $val -> [0] +] [$ if $tab $][$ if $colcnt-- < 1 $]<[# #]/tr>[$endif$][$endif$] [$endif$] [$endforeach$] [$ foreach $val (@$values) $] [$if !defined ($filter) || ($val =~ /$filter/i) $] [$ if $tab $][$ if $colcnt == 0 $]<[# #]tr>[- $colcnt = $tab -][$endif$][$endif$] [#- $fdat{$name} = $val, $set = 0 if ($set) ; -#] {sublines} || $self -> {subobjects}) $] OnClick="show_checkboxes_checked(this,[+ $i +],[+ $max +])" [$endif$] > [$ if $tab $][$endif$] [+ $options ->[$i] || $val +] [- $vert = $self -> {vert} -][$while $vert-- > 0 $]
[$endwhile$] [$ if $tab $][$ if $colcnt-- < 1 $]<[# #]/tr>[$endif$][$endif$] [$endif$] [* $i++ ; *] [$endforeach$] [$ foreach $val (@$addbottom) $] [$if !defined ($filter) || ($val->[0] =~ /$filter/i) $] [$ if $tab $][$ if $colcnt == 0 $]<[# #]tr>[- $colcnt = $tab -][$endif$][$endif$] [#- $fdat{$name} = $val -> [0], $set = 0 if ($set) ; -#] [$ if $tab $][$endif$] [+ $val ->[1] || $val -> [0] +] [$ if $tab $][$ if $colcnt-- < 1 $]<[# #]/tr>[$endif$][$endif$] [$endif$] [$endforeach$] [$if $tab $]<[# #]/table>[$ endif $] [$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::checkboxes - A multiple checkbox control inside an Embperl Form =head1 SYNOPSIS { type => 'checkboxes', text => 'blabla', name => 'foo', values => [1,2,3], options => ['foo', 'bar', 'none'], } =head1 DESCRIPTION Used to create an checkboxes control inside an Embperl Form. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be 'checkboxes' =head3 name Specifies the name of the checkboxes control =head3 text Will be used as label for the checkboxes control =head3 values Gives the values as an array ref of the checkboxes control. =head3 options Gives the options as an array ref that should be displayed to the user. If no options are given, the values from values are used. =head3 vert If specified arranges the checkboxes button vertically. The number given specifies the number of
's used the separate the checkboxes buttons. =head3 tab if specified arranges the checkboxes in a table. The number given specifies the number of columns in one table row. =head3 addtop Array ref which contains items that should be added at the left or top of the checkboxes buttons. Each item consists of an array ref with two entries, the first is the value and the second is the option that is displayed on the page. If the second is missing the value (first entry)is displayed. Example: addtop => [ [1 => 'first item'], [2 => 'second item']] =head3 addbottom Array ref which contains items that should be added at the right or bottom of the checkboxes buttons. Each item consists of an array ref with two entries, the first is the value and the second is the option that is displayed on the page. If the second is missing the value (first entry)is displayed. Example: addbottom => [ [9999 => 'last item'], [9999 => 'very last item']] =head3 filter If given, only items where the value matches the regex given in C are displayed. =head1 Author G. Richter (richter at embperl dot org) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/password.pm0000644000000000000000000000005012311326120022211 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/password.pm0000755000000000000000000000716712311326120021220 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::password ; use strict ; use base 'Embperl::Form::Control' ; use vars qw{%fdat} ; use Embperl::Inline ; # ------------------------------------------------------------------------------------------ # # init_data - daten aufteilen # sub init_data { my ($self, $req, $parentctrl) = @_ ; my $fdat = $req -> {docdata} || \%fdat ; my $name = $self->{name} ; $fdat->{$name} = $fdat->{$name}?'********':'' ; my $retype_name = $self->{retype_name} ; $fdat->{$retype_name} = $fdat->{$name} if ($retype_name) ; } # ------------------------------------------------------------------------------------------ # # prepare_fdat - daten zusammenfuehren # sub prepare_fdat { my ($self, $req) = @_ ; my $fdat = $req -> {form} || \%fdat ; my $name = $self->{name} ; delete $fdat -> {$name} if ($fdat -> {$name} eq '********') ; } # --------------------------------------------------------------------------- # # get_validate_auto_rules - get rules for validation, in case user did # not specify any # sub get_validate_auto_rules { my ($self, $req) = @_ ; return [ ($self -> {required}?(required => 1):(emptyok => 1)), length_min => 4 ] if (!$self->{retype_name}) ; return [ "same", $self->{retype_name}, ($self -> {required}?(required => 1):(emptyok => 1)), length_min => 4 ] ; } 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show_control - output the control #] [$ sub show_control ($self, $req) $] get_std_control_attr($req) } +] [$if $self -> {size} $]size="[+ $self->{size} +]"[$endif$] [$if $self -> {maxlength} $]size="[+ $self->{maxlength} +]"[$endif$] > [$endsub$] [# --------------------------------------------------------------------------- # # show_control_readonly - output the control as readonly #] [$ sub show_control_readonly ($self) $][$ if ($fdat{$self->{name}}) $]********[$endif$][$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::password - A password input control inside an Embperl Form =head1 SYNOPSIS { type => 'password', text => 'blabla', name => 'foo', size => 10, } =head1 DESCRIPTION Used to create a password control inside an Embperl Form. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be 'password' =head3 name Specifies the name of the control =head3 text Will be used as label for the text input control =head3 size Gives the size in characters =head3 retype_name Name of control that is used to repeat the password. An automatic validation rule will be generated, to make sure both inputs are equal. =head3 maxlength Gives the maximun length in characters =head1 Author G. Richter (richter at embperl dot org) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/displaylink.pm0000644000000000000000000000005012311326120022672 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/displaylink.pm0000755000000000000000000001016512311326120021671 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::displaylink ; use strict ; use base 'Embperl::Form::Control' ; use Embperl::Inline ; # --------------------------------------------------------------------------- # # show_control_readonly - output readonly control # sub show_control_readonly { my ($self, $req) = @_ ; $self -> show_control ($req) ; } 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show_control - output the control #] [$ sub show_control ($self, $req) my $name = $self->{name}; my $hrefs = $self -> {href} ; my $targets = $self -> {target} ; my $opens = $self -> {open} ; my $displays = $self -> {link} || $self -> {value} ; my $form = $self -> form ; my $showoptions = $self -> {showoptions} ; my $state = $self -> {state} ; $hrefs = [$hrefs] if (!ref $hrefs) ; $targets = [$targets] if ($targets && !ref $targets) ; $opens = [$opens] if ($opens && !ref $opens) ; $displays = [$displays] if (!ref $displays) ; @hrefs = map { my $x = $_ ; $x =~ s/%%%name%%%/$epreq->Escape ($fdat{$name},6)/eg ; $x =~ s/%%(.+?)%%/$epreq->Escape ($fdat{$1}, 6)/eg ; $x } ref ($hrefs)?@$hrefs:($hrefs) ; @opens = map { my $x = $_ ; $x =~ s/%%%name%%%/$epreq->Escape ($fdat{$name},6)/eg ; $x =~ s/%%(.+?)%%/$epreq->Escape ($fdat{$1}, 6)/eg ; $x } ref ($opens)?@$opens:($opens) ; @displays = map { my $x = $_ ; $x =~ s/%%%name%%%/$fdat{$name}/g ; $x =~ s/%%(.+?)%%/$fdat{$1}/eg ; $x } @$displays ; my $dispn = 0 ; $]
get_std_control_attr($req, '', 'readonly') } +]> [$ foreach $display (@displays) $] [$if $opens[$dispn] $] {eventattrs} } +]> [$else$] [$dispn] $]target="[+ $targets -> [$dispn] +]"[$endif$] [+ do { local $escmode = 0 ; $self -> {eventattrs} } +]> [$endif$][$ if $showoptions < 0 $][+ do { local $escmode = 0 ; $display } +][$else$][+ $showoptions?$display:$form -> convert_text ($self, $display, undef, $req) +][$endif$]  [- $dispn++ -] [$endforeach$]
__END__ =pod =head1 NAME Embperl::Form::Control::displaylink - A control to display links inside an Embperl Form =head1 SYNOPSIS { type => 'displaylink', text => 'blabla', link => ['ecos', 'bb5000'], href => ['http://www.ecos.de', 'http://www.bb5000.info'] } =head1 DESCRIPTION Used to create a control which displays links inside an Embperl Form. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be set to 'displaylink'. =head3 text Will be used as label for the text display control. =head3 link Arrayref with texts for the links that should be shown to the user =head3 href Arrayref with hrefs %%%% is replaced by $fdat{} =head3 open Arrayref, if a value is given for the link, the value will be used as javascript function which is executed onclick. href will be pass as argument. %%%% is replaced by $fdat{} =head3 target Arrayref with targets =head3 showtext If set the texts from the link parameter will not be passed thru convert_text =head1 Author G. Richter (richter at embperl dot org) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/inputlist.pm0000644000000000000000000000005012311326120022402 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/inputlist.pm0000755000076400000000000000526312311326120022102 0ustar00richterroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::inputlist ; use strict ; use base 'Embperl::Form::Control' ; use Embperl::Inline ; use vars qw{%fdat} ; 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show_control - output the control #] [$ sub show_control ($self) my $class = $self -> {class} ; my $opts = $self -> {options} ; my $vals = $self -> {values} ; my $sep = $self -> {separator} || $self -> {seperator}; my $sizes = $self -> {sizes} ; $sizes ||= []; $sep ||= ' '; $opts ||= $vals; my $i = 0; $] [$ while ($i < @$vals) $][-$size = $sizes->[$i] ; $size ||= $self->{size} -] {eventattrs} } +]>[+ ($i +1) < @$vals?$sep:'' +] [- $i++ -] [$endwhile$] [$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::inputjoin - A number of text input controls inside an Embperl Form =head1 SYNOPSIS { type => 'inputlist', text => 'blabla', name => 'foo', size => 10, class => 'bar', separator => '.', sizes => [2,4,5], } =head1 DESCRIPTION Used to create a number of input controls inside an Embperl Form. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be 'inputlist' =head3 name Specifies the name of the control =head3 text Will be used as label for the text input control =head3 size Gives the default size in characters =head3 sizes Gives the size in characters for each input field, this parameter has to be given as an array reference =head3 class Alternative CSS class name =head3 values Gives the names for each input field, this parameter has to be given as an array reference =head3 separator String to display between the input boxes =head1 Author H. Jung (jung@dev.ecos.de) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/mult.pm0000644000000000000000000000005012311326120021330 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/mult.pm0000755000000000000000000002123712311326120020331 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::mult ; use strict ; use base 'Embperl::Form::Control::grid' ; use vars qw{%fdat $epreq} ; use Embperl::Inline ; # --------------------------------------------------------------------------- # # new - create a new control # sub new { my ($class, $args) = @_ ; my $self = Embperl::Form::ControlMultValue -> new($args) ; bless $self, $class ; $self -> init ; return $self ; } # --------------------------------------------------------------------------- # # init - init the new control # sub init { my ($self) = @_ ; my $form = $self -> form ; $self -> {fields} ||= [$self -> {field}] ; $self -> {class} ||= 'ef-control-mult' ; my $options = $form -> {options} ; $form -> new_controls ($self -> {fields}, $options, undef, undef, $options -> {masks}, $options -> {defaults}, 1) ; return $self ; } # ------------------------------------------------------------------------------------------ # # init_data - daten aufteilen # sub init_data { my ($self, $req) = @_ ; my $fdat = $req -> {docdata} || \%fdat ; my $name = $self->{name} ; my @entries = ref $fdat->{$name} eq 'ARRAY'?@{$fdat->{$name}}:split("\t",$fdat->{$name}); my $field = $self -> {fields}[0] ; my $i = 0 ; foreach my $entry (@entries) { $fdat->{"__${name}__$i"} = $entry ; if ($field -> can ('init_data')) { local $field->{name} = "__${name}__$i" ; local $field -> {fullid} = "$self->{fullid}__$i" ; $field -> init_data ($req, $self) ; } $i++ ; } $fdat->{"__${name}_max"} = $i?$i:1; } # ------------------------------------------------------------------------------------------ # # prepare_fdat - daten zusammenfuehren # sub prepare_fdat { my ($self, $req) = @_ ; my $fdat = $req -> {form} || \%fdat ; my $name = $self->{name} ; my $max = $fdat->{"__${name}_max"} || 1 ; my $field = $self -> {fields}[0] ; my @rows; my $val ; for (my $i = 0; $i < $max; $i++) { if ((ref ($field) =~ /::/) && $field -> can ('prepare_fdat')) { local $field->{name} = "__${name}__$i" ; local $field -> {fullid} = "$self->{fullid}__$i" ; $field -> prepare_fdat ($req) ; } $val = $fdat->{"__${name}__$i"} ; push @rows, $val if ($val ne '') ; } $fdat->{$name} = \@rows if (@rows > 1 || defined ($rows[0]) || $fdat->{"__${name}_max"} > 0) ; foreach my $key (keys %$fdat) { delete $fdat->{$key} if ($key =~ /^__\Q$name\E__/) ; } } # ------------------------------------------------------------------------------------------ # # get_display_text - returns the text that should be displayed # sub get_display_text { my ($self, $req, $value) = @_ ; my $field = $self -> {fields}[0] ; return if (!$field) ; return $field -> get_display_text ($req, $value) ; } # ------------------------------------------------------------------------------------------ sub show { $_[0] -> {fullid} = $_[1] -> {uuid} . '_' . $_[0] -> {id} ; Embperl::Form::Control::show (@_) } #sub show_control_readonly { my $self = shift ; $self -> show_control (@_) } 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show - output the whole control including the label #] [$sub show ($self, $req) $fdat{$self -> {name}} = $self -> {default} if ($fdat{$self -> {name}} eq '' && exists ($self -> {default})) ; my $span = 0 ; $] is_readonly($req) ) $]_ef_attach="ef_mult"[$endif$] > [- $span += $self -> show_label_cell ($req, $span); $self -> show_control_cell ($req, $span) ; -]
[$ endsub $] [# --------------------------------------------------------------------------- # # show_control - output the control #] [$ sub show_control ($self, $req) my $name = $self -> {name} ; my $max = $fdat{"__${name}_max"} ||= 1 ; my $span = ($self->{width_percent}) ; my $nsprefix = $self -> form -> {jsnamespace} ; my $jsname = $name ; $jsname =~ s/[^a-zA-Z0-9]/_/g ; $jsname .= 'Grid' ; $] [$ if ($max == 1 && $self -> is_readonly($req) ) $] [- my $field = $self -> {fields}[0] ; local $field -> {name} = "__${name}__0" ; $field -> show_control_readonly ($req) ; -] [$else$] [- $fdat{$name} = $self -> {default} if ($fdat{$name} eq '' && exists ($self -> {default})) ; my $span = 0 ; -]
get_std_control_attr($req) } +]> [- $self -> show_grid_table ($req) ; -]
[- local $req -> {epf_no_script} = 1 ; $self -> show_grid_table_row ($req, '%row%') ; -]
[$endif$] [$endsub$] [# --------------------------------------------------------------------------- # # show_grid_table_row Erzeugt eine Grid-Tabelle-Zeile #] [$ sub show_grid_table_row ($self, $req, $i) $field = $self -> {fields}[0] ; $id = $self -> {fullid}; $name = $self -> {name} ; my $jsname = $name ; $jsname =~ s/[^a-zA-Z0-9]/_/g ; $jsname .= 'Grid' ; my $ro = $self -> is_readonly ($req) ; $] [- local $field -> {name} = "__${name}__$i" ; if ($ro) { $field -> show_control_readonly ($req) } else { $field -> show_control ($req) } -] [$ endsub $] [$ sub show_label_icon ($self) $name = $self -> {name} ; my $jsname = $name ; $jsname =~ s/[^a-zA-Z0-9]/_/g ; $jsname .= 'Grid' ; $] [$if (! $self -> is_readonly ($req)) $] [$endif$] [$endsub$] [# --------------------------------------------------------------------------- # # show_grid_table Erzeugt eine Grid-Tabelle #] [$ sub show_grid_table ($self, $req) my $name = $self->{name} ; my $fields = $self -> {fields} ; my $id = $self -> {fullid}; my $i = 0 ; my $max = $fdat{"__${name}_max"} || 1 ; $] [* for ($i = 0; $i < $max ; $i++ ) { *] [- $self -> show_grid_table_row ($req, $i) ; -] [* } *] [$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::grid - A grid control inside an Embperl Form =head1 SYNOPSIS =head1 DESCRIPTION Used to create a grid control inside an Embperl Form. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be 'grid' =head3 fields Array ref with field definitions =head3 header_bottom If grid has more rows as given in this parameter, a header line is also displayed at the bottom of the grid. Default is 10. Set to -1 to always get a header at the bottom. =head2 Example { name => 'provider-path', text => 'Suchpfad', type => 'grid', fields => [ { name => 'active', text => 'Aktiv', type => 'checkbox', width => '30' }, { name => 'path', text => 'Pfad' }, ], }, =head1 Author G. Richter (richter at embperl dot org) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/radio.pm0000644000000000000000000000005012311326120021445 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/radio.pm0000755000000000000000000001072212311326120020443 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::radio ; use strict ; use vars qw{%fdat} ; use base 'Embperl::Form::ControlMultValue' ; use Embperl::Inline ; # --------------------------------------------------------------------------- sub show_control_addons { my ($self, $req) = @_ ; } 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show_control - output the control #] [$ sub show_control ($self, $req, $filter, $values, $options) ($values, $options) = $self -> get_values ($req) if (!$values) ; my $name = $self -> {name} ; my $ignorecase= $self -> {ignorecase} ; my $max = @$values ; my $set = !defined ($fdat{$name})?1:0 ; my $nsprefix = $self -> form -> {jsnamespace} ; my $ctrlid = ($req -> {uuid} . '_' . $name) ; my $val ; my $i = 0 ; if ($self -> {vert}) { $tr = '' ; $trend = '' ; $trglob = '' ; $trendglob = '' ; } else { $tr = '' ; $trend = '' ; $trglob = '' ; $trendglob = '' ; } $] {trigger}) $]_ef_attach="ef_radio" name="[+ $self -> {force_name} || $self -> {name} +]"[$endif$] >[+ do { local $escmode = 0 ; $trglob }+] [$ foreach $val (@$values) $][- $x = ($val =~ /$filter/i) -] [- $fdat{$name} = $val, $set = 0 if ($set) ; $fdat{$name} = $val if ($ignorecase && lc($fdat{$name}) eq lc($val)) ; -] [+ do { local $escmode = 0 ; $tr }+][+ do { local $escmode = 0 ; $trend }+] [* $i++ ; *] [$endforeach$] [+ do { local $escmode = 0 ; $trendglob }+]
get_std_control_attr($req, "$ctlid-_-$val") } +] value="[+ $val +]" >[+ $options ->[$i] || $val +]
[$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::radio - A radio control inside an Embperl Form =head1 SYNOPSIS { type => 'radio', text => 'blabla', name => 'foo', values => [1,2,3], options => ['foo', 'bar', 'none'], } =head1 DESCRIPTION Used to create an radio control inside an Embperl Form. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be 'radio' =head3 name Specifies the name of the radio control =head3 text Will be used as label for the radio control =head3 values Gives the values as an array ref of the radio control. =head3 options Gives the options as an array ref that should be displayed to the user. If no options are given, the values from values are used. =head3 vert If specified arranges the radio button vertically. The number given specifies the number of
's used the separate the radio buttons. =head3 ignorecase If given, ignore the case of the posted values in %fdat, when selecting a radio button. =head3 addtop Array ref which contains items that should be added at the left or top of the radio buttons. Each item consists of an array ref with two entries, the first is the value and the second is the option that is displayed on the page. If the second is missing the value (first entry)is displayed. Example: addtop => [ [1 => 'first item'], [2 => 'second item']] =head3 addbottom Array ref which contains items that should be added at the right or bottom of the radio buttons. Each item consists of an array ref with two entries, the first is the value and the second is the option that is displayed on the page. If the second is missing the value (first entry)is displayed. Example: addbottom => [ [9999 => 'last item'], [9999 => 'very last item']] =head3 filter If given, only items where the value matches the regex given in C are displayed. =head1 Author G. Richter (richter at embperl dot org) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/duration.pm0000644000000000000000000000005012311326120022174 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/duration.pm0000644000000000000000000000716212311326120021173 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::duration ; use strict ; use base 'Embperl::Form::Control::number' ; use Embperl::Inline ; use vars qw{%fdat} ; # --------------------------------------------------------------------------- # # init - init the new control # sub init { my ($self) = @_ ; $self->{unit} ||= '' ; return $self ; } # ------------------------------------------------------------------------------------------ # # init_data - daten aufteilen # sub init_data { my ($self, $req, $parentctrl) = @_ ; my $fdat = $req -> {docdata} || \%fdat ; my $name = $self->{name} ; my $val = $fdat->{$name} ; return if ($val eq '') ; my $aval = abs ($val) ; my $sec = $aval % 60 ; my $min = int ($aval / 60) % 60 ; my $hour = int($aval / 3600) ; my $duration = ($val<0?'-':'') . ($hour?sprintf('%d:%02d', $hour, $min):$min) ; if ($sec != 0) { $duration .= sprintf (':%02d', $sec) ; } $fdat->{$name} = $duration ; } # ------------------------------------------------------------------------------------------ # # prepare_fdat - daten zusammenfuehren # sub prepare_fdat { my ($self, $req) = @_ ; my $fdat = $req -> {form} || \%fdat ; my $name = $self->{name} ; my $val = $fdat->{$name} ; return if ($val eq '') ; my $neg = 0 ; $neg = 1 if ($val =~ s/^\s*-//) ; my @vals = split (/:/, $val, 3) ; $fdat->{$name} = @vals == 1?$vals[0] * 60:$vals[0] * 3600 + $vals[1] * 60 + $vals[2] ; $fdat->{$name} = - $fdat{$name} if ($neg) ; } # --------------------------------------------------------------------------- # # get_validate_auto_rules - get rules for validation, in case user did # not specify any # sub get_validate_auto_rules { my ($self, $req) = @_ ; return [ $self -> {required}?(required => 1):(emptyok => 1), -type => 'Duration' ] ; } 1 ; __EMBPERL__ __END__ =pod =head1 NAME Embperl::Form::Control::price - A price input control with optional unit inside an Embperl Form =head1 SYNOPSIS { type => 'price', text => 'blabla', name => 'foo', unit => 'sec', } =head1 DESCRIPTION Used to create a price input control inside an Embperl Form. Will format number as a money ammout. Optionaly it can display an unit after the input field. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be 'price' =head3 name Specifies the name of the control =head3 text Will be used as label for the numeric input control =head3 size Gives the size in characters. (Default: 10) =head3 maxlength Gives the maximun length in characters =head3 unit Gives a string that should be displayed right of the input field. (Default: €) =head3 use_comma If set the decimal character is comma instead of point (Default: on) =head1 Author G. Richter (richter at embperl dot org) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/show.pm0000644000000000000000000000005012311326120021327 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/show.pm0000755000000000000000000000603712311326120020331 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::show ; use strict ; use base 'Embperl::Form::Control' ; use Embperl::Inline ; 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show_control - output the control #] [$ sub show_control ($self, $req, $value) my $name = $self->{name}; my $value = exists $self->{value} ? $self->{value} : $fdat{$name}; $value = int($value) if ($self -> {int}) ; $value = $value?1:0 if ($self -> {bool}) ; my $options = $value ; $options = [ split /\t/, $value ] if $self->{split}; $options = [ split /\n/, $value ] if $self->{splitlines}; $options = [$options] if (!ref $options) ; $options = $self -> form -> convert_options ($self, $options, $options, $req) if (ref $options eq 'ARRAY' && !$self -> {showoptions}) ; $][$ if ref $options eq 'ARRAY' $][- $n = @$options -][$ foreach $v (@$options) $][+ $v +][$ if $n-- > 1 $]
[$endif$][$ endforeach $][$ elsif ref $value eq 'HASH' $][$ foreach $k (keys %$value) $][+ $k +]: [+ $value->{$k} +]
[$ endforeach $][$ elsif ref $value $][+ ref $value +][$ else $][+ $value +][$ endif $] [$ if $self->{hidden} $] [$endif$] [$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::show - A text display control inside an Embperl Form =head1 SYNOPSIS { type => 'display', text => 'blabla', hidden => 1, name => 'foo', split => 1 } =head1 DESCRIPTION Used to create a display only control inside an Embperl Form. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be set to 'show'. =head3 text Will be used as label for the text display control. =head3 value value to display. If not given $fdat{} will be used. If the data given within value is an arrayref, every element will be displayed on a separate line. =head3 hidden If set, an appropriate hidden input field will be created automatically. =head3 name Will be used as name for the hidden input field. =head3 split Splits the value into an array at \t if set and displays every array element on a new line. =head3 splitlines Splits the value into an array at \n if set and displays every array element on a new line. =head1 Author G. Richter (richter at embperl dot org), A. Beckert (beckert@ecos.de) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/hidden.pm0000644000000000000000000000005012311326120021602 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/hidden.pm0000644000076400000000000000377312311326120021303 0ustar00richterroot00000000000000################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::hidden ; use strict ; use base 'Embperl::Form::Control' ; use Embperl::Inline ; sub noframe { return 1; } # --------------------------------------------------------------------------- # # is_hidden - returns true if this is a hidden control # sub is_hidden { my ($self, $req) = @_ ; return 1 ; } sub show_control { show (@_) ; } sub show_control_readonly { show (@_) ; } 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show_control - output the control #] [$ sub show ($self, $req) my $name = $self->{name}; my $value = exists $self->{value} ? $self->{value} : $fdat{$name}; $] [$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::hidden - A hidden form field control inside an Embperl Form =head1 SYNOPSIS { type => 'hidden', name => 'foo', } =head1 DESCRIPTION Used to create a hidden form field control inside an Embperl Form. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be set to 'hidden'. =head3 name Will be used as name for the hidden input field. =head1 Author G. Richter (richter at embperl dot org), A. Beckert (beckert@ecos.de) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/datetime.pm0000644000000000000000000000005012323437736022166 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/datetime.pm0000644000000000000000000001520612323437736021163 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::datetime ; use strict ; use base 'Embperl::Form::Control::number' ; use Embperl::Inline ; use POSIX qw(strftime); use Time::Local qw(timelocal_nocheck timegm_nocheck); use Date::Calc qw{Delta_DHMS Add_Delta_Days} ; use vars qw{%fdat} ; our $tz_local = (timegm_nocheck(localtime())-time())/60; # --------------------------------------------------------------------------- # # init - init the new control # sub init { my ($self) = @_ ; $self->{unit} ||= '' ; return $self ; } # ------------------------------------------------------------------------------------------ # # init_data - daten aufteilen # sub init_data { my ($self, $req, $parentctrl, $force) = @_ ; my $fdat = $req -> {docdata} || \%fdat ; my $name = $self->{name} ; my $time = $fdat->{$name} ; return if ($time eq '' || ($req -> {"ef_datetime_init_done_$name"} && !$force)) ; if ($self -> {dynamic} && ($time =~ /^\s*((?:d|m|y|q)(?:\+|-)?(?:\d+)?)\s*$/)) { $fdat->{$name} = $1 ; $req -> {"ef_datetime_init_done_$name"} = 1 ; return ; } my ($y, $m, $d, $h, $min, $s, $z) = ($time =~ /^(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(.)/) ; # Getting the local timezone my $date = eval { my @time = gmtime(timegm_nocheck($s,$min,$h,$d,$m-1,$y-1900)+($tz_local*60)); my $format = $self -> {notime} || ($s == 0 && $h == 0 && $min == 0)?'%d.%m.%Y':'%d.%m.%Y, %H:%M' ; strftime ($format, @time[0..5]) ; } ; if ($time && !$date && ($time =~ /\d+\.\d+\.\d+/)) { $date = $time ; } $fdat->{$name} = $date ; $req -> {"ef_datetime_init_done_$name"} = 1 ; } # ------------------------------------------------------------------------------------------ # # prepare_fdat - daten zusammenfuehren # sub prepare_fdat { my ($self, $req) = @_ ; return if ($self -> is_readonly ($req)) ; my $fdat = $req -> {form} || \%fdat ; my $name = $self->{name} ; my $date = $fdat -> {$name} ; return if ($date eq '') ; if ($self -> {dynamic} && ($date =~ /^\s*((?:d|m|y|q)\s*(?:\+|-)?\s*(?:\d+)?)\s*$/)) { $fdat->{$name} = $1 ; $fdat->{$name} =~ s/\s//g ; return ; } my ($year, $mon, $day, $hour, $min, $sec) ; if ($date eq '*' || $date eq '.') { my $offset ||= 0 ; ($sec, $min, $hour, $day, $mon, $year) = gmtime (time + $offset) ; $year += 1900 ; $mon++ ; } else { $date =~ tr/,;/ / ; my ($d, $t) = split (/\s+/, $date) ; if ($d =~ /:/) { $t = $d ; $d = '' ; } ($day, $mon, $year) = map { $_ + 0 } split (/\./, $d) ; ($hour, $min, $sec) = map { $_ + 0 } split (/\:/, $t) ; if ($year == 0 || $mon == 0 || $day == 0) { my ($s, $min, $h, $md, $m, $y) = localtime ; $day ||= $md ; $mon ||= $m + 1; $year ||= $y + 1900 ; } if ($year < 70) { $year += 2000 ; } elsif ($year >= 70 && $year < 100) { $year += 1900 ; } if ($year < 1907) { $year = $year % 100 + 2000 ; } ($year,$mon,$day, $hour,$min,$sec) = Date::Calc::Add_Delta_DHMS($year,$mon,$day, $hour,$min,$sec, 0, 0, -$tz_local, 0) if ($hour || $min || $sec) ; } $fdat -> {$name} = $year?sprintf ('%04d%02d%02d%02d%02d%02dZ', $year, $mon, $day, $hour, $min, $sec):'' ; } # --------------------------------------------------------------------------- # # get_validate_auto_rules - get rules for validation, in case user did # not specify any # sub get_validate_auto_rules { my ($self, $req) = @_ ; return [ $self -> {required}?(required => 1):(emptyok => 1), -type => 'DateTime' ] ; } 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show_control - output the control #] [$ sub show_control ($self) $self -> {size} ||= 80 / ($self -> {width} || 2) ; my $class = $self -> {class} ||= '' ; my $fullid = $req -> {uuid} . '_' . $self ->{id} ; $] get_std_control_attr($req, $fullid) } +] [$if $self -> {size} $]size="[+ $self->{size} +]"[$endif$] [$if $self -> {maxlength} $]maxlength="[+ $self->{maxlength} +]"[$endif$] _ef_attach="ef_datetime" _ef_dynamic="[+ $self -> {dynamic}?'true':'' +]" > [# #] [$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::price - A price input control with optional unit inside an Embperl Form =head1 SYNOPSIS { type => 'price', text => 'blabla', name => 'foo', unit => 'sec', } =head1 DESCRIPTION Used to create a datetime input control inside an Embperl Form. Will format number as a date/time. See Embperl::Form on how to specify parameters. Datetime format in %fdat is excpected as YYYYMMTTHHMMSSZ =head2 PARAMETER =head3 type Needs to be 'datetime' =head3 name Specifies the name of the control =head3 text Will be used as label for the numeric input control =head3 size Gives the size in characters. (Default: 10) =head3 notime does not display time =head3 dynamic allows the following values to be entered: d, m, y, d-N, d+N, m-N, m+N, y-N, y+N N is any number. This values are simply passed through and need to be process somewhere else. =head1 Author G. Richter (richter at embperl dot org) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/line.pm0000644000000000000000000000005012311326120021276 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/line.pm0000755000000000000000000000325612311326120020300 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::line ; use strict ; use base 'Embperl::Form::Control' ; use Embperl::Inline ; 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show - output the control #] [$ sub show ($self, $req) my $span = ($self->{width_percent}) ; my $state = $self -> {state} ; $]
[$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::line - A horizontal line an Embperl Form =head1 SYNOPSIS { type => 'line', } =head1 DESCRIPTION Used to create a horizontal line inside an Embperl Form. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be 'line' =head1 Author G. Richter (richter at embperl dot org) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/price.pm0000644000000000000000000000005012311326120021451 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/price.pm0000644000000000000000000001012712311326120020443 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::price ; use strict ; use base 'Embperl::Form::Control::number' ; use Embperl::Inline ; use vars qw{%fdat} ; # --------------------------------------------------------------------------- # # init - init the new control # sub init { my ($self) = @_ ; $self -> {use_comma} = 1 if (!defined $self -> {use_comma}) ; $self->{unit} = '€' if (!defined ($self->{unit} )); return $self ; } # ------------------------------------------------------------------------------------------ # # init_data - daten aufteilen # sub init_data { my ($self, $req, $parentctrl, $force) = @_ ; my $fdat = $req -> {docdata} || \%fdat ; delete $self -> {unit} if ($parentctrl) ; my $name = $self->{name} ; my $val = $fdat->{$name} ; return if ($val eq '' || (!$force && $req -> {"ef_price_init_done_$name"})) ; my $sep ; my $dec ; my $int ; my @int ; my $frac ; my $minus = $val =~ s/^-// ; ($int, $frac) = split (/\./, $val, 2) ; if ($self -> {use_comma}) { $sep = '.' ; $dec = ',' ; } else { $sep = ',' ; $dec = '.' ; } $int = '0' x ((3 - length($int)) % 3) . $int; while ($int =~ /(...)/g) { push @int, $1 ; } $int[0] =~ s/^0+// ; $int[0] = '0' if (@int == 1 && !$int[0]) ; $frac = substr ($frac . '00', 0, 2) ; $fdat->{$name} = ($minus?'-':'') . join ($sep, @int) . $dec . $frac ; $req -> {"ef_price_init_done_$name"} = 1 ; } # ------------------------------------------------------------------------------------------ # # prepare_fdat - daten zusammenfuehren # sub prepare_fdat { my ($self, $req) = @_ ; my $fdat = $req -> {form} || \%fdat ; my $name = $self->{name} ; my $val = $fdat->{$name} ; return if ($val eq '') ; $val =~ s/\s+//g ; if ($self -> {use_comma}) { $val =~ s/\.//g ; $val =~ s/\,/./ ; } $fdat->{$name} = $val + 0 ; } # --------------------------------------------------------------------------- # # get_validate_auto_rules - get rules for validation, in case user did # not specify any # sub get_validate_auto_rules { my ($self, $req) = @_ ; return [ $self -> {required}?(required => 1):(emptyok => 1), -type => 'Number' ] ; } 1 ; __EMBPERL__ __END__ =pod =head1 NAME Embperl::Form::Control::price - A price input control with optional unit inside an Embperl Form =head1 SYNOPSIS { type => 'price', text => 'blabla', name => 'foo', unit => 'sec', } =head1 DESCRIPTION Used to create a price input control inside an Embperl Form. Will format number as a money ammout. Optionaly it can display an unit after the input field. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be 'price' =head3 name Specifies the name of the control =head3 text Will be used as label for the numeric input control =head3 size Gives the size in characters. (Default: 10) =head3 maxlength Gives the maximun length in characters =head3 unit Gives a string that should be displayed right of the input field. (Default: €) =head3 use_comma If set the decimal character is comma instead of point (Default: on) =head1 Author G. Richter (richter at embperl dot org) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/Control/PaxHeaders.14966/scriptcode.pm0000644000000000000000000000005012311326120022506 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control/scriptcode.pm0000644000076400000000000000410312311326120022173 0ustar00richterroot00000000000000################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control::scriptcode ; use strict ; use base 'Embperl::Form::Control' ; use Embperl::Inline ; sub noframe { return 1; } # --------------------------------------------------------------------------- # # is_hidden - returns true if this is a hidden control # sub is_hidden { my ($self, $req) = @_ ; return 1 ; } 1 ; __EMBPERL__ [# --------------------------------------------------------------------------- # # show_control - output the control #] [$ sub show ($self, $req) my $name = $self -> {name}; my $type = $self -> {scripttype} || 'text/javascript' ; $] [$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control::scriptcode - A control to add script code to an Embperl Form =head1 SYNOPSIS { type => 'scriptcode', code => 'function onEvent { .... }', } =head1 DESCRIPTION Used to create a script code blockinside an Embperl Form. The code block is added to the end of the form. See Embperl::Form on how to specify parameters. =head2 PARAMETER =head3 type Needs to be set to 'scriptcode'. =head3 name optional =head3 scripttype Type of script code. Default: text/javascript =head3 code The actual script code. =head1 Author G. Richter (richter at embperl dot org), A. Beckert (beckert@ecos.de) =head1 See Also perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/PaxHeaders.14966/Validate.pm0000644000000000000000000000005012311327004020462 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate.pm0000644000000000000000000007002112311327004017453 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: Validate.pm 1578075 2014-03-16 14:01:14Z richter $ # ################################################################################### package Embperl::Form::Validate; use strict; use vars qw($VERSION $has_encode); BEGIN { eval "require Encode" ; $has_encode = $@?0:1 ; } $VERSION = '2.5.0' ; =head1 NAME Embperl::Form::Validate - Form validation with server- and client-side support. =head1 DESCRIPTION This modules is developed to do form validation for you. It works on the server side by checking the posted form data and it generates client side script functions, to validate the form values, as far as possible, before they are send to the server, to avoid another server roundtrip. Also it has the best support for Embperl, it should also work outside of Embperl e.g. with CGI.pm or mod_perl. It can be extended by new validation rules for additional syntaxes (e.g. US zip codes, German Postleitzahlen, number plates, iso-3166 2-digit language or country codes, etc.) Each module has the ability to rely it's answer on parameters like e.g. the browser, which caused the request for or submitted the form. The module fully supports internationalisation. Any message can be provided in multiple languages and it makes use of Embperl's multilanguage support. =head1 SYNOPSIS use Embperl::Form::Validate; my $epf = new Embperl::Form::Validate($rules, $form_id); $epf->add_rule('fnord', $fnord_rules); # validate the form values and returns error information, if any my $result = $epf -> validate ; # Does the form content validate? print 'Validate: ' . ($result?'no':'yes'); # validate the form values and reaturn all error messages, if any my $errors = $epf->validate_messages($fdat, $pref); # Get the code for a client-side form validation according to the # rules given to new: $epf -> get_script_code ; =head1 METHODS The following methods are available: =head2 $epf = Embperl::Form::Validate -> new ($rules [, $form_id ], [$default_language], [$charset]); Constructor for a new form validator. Returns a reference to a Embperl::Form::Validate object. =over =item $rules should be a reference to an array of rules, see L<"RULES"> elsewhere in this document for details. =item $form_id should be the name (im HTML) or id (in XHTML) parameter of the form tag, which has to be verified.It\'s e.g. used for generating the right path in the JavaScript DOM. It defaults to 'forms[0]' which should be the first form in your page. =item $default_language language to use when no messages are available in the desired language. Defaults to 'en'. =item $charset Pass 'utf-8' in case you want utf-8 messages. =back =cut sub new { my $invokedby = shift; my $class = ref($invokedby) || $invokedby; my ($frules, $form_id, $default_language, $charset) = @_ ; my $self = { form_id => $form_id || 'forms[0]', # The name frules => $frules || [], # \@frules default_language => $default_language || 'en', charset => $charset || 'iso8859-15', }; bless($self, $class); $self->init; return $self; } ### ### init() yet undocumented. The only purpose of init() is too allow ### to add functionality without rewriting the whole new() method. ### sub init # $self { my $self = shift; return 1; } =head2 $epf->add_rules($field, $field_rules); Adds rules $field_rules for a (new) field $field to the validator, e.g. $epf->add_rule([ -key => 'fnord', -type => 'Number', -max => 1.3, -name => 'Fnord' ]); The new rule will be appended to the end of the list of rules. See L<"RULES"> elsewhere in this document. =cut sub add_rule # $self, $field, \%rules { my $self = shift; my $rules = shift; push @{$self->{frules}}, $rules; return 1; } =head2 $epf -> validate ([$fdat, [$pref]]); Does the server-side form validation. =over =item $fdat should be a hash reference to all postend form values. It defaults to %fdat of the current Embperl page. =item $pref can contain addtional information for the validation process. At the moment the keys C and C are recognized. C defaults to the language set by Embperl. C defaults to the one given with C. =back The method verifies the content $fdat according to the rules given to the Embperl::Form::Validate constructor and added by the add_rule() method and returns an array refernce to error information. If there is no error it returns undef. Each element of the returned array contains a hash with the following keys: =over =item key key into $fdat which caused the error =item id message id =item typeobj object reference to the Validate object which was used to validate the field =item name human readable name, if any. Maybe a hash with multiple languages. =item msg field specific messages, if any. Maybe a hash with multiple languages. =item param array with parameters which should subsituted inside the message =back =cut sub loadtype { my ($self, $type) = @_ ; eval "require $type;"; die 'Died inside '.__PACKAGE__.'::loadtype::eval: '.$@ if $@; return $type; } sub newtype { my ($self, $type) = @_ ; $type ||= 'Default'; $type = 'Embperl::Form::Validate::'.$type unless $type =~ m!(::|/)!; my $obj = $self -> {typeobjs}{$type} ; return $obj if ($obj) ; $type = $self -> loadtype ($type) ; $obj = $self -> {typeobjs}{$type} = $type -> new ; return $obj ; } sub validate_rules { my ($self, $frules, $fdat, $pref, $result) = @_ ; my %param ; my $type ; my $typeobj ; my $i ; my $keys = [] ; my $key ; my $status ; my $name ; my $msg ; my $break = 0 ; while ($i < @$frules) { my $action = $frules -> [$i++] ; if (ref $action eq 'ARRAY') { my $fail = $self -> validate_rules ($action, $fdat, $pref, $result) ; return $fail if ($fail) ; } elsif (ref $action eq 'CODE') { my $arg = $frules -> [$i++] ; foreach my $k (@$keys) { $status = &$action($k, $fdat -> {$k}, $arg, $fdat, $pref) ; last if (!$status) ; } } elsif ($action =~ /^-(.*?)$/) { if ($1 eq 'key') { $key = $frules->[$i++] ; $keys = ref $key?$key:[$key] ; $type = 'Default' ; $typeobj = $self -> newtype ($type) ; $name = undef ; $msg = undef ; } elsif ($1 eq 'name') { $name = $i++ ; } elsif ($1 eq 'msg') { $msg = $i++ ; } elsif ($1 eq 'break') { $break = $frules->[$i++] ; } elsif ($1 eq 'type') { $type = $frules->[$i++] ; $typeobj = $self -> newtype ($type) ; foreach my $k (@$keys) { $status = $typeobj -> validate ($k, $fdat -> {$k}, $fdat, $pref) ; last if (!$status) ; } } else { $param{$1} = 1 ; } } else { my $arg = $frules -> [$i++] ; foreach my $k (@$keys) { my $method = 'validate_' . $action ; $status = $typeobj -> $method ($k, $fdat -> {$k}, $arg, $fdat, $pref) ; last if (!$status) ; } } if ($status) { if (@$status && !$break) { my $id = $status -> [0] ; push @$result, { typeobj => $typeobj, id => $id, key => $key, ($name?(name => $frules -> [$name]):()), ($msg?(msg => $frules -> [$msg]):()), param => $status} ; } last if (!$param{cont}) } } return $param{fail} ; } sub validate { my ($self, $fdat, $pref, $epreq) = @_ ; $epreq ||= $Embperl::req ; $fdat ||= $epreq -> thread -> form_hash ; my @result ; $self -> validate_rules ($self->{frules}, $fdat, $pref, \@result) ; return \@result ; } sub build_message { my ($self, $id, $key, $name, $msg, $param, $typeobj, $pref, $epreq) = @_ ; my $language = $pref -> {language} ; my $default_language = $pref -> {default_language} || $self -> {default_language} ; my $charset = $pref -> {charset} ; my $txt ; $name ||= $epreq?$epreq -> gettext($key):$key ; if (ref $name eq 'ARRAY') { my @names ; foreach my $n (@$name) { push @names, ref $n ? ($n -> {"$language.$charset"} || $n -> {"$default_language.$charset"} || $n -> {$language} || $n -> {$default_language} || (each %$n)[1] || $key):$n ; } $name = join (', ', @names) ; } else { $name = ref $name ? ($name -> {"$language.$charset"} || $name -> {"$default_language.$charset"} || $name -> {$language} || $name -> {$default_language} || (each %$name)[1] || $key):$name ; } if ($msg) { $txt = ref $msg ? ($msg -> {"$language.$charset"} || $msg -> {"$default_language.$charset"} || $msg -> {$language} || $msg -> {$default_language} || (each %$msg)[1] || undef):$msg ; } else { $txt = $typeobj -> getmsg ($id, "$language.$charset", "$default_language.$charset") ; $txt ||= $typeobj -> getmsg ($id, $language, $default_language) ; } $txt = $epreq -> gettext($id) if (!$txt && $epreq) ; $txt ||= "Missing Message $id: %0 %1 %2 %3" ; $id = $param -> [0] ; $param -> [0] = $name ; my @param ; eval "require Encode" ; if ($charset && $has_encode) { @param = map { Encode::encode($charset, $_) } @$param ; } else { @param = @$param ; } $txt =~ s/%(\d+)/$param[$1]/g ; $param -> [0] = $id ; return $txt ; } =pod =head2 $epf -> error_message ($err, [ $pref ]) Converts one item returned by validate into a error message =over =item $err Item returned by validate =item $pref Preferences (see L) =back =cut sub error_message { my ($self, $err, $pref, $epreq) = @_ ; $epreq ||= $Embperl::req ; return $self -> build_message ($err -> {id}, $err -> {key}, $err -> {name}, $err -> {msg}, $err -> {param}, $err -> {typeobj}, $pref, $epreq) ; } =pod =head2 $epf -> validate_messages ($fdat, [ $pref ]) Validate the form content and returns the error messages as array ref if any. See L for details. =cut sub validate_messages { my ($self, $fdat, $pref, $epreq) = @_ ; $epreq ||= $Embperl::req ; $pref -> {language} ||= $epreq -> param -> language if ($epreq) ; $pref -> {default_language} ||= $self -> {default_language} ; $pref -> {charset} ||= $self -> {charset} ; my $result = $self -> validate ($fdat, $pref, $epreq) ; return [] if (!@$result) ; my @msgs ; foreach my $err (@$result) { my $msg = $self -> build_message ($err -> {id}, $err -> {key}, $err -> {name}, $err -> {msg}, $err -> {param}, $err -> {typeobj}, $pref, $epreq) ; push @msgs, $msg ; } return \@msgs ; } sub gather_script_code { my ($self, $frules, $pref, $epreq) = @_ ; my %param ; my $type ; my $typeobj ; my $i ; my $keys = [] ; my $key ; my $status ; my $name ; my $msg ; my $msgparam ; my $language = $pref -> {language} ; my $default_language = $pref -> {default_language} || 'en' ; my $scriptcode = $self -> {scriptcode} ||= {} ; my $script = '' ; my $form = $self -> {form_id} ; my $break = 0 ; while ($i < @$frules) { my $arg ; my $method ; my $action = $frules -> [$i++] ; if (ref $action eq 'ARRAY') { $script .= $self -> gather_script_code ($action, $pref, $epreq) ; } elsif (ref $action eq 'CODE') { $i++ ; } elsif ($action =~ /^-(.*?)$/) { if ($1 eq 'key') { $key = $frules->[$i++] ; $keys = ref $key?$key:[$key] ; $type = 'Default' ; $typeobj = $self -> newtype ($type) ; $name = undef ; $msg = undef ; } elsif ($1 eq 'name') { $name = $i++ ; } elsif ($1 eq 'msg') { $msg = $i++ ; } elsif ($1 eq 'break') { $break = $frules->[$i++] ; } elsif ($1 eq 'type') { $type = $frules->[$i++] ; $typeobj = $self -> newtype ($type) ; $method = 'getscript_validate' ; $arg = '' ; } else { $param{$1} = 1 ; } } else { $method = 'getscript_' . $action ; $arg = $frules -> [$i++] ; } if ($method) { my $code ; my $ret ; my $k = "$type*$action*$arg" ; if (!exists ($scriptcode -> {$k})) { if ($typeobj -> can ($method)) { ($code, $msgparam) = $typeobj -> $method ($arg, $pref, $form) ; $scriptcode -> {$k} = [$code, $msgparam] ; } else { $code = '' ; $scriptcode -> {$k} = '' ; } } else { if ($scriptcode -> {$k}) { $code = $scriptcode -> {$k}[0] ; $msgparam = $scriptcode -> {$k}[1] ; } } if ($code) { my $nametxt = $name?$frules -> [$name]:undef ; my $msgtxt = $msg?$frules -> [$msg]:undef ; my $setmsg = '' ; if ($msgparam && !$break) { my $txt = $self -> build_message ($msgparam -> [0], $key, $nametxt, $msgtxt, $msgparam, $typeobj, $pref, $epreq) ; $setmsg = "ids[i] = '$key' ; msgs[i++]='$txt';" } if (!ref $key) { $script .= "obj = formelem\['$key'\] ; if (obj && !($code)) { $setmsg " . ($param{fail}?'fail=1;break;':($param{cont}?'':'break;')) . "}\n" ; } else { foreach my $k (@$keys) { $script .= "obj = formelem\['$k'\] ; if (obj && !($code)) {" ; } $script .= " $setmsg " . ($param{fail}?'fail=1;break;':($param{cont}?'':'break;')) . "\n" ; foreach my $k (@$keys) { $script .= "}" ; } } } } } if ($script) { return qq{ do { $script } while (0) ; if (fail) break ; } ; } return '' ; } =pod =head2 $epf -> get_script_code ([$pref]) Returns the script code necessary to do the client-side validation. Put the result between tags inside your page. It will contain a function that is named C> where is replaced by the form named you have passed to L. You should call this function in the C of your form. Example:
....
=cut sub get_script_code { my ($self, $pref, $epreq) = @_ ; $epreq ||= $Embperl::req ; $pref ||= {} ; $pref -> {language} ||= $epreq -> param -> language if ($epreq) ; $pref -> {default_language} ||= $self -> {default_language} ; $pref -> {charset} ||= $self -> {charset} ; my $script ; $script = $self -> gather_script_code ($self->{frules}, $pref, $epreq) ; my $fname = $self -> {form_id} ; $fname =~ s/([^a-zA-Z0-9_])/_/g ; return qq{ function epform_validate_$fname(return_msgs, failed_class, formelem) { var msgs = new Array ; var ids = new Array ; var fail = 0 ; var i = 0 ; var obj ; if (!formelem) formelem = document.$fname ; do { $script ; } while (0) ; if (failed_class) { var key ; var i ; for (key in ids) { var elems = formelem\[ids[key]\] ; if (elems) { if (!(elems instanceof NodeList)) elems = [elems] ; if (elems[0] instanceof NodeList) elems = elems[0] ; for (i = 0; i < elems.length ;i++) { var elem = elems[i] ; if (elem.getAttribute('type') == 'radio') elem = elem.parentElement ; var eclass = elem.getAttribute('class') ; elem.setAttribute ('class', eclass + ' ' + failed_class) ; elem.setAttribute ('title', msgs[key]) ; } } } } if (return_msgs) { var ret = [msgs, ids] ; return ret ; } if (i) alert (msgs.join('\\n')) ; return !i ; } } ; } =head1 DATA STRUCTURES The functions and methods expect the named data structures as follows: =head2 RULES The $rules array contains a list of tests to perform. Alls the given tests are process sequenzially. You can group tests together, so when one test fails the remaining tests of the same group are not processed and the processing continues in the next outer group with the next test. [ [ -key => 'lang', -name => 'Language' required => 1, length_max => 5, ], [ -key => 'from', -type => 'EMail', emptyok => 1, ], -key => ['foo', 'bar'] required => 1, ] All items starting with a dash are control elements, while all items without a dash are tests to perform. =over =item -key gives the key in the passed form data hash which should be tested. -key is normally the name given in the HTML name attribute within a form field. C<-key> can also be a arrayref, in which case B the given keys must statisfy the following test to succeed. =item -name is a human readable name that should be used in error messages. Can be hash with multiple languages, e.g. -name => { 'en' => 'date', 'de' => 'Datum' } =item -type specfify to not use the standard tests, but the ones for a special type. For example there is a type C which will replaces all the comparsions by numeric ones instead of string comparisions. You may add your own types by writing a module that contains the necessary test and dropping it under Embperl::Form::Validate::. The -type directive also can verfiy that the given data has a valid format for the type. The following types are available: =over =item Default This one is used when no type is specified. It contains all the standard tests. =item Number Input must be a floating point number. =item Integer Input must be a integer number. =item PosInteger Input must be a integer number and greater or equal zero. =item TimeHHMM Input must be the time in the format hh::mm =item TimeHHMMSS Input must be the time in the format hh::mm:ss =item TimeValue Input must be a number followed by s, m, h, d or w. =item EMail Input must be a valid email address including a top level domain e.g. user@example.com =item EMailRFC Input must be a valid email address, no top level domain is required, so user@foo is also valid. =item IPAddr Input must be an ip-address in the form nnn.nnn.nnn.nnn =item IPAddr_Mask Input must be an ip-address and network mask in the form nnn.nnn.nnn.nnn/mm =item FQDN_IPAddr Input must be an ip-address or an fqdn (host.domain) =item select This used together with required and causes Embperl::Form::Validate to test of a selected index != 0 instead of a non empty input. =back If you write your own type package, make sure to send them back, so they can be part of the next distribution. =item -msg Used to give messages which should be used when the test fails. This message overrides the standard messages provided by Embperl::Form::Validate and by Embperls message management. Can also be a hash with messages for multiple languages. The -msg parameter must preceed the test for which it should be displayed. You can have multiple different messages for different tests, e.g. [ -key => 'email', -name => 'E-Mail-Address', emptyok => 1, # it's ok to leave this field empty (in this case the following tests are skiped) -msg => 'The E-Mail-Address is invalid.', matches_regex => '(^[^ <>()@¡-ÿ]+@[^ <>()@¡-ÿ]+\.[a-zA-Z]{2,3}$)', -msg => 'The E-Mail address must contain a "@".', must_contain_one_of => '@', -msg => 'The E-Mail address must contain at least one period.', must_contain_one_of => '.', ], =item -fail stops further validation of any rule after the first error is found =item -cont continues validation in the same group, also a error was found =item -break => 1 errors only break current block, but does not display any message. -break => 0 turns bak to normal behaviour. This can be used for preconditions: [ -key => 'action', emptyok => 1, -break => 1, ne => 0, -break => 0, -key => 'input', 'required' => 1 ] The above example will only require the field "input", when the field "action" is not empty and is not zero. =item [arrayref] you can place a arrayref with tests at any point in the rules list. The array will be considered as a group and the default is the stop processing of a group as soon as the first error is found and continue with processing with the next rule in the next outer group. =back The following test are currently defined: =over =item required =item emptyok =item length_min =item length_max =item length_eq =item eq =item same Value must be the same as in field given as argument. This is useful if you want for example verify that two passwords are the same. The Text displayed to the user for the second field maybe added to the argument separeted by a colon. Example: $epf = Embperl::Form::Validate -> new ( [ -key => 'pass', -name => 'Password', required => 1, length_min => 4, -key => 'pass2', -name => 'Repeat Password', required => 1, length_min => 4, same => 'pass:Password', ], 'passform') ; =item ne =item lt =item gt =item le =item ge =item matches_regex Value must match B regular expression. Only executed on server side. =item matches_regex_js Value must match B regular expression. Only executed on client side. B If the user has disabled JavaScript in his browser this test will be never executed. Use a corresponding Perl Regex with C to get a server side validation. Use this with care, because different browser may have different support for regular expressions. =item not_matches_regex Value must not match B regular expression. Only executed on server side. =item not_matches_regex_js Value must not match B regular expression. Only executed on client side. B If the user has disabled JavaScript in his browser this test will be never executed. Use a corresponding Perl Regex with C to get a server side validation. Use this with care, because different browser may have different support for regular expressions. =item matches_wildcard =item must_only_contain =item must_not_contain =item must_contain_one_of =item checked Checkbox must be selected =item notchecked Checkbox must not be selected =back =head2 PREFERENCES The $pref hash (reference) contains information about a single form request or submission, e.g. the browser version, which made the request or submission and the language in which the error messages should be returned. See also L =head2 ERROR CODES For a descriptions of the error codes, validate is returning see L =head2 FDAT See also L. my $fdat = { foo => 'foobar', bar => 'baz', baz => 49, fnord => 1.2 }; =head1 Example This example simply validates the form input when you hit submit. If your input is correct, the form is redisplay with your input, otherwise the error message is shown. If you turn off JavaScript the validation is still done one the server-side. Any validation for which no JavaScript validation is defined (like regex matches), only the server-side validation is performed. [- use Embperl::Form::Validate ; $epf = Embperl::Form::Validate -> new ( [ [ -key => 'name', -name => 'Name', required => 1, length_min => 4, ], [ -key => 'id', -name => 'Id', -type => 'Number', gt => 0, lt => 10, ], [ -key => 'email', -msg => 'This is not a valid E-Mail address', must_contain_one_of => '@.', matches_regex => '..+@..+\\...+', length_min => 8, ], [ -key => 'msg', -name => 'Message', emptyok => 1, length_min => 10, ] ]) ; if ($fdat{check}) { $errors = $epf -> validate_messages ; } -]

Embperl Example - Input Form Validation

[$if @$errors $]

Please correct the following errors

[$foreach $e (@$errors)$] [+ $e +]
[$endforeach$] [$else$]

Please enter your data

[$endif$]
Name
Id (1-9)
E-Mail
Message

Embperl (c) 1997-2010 G.Richter / ecos gmbh www.ecos.de See also eg/x/formvalidation.htm =head1 SEE ALSO See also L. =head1 AUTHOR Axel Beckert (abe@ecos.de) Gerald Richter (richter at embperl dot org) Embperl-2.5.0/Embperl/Form/PaxHeaders.14966/Validate0000644000000000000000000000005012323454053020057 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/0000755000000000000000000000000012323454053017125 5ustar00rootroot00000000000000Embperl-2.5.0/Embperl/Form/Validate/PaxHeaders.14966/EMail.pm0000644000000000000000000000005012311327004021451 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/EMail.pm0000644000000000000000000000624212311327004020446 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: EMail.pm 1578075 2014-03-16 14:01:14Z richter $ # ################################################################################### package Embperl::Form::Validate::EMail ; use base qw(Embperl::Form::Validate::Default); my %error_messages = ( de => { validate_email => 'Die eingegebene E-Mail-Adresse "%0" in Feld "%1" ist ungültig, sie muß genau ein "@" enthalten und darf keine Leerzeichen, Klammern oder Umlaute enthalten.', validate_email_nomailto => 'Die eingegebene E-Mail-Adresse "%0" in Feld "%1" scheint mit einem "mailto:" zu beginnen. Bitte geben Sie nur eine E-Mail-Adresse ein und keine mit "mailto:" beginnende URL.', }, 'de.utf-8' => { validate_email => 'Die eingegebene E-Mail-Adresse "%0" in Feld "%1" ist ungültig, sie muß genau ein "@" enthalten und darf keine Leerzeichen, Klammern oder Umlaute enthalten.', validate_email_nomailto => 'Die eingegebene E-Mail-Adresse "%0" in Feld "%1" scheint mit einem "mailto:" zu beginnen. Bitte geben Sie nur eine E-Mail-Adresse ein und keine mit "mailto:" beginnende URL.', }, en => { validate_email => 'The given e-mail address "%0" in field "%1" is not valid. It must have exactly one "@" and must not contain any blanks, parentheses or special charactes like umlauts.', validate_email_nomailto => 'The given e-mail address "%0" in field "%1" seems to be prepended by "mailto:". Please enter only an e-mail address and no URL starting with "mailto:".', } ); # -------------------------------------------------------------- sub getmsg { my ($self, $id, $language, $default_language) = @_ ; return $error_messages{$language}{$id} || $error_messages{$default_language}{$id} || $self -> SUPER::getmsg ($id, $language, $default_language) ; } # -------------------------------------------------------------- sub validate { my ($self, $key, $value, $fdat, $pref) = @_ ; # The valid address "user@tld" or local addresses are not valid in this more general ruleset if ($value !~ /^[^ <>()@¡-ÿ]+@[^ <>()@¡-ÿ]+\.[a-zA-Z]{2,4}$/ or $value =~ /@(\.|.*(\.\.|@))/) { return ['validate_email', $value, $key] ; } if ($value =~ /^mailto:/i) { return ['validate_email_nomailto', $value, $key] ; } return undef ; } # -------------------------------------------------------------- sub getscript_validate { my ($self, $arg, $pref) = @_ ; return ('((obj.value.search(/^[^ <>()@\x80-\xff]+@[^ <>()@\x80-\xff]+\.[a-zA-Z]{2,4}$/) >= 0) && (obj.value.search(/@(\.|.*(\.\.|@))|mailto:/i) < 0))', ['validate_email', "'+obj.value+'"]) ; } 1; Embperl-2.5.0/Embperl/Form/Validate/PaxHeaders.14966/TimeHHMM.pm0000644000000000000000000000005012311327004022032 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/TimeHHMM.pm0000644000000000000000000000413112311327004021022 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: TimeHHMM.pm 1578075 2014-03-16 14:01:14Z richter $ # ################################################################################### package Embperl::Form::Validate::TimeHHMM ; use base qw(Embperl::Form::Validate::Default); my %error_messages = ( de => { validate_time => 'Feld %0: "%1" ist kein gültiges Zeitformat. Geben Sie die Zeit in der Form hh:mm ein', }, 'de.utf-8' => { validate_time => 'Feld %0: "%1" ist kein gültiges Zeitformat. Geben Sie die Zeit in der Form hh:mm ein', }, en => { validate_time => 'Field %0: "%1" isn\\\'t a valid time. Please enter the time as hh:mm', } ); # -------------------------------------------------------------- sub getmsg { my ($self, $id, $language, $default_language) = @_ ; return $error_messages{$language}{$id} || $error_messages{$default_language}{$id} || $self -> SUPER::getmsg ($id, $language, $default_language) ; } # -------------------------------------------------------------- sub validate { my ($self, $key, $value, $fdat, $pref) = @_ ; if($value =~ /^(\d\d):(\d\d)$/) { if ($1 < 0 || $1 > 23 || $2 < 0 || $2 > 59 ) { return ['validate_time', $value] ; } return undef ; } return ['validate_time', $value] ; } # -------------------------------------------------------------- sub getscript_validate { my ($self, $arg, $pref) = @_ ; return ('obj.value.search(/^\d{2}\:\d{2}$/) >= 0', ['validate_time', "'+obj.value+'"]) ; } 1; Embperl-2.5.0/Embperl/Form/Validate/PaxHeaders.14966/Number.pm0000644000000000000000000000005012311327004021712 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/Number.pm0000644000000000000000000001063012311327004020703 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: Number.pm 1578075 2014-03-16 14:01:14Z richter $ # ################################################################################### package Embperl::Form::Validate::Number ; use base qw(Embperl::Form::Validate::Default); my $VERSION = '2.0.0' ; my %error_messages = ( de => { validate_number => '%0 muß eine Zahl sein', }, 'de.utf-8' => { validate_number => '%0 muß eine Zahl sein', }, en => { validate_number => '%0 must be a number', } ); # -------------------------------------------------------------- sub getmsg { my ($self, $id, $language, $default_language) = @_ ; return $error_messages{$language}{$id} || $error_messages{$default_language}{$id} || $self -> SUPER::getmsg ($id, $language, $default_language) ; } # -------------------------------------------------------------- sub validate { my ($self, $key, $value, $fdat, $pref) = @_ ; return $value =~ /^\s*[0-9+-.,][0-9.,eE]*\s*$/ ? undef : ['validate_number', $value] ; } # -------------------------------------------------------------- sub getscript_validate { my ($self, $arg, $pref) = @_ ; return ('obj.value.search(/^\s*[0-9+-.,][0-9.,eE]*\s*$/) >= 0', ['validate_number', "'+obj.value+'"]) ; } # -------------------------------------------------------------- sub validate_eq { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return $value == $arg ? undef : ['validate_eq', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_eq { my ($self, $arg, $pref) = @_ ; return ("obj.value == $arg", ['validate_eq', "+'obj.value'+", $arg]) ; } # -------------------------------------------------------------- sub validate_gt { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return $value > $arg ? undef : ['validate_gt', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_gt { my ($self, $arg, $pref) = @_ ; return ("obj.value > $arg", ['validate_gt', "+'obj.value'+", $arg]) ; } # -------------------------------------------------------------- sub validate_lt { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return $value < $arg ? undef : ['validate_lt', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_lt { my ($self, $arg, $pref) = @_ ; return ("obj.value < $arg", ['validate_lt', "+'obj.value'+", $arg]) ; } # -------------------------------------------------------------- sub validate_ge { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return $value >= $arg ? undef : ['validate_ge', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_ge { my ($self, $arg, $pref) = @_ ; return ("obj.value >= $arg", ['validate_ge', "+'obj.value'+", $arg]) ; } # -------------------------------------------------------------- sub validate_le { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return $value <= $arg ? undef : ['validate_le', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_le { my ($self, $arg, $pref) = @_ ; return ("obj.value <= $arg", ['validate_le', "+'obj.value'+", $arg]) ; } # -------------------------------------------------------------- sub validate_ne { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return $value != $arg ? undef : ['validate_ne', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_ne { my ($self, $arg, $pref) = @_ ; return ("obj.value != $arg", ['validate_ne', "+'obj.value'+", $arg]) ; } 1; Embperl-2.5.0/Embperl/Form/Validate/PaxHeaders.14966/PosInteger.pm0000644000000000000000000000005012311326120022537 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/PosInteger.pm0000755000000000000000000000374512311326120021544 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: Integer.pm,v 1.3 2004/01/23 06:50:57 richter Exp $ # ################################################################################### package Embperl::Form::Validate::PosInteger ; use base qw(Embperl::Form::Validate::Integer); my %error_messages = ( de => { validate_pos_number => '%0 muß eine Zahl größer oder gleich Null sein', }, 'de.utf-8' => { validate_pos_number => '%0 muß eine Zahl größer oder gleich Null sein', }, en => { validate_pos_number => '%0 must be a number greater or equal zero', } ); # -------------------------------------------------------------- sub getmsg { my ($self, $id, $language, $default_language) = @_ ; return $error_messages{$language}{$id} || $error_messages{$default_language}{$id} || $self -> SUPER::getmsg ($id, $language, $default_language) ; } # -------------------------------------------------------------- # -------------------------------------------------------------- sub validate { my ($self, $key, $value, $fdat, $pref) = @_ ; return $value =~ /^\s*[0-9+][0-9]*\s*$/ ? undef : ['validate_pos_number', $value] ; } # -------------------------------------------------------------- sub getscript_validate { my ($self, $arg, $pref) = @_ ; return ('obj.value.search(/^\s*[0-9+][0-9]*\s*$/) >= 0', ['validate_pos_number', "'+obj.value+'"]) ; } 1; Embperl-2.5.0/Embperl/Form/Validate/PaxHeaders.14966/EMailRFC.pm0000644000000000000000000000005012311327004022004 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/EMailRFC.pm0000644000000000000000000000312512311327004020776 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: EMailRFC.pm 1578075 2014-03-16 14:01:14Z richter $ # ################################################################################### package Embperl::Form::Validate::EMailRFC ; use base qw(Embperl::Form::Validate::EMail); # -------------------------------------------------------------- sub validate { my ($self, $key, $value, $fdat, $pref) = @_ ; # The valid address "user@tld" or local addresses are valid in this RFC conforming ruleset if ($value !~ /^[^ <>()@¡-ÿ]+@[^ <>()@¡-ÿ]+$/ or $value =~ /@(\.|.*(\.\.|@))/) { return ['validate_email', $value, $key] ; } if ($value =~ /^mailto:/i) { return ['validate_email_nomailto', $value, $key] ; } return undef ; } # -------------------------------------------------------------- sub getscript_validate { my ($self, $arg, $pref) = @_ ; return ('((obj.value.search(/^[^ <>()@¡-ÿ]+@[^ <>()@¡-ÿ]+$/) >= 0) && (obj.value.search(/@(\.|.*(\.\.|@))|mailto:/i) < 0))', ['validate_email', "'+obj.value+'"]) ; } 1; Embperl-2.5.0/Embperl/Form/Validate/PaxHeaders.14966/TimeHHMMSS.pm0000644000000000000000000000005012311327004022300 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/TimeHHMMSS.pm0000644000000000000000000000425112311327004021273 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: TimeHHMMSS.pm 1578075 2014-03-16 14:01:14Z richter $ # ################################################################################### package Embperl::Form::Validate::TimeHHMMSS ; use base qw(Embperl::Form::Validate::Default); my %error_messages = ( de => { validate_time_long => 'Feld %0: "%1" ist kein gültiges Zeitformat. Geben Sie die Zeit in der Form hh:mm:ss ein', }, 'de.utf-8' => { validate_time_long => 'Feld %0: "%1" ist kein gültiges Zeitformat. Geben Sie die Zeit in der Form hh:mm:ss ein', }, en => { validate_time_long => 'Field %0: "%1" isn\\\'t a valid time. Please enter the time as hh:mm:ss', } ); # -------------------------------------------------------------- sub getmsg { my ($self, $id, $language, $default_language) = @_ ; return $error_messages{$language}{$id} || $error_messages{$default_language}{$id} || $self -> SUPER::getmsg ($id, $language, $default_language) ; } # -------------------------------------------------------------- sub validate { my ($self, $key, $value, $fdat, $pref) = @_ ; if($value =~ /^(\d\d):(\d\d):(\d\d)$/) { if ($1 < 0 || $1 > 23 || $2 < 0 || $2 > 59 || $3 < 0 || $3 > 59) { return ['validate_time_long', $value] ; } return undef ; } return ['validate_time_long', $value] ; } # -------------------------------------------------------------- sub getscript_validate { my ($self, $arg, $pref) = @_ ; return ('obj.value.search(/^\d\d:\d\d:\d\d$/) >= 0', ['validate_time_long', "'+obj.value+'"]) ; } 1; Embperl-2.5.0/Embperl/Form/Validate/PaxHeaders.14966/Integer.pm0000644000000000000000000000005012311327004022057 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/Integer.pm0000644000000000000000000000242012311327004021046 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: Integer.pm 1578075 2014-03-16 14:01:14Z richter $ # ################################################################################### package Embperl::Form::Validate::Integer ; use base qw(Embperl::Form::Validate::Number); # -------------------------------------------------------------- sub validate { my ($self, $key, $value, $fdat, $pref) = @_ ; return $value =~ /^\s*[0-9+-][0-9]*\s*$/ ? undef : ['validate_number', $value] ; } # -------------------------------------------------------------- sub getscript_validate { my ($self, $arg, $pref) = @_ ; return ('obj.value.search(/^\s*[0-9+-][0-9]*\s*$/) >= 0', ['validate_number', "'+obj.value+'"]) ; } 1; Embperl-2.5.0/Embperl/Form/Validate/PaxHeaders.14966/Default.pm0000644000000000000000000000005012311327004022046 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/Default.pm0000644000000000000000000004312412311327004021043 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: Default.pm 1578075 2014-03-16 14:01:14Z richter $ # ################################################################################### package Embperl::Form::Validate::Default; use strict; use vars qw($VERSION %error_messages %script_functions %prefixes); $VERSION = '2.0.0' ; %script_functions = (); %prefixes = (); %error_messages = ( de => { validate_required => 'Bitte Feld "%0" ausfüllen', validate_eq => 'Falscher Inhalt "%1" des Feldes "%0": Erwartet wird "%2"', validate_same => '"%0" stimmt nicht mit "%2" überein', validate_lt => '%0 muß kleiner als %2 sein', validate_gt => '%0 muß größer als %2 sein', validate_le => '%0 muß kleiner oder gleich wie %2 sein', validate_ge => '%0 muß größer oder gleich %2 sein', validate_ne => '%0 muß ungleich %2 sein', validate_length_max => 'Inhalt des Feldes %0 ist zu lang, maximale Länge sind %2, eingegeben wurden %1 Zeichen', validate_length_min => 'Inhalt des Feldes %0 ist zu kurz, minimal Länge sind %2, eingegeben wurden %1 Zeichen', validate_length_eq => 'Inhalt des Feldes %0 hat die falsche Länge: Er sollte %2 Zeichen lang sein, ist aber %1 lang', validate_matches_regex => 'Inhalt "%1" des Feldes %0 entspricht nicht dem regulären Ausdruck /%2/', validate_matches_regex_js => 'Inhalt "%1" des Feldes %0 entspricht nicht dem regulären Ausdruck /%2/', validate_not_matches_regex => 'Inhalt "%1" des Feldes %0 darf nicht dem regulären Ausdruck /%2/ entsprechen', validate_not_matches_regex_js => 'Inhalt "%1" des Feldes %0 darf nicht dem regulären Ausdruck /%2/ entsprechen', validate_matches_wildcard => 'Inhalt "%1" des Feldes %0 entspricht nicht dem Wildcard-Ausdruck "%2"', validate_must_only_contain => 'Das Feld %0 darf nur folgende Zeichen enthalten: "%2"', validate_must_contain_one_of => 'Das Feld %0 muß mindestens eines der folgenden Zeichen enthalten: "%2"', validate_must_not_contain => 'Das Feld %0 darf folgende Zeichen nicht enthalten: "%2"' }, 'de.utf-8' => { validate_required => 'Bitte Feld "%0" ausfüllen', validate_eq => 'Falscher Inhalt "%1" des Feldes "%0": Erwartet wird "%2"', validate_same => '"%0" stimmt nicht mit "%2" überein', validate_lt => '%0 muß kleiner als %2 sein', validate_gt => '%0 muß größer als %2 sein', validate_le => '%0 muß kleiner oder gleich wie %2 sein', validate_ge => '%0 muß größer oder gleich %2 sein', validate_ne => '%0 muß ungleich %2 sein', validate_length_max => 'Inhalt des Feldes %0 ist zu lang, maximale Länge sind %2, eingegeben wurden %1 Zeichen', validate_length_min => 'Inhalt des Feldes %0 ist zu kurz, minimal Länge sind %2, eingegeben wurden %1 Zeichen', validate_length_eq => 'Inhalt des Feldes %0 hat die falsche Länge: Er sollte %2 Zeichen lang sein, ist aber %1 lang', validate_matches_regex => 'Inhalt "%1" des Feldes %0 entspricht nicht dem regulären Ausdruck /%2/', validate_matches_regex_js => 'Inhalt "%1" des Feldes %0 entspricht nicht dem regulären Ausdruck /%2/', validate_not_matches_regex => 'Inhalt "%1" des Feldes %0 darf nicht dem regulären Ausdruck /%2/ entsprechen', validate_not_matches_regex_js => 'Inhalt "%1" des Feldes %0 darf nicht dem regulären Ausdruck /%2/ entsprechen', validate_matches_wildcard => 'Inhalt "%1" des Feldes %0 entspricht nicht dem Wildcard-Ausdruck "%2"', validate_must_only_contain => 'Das Feld %0 darf nur folgende Zeichen enthalten: "%2"', validate_must_contain_one_of => 'Das Feld %0 muß mindestens eines der folgenden Zeichen enthalten: "%2"', validate_must_not_contain => 'Das Feld %0 darf folgende Zeichen nicht enthalten: "%2"' }, en => { validate_required => 'Please enter a value in %0', validate_eq => 'Wrong content "%1" of field %0: Expected "%2"', validate_same => '"%0" does not match "%2"', validate_lt => '%0 must be less then %2', validate_gt => '%0 must be greater then %2', validate_le => '%0 must be less or equal then %2', validate_ge => '%0 must be greater or equal then %2', validate_ne => 'Wrong content "%1" of field %0: Expected not "%2"', validate_length_max => 'Content of field %0 is too long, has %1 characters, maximum is %2 characters', validate_length_min => 'Content of field %0 is too short, has %1 characters, minimum is %2 characters', validate_length_eq => 'Content of field %0 has wrong length: It is %1 characters long, but should be %2 characters long', validate_matches_regex => 'Field %0 doesn"t match regexp /%2/', validate_matches_regex_js => 'Field %0 doesn"t match regexp /%2/', validate_not_matches_regex => 'Field %0 must not match regexp /%2/', validate_not_matches_regex_js => 'Field %0 must not match regexp /%2/', validate_matches_wildcard => 'Field %0 doesn"t match wildcard expression "%2"', validate_must_only_contain => 'Field %0 must contain only the following characters: "%2"', validate_must_contain_one_of => 'Field %0 must contain one of the following characters: "%2"', validate_must_not_contain => 'Field %0 must not contain the following characters: "%2"' } ); # -------------------------------------------------------------- sub new { my $invokedby = shift; my $class = ref($invokedby) || $invokedby; my $self = {} ; bless($self, $class); $self->init; return $self; } # -------------------------------------------------------------- sub getmsg { my ($self, $id, $language, $default_language) = @_ ; return $error_messages{$language}{$id} || $error_messages{$default_language}{$id} ; } # -------------------------------------------------------------- sub init { my $self = shift; return 1; } # -------------------------------------------------------------- sub validate { return undef ; } # -------------------------------------------------------------- sub validate_required { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return defined($value) && $value ne '' ? undef : ['validate_required'] ; } # -------------------------------------------------------------- sub getscript_required { my ($self, $arg, $pref) = @_ ; return ('obj instanceof NodeList?obj[0].value:obj.value', ['validate_required']) ; } # -------------------------------------------------------------- sub validate_emptyok { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return !defined($value) || $value eq '' ? [] : undef ; } # -------------------------------------------------------------- sub getscript_emptyok { my ($self, $arg, $pref) = @_ ; return ('obj.value') ; } # -------------------------------------------------------------- sub validate_checked { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return !defined($value) || $value eq '' ? undef : [] ; } # -------------------------------------------------------------- sub getscript_checked { my ($self, $arg, $pref) = @_ ; return ('obj.checked') ; } # -------------------------------------------------------------- sub validate_notchecked { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return !defined($value) || $value eq '' ? [] : undef ; } # -------------------------------------------------------------- sub getscript_notchecked { my ($self, $arg, $pref) = @_ ; return ('!obj.checked') ; } # -------------------------------------------------------------- sub validate_eq { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return $value eq $arg ? undef : ['validate_eq', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_eq { my ($self, $arg, $pref) = @_ ; return ("obj.value == '$arg'", ['validate_eq', "+'obj.value'+", $arg]) ; } # -------------------------------------------------------------- sub validate_same { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; my ($key2, $name2) = split (/:/, $arg) ; $name2 ||= $key2 ; return $value eq $fdat -> {$key2} ? undef : ['validate_same', $value, $name2] ; } # -------------------------------------------------------------- sub getscript_same { my ($self, $arg, $pref, $form) = @_ ; my ($key2, $name2) = split (/:/, $arg) ; $name2 ||= $key2 ; return ("obj.value == document.$form\['$key2'\].value", ['validate_same', "+'obj.value'+", $name2]) ; } # -------------------------------------------------------------- sub validate_gt { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return $value gt $arg ? undef : ['validate_gt', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_gt { my ($self, $arg, $pref) = @_ ; return ("obj.value > '$arg'", ['validate_gt', "+'obj.value'+", $arg]) ; } # -------------------------------------------------------------- sub validate_lt { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return $value lt $arg ? undef : ['validate_lt', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_lt { my ($self, $arg, $pref) = @_ ; return ("obj.value < '$arg'", ['validate_lt', "+'obj.value'+", $arg]) ; } # -------------------------------------------------------------- sub validate_ge { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return $value ge $arg ? undef : ['validate_ge', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_ge { my ($self, $arg, $pref) = @_ ; return ("obj.value >= '$arg'", ['validate_ge', "+'obj.value'+", $arg]) ; } # -------------------------------------------------------------- sub validate_le { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return $value le $arg ? undef : ['validate_le', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_le { my ($self, $arg, $pref) = @_ ; return ("obj.value <= '$arg'", ['validate_gt', "+'obj.value'+", $arg]) ; } # -------------------------------------------------------------- sub validate_ne { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return $value ne $arg ? undef : ['validate_ne', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_ne { my ($self, $arg, $pref) = @_ ; return ("obj.value != '$arg'", ['validate_gt', "+'obj.value'+", $arg]) ; } # -------------------------------------------------------------- sub validate_length_max { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return length($value) <= $arg ? undef : ['validate_length_max', length($value), $arg] ; } # -------------------------------------------------------------- sub getscript_length_max { my ($self, $arg, $pref) = @_ ; return ("obj.value.length <= $arg", ['validate_length_max', "'+obj.value.length+'", $arg]) ; } # -------------------------------------------------------------- sub validate_length_min { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return length($value) >= $arg ? undef : ['validate_length_min', length($value), $arg] ; } # -------------------------------------------------------------- sub getscript_length_min { my ($self, $arg, $pref) = @_ ; return ("obj.value.length >= $arg", ['validate_length_min', "'+obj.value.length+'", $arg]) ; } # -------------------------------------------------------------- sub validate_length_eq { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return length($value) == $arg ? undef : ['validate_length_eq', length($value), $arg] ; } # -------------------------------------------------------------- sub getscript_length_eq { my ($self, $arg, $pref) = @_ ; return ("obj.value.length == $arg", ['validate_length_eq', "'+obj.value.length+'", $arg]) ; } # -------------------------------------------------------------- sub validate_matches_regex { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return ($value =~ /$arg/) ? undef : ['validate_matches_regex', $value, $arg] ; } # -------------------------------------------------------------- sub validate_matches_regex_perl { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return ($value =~ /$arg/) ? undef : ['validate_matches_regex', $value, $arg] ; } # -------------------------------------------------------------- sub validate_matches_regex_js { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return undef ; # only client side! } # -------------------------------------------------------------- sub getscript_matches_regex { my ($self, $arg, $pref) = @_ ; $arg =~ s(/)(\\/)g; # JS needs / escaping return ("obj.value.search(/$arg/) >= 0", ['validate_matches_regex', "'+obj.value+'", $arg]) ; } # -------------------------------------------------------------- sub getscript_matches_regex_js { my ($self, $arg, $pref) = @_ ; $arg =~ s(/)(\\/)g; # JS needs / escaping return ("obj.value.search(/$arg/) >= 0", ['validate_matches_regex', "'+obj.value+'", $arg]) ; } # -------------------------------------------------------------- sub validate_not_matches_regex { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return ($value !~ /$arg/) ? undef : ['validate_not_matches_regex', $value, $arg] ; } # -------------------------------------------------------------- sub validate_not_matches_regex_perl { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return ($value !~ /$arg/) ? undef : ['validate_not_matches_regex', $value, $arg] ; } # -------------------------------------------------------------- sub validate_not_matches_regex_js { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; return undef ; # only client side! } # -------------------------------------------------------------- sub getscript_not_matches_regex { my ($self, $arg, $pref) = @_ ; $arg =~ s(/)(\\/)g; # JS needs / escaping return ("obj.value.search(/$arg/) < 0", ['validate_not_matches_regex', "'+obj.value+'", $arg]) ; } # -------------------------------------------------------------- sub getscript_not_matches_regex_js { my ($self, $arg, $pref) = @_ ; $arg =~ s(/)(\\/)g; # JS needs / escaping return ("obj.value.search(/$arg/) < 0", ['validate_not_matches_regex', "'+obj.value+'", $arg]) ; } # -------------------------------------------------------------- sub validate_matches_wildcard { my ($self, $key, $value, $wc, $fdat, $pref) = @_ ; $wc =~ s/=/==/g; $wc =~ s/(^|[^\\])\?/$1=./g; $wc =~ s/([^\\])\*/$1=.=*/g; $wc =~ s/([^\\])([][])/$1=$2/g; $wc =~ s/=(.)/$1/g; return ($value =~ /$wc/) ? undef : ['validate_matches_wildcard', $value, $wc] ; } # -------------------------------------------------------------- sub validate_must_only_contain { my ($self, $key, $value, $moc, $fdat, $pref) = @_ ; $moc =~ s/^\^(.)/$1^/; $moc =~ s/^(.*)\]/\]$1/; $moc =~ s/^(.*)-/-$1/; $moc =~ s#/#\\/#; return ($value =~ /^[$moc]*$/) ? undef : ['validate_must_only_contain', $value, $moc] ; } # -------------------------------------------------------------- sub getscript_must_only_contain { my ($self, $arg, $pref) = @_ ; $arg =~ s/^\^(.)/$1^/; $arg =~ s/^(.*)\]/\]$1/; $arg =~ s/^(.*)-/-$1/; $arg =~ s#/#\\/#; return ("obj.value.search(/^[$arg]*\$/) >= 0", ['validate_must_only_contain', "'+obj.value+'", $arg]) ; } # -------------------------------------------------------------- sub validate_must_not_contain { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; $arg =~ s/^\^(.)/$1^/; $arg =~ s/^(.*)\]/\]$1/; $arg =~ s/^(.*)-/-$1/; $arg =~ s#/#\\/#; return ($value !~ /[$arg]/) ? undef : ['validate_must_only_contain', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_must_not_contain { my ($self, $arg, $pref) = @_ ; $arg =~ s/^\^(.)/$1^/; $arg =~ s/^(.*)\]/\]$1/; $arg =~ s/^(.*)-/-$1/; $arg =~ s#/#\\/#; return ("obj.value.search(/[$arg]/) == -1", ['validate_must_not_contain', "'+obj.value+'", $arg]) ; } # -------------------------------------------------------------- sub validate_must_contain_one_of { my ($self, $key, $value, $arg, $fdat, $pref) = @_ ; $arg =~ s/^\^(.)/$1^/; $arg =~ s/^(.*)\]/\]$1/; $arg =~ s/^(.*)-/-$1/; $arg =~ s#/#\\/#; return ($value =~ /[$arg]/) ? undef : ['validate_must_only_contain', $value, $arg] ; } # -------------------------------------------------------------- sub getscript_must_contain_one_of { my ($self, $arg, $pref) = @_ ; $arg =~ s/^\^(.)/$1^/; $arg =~ s/^(.*)\]/\]$1/; $arg =~ s/^(.*)-/-$1/; $arg =~ s#/#\\/#; return ("obj.value.search(/[$arg]/) >= 0", ['validate_must_contain_one_of', "'+obj.value+'", $arg]) ; } # -------------------------------------------------------------- 1 ; Embperl-2.5.0/Embperl/Form/Validate/PaxHeaders.14966/FQDN_IPAddr.pm0000644000000000000000000000005012311327004022375 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/FQDN_IPAddr.pm0000644000000000000000000000427412311327004021375 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: FQDN_IPAddr.pm 1578075 2014-03-16 14:01:14Z richter $ # ################################################################################### package Embperl::Form::Validate::FQDN_IPAddr ; use base qw(Embperl::Form::Validate::Default); my %error_messages = ( de => { validate_fqdn_ipaddr => 'Feld %0: "%1" ist keine gültiger Hostname oder IP-Adresse.', }, 'de.utf-8' => { validate_fqdn_ipaddr => 'Feld %0: "%1" ist keine gültiger Hostname oder IP-Adresse.', }, en => { validate_fqdn_ipaddr => 'Field %0: "%1" isn\\\'t a valid hostname or ip-address.', } ); # -------------------------------------------------------------- sub getmsg { my ($self, $id, $language, $default_language) = @_ ; return $error_messages{$language}{$id} || $error_messages{$default_language}{$id} || $self -> SUPER::getmsg ($id, $language, $default_language) ; } # -------------------------------------------------------------- sub validate { my ($self, $key, $value, $fdat, $pref) = @_ ; if ($value =~ /^(\d+)\.(\d+).(\d+)\.(\d+)$/) { if ($1 < 0 || $1 > 255 || $2 < 0 || $2 > 255 || $3 < 0 || $3 > 255 || $4 < 0 || $4 > 255) { ; } else { return undef ; } } return undef if ($value =~ /^[-.a-zA-Z0-9]+$/) ; return ['validate_fqdn_ipaddr', $value] ; } # -------------------------------------------------------------- sub getscript_validate { my ($self, $arg, $pref) = @_ ; return ('obj.value.search(/^[-.a-zA-Z0-9]+$/) >= 0 ', ['validate_fqdn_ipaddr', "'+obj.value+'"]) ; } 1; Embperl-2.5.0/Embperl/Form/Validate/PaxHeaders.14966/IPAddr.pm0000644000000000000000000000005012311327004021565 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/IPAddr.pm0000644000000000000000000000435312311327004020563 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: IPAddr.pm 1578075 2014-03-16 14:01:14Z richter $ # ################################################################################### package Embperl::Form::Validate::IPAddr ; use base qw(Embperl::Form::Validate::Default); my %error_messages = ( de => { validate_ipaddr => 'Feld %0: "%1" ist keine gültige IP-Adresse. Geben Sie die IP-Adresse in der Form nnn.nnn.nnn.nnn ein', }, 'de.utf-8' => { validate_ipaddr => 'Feld %0: "%1" ist keine gültige IP-Adresse. Geben Sie die IP-Adresse in der Form nnn.nnn.nnn.nnn ein', }, en => { validate_ipaddr => 'Field %0: "%1" isn\\\'t a valid ip-address. Please enter the ip-address as nnn.nnn.nnn.nnn', } ); # -------------------------------------------------------------- sub getmsg { my ($self, $id, $language, $default_language) = @_ ; return $error_messages{$language}{$id} || $error_messages{$default_language}{$id} || $self -> SUPER::getmsg ($id, $language, $default_language) ; } # -------------------------------------------------------------- sub validate { my ($self, $key, $value, $fdat, $pref) = @_ ; if ($value =~ /^(\d+)\.(\d+).(\d+)\.(\d+)$/) { if ($1 < 0 || $1 > 255 || $2 < 0 || $2 > 255 || $3 < 0 || $3 > 255 || $4 < 0 || $4 > 255) { return ['validate_ipaddr', $value] ; } return undef ; } return ['validate_ipaddr', $value] ; } # -------------------------------------------------------------- sub getscript_validate { my ($self, $arg, $pref) = @_ ; return ('obj.value.search(/^\d+\.\d+.\d+.\d+$/) >= 0', ['validate_ipaddr', "'+obj.value+'"]) ; } 1; Embperl-2.5.0/Embperl/Form/Validate/PaxHeaders.14966/IPAddr_Mask.pm0000644000000000000000000000005012311327004022540 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/IPAddr_Mask.pm0000644000000000000000000000457212311327004021541 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: IPAddr_Mask.pm 1578075 2014-03-16 14:01:14Z richter $ # ################################################################################### package Embperl::Form::Validate::IPAddr_Mask ; use base qw(Embperl::Form::Validate::Default); my %error_messages = ( de => { validate_ipaddr_mask => 'Feld %0: "%1" ist keine gültige IP-Adresse/Netzmaske. Geben Sie die IP-Adresse/Netzmaske in der Form nnn.nnn.nnn.nnn/mm ein', }, 'de.utf-8' => { validate_ipaddr_mask => 'Feld %0: "%1" ist keine gültige IP-Adresse/Netzmaske. Geben Sie die IP-Adresse/Netzmaske in der Form nnn.nnn.nnn.nnn/mm ein', }, en => { validate_ipaddr_mask => 'Field %0: "%1" isn\\\'t a valid ip-address/netmask. Please enter the ip-address/netmask as nnn.nnn.nnn.nnn/mm', } ); # -------------------------------------------------------------- sub getmsg { my ($self, $id, $language, $default_language) = @_ ; return $error_messages{$language}{$id} || $error_messages{$default_language}{$id} || $self -> SUPER::getmsg ($id, $language, $default_language) ; } # -------------------------------------------------------------- sub validate { my ($self, $key, $value, $fdat, $pref) = @_ ; if ($value =~ /^(\d+)\.(\d+).(\d+)\.(\d+)\/(\d+)$/) { if ($1 < 0 || $1 > 255 || $2 < 0 || $2 > 255 || $3 < 0 || $3 > 255 || $4 < 0 || $4 > 255 || $5 < 1 || $5 > 32) { return ['validate_ipaddr_mask', $value] ; } return undef ; } return ['validate_ipaddr_mask', $value] ; } # -------------------------------------------------------------- sub getscript_validate { my ($self, $arg, $pref) = @_ ; return ('obj.value.search(/^\d+\.\d+.\d+.\d+\/\d+$/) >= 0', ['validate_ipaddr_mask', "'+obj.value+'"]) ; } 1; Embperl-2.5.0/Embperl/Form/Validate/PaxHeaders.14966/Select.pm0000644000000000000000000000005012311327004021701 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/Select.pm0000644000000000000000000000177612311327004020705 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: Select.pm 1578075 2014-03-16 14:01:14Z richter $ # ################################################################################### package Embperl::Form::Validate::Select ; use base qw(Embperl::Form::Validate::Default); # -------------------------------------------------------------- sub getscript_required { my ($self, $arg, $pref) = @_ ; return ('obj.selectedIndex != 0', ['validate_required']) ; } 1; Embperl-2.5.0/Embperl/Form/Validate/PaxHeaders.14966/TimeValue.pm0000644000000000000000000000005012311326120022353 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Validate/TimeValue.pm0000755000076400000000000000411112311326120022042 0ustar00richterroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id: Integer.pm,v 1.3 2004/01/23 06:50:57 richter Exp $ # ################################################################################### package Embperl::Form::Validate::TimeValue ; use base qw(Embperl::Form::Validate::Integer); my %error_messages = ( de => { validate_timevalue => 'Feld %0: "%1" ist keine gültige Zeit. Geben Sie eine Zahl gefolgt von s, m, h, d oder w ein.', }, 'de.utf-8' => { validate_timevalue => 'Feld %0: "%1" ist keine gültige Zeit. Geben Sie eine Zahl gefolgt von s, m, h, d oder w ein.', }, en => { validate_timevalue => 'Field %0: "%1" isn\\\'t a valid time value. Please enter a number followed by s, m, h, d or w.', } ); # -------------------------------------------------------------- sub getmsg { my ($self, $id, $language, $default_language) = @_ ; return $error_messages{$language}{$id} || $error_messages{$default_language}{$id} || $self -> SUPER::getmsg ($id, $language, $default_language) ; } # -------------------------------------------------------------- sub validate { my ($self, $key, $value, $fdat, $pref) = @_ ; return $value =~ /^\s*[0-9+][0-9]*(?:s|m|h|d|w)\s*$/ ? undef : ['validate_timevalue', $value] ; } # -------------------------------------------------------------- sub getscript_validate { my ($self, $arg, $pref) = @_ ; return ('obj.value.search(/^\s*[0-9+][0-9]*(?:s|m|h|d|w)\s*$/) >= 0', ['validate_timevalue', "'+obj.value+'"]) ; } 1; Embperl-2.5.0/Embperl/Form/PaxHeaders.14966/Control.pm0000644000000000000000000000005012311326120020347 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/Control.pm0000755000000000000000000004667512311326120017365 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::Control ; use strict ; use vars qw{%fdat} ; use Embperl::Inline ; # --------------------------------------------------------------------------- # # new - create a new control # sub new { my ($class, $args) = @_ ; my $self = { %$args } ; bless $self, $class ; $self -> init ; return $self ; } # --------------------------------------------------------------------------- # # init - init the new control # sub init { my ($self) = @_ ; my $eventattrs = '' ; if (my $e = $self -> {event}) { for (my $i = 0; $i < @$e; $i += 2) { $eventattrs .= $e -> [$i] . '="' . $e -> [$i+1] . '" ' ; } } $self -> {eventattrs} = $eventattrs ; $self -> {imagedir} ||= '/images' ; return $self ; } # --------------------------------------------------------------------------- # # noframe - do not draw frame border if this is the only control # sub noframe { return ; } # --------------------------------------------------------------------------- # # is_disabled - do not display this control at all # sub is_disabled { my ($self, $req) = @_ ; my $disable = $self -> {disable} || $req -> {form_options_masks}{$self->{name}}{disable} || $req -> {form_options_masks}{'*'}{disable} ; $disable = &{$disable}($self, $req) if (ref ($disable) eq 'CODE') ; return $disable ; } # --------------------------------------------------------------------------- # # is_blanked - display this control as blank field # sub is_blanked { my ($self, $req) = @_ ; my $disable = $self -> {blank} || $req -> {form_options_masks}{$self->{name}}{blank} || $req -> {form_options_masks}{'*'}{blank} ; $disable = &{$disable}($self, $req) if (ref ($disable) eq 'CODE') ; return $disable ; } # --------------------------------------------------------------------------- # # is_readonly - could value of this control be changed ? # sub is_readonly { my ($self, $req) = @_ ; my $readonly = $self -> {readonly} || $req -> {form_options_masks}{$self->{name}}{readonly} || $req -> {form_options_masks}{'*'}{readonly} ; $readonly = &{$readonly}($req) if (ref ($readonly) eq 'CODE') ; return $readonly ; } # --------------------------------------------------------------------------- # # is_with_id - returns true if the control shows something that has an internal id # sub is_with_id { my ($self, $req) = @_ ; return 0 ; } # --------------------------------------------------------------------------- # # is_hidden - returns true if this is a hidden control # sub is_hidden { my ($self, $req) = @_ ; return ; } # --------------------------------------------------------------------------- # # has_code_refs - returns true if is_readonly or is_disabled are coderefs # sub has_code_refs { my ($self, $req) = @_ ; return ref ($self -> {readonly}) eq 'CODE' || ref ($self -> {disable}) eq 'CODE' || ref ($self -> {blank}) eq 'CODE' ; } # --------------------------------------------------------------------------- # # code_ref_fingerprint - returns fingerprint of is_readonly and is_disabled # sub code_ref_fingerprint { my ($self, $req) = @_ ; return ($self -> is_readonly($req)?'R':'W') . ($self -> is_disabled($req)?'D':'E') . ($self -> is_blanked($req)?'B':'S') ; } # --------------------------------------------------------------------------- # # constrain_attrs - returns attrs that might change the form layout # if there value changes # sub constrain_attrs { my ($self, $req) = @_ ; return () ; } # --------------------------------------------------------------------------- # # get_on_show_code # # retuns js code that should be excuted when form becomes visible # sub get_on_show_code { return ; } # --------------------------------------------------------------------------- # # get_active_id - get the id of the value which is currently active # sub get_active_id { return ; } # --------------------------------------------------------------------------- # # form - return form object # sub form { my ($self) = @_ ; return $Embperl::FormData::forms{$self -> {formptr}} ; } # --------------------------------------------------------------------------- # # load_form - load a form to a given formptr. # # This class method should be overwritten, to load a form to a given # formptr, in case it is not already loaded # The formptr maybe passed in the options hash during form creation # # in $formptr # sub load_form { my ($class, $formptr) = @_ ; } # --------------------------------------------------------------------------- # # get_control_from_id # sub get_control_from_id { my ($class, $id) = @_ ; my ($formptr, $ctlid) = split /#/, $id ; my $form = $Embperl::FormData::forms{$formptr} ; if (!$form) { $class -> load_form ($formptr) ; $form = $Embperl::FormData::forms{$formptr} ; die "Form for '$formptr' is not available" if (!$form) ; } my $ctl = $form -> {controlids}{$ctlid} ; die "Control '$ctlid' in Form '$formptr' is not available" if (!$ctl) ; return $ctl ; } # --------------------------------------------------------------------------- # # get_id_for_control # sub get_id_for_control { my ($self, $reqdata) = @_ ; return "$self->{formptr}#$self->{id}" ; } # --------------------------------------------------------------------------- # # label_text - return text of label # sub label_text { my ($self, $req) = @_ ; my $key = 'label_text' . ($req -> {form_options}{language_fingerprint} || $req -> {form_options}{language}) ; return $self -> {$key} if ($self -> {$key}) ; return $self -> {$key} = $self -> {showtext}?($self->{text} || $self->{name}):$self -> form -> convert_label ($self, undef, undef, $req) ; } # --------------------------------------------------------------------------- # # get_validate_auto_rules - get rules for validation, in case user did # not specify any # should be overwritten by control # sub get_validate_auto_rules { my ($self, $req) = @_ ; return if (!$self -> {required}) ; return [ required => 1 ] ; } # --------------------------------------------------------------------------- # # get_validate_rules - get rules for validation # sub get_validate_rules { my ($self, $req) = @_ ; my @local_rules ; if ($self -> {validate}) { @local_rules = ( -key => $self->{name} ); push @local_rules, -name => $self -> label_text ($req); push @local_rules, @{$self -> {validate}}; } else { my $auto = $self -> get_validate_auto_rules ($req) ; if ($auto) { @local_rules = ( -key => $self->{name} ); push @local_rules, -name => $self -> label_text ($req) ; push @local_rules, @{$auto}; } } return \@local_rules ; } # --------------------------------------------------------------------------- # # has_validate_rules - check if there is anything to validate and # create auto rules # sub has_validate_rules { my ($self, $req) = @_ ; if ($self -> {validate}) { return scalar(@{$self -> {validate}}) ; } my $auto = $self -> get_validate_auto_rules ($req) ; if ($auto) { $self -> {validate} = $auto ; return scalar(@$auto) ; } $self -> {validate} = [] ; return 0 ; } # --------------------------------------------------------------------------- # # has_auto_label_size - returns true if label should be auto sized for this control # sub has_auto_label_size { return 1 ; } # --------------------------------------------------------------------------- # # get_value - return the current value for the control # if dataprefix is set, every hash key within dataprefix is tried # sub get_value { my ($self, $req) = @_ ; my $fdat = $req -> {docdata} || \%Embperl::fdat ; my $name = $self -> {srcname} || $self -> {force_name} || $self -> {name} ; return $fdat -> {$name} ; my $dataprefix = $self -> {dataprefix} ; return $fdat -> {$name} if (!$dataprefix) ; foreach my $prefix (@$dataprefix) { my $item = $prefix?$fdat -> {$prefix}{$name}:$fdat -> {$name} ; return $item if (defined ($item)) ; } return ; } # --------------------------------------------------------------------------- # # get_std_control_attr - return the default attributes for the control # # ret string with all standard attribute, already html escaped # sub get_std_control_attr { my ($self, $req, $id, $type, $addclass) = @_ ; my $name = $self -> {force_name} || $self -> {name} ; my $ctrlid = $id || ($req -> {uuid} . '_' . $name) ; my $class = $self -> {class} ; my $width = $self -> {width_percent} ; my $events = $self -> {eventattrs} ; $type ||= $self -> {type} ; my $state = $self -> {state} ; $state =~ s/[^-a-zA-Z0-9_]/_/g ; my $attrs = qq{class="ef-control ef-control-width-$width ef-control-$type ef-control-$type-width-$width $addclass $class $state" id="$ctrlid" $events} ; return wantarray?($attrs, $ctrlid, $name):$attrs ; } # ------------------------------------------------------------------------------------------ # # get_display_text - returns the text that should be displayed # sub get_display_text { my ($self, $req, $value) = @_ ; $value = $self -> get_value ($req) if (!defined ($value)) ; return $value ; } # --------------------------------------------------------------------------- # # get_id_from_value - returns id for a given value # sub get_id_from_value { #my ($self, $value) = @_ ; return ; } 1 ; # =========================================================================== __EMBPERL__ [$syntax EmbperlBlocks $] [# --------------------------------------------------------------------------- # # show - output the whole control including the label #] [$sub show ($self, $req) $fdat{$self -> {name}} = $self -> {default} if ($fdat{$self -> {name}} eq '' && exists ($self -> {default})) ; my $span = 0 ; $] [$ if ($self -> is_blanked ($req)) $] [$else$][- $span += $self -> show_label_cell ($req, $span); $self -> show_control_cell ($req, $span) ; -][$endif$]
[$ endsub $] [# --------------------------------------------------------------------------- # # show_sub_begin - output begin of sub form #] [$sub show_sub_begin ($self, $req) my $span = $self->{width_percent} ; $] [$endsub$] [# --------------------------------------------------------------------------- # # show_sub_end - output end of sub form #] [$sub show_sub_end ($self, $req) $] [$endsub$] [# --------------------------------------------------------------------------- # # show - output the label #] [$ sub show_label ($self, $req) $][- if ($self -> {showoptionslabel}) { my $opts = $self -> form -> convert_options ($self, [$self -> {value}], undef, $req) ; $self -> {text} = $opts -> [0] ; $self -> {showtext} = 1 ; } -][+ $self -> label_text ($req) +][$endsub$] [# --------------------------------------------------------------------------- # # show_label_icon - output the icon before the label #] [$sub show_label_icon ($self, $req) $] [$if $self -> {xxsublines} $] [$endif$] [$if $self -> {xxparentid} $] [$endif$] [$endsub$] [# --------------------------------------------------------------------------- # # show - output the control #] [$ sub show_label_cell ($self, $req) my $style = ''; $style = 'white-space:nowrap; ' if ($self->{labelnowrap}) ; $addclass = 'ef-label-box-width-' . ($self->{width_percent}) ; $addclass2 = 'ef-label-width-' . ($self->{width_percent}) ; $] {labelclass}" +][$ endif $]" [$ if $style $]style="[+ $style +]"[$ endif $]>
[- $self -> show_label ($req); $self -> show_label_icon ($req) ; -]
[- return $span ; -] [$endsub$] [# --------------------------------------------------------------------------- # # show_control - output the control itself #] [$ sub show_control ($self, $req) $]
get_std_control_attr($req) } +]>[+ $self->{value} +]
[$endsub$] [# --------------------------------------------------------------------------- # # show_control_readonly - output the control as readonly #] [$ sub show_control_readonly ($self, $req, $value) my $text = $self -> get_display_text ($req, $value) ; my $name = $self -> {force_name} || $self -> {name} ; $]
get_std_control_attr($req, '', 'readonly') } +] _ef_divname="[+ $name +]">[+ $text +]
[$ if $self->{hidden} $] [$endif$] [$endsub$] [# --------------------------------------------------------------------------- # # show_control_readonly_array - output the control as readonly, multiple # times in case of array #] [! sub show_control_readonly_array { my ($self, $req, $value) = @_ ; $value = $self -> get_value ($req) if (!defined ($value)) ; if (ref ($value) eq 'ARRAY') { foreach my $subval (@$value) { $self -> show_control_readonly ($req, defined ($subval)?$subval:'') ; } } else { $self -> show_control_readonly ($req, $value) ; } } !] [# --------------------------------------------------------------------------- # # show_control_addons - output additional things after the control #] [$ sub show_control_addons ($self, $req) $][$endsub$] [# --------------------------------------------------------------------------- # # show_controll_cell - output the table cell for the control #] [$ sub show_control_cell ($self, $req, $x) my $ro = $self -> is_readonly ($req) ; my $addclass = 'ef-control-box-width-' . ($self->{width_percent} || 50 ) ; $addclass .= ' ef-control-box-readonly' if ($ro) ; $] [* my @ret = $ro?$self -> show_control_readonly_array($req):$self -> show_control ($req); $self -> show_control_addons ($req) ; *] [* return @ret ; *] [$endsub$] __END__ =pod =head1 NAME Embperl::Form::Control - Base class for controls inside an Embperl Form =head1 SYNOPSIS Do not use directly, instead derive a class =head1 DESCRIPTION This class is not used directly, it is used as a base class for all controls inside an Embperl Form. It provides a set of methods that could be overwritten to customize the behaviour of your controls. =head1 METHODS =head2 new Create a new control =head2 init Init the new control =head2 noframe Do not draw frame border if this is the only control =head2 is_disabled Do not display this control at all. =head2 is_readonly Could value of this control be changed ? =head2 label_text Returns the text of the label =head2 show Output the control =head2 get_on_show_code Returns JavaScript code that should be executed when the form becomes visible =head2 get_active_id Get the id of the value which is currently active =head2 form Return the form object of this control =head2 show_sub_begin Output begin of sub form =head2 show_sub_end Output end of sub form =head2 show_label Output the label of the control =head2 show_label_icon Output the icon after the label =head2 show_label_cell Output the table cell in which the label will be displayed Must return the columns it spans (default: 1) =head2 show_control Output the control itself =head2 show_control_readonly Output the control itself as readonly =head2 show_control_addons output additional things after the control =head2 show_control_cell Output the table cell in which the control will be displayed Gets the x position as argument =head1 PARAMETERS =head3 name Specifies the name of the control =head3 text Will be used as label for the control, if not given 'name' is used as default. Normaly the the name and text parameters are processed by the method C of the C object. This method can be overwritten, to allow translation etc. If the parameter C is given a true value, C is not called and the text is displayed as it is. =head3 showtext Display label without passing it through C. See C. =head2 labelnowrap If set, the text label will not be line wrapped. =head2 labelclass If set, will be used as additional CSS classes for the label text cell. =head2 readonly If set, displays a readonly version of the control. =head2 disable If set, the control will not be displayed at all. =head2 newline If set to 1, forces a new line before the control. If set to -1, forces a new line after the control. =head2 width Gives the widths of the control. The value is C<1/width> of the the whole width of the form. So if you want to have four controls in one line set C to 4. The default value is 2. =head2 width_percent With this parameter you can also specify the width of the control in percent. This parameter take precedence over C =head2 default Default value of the control =head2 imagedir Basepath where to find images, in case the control uses images. Default value is /images =head2 trigger When set will trigger state changes of other controls. See "state". =head2 state Can be used to hide/show disable/enable the control trigger by other controls. Checkbox define the following states: =over =item * -show Show control if checkbox checked =item * -hide Hide control if checkbox checked =item * -enable Enable control if checkbox checked =item * -disable Disable control if checkbox checked =back =head1 AUTHOR G. Richter (richter at embperl dot org) =head1 SEE ALSO perl(1), Embperl, Embperl::Form Embperl-2.5.0/Embperl/Form/PaxHeaders.14966/ControlMultValue.pm0000644000000000000000000000005012323437277022231 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/ControlMultValue.pm0000755000000000000000000002671012323437277021233 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::ControlMultValue ; use strict ; use vars qw{%fdat} ; use base 'Embperl::Form::Control' ; use Embperl::Inline ; # --------------------------------------------------------------------------- # # init - Init the new control # sub init { my ($self) = @_ ; if ($self -> {datasrc}) { my $name = $self -> {datasrc} ; $name =~ s/[#\/].+$// ; my $form = $self -> form ; my $packages = $form -> get_datasrc_packages ; $self -> {datasrcobj} = $form -> new_object ($packages, $name, $self, { datarsc => $self -> {datasrc}}) ; } $self -> SUPER::init ; return $self ; } # --------------------------------------------------------------------------- # # constrain_attrs - returns attrs that might change the form layout # if there value changes # sub constrain_attrs { my ($self, $req) = @_ ; return if (!$self -> {datasrcobj}) ; return $self -> {datasrcobj} -> constrain_attrs ($req) ; } # --------------------------------------------------------------------------- # # get_all_values - returns all values and options, including addtop and addbottom # sub get_all_values { my ($self, $req) = @_ ; my $key = "all_values:$self" ; my $v ; return @$v if ($v = $req -> {$key}) ; my $addtop = $self -> {addtop} ; my $addbottom = $self -> {addbottom} ; my $values ; my $options ; my $nocache = 0 ; if ($self -> {datasrcobj}) { my $key = "all_values_datasrc:$self->{datasrcobj}" ; if (my $v = $req -> {$key}) { ($values, $options) = @$v ; } else { ($values, $options) = $self -> {datasrcobj} -> get_values ($req, $self) ; $options ||= $values ; $nocache = $self -> {datasrcobj} -> values_no_cache ; $req -> {$key} = [$values, $options] if (!$nocache) ; } } else { $values = $self -> {values} ; $options = $self -> {options} || $values ; $options = $self -> form -> convert_options ($self, $self -> {values}, $options, $req) if (!$self -> {showoptions}) ; } if (!$addtop && !$addbottom) { $req -> {$key} = [$values, $options] ; return ($values, $options) } my @values ; my @options ; if ($addtop) { push @values, map { ref $_?$_ -> [0]:$_ } @$addtop ; push @options, map { ref $_?$_ -> [1]:$_ } @$addtop ; } if ($values) { if ($addtop && $values -> [0] eq '' && $options -> [0] eq '---') { push @values, @{$values}[1..$#$values] ; push @options, @{$options}[1..$#$options] ; } else { push @values, @$values ; push @options, @$options ; } } if ($addbottom) { push @values, map { $_ -> [0] } @$addbottom ; push @options, map { $_ -> [1] } @$addbottom ; } $req -> {$key} = [\@values, \@options] if (!$nocache) ; return (\@values, \@options) ; } # --------------------------------------------------------------------------- # # get_values - returns values and options, possibly filter applied # sub get_values { my ($self, $req) = @_ ; my ($values, $options) = $self -> get_all_values ($req) ; my $filter = $self -> {filter} ; return ($values, $options) if (!$filter) ; my @values ; my @options ; my $i = 0 ; foreach (@$values) { if (/$filter/) { push @values, $_ ; push @options, $options -> [$i] ; } $i++ ; } return (\@values, \@options) ; } # --------------------------------------------------------------------------- # # get_datasource_controls - returns additional controls provided by the # datasource object e.g. a browse button # sub get_datasource_controls { my ($self, $req) = @_ ; return $self -> {datasrcobj} -> get_datasource_controls ($req, $self) if ($self -> {datasrcobj}) ; return ; } # --------------------------------------------------------------------------- # # get_id_from_value - returns id for a given value # sub get_id_from_value { my ($self, $value) = @_ ; return if (!$self -> {datasrcobj}) ; return $self -> {datasrcobj} -> get_id_from_value ($value) ; } # --------------------------------------------------------------------------- # # get_option_form_value - returns the option for a given value # # in $value value # ret option # sub get_option_from_value { my ($self, $value, $req) = @_ ; my $addtop = $self -> {addtop} ; if ($addtop) { foreach (@$addtop) { if ($_ -> [0] eq $value) { return $_ -> [1] ; } } } if ($self->{datasrc}) { my $option = $self -> {datasrcobj} -> get_option_from_value ($value, $req, $self) ; return $option if (defined ($option)) ; } elsif (ref $self -> {values}) { my $i = 0 ; foreach (@{$self -> {values}}) { if ($_ eq $value) { my $options = [$self -> {options}[$i] || $value] ; $options = $self -> form -> convert_options ($self, [$value], $options, $req) if (!$self -> {showoptions}) ; return $options -> [0] ; } $i++ ; } } my $addbottom = $self -> {addbottom} ; if ($addbottom) { foreach (@$addbottom) { if ($_ -> [0] eq $value) { return $_ -> [1] ; } } } return ; } # --------------------------------------------------------------------------- # # get_active_id - get the id of the value which is currently active # sub get_active_id { my ($self, $req) = @_ ; my $key = "active_id:$self" ; my $id ; return $id if ($id = $req -> {$key}) ; my ($values, $options) = $self -> get_values ($req) ; my $name = $self -> {name} ; my $dataval = $fdat{$name} || $values -> [0] ; my $activeid ; my $i = 0 ; foreach my $val (@$values) { if ($val eq $dataval) { $activeid = "$name-$i" ; last ; } $i++ ; } return $req -> {$key} = $activeid ; } # --------------------------------------------------------------------------- # # is_with_id - returns true if the control shows something that has an internal id # sub is_with_id { my ($self, $req) = @_ ; return 1 ; } # ------------------------------------------------------------------------------------------ # # get_display_text - returns the text that should be displayed # sub get_display_text { my ($self, $req, $value) = @_ ; $value = $self -> get_value ($req) if (!defined ($value)) ; $value = $self -> get_option_from_value ($value, $req) ; return $value ; } # --------------------------------------------------------------------------- # # init_markup - add any dynamic markup to the form data # sub init_markup { my ($self, $req, $parentctl, $method) = @_ ; return if (!$self -> is_readonly($req) && (! $parentctl || ! $parentctl -> is_readonly($req))) ; my $val = $self -> get_value ($req) ; if ($val ne '') { my $name = $self -> {name} ; my $fdat = $req -> {docdata} || \%Embperl::fdat ; $fdat -> {'_opt_' . $name} = $self -> get_option_from_value ($val, $req) ; $fdat -> {'_id_' . $name} = $self -> get_id_from_value ($val, $req) ; } } 1 ; # damit %fdat etc definiert ist __EMBPERL__ [# --------------------------------------------------------------------------- # # show_control_readonly - output the control as readonly #] [$ sub show_control_readonly ($self, $req, $value) my $text = $self -> get_display_text ($req, $value) ; my $id = $self -> get_id_from_value ($val, $req) ; my $name = $self -> {force_name} || $self -> {name} ; $]
get_std_control_attr($req, '', 'readonly', 'ef-control-with-id') } +] _ef_divname="_opt_[+ $name +]">[+ $text +]
[$ if $self->{hidden} $] [$endif$] [$endsub$] [# --------------------------------------------------------------------------- # # show_control_addons - output additional things after the control #] [$ sub show_control_addons ($self, $req) my $datasrc_ctrls ; $datasrc_ctrls = $self -> get_datasource_controls ($req) unless ($self -> {no_datasource_controls}) ; $][$if $datasrc_ctrls $] [$foreach my $ctrl (@$datasrc_ctrls) $] [$if $ctrl -> {icon} $][+ $ctrl -> {text} +][$else$][+ $ctrl -> {text} +][$endif$] [$endforeach$] [$endif$] [$endsub$] __END__ =pod =head1 NAME Embperl::Form::ControlMultValue - Base class for controls inside an Embperl Form which have multiple values to select from, like a select box or radio buttons. =head1 SYNOPSIS Do not use directly, instead derive a class =head1 DESCRIPTION This class is not used directly, it is used as a base class for all controls which have multiple values to select from inside an Embperl Form. It provides a set of methods that could be overwritten to customize the behaviour of your controls. =head1 METHODS =head2 get_values returns the values and options =head2 get_datasource_controls returns additional controls provided by the datasource object e.g. a browse button =head2 get_active_id get the id of the value which is currently active =head1 PARAMETERS =head3 values Arrayref with the values to select from. This is what gets submited back to the server. =head3 options Arrayref with the options to select from. This is what the user sees. =head3 datasrc Name of an class which provides the values for the values and options parameters. Either a full package name or a name, in which case all packages which are returned by Embperl::Form::get_datasrc_packages are searched. Everything after '#' is ignored and can be used by the DataSource module to do further selections. =head3 no_datasource_controls Disables the output of the additional controls =head1 AUTHOR G. Richter (richter at embperl dot org) =head1 SEE ALSO perl(1), Embperl, Embperl::Form, Embperl::From::Control, Embperl::Form::DataSource Embperl-2.5.0/Embperl/Form/PaxHeaders.14966/DataSource.pm0000644000000000000000000000005012311326120020761 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form/DataSource.pm0000644000000000000000000001027212311326120017754 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form::DataSource ; use strict ; # --------------------------------------------------------------------------- # # new - create a new datasource object # sub new { my ($class, $args) = @_ ; my $self = {datsrc => $args -> {datasrc}} ; bless $self, $class ; $self -> init ($args) ; return $self ; } # --------------------------------------------------------------------------- # # init - init the new datasource object # sub init { my ($self) = @_ ; return $self ; } # --------------------------------------------------------------------------- # # values_no_cache - returns true to inhibit cacheing of values during one request # sub values_no_cache { 0 } # --------------------------------------------------------------------------- # # constrain_attrs - returns attrs that might change the form layout # if there value changes # sub constrain_attrs { my ($self, $req) = @_ ; return () if (!$self -> {constrain}) ; return ($self -> {constrain}) ; } # --------------------------------------------------------------------------- # # sorttype - returns information how to sort this datasource values for displaying # sub sorttype { undef } # --------------------------------------------------------------------------- # # get_values - returns the values and options # sub get_values { my ($self, $req) = @_ ; die "Please overwrite get_values in " . ref $self ; } # --------------------------------------------------------------------------- # # get_option_from_value - returns the option for a given value # # in $value value # ret option # sub get_option_from_value { my ($self, $value, $req, $ctrl) = @_ ; my ($values, $options) = $self -> get_values ($req, $ctrl) ; my $i = 0 ; foreach (@$values) { if ($_ eq $value) { return $options -> [$i] ; } $i++ ; } return ; } # --------------------------------------------------------------------------- # # get_id_from_value - returns id for a given value # sub get_id_from_value { my ($self, $value) = @_ ; return $value ; } # --------------------------------------------------------------------------- # # get_datasource_controls - returns additional controls provided by the # datasource object e.g. a browse button # sub get_datasource_controls { my ($self, $req, $ctrl) = @_ ; return ; } 1 ; __END__ =pod =head1 NAME Embperl::Form::DataSource - Base class for data source objects which provides the data for ControlMutlValue objects. =head1 SYNOPSIS Do not use directly, instead derive a class =head1 DESCRIPTION This class is not used directly, it is used as a base class for all data source objects. It provides a set of methods that could be overwritten to customize the behaviour of your controls. =head1 METHODS =head2 get_values returns the values and options. Must be overwritten. =head3 get_id_from_value returns an id for a given value. This allow to have an id form an value/option pair which is not excat the same as the value. This is used in json requests for example for selectdyn control. =head3 get_datasource_controls returns additional controls provided by the datasource object e.g. a browse button =head1 AUTHOR G. Richter (richter at embperl dot org) =head1 SEE ALSO perl(1), Embperl, Embperl::Form, Embperl::From::ControlMultValue Embperl-2.5.0/Embperl/PaxHeaders.14966/Form.pm0000644000000000000000000000005012311326120016727 xustar000000000000000020 atime=1397643244 20 ctime=1397643307 Embperl-2.5.0/Embperl/Form.pm0000755000000000000000000011464712311326120015740 0ustar00rootroot00000000000000 ################################################################################### # # Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de # Embperl - Copyright (c) 2008-2014 Gerald Richter # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # $Id$ # ################################################################################### package Embperl::Form ; use strict ; use lib qw{..} ; use Embperl ; use Embperl::Form::Control ; use Embperl::Form::Validate ; use Embperl::Form::Control::blank ; use Embperl::Inline ; use Data::Dumper ; use Storable ; use MIME::Base64 ; our %forms ; our $form_cnt = 1 ; our %CLEANUP = ('forms' => 0) ; use vars qw{$epreq} ; # --------------------------------------------------------------------------- # # sub_new - create a new sub form # sub sub_new { my ($class, $controls, $options, $id, $toplevel, $parentptr) = @_ ; $id ||= 'topdiv' ; $options ||= {} ; $toplevel = 1 if (!defined ($toplevel)) ; my $self = ref $class?$class:{} ; $self -> {controls} = $controls ; $self -> {options} = $options ; $self -> {id} = $id ; $self -> {parentptr} = $parentptr ; $self -> {formname} = $options -> {formname} || 'topform' ; $self -> {bottom_code} = [] ; $self -> {validate_rules} = [] ; $self -> {toplevel} = $toplevel ; $self -> {checkitems} = $options -> {checkitems} ; $self -> {valign} = $options -> {valign} || 'top' ; $self -> {jsnamespace} = $options -> {jsnamespace} || '' ; $self -> {jsnamespace} .= '.' if ($self -> {jsnamespace}) ; $self -> {disable} = $options -> {disable} ; $self -> {control_packages} = $options -> {control_packages} ; $self -> {datasrc_packages} = $options -> {datasrc_packages} ; $self -> {formptr} = ($options -> {formptr} || "$self") . '/' . $id ; bless $self, $class if (!ref $class); # The following lines needs to there twice! # some weired bug in Perl? $Embperl::FormData::forms{$self -> {formptr}} = $self ; $Embperl::FormData::forms{$self -> {formptr}} = $self ; if ($toplevel) { $self -> {fields2empty} = [] ; $self -> {init_data} = [] ; $self -> {init_markup} = [] ; $self -> {prepare_fdat} = [] ; $self -> {code_refs} = [] ; $self -> {constrain_attrs} = [] ; $self -> {do_validate} = [] ; } else { $self -> {fields2empty} = $self -> parent_form -> {fields2empty} ; $self -> {init_data} = $self -> parent_form -> {init_data} ; $self -> {init_markup} = $self -> parent_form -> {init_markup} ; $self -> {prepare_fdat} = $self -> parent_form -> {prepare_fdat} ; $self -> {constrain_attrs} = $self -> parent_form -> {constrain_attrs} ; $self -> {code_refs} = $self -> parent_form -> {code_refs} ; $self -> {do_validate} = $self -> parent_form -> {do_validate} ; } push @{$self -> {code_refs}}, $self if ($self -> has_code_refs) ; $self -> new_controls ($controls, $options, undef, $id, $options -> {masks}, $options -> {defaults}) ; $self -> {noframe} = 1 if ($controls && @$controls > 0 && $controls -> [0] -> noframe) ; return $self ; } # --------------------------------------------------------------------------- # # new - create a new form # sub new { my $class = shift ; return $class -> sub_new (@_) ; } # --------------------------------------------------------------------------- # # DESTROY # sub DESTROY { my ($self) = @_ ; delete $Embperl::FormData::forms{$self -> {formptr}} ; } # --------------------------------------------------------------------------- # # get_control_packages # # returns an array ref with packges where to search for control classes # sub get_control_packages { my ($self) = @_ ; return $self -> {control_packages} || ['Embperl::Form::Control'] ; } # --------------------------------------------------------------------------- # # get_datasrc_packages # # returns an array ref with packges where to search for data source classes # sub get_datasrc_packages { my ($self) = @_ ; return $self -> {datasrc_packages} || ['Embperl::Form::DataSource'] ; } # --------------------------------------------------------------------------- # # new_object - load a control or datasrc class and create a new object of # this class # # in $packages arrayref of packages to search the class # $name name of the class. Either a full package name or # only the last part of the package. In the later # @$packages are searched for this class # ret reference to the object # sub new_object { my ($self, $packages, $name, $args) = @_ ; my $ctlmod ; my $obj ; $args ||= {} ; if ($name =~ /::/) { if (!defined (&{"$name\:\:new"})) { { local $SIG{__DIE__} ; eval "require $name" ; } if ($@) { my $modfile = $name . '.pm' ; $modfile =~ s/::/\//g ; if ($@ !~ /Can\'t locate $modfile/) { die "require $name: $@" ; } } } $obj = $name -> new ($args) ; $ctlmod = $name ; } else { foreach my $package (@$packages) { my $mod = "$package\:\:$name" ; if ($mod -> can('new')) { $obj = $mod -> new ($args) ; $ctlmod = $mod ; last ; } } if (!$ctlmod) { foreach my $package (@$packages) { my $mod = "$package\:\:$name" ; { local $SIG{__DIE__} ; eval "require $mod" ; } if ($@) { my $modfile = $mod . '.pm' ; $modfile =~ s/::/\//g ; if ($@ !~ /Can\'t locate $modfile/) { die "require $mod: $@" ; } } if ($mod -> can('new')) { $obj = $mod -> new ($args) ; $ctlmod = $mod ; last ; } } } } die "No Module found for type = $name, searched: @$packages" if (!$ctlmod || !$obj) ; return $obj ; } # --------------------------------------------------------------------------- # # new_controls - transform elements to control objects # sub new_controls { my ($self, $controls, $options, $id, $formid, $masks, $defaults, $no_init) = @_ ; my $n = 0 ; my $packages = $self -> get_control_packages ; foreach my $control (@$controls) { die "control definition must be a hashref or an object, is '$control' " if (!ref $control || ref $control eq 'ARRAY'); my $ctlid = $control->{name} ; my $q = 2 ; while (exists $self -> {controlids}{$ctlid}) { $ctlid = $control->{name} . '_' . $q ; $q++ ; } my $name = $control -> {name} ; $control -> {type} =~ s/sf_select.+/select/ ; $control -> {type} ||= ($control -> {name}?'input':'blank') ; $control -> {parentid} = $id if ($id) ; $control -> {id} ||= $ctlid ; $control -> {basename} = $control->{name} ; $control -> {formid} = $formid ; $control -> {formptr} = $self -> {formptr} ; my $type = $control -> {type} ; my $default = $defaults -> {$name} || $defaults -> {"*$type"} || $defaults -> {'*'}; my $mask = $masks -> {$name} || $masks -> {"*$type"} || $masks -> {'*'}; if ($mask) { foreach (keys %$mask) { $control -> {$_} = $mask -> {$_} ; } } if ($default) { foreach (keys %$default) { $control -> {$_} = $default -> {$_} if (!exists $control -> {$_}) ; } } if (ref $control eq 'HASH') { my $type = $control -> {type} ; $control = $self -> new_object ($packages, $type, $control) ; if (!$no_init) { push @{$self -> {init_data}}, $control if ($control -> can ('init_data')) ; push @{$self -> {init_markup}}, $control if ($control -> can ('init_markup')) ; push @{$self -> {prepare_fdat}}, $control if ($control -> can ('prepare_fdat')) ; push @{$self -> {code_refs}}, $control if ($control -> has_code_refs) ; push @{$self -> {do_validate}}, $control if ($control -> has_validate_rules) ; push @{$self -> {constrain_attrs}}, $control -> constrain_attrs ; } } $self -> {controlids}{$control->{id}} = $control ; next if ($control -> is_disabled ()) ; if ($control -> {sublines}) { my $i = 0 ; my $name = $control -> {name} ; foreach my $subcontrols (@{$control -> {sublines}}) { next if (!$subcontrols) ; $self -> new_controls ($subcontrols, $options, "$name-$i", $formid, $masks, $defaults, $no_init) ; $i++ ; } } if ($control -> {subforms}) { my @obj ; my @ids ; my $i = 0 ; foreach my $subcontrols (@{$control -> {subforms}}) { next if (!$subcontrols) ; my $ctlid = $control -> {values}[$i] || $control->{name} ; my $q = 2 ; while (exists $self -> {controlids}{$ctlid}) { $ctlid = $control->{name} . '_' . $q ; $q++ ; } my $class = ref $self ; local $options -> {disable} = $control -> {disables}[$i] ; my $subform = $class -> sub_new ($subcontrols, $options, $ctlid, 0, $self -> {formptr}) ; $subform -> {text} ||= $control -> {options}[$i] if (exists ($control -> {options}) && $control -> {options}[$i]) ; $subform -> {parent_control} = $control ; push @ids, $ctlid ; push @obj, $subform ; $i++ ; } $control -> {subobjects} = \@obj ; $control -> {subids} = \@ids ; } $n++ ; } } # --------------------------------------------------------------------------- # # parent_form - return parent form object if any # sub parent_form { my ($self) = @_ ; return $Embperl::FormData::forms{$self -> {parentptr}} ; } # --------------------------------------------------------------------------- # # add_code_at_bottom - add js code at the bottom of the page # sub add_code_at_bottom { my ($self, $code) = @_ ; push @{$self->{bottom_code}}, $code ; } # --------------------------------------------------------------------------- # # layout - build the layout of the form # sub layout { my ($self, $controls, $level) = @_ ; $controls ||= $self -> {controls} ; $level ||= 1 ; my $hidden = $self -> {hidden} ||= [] ; my $x = 0 ; my $max_x = 100 ; my $line = [] ; my @lines ; my $max_num = 0 ; my $num = 0 ; my $last_state ; foreach my $control (@$controls) { next if ($control -> is_disabled ()) ; if ($control -> is_hidden) { $control -> {width_percent} = 0 ; push @$hidden, $control ; next ; } my $width = ($control -> {width} eq 'expand')?100:$control -> {width_percent} || int($max_x / ($control -> {width} || 2)) ; #$width = 21 if ($x == 0 && $width < 21) ; if ($x + $width > $max_x || $control -> {newline} > 0 || (($control -> {sublines} || $control -> {subobjects}) && @$line)) { # new line if ($x < $max_x) { push @$line, Embperl::Form::Control::blank -> new ( {width_percent => int($max_x - $x), level => $level, x_percent => int($x), state => $last_state }) ; } push @lines, $line ; $line = [] ; $x = 0 ; $num = 0 ; } push @$line, $control ; $last_state = $control -> {state} ; $control -> {width_percent} = $control -> {width} eq 'expand'?'expand':int($width) ; $control -> {x_percent} = int($x) ; $control -> {level} = $level ; $x += $width ; $num++ ; $max_num = $num if ($num > $max_num) ; if ($control -> {subobjects} || $control -> {sublines} || $control -> {newline} < 0) { # new line if ($x < $max_x) { push @$line, Embperl::Form::Control::blank -> new ( {width_percent => int($max_x - $x), level => $level, x_percent => int($x), state => $last_state }) ; $num++ ; $max_num = $num if ($num > $max_num) ; } push @lines, $line ; $line = [] ; $x = 0 ; $num = 0 ; } if ($control -> {sublines}) { foreach my $subcontrols (@{$control -> {sublines}}) { next if (!$subcontrols) ; my $sublines = $self -> layout ($subcontrols, $level + 1) ; push @lines, @$sublines ; } } if ($control -> {subobjects}) { my @obj ; foreach my $subobj (@{$control -> {subobjects}}) { next if (!$subobj) ; $subobj -> layout ; push @$hidden, @{$subobj -> {hidden}} ; delete $subobj -> {hidden} ; } } } if ($x > 0 && $x < $max_x) { push @$line, Embperl::Form::Control::blank -> new ( {width_percent => int($max_x - $x), level => $level, x_percent => int($x), state => $last_state }) ; $num++ ; $max_num = $num if ($num > $max_num) ; } push @lines, $line if (@$line); $self -> {max_num} = $max_num ; return $self -> {layout} = \@lines ; } # --------------------------------------------------------------------------- # # show_controls - output the form control area # sub show_controls { my ($self, $req, $activeid, $options) = @_ ; if ($self -> {toplevel}) { $req -> {form_options_masks} = ($options && $options -> {masks}) || {} ; $req -> {uuid} ||= $form_cnt++ ; @{$self -> {fields2empty}} = () ; } my $lines = $self -> {layout} ; my %n ; my $activesubid ; my @activesubid ; $self -> show_controls_begin ($req, $activeid) ; my $lineno = 0 ; foreach my $line (@$lines) { my $linelevel = @$line?$line->[0]{level}:0 ; my $lineid = @$line && $line->[0]{parentid}?"$line->[0]{parentid}":'id' ; $n{$lineid} ||= 10 ; my $visible = $self -> show_line_begin ($req, $lineno, "$lineid-$n{$lineid}", $activesubid[$linelevel-1] || $activeid); foreach my $control (@$line) { # my $newactivesubid = $control -> {subobjects} && $visible?$control -> get_active_id ($req):'-' ; my $newactivesubid = ($control -> {subobjects} || $control -> {sublines}) && $visible?$control -> get_active_id ($req):'' ; $control -> show ($req) if (!$control -> is_disabled ($req)) ; $activesubid[$control -> {level}] = $newactivesubid if ($newactivesubid) ; if ($control -> {subobjects}) { my @obj ; $control -> show_sub_begin ($req) ; foreach my $subobj (@{$control -> {subobjects}}) { next if (!$subobj || !$subobj -> {controls} || !@{$subobj -> {controls}} || $subobj -> is_disabled ($req)) ; $subobj -> show ($req, $activesubid[$control -> {level}]) ; } $control -> show_sub_end ($req) ; } } $self -> show_line_end ($req, $lineno); $lineno++ ; $n{$lineid}++ ; } $self -> show_controls_end ($req) ; $self -> show_controls_hidden ($req) if ($self -> {hidden}) ; $self -> show_checkitems ($req) if ($self -> {checkitems} && $self -> {toplevel}) ; return ; } # --------------------------------------------------------------------------- # # init_validate - init validate functions # sub init_validate { my ($self, $req, $options) = @_ ; if ($self -> {toplevel}) { my $epf = $self -> {validate} ; if (!defined ($epf)) { my @validate_rules ; foreach my $control (@{$self -> {do_validate}}) { push @validate_rules, $control -> get_validate_rules ($req) ; } if (@validate_rules) { $epf = $self -> {validate} = Embperl::Form::Validate -> new (\@validate_rules, $self -> {formname}, $options -> {language}, $options -> {charset}) ; $self -> add_code_at_bottom ($epf -> get_script_code) ; } else { $self -> {validate} = 0 ; } } } return $self -> {validate}?1:0 ; } # --------------------------------------------------------------------------- # # show - output the form # sub show { my ($self, $req, $activeid, $options) = @_ ; if ($self -> {toplevel}) { $self -> init_validate ($req, $options) ; $self -> init_data ($req) ; $self -> show_form_begin ($req) ; } #$self -> validate ($req) if ($self -> {toplevel}); $self -> show_controls ($req, $activeid, $options) ; $self -> show_form_end ($req) if ($self -> {toplevel}); } # --------------------------------------------------------------------------- # # init_data - init fdat before showing # sub init_data { my ($self, $req, $options) = @_ ; if ($self -> {toplevel} && $options) { $req -> {form_options_masks} = ($options && $options -> {masks}) || {} ; } foreach my $control (@{$self -> {init_data}}) { $control -> init_data ($req) if (!$control -> is_disabled ($req)) ; } } # --------------------------------------------------------------------------- # # init_markup - add any dynamic markup to the form data # sub init_markup { my ($self, $req, $parentctl, $method, $options) = @_ ; if ($self -> {toplevel} && $options) { $req -> {form_options_masks} = ($options && $options -> {masks}) || {} ; } foreach my $control (@{$self -> {init_markup}}) { $control -> init_markup ($req, $parentctl, $method) if (!$control -> is_disabled ($req)) ; } } # --------------------------------------------------------------------------- # # prepare_fdat - change fdat after submit # sub prepare_fdat { my ($self, $req, $options) = @_ ; if ($self -> {toplevel} && $options) { $req -> {form_options_masks} = ($options && $options -> {masks}) || {} ; } foreach my $control (@{$self -> {prepare_fdat}}) { $control -> prepare_fdat ($req) if (!$control -> is_disabled ($req)) ; } } # --------------------------------------------------------------------------- # # is_disabled - do not display this control at all # sub is_disabled { my ($self, $req) = @_ ; my $disable = $self -> {disable} ; $disable = &{$disable}($self, $req) if (ref ($disable) eq 'CODE') ; return $disable ; } # --------------------------------------------------------------------------- # # has_code_refs - returns true if is_readonly or is_disabled are coderefs # sub has_code_refs { my ($self, $req) = @_ ; return ref ($self -> {disable}) eq 'CODE' ; } # --------------------------------------------------------------------------- # # code_ref_fingerprint - returns fingerprint of is_disabled # sub code_ref_fingerprint { my ($self, $req) = @_ ; return ($self -> is_disabled($req)?'D':'E') ; } # --------------------------------------------------------------------------- # # all_code_ref_fingerprints - returns a fingerprint of the result of all code refs # can be used to check if is_readonly or is_disabled # has dynamicly changed # sub all_code_ref_fingerprints { my ($self, $req) = @_ ; my $fp ; foreach my $control (@{$self -> {code_refs}}) { $fp .= $control -> code_ref_fingerprint ($req) ; } return $fp ; } # --------------------------------------------------------------------------- # # constrain_attrs - returns attrs that might change the form layout # if there value changes # sub constrain_attrs { my ($self, $req) = @_ ; return $self -> {constrain_attrs} ; } # --------------------------------------------------------------------------- # # validate - validate the form input # sub validate { my ($self, $fdat, $pref, $epreq) = @_ ; my $validate = $self -> {validate} ; my $result = $validate -> validate ($fdat, $pref, $epreq) ; my @msgs ; foreach my $err (@$result) { my $msg = $validate -> error_message ($err, $pref, $epreq) ; push @msgs, $msg ; } return ($result, \@msgs) ; } #------------------------------------------------------------------------------------------ # # add_tabs # # fügt ein tab element mit subforms zu einem Formular hinzu # wird nur eine Subform übergeben, werden nur diese Felder zurückgeliefert # ohne tabs # # in $subform array mit hashs # text => # fn => Dateiname # fields => Felddefinitionen (alternativ zu fn) # $args wird an fields funktionen durchgereicht # $tabs_per_line anzahl tabs pro Zeile # sub add_tabs { my ($self, $subforms, $args, $tabs_per_line) = @_ ; my @forms ; my @values ; my @options ; my @grids; $args ||= {} ; foreach my $file (@$subforms) { my $fn = $file -> {fn} ; my $subfields = $file -> {fields} ; push @options, $file -> {text}; if ($fn) { my $obj = Execute ({object => $fn} ) ; $subfields = $obj -> fields ($epreq, {%$file, %$args}) ; } push @forms, $subfields; push @grids, $file -> {grid}; push @values, $file -> {value} ||= scalar(@forms); } if (@forms == 1) { return @{$forms[0]} ; } return { section => 'cSectionText', name => '__auswahl', type => 'tabs', values => \@values, grids => \@grids, options => \@options, subforms=> \@forms, width => 1, 'tabs_per_line' => $tabs_per_line, }, } #------------------------------------------------------------------------------------------ # # add_line # # adds the given controls into one line # # sub add_line { my ($self, $controls, $cnt) = @_ ; $cnt ||= @$controls ; foreach my $control (@$controls) { $control -> {width} = $cnt ; } return @$controls ; } #------------------------------------------------------------------------------------------ # # add_sublines # # fügt ein tab elsement mit subforms zu einem Formular hinzu # # in $subform array mit hashs # text => # fn => Dateiname # fields => Felddefinitionen (alternativ zu fn) # sub add_sublines { my ($self, $object_data, $subforms, $type) = @_; $object_data ||= {} ; $object_data -> {text} ||= $object_data -> {name} ; my @forms ; my @values ; my @options ; foreach my $file (@$subforms) { my $fn = $file -> {fn} ; my $subfields = $file -> {fields} ; if ($fn) { my $obj = Execute ({object => "$fn"} ) ; $subfields = $obj -> fields ($epreq, $file) ; } $subfields ||= [] ; foreach (@$subfields) { $_ -> {state} = $object_data -> {name} . '-show-' . ($file->{value} || $file->{name}) ; } push @forms, $subfields ; push @values, $file->{value} || $file->{name}; push @options, $file -> {text} || $file->{value} || $file->{name}; } $object_data -> {trigger} = 1 ; return { %$object_data, type => $type || 'select', values => \@values, options => \@options, sublines => \@forms, }; } #------------------------------------------------------------------------------------------ # # fields_add_checkbox_subform # # fügt ein checkbox Element mit Subforms hinzu # # in $subform array mit hashs # text => # name => # value => # fn => Dateiname # fields => Felddefinitionen (alternativ zu fn) # sub add_checkbox_subform { my ($self, $subform, $args) = @_ ; $args ||= {} ; my $name = $subform->{name}; my $text = $subform->{text}; my $value = $subform->{value} || 1 ; my $width = $subform->{width}; my $section; if(! $subform->{nosection}) { $section = $subform->{section}; $section ||= 1; } $name ||= "__$value"; $width ||= 1; my $subfield; my $fn; if($subfield = $subform->{fields}) { # .... ok } elsif($fn = $subform->{fn}) { my $obj = Execute ({object => "./$fn"} ) ; #$subfield = [eval {$obj -> fields ($r, { %$file, %$args} ) || undef}]; } my $subfields = $subfield -> [0] ; foreach (@$subfields) { $_ -> {state} = $subform -> {name} . '-show' ; } $subfields = $subfield -> [1] ; foreach (@$subfields) { $_ -> {state} = $subform -> {name} . '-hide'; } return {type => 'checkbox' , trigger => 1, section => $section, width => $width, name => $name, text => $text, value => $value, sublines => $subfield} } #------------------------------------------------------------------------------------------ # # convert_label # # converts the label of a control to the text that should be outputed. # By default does return the text or name parameter of the control. # Can be overwritten to allow for example internationalization. # # in $ctrl Embperl::Form::Control object # $name optional: name to translate, if not given take $ctrl -> {text} # sub convert_label { my ($self, $ctrl, $name, $text, $req) = @_ ; return $text || $ctrl->{text} || $name || $ctrl->{name} ; } #------------------------------------------------------------------------------------------ # # convert_options # # converts the values/options of a control to the text that should be outputed. # By default does nothing. # Can be overwritten to allow for example internationalization. # # in $ctrl Embperl::Form::Control object # $values values of the control i.e. values that are submitted # $options options of the control i.e. text that should be displayed # sub convert_options { my ($self, $ctrl, $values, $options, $req) = @_ ; return $options ; } #------------------------------------------------------------------------------------------ # # convert_text # # converts the text of a controls like transparent to the text that should be outputed. # By default does nothing. # Can be overwritten to allow for example internationalization. # # in $ctrl Embperl::Form::Control object # $value value that is shown # sub convert_text { my ($self, $ctrl, $value, $text, $req) = @_ ; return $value || $ctrl->{text} || $ctrl->{name} ; } #------------------------------------------------------------------------------------------ # # diff_checkitems # # Takes the posted form data and the checkitems, compares them and return the # fields that have changed # # in $check optional: arrayref with fieldnames that should be checked # ret \%diff fields that have changed # sub diff_checkitems { my ($self, $check) = @_ ; my %diff ; my $checkitems = eval { Storable::thaw(MIME::Base64::decode ($Embperl::fdat{-checkitems})) } ; foreach ($check?@$check:keys %Embperl::fdat) { next if ($_ eq '-checkitems') ; $diff{$_} = 1 if ($checkitems -> {$_} ne $Embperl::fdat{$_}) ; } return \%diff ; } 1; __EMBPERL__ [$syntax EmbperlBlocks $] [# --------------------------------------------------------------------------- # # show_form_begin - output begin of form #] [$ sub show_form_begin ($self, $req) $]
{on_submit_function}) $] onSubmit="s=[+ $self->{on_submit_function} +];if (s) { v=doValidate; doValidate=1; return ((!v) || epform_validate_[+ $self->{formname} +]()); } else { return false; }" [$else$] onSubmit="v=doValidate; doValidate=1; return ( (!v) || epform_validate_[+ $self->{formname}+]());" [$endif$] > [$endsub$] [# --------------------------------------------------------------------------- # # show_form_end - output end of form #] [$ sub show_form_end ($req) $]
[$endsub$] [ --------------------------------------------------------------------------- # # show_controls_begin - output begin of form controls area #] [$ sub show_controls_begin ($self, $req, $activeid) my $parent = $self -> parent_form ; my $class = $self -> {options}{classdiv} || ($parent -> {noframe}?'ef-tabs-border-u':'ef-tabs-border') ; my $parent_control = $self -> {parent_control} ; $] [$if $parent_control && $parent_control -> can('show_subform_controls_begin') $] [- $parent_control -> show_subform_controls_begin ($self, $req, $activeid) -] [$else$]
{id} ne $activeid) $] style="display: none" [$endif$] > [$if (!$self -> {noframe}) $]
[$endif$] [$endif$] [$endsub$] [# --------------------------------------------------------------------------- # # show_controls_end - output end of form controls area #] [$sub show_controls_end ($self, $req) my $parent_control = $self -> {parent_control} ; $] [$if $parent_control && $parent_control -> can('show_subform_controls_end') $] [- $parent_control -> show_subform_controls_end ($self, $req) -] [$else$] [$ if (!$self -> {noframe}) $]
[$endif$]
[$endif$] [$ if (@{$self->{bottom_code}}) $] [$endif$] [$ if ($self -> {toplevel} && @{$self -> {fields2empty}}) $] [$endif$] [$endsub$] [# --------------------------------------------------------------------------- # # show_controls_hidden - output hidden controls and the end of form #] [$sub show_controls_hidden ($self, $req) $] [$ foreach my $ctl (@{$self->{hidden}}) $] [- $ctl -> show ($req) ; -] [$ endforeach $] [$endsub$] [# --------------------------------------------------------------------------- # # show_checkitems - output data to allow verifying if any data has changed #] [$sub show_checkitems ($self, $req) my $checkitems = MIME::Base64::encode (Storable::freeze (\%idat)) ; $] [$endsub$] [# --------------------------------------------------------------------------- # # show_line_begin - output begin of line #] [$ sub show_line_begin ($self, $req, $lineno, $id, $activeid) my $baseid ; my $baseidn ; my $baseaid ; my $baseaidn ; if ($id =~ /^(.+)-(\d+?)-(\d+?)$/) { $baseid = $1 ; $baseidn = $2 ; } if ($activeid =~ /^(.+)-(\d+?)$/) { $baseaid = $1 ; $baseaidn = $2 ; } my $class = $lineno == 0?'cTableRow1':'cTableRow' ; $] [# #][* return !($activeid eq '-' || ($baseid eq $baseaid && $baseidn != $baseaidn)) *][$endsub$] [# --------------------------------------------------------------------------- # # show_line_end - output end of line #] [$ sub show_line_end ($req) $][$endsub$] __END__ =pod =head1 NAME Embperl::Form - Embperl Form class =head1 SYNOPSIS =head1 DESCRIPTION =head1 METHODS =head2 new ($controls, $options) =over 4 =item * $controls Array ref with controls which should be displayed inside the form. Each control needs either to be a hashref with all parameters for the control or a control object. If hash refs are given it's necessary to specify the C parameter, to let Embperl::Form know which control to create. See Embperl::Form::Control and Embperl::Form::Control::* for a list of available parameters. =item * $options Hash ref which can take the following parameters: =over 4 =item * formname Will be used as name and id attribute of the form. If you have more then one form on a page it's necessary to have different form names to make form validation work correctly. =item * masks Contains a hash ref which can specify a set of masks for the controls. A mask is a set of parameter which overwrite the setting of a control. You can specify a mask for a control name (key is name), for a control type (key is *type) or for all controls (key is *). Example: { 'info' => { readonly => 1}, '*textarea' => { cols => 80 }, '*' => { labelclass => 'myclass', labelnowrap => 1} } This will force the control with the name C to be readonly, it will force all C
[+$regs[$row]{Id}+]

[+$kats[$row]{Id}+]
ks = [+ do { @ks = sort keys %idat ; "@ks" } +]

[+ $ks[$i=$row] +][+ $idat{$ks[$i] || ''} +]
[- @ksall = qw{Wert1 Wert2 Wert3 Wert4 Wert5 Wert6 Wert7 Wert8} ; -] [$ foreach $i (1,5,2,6) $] [$endforeach$] [$ foreach $i (1,5,2,6) $] [$endforeach$] [- @order = (1,5,2,6) -]
[- $fdat{ta} = 'blabla' -]
[$ foreach $i (5,2,6,1) $]

i = [+ $i +] fdat{feld5} [+ $fdat{feld5} +]

[$endforeach$] ks = [+ do { @ks = sort keys %idat ; "@ks" } +]

[+ $ks[$i=$row] +][+ $idat{$ks[$i] || ''} +]
[- @empty = () -] Embperl-2.5.0/test/html/PaxHeaders.14966/subout.htm0000644000000000000000000000005012023276646020077 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/subout.htm0000644000076400000000000000173512023276646017574 0ustar00richterroot00000000000000 Tests for Embperl - Embperl sub Metacommand 2 [###### sub 1 #####] [$sub txt1$] *txt* *txt*

[+ "h2" +]

*txt* [$endsub$] [###### sub 2 #####] [$sub txt2$] *txt2* *txt2*

Here goes some normal html text

*txt2* [- txt1 -] *txt2* after txt1 [$endsub$] [###### sub 3 #####] [$sub txt3$] [- txt2 -] *txt3* after txt3 [$endsub$] [###### sub 4 #####] [$sub txt4$] [- txt1 -] [$endsub$] [###### sub 5 #####] [$sub txt5$] [+ "sub 5" +] [$endsub$] [###### sub 6 #####] [$sub txt6$] [- print OUT "sub 6\n" -] [$endsub$] [###### sub 7 #####] [$sub txt7$] [- txt5 -] [+ "sub 7" +] [$endsub$] [###### sub 8 #####] [$sub txt8$] [- txt6 -] [- print OUT "sub 8\n" -] [$endsub$]

Tests for Embperl - Embperl sub Metacommand output

*1 [- txt1 -] *2 [- txt2 -] *3 [- txt1 -] [- txt2 -] *1+2 [- txt1 ; txt2 -] [- txt1 ; txt2 -] ----> txt3 [- txt3 -] *4 [- txt4 -] *5 [- txt5 -] *6 [- txt6 -] *7 [- txt7 -] *8 [- txt8 -] Embperl-2.5.0/test/html/PaxHeaders.14966/nochdir0000644000000000000000000000005012323454053017406 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/nochdir/0000755000000000000000000000000012323454053016454 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/nochdir/PaxHeaders.14966/nochdir.htm0000644000000000000000000000005012023276646021632 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/nochdir/nochdir.htm0000644000076400000000000000112012023276646021313 0ustar00richterroot00000000000000 Some tests for Embperl [- use Cwd (); -] optDisableChdir:[+ $optDisableChdir +]
optDisableFormData: [+ $optDisableFormData +]
Script CWD: [+ $script = Cwd::fastcwd() +]
Embperl CWD: [+ $ep = $HTML::Embperl::cwd +]
Equal: [+ $script eq $ep?'Yes':'No' +]
Diff CWD: [+ do { $script =~ /$ep/ ; ">$'<" } +]
Test/html: [+ $script =~ /test(?:\/|\\)html$/?'yes':'no' +] [- @ks = sort keys %fdat -]
[+ $ks[$row] +][+ $fdat{$ks[$row] || ''} +]
Embperl-2.5.0/test/html/PaxHeaders.14966/unclosed.htm0000644000000000000000000000005012023276646020372 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/unclosed.htm0000755000076400000000000000015412023276646020064 0ustar00richterroot00000000000000 Tests for Embperl - Unclosed if [$ if 1 $] Embperl-2.5.0/test/html/PaxHeaders.14966/error.htm0000644000000000000000000000005012023276646017707 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/error.htm0000644000076400000000000000176112023276646017403 0ustar00richterroot00000000000000 Some Plain tests for Embperl Here it starts with some HTML Text

All values should be undefined: $a = [+ $a +]
$b = [+ $b +]
$c = [+ $c +]
$d = [+ $d +]
$e = [+ $e +]
Here we will see an error: [- $a = (qqqqqqqqqqqqqq -] First of all assign a value: [- $a = '(this is the value in $a)' -]
Now we have some 'Umlaute': [- $b = "$a äöü" -] Second Error:
[+ $a+ +] [+ qq2$b +]
And now a and b together: [+ "$a$b" +]

Here we have some HTML tags within the perl code, Embperl will delete them!
[+ $c =
6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
[- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value [$if {$error is here ) $] $a = [+ $a +]
$b = [+ $b +]
$c = [+ $c +]
$d = [+ $d +]
$e = [+ $e +]
[$endif$]

Ok.

Embperl-2.5.0/test/html/PaxHeaders.14966/inputjava.htm0000644000000000000000000000005012023276646020557 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/inputjava.htm0000644000076400000000000000343212023276646020250 0ustar00richterroot00000000000000 [- $s = "script.htm" -] [$ if (($fdat{'Screen'} || 0) != 1) $]

Screen 1
[$ else $]
Screen 2
[$ endif $] Embperl-2.5.0/test/html/PaxHeaders.14966/setunknownsess.htm0000644000000000000000000000005012023276646021667 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/setunknownsess.htm0000644000076400000000000000033112023276646021353 0ustar00richterroot00000000000000 Tests for Embperl - Set Session Data (unknown cookie) [- while (($k, $v) = each (%fdat)) { $udat{$k} = $fdat{$k} ; } -] [+ $udat{_session_id} +] Embperl-2.5.0/test/html/PaxHeaders.14966/var.htm0000644000000000000000000000005012023276646017346 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/var.htm0000644000076400000000000000215012023276646017033 0ustar00richterroot00000000000000 Some Plain tests for Embperl [$VAR $a $b $c $d $e $] Here it starts with some HTML Text

All values should be undefined: $a = [+ $a || '' +]
$b = [+ $b || '' +]
$c = [+ $c || '' +]
$d = [+ $d || '' +]
$e = [+ $e || '' +]
First of all assign a value: [- $a = '(this is the value in $a)' -]
Now we have some 'Umlaute': [- $b = "$a äöü" -] Now lets look what we are getting from this:
[+ $a +] [+ $b +]
And now a and b together: [+ "$a$b" +]

Here we have some HTML tags within the perl code, Embperl will delete them!
[+ $c =
6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
[- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value $a = [+ $a +]
$b = [+ $b +]
$c = [+ $c +]
$d = [+ $d +]
$e = [+ $e +]

Ok.

[# This is an Embperl comment it will totaly removed from the html source #] [# [+ "blabla" +] it will also hide perl code #] Embperl-2.5.0/test/html/PaxHeaders.14966/exitreq.htm0000644000000000000000000000005012023276646020237 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/exitreq.htm0000644000076400000000000000027412023276646017731 0ustar00richterroot00000000000000 Tests for Embperl - request exit Before Exit Main [- Execute('exitsub.htm', 200) -] After Exit Main [+ "perl after exit main" +] Embperl-2.5.0/test/html/PaxHeaders.14966/getbsess.htm0000644000000000000000000000005012023276646020375 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/getbsess.htm0000644000076400000000000000176212023276646020072 0ustar00richterroot00000000000000 Tests for Embperl - Set Session Data fdat:
[- @ks = sort keys %fdat -]
[+ $ks[$row] +][+ $fdat{$ks[$row] || ''} +]
udat:
[- $off = 0 ; $off-- if ($HTML::Embperl::SessionMgnt == 2 && !defined (tied (%udat) -> getid)) ; -] [- @ks = grep (!/^_/, sort (keys %udat)) ; $num = keys (%udat) - $#ks - 1 + $off ; -]
[+ $ks[$row] +][+ $udat{$ks[$row] || ''} +]
[+ $num > 0?"ok (num=$num)":"Not a session hash (num=$num)" +]

[- while (($k, $v) = each (%fdat)) { $udat{$k} = $fdat{$k} ; } -] $mdat{cnt} = -[+ $mdat{cnt} +]-
$udat{cnt} = -[+ $udat{cnt} +]-
[- $s = $Apache::Session::Win32::sessions || $Apache::Session::MemoryStore::store -] [- @ks = sort keys %$s -] sessions:
[+ $ks[$row] +][+ $s -> {$ks[$row] || ''} +]
Embperl-2.5.0/test/html/PaxHeaders.14966/table.htm0000644000000000000000000000005012023276646017645 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/table.htm0000644000076400000000000001414712023276646017343 0ustar00richterroot00000000000000 HTML table tag in Embperl

$tabmode = default

Display an two dimensional array with one, two and three columns !
Please take a look at the source in your browser to see the difference
[- undef @a ; undef @b ; $a[0][0] = 'a1/1' ; $a[1][0] = 'a2/1' ; $a[1][1] = 'a2/2' ; $a[2][0] = 'a3/1' ; $a[2][1] = 'a3/2' ; $a[2][2] = 'a3/3' ; $b[0][0] = 'b1/1' ; $b[1][0] = 'b2/1' ; $b[1][1] = 'b2/2' ; $b[2][0] = 'b3/1' ; $b[2][1] = 'b3/2' ; $b[2][2] = 'b3/3' ; $maxcol=99 ; -] $a[0][[0] = '1/1' ;
$a[1][[0] = '2/1' ;
$a[1][[1] = '2/2' ;
$a[2][[0] = '3/1' ;
$a[2][[1] = '3/2' ;
$a[2][[2] = '3/3' ;

$tabmode = default

[+ $a[$row][0] +]
[+ $a[2][$col] +]
before[+ $a[$row][0] +]
before[+ $a[2][$col] +]
[+ $a[$row][0] +]after
[+ $a[2][$col] +]after
before[+ $a[$row][0] +]after
before[+ $a[2][$col] +]after
[+ $c[$row] +]
[+ $c[$col] +]
[+ $a[$row][$col] +]
[+ $b[$row][$col] +]
[+ $a[$row][$col] +]
[+ $b[2][$col] +]
[+ $a[2][$col] +]
[+ $a[$row+1][0] +]
[+ $a[$row][0] +]
[+ $a[$rows+1][0] +]
[+ $a[$rows][0] +]
[+ $rows +]
[+ $a[$row][$col] +]
[- $a[0][1] = 'a1/2' ; -]
[+ $a[$row*2][$col*2] +] [+ $a[$row*2][$col*2+1] +]
[+ $a[$row*2+1][$col*2] +] [+ $a[$row*2+1][$col*2+1] +]
[- $a[0][1] = undef ; -] [- undef @regs ; undef @kats ; $regs[0]{Id} = 'Pfalz' ; $regs[1]{Id} = 'Rheinhessen' ; $kats[0]{Id} = 'Kultur' ; $kats[1]{Id} = 'Sport' ; -]
[+$regs[$row]{Id}+]

[+$kats[$row]{Id}+]
[- $kats[2]{Id} = 'Veranstaltungen' ; $kats[3]{Id} = '' ; -]
[$endif$]
[- print LOG "row= $row regs=$regs[0]{Id}\n" ; 1 ; -] [- print LOG "1row= $row regs=$regs[0]{Id}\n" ; $cmp = $regs[0]->{Id} ; print LOG "2row= $row regs=$regs[0]{Id}\n" ; 1 ; -] [- while (($k, $v) = each (%{$regs[0]})) { print LOG "$v=$k;\n" ; } -] [$if ($cmp || '') ne '' $] [+$regs[$row]{Id}+]

[- print LOG "row= $row regs=$kats[0]{Id}\n" ; 1 ; -] [- $cmp = $kats[$row]{Id} -] [$if ($cmp || '') ne '' $] [+$kats[$row]{Id}+]

[$endif$]
[- # build tight loop table with array data, multidimensional 5x6 @array = sort ("Hello", "World", "2000", "Hello", "World", "2000"); @multi = (\@array, \@array, \@array, \@array, \@array); -]
[+ $multi[$row][$col] +]
[+ $a[$row][0] +]
[+ $a[2][$col] +]
[+ $a[$row][$col] +]
[+ $a[$icon_height=$row][0] +] [- $icon_width = 5 ; -] iit logo
[+ $a[$row][0] +]
[+ $a[2][$col] +]
Embperl-2.5.0/test/html/PaxHeaders.14966/include.htm0000644000000000000000000000005012023276646020201 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/include.htm0000755000076400000000000000672412023276646017704 0ustar00richterroot00000000000000 Embperl Tests - Include other Embperl pages via Execute

Embperl Tests - Include other Embperl pages via Execute

[- $optRawInput = 1 -] [- $tst1 = '

Here is some text

' ; -]

1.) Include from memory

[- Execute ({input => \$tst1, mtime => 1, inputfile => 'Some text', }) ; -]

2.) Include from memory with some Embperl code

[- Execute ({input => \('[- @ar = (a1, b2, c3) -' . ']
[+$ar[$col]+]

'), mtime => 1, inputfile => 'table', }) ; -]

3.) Include from memory with passing of variables

[- $MyPackage::Interface::Var = 'Some Var' ; -] [- Execute ({input => \'

Transfer some vars [+ $Var +] !

', inputfile => 'Var', mtime => 1, 'package' => 'MyPackage::Interface', }) ; -]

4.) Change the variable, but not the code

[- $MyPackage::Interface::Var = 'Do it again' ; # code is the same, so give the same mtime and inputfile to avoid recompile # Note you get problems is you change the code, but did not restart the server or # change the value in mtime. So make sure if you change something also change mtime! Execute ({input => \'

Transfer some vars [+ $Var +] !

', inputfile => 'Var2', mtime => 1, 'package' => 'MyPackage::Interface', req_rec => $req_rec}) ; -]

5.) Use \@param to pass parameters

[- Execute ({input => \'

Use @param to transfer some data ([+ "@param" +]) !

', inputfile => 'Param', param => [1, 2, 3, 4] } ) ; -]

6.) Use \@param to pass parameters and return it

[- @p = ('vara', 'varb') ; -]

$p[0] is [+ $p[0] +] and $p[1] is [+ $p[1] +]

[- Execute ({input => \('

Got data in @param ([+ "@param" +]) !

[- $param[0] = "newA" ; $param[1] = "newB" ; -' . ']

Change data in @param to ([+ "@param" +]) !

'), inputfile => 'Param & Return', req_rec => $req_rec, param => \@p } ) ; -]

$p[0] is now [+ $p[0] +] and $p[1] is now [+ $p[1] +]

7.) Presetup \%fdat and \@ffld

[- %myfdat = ('test' => 'value', 'fdat' => 'text') ; @myffld = sort keys %myfdat ; Execute ({input => \'

[+ $ffld[$row] +][+ do { local $^W = 0 ; $fdat{$ffld[$row]} } +]

', inputfile => 'fdat & ffld', req_rec => $req_rec, fdat => \%myfdat, ffld => \@myffld} ) ; -]

8a.) Include a file

[- Execute ('inc.htm') -]

8b.) Include again the same file

[- Execute ('inc.htm') -]

9.) Include a file and return output in a scalar

[- Execute ({inputfile => 'inc.htm', output => \$out, req_rec => $req_rec}) ; -]

[+ $out +]

10.) Include inside a table

[- @a = ('m1', 'm2', 'm3') -]
[+ $a[$row] +] : [- Execute ({inputfile => 'incsub.htm', req_rec => $req_rec, param => [$a[$row], 'main']}) -]

11.) Include a file with parameters

[- Execute ('incparam.htm', 0, 'B', 'three', 'dddd', '555') -]

12.) Include a file and write outputfile

[# - Execute ({inputfile => 'inc.htm', outputfile => "../tmp/incout.htm", }) ; - #]

12.) Done :-)


HTML::Embperl (c) 1997-1998 G.Richter Embperl-2.5.0/test/html/PaxHeaders.14966/exit.htm0000644000000000000000000000005012023276646017527 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/exit.htm0000755000076400000000000000023112023276646017215 0ustar00richterroot00000000000000 Tests for Embperl - component exit Before Exit [- exit -] After Exit [+ "perl after exit" +] Embperl-2.5.0/test/html/PaxHeaders.14966/callsub.htm0000644000000000000000000000005012023276646020203 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/callsub.htm0000755000076400000000000000212712023276646017677 0ustar00richterroot00000000000000 Tests for Embperl - Embperl sub Metacommand [###### first sub #####] [$sub txt$] *txt* *txt*

Here goes some normal html text

*txt* [$endsub$] [###### second sub #####] [$sub perl_code $] *perl_code* *perl_code* Here comes some perl: *perl_code* *perl_code* [- $foo = 'Hello world' -] *perl_code* *perl_code* foo = [+ $foo +]
*perl_code* testdata = [+ $testdata +]
*perl_code* [$endsub$] [###### main page #####]

Tests for Embperl - Embperl sub Metacommand

[- $testdata = 'abcd' -] Now we call the first sub via Execute: [- Execute ('#txt') -] And now the second via Execute: [- Execute ('#perl_code') -] Now we call the first sub via Perl: [- txt -] And now the second via Perl: [- perl_code -] -> Second time, other order: And now the second via Perl: [- perl_code -] Now we call the first sub via Perl: [- txt -] -> And Execute again, but other order And now the second via Execute: [- Execute ('#perl_code') -] Now we call the first sub via Execute: [- Execute ('#txt') -] And done! Embperl-2.5.0/test/html/PaxHeaders.14966/subimp.htm0000644000000000000000000000005012023276646020055 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/subimp.htm0000755000076400000000000000127412023276646017553 0ustar00richterroot00000000000000 [###### first sub #####] [$sub tfirst$] *1* *1*

1.) Here goes some normal html text

*1* [$endsub$] [###### second sub #####] [$sub tsecond $] *2* *2*2.) Here comes some perl: *2* *2*[- $foo = 'Hello world' -] *2* *2*foo = [+ $foo +]
*2*testdata = [+ $testdata +]
*2* [$endsub$] [###### table header #####] [$sub tabheader $] 12> [$endsub$] [###### table cell #####] [$sub tabcell $] *4* *4*[+ $_[0] -> [$row][$col] +] *4* [$endsub$] [###### table footer #####] [$sub tabfooter $] [$endsub$] [###### req_rec #####] [$sub trr$] *6* *6*

$req_rec = [+ $req_rec +] $$req_rec = [+ $$req_rec +]

*6* [$endsub$] Embperl-2.5.0/test/html/PaxHeaders.14966/setsess.htm0000644000000000000000000000005012023276646020247 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/setsess.htm0000755000076400000000000000174012023276646017743 0ustar00richterroot00000000000000 Tests for Embperl - Set Session Data fdat:
[- @ks = sort keys %fdat -]
[+ $ks[$row] +][+ $fdat{$ks[$row] || ''} +]
udat:
[- $id = tied (%udat) -> getid -] [- @ks = grep (!/^_/, sort (keys %udat)) ; $num = keys (%udat) - @ks - ($id?0:1) -]
[+ $ks[$row] +][+ $udat{$ks[$row] || ''} +]
[+ $id?"ok (num=$num)":"Not a session hash (num=$num)" +]

[- while (($k, $v) = each (%fdat)) { $udat{$k} = $fdat{$k} ; } -] [- $s = $Apache::Session::MemoryStore::store || $Apache::Session::Win32::sessions -] [- @ks = sort keys %$s -] sessions:
[+ $ks[$row] +][+ $s -> {$ks[$row] || ''} +]
continue continue continue

Embperl-2.5.0/test/html/PaxHeaders.14966/chdir0000644000000000000000000000005012323454053017051 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/chdir/0000755000000000000000000000000012323454053016117 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/chdir/PaxHeaders.14966/chdir2src.htm0000644000000000000000000000005012102651357021524 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/chdir/chdir2src.htm0000755000000000000000000000164412102651357020525 0ustar00rootroot00000000000000 Some tests for Embperl Compile: [! use Cwd ; use lib qw{.} ; BEGIN { $begin = getcwd } $compile = getcwd ; !] [- use chdir2src ; $test = chdir2src::test () ; -] Run: Begin CWD: [+ $begin +]
Compile CWD: [+ $compile +]
Script CWD: [+ $script = getcwd +]
Embperl CWD: [+ $ep = $FindBin::Bin || $ENV{EMBPERL_SRC} +]
$0: [+ $abs = $0 +] Use Test: [+ $test +] [- $abs = $ep . '/' . $0 if (!($0 =~ /^\//)) ; -] $0 (absolut): [+ $abs +] Equal: [+ $script eq $ep?'Yes':'No' +]
Compile Equal: [+ $script eq $compile?'yes':'no' +] Diff CWD: [+ do { $script =~ /$ep/ ; ">$'<" } +]
Diff $0: [+ do { $abs =~ /$ep/ ; ">$'<" } +]
Test/html: [+ $script =~ /test(?:\/|\\)html(?:\/|\\)chdir$/?'yes':'no' +] [- @ks = sort keys %fdat -]
[+ $ks[$row] +][+ $fdat{$ks[$row] || ''} +]
Embperl-2.5.0/test/html/chdir/PaxHeaders.14966/chdir2src.pm0000644000000000000000000000005012311326120021335 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/chdir/chdir2src.pm0000644000000000000000000000005612311326120020327 0ustar00rootroot00000000000000 package chdir2src ; sub test { 'ok' } 1 ; Embperl-2.5.0/test/html/PaxHeaders.14966/rtf0000644000000000000000000000005012323454053016553 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/rtf/0000755000000000000000000000000012323454053015621 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/rtf/PaxHeaders.14966/rtffull.asc0000644000000000000000000000005012023276646021005 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/rtf/rtffull.asc0000644000076400000000000001014612023276646020476 0ustar00richterroot00000000000000{\rtf1\ansi\ansicpg1252\uc1 \deff0\deflang1033\deflangfe1031{\fonttbl{\f0\froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}{\f1\fswiss\fcharset0\fprq2{\*\panose 020b0604020202020204}Arial;} {\f16\froman\fcharset238\fprq2 Times New Roman CE;}{\f17\froman\fcharset204\fprq2 Times New Roman Cyr;}{\f19\froman\fcharset161\fprq2 Times New Roman Greek;}{\f20\froman\fcharset162\fprq2 Times New Roman Tur;} {\f21\froman\fcharset186\fprq2 Times New Roman Baltic;}{\f22\fswiss\fcharset238\fprq2 Arial CE;}{\f23\fswiss\fcharset204\fprq2 Arial Cyr;}{\f25\fswiss\fcharset161\fprq2 Arial Greek;}{\f26\fswiss\fcharset162\fprq2 Arial Tur;} {\f27\fswiss\fcharset186\fprq2 Arial Baltic;}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255;\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128; \red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0;\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{\widctlpar\adjustright \fs20\lang1031\cgrid \snext0 Normal;}{\*\cs10 \additive Default Paragraph Font;}}{\info{\title xyz}{\author gr}{\operator gr}{\creatim\yr2001\mo5\dy7\hr8\min17}{\revtim\yr2001\mo5\dy7\hr8\min17}{\printim\yr2000\mo7\dy10\hr15\min3}{\version2}{\edmins0}{\nofpages1}{\nofwords45}{\nofchars257} {\*\company ecos}{\nofcharsws315}{\vern113}}\paperw16840\paperh11907\margl567\margr567\margt567\margb851 \deftab708\widowctrl\ftnbj\aenddoc\hyphhotz425\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\formshade\viewkind1\viewscale50\pgbrdrhead\pgbrdrfoot \fet0\sectd \lndscpsxn\psz9\linex0\headery709\footery709\colsx709\endnhere\sectdefaultcl {\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta )}}{\*\pnseclvl5 \pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}\trowd \trrh-10199\trkeep \clvertalt\cltxtbrl \cellx3986\clvertalt\cltxbtlr \cellx7973\clvertalt\cltxtbrl \cellx11959\clvertalt\cltxbtlr \cellx15946\pard\plain \li113\ri113\widctlpar\intbl\adjustright \fs20\lang1031\cgrid {\b\f1\fs80 \par }\pard \li2124\ri113\widctlpar\intbl\adjustright {\b\f1\fs80 }{\field{\*\fldinst {\b\f1\fs80\lang1036 MERGEFIELD Vorname }}{\fldrslt {\b\f1\fs80\lang1024 Rosina}}}{\b\f1\fs80\lang1036 }{\field{\*\fldinst {\b\f1\fs80\lang1036 MERGEFIELD Nachname } }{\fldrslt {\b\f1\fs80\lang1024 Maloiseau}}}{\b\f1\fs80\lang1036 \cell }\pard \ri113\widctlpar\intbl\adjustright {\b\f1\fs48\lang1036 \par }\pard \li2124\ri113\widctlpar\intbl\adjustright {\b\f1\fs80\lang1036 \par }{\b\f1\fs80 }{\field{\*\fldinst {\b\f1\fs80\lang1036 MERGEFIELD Vorname }}{\fldrslt {\b\f1\fs80\lang1024 Rosina}}}{\b\f1\fs80\lang1036 }{\field{\*\fldinst {\b\f1\fs80\lang1036 MERGEFIELD Nachname }}{\fldrslt {\b\f1\fs80\lang1024 Maloiseau}}} {\field{\*\fldinst {\b\f1\fs80\lang1036 NEXT }}{\fldrslt }}{\b\f1\fs80\lang1036 \cell }\pard \li113\ri113\widctlpar\intbl\adjustright {\b\f1\fs80\lang1036 \par }\pard \li2832\ri113\widctlpar\intbl\adjustright {\b\f1\fs80\lang1036 \par }{\field{\*\fldinst {\b\f1\fs80 MERGEFIELD Vorname }}{\fldrslt {\b\f1\fs80\lang1024 Ursula}}}{\b\f1\fs80 }{\field{\*\fldinst {\b\f1\fs80 MERGEFIELD Nachname }}{\fldrslt {\b\f1\fs80\lang1024 Knauf}}}{\b\f1\fs80 \cell }\pard \li113\ri113\widctlpar\intbl\adjustright {\b\f1\fs80 \par }\pard \li2832\ri113\widctlpar\intbl\adjustright {\b\f1\fs80 \par }{\field{\*\fldinst {\b\f1\fs80 MERGEFIELD Vorname }}{\fldrslt {\b\f1\fs80\lang1024 Ursula}}}{\b\f1\fs80 }{\field{\*\fldinst {\b\f1\fs80 MERGEFIELD Nachname }}{\fldrslt {\b\f1\fs80\lang1024 Knauf}}}{\b\f1\fs80 \cell }\pard \widctlpar\intbl\adjustright {\b\f1 \row }\pard \widctlpar\adjustright { \par }}Embperl-2.5.0/test/html/rtf/PaxHeaders.14966/rtfmeta.asc0000644000000000000000000000005012023276646020771 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/rtf/rtfmeta.asc0000644000076400000000000000141512023276646020461 0ustar00richterroot00000000000000{\rtf1 {[$ if $param[$_ep_rtf_ndx]{'adressen_name'} ne $lastnr $]} {[+ "l=$lastnr, p=$param[$_ep_rtf_ndx]{'adressen_name'}" +][- $lastnr = $param[$_ep_rtf_ndx]\{'adressen_name'\} -]} { Sehr } {\field{\*\fldinst { IF }{\field{\*\fldinst { MERGEFIELD adressen_anrede }}{\fldrslt {\lang1024 Herr}}}{ = "Herr" "geehrter" "geehrte" }}{\fldrslt {\lang1024 geehrter}}} { } {\field{\*\fldinst { MERGEFIELD adressen_anrede }}{\fldrslt {\lang1024 \'abadressen_anrede\'bb}}} { }{\field{\*\fldinst { MERGEFIELD adressen_name }}{\fldrslt {\lang1024 \'abadressen_name\'bb}}} {, \par \par dies ist ein Anschreiben \par \par Mit freundlichen Gr\'fc\'dfen. \par } {[$endif$]} { \par Es handelt sich um Kur Nr}{\field{\*\fldinst { MERGEFIELD nr }}{\fldrslt {\lang1024 \'abadressen_name\'bb}}} }Embperl-2.5.0/test/html/rtf/PaxHeaders.14966/rtfloop.asc0000644000000000000000000000005012023276646021014 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/rtf/rtfloop.asc0000644000076400000000000003643012023276646020511 0ustar00richterroot00000000000000{\rtf1\ansi\ansicpg1252\uc1 \deff0\deflang1031\deflangfe1031{\fonttbl{\f0\froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}{\f27\fswiss\fcharset0\fprq2{\*\panose 020b0604030504040204}Tahoma;} {\f120\fswiss\fcharset0\fprq2{\*\panose 00000000000000000000}Helvetica (PCL6);}{\f121\fnil\fcharset0\fprq2{\*\panose 00000000000000000000}Stonehenge{\*\falt Times New Roman};} {\f122\fnil\fcharset0\fprq2{\*\panose 00000000000000000000}Metro{\*\falt Times New Roman};}{\f127\froman\fcharset238\fprq2 Times New Roman CE;}{\f128\froman\fcharset204\fprq2 Times New Roman Cyr;}{\f130\froman\fcharset161\fprq2 Times New Roman Greek;} {\f131\froman\fcharset162\fprq2 Times New Roman Tur;}{\f134\froman\fcharset186\fprq2 Times New Roman Baltic;}{\f343\fswiss\fcharset238\fprq2 Tahoma CE;}{\f344\fswiss\fcharset204\fprq2 Tahoma Cyr;}{\f346\fswiss\fcharset161\fprq2 Tahoma Greek;} {\f347\fswiss\fcharset162\fprq2 Tahoma Tur;}{\f348\fswiss\fcharset177\fprq2 Tahoma (Hebrew);}{\f349\fswiss\fcharset178\fprq2 Tahoma (Arabic);}{\f350\fswiss\fcharset186\fprq2 Tahoma Baltic;}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255; \red0\green255\blue255;\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0; \red128\green128\blue0;\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{\ql \li0\ri0\widctlpar\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 \snext0 Normal;}{ \s1\ql \li0\ri0\keepn\widctlpar\faauto\adjustright\rin0\lin0\itap0 \f121\fs24\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 \sbasedon0 \snext0 heading 1;}{\s2\qc \li0\ri0\keepn\widctlpar\faauto\adjustright\rin0\lin0\itap0 \b\f121\fs44\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 \sbasedon0 \snext0 heading 2;}{\s3\ql \li2124\ri0\keepn\widctlpar\faauto\adjustright\rin0\lin2124\itap0 \f122\fs40\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 \sbasedon0 \snext0 heading 3;}{\s4\ql \li2124\ri0\keepn\widctlpar\faauto\adjustright\rin0\lin2124\itap0 \b\f122\fs40\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 \sbasedon0 \snext0 heading 4;}{\s5\qc \li0\ri0\keepn\widctlpar\faauto\adjustright\rin0\lin0\itap0 \b\f120\fs36\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 \sbasedon0 \snext0 heading 5;}{\*\cs10 \additive Default Paragraph Font;}{\s15\ql \li0\ri0\widctlpar\tqc\tx4536\tqr\tx9072\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 \sbasedon0 \snext15 header;}{\s16\ql \li0\ri0\widctlpar\tqc\tx4536\tqr\tx9072\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 \sbasedon0 \snext16 footer;}{ \s17\qc \li0\ri0\widctlpar\faauto\adjustright\rin0\lin0\itap0 \b\f121\fs44\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 \sbasedon0 \snext17 Title;}{\s18\ql \li0\ri0\widctlpar\faauto\adjustright\rin0\lin0\itap0 \cbpat9 \f27\fs20\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 \sbasedon0 \snext18 Document Map;}{\s19\qc \li0\ri0\widctlpar\faauto\adjustright\rin0\lin0\itap0 \b\f122\fs40\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 \sbasedon0 \snext19 Subtitle;}} {\info{\title Teilnehmerliste}{\author gr}{\operator gr}{\creatim\yr2001\mo5\dy8\hr5\min56}{\revtim\yr2001\mo5\dy8\hr14\min8}{\printim\yr2000\mo10\dy30\hr15\min53}{\version6}{\edmins0}{\nofpages1}{\nofwords93}{\nofchars534} {\*\company ecos}{\nofcharsws655}{\vern8249}}\paperw11907\paperh16840\margl851\margr397\margt3119\margb1134 \deftab708\widowctrl\ftnbj\aenddoc\hyphhotz425\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\hyphcaps0\formshade\horzdoc\dghspace120\dgvspace120\dghorigin1701\dgvorigin1984\dghshow0\dgvshow3 \jcompress\viewkind1\viewscale50\pgbrdrhead\pgbrdrfoot\nolnhtadjtbl \fet0\sectd \psz9\linex0\headery709\footery284\colsx709\endnhere\sectdefaultcl {\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl2 \pnucltr\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta )}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl6 \pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}\pard\plain \qc \li0\ri0\widctlpar\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 {- }{\field{\*\fldinst { PAGE \\* MERGEFORMAT }}{\fldrslt {\lang1024\langfe1024\noproof 1}}}{ - \par }{\expnd23\expndtw116 \par }\pard\plain \s17\qc \li0\ri0\widctlpar\faauto\adjustright\rin0\lin0\itap0 \b\f121\fs44\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 {\f120\fs48\expnd23\expndtw116 Teilnehmerliste \par \par }\pard\plain \qc \li0\ri0\widctlpar\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 {\b\f120\fs32 \par \par }{\field{\*\fldinst {\b\f120\fs44 MERGEFIELD Kunde }}{\fldrslt {\b\f120\fs44\lang1024\langfe1024\noproof Gasversorgung Rheinhessen}}}{\b\f120\fs44 \par }{\field{\*\fldinst {\b\f120\fs44 MERGEFIELD Compfirma }}{\fldrslt {\b\f120\fs44\lang1024\langfe1024\noproof MS}}}{\b\f120\fs44 }{\field{\*\fldinst {\b\f120\fs44 MERGEFIELD Kurs }}{\fldrslt {\b\f120\fs44\lang1024\langfe1024\noproof Outlook}}}{ \b\f120\fs44 }{\field{\*\fldinst {\b\f120\fs44 MERGEFIELD Version }}{\fldrslt {\b\f120\fs44\lang1024\langfe1024\noproof 2000}}}{\b\f120\fs44 \par }{\field{\*\fldinst {\b\f120\fs36 MERGEFIELD Stufe }}{\fldrslt {\b\f120\fs36\lang1024\langfe1024\noproof Grundlagen}}}{\b\f120\fs40 \par \par }\pard\plain \s1\ql \li2124\ri0\keepn\widctlpar\faauto\outlinelevel0\adjustright\rin0\lin2124\itap0 \f121\fs24\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 {\f120\fs36 Referent:\tab }{\field{\*\fldinst {\f120\fs36 MERGEFIELD Referent }}{\fldrslt { \f120\fs36\lang1024\langfe1024\noproof Herr Jost}}}{\f120\fs36 \par }\pard\plain \ql \li0\ri0\widctlpar\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 {\f120 \par }\pard\plain \s3\ql \li2124\ri0\keepn\widctlpar\faauto\outlinelevel2\adjustright\rin0\lin2124\itap0 \f122\fs40\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 {\f120\fs36 Datum: \tab \tab }{\field{\*\fldinst {\f120\fs36 MERGEFIELD Datum_Teilnehmerliste }}{\fldrslt {\f120\fs36\lang1024\langfe1024\noproof 19.03.01}}}{\f120\fs36 }{\field\fldedit{\*\fldinst {\f120\fs36 MERGEFIELD Tageszeit }}{\fldrslt }}{\f120\fs36 }{\field\fldedit{\*\fldinst {\f120\fs36 MERGEFIELD Uhrzeit_Anfang }}{\fldrslt }}{\f120\fs36 }{\field\fldedit{\*\fldinst {\f120\fs36 MERGEFIELD Uhrzeit_Ende }}{\fldrslt }}{\f120\fs36 \par }\pard\plain \s15\ql \li0\ri0\widctlpar\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 {\f120 \par \par }\trowd \trgaph70\trleft-70\trkeep\trbrdrt\brdrs\brdrw10 \trbrdrl\brdrs\brdrw10 \trbrdrb\brdrs\brdrw10 \trbrdrr\brdrs\brdrw10 \trbrdrh\brdrs\brdrw10 \trbrdrv\brdrs\brdrw10 \trftsWidth1\trpaddl70\trpaddr70\trpaddfl3\trpaddfr3 \clvertalt\clbrdrt \brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2480 \cellx2410\clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2693 \cellx5103\clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth4111 \cellx9214\pard\plain \ql \li0\ri0\widctlpar\intbl\faauto\adjustright\rin0\lin0 \fs20\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 {\b\f120\fs24 Name:\cell Vorname:\cell Unterschrift:\cell }\pard \ql \li0\ri0\widctlpar\intbl\faauto\adjustright\rin0\lin0 {\b\f120\fs24 \trowd \trgaph70\trleft-70\trkeep\trbrdrt\brdrs\brdrw10 \trbrdrl\brdrs\brdrw10 \trbrdrb\brdrs\brdrw10 \trbrdrr\brdrs\brdrw10 \trbrdrh\brdrs\brdrw10 \trbrdrv\brdrs\brdrw10 \trftsWidth1\trpaddl70\trpaddr70\trpaddfl3\trpaddfr3 \clvertalt\clbrdrt \brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2480 \cellx2410\clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2693 \cellx5103\clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth4111 \cellx9214\row }\trowd \trgaph70\trrh-440\trleft-70\trkeep\trbrdrt \brdrs\brdrw10 \trbrdrl\brdrs\brdrw10 \trbrdrb\brdrs\brdrw10 \trbrdrr\brdrs\brdrw10 \trbrdrh\brdrs\brdrw10 \trbrdrv\brdrs\brdrw10 \trftsWidth1\trpaddl70\trpaddr70\trpaddfl3\trpaddfr3 \clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb \brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2480 \cellx2410\clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2693 \cellx5103\clvertalt\clbrdrt \brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth4111 \cellx9214\pard \ql \li0\ri0\widctlpar\intbl\faauto\adjustright\rin0\lin0 {\f120\fs36 \cell \cell \cell }\pard \ql \li0\ri0\widctlpar\intbl\faauto\adjustright\rin0\lin0 {\f120\fs24 \trowd \trgaph70\trrh-440\trleft-70\trkeep\trbrdrt\brdrs\brdrw10 \trbrdrl\brdrs\brdrw10 \trbrdrb\brdrs\brdrw10 \trbrdrr\brdrs\brdrw10 \trbrdrh\brdrs\brdrw10 \trbrdrv\brdrs\brdrw10 \trftsWidth1\trpaddl70\trpaddr70\trpaddfl3\trpaddfr3 \clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2480 \cellx2410\clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl \brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2693 \cellx5103\clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth4111 \cellx9214 \row }\trowd \trgaph70\trrh-440\trleft-70\trkeep\trbrdrt\brdrs\brdrw10 \trbrdrl\brdrs\brdrw10 \trbrdrb\brdrs\brdrw10 \trbrdrr\brdrs\brdrw10 \trbrdrh\brdrs\brdrw10 \trbrdrv\brdrs\brdrw10 \trftsWidth1\trpaddl70\trpaddr70\trpaddfl3\trpaddfr3 \clvertalc \clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2480 \cellx2410\clvertalc\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2693 \cellx5103\clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth4111 \cellx9214\pard\plain \s1\ql \li0\ri0\keepn\widctlpar\intbl\faauto\outlinelevel0\adjustright\rin0\lin0 \f121\fs24\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 {\field{\*\fldinst {\f120\fs20 MERGEFIELD Nachname }}{\fldrslt {\f120\fs20\lang1024\langfe1024\noproof Stampp}}} {\f120\fs20 \cell }\pard\plain \ql \li0\ri0\widctlpar\intbl\faauto\adjustright\rin0\lin0 \fs20\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 {\field{\*\fldinst {\f120\fs24 MERGEFIELD Vorname }}{\fldrslt {\f120\fs24\lang1024\langfe1024\noproof Anja}}} {\field{\*\fldinst {\f120\fs24 NEXT }}{\fldrslt }}{\f120\fs24 \cell }{\f120\fs36 \cell }\pard \ql \li0\ri0\widctlpar\intbl\faauto\adjustright\rin0\lin0 {\f120\fs40 \trowd \trgaph70\trrh-440\trleft-70\trkeep\trbrdrt\brdrs\brdrw10 \trbrdrl\brdrs\brdrw10 \trbrdrb\brdrs\brdrw10 \trbrdrr\brdrs\brdrw10 \trbrdrh\brdrs\brdrw10 \trbrdrv\brdrs\brdrw10 \trftsWidth1\trpaddl70\trpaddr70\trpaddfl3\trpaddfr3 \clvertalc\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2480 \cellx2410\clvertalc\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2693 \cellx5103\clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth4111 \cellx9214\row }\pard \ql \li0\ri0\widctlpar\intbl\faauto\adjustright\rin0\lin0 {\field{\*\fldinst {\f120\fs24 MERGEFIELD Nachname }}{\fldrslt { \f120\fs24\lang1024\langfe1024\noproof Pflugbeil}}}{\f120\fs24 \cell }{\field{\*\fldinst {\f120\fs24\lang1040\langfe1031\langnp1040 MERGEFIELD Vorname }}{\fldrslt {\f120\fs24\lang1024\langfe1024\noproof Andre}}}{\field{\*\fldinst { \f120\fs24\lang1040\langfe1031\langnp1040 NEXT }}{\fldrslt }}{\f120\fs24\lang1040\langfe1031\langnp1040 \cell }{\f120\fs36\lang1040\langfe1031\langnp1040 \cell }\pard \ql \li0\ri0\widctlpar\intbl\faauto\adjustright\rin0\lin0 { \f120\fs40\lang1040\langfe1031\langnp1040 \trowd \trgaph70\trrh-440\trleft-70\trkeep\trbrdrt\brdrs\brdrw10 \trbrdrl\brdrs\brdrw10 \trbrdrb\brdrs\brdrw10 \trbrdrr\brdrs\brdrw10 \trbrdrh\brdrs\brdrw10 \trbrdrv\brdrs\brdrw10 \trftsWidth1\trpaddl70\trpaddr70\trpaddfl3\trpaddfr3 \clvertalc\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2480 \cellx2410\clvertalc\clbrdrt\brdrs\brdrw10 \clbrdrl \brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2693 \cellx5103\clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth4111 \cellx9214 \row }\trowd \trgaph70\trrh-440\trleft-70\trkeep\trbrdrt\brdrs\brdrw10 \trbrdrl\brdrs\brdrw10 \trbrdrb\brdrs\brdrw10 \trbrdrr\brdrs\brdrw10 \trbrdrh\brdrs\brdrw10 \trbrdrv\brdrs\brdrw10 \trftsWidth1\trpaddl70\trpaddr70\trpaddfl3\trpaddfr3 \clvertalc \clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2480 \cellx2410\clvertalc\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2693 \cellx5103\clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth4111 \cellx9214\pard \ql \li0\ri0\widctlpar\intbl\faauto\adjustright\rin0\lin0 {\field{\*\fldinst {\f120\fs24\lang1040\langfe1031\langnp1040 MERGEFIELD Nachname }}{\fldrslt {\f120\fs24\lang1024\langfe1024\noproof Delevska}}}{\f120\fs24\lang1040\langfe1031\langnp1040 \cell } {\field{\*\fldinst {\f120\fs24\lang1040\langfe1031\langnp1040 MERGEFIELD Vorname }}{\fldrslt {\f120\fs24\lang1024\langfe1024\noproof Aleksandra}}}{\f120\fs24\lang1040\langfe1031\langnp1040 \cell }{\f120\fs36\lang1040\langfe1031\langnp1040 \cell }\pard \ql \li0\ri0\widctlpar\intbl\faauto\adjustright\rin0\lin0 {\f120\fs40\lang1040\langfe1031\langnp1040 \trowd \trgaph70\trrh-440\trleft-70\trkeep\trbrdrt\brdrs\brdrw10 \trbrdrl\brdrs\brdrw10 \trbrdrb\brdrs\brdrw10 \trbrdrr\brdrs\brdrw10 \trbrdrh \brdrs\brdrw10 \trbrdrv\brdrs\brdrw10 \trftsWidth1\trpaddl70\trpaddr70\trpaddfl3\trpaddfr3 \clvertalc\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2480 \cellx2410\clvertalc \clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth2693 \cellx5103\clvertalt\clbrdrt\brdrs\brdrw10 \clbrdrl\brdrs\brdrw10 \clbrdrb\brdrs\brdrw10 \clbrdrr\brdrs\brdrw10 \cltxlrtb\clftsWidth3\clwWidth4111 \cellx9214\row }\pard \ql \li0\ri0\widctlpar\faauto\adjustright\rin0\lin0\itap0 {\f120 \par \par }}Embperl-2.5.0/test/html/rtf/PaxHeaders.14966/rtfadv.asc0000644000000000000000000000005012023276646020615 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/rtf/rtfadv.asc0000644000076400000000000001312112023276646020302 0ustar00richterroot00000000000000{\rtf1 { Sehr } {\field{\*\fldinst { IF }{\field{\*\fldinst { MERGEFIELD adressen_anrede }}{\fldrslt {\lang1024 Herr}}}{ = "Herr" "geehreter" "geehrte" }}{\fldrslt {\lang1024 geehreter}}} { } {\field{\*\fldinst { MERGEFIELD adressen_anrede }}{\fldrslt {\lang1024 \'abadressen_anrede\'bb}}} { }{\field{\*\fldinst { MERGEFIELD adressen_name }}{\fldrslt {\lang1024 \'abadressen_name\'bb}}} {\field {\*\fldinst {\f1\fs22 IF } {\field {\*\fldinst {\f1\fs22 MERGEFIELD anschreiben_typ } } {\fldrslt {\f1\fs22\lang1024 Dienstadresse} } } {\f1\fs22 = Dienstadresse } {\field{\*\fldinst {\f1\fs22 MERGEFIELD adressen_dienststelle }}{\fldrslt {\f1\fs22\lang1024 Mittelrheinische Treuhand GmbH}}} {\f1\fs22 "" } }{\fldrslt {\f1\fs22\lang1024 Mittelrheinische Treuhand GmbH}}} {\field {\*\fldinst {\f1\fs22 IF } {\field {\*\fldinst {\f1\fs22 MERGEFIELD anschreiben_typ } } {\fldrslt {\f1\fs22\lang1024 Dienstadresse} } } {\f1\fs22 = Dienstadresse } {\field {\*\fldinst {\f1\fs22 MERGEFIELD adressen_dienststelle } } {\fldrslt {\f1\fs22\lang1024 Mittelrheinische Treuhand GmbH} } } {\f1\fs22 "" } } {\fldrslt {\f1\fs22\lang1024 Mittelrheinische Treuhand GmbH} } } {\field {\*\fldinst {\f1\fs22 IF } {\field {\*\fldinst {\f1\fs22 MERGEFIELD adressen_anrede }} {\fldrslt {\f1\fs22\lang1024 Herr}}} {\f1\fs22 = "Herr" "n" "" } } {\fldrslt {\f1\fs22\lang1024 n}}} {\f1\fs22 } {\field {\*\fldinst {\f1\fs22 IF } {\field {\*\fldinst {\f1\fs22 MERGEFIELD anschreiben_typ }} {\fldrslt {\f1\fs22\lang1024 Dienstadresse}} } {\f1\fs22 = Dienstadresse } {\field {\*\fldinst {\f1\fs22 MERGEFIELD adressen_dienstbezeichnung }} {\fldrslt {\f1\fs22\lang1024 Wirtschaftspr\'fcfer}} } {\f1\fs22 "" } } {\fldrslt {\f1\fs22\lang1024 Wirtschaftspr\'fcfer}} } {\f1\fs22\par } {\field {\*\fldinst {\f1\fs22 MERGEFIELD adressen_titel }} {\fldrslt {\f1\fs22\lang1024 Dr.}} } {\field {\*\fldinst {\f1\fs22 IF } {\field {\*\fldinst {\f1\fs22 MERGEFIELD adressen_titel }} {\fldrslt {\f1\fs22\lang1024 Dr.}} } {\f1\fs22 <> "" " " "" } } {\fldrslt {\f1\fs22\lang1024 }} } {\field {\*\fldinst {\f1\fs22 MERGEFIELD adressen_vorname }} {\fldrslt {\f1\fs22\lang1024 Horst}} }{\f1\fs22 } {\field {\*\fldinst {\f1\fs22 MERGEFIELD adressen_name }} {\fldrslt {\f1\fs22\lang1024 Bremser}} } {\field {\*\fldinst {\f1\fs22 IF } {\field {\*\fldinst {\f1\fs22 MERGEFIELD anschreiben_typ }} {\fldrslt {\f1\fs22\lang1024 Dienstadresse}} } {\f1\fs22 = Dienstadresse } {\field {\*\fldinst {\f1\fs22 MERGEFIELD adressen_dienst_strasse }} {\fldrslt {\f1\fs22\lang1024 Hohenzollernstra\'dfe 104-106}}} {\f1\fs22 } {\field {\*\fldinst {\f1\fs22 MERGEFIELD adressen_priv_strasse }} {\fldrslt {\f1\fs22\lang1024 Reinerzer Ring 29}} } {\f1\fs22 }} {\fldrslt {\f1\fs22\lang1024 Hohenzollernstra\'dfe 104-106}} } {\f1\fs22 \par Sehr }{\field{\*\fldinst {\f1\fs22 IF }{\field{\*\fldinst {\f1\fs22 MERGEFIELD adressen_anrede }}{\fldrslt {\f1\fs22\lang1024 Herr}}}{\f1\fs22 = "Herr" "geehrter" "geehrte" }}{\fldrslt {\f1\fs22\lang1024 geehrter}}}{\f1\fs22 }{\field{\*\fldinst { \f1\fs22 MERGEFIELD adressen_anrede }}{\fldrslt {\f1\fs22\lang1024 Herr}}}{\f1\fs22 }{\field{\*\fldinst {\f1\fs22 MERGEFIELD adressen_titel }}{\fldrslt {\f1\fs22\lang1024 Dr.}}}{\field{\*\fldinst {\f1\fs22 IF }{\field{\*\fldinst {\f1\fs22 MERGEFIELD adressen_titel }}{\fldrslt {\f1\fs22\lang1024 Dr.}}}{\f1\fs22 <> "" " " "" }}{\fldrslt {\f1\fs22\lang1024 }}}{\field{\*\fldinst {\f1\fs22 MERGEFIELD adressen_name }}{\fldrslt {\f1\fs22\lang1024 Bremser}}}{\f1\fs22 , \par {, \par \par dies ist ein Anschreiben \par \par Mit freundlichen Gr\'fc\'dfen. \par \par Datensatz }{\field{\*\fldinst { MERGEREC }}{\fldrslt {\lang1024 \'abDatensatz verbinden\'bb}}}{ \par \par Sq }{\field{\*\fldinst { MERGESEQ }}{\fldrslt {\lang1024 \'abSeriendruck-Sequenz-Nr.\'bb}}}{ \par \par NEXT }{\field{\*\fldinst { NEXT }}{\fldrslt {\lang1024 \'abN\'e4chster Datensatz\'bb}}} {\field{\*\fldinst { MERGEFIELD adressen_vorname }}{\fldrslt {\lang1024 \'abadressen_vorname\'bb}}} { \par \par NEXTIF }{\field{\*\fldinst { NEXTIF }{\field{\*\fldinst { MERGEFIELD adressen_anrede }}{\fldrslt {\lang1024 Herr}}}{ = "Herr" }}{\fldrslt {\lang1024 \'abN\'e4chster Datensatz Wenn\'bb}}} {\field{\*\fldinst { MERGEFIELD adressen_vorname }}{\fldrslt {\lang1024 \'abadressen_vorname\'bb}}} { \par \par SKIPIF }{\field{\*\fldinst { SKIPIF }{\field{\*\fldinst { MERGEFIELD adressen_anrede }}{\fldrslt {\lang1024 Herr}}}{ = "Herr" }}{\fldrslt {\lang1024 \'abDatensatz \'fcberspringen...\'bb}}} {\field{\*\fldinst { MERGEFIELD adressen_vorname }}{\fldrslt {\lang1024 \'abadressen_vorname\'bb}}} { \par \par \par }}Embperl-2.5.0/test/html/rtf/PaxHeaders.14966/rtfbasic.asc0000644000000000000000000000005012023276646021124 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/rtf/rtfbasic.asc0000644000076400000000000000457312023276646020624 0ustar00richterroot00000000000000{\rtf1 {one: }{\field{\*\fldinst { DOCVARIABLE one \\* MERGEFORMAT }}{\fldrslt }} {hash.b: }{\field{\*\fldinst { DOCVARIABLE hash.b \\* MERGEFORMAT }}{\fldrslt }} {array.2: }{\field{\*\fldinst { DOCVARIABLE array.2 }}{\fldrslt }} {hash.c.2: }{\field{\*\fldinst { DOCVARIABLE hash.c.2 \\* MERGEFORMAT }}{\fldrslt }} {hash.c.3: }{\field{\*\fldinst { DOCVARIABLE hash.c.3 }}{\fldrslt }} {hash.c.2: }{\field{\*\fldinst { MERGEFIELD hash.c.0 \\* MERGEFORMAT }}{\fldrslt }} {hash.c.3: }{\field{\*\fldinst { MERGEFIELD hash.c.1 }}{\fldrslt }} {1.1} {\field{\*\fldinst {\b\f1\fs80\lang1024 MERGEFIELD one }}{\fldrslt {\b\f1\fs80\lang1024 ----}}} {1.2} {\field{\*\fldinst { \b\f1\fs80\lang1024 MERGEFIELD one}}{\fldrslt {\b\f1\fs80\lang1024 ----}}} {1.3} {\field{\*\fldinst {MERGEFIELD one}}{\fldrslt {\b\f1\fs80\lang1024 ----}}} {1.4} {\field{\*\fldinst { MERGEFIELD one}}{\fldrslt {\b\f1\fs80\lang1024 ----}}} {1.5} {\field{\*\fldinst { MERGEFIELD one }}{\fldrslt {\b\f1\fs80\lang1024 ----}}} {1.6} {\field{\*\fldinst {MERGEFIELD one }}{\fldrslt {\b\f1\fs80\lang1024 ----}}} {1.7} {\field{\*\fldinst {MERGEFIELD one }} {\fldrslt {\b\f1\fs80\lang1024 ----}}} {2.1} {\field{\*\fldinst MERGEFIELD one}{\fldrslt one}} {2.2} {\field{\*\fldinst MERGEFIELD one}{\fldrslt one}} {2.3} {\field{\*\fldinst MERGEFIELD one }{\fldrslt one}} {\field{\*\fldinst {MERGEFIELD uml }}{\fldrslt {\b\f1\fs80\lang1024 ----}}} {\field{\*\fldinst {MERGEFIELD brace }}{\fldrslt {\b\f1\fs80\lang1024 ----}}} {pass this thru: }{\field{\*\fldinst { PAGE \\* MERGEFORMAT }}{\fldrslt {\lang1024\langfe1024\noproof 1}}} {pass this thru as hyperlink: }{\field\flddirty{\*\fldinst {\f1\fs22 HYPERLINK "mailto:wullenweber@komrp.de" }{\f1\fs22 {\*\datafield 00d0c9ea79f9bace118c8200aa004ba90b020000001700000015000000770075006c006c0065006e007700650062006500720040006b006f006d00720070002e00640065000000e0c9ea79f9bace118c8200aa004ba90b380000006d00610069006c0074006f003a00770075006c006c0065006e0077006500620065007200 40006b006f006d00720070002e00640065000000000000}}}{\fldrslt {\f1\fs22 wullenweber@komrp.de}}} { Here we have some spaces: } { } { ok } {\pard { Here we have some spaces: } { } { ok } {\field{\*\fldinst {MERGEFIELD one}}{\fldrslt {\b\f1\fs80\lang1024 ----}}}{ }{\field{\*\fldinst {MERGEFIELD uml}}{\fldrslt {\b\f1\fs80\lang1024 ----}}} {onCRLFe: }{\field{\*\fldinst { DOCVARIABLE on e \\* MERGEFORMAT }}{\fldrslt }} } }Embperl-2.5.0/test/html/PaxHeaders.14966/subargs.htm0000644000000000000000000000005012023276646020224 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/subargs.htm0000755000076400000000000000105612023276646017720 0ustar00richterroot00000000000000 Define a Subroutine with Args within Embperl [$ sub test ($a, $b) $] a=[+ $a +] b=[+ $b +] [$endsub$] [$ sub test2 ($a, $b) $c = $a + $b ; $] c=[+ $a +] + [+ $b +] = [+ $c +] [$endsub$] [$ sub test3 ($a, $b) my $c = ($a - $b) ; $] a=[+ $a +] b=[+ $b +] c=[+ $c +] [$endsub$] 1,2->[- test(1,2) -] 3,4->[- test(3,4) -] 1,2->[- test2(1,2) -] 3,4->[- test2(3,4) -] 1,2->[- test3(1,2) -] 3,4->[- test3(3,4) -]

Ok.

Embperl-2.5.0/test/html/PaxHeaders.14966/incsub.htm0000644000000000000000000000005012023276646020041 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/incsub.htm0000755000076400000000000000045012023276646017532 0ustar00richterroot00000000000000[+ "Start include" +] [- @a = ('s1', 's2', 's3') -]
[+ "$param[0] - " +][+ $a[$col] +]
Parameters:
[+ $param[$col] +]
p0 [+ $param[0] +] p1 [+ $param[1] +] [+ "End include" +] Embperl-2.5.0/test/html/PaxHeaders.14966/executesub.htm0000644000000000000000000000005012023276646020732 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/executesub.htm0000644000076400000000000000054212023276646020422 0ustar00richterroot00000000000000 Tests for Embperl - Execute subs

Tests for Embperl - Execute subs

First sub: [- Execute ('subexec.htm#tfirst') -] Second sub: [- Execute ('subexec.htm#tsecond') -] Second sub: [- Execute ('subexec.htm#tsecond') -] First sub: [- Execute ('subexec.htm#tfirst') -] And done! Embperl-2.5.0/test/html/PaxHeaders.14966/subimp.pm0000644000000000000000000000005012311326120017660 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/subimp.pm0000755000076400000000000000176012311326120017356 0ustar00richterroot00000000000000 package subimp ; #require Embperl::Module ; #@ISA = qw{Embperl::Module} ; #Embperl::Module::init (\*DATA) ; #1 ; { local $/ = undef ; my $data = ; # compile page my $pn = __PACKAGE__ ; Embperl::Execute ({inputfile => __FILE__, input => \$data, mtime => -M __FILE__ , import => 0, options => Embperl::optKeepSrcInMemory, package => $pn . $ENV{EMBPERL_EP1COMPAT}}) ; } # import subs sub import { my $pn = __PACKAGE__ ; Embperl::Execute ({inputfile => __FILE__, import => 2, package => $pn . $ENV{EMBPERL_EP1COMPAT}}) ; 1 ; } 1 ; __DATA__ [###### first sub #####] [$sub tfirst$]

1.) Here goes some normal html text

[$endsub$] [###### second sub #####] [$sub tsecond $] 2.) Here comes some perl: [- $foo = 'Hello world' -] foo = [+ $foo +]
testdata = [+ $testdata +]
params in sub.pm = [+ "@_" +] [$endsub$] [###### table cell #####] [$sub tabcell $] [+ $_[0] -> [$row][$col] +] [$endsub$] Embperl-2.5.0/test/html/PaxHeaders.14966/if.htm0000644000000000000000000000005012023276646017154 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/if.htm0000755000076400000000000002441512023276646016654 0ustar00richterroot00000000000000 IF Metacommand in Embperl [- $a = 1; $b = 0; $c = 5; $d = 'txt' -] a1 [$if $a$] a
[$ endif$] a2 [$if $a $] a
[$else$] not a
[$ endif $] a3 [$if $a
$] a
[$else
$] not a
[$ endif
$] a4 [# [$
if $a $] a
[$
else
$] not a
[$
endif $] #] a5 [$ if $a$] a
[$if $b == 0$] b is null
[$else$] b is not null
[$endif$] [$ else$] not a
[$ endif $] [$ if $a$] a
[$if $b == 0$] b is null
[$else$] b is not null
[$endif$] [$ else$] not a
[$if $b == 0$] b is null
[$else$] b is not null
[$endif$] [$ endif $] [$ if !$a$] not a
[$if $b == 0$] b is null
[$else$] b is not null
[$endif$] [$ else$] a
[$if $b == 0$] b is null
[$else$] b is not null
[$endif$] [$ endif $] [$ if $a$] a
[$if $b == 0$] b is null
[$elsif $c == 5 $] b is not null and c is 5
[$elsif $d eq 'txt'$] b is not null and c is not 5, but d is 'txt'
[$else$] b is not null and c is not 5 and d is not 'txt'
[$endif$] [$ else$] not a
[$ endif $] [$ if $a$] a
[$if $b == 0$] b is null
[$elsif $c == 5 $] b is not null and c is 5
[$elsif $d eq 'txt'$] b is not null and c is not 5, but d is 'txt'
[$else$] b is not null and c is not 5 and d is not 'txt'
[$endif$] [$ else$] not a
[$if $b == 0$] b is null
[$elsif $c == 5 $] b is not null and c is 5
[$elsif $d eq 'txt'$] b is not null and c is not 5, but d is 'txt'
[$else$] b is not null and c is not 5 and d is not 'txt'
[$endif$] [$ endif $] [$ if $a == 0 $] a is null
[$if $b != 0$] b not is null
[$elsif $c == 5 $] b is null and c is 5
[$elsif $d eq 'txt'$] b is null and c is not 5, but d is 'txt'
[$else$] b is null and c is not 5 and d is not 'txt'
[$endif$] [$ else$] a is not null
[$if $b != 0$] b is not null
[$elsif $c == 5 $] b is null and c is 5
[$elsif $d eq 'txt'$] b is null and c is not 5, but d is 'txt'
[$else$] b is null and c is not 5 and d is not 'txt'
[$endif$] [$ endif $] [$ if $a == 0 $] a is null
[$if $b != 0$] b not is null
[$elsif $c == 5 $] b is null and c is 5
[$elsif $d eq 'txt'$] b is null and c is not 5, but d is 'txt'
[$else$] b is null and c is not 5 and d is not 'txt'
[$endif$] [$ else$] a is not null
[$if $b != 0$] b is not null
[$elsif $c != 5 $] b is null and c is not 5
[$elsif $d ne 'txt'$] b is null and c is not 5, but d is not 'txt'
[$else$] b is null and c is 5 and d is 'txt'
[$endif$] [$ endif $] [$ if $a == 0 $] a is null
[$if $b != 0$] b not is null
[$elsif $c == 5 $] b is null and c is 5
[$elsif $d eq 'txt'$] b is null and c is not 5, but d is 'txt'
[$else$] b is null and c is not 5 and d is not 'txt'
[$endif$] [$ else$] a is not null
[$if $b != 0$] b is not null
[$elsif $c != 5 $] b is null and c is not 5
[$elsif $d ne 'txt'$] b is null and c is not 5, but d is not 'txt'
[$else$] b is null and c is 5 and d is 'txt'
[$if $b != 0$] b is not null
[$elsif $c != 5 $] b is null and c is not 5
[$elsif $d eq 'txt'$] b is null and c is not 5, but d is 'txt'
[$if $d eq 'txt'$] If we get to here it looks good with the tests
[$else$] No not go to here, something is wrong!
[$endif$] [$else$] b is null and c is 5 and d is 'txt'
[$endif$] [$endif$] [$ endif $] [$ if $a == 0 $] a is null
[$if $b != 0$] b not is null
[$elsif $c == 5 $] b is null and c is 5
[$elsif $d eq 'txt'$] b is null and c is not 5, but d is 'txt'
[$else$] b is null and c is not 5 and d is not 'txt'
[$endif$] [$ else$] a is not null
[$if $b != 0$] b is not null
[$if $d eq 'txt'$] No not go to here, something is wrong! (a)
[$else$] No not go to here, something is wrong! (b)
[$endif$] [$elsif $c != 5 $] b is null and c is not 5
[$if $d eq 'txt'$] No not go to here, something is wrong! (a)
[$else$] No not go to here, something is wrong! (b)
[$endif$] [$elsif $d ne 'txt'$] b is null and c is not 5, but d is not 'txt'
[$if $d eq 'txt'$] No not go to here, something is wrong! (a)
[$else$] No not go to here, something is wrong! (b)
[$endif$] [$else$] b is null and c is 5 and d is 'txt'
[$if $b != 0$] b is not null
[$if $d eq 'txt'$] No not go to here, something is wrong! (a)
[$else$] No not go to here, something is wrong! (b)
[$endif$] [$elsif $c != 5 $] b is null and c is not 5
[$if $d eq 'txt'$] No not go to here, something is wrong! (a)
[$else$] No not go to here, something is wrong! (b)
[$endif$] [$elsif $d eq 'txt'$] b is null and c is not 5, but d is 'txt'
[$if $d eq 'txt'$] If we get to here it looks good with the tests
[$else$] No not go to here, something is wrong!
[$endif$] [$else$] b is null and c is 5 and d is 'txt'
[$if $d eq 'txt'$] No not go to here, something is wrong! (a)
[$else$] No not go to here, something is wrong! (b)
[$endif$] [$endif$] [$endif$] [$ endif $] [- $ttrue = 'true'; $tfalse = '' -] [$if $ttrue $] ttrue = true [$else$] ttrue = false [$endif$] [$if $tfalse $] tfalse = true [$else$] tfalse = false [$endif$] The following HTML tags schould be ignored by Embperl Ignored, ok! Not ignored, ERROR!
[$ if ($badge eq "iit") $] [$ else $] [$ endif $] iit logo
[- $cookie_badge = "iit" ; $server_type = "iii.co.uk" ; $icon_width = 1 ; $icon_height=2; -]
[$ if ($badge eq "iit") $] [$ else $] [$ endif $] iit logo
[- $icon_width = 5 ; $icon_height=10; -] iit logo [- $icon_width = 6 ; $icon_height=11; $server_type="iii" ; $badge = "iit" -] iit logo iit logo Embperl-2.5.0/test/html/PaxHeaders.14966/safe0000644000000000000000000000005012323454053016676 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/safe/0000755000000000000000000000000012323454053015744 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/safe/PaxHeaders.14966/safe.htm0000644000000000000000000000005012023276646020412 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/safe/safe.htm0000644000076400000000000000715012023276646020104 0ustar00richterroot00000000000000 Some Plain tests Embperl Here it starts with some HTML Text

All values should be undefined: $a = [+ $a +]
$b = [+ $b +]
$c = [+ $c +]
$d = [+ $d +]
$e = [+ $e +]
First of all assign a value: [- $a = '(this is the value in $a)' -]
Now we have some 'Umlaute': [- $b = "$a äöü" -] Now lets look what we are getting from this:
[+ $a +] [+ $b +]
And now a and b together: [+ "$a$b" +]

Here we have some HTML tags within the perl code, Embperl will delete them!
[+ $c =
6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
[- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value $a = [+ $a +]
$b = [+ $b +]
$c = [+ $c +]
$d = [+ $d +]
$e = [+ $e +]
[- $a = 1; $b = 0; $c = 5; $d = 'txt' -] [$if $a$] a
[$ endif$] [$if $a $] a
[$else$] not a
[$ endif $] [$ if $a$] a
[$if $b == 0$] b is null
[$else$] b is not null
[$endif$] [$ else$] not a
[$ endif $] [$ if $a$] a
[$if $b == 0$] b is null
[$else$] b is not null
[$endif$] [$ else$] not a
[$if $b == 0$] b is null
[$else$] b is not null
[$endif$] [$ endif $] [$ if !$a$] not a
[$if $b == 0$] b is null
[$else$] b is not null
[$endif$] [$ else$] a
[$if $b == 0$] b is null
[$else$] b is not null
[$endif$] [$ endif $] [- $i = 0 -] [$ while $i <= $#ffld $] [+ $ffld[$i] +] = [+ $fdat{$ffld[$i]} +] [- $j = 0 -] [$ while $j <= $i $] [+ $j++ +] [$ endwhile $]
[- $i++ -] [$ endwhile $]
[+ $c[$row][$col] +]

$tabmode = default

Display an two dimensional array with one, two and three columns !
Please take a look at the source in your browser to see the difference
[- undef @a ; undef @b ; $a[0][0] = 'a1/1' ; $a[1][0] = 'a2/1' ; $a[1][1] = 'a2/2' ; $a[2][0] = 'a3/1' ; $a[2][1] = 'a3/2' ; $a[2][2] = 'a3/3' ; $b[0][0] = 'b1/1' ; $b[1][0] = 'b2/1' ; $b[1][1] = 'b2/2' ; $b[2][0] = 'b3/1' ; $b[2][1] = 'b3/2' ; $b[2][2] = 'b3/3' ; $maxcol=99 ; -] $a[0][[0] = '1/1' ;
$a[1][[0] = '2/1' ;
$a[1][[1] = '2/2' ;
$a[2][[0] = '3/1' ;
$a[2][[1] = '3/2' ;
$a[2][[2] = '3/3' ;

$tabmode = default

[+ $a[$row][$col] +]
1 2 3
[+ $a[$row][$col] +]
[+ $b[2][$col] +]
[+ $a[$row][$col] +]
[+ $b[$row][$col] +]
[+ $a[$row][$col] +]

[+ $HTML::Embperl::VERSION +]

[+ $tabmode +]

[+ local $tabmode = 1 +]

[- $i = 0 ; while ($i < 10) { $ii[$i++] = "ii[$i] = $i" ; } -]
[+ $ii[$row] +]
[- @fe = (1, 10, 100, 1000) -] [$ foreach $fe @fe $] [+ $fe +] [$ endforeach $] Embperl-2.5.0/test/html/PaxHeaders.14966/inctext.htm0000644000000000000000000000005012023276646020234 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/inctext.htm0000644000076400000000000000033712023276646017726 0ustar00richterroot00000000000000 Embperl Tests - Include literal text [- $a = 'Start' ; $b = 'End' -] [+ $a +] [- Execute ({inputfile => 'SSIEP/ssiep.htm', syntax => 'Text'}) ; -] [+ $b +] Embperl-2.5.0/test/html/PaxHeaders.14966/epglobals.htm0000644000000000000000000000005012023276646020526 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/epglobals.htm0000644000076400000000000000030212023276646020210 0ustar00richterroot00000000000000 epreq: [+ ref $epreq +] epapp: [+ ref $epapp +] epreq -> app [+ $epreq -> app +] epapp [+ $epapp +] eq [+ $epreq -> app eq $epapp?'yes':'no' +] appname [+ $epapp -> config -> app_name +] Embperl-2.5.0/test/html/PaxHeaders.14966/pure.htm0000644000000000000000000000005012023276646017531 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/pure.htm0000644000076400000000000000032312023276646017216 0ustar00richterroot00000000000000 Some tests for Embperl Here it starts with some HTML Text

This pure HTML Text. Nothing todo for Embperl,
just pass it thru...

Ok.

Embperl-2.5.0/test/html/PaxHeaders.14966/mailformto.htm0000644000000000000000000000005012023276646020727 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/mailformto.htm0000644000076400000000000000071212023276646020416 0ustar00richterroot00000000000000 Embperl Tests - use MailFormTo [- $MailTo = 'richter@ecos.de' ; $fdat{email} = 'test_mailformto' ; $fdat{msg} = 'Embperl tests' ; @ffld = keys %fdat ; -] [- MailFormTo ($MailTo,'Embperl TEST Formdata','email') -] $? = [+ $? +]
[$ if $? $]

Sorry, there was an error, your mail couldn't be send

[$else$]

Your mail was successfully delivered

[$endif$] Embperl-2.5.0/test/html/PaxHeaders.14966/epform.htm0000644000000000000000000000005012023276646020046 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/epform.htm0000644000076400000000000000255012023276646017537 0ustar00richterroot00000000000000 Embperl Tests - Embperl::Form::Validate [- use Embperl::Form::Validate; $epf = Embperl::Form::Validate -> new ([ [ -key => 'datum', -msg => 'Bitte Datum eintragen', required => 1, -msg => 'Datum überprüfen', matches_regex => '\d+\.\d+\.\d+', ], [ -key => 'stunden', -msg => 'Bitte Stunden eintragen', required => 1, -msg => 'Stundenzahl nicht numerisch', # fail-msg for next test -type => 'Number', # only Number and Default available -msg => 'Stundenzahl muß >0 sein', # fail-msg for next test gt => 0, ], [ -key => 'kommentar', -msg => 'Bitte (sinnvollen) Kommentar eingeben', required => 1, ], ], 'foo'); $failures = $epf -> validate_messages ; if (@$failures) { print OUT "Fehler:\n"; foreach $msg (@$failures) { print OUT "$msg
\n"; } } -]
stunden
datum
kommentar

Embperl-2.5.0/test/html/PaxHeaders.14966/execwithsub.htm0000644000000000000000000000005012023276646021110 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/execwithsub.htm0000644000076400000000000000004212023276646020573 0ustar00richterroot00000000000000[- Execute('execwithsub2.htm') -] Embperl-2.5.0/test/html/PaxHeaders.14966/errmsg.htm0000644000000000000000000000005012023276646020055 xustar000000000000000020 atime=1397643272 20 ctime=1397643307 Embperl-2.5.0/test/html/errmsg.htm0000755000076400000000000000023312023276646017545 0ustar00richterroot00000000000000 Tests for Embperl - ErrorDocument This page is shown due to an ErrorDocument redirection

Embperl-2.5.0/test/html/PaxHeaders.14966/tagintag.htm0000644000000000000000000000005012023276646020354 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/tagintag.htm0000644000076400000000000000043112023276646020041 0ustar00richterroot00000000000000 [$syntax + Test $] > "> "> "> > Embperl-2.5.0/test/html/PaxHeaders.14966/delrdsess.htm0000644000000000000000000000005012023276646020546 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/delrdsess.htm0000644000076400000000000000136612023276646020243 0ustar00richterroot00000000000000 Tests for Embperl - Delete Session Data udat before:
[- @ks = grep (!/^_/, sort (keys %udat)) ; $num = keys (%udat) - $#ks - 1 ; -]
[+ $ks[$row] +][+ $udat{$ks[$row] || ''} +]
[+ $num > 0?"ok (num=$num)":"Not a session hash (num=$num)" +]

$mdat{cnt} = -[+ $mdat{cnt} +]-
$udat{cnt} = -[+ $udat{cnt} +]-
[- $_[0] -> DeleteSession (1) ; -] udat after:
[- @ks = grep (!/^_/, sort (keys %udat)) ; $num = keys (%udat) - $#ks - 1 ; -]
[+ $ks[$row] +][+ $udat{$ks[$row] || ''} +]
[+ $num > 0?"ok (num=$num)":"Not a session hash (num=$num)" +]

Embperl-2.5.0/test/html/PaxHeaders.14966/mix.htm0000644000000000000000000000005012023276646017353 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/mix.htm0000755000076400000000000000167612023276646017057 0ustar00richterroot00000000000000 Embperl Tests - Mix top level perl, with subroutines and metacommands Here it starts with some HTML Text

All values should be undefined: [* $a = 'global value' ; *]
global value: $a = [+ $a || '' +]
[* { local $a ; *] $a = [+ $a || '' +]
[* $a = 'lokal value' ; *]
lokal value: $a = [+ $a || '' +]
[* } *] again global value: $a = [+ $a || '' +]
[* @x = (1, 4 ,8, 17) ; *] [- $i = 0 -] [$ while $i <= $#x $] [+ $i +] = [+ $x[$i] +]
[* $j = 0 ; *] [$ while $j <= $i $] [+ $j++ +] [$ endwhile $]
[* $i++ ; *] [$ endwhile $] [- undef @b ; $b[0][0] = 'b1/1' ; $b[1][0] = 'b2/1' ; $b[1][1] = 'b2/2' ; $b[2][0] = 'b3/1' ; $b[2][1] = 'b3/2' ; $b[2][2] = 'b3/3' ; -]
[* $i = $row ; *][+ $i +][+ $b[$row][$col] +]
Embperl-2.5.0/test/html/PaxHeaders.14966/xml0000644000000000000000000000005012323454053016560 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/xml/0000755000000000000000000000000012323454053015626 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/xml/PaxHeaders.14966/pod.xsl0000644000000000000000000000005012023276646020156 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/xml/pod.xsl0000644000076400000000000000602612023276646017651 0ustar00richterroot00000000000000 <xsl:value-of select="/pod/head/title"/>

    • Embperl-2.5.0/test/html/xml/PaxHeaders.14966/kfdres.xml0000644000000000000000000000005012023276646020644 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/xml/kfdres.xml0000755000076400000000000000507412023276646020344 0ustar00richterroot00000000000000 Success0767703OEIC3Henderson North American186Henderson Global InvestorsHenderson Investment Funds LimitedChase Manhattan Trustees Limited01N00005001899-12-30 12:00:00-1ANorth America50.110Income5ATo provide capital growth by investing in North American companies. The Fund will primarily invest in larger companies.11.5000027.629569.4737121.4905309.45661042.37051155.56931281.06121657.69485.180800 212 256xxxxxxxxxxxxxxretailclientservices@henderson.com7Henderson Global InvestorsHenderson Global Investors4 BroadgateLondonEC2M 2DAUKxxxxxxxxxxxxxx0800 212 256retailclientservices@henderson.com Embperl-2.5.0/test/html/xml/PaxHeaders.14966/kfd.xsl0000644000000000000000000000005012023276646020140 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/xml/kfd.xsl0000644000076400000000000001763112023276646017637 0ustar00richterroot00000000000000
    Manager / Authorised Corporate Director:








    Name of Trustee/Depositary:
    Fund Investment Objective:
    Initial Charge:&nbsp; %
    Annual Charge:&nbsp; %
    Other Charges:&nbsp; %
    Special Risk Factors:
    Fund Manager's comments on important changes pending:

    Units or shares purchased within an ISA :
    At end of year Investment to date Income to date Effect of deductions to date What you might get back at 7%
    1 &pound;1,000.00 &pound; &pound; &pound;
    3 &pound;1,000.00 &pound; &pound; &pound;
    5 &pound;1,000.00 &pound; &pound; &pound;
    10 &pound;1,000.00 &pound; &pound; &pound;

    The last line in the table shows that over ten years the effect of the total charges and expenses could amount to &pound;. Putting it another way, this would have the same effect as bringing the illustrated investment growth from 7% a year down to %.

    Embperl-2.5.0/test/html/xml/PaxHeaders.14966/pod.xml0000644000000000000000000000005012023276646020150 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/xml/pod.xml0000644000076400000000000000062112023276646017636 0ustar00richterroot00000000000000 HEAD1 some text under HEAD1 HEAD2 some text under HEAD2 HEAD3 some text under HEAD3 format bold code italic underline first item text 1 second item text 2 first item text 1 second item text 2 Embperl-2.5.0/test/html/xml/PaxHeaders.14966/podold.xsl0000644000000000000000000000005012023276646020655 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/xml/podold.xsl0000644000076400000000000000265212023276646020351 0ustar00richterroot00000000000000 POD

    -




    • Embperl-2.5.0/test/html/PaxHeaders.14966/sub.htm0000644000000000000000000000005012023276646017347 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/sub.htm0000644000076400000000000000131712023276646017040 0ustar00richterroot00000000000000 Define a SUbroutine within Embperl Here we define a subroutine

    NOTE: It must be defined within [[! ... !] to avoid redefinition! [! # Here we add a comment sub Hello { # not much to do ... return 'Hello world' ; } !] Now we call the subroutine: [+ Hello () +]

    $XXXXXX::var = [+ defined ($XXXXXX::var)?$XXXXXX::var:'' +]
    Setup some variable outside our namespace, which should not be cleaned up
    [- $XXXXXX::var = 1 -] $XXXXXX::var = [+ defined ($XXXXXX::var)?$XXXXXX::var:'' +]
    [! sub CLEANUP { print LOG "This will be called before variable cleanup\n" ; undef $XXXXXX::var ; } !]

    Ok.

    Embperl-2.5.0/test/html/PaxHeaders.14966/delwrsess.htm0000644000000000000000000000005012023276646020571 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/delwrsess.htm0000644000076400000000000000203212023276646020255 0ustar00richterroot00000000000000 Tests for Embperl - Delete Session Data udat before:
    [- @ks = grep (!/^_/, sort (keys %udat)) ; $num = keys (%udat) - $#ks - 1 ; -]
    [+ $ks[$row] +][+ $udat{$ks[$row] || ''} +]
    [+ $num > 0?"ok (num=$num)":"Not a session hash (num=$num)" +]

    $mdat{cnt} = -[+ $mdat{cnt} +]-
    $udat{cnt} = -[+ $udat{cnt} +]-
    [- $_[0] -> DeleteSession (1) ; -] udat after:
    [- @ks = grep (!/^_/, sort (keys %udat)) ; $num = keys (%udat) - $#ks - 1 ; -]
    [+ $ks[$row] +][+ $udat{$ks[$row] || ''} +]
    [+ $num > 0?"ok (num=$num)":"Not a session hash (num=$num)" +]

    [+ $udat{b} = 2 +] udat after write:
    [- @ks = grep (!/^_/, sort (keys %udat)) ; $num = keys (%udat) - $#ks - 1 ; -]
    [+ $ks[$row] +][+ $udat{$ks[$row] || ''} +]
    [+ $num > 0?"ok (num=$num)":"Not a session hash (num=$num)" +]

    Embperl-2.5.0/test/html/PaxHeaders.14966/setbadsess.htm0000644000000000000000000000005012023276646020716 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/setbadsess.htm0000644000076400000000000000033212023276646020403 0ustar00richterroot00000000000000 Tests for Embperl - Set Session Data (with bad cookie) [- while (($k, $v) = each (%fdat)) { $udat{$k} = $fdat{$k} ; } -] [+ $udat{_session_id} +] Embperl-2.5.0/test/html/PaxHeaders.14966/rawinput0000644000000000000000000000005012323454053017631 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/rawinput/0000755000000000000000000000000012323454053016677 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/rawinput/PaxHeaders.14966/include.htm0000644000000000000000000000005012023276646022052 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/rawinput/include.htm0000644000076400000000000001236412023276646021547 0ustar00richterroot00000000000000 Embperl Tests - Include other Embperl pages via Execute

    Embperl Tests - Include other Embperl pages via Execute

    [- $optRawInput = 1 -] [- $tst1 = '

    Here is some text

    ' . "\n" ; -]

    1.) Include from memory

    [- Execute ({input => \$tst1, mtime => 1, inputfile => 'Some text', }) ; -]

    2.) Include from memory with some Embperl code

    [- Execute ({input => \('[- @ar = (a1, b2, c3) -' . ']
    [+$ar[$col]+]

    ' . "\n" ), mtime => 1, inputfile => 'table', }) ; -]

    3.) Include from memory with passing of variables

    [- $MyPackage::Interface::Var = 'Some Var' ; -] [- Execute ({input => \"

    Transfer some vars [+ \$Var +] !

    \n" , inputfile => 'Var', mtime => 1, 'package' => 'MyPackage::Interface', }) ; -]

    4.) Change the variable, but not the code

    [- $MyPackage::Interface::Var = 'Do it again' ; # code is the same, so give the same mtime and inputfile to avoid recompile # Note you get problems is you change the code, but did not restart the server or # change the value in mtime. So make sure if you change something also change mtime! Execute ({input => \"

    Transfer some vars [+ \$Var +] !

    \n", inputfile => 'Var2', mtime => 1, 'package' => 'MyPackage::Interface', req_rec => $req_rec}) ; -]

    5a.) Use method -> param to pass parameters

    [- Execute ({input => \"

    Use method -> param to transfer some data ([+ do { \$p = shift -> component -> param -> param ; \"\@\$p\" } +]) !

    \n", inputfile => 'Parammethod', param => [1, 2, 3, 4] } ) ; -]

    5.) Use \@param to pass parameters

    [- Execute ({input => \"

    Use \@param to transfer some data ([+ \"\@param\" +]) !

    \n", inputfile => 'Param', param => [1, 2, 3, 4] } ) ; -]

    6.) Use \@param to pass parameters and return it

    [- @p = ('vara', 'varb') ; -]

    $p[0] is [+ $p[0] +] and $p[1] is [+ $p[1] +]

    [- Execute ({input => \('

    Got data in @param ([+ "@param" +]) !

    [- $param[0] = "newA" ; $param[1] = "newB" ; -' . ']

    Change data in @param to ([+ "@param" +]) !

    ' . "\n"), inputfile => 'Param & Return', req_rec => $req_rec, param => \@p } ) ; -]

    $p[0] is now [+ $p[0] +] and $p[1] is now [+ $p[1] +]

    7.) Presetup \%fdat and \@ffld

    [- %myfdat = ('test' => 'value', 'fdat' => 'text') ; @myffld = sort keys %myfdat ; Execute ({input => \('

    [+ $ffld[$row] +][+ do { local $^W = 0 ; $fdat{$ffld[$row]} } +]

    ' . "\n") , inputfile => 'fdat & ffld', req_rec => $req_rec, fdat => \%myfdat, ffld => \@myffld} ) ; -]

    7a.) Presetup my \%fdat and my \@ffld

    [- my %myfdat = ('test1' => 'value1', 'fdat1' => 'text1') ; my @myffld = sort keys %myfdat ; Execute ({input => \('

    [+ $ffld[$row] +][+ do { local $^W = 0 ; $fdat{$ffld[$row]} } +]

    ' . "\n") , inputfile => 'fdat & ffld', req_rec => $req_rec, fdat => \%myfdat, ffld => \@myffld} ) ; -]

    7b.) Presetup \%fdat

    [- %myfdat = ('test2' => 'value2', 'fdat2' => 'text2') ; #@myffld = sort keys %myfdat ; Execute ({input => \('

    [+ $ffld[$row] +][+ do { local $^W = 0 ; $fdat{$ffld[$row]} } +]

    ' . "\n") , inputfile => 'fdat & ffld', req_rec => $req_rec, fdat => \%myfdat,} ) ; -]

    7c.) Presetup \@ffld

    [- %myfdat = ('test3' => 'value3', 'fdat3' => 'text3') ; @myffld = sort keys %myfdat ; Execute ({input => \('

    [+ $ffld[$row] +][+ do { local $^W = 0 ; $fdat{$ffld[$row]} } +]

    @ffld = [+ "@ffld" +]' . "\n") , inputfile => 'ffld', req_rec => $req_rec, ffld => \@myffld} ) ; -]

    8a.) Include a file

    [- Execute ({inputfile => '../inc.htm', options => 0, input_escmode => 7, }) -]

    8b.) Include again the same file

    [- Execute ({inputfile => '../inc.htm', options => 0, input_escmode => 7, }) -]

    9.) Include a file and return output in a scalar

    [- Execute ({inputfile => '../inc.htm', output => \$out, options => 0, input_escmode => 7, req_rec => $req_rec}) ; -]

    [+ $out +]

    10.) Include inside a table

    [- @a = ('m1', 'm2', 'm3') -]
    [+ $a[$row] +] : [- Execute ({inputfile => '../incsub.htm', req_rec => $req_rec, param => [$a[$row], 'main']}) -]

    11.) Include a file with parameters

    [- Execute ('../incparam.htm', 0, 'B', 'three', 'dddd', '555') -]

    12.) Include a file and write outputfile

    [# - Execute ({inputfile => '../inc.htm', outputfile => "../../tmp/incout.htm", }) ; - #]

    12.) Done :-)


    Embperl (c) 1997-2005 G.Richter Embperl-2.5.0/test/html/rawinput/PaxHeaders.14966/rawinput.htm0000644000000000000000000000005012023276646022300 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/rawinput/rawinput.htm0000755000076400000000000000350412023276646021774 0ustar00richterroot00000000000000 Some Plain tests for Embperl using optRawInput Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a || '' +]
    $b = [+ $b || '' +]
    $c = [+ $c || '' +]
    $d = [+ $d || '' +]
    $e = [+ $e || '' +]
    First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöü" -] Now lets look what we are getting from this:
    [+ $a +] [+ $b +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code,
    Embperl will not delete them when optRawInput is set !
    [+ $c = "
    6 + 17 * 3" +] Here we have something which looks like a HTML tag, but does not start with
    a character, Embperl does not change them!
    [+ "SELECT * FROM a ORDER BY b USING <; Hi There>" +] Embperl will not translate HMTL escapes to the right characters
    when optRawInput is set
    [- $e = 2 -] [+ $d = "$e < 6" +] Now they should have a value $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]

    Ok.

    optRawInput is now: [+ $optRawInput +]
    optRawInput is set now to: [+ $optRawInput = 1 +]
    optRawInput is now: [+ $optRawInput +]
    [+ $c = "
    6 + 17 * 3" +] [- $b = "$a äöü" -] Now lets look what we are getting from this:
    $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    optRawInput is now: [+ $optRawInput +]
    optRawInput is set now to: [+ $optRawInput = 0 +]
    optRawInput is now: [+ $optRawInput +]
    [+ $c = "
    6 + 17 * 3" +] [- $b = "$a äöü" -] Now lets look what we are getting from this:
    $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/execsecond.htm0000644000000000000000000000005012023276646020676 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/execsecond.htm0000644000076400000000000000005412023276646020364 0ustar00richterroot00000000000000 [- Execute ('EmbperlObject/epohead.htm') -]Embperl-2.5.0/test/html/PaxHeaders.14966/topinc.htm0000644000000000000000000000005012023276646020052 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/topinc.htm0000644000076400000000000000017012023276646017537 0ustar00richterroot00000000000000 **** start [- Execute({input => \'top = [+ $top +];', inputfile => 'xxx', top_include => '$top = 99;'}) ; -] **** end Embperl-2.5.0/test/html/PaxHeaders.14966/subtextarea.htm0000644000000000000000000000005012023276646021105 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/subtextarea.htm0000644000076400000000000000123512023276646020575 0ustar00richterroot00000000000000 Embperl Tests [$ foreach $k (@ffld) $] [+ $k +] = [+ $fdat{$k} +]
    [$endforeach$] [$ sub EntryRow $]
    [$ endsub $]


    [- EntryRow('Title*', 'title') -] [- EntryRow('Pub. Date*', 'pubdate', '(m/d/y, "today"...)') -]
    Embperl-2.5.0/test/html/PaxHeaders.14966/getdelsess.htm0000644000000000000000000000005012023276646020720 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/getdelsess.htm0000644000076400000000000000165112023276646020412 0ustar00richterroot00000000000000 Tests for Embperl - Set Session Data fdat:
    [- @ks = sort keys %fdat -]
    [+ $ks[$row] +][+ $fdat{$ks[$row] || ''} +]
    udat:
    [- $id = tied (%udat) -> getid -] [- @ks = grep (!/^_/, sort (keys %udat)) ; $num = keys (%udat) - @ks - ($id?0:1) -]
    [+ $ks[$row] +][+ $udat{$ks[$row] || ''} +]
    [+ $id?"ok (num=$num)":"Not a session hash (num=$num)" +]

    [- while (($k, $v) = each (%fdat)) { $udat{$k} = $fdat{$k} ; } -] $mdat{cnt} = -[+ $mdat{cnt} +]-
    $udat{cnt} = -[+ $udat{cnt} +]-
    [- $s = $Apache::Session::Win32::sessions || $Apache::Session::MemoryStore::store -] [- @ks = sort keys %$s -] sessions:
    [+ $ks[$row] +][+ $s -> {$ks[$row] || ''} +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/inputjs2.htm0000644000000000000000000000005012023276646020334 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/inputjs2.htm0000644000076400000000000000375312023276646020033 0ustar00richterroot00000000000000 [$syntax EmbperlHTML$] Embperl-2.5.0/test/html/PaxHeaders.14966/escraw.htm0000644000000000000000000000005012023276646020042 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/escraw.htm0000755000076400000000000000662512023276646017545 0ustar00richterroot00000000000000 Some tests for Embperl escaping [- $optRawInput = 0 -] [- $escmode = 0 -] $optRawInput [+ $optRawInput +] $escmode [+ $escmode +] 'here is a \ ' -> [+ 'here is a \ ' +] 'here is a \\ ' -> [+ 'here is a \\ ' +] 'here is a \\\ ' -> [+ 'here is a \\\ ' +] 'here is a \\\\ ' -> [+ 'here is a \\\\ ' +] 'here is a ' -> [+ 'here is a ' +] 'here is a \ ' -> [+ 'here is a \' +] 'here is a \\ ' -> [+ 'here is a \\' +] 'here is a \\\ ' -> [+ 'here is a \\\' +] 'here is a \\\\ ' -> [+ 'here is a \\\\' +] 'here is a \ ' -> [+ 'here is a \' +] 'here is a \\ ' -> [+ 'here is a \\' +] 'here is a \\\ ' -> [+ 'here is a \\\' +] 'here is a \\\\ ' -> [+ 'here is a \\\\' +] [- $optRawInput = 1 -] [- $escmode = 0 -] $optRawInput [+ $optRawInput +] $escmode [+ $escmode +] 'here is a \ ' -> [+ 'here is a \ ' +] 'here is a \\ ' -> [+ 'here is a \\ ' +] 'here is a \\\ ' -> [+ 'here is a \\\ ' +] 'here is a \\\\ ' -> [+ 'here is a \\\\ ' +] 'here is a ' -> [+ 'here is a ' +] 'here is a \ ' -> [+ 'here is a \' +] 'here is a \\ ' -> [+ 'here is a \\' +] 'here is a \\\ ' -> [+ 'here is a \\\' +] 'here is a \\\\ ' -> [+ 'here is a \\\\' +] 'here is a \ ' -> [+ 'here is a \' +] 'here is a \\ ' -> [+ 'here is a \\' +] 'here is a \\\ ' -> [+ 'here is a \\\' +] 'here is a \\\\ ' -> [+ 'here is a \\\\' +] [- $optRawInput = 0 -] [- $escmode = 1 -] $optRawInput [+ $optRawInput +] $escmode [+ $escmode +] 'here is a \ ' -> [+ 'here is a \ ' +] 'here is a \\ ' -> [+ 'here is a \\ ' +] 'here is a \\\ ' -> [+ 'here is a \\\ ' +] 'here is a \\\\ ' -> [+ 'here is a \\\\ ' +] 'here is a ' -> [+ 'here is a ' +] 'here is a \ ' -> [+ 'here is a \' +] 'here is a \\ ' -> [+ 'here is a \\' +] 'here is a \\\ ' -> [+ 'here is a \\\' +] 'here is a \\\\ ' -> [+ 'here is a \\\\' +] 'here is a \ ' -> [+ 'here is a \' +] 'here is a \\ ' -> [+ 'here is a \\' +] 'here is a \\\ ' -> [+ 'here is a \\\' +] 'here is a \\\\ ' -> [+ 'here is a \\\\' +] [- $optRawInput = 1 -] [- $escmode = 1 -] $optRawInput [+ $optRawInput +] $escmode [+ $escmode +] 'here is a \ ' -> [+ 'here is a \ ' +] 'here is a \\ ' -> [+ 'here is a \\ ' +] 'here is a \\\ ' -> [+ 'here is a \\\ ' +] 'here is a \\\\ ' -> [+ 'here is a \\\\ ' +] 'here is a ' -> [+ 'here is a ' +] 'here is a \ ' -> [+ 'here is a \' +] 'here is a \\ ' -> [+ 'here is a \\' +] 'here is a \\\ ' -> [+ 'here is a \\\' +] 'here is a \\\\ ' -> [+ 'here is a \\\\' +] 'here is a \ ' -> [+ 'here is a \' +] 'here is a \\ ' -> [+ 'here is a \\' +] 'here is a \\\ ' -> [+ 'here is a \\\' +] 'here is a \\\\ ' -> [+ 'here is a \\\\' +] Embperl-2.5.0/test/html/PaxHeaders.14966/hidden.htm0000644000000000000000000000005012023276646020011 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/hidden.htm0000644000076400000000000000353612023276646017507 0ustar00richterroot00000000000000 Test for hidden meta command [- $regs{feld1} = 'Pfalz' ; $regs{feld2} = 'Rhein"hessen"&Pfalz' ; $kats{feld1} = 'Kultur' ; $sort[0] = 'feld4' ; $sort[1] = 'feld3' ; $sort[2] = 'feld2' ; $sort[3] = 'feld1' ; -]

     

    a1[$hidden$] a2[$hidden regs $] a3[$hidden regs, kats $] a4[$hidden regs, kats, sort $] a5[$hidden %regs $] a6[$hidden %regs, %kats $] a7[$hidden %regs, %kats, @sort $] a8[$hidden %fdat, %idat, @sort $] b1[$hidden$] b2[$hidden regs $] b3[$hidden regs, kats $] b4[$hidden regs, kats, sort $] b5[$hidden %regs $] b6[$hidden %regs, %kats $] s1[$hidden$] c1[$hidden$] c2[$hidden regs $] c3[$hidden regs, kats $] c4[$hidden regs, kats, sort $] c5[$hidden %regs $] c6[$hidden %regs, %kats $] d1[$hidden$] d2[$hidden regs $] d3[$hidden regs, kats $] d4[$hidden regs, kats, sort $] d5[$hidden %regs $] d6[$hidden %regs, %kats $] d7[$hidden %regs, %kats, @sort $] [- $fdat{empty1} = undef ; push @ffld, 'empty1' ; -] [- $fdat{empty2} = '' ; push @ffld, 'empty2' ; -] e1[$hidden $] e2[$hidden %fdat, %idat, @ffld $] optNoHiddenEmptyValue is now [+ $optNoHiddenEmptyValue +] [- $optNoHiddenEmptyValue = 1 -] optNoHiddenEmptyValue is now [+ $optNoHiddenEmptyValue +] e1[$hidden $] e2[$hidden %fdat, %idat, @ffld $] [- $optNoHiddenEmptyValue = 0 -] optNoHiddenEmptyValue is now [+ $optNoHiddenEmptyValue +] e1[$hidden $] e2[$hidden %fdat, %idat, @ffld $]
    [$foreach $i (1..4)$]
    l1[$hidden $]
    [$endforeach$] Embperl-2.5.0/test/html/PaxHeaders.14966/noerr0000644000000000000000000000005012323454053017105 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/noerr/0000755000000000000000000000000012323454053016153 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/noerr/PaxHeaders.14966/noerrpage.htm0000644000000000000000000000005012023276646021665 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/noerr/noerrpage.htm0000644000076400000000000000201712023276646021354 0ustar00richterroot00000000000000 Some Plain tests for Embperl Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    Here we will see an error: [- $a = (qqqqqqqqqqqqqq -] First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöü" -] Second Error:
    [+ $a+ +] [+ qq2$b +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
    [- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value [$if {$error is here ) $] $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    [$endif$] Tag missmatch:

    Ok.

    Embperl-2.5.0/test/html/PaxHeaders.14966/plain.htm0000644000000000000000000000005012023276646017661 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/plain.htm0000644000076400000000000000411112023276646017345 0ustar00richterroot00000000000000 Some Plain tests for Embperl Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a || '' +]
    $b = [+ $b || '' +]
    $c = [+ $c || '' +]
    $d = [+ $d || '' +]
    $e = [+ $e || '' +]
    ARRAY @d = [+ do { my @tmp1 = @d; "@tmp1" } +] num = [+ @d +]
    ARRAY @x = [+ do { my @tmp1 = %x; "@tmp1" } +] num = [+ @x +]
    HASH %a = [+ do { my @tmp1 = %a; my @tmp11 = sort @tmp1 ; "@tmp11" } +] num = [+ keys %a +]
    HASH %y = [+ do { my @tmp2 = %y; my @tmp21 = sort @tmp2 ; "@tmp21" } +] num = [+ keys %y +]
    First of all assign a value: [- $a = '(this is the value in $a)' -]
    [- @d = (1, 2, 3) ; @x = (9, 8, 7) -] [- %a = (1 => 'a', 2 => 'b', 3 => 'c') ; %y = (9 => 'x', 8 => 'y', 7 => 'z') -] Now we have some 'Umlaute': [- $b = "$a äöü" -] Now lets look what we are getting from this:
    [+ $a +] [+ $b +]
    ARRAY @d = [+ "@d" +] num = [+ @d +]
    ARRAY @x = [+ "@x" +] num = [+ @x +]
    HASH %a = [+ do { my @tmp1 = %a; my @tmp11 = sort @tmp1 ; "@tmp11" } +] num = [+ keys %a +]
    HASH %y = [+ do { my @tmp2 = %y; my @tmp21 = sort @tmp2 ; "@tmp21" } +] num = [+ keys %y +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3    + 0 +] [+ "SELECT *
    FROM a ORDER BY b USING <; Hi There>" +] Here we have something which looks like a HTML tag, but does not start with
    a character, Embperl does not change them!
    [+ "SELECT * FROM a ORDER BY b USING <; Hi There>" +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
    [- $e = 2 # here is a perl comment -] [+ $d = $e < 6 +] Now they should have a value $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    Input Separator = [+ ord($/) +]
    [-=pod blabla =cut-] [- =pod blabla =cut -]

    Ok.

    Embperl-2.5.0/test/html/PaxHeaders.14966/cookieexpire.htm0000644000000000000000000000005012023276646021244 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/cookieexpire.htm0000644000076400000000000000036012023276646020732 0ustar00richterroot00000000000000 [- $r = shift -] app_name: [+ $r -> app -> config -> app_name +] cookie_expires cfg: [+ $r -> app -> config -> cookie_expires +] cookie_expires req: [+ $r -> cookie_expires +] output_mode: [+ $r -> config -> output_mode +] Embperl-2.5.0/test/html/PaxHeaders.14966/sub2.htm0000644000000000000000000000005012023276646017431 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/sub2.htm0000644000076400000000000000150612023276646017122 0ustar00richterroot00000000000000 Tests for Embperl - Embperl sub Metacommand 2 [###### sub 1 #####] [$sub txt1$] *txt* *txt*

    Here goes some normal html text

    *txt* [$endsub$] [###### sub 2 #####] [$sub txt2$] *txt2* *txt2*

    Here goes some normal html text

    *txt2* [- txt1 -] *txt2* after txt1 [$endsub$] [###### sub 3 #####] [$sub txt3$] [- txt2 -] *txt3* after txt3 [$endsub$] [$sub tabrow $]

    [$endsub$]

    Tests for Embperl - Embperl sub Metacommand 2

    *1 [- txt1 -] *2 [- txt2 -] *3 [- txt1 -] [- txt2 -] *4 [- txt1 ; txt2 -] [- txt1 ; txt2 -] ----> txt3 [- txt3 -] ========================================================
    [+ $_[0] +]
    [- tabrow(1) -] [$if (1) $] [- tabrow(2) -] [$else$] [- tabrow(3) -] [$endif$] [- tabrow(4) -] -> 5 [- tabrow(5) -]
    Embperl-2.5.0/test/html/PaxHeaders.14966/exit3.htm0000644000000000000000000000005012023276646017612 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/exit3.htm0000644000076400000000000000023612023276646017302 0ustar00richterroot00000000000000 Tests for Embperl - exit in sub [$ sub x $] [- exit -] [$endsub$] Before Exit [- x -] After Exit Embperl-2.5.0/test/html/PaxHeaders.14966/incxmlLibXSLT.htm0000644000000000000000000000005012023276646021212 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/incxmlLibXSLT.htm0000644000076400000000000000056612023276646020710 0ustar00richterroot00000000000000 Include POD via XSLT

    Start pod.xml

    [- Execute ({inputfile => 'xml/pod.xml', recipe => 'EmbperlLibXSLT', xsltstylesheet => 'xml/podold.xsl'}) ; -]

    Start kfdres.xml

    [- Execute ({inputfile => 'xml/kfdres.xml', recipe => 'EmbperlLibXSLT', xsltstylesheet => 'xml/kfd.xsl'}) ; -]

    END

    Embperl-2.5.0/test/html/PaxHeaders.14966/subtab.htm0000644000000000000000000000005012023276646020036 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/subtab.htm0000644000076400000000000000470012023276646017526 0ustar00richterroot00000000000000 Embperl Test - Subs and Tables [###############################################################################################] [$ sub Kurslink $][$endsub$] [###############################################################################################] [$ sub cell $] [$if !$rec -> {id} $] [- Neulink -] [$ elsif $fdat{bereich_id} eq 'f' || !$kurs -> {-gebucht} || $xkurs $] [$if $xkurs $]  [- Kurslink -] {-gebucht}?"/images/leer_rot.gif":"/images/leer_gelb.gif") +]"> [$else$]  [- Kurslink -] [$endif$] [$ elsif $fdat{bereich_id} eq 'b' $] [- $n = 2 -] [$ while ($n--) $] [- $banzahl = 1 ; $sanzahl = 5 ; -] [$ if $banzahl > 0 $] [$endif$] [$endwhile$]
    [- Kurslink -][- Kurslink (($sanzahl || 0) . "/$banzahl") -] [+ $brec -> {bereichkurz} +] 
    [$ endif $] [$endsub $] [###############################################################################################] [- $rec = { id => 1 } ; $kurs = { -gebucht => 1 } ; $brec = { id => 2, bereichkurz => 'bu' } ; $fdat{bereich_id} = 'b' ; $bgcol = '#1' ; $gifext = 'xxx' ; $l = 2 ; -] [$ while ($l-- > 0) $] [- cell -] [$endwhile$]
    Embperl-2.5.0/test/html/PaxHeaders.14966/incerrobj.htm0000644000000000000000000000005012023276646020533 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/incerrobj.htm0000644000076400000000000000032412023276646020221 0ustar00richterroot00000000000000[+ "Start include incerrobj" +] [! { package testerrobj ; sub new { return bless { msg => "Error Message from Object"} ; } } !] [- die testerrobj -> new () ; -] [+ "End include incerrobj" +] Embperl-2.5.0/test/html/PaxHeaders.14966/pod0000644000000000000000000000005012323454053016542 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/pod/0000755000000000000000000000000012323454053015610 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/pod/PaxHeaders.14966/pod.asc0000644000000000000000000000005012023276646020100 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/pod/pod.asc0000644000076400000000000000312112023276646017564 0ustar00richterroot00000000000000something before =pod =head1 NAME Test pod for Embperl =head1 HEAD1 some text under HEAD1 more text under HEAD1 some verbatim paragraph normal text wraps around verbatim col 1 line 2 line 3 verbatim col 3 lin2 lin3 again col 3 para text goes here =head2 HEAD2 some text under HEAD2 =head2 second HEAD2 which wraps to the next line some text under HEAD2 which also warps to the next line another paragraph is this =head3 HEAD3 some text under HEAD3 =head2 third HEAD2 which wraps to the next line some text under HEAD2 which also warps to the next line format B C I U =over 4 =item first item text 1 =item second item text 2 =back =over 4 =item * first item text 1 two lines =item * second item text 2 two lines =over 4 =item nested list item 1 text 1 line 2 =item nested list item 2 text 2 line 2 =back =back =head1 again HEAD1 and second line of title again some text under HEAD1 =head2 again HEAD2 again some text under HEAD2 =cut This text should be not visble =head1 restart some text =cut This text should be not visble2 =head1 restart 2 =head2 restart 2 Head 2 text =cut This text should be not visble3 =head1 restart 2 =head2 restart 2 Head 2 =cut This text should be not visble4 =head2 restart 3 Head 2 end L L http://www.ecos.de ftp://ftp.dev.ecos.de L L<"xxx 2"|"yyy 2"> http://www.ecos.de ftp://ftp.dev.ecos.de =head1 #ID Test head1 =head2 #ID Test head2 #ID Test para =cut This text should be not visble5 Embperl-2.5.0/test/html/PaxHeaders.14966/tabmode.htm0000644000000000000000000000005012023276646020171 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/tabmode.htm0000755000076400000000000000346612023276646017674 0ustar00richterroot00000000000000 [- undef @a ; undef @b ; $a[0][0] = 'a1/1' ; $a[1][0] = 'a2/1' ; $a[1][1] = 'a2/2' ; $a[2][0] = 'a3/1' ; $a[2][1] = 'a3/2' ; $a[2][2] = 'a3/3' ; $b[0][0] = 'b1/1' ; $b[1][0] = 'b2/1' ; $b[1][1] = 'b2/2' ; $b[2][0] = 'b3/1' ; $b[2][1] = 'b3/2' ; $b[2][2] = 'b3/3' ; $maxcol=99 ; -] $a[0][[0] = '1/1' ;
    $a[1][[0] = '2/1' ;
    $a[1][[1] = '2/2' ;
    $a[2][[0] = '3/1' ;
    $a[2][[1] = '3/2' ;
    $a[2][[2] = '3/3' ;

    $tabmode = default

    [+ $a[$row][0] +]
    1 2 3
    [+ $a[$row][$col] +]
    [+ $b[2][$col] +]
    [+ $a[$row][$col] +]

    $tabmode=3 + 48 ; $maxcol = 4; $maxrow = 4

    [- $tabmode=3 + 48 ; $maxcol = 4; $maxrow = 4 -]
    [+ $a[$row][$col] +]

    $tabmode=1 + 32 ;

    [- $tabmode=1 + 32 ; -]
    [+ $a[$row][$col] +]
    optDisableTableScan is now: [+ $optDisableTableScan +]
    optDisableTableScan is set now to: [+ $optDisableTableScan = 1 +]
    optDisableTableScan is now: [+ $optDisableTableScan +]
    [+ $a[$row][$col] +]
    optDisableTableScan is now: [+ $optDisableTableScan +]
    optDisableTableScan is set now to: [+ $optDisableTableScan = 0 +]
    optDisableTableScan is now: [+ $optDisableTableScan +]
    [+ $a[$row][$col] +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/nph0000644000000000000000000000005012323454053016545 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/nph/0000755000000000000000000000000012323454053015613 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/nph/PaxHeaders.14966/nphinc.htm0000644000000000000000000000005012023276646020622 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/nph/nphinc.htm0000755000076400000000000000100612023276646020311 0ustar00richterroot00000000000000 Embperl Tests - Include with optEarlyHttpHeaders

    Embperl Tests - Include with optEarlyHttpHeaders

    forinc in main = [+ $fdat{forinc} +]
    Before Execute
    [- Execute('incshort.htm', 'Inside Execute') -] After Execute [- $fdat{forinc} = 'message' -] forinc in main = [+ $fdat{forinc} +]
    In Table Before Execute
    [- Execute('incshort.htm', 'In Table Inside Execute') -] In Table After Execute
    Embperl-2.5.0/test/html/nph/PaxHeaders.14966/incshort.htm0000644000000000000000000000005012023276646021174 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/nph/incshort.htm0000755000076400000000000000010712023276646020664 0ustar00richterroot00000000000000[+ $param[0] +]
    forinc in include = [+ $fdat{forinc} +]
    Embperl-2.5.0/test/html/nph/PaxHeaders.14966/npherr.htm0000644000000000000000000000005012023276646020641 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/nph/npherr.htm0000644000076400000000000000201712023276646020330 0ustar00richterroot00000000000000 Some Plain tests for Embperl Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    Here we will see an error: [- $a = (qqqqqqqqqqqqqq -] First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöü" -] Second Error:
    [+ $a+ +] [+ qq2$b +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
    [- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value [$if {$error is here ) $] $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    [$endif$] Tag missmatch:

    Ok.

    Embperl-2.5.0/test/html/nph/PaxHeaders.14966/div.htm0000644000000000000000000000005012023276646020125 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/nph/div.htm0000644000076400000000000000666712023276646017633 0ustar00richterroot00000000000000 Some Plain tests Embperl Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a || '' +]
    $b = [+ $b || '' +]
    $c = [+ $c || '' +]
    $d = [+ $d || '' +]
    $e = [+ $e || '' +]
    First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöü" -] Now lets look what we are getting from this:
    [+ $a +] [+ $b +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
    [- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    [- $a = 1; $b = 0; $c = 5; $d = 'txt' -] [$if $a$] a
    [$ endif$] [$if $a $] a
    [$else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [$ if !$a$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [- $i = 0 -] [$ while $i <= $#ffld $] [+ $ffld[$i] +] = [+ $fdat{$ffld[$i]} +] [- $j = 0 -] [$ while $j <= $i $] [+ $j++ +] [$ endwhile $]
    [- $i++ -] [$ endwhile $]

    [+ $c[$row][$col] +]

    $tabmode = default

    Display an two dimensional array with one, two and three columns !
    Please take a look at the source in your browser to see the difference
    [- undef @a ; undef @b ; $a[0][0] = 'a1/1' ; $a[1][0] = 'a2/1' ; $a[1][1] = 'a2/2' ; $a[2][0] = 'a3/1' ; $a[2][1] = 'a3/2' ; $a[2][2] = 'a3/3' ; $b[0][0] = 'b1/1' ; $b[1][0] = 'b2/1' ; $b[1][1] = 'b2/2' ; $b[2][0] = 'b3/1' ; $b[2][1] = 'b3/2' ; $b[2][2] = 'b3/3' ; $maxcol=99 ; -] $a[0][[0] = '1/1' ;
    $a[1][[0] = '2/1' ;
    $a[1][[1] = '2/2' ;
    $a[2][[0] = '3/1' ;
    $a[2][[1] = '3/2' ;
    $a[2][[2] = '3/3' ;

    $tabmode = default

    [+ $a[$row][$col] +]
    [+ $a[$row][$col] +]
    [+ $a[$row][$col] +]
    [+ $b[$row][$col] +]
    [+ $a[$row][$col] +]

    [+ $HTML::Embperl::VERSION +]

    [+ $tabmode || 17 +]

    [+ local $tabmode = 1 +]

    [- $i = 0 ; while ($i < 10) { $ii[$i++] = "ii[$i] = $i" ; } -]
    [+ $ii[$row] +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/varepvar.htm0000644000000000000000000000005012023276646020404 xustar000000000000000020 atime=1397643272 20 ctime=1397643307 Embperl-2.5.0/test/html/varepvar.htm0000644000076400000000000000133512023276646020075 0ustar00richterroot00000000000000 Test for predefined Embperl variables and [ $ var $ ] [$ var $conf $ar $] $conf = [+ defined ($conf)?$conf:'' +]
    $_[0] = [+ defined ($_[0])?$_[0]:'' +]
    $_[1] = [+ defined ($_[1])?$_[1]:'' +]
    $rec_rec = [+ $req_rec +]
    $$rec_rec = [+ $$req_rec +]
    [- $ar = $Embperl::modperlapi >= 2?eval { Apache2::RequestUtil->request }:eval { Apache->request } ; $@ = '' -] Apache->request = [+ $ar +]
    ${Apache->request} = [+ $$ar +]
    ${Apache->request} = $$req_rec ? [+ ($$ar == $$req_rec)?'yes':'no' +]
    [+ $req_rec -> filename +]
    [+ $ffld[$row] +][+ $fdat{$ffld[$row]} +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/errorfirstrun.htm0000644000000000000000000000005012047455004021475 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/errorfirstrun.htm0000644000000000000000000000007512047455004020470 0ustar00rootroot00000000000000[! use strict; sub test { $x = 1; } !] [! 5 + !]Embperl-2.5.0/test/html/PaxHeaders.14966/ifuncsrc0000644000000000000000000000005012323454053017574 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/ifuncsrc/0000755000000000000000000000000012323454053016642 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/ifuncsrc/PaxHeaders.14966/proxy.htm0000644000000000000000000000005012023276646021553 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/ifuncsrc/proxy.htm0000644000076400000000000000246512023276646021251 0ustar00richterroot00000000000000 mod_include/proxy test This document contains SSI and Embperl commands
    Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a || '' +]
    $b = [+ $b || '' +]
    $c = [+ $c || '' +]
    $d = [+ $d || '' +]
    $e = [+ $e || '' +]
    First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöü" -] Now lets look what we are getting from this:
    [+ $a +] [+ $b +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3    + 0 +] [+ "SELECT *
    FROM a ORDER BY b USING <; Hi There>" +] Here we have something which looks like a HTML tag, but does not start with
    a character, Embperl does not change them!
    [+ "SELECT * FROM a ORDER BY b USING <; Hi There>" +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
    [- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]

    Ok.

    The following code should be trapped by the perl interpreter
    when running with -T option or PaintTaintCheck on

    [+ do { system ('echo blabla') ;} +]

    Ok.

    Embperl-2.5.0/test/html/PaxHeaders.14966/inputdisable.htm0000644000000000000000000000005012023276646021241 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/inputdisable.htm0000755000076400000000000001676412023276646020751 0ustar00richterroot00000000000000 [- @ks = sort keys %idat -]
    [+ $ks[$row] +][+ $idat{$ks[$row] || ''} +]
    optDisableInputScan is now: [+ $optDisableInputScan +]
    optDisableInputScan is set now to: [+ $optDisableInputScan = 1 +]
    optDisableInputScan is now: [+ $optDisableInputScan +]
    [+ $ks[$row] +][+ $idat{$ks[$row] || ''} +]
    optDisableInputScan is now: [+ $optDisableInputScan +]
    optDisableInputScan is set now to: [+ $optDisableInputScan = 0 +]
    optDisableInputScan is now: [+ $optDisableInputScan +]
    [+ $ks[$row] +][+ $idat{$ks[$row] || ''} +]
    optUndefToEmptyValue is now: [+ $optUndefToEmptyValue +]
    optUndefToEmptyValue is set now to: [+ $optUndefToEmptyValue = 1 +]
    optUndefToEmptyValue is now: [+ $optUndefToEmptyValue +]
    optUndefToEmptyValue is now: [+ $optUndefToEmptyValue +]
    optUndefToEmptyValue is set now to: [+ $optUndefToEmptyValue = 0 +]
    optUndefToEmptyValue is now: [+ $optUndefToEmptyValue +]
    [- $fdat{mult2} = "Wert2\tWert5\tWert6" ; -] [- $fdat{mult3} = "Wert4" ; -] [- $fdat{mult4} = "Wert1\tWert2\tWert7" ; -] [- $fdat{mult5} = "Wert3" ; -] [- $fdat{mycheck} = 'N' -] optRawInput is now: [+ $optRawInput +]
    optRawInput is set now to: [+ $optRawInput = 1 +]
    optRawInput is now: [+ $optRawInput +]

    Embperl-2.5.0/test/html/PaxHeaders.14966/ifperl.htm0000644000000000000000000000005012023276646020037 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/ifperl.htm0000755000076400000000000000324612023276646017536 0ustar00richterroot00000000000000 IF Metacommand in Embperl [- $a = 1; $b = 0; $c = 5; $d = 'txt' -] a1 [* if ($a) { *] a
    [* } *] a2 [* if ( $a) { *] a
    [* } else { *] not a
    [* } *] a3 [* if ( $a
    ) { *] a
    [* } else {
    *] not a
    [* }
    *] a4 [*
    if ($a) { *] a
    [*
    } else {
    *] not a
    [*
    } *] a5 [* if ($a) {*] a
    [* if ( $b == 0) {*] b is null
    [* } else { *] b is not null
    [* } *] [* } else{*] not a
    [* } *] [* if ($a) {*] a
    [* if ( $b == 0) {*] b is null
    [* } else { *] b is not null
    [* } *] [* } else {*] not a
    [* if ( $b == 0) {*] b is null
    [* } else { *] b is not null
    [* } *] [* } *] [* if (!$a) {*] not a
    [* if ( $b == 0) {*] b is null
    [* } else { *] b is not null
    [* } *] [* } else {*] a
    [* if ( $b == 0) {*] b is null
    [* } else { *] b is not null
    [* } *] [* } *] [* if ($a) {*] a
    [* if ( $b == 0) {*] b is null
    [* } elsif ($c == 5) { *] b is not null and c is 5
    [* } elsif ($d eq 'txt') {*] b is not null and c is not 5, but d is 'txt'
    [* } else { *] b is not null and c is not 5 and d is not 'txt'
    [* } *] [* } else {*] not a
    [* } *] [- $ttrue = 'true'; $tfalse = '' -] [* if ( $ttrue) { *] ttrue = true [* } else { *] ttrue = false [* } *] [* if ( $tfalse) { *] tfalse = true [* } else { *] tfalse = false [* } *] Embperl-2.5.0/test/html/PaxHeaders.14966/incperl.htm0000644000000000000000000000005012023276646020212 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/incperl.htm0000644000076400000000000000037512023276646017706 0ustar00richterroot00000000000000 Embperl Tests - Include perl script [- $a = 'Start' ; $b = 'End' -] [+ $a +] [- Execute ({inputfile => 'registry/script.pl', syntax => 'Perl', param => ['a', 'b', 'c']}) ; -] [+ $b +] Embperl-2.5.0/test/html/PaxHeaders.14966/execnotfound.htm0000644000000000000000000000005012023276646021257 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/execnotfound.htm0000644000076400000000000000035412023276646020750 0ustar00richterroot00000000000000 Tests for Embperl - Execute non exitent file [- $r = shift ; $rc = Execute ({ inputfile => 'notfound.htm', options => 262144 }) ; -] rc = [+ $rc +]

    Done.

    Embperl-2.5.0/test/html/PaxHeaders.14966/execwithsub2.htm0000644000000000000000000000005012023276646021172 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/execwithsub2.htm0000644000076400000000000000010112023276646020651 0ustar00richterroot00000000000000[$ sub test $] test [$ endsub $] [- Execute({sub => 'test'}) -] Embperl-2.5.0/test/html/PaxHeaders.14966/keepspaces.htm0000644000000000000000000000005012023276646020701 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/keepspaces.htm0000644000076400000000000000062312023276646020371 0ustar00richterroot000000000000001 2 3 [$if 1 $]4 5 [$endif$] 6 7 [+ 7.1 +] 7.2 8 [$sub foo $] foo2 [$if 0 $] foo2.1 [$endif$] foo2.2 [$endsub$] after sub foo call sub foo [- foo -] more text call sub foo 2 [- foo -] more text 2 [$sub bar$]inbar[$endsub$] call sub bar [- bar -] after call to bar call sub bar 2 [- bar -] after call to bar 2 [$foreach $i (1..5) $] # new line [+ $i +] [$endforeach$] Embperl-2.5.0/test/html/PaxHeaders.14966/varerr.htm0000644000000000000000000000005012023276646020057 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/varerr.htm0000644000076400000000000000200012023276646017536 0ustar00richterroot00000000000000 Some Plain tests for Embperl [$VAR $vara $varb $c $] Here it starts with some HTML Text

    All values should be undefined: $vara = [+ $vara +]
    $varb = [+ $varb +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    First of all assign a value: [- $vara = '(this is the value in $vara)' -]
    Now we have some 'Umlaute': [- $varb = "$vara äöü" -] Now lets look what we are getting from this:
    [+ $vara +] [+ $varb +]
    And now a and b together: [+ "$vara$varb" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $vara &lt; 6 will get the perl expression $vara < 6:
    [- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value $vara = [+ $vara +]
    $varb = [+ $varb +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]

    Ok.

    Embperl-2.5.0/test/html/PaxHeaders.14966/nooutput.htm0000644000000000000000000000005012023276646020453 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/nooutput.htm0000644000076400000000000000025212023276646020141 0ustar00richterroot00000000000000 Tests for Embperl - Some Perl, but no output 1 [- $a = 5 -] 2 [- $x = localtime -] 3 [- $b = $x . $a -] Embperl-2.5.0/test/html/PaxHeaders.14966/execviamod.pm0000644000000000000000000000005012311326120020505 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/execviamod.pm0000644000076400000000000000105112311326120020171 0ustar00richterroot00000000000000 sub execviamod { print OUT "begin execviamod\n" ; Embperl::Execute ({inputfile => 'plain.htm', input_escmode => 7, escmode => 7}) ; print OUT "middle execviamod\n" ; Embperl::Req::ExecuteComponent ({inputfile => 'plain.htm', input_escmode => 7, escmode => 7}) ; print OUT "end execviamod\n" ; } sub execviamod2 { Embperl::Execute ({inputfile => 'div.htm', input_escmode => 7, escmode => 7}) ; Embperl::Req::ExecuteComponent ({inputfile => 'div.htm', input_escmode => 7, escmode => 7}) ; } 1 ; Embperl-2.5.0/test/html/PaxHeaders.14966/keepreq.htm0000644000000000000000000000005012023276646020212 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/keepreq.htm0000644000076400000000000000052512023276646017703 0ustar00richterroot00000000000000 [- $r = shift ; $p = $r -> param ; -] r before global: [+ $Embperl::TEST::r +] lokal: [+ $r +] p before global: [+ $Embperl::TEST::p +] lokal: [+ $p +] [- $Embperl::TEST::r = $r ; $Embperl::TEST::p = $p ; -] r after global: [+ $Embperl::TEST::r +] lokal: [+ $r +] p after global: [+ $Embperl::TEST::p +] lokal: [+ $p +] Embperl-2.5.0/test/html/PaxHeaders.14966/includeerr3.htm0000644000000000000000000000005012023276646020775 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/includeerr3.htm0000644000076400000000000000133412023276646020465 0ustar00richterroot00000000000000 Embperl Tests - Errors in Include other Embperl pages via Execute 3

    Embperl Tests - Errors in Include other Embperl pages via Execute 3

    [# cause runtime error #] [- Execute ( {inputfile => 'incerr.htm', param => ['err', 'main'], errors => \@errors}) -] ***errors: [+ "@errors" +]
    [- $rc = Execute ( {inputfile => 'incerrobj.htm', errors => \@errors}) -] ***rc: [+ $rc +] ***errors: #[+ scalar(@errors) +]
    ***errors: [+ join ("\n\n", @errors) +]
    ***errobj: [- $e = $epreq -> errobj -][+ $e +]
    ***errobj msg: [+ $epreq -> errobj?$epreq -> errobj -> {msg}:'' +]
    ***errors msg: [+ ref $errors[-1]?$errors[-1] -> {msg}:'' +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/getsess.htm0000644000000000000000000000005012023276646020233 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/getsess.htm0000755000076400000000000000370312023276646017730 0ustar00richterroot00000000000000 Tests for Embperl - Set Session Data [# [- $s = $Apache::Session::Win32::sessions || $Apache::Session::MemoryStore::store -] [- @ks = sort keys %$s -] sessions:
    [+ $ks[$row] +][+ $sh = $s -> {$ks[$row] || ''} +][$if ref($sh) eq 'HASH' $][+ do { my @tmp = map { "$_ = $sh->{$_}" } keys (%$sh) ; join (', ', @tmp) } +][$endif$]
    tied (%mdat) [+ $m = tied (%mdat) +]
    ref [+ ref ($m) +]
    content [+ do { my @tmp = map { "$_ = $mdat{$_}" } keys (%mdat) ; join (', ', @tmp) } +]
    tied (%udat) [+ $u = tied (%udat) +]
    ref [+ ref ($u) +]
    content [+ do { my @tmp = map { "$_ = $udat{$_}" } keys (%udat) ; join (', ', @tmp) } +]
    a=[+ scalar (do {$udat{'a'}}) +][+ $aa +] #] fdat:
    [- @ks = sort keys %fdat -]
    [+ $ks[$row] +][+ $fdat{$ks[$row] || ''} +]
    udat:
    [- $id = tied (%udat) -> getid -] [- @ks = grep (!/^_/, sort (keys %udat)) ; $num = keys (%udat) - @ks - ($id?0:1) -]
    [+ $ks[$row] +][+ $udat{$ks[$row] || ''} +]
    [+ $id?"ok (num=$num)":"Not a session hash (num=$num)" +]

    [- while (($k, $v) = each (%fdat)) { $udat{$k} = $fdat{$k} ; } -] $mdat{cnt} = -[+ $mdat{cnt} +]-
    $udat{cnt} = -[+ $udat{cnt} +]-
    [- $s = $Apache::Session::Win32::sessions || $Apache::Session::MemoryStore::store -] [- @ks = sort keys %$s -] sessions:
    [+ $ks[$row] +][+ $sh = $s -> {$ks[$row] || ''} +][$if ref($sh) eq 'HASH' $][+ do { my @tmp = map { "$_ = $sh->{$_}" } keys (%$sh) ; join (', ', @tmp) } +][$endif$]
    continue continue continue

    Embperl-2.5.0/test/html/PaxHeaders.14966/errmsg2.htm0000644000000000000000000000005012023276646020137 xustar000000000000000020 atime=1397643272 20 ctime=1397643307 Embperl-2.5.0/test/html/errmsg2.htm0000755000076400000000000000065312023276646017635 0ustar00richterroot00000000000000 Tests for Embperl - ErrorDocument This page is shown due to an ErrorDocument redirection

    main: [+ $req_rec -> main +] prev: [+ $req_rec -> prev +] next: [+ $req_rec -> next +] [- $errors = $req_rec -> prev -> pnotes('EMBPERL_ERRORS') ; -] There are [+ scalar(@$errors) +] errormessages:
    [+ $errors -> [$row] +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/select.htm0000644000000000000000000000005012023276646020035 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/select.htm0000644000076400000000000000113412023276646017523 0ustar00richterroot00000000000000[- $values = [ [1, 2, 'a', 'aa'], [3, 4, 'b', 'bb'], [5, 6, 'c', 'cc'] ]; -] Embperl-2.5.0/test/html/PaxHeaders.14966/subempty.htm0000644000000000000000000000005012023276646020426 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/subempty.htm0000644000076400000000000000025012023276646020112 0ustar00richterroot00000000000000[$sub entry $] [* my ($obj) = @_ ; return if (!$obj) ; *] [+ $obj +] [$endsub $] [$sub txt $] blablabla [$endsub$] [- entry (undef) ; entry ('not undef') ; txt ; -] Embperl-2.5.0/test/html/PaxHeaders.14966/selecttab.htm0000644000000000000000000000005012023276646020524 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/selecttab.htm0000644000076400000000000000731412023276646020220 0ustar00richterroot00000000000000
    Audience > Multiple Upload
     
    Upload Audience
    [- $file = $table[$r=$row][$c=$col] -] [- use Data::Dumper ; -][+ Dumper (@table, $r, $c) +]
    Upload File [+ $file +]
     
    Browse for File to Upload
     
    Website
     
    Embperl-2.5.0/test/html/PaxHeaders.14966/subreq.htm0000644000000000000000000000005012023276646020057 xustar000000000000000020 atime=1397643278 20 ctime=1397643307 Embperl-2.5.0/test/html/subreq.htm0000644000076400000000000000022612023276646017546 0ustar00richterroot00000000000000 Embperl Tests - Apache 2 subrequest [- Execute ({subreq=>'/html/match/div.asc'}) -] Embperl-2.5.0/test/html/PaxHeaders.14966/subexec.htm0000644000000000000000000000005012023276646020214 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/subexec.htm0000644000076400000000000000045012023276646017702 0ustar00richterroot00000000000000 [###### first sub #####] [$sub tfirst$] *1* *1*

    1.) Here goes some normal html text

    *1* [$endsub$] [###### second sub #####] [$sub tsecond $] *2* *2*2.) Here comes some perl: *2* *2*[- $foo = 'Hello world' -] *2* *2*foo = [+ $foo +]
    *2*testdata = [+ $testdata +]
    *2* [$endsub$] Embperl-2.5.0/test/html/PaxHeaders.14966/hostconfig.htm0000644000000000000000000000005012023276646020721 xustar000000000000000020 atime=1397643275 20 ctime=1397643307 Embperl-2.5.0/test/html/hostconfig.htm0000644000076400000000000000030112023276646020402 0ustar00richterroot00000000000000 appname = [+ $_[0] -> app -> config -> app_name +]
    input_escmode = [+ $_[0] -> component -> config -> input_escmode +]
    object_base = [+ $_[0] -> app -> config -> object_base +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/includeerrbt.htm0000644000000000000000000000005012023276646021240 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/includeerrbt.htm0000644000076400000000000000053512023276646020732 0ustar00richterroot00000000000000 Embperl Tests - Errors in Include with backtrace

    Embperl Tests - Errors in Include with backtrace

    [- Execute ( {inputfile => 'incerr.htm', param => ['err', 'main'], options => Embperl::Constant::optShowBacktrace}) -]

    Embperl (c) 1997-2005 G.Richter Embperl-2.5.0/test/html/PaxHeaders.14966/getnosess.htm0000644000000000000000000000005012023276646020570 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/getnosess.htm0000755000076400000000000000151212023276646020261 0ustar00richterroot00000000000000 Tests for Embperl - Set Session Data fdat:
    [- @ks = sort keys %fdat -]
    [+ $ks[$row] +][+ $fdat{$ks[$row] || ''} +]
    udat:
    [- $id = tied (%udat) -> getid -] [- @ks = grep (!/^_/, sort (keys %udat)) ; $num = keys (%udat) - @ks - ($id?0:1) -]
    [+ $ks[$row] +][+ $udat{$ks[$row] || ''} +]
    [+ $id?"ok (num=$num)":"Not a session hash (num=$num)" +]

    [- while (($k, $v) = each (%fdat)) { $udat{$k} = $fdat{$k} ; } -] [- $s = $Apache::Session::Win32::sessions || $Apache::Session::MemoryStore::store -] [- @ks = sort keys %$s -] sessions:
    [+ $ks[$row] +][+ $s -> {$ks[$row] || ''} +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/match0000644000000000000000000000005012323454053017054 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/match/0000755000000000000000000000000012323454053016122 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/match/PaxHeaders.14966/div.asc0000644000000000000000000000005012023276646020412 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/match/div.asc0000644000076400000000000000706512023276646020111 0ustar00richterroot00000000000000 Some Plain tests Embperl Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a || '' +]
    $b = [+ $b || '' +]
    $c = [+ $c || '' +]
    $d = [+ $d || '' +]
    $e = [+ $e || '' +]
    First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöü" -] Now lets look what we are getting from this:
    [+ $a +] [+ $b +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
    [- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    [- $a = 1; $b = 0; $c = 5; $d = 'txt' -] [$if $a$] a
    [$ endif$] [$if $a $] a
    [$else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [$ if !$a$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [- $i = 0 -] [$ while $i <= $#ffld $] [+ $ffld[$i] +] = [+ $fdat{$ffld[$i]} +] [- $j = 0 -] [$ while $j <= $i $] [+ $j++ +] [$ endwhile $]
    [- $i++ -] [$ endwhile $]
    [+ $c[$row][$col] +]

    $tabmode = default

    Display an two dimensional array with one, two and three columns !
    Please take a look at the source in your browser to see the difference
    [- undef @a ; undef @b ; $a[0][0] = 'a1/1' ; $a[1][0] = 'a2/1' ; $a[1][1] = 'a2/2' ; $a[2][0] = 'a3/1' ; $a[2][1] = 'a3/2' ; $a[2][2] = 'a3/3' ; $b[0][0] = 'b1/1' ; $b[1][0] = 'b2/1' ; $b[1][1] = 'b2/2' ; $b[2][0] = 'b3/1' ; $b[2][1] = 'b3/2' ; $b[2][2] = 'b3/3' ; $maxcol=99 ; -] $a[0][[0] = '1/1' ;
    $a[1][[0] = '2/1' ;
    $a[1][[1] = '2/2' ;
    $a[2][[0] = '3/1' ;
    $a[2][[1] = '3/2' ;
    $a[2][[2] = '3/3' ;

    $tabmode = default

    [+ $a[$row][$col] +]
    1 2 3
    [+ $a[$row][$col] +]
    [+ $b[2][$col] +]
    [+ $a[$row][$col] +]
    [+ $b[$row][$col] +]
    [+ $a[$row][$col] +]

    [+ $HTML::Embperl::VERSION +]

    [+ $tabmode +]

    [+ local $tabmode = 1 +]

    [- $i = 0 ; while ($i < 10) { $ii[$i++] = "ii[$i] = $i" ; } -]
    [+ $ii[$row] +]
    Embperl-2.5.0/test/html/match/PaxHeaders.14966/div.htm0000644000000000000000000000005012023276646020434 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/match/div.htm0000644000076400000000000000666712023276646020142 0ustar00richterroot00000000000000 Some Plain tests Embperl Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a || '' +]
    $b = [+ $b || '' +]
    $c = [+ $c || '' +]
    $d = [+ $d || '' +]
    $e = [+ $e || '' +]
    First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöü" -] Now lets look what we are getting from this:
    [+ $a +] [+ $b +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
    [- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    [- $a = 1; $b = 0; $c = 5; $d = 'txt' -] [$if $a$] a
    [$ endif$] [$if $a $] a
    [$else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [$ if !$a$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [- $i = 0 -] [$ while $i <= $#ffld $] [+ $ffld[$i] +] = [+ $fdat{$ffld[$i]} +] [- $j = 0 -] [$ while $j <= $i $] [+ $j++ +] [$ endwhile $]
    [- $i++ -] [$ endwhile $]
    [+ $c[$row][$col] +]

    $tabmode = default

    Display an two dimensional array with one, two and three columns !
    Please take a look at the source in your browser to see the difference
    [- undef @a ; undef @b ; $a[0][0] = 'a1/1' ; $a[1][0] = 'a2/1' ; $a[1][1] = 'a2/2' ; $a[2][0] = 'a3/1' ; $a[2][1] = 'a3/2' ; $a[2][2] = 'a3/3' ; $b[0][0] = 'b1/1' ; $b[1][0] = 'b2/1' ; $b[1][1] = 'b2/2' ; $b[2][0] = 'b3/1' ; $b[2][1] = 'b3/2' ; $b[2][2] = 'b3/3' ; $maxcol=99 ; -] $a[0][[0] = '1/1' ;
    $a[1][[0] = '2/1' ;
    $a[1][[1] = '2/2' ;
    $a[2][[0] = '3/1' ;
    $a[2][[1] = '3/2' ;
    $a[2][[2] = '3/3' ;

    $tabmode = default

    [+ $a[$row][$col] +]
    [+ $a[$row][$col] +]
    [+ $a[$row][$col] +]
    [+ $b[$row][$col] +]
    [+ $a[$row][$col] +]

    [+ $HTML::Embperl::VERSION +]

    [+ $tabmode || 17 +]

    [+ local $tabmode = 1 +]

    [- $i = 0 ; while ($i < 10) { $ii[$i++] = "ii[$i] = $i" ; } -]
    [+ $ii[$row] +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/delsess.htm0000644000000000000000000000005012023276646020220 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/delsess.htm0000755000076400000000000000075412023276646017720 0ustar00richterroot00000000000000 Tests for Embperl - Delete Session Data udat before:
    [- @ks = grep (!/^_/, sort (keys %udat)) ; $num = keys (%udat) - $#ks - 1 ; -]
    [+ $ks[$row] +][+ $udat{$ks[$row] || ''} +]
    [+ $num > 0?"ok (num=$num)":"Not a session hash (num=$num)" +]

    $mdat{cnt} = -[+ $mdat{cnt} +]-
    $udat{cnt} = -[+ $udat{cnt} +]-
    [- $_[0] -> DeleteSession (1) ; -] Embperl-2.5.0/test/html/PaxHeaders.14966/ofunc0000644000000000000000000000005012323454053017072 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/ofunc/0000755000000000000000000000000012323454053016140 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/ofunc/PaxHeaders.14966/div.htm0000644000000000000000000000005012023276646020452 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/ofunc/div.htm0000644000076400000000000000666712023276646020160 0ustar00richterroot00000000000000 Some Plain tests Embperl Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a || '' +]
    $b = [+ $b || '' +]
    $c = [+ $c || '' +]
    $d = [+ $d || '' +]
    $e = [+ $e || '' +]
    First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöü" -] Now lets look what we are getting from this:
    [+ $a +] [+ $b +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
    [- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    [- $a = 1; $b = 0; $c = 5; $d = 'txt' -] [$if $a$] a
    [$ endif$] [$if $a $] a
    [$else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [$ if !$a$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [- $i = 0 -] [$ while $i <= $#ffld $] [+ $ffld[$i] +] = [+ $fdat{$ffld[$i]} +] [- $j = 0 -] [$ while $j <= $i $] [+ $j++ +] [$ endwhile $]
    [- $i++ -] [$ endwhile $]
    [+ $c[$row][$col] +]

    $tabmode = default

    Display an two dimensional array with one, two and three columns !
    Please take a look at the source in your browser to see the difference
    [- undef @a ; undef @b ; $a[0][0] = 'a1/1' ; $a[1][0] = 'a2/1' ; $a[1][1] = 'a2/2' ; $a[2][0] = 'a3/1' ; $a[2][1] = 'a3/2' ; $a[2][2] = 'a3/3' ; $b[0][0] = 'b1/1' ; $b[1][0] = 'b2/1' ; $b[1][1] = 'b2/2' ; $b[2][0] = 'b3/1' ; $b[2][1] = 'b3/2' ; $b[2][2] = 'b3/3' ; $maxcol=99 ; -] $a[0][[0] = '1/1' ;
    $a[1][[0] = '2/1' ;
    $a[1][[1] = '2/2' ;
    $a[2][[0] = '3/1' ;
    $a[2][[1] = '3/2' ;
    $a[2][[2] = '3/3' ;

    $tabmode = default

    [+ $a[$row][$col] +]
    [+ $a[$row][$col] +]
    [+ $a[$row][$col] +]
    [+ $b[$row][$col] +]
    [+ $a[$row][$col] +]

    [+ $HTML::Embperl::VERSION +]

    [+ $tabmode || 17 +]

    [+ local $tabmode = 1 +]

    [- $i = 0 ; while ($i < 10) { $ii[$i++] = "ii[$i] = $i" ; } -]
    [+ $ii[$row] +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/heredoc.htm0000644000000000000000000000005012023276646020167 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/heredoc.htm0000644000076400000000000000031612023276646017656 0ustar00richterroot00000000000000[- sub error_check { $error = <<END if ($units == 0); To Create a duplicate entry you must first fill in the units field. END } -] HELLO [- error_check -] [+ $error +] Embperl-2.5.0/test/html/PaxHeaders.14966/app0000644000000000000000000000005012323454053016540 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/app/0000755000000000000000000000000012323454053015606 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/app/PaxHeaders.14966/i18n.htm0000644000000000000000000000005012023276646020115 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/app/i18n.htm0000644000076400000000000000370212023276646017606 0ustar00richterroot00000000000000[- $r = shift -] [- $r -> {language_set} = [{id => 'de', 'name' => 'Deutsch'}, {id => 'en', 'name' => 'English'}, ] ; $escmode = 3 ; -]
    [= add1 =] News

    [= add2 =]

    URL:
    [- $rec = $r -> {language_set}[$row] -]
    [+ $rec -> {name} +]
    [= heading =]:
    [= url =]:
    [= description =]:


         Use gettext: description = [+ $r -> gettext ('description') +] heading = [+ $r -> gettext ('heading') +] add3 = [+ $r -> gettext ('add3') +] [$ foreach $i (1..4) $] addsel[+$i +] = [+ $r -> gettext ("addsel$i") +]
    [= next =]
    addsel[+$i +] (2) = [+ $r -> gettext ("addsel$i") +]
    [$endforeach$] [$ foreach $i (1..4) $] addsel[+$i +] = [+ $r -> gettext ("addsel$i") +]
    last: [= last =]
    [$endforeach$] [$ foreach $i (1..4) $] addsel[+$i +] = [+ $r -> gettext ("addsel$i") +]
    [= last =]
    [$endforeach$] [= this is text with spaces =] [+ $r -> gettext('ÄÜÖ') +] [= test undef =] Embperl-2.5.0/test/html/PaxHeaders.14966/nesting.htm0000644000000000000000000000005012023276646020225 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/nesting.htm0000755000076400000000000000172612023276646017725 0ustar00richterroot00000000000000 Tests for Embperl - Nesting of html and meta commands [- $fdat{aa} = 11 ; $fdat{bb} = 22 ; $fdat{cc} = 33 ; $fdat{dd} = 44 ; $t = 1 ; $f = 0 ; -] [- @ks = sort keys %fdat -]
    [+ $ks[$row] +][+ $fdat{$ks[$row] || ''} +]
    [# [$if $t $] [$endif$] [$if $t $]
    [+ $ks[$row] +][+ $fdat{$ks[$row] || ''} +]
    [$endif$] #] [$if $f $] [$endif$] [$if $f $]
    [+ $ks[$row] +][+ $fdat{$ks[$row] || ''} +]
    [$endif$] [- $count = 0 -]
    [$ while $count < 10 $]
    [+ $count +]
    [- $count++ -] [$ endwhile $]
    [- $count = 0 -]
    [$ while $count < 10 $]
    [- print OUT $count; -]
    [- $count++ -] [$ endwhile $]
    Embperl-2.5.0/test/html/PaxHeaders.14966/registry0000644000000000000000000000005012323454053017630 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/registry/0000755000000000000000000000000012323454053016676 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/registry/PaxHeaders.14966/script.pl0000644000000000000000000000005012023276646021555 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/registry/script.pl0000644000076400000000000000031012023276646021236 0ustar00richterroot00000000000000 print OUT "Embperl Tests - Includeded perl script - Start\n" ; $i = 0 ; foreach (@param) { print OUT $i++, " = $_\n" ; } print OUT "Embperl Tests - Includeded perl script - End\n" ; Embperl-2.5.0/test/html/registry/PaxHeaders.14966/hello.htm0000644000000000000000000000005012023276646021531 xustar000000000000000020 atime=1397643275 20 ctime=1397643307 Embperl-2.5.0/test/html/registry/hello.htm0000755000076400000000000000003212023276646021216 0ustar00richterroot00000000000000 print "Hello World!\n" ; Embperl-2.5.0/test/html/registry/PaxHeaders.14966/reggetsess.htm0000644000000000000000000000005012023276646022601 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/registry/reggetsess.htm0000755000076400000000000000142112023276646022271 0ustar00richterroot00000000000000# # run this under mod_perl / Apache::Registry # use Embperl ; my($r) = @_; $Embperl::DebugDefault = 811005 ; eval "use Apache2::compat" ; $r -> status (200) ; $r -> send_http_header () ; print "Test for Embperl::Req::SetupSession\n" ; my $session = Embperl::Req::SetupSession ($r) ; $off = 0 ; #$off-- if ($Embperl::SessionMgnt == 2 && !defined (tied (%$session) -> getid)) ; @ks = grep (!/^_/, sort (keys %$session)) ; $num = keys (%$session) - $#ks - 1 + $off ; foreach (@ks) { print "$_ = $session->{$_}
    \n" ; } $tst1 = '

    Here is some text inside of Execute

    ' ; Embperl::Execute ({input => \$tst1, mtime => 1, inputfile => 'Some text session test', }) ; print "\n" ; Embperl-2.5.0/test/html/registry/PaxHeaders.14966/errpage.htm0000644000000000000000000000005012023276646022053 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/registry/errpage.htm0000755000076400000000000000205212023276646021544 0ustar00richterroot00000000000000# # Example for using Embperl::Execute # # run this under mod_perl / Apache::Registry # use Embperl ; my($r) = @_; # workaround for broken $r -> chdir_file in Apache::Registry on ActiveState perl use Cwd ; use File::Basename ; my $fn = $r -> filename ; chdir(dirname ($fn)) ; $Embperl::DebugDefault = 811005 ; $r -> status (200) ; $r -> send_http_header () ; print "Test for Embperl::Execute and errors\n" ; my $out ; print "

    1.) The next one produces an error page

    \n" ; Embperl::Execute ({inputfile => '../error.htm', output => \$out, req_rec => $r}) ; print "

    $out

    \n" ; undef $out ; print "

    2.) The next one produces an errors, but error page is disabled

    \n" ; Embperl::Execute ({inputfile => '../error.htm', output => \$out, options => Embperl::optDisableEmbperlErrorPage, req_rec => $r}) ; print "

    $out

    \n" ; undef $out ; print "

    3.) Done :-)

    \n" ; print "\n"; Embperl-2.5.0/test/html/registry/PaxHeaders.14966/Execute.htm0000644000000000000000000000005012023276646022030 xustar000000000000000020 atime=1397643275 20 ctime=1397643307 Embperl-2.5.0/test/html/registry/Execute.htm0000755000076400000000000000727312023276646021533 0ustar00richterroot00000000000000# # Example for using Embperl::Execute # # run this under mod_perl / Apache::Registry # use Embperl ; my($r) = @_; # workaround for broken $r -> chdir_file in Apache::Registry on ActiveState perl use Cwd ; use File::Basename ; if ($Embperl::modperlapi < 2) { eval { require Apache::compat } ; $@ = '' ; } else { eval { require Apache2::compat } ; $@ = '' ; } my $fn = $r -> filename ; chdir(dirname ($fn)) ; $Embperl::DebugDefault = 0xffffdffd ; $tst1 = '

    Here is some text

    ' ; $r -> status (200) ; $r -> send_http_header () ; print "Test for Embperl::Execute\n" ; print "

    1.) Include from memory

    \n" ; Embperl::Execute ({input => \$tst1, mtime => 1, inputfile => 'Some text', req_rec => $r}) ; print "\n

    2.) Include from memory with some Embperl code

    \n" ; Embperl::Execute ({input => \'[- @ar = (a1, b2, c3) -]
    [+$ar[$col]+]

    ', mtime => 1, inputfile => 'table', req_rec => $r}) ; print "\n

    3.) Include from memory with passing of variables

    \n" ; $MyPackage::Interface::Var = 'Some Var' ; Embperl::Execute ({input => \'

    Transfer some vars [+ $Var +] !

    ', inputfile => 'Var', mtime => 1, 'package' => 'MyPackage::Interface', req_rec => $r}) ; print "\n

    4.) Change the variable, but not the code

    \n" ; $MyPackage::Interface::Var = 'Do it again' ; # code is the same, so give the same mtime and inputfile to avoid recompile # Note you get problems is you change the code, but did not restart the server or # change the value in mtime. So make sure if you change something also change mtime! Embperl::Execute ({input => \'

    Transfer some vars [+ $Var +] !

    ', inputfile => 'Var2', mtime => 1, 'package' => 'MyPackage::Interface', req_rec => $r}) ; print "\n

    5.) Use \@param to pass parameters

    \n" ; Embperl::Execute ({input => \'

    Use @param to transfer some data ([+ "@param" +]) !

    ', inputfile => 'Param', debug => 0xffffdffd, req_rec => $r, param => [1, 2, 3, 4] } ) ; print "\n

    6.) Use \@param to pass parameters and return it

    \n" ; my @p = ('vara', 'varb') ; print "\n

    \$p[0] is $p[0] and \$p[1] is $p[1]

    " ; Embperl::Execute ({input => \'

    Got data in @param ([+ "@param" +]) !

    [- $param[0] = "newA" ; $param[1] = "newB" ; -]

    Change data in @param to ([+ "@param" +]) !

    ', inputfile => 'Param & Return', req_rec => $r, param => \@p } ) ; print "\n

    \$p[0] is now $p[0] and \$p[1] is now $p[1]

    " ; print "

    7.) Presetup \%fdat and \@ffld

    \n" ; my %myfdat = ('test' => 'value', 'fdat' => 'text') ; my @myffld = sort keys %myfdat ; Embperl::Execute ({input => \'

    [+ $ffld[$row] +][+ do { local $^W = 0 ; $fdat{$ffld[$row]} } +]

    ', inputfile => 'fdat & ffld', req_rec => $r, fdat => \%myfdat, ffld => \@myffld} ) ; print "\n

    8.) Inculde a file

    \n" ; Embperl::Execute ({inputfile => '../inc.htm', input_escmode => 7, req_rec => $r}) ; print "\n

    9.) Inculde a file and return output in a scalar

    \n" ; my $out ; Embperl::Execute ({inputfile => '../inc.htm', input_escmode => 7, output => \$out, req_rec => $r}) ; print "\n

    $out

    \n" ; print "\n

    10.) Test \$req_rec inside Execute

    \n" ; Embperl::Execute ('../reqrec.htm') ; print "\n

    11.) Done :-)

    \n" ; print "\n"; Embperl-2.5.0/test/html/registry/PaxHeaders.14966/tied.htm0000644000000000000000000000005012023276646021353 xustar000000000000000020 atime=1397643275 20 ctime=1397643307 Embperl-2.5.0/test/html/registry/tied.htm0000755000076400000000000000436112023276646021051 0ustar00richterroot00000000000000# # Test for magic and numeric vaiables within Embperl::Execute # # run this under mod_perl / Apache::Registry # { package Embperl::Test::Tie ; sub TIESCALAR { my ($class, $var) = @_ ; return bless \$var, $class ; } sub FETCH { my $self = shift ; return $$self ; } } use Embperl ; my($r) = @_; $Embperl::DebugDefault = 811005 ; $tst1 = '

    Here is some text

    ' ; $r -> status (200) ; $r -> send_http_header () ; print "Test for Embperl::Execute\n" ; print "

    1.) Include from memory: ref to string

    \n" ; $rc = Embperl::Execute ({inputfile => 'test_ref_string', input => \$tst1, mtime => 1}) ; print "\nrc = $rc\n" ; print "Test for Embperl::Execute\n" ; print "

    2.) Include from memory: numeric

    \n" ; $rc = Embperl::Execute ({inputfile => 'test_numeric', input => 5, mtime => 1, options => Embperl::Constant::optReturnError}) ; print "\nrc = $rc\n" ; print "Test for Embperl::Execute\n" ; print "

    3.) Include from memory: string

    \n" ; $rc = Embperl::Execute ({inputfile => 'test_string', input => 'Hi', mtime => 1, options => Embperl::Constant::optReturnError}) ; print "\nrc = $rc\n" ; print "Test for Embperl::Execute\n" ; print "

    4.) Include from memory: array

    \n" ; $rc = Embperl::Execute ({inputfile => 'test_array', input => ['a', 'b', 'c'], mtime => 1}) ; print "\nrc = $rc\n" ; tie $tiedvar1, 'Embperl::Test::Tie', $tst1 ; print "Test for Embperl::Execute\n" ; print "

    5.) Include from memory: tied string ref

    \n" ; $rc = Embperl::Execute ({inputfile => 'test_tied_string_ref', input => \$tiedvar1, mtime => 1}) ; print "\nrc = $rc\n" ; print "Test for Embperl::Execute\n" ; print "

    6.) Include from memory: tied string

    \n" ; $rc = Embperl::Execute ({inputfile => 'test_tied_string', input => $tiedvar1, mtime => 1, options => Embperl::Constant::optReturnError}) ; print "\nrc = $rc\n" ; print "

    6.) Done :-)

    \n" ; print "\n"; Embperl-2.5.0/test/html/PaxHeaders.14966/exitcomp.htm0000644000000000000000000000005012023276646020406 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/exitcomp.htm0000644000076400000000000000027112023276646020075 0ustar00richterroot00000000000000 Tests for Embperl - component exit Before Exit Main [- Execute('exitsub.htm') -] After Exit Main [+ "perl after exit main" +] Embperl-2.5.0/test/html/PaxHeaders.14966/post.htm0000644000000000000000000000005012023276646017543 xustar000000000000000020 atime=1397643273 20 ctime=1397643307 Embperl-2.5.0/test/html/post.htm0000755000076400000000000000042512023276646017236 0ustar00richterroot00000000000000 Tests for Embperl - Show posted data [- @ks = sort keys %fdat -]
    [+ $ks[$row] +]Length=[+ length ($fdat{$ks[$row] || ''}) +][+ $fdat{$ks[$row] || ''} +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/div.htm0000644000000000000000000000005012023276646017340 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/div.htm0000644000076400000000000000666712023276646017046 0ustar00richterroot00000000000000 Some Plain tests Embperl Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a || '' +]
    $b = [+ $b || '' +]
    $c = [+ $c || '' +]
    $d = [+ $d || '' +]
    $e = [+ $e || '' +]
    First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöü" -] Now lets look what we are getting from this:
    [+ $a +] [+ $b +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
    [- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    [- $a = 1; $b = 0; $c = 5; $d = 'txt' -] [$if $a$] a
    [$ endif$] [$if $a $] a
    [$else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [$ if !$a$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [- $i = 0 -] [$ while $i <= $#ffld $] [+ $ffld[$i] +] = [+ $fdat{$ffld[$i]} +] [- $j = 0 -] [$ while $j <= $i $] [+ $j++ +] [$ endwhile $]
    [- $i++ -] [$ endwhile $]
    [+ $c[$row][$col] +]

    $tabmode = default

    Display an two dimensional array with one, two and three columns !
    Please take a look at the source in your browser to see the difference
    [- undef @a ; undef @b ; $a[0][0] = 'a1/1' ; $a[1][0] = 'a2/1' ; $a[1][1] = 'a2/2' ; $a[2][0] = 'a3/1' ; $a[2][1] = 'a3/2' ; $a[2][2] = 'a3/3' ; $b[0][0] = 'b1/1' ; $b[1][0] = 'b2/1' ; $b[1][1] = 'b2/2' ; $b[2][0] = 'b3/1' ; $b[2][1] = 'b3/2' ; $b[2][2] = 'b3/3' ; $maxcol=99 ; -] $a[0][[0] = '1/1' ;
    $a[1][[0] = '2/1' ;
    $a[1][[1] = '2/2' ;
    $a[2][[0] = '3/1' ;
    $a[2][[1] = '3/2' ;
    $a[2][[2] = '3/3' ;

    $tabmode = default

    [+ $a[$row][$col] +]
    [+ $a[$row][$col] +]
    [+ $a[$row][$col] +]
    [+ $b[$row][$col] +]
    [+ $a[$row][$col] +]

    [+ $HTML::Embperl::VERSION +]

    [+ $tabmode || 17 +]

    [+ local $tabmode = 1 +]

    [- $i = 0 ; while ($i < 10) { $ii[$i++] = "ii[$i] = $i" ; } -]
    [+ $ii[$row] +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/exitsub.htm0000644000000000000000000000005012023276646020241 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/exitsub.htm0000644000076400000000000000035312023276646017731 0ustar00richterroot00000000000000 Tests for Embperl - request exit sub Before Exit [- if ($param[0]) { exit (200) ; } else { exit ; } -] After Exit [+ "perl after exit" +] Embperl-2.5.0/test/html/PaxHeaders.14966/tagscan.htm0000644000000000000000000000005012023276646020176 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/tagscan.htm0000755000076400000000000000521312023276646017671 0ustar00richterroot00000000000000 Some tests for Embperl [- $a = ' and more' -]

    Here it starts with some HTML Text

    [- $aaa = 1 -] [- $fdat{ VERSION } = 3 -] = 3 $] WIDTH=35 [$ endif $]> = 4 $] WIDTH=35 [$ endif $]> = 3 $] foo="" [$ endif $]> = 4 $] foo="" [$ endif $]> [- @ks = sort keys %idat -]
    [+ $ks[$row] +][+ $fdat{$ks[$row] || ''} +]
    [- $stuff = ("X" x 79 . "\n") x 26; -] Testing ... length of STUFF=[+ length($stuff) +]

    [- $stuff = "X" x 2046; -] Testing ... length of STUFF=[+ length($stuff) +]

    [- $stuff = "X" x 2047; -] Testing ... length of STUFF=[+ length($stuff) +]

    [- $stuff = "X" x 2048; -] Testing ... length of STUFF=[+ length($stuff) +]

    [- $stuff = "X" x 2049; -] Testing ... length of STUFF=[+ length($stuff) +]

    [- $stuff = "X" x 2050; -] Testing ... length of STUFF=[+ length($stuff) +]

    [- $stuff = "X" x 30000; -] Testing ... length of STUFF=[+ length($stuff) +]

    <[+ 'b' +]> [$ foreach $tag ('a', 'b', 'c') $] <[+ $tag +]> [$endforeach$] Embperl-2.5.0/test/html/PaxHeaders.14966/errdoc0000644000000000000000000000005012323454053017236 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/errdoc/0000755000000000000000000000000012323454053016304 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/errdoc/PaxHeaders.14966/errdoc.htm0000644000000000000000000000005012023276646021312 xustar000000000000000020 atime=1397643272 20 ctime=1397643307 Embperl-2.5.0/test/html/errdoc/errdoc.htm0000644000076400000000000000176012023276646021005 0ustar00richterroot00000000000000 Some Plain tests for Embperl Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    Here we will see an error: [- $a = (qqqqqqqqqqqqqq -] First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöü" -] Second Error:
    [+ $a+ +] [+ qq2$b +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
    [- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value [$if {$error is here ) $] $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    [$endif$]

    Ok.

    Embperl-2.5.0/test/html/errdoc/PaxHeaders.14966/epl0000644000000000000000000000005012323454053020016 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/errdoc/epl/0000755000000000000000000000000012323454053017064 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/errdoc/epl/PaxHeaders.14966/errdoc2.htm0000644000000000000000000000005012023276646022154 xustar000000000000000020 atime=1397643272 20 ctime=1397643307 Embperl-2.5.0/test/html/errdoc/epl/errdoc2.htm0000644000076400000000000000176012023276646021647 0ustar00richterroot00000000000000 Some Plain tests for Embperl Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    Here we will see an error: [- $a = (qqqqqqqqqqqqqq -] First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöü" -] Second Error:
    [+ $a+ +] [+ qq2$b +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
    [- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value [$if {$error is here ) $] $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    [$endif$]

    Ok.

    Embperl-2.5.0/test/html/PaxHeaders.14966/opmask0000644000000000000000000000005012323454053017252 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/opmask/0000755000000000000000000000000012323454053016320 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/opmask/PaxHeaders.14966/opmasktrap.htm0000644000000000000000000000005012023276646022231 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/opmask/opmasktrap.htm0000644000076400000000000000706512023276646021730 0ustar00richterroot00000000000000 Some Plain tests Embperl Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a || '' +]
    $b = [+ $b || '' +]
    $c = [+ $c || '' +]
    $d = [+ $d || '' +]
    $e = [+ $e || '' +]
    First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöü" -] Now lets look what we are getting from this:
    [+ $a +] [+ $b +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
    [- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    [- $a = 1; $b = 0; $c = 5; $d = 'txt' -] [$if $a$] a
    [$ endif$] [$if $a $] a
    [$else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [$ if !$a$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [- $i = 0 -] [$ while $i <= $#ffld $] [+ $ffld[$i] +] = [+ $fdat{$ffld[$i]} +] [- $j = 0 -] [$ while $j <= $i $] [+ $j++ +] [$ endwhile $]
    [- $i++ -] [$ endwhile $]
    [+ $c[$row][$col] +]

    $tabmode = default

    Display an two dimensional array with one, two and three columns !
    Please take a look at the source in your browser to see the difference
    [- undef @a ; undef @b ; $a[0][0] = 'a1/1' ; $a[1][0] = 'a2/1' ; $a[1][1] = 'a2/2' ; $a[2][0] = 'a3/1' ; $a[2][1] = 'a3/2' ; $a[2][2] = 'a3/3' ; $b[0][0] = 'b1/1' ; $b[1][0] = 'b2/1' ; $b[1][1] = 'b2/2' ; $b[2][0] = 'b3/1' ; $b[2][1] = 'b3/2' ; $b[2][2] = 'b3/3' ; $maxcol=99 ; -] $a[0][[0] = '1/1' ;
    $a[1][[0] = '2/1' ;
    $a[1][[1] = '2/2' ;
    $a[2][[0] = '3/1' ;
    $a[2][[1] = '3/2' ;
    $a[2][[2] = '3/3' ;

    $tabmode = default

    [+ $a[$row][$col] +]
    1 2 3
    [+ $a[$row][$col] +]
    [+ $b[2][$col] +]
    [+ $a[$row][$col] +]
    [+ $b[$row][$col] +]
    [+ $a[$row][$col] +]

    [+ $HTML::Embperl::VERSION +]

    [+ $tabmode +]

    [+ local $tabmode = 1 +]

    [- $i = 0 ; while ($i < 10) { $ii[$i++] = "ii[$i] = $i" ; } -]
    [+ $ii[$row] +]
    Embperl-2.5.0/test/html/opmask/PaxHeaders.14966/opmask.htm0000644000000000000000000000005012023276646021342 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/opmask/opmask.htm0000644000076400000000000000672612023276646021044 0ustar00richterroot00000000000000 Some Plain tests Embperl Here it starts with some HTML Text

    All values should be undefined: $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöü" -] Now lets look what we are getting from this:
    [+ $a +] [+ $b +]
    And now a and b together: [+ "$a$b" +]

    Here we have some HTML tags within the perl code, Embperl will delete them!
    [+ $c =
    6 + 17 * 3 +] Embperl will also translate HMTL escapes to the right characters i.e. $a &lt; 6 will get the perl expression $a < 6:
    [- $e = 2 -] [+ $d = $e < 6 +] Now they should have a value $a = [+ $a +]
    $b = [+ $b +]
    $c = [+ $c +]
    $d = [+ $d +]
    $e = [+ $e +]
    [- $a = 1; $b = 0; $c = 5; $d = 'txt' -] [$if $a$] a
    [$ endif$] [$if $a $] a
    [$else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$ endif $] [$ if $a$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [$ if !$a$] not a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ else$] a
    [$if $b == 0$] b is null
    [$else$] b is not null
    [$endif$] [$ endif $] [- $i = 0 -] [$ while $i <= $#ffld $] [+ $ffld[$i] +] = [+ $fdat{$ffld[$i]} +] [- $j = 0 -] [$ while $j <= $i $] [+ $j++ +] [$ endwhile $]
    [- $i++ -] [$ endwhile $]
    [+ $c[$row][$col] +]

    $tabmode = default

    Display an two dimensional array with one, two and three columns !
    Please take a look at the source in your browser to see the difference
    [- undef @a ; undef @b ; $a[0][0] = 'a1/1' ; $a[1][0] = 'a2/1' ; $a[1][1] = 'a2/2' ; $a[2][0] = 'a3/1' ; $a[2][1] = 'a3/2' ; $a[2][2] = 'a3/3' ; $b[0][0] = 'b1/1' ; $b[1][0] = 'b2/1' ; $b[1][1] = 'b2/2' ; $b[2][0] = 'b3/1' ; $b[2][1] = 'b3/2' ; $b[2][2] = 'b3/3' ; $maxcol=99 ; -] $a[0][[0] = '1/1' ;
    $a[1][[0] = '2/1' ;
    $a[1][[1] = '2/2' ;
    $a[2][[0] = '3/1' ;
    $a[2][[1] = '3/2' ;
    $a[2][[2] = '3/3' ;

    $tabmode = default

    [+ $a[$row][$col] +]
    1 2 3
    [+ $a[$row][$col] +]
    [+ $b[2][$col] +]
    [+ $a[$row][$col] +]
    [+ $b[$row][$col] +]
    [+ $a[$row][$col] +]
    Shared data: [+ $testshare +]
    Not Shared data: [+ $testshareX +]

    [+ $HTML::Embperl::VERSION +]

    [+ $tabmode +]

    [+ local $tabmode = 1 +]

    Embperl-2.5.0/test/html/PaxHeaders.14966/importsub2.htm0000644000000000000000000000005012023276646020664 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/importsub2.htm0000755000076400000000000000067412023276646020365 0ustar00richterroot00000000000000 Tests for Embperl - Importing subs 2

    Tests for Embperl - Importing subs

    [! Execute({inputfile => 'subimp.htm', import => 1}) !] Second sub: [- tsecond -] First sub: [- tfirst -] [- @cell = (['2a1', '2a2'], ['2b1', '2b2']) -] And now a table splitted into several subs: [- tabcell (\@cell) -]
    12>
    And done! Embperl-2.5.0/test/html/PaxHeaders.14966/mail.htm0000644000000000000000000000005012023425320017461 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/mail.htm0000644000076400000000000000117312023425320017152 0ustar00richterroot00000000000000 Embperl Tests - use Mail taglib [- $fdat{Email} = 'richter at embperl dot org' ; -] [$ syntax + Mail $] Hi, this is a test for a new mail tag it is send at [+ scalar(localtime) +] from Embperl's Mail taglib. [+ "tagend" +]
    $? = [+ $? +]
    [$ if $? $]

    Sorry, there was an error, your mail couldn't be send

    [$else$]

    Your mail was successfully delivered

    [$endif$] Embperl-2.5.0/test/html/PaxHeaders.14966/asp.htm0000644000000000000000000000005012023276646017341 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/asp.htm0000644000076400000000000000065212023276646017033 0ustar00richterroot00000000000000 Embperl Tests - use ASP syntax [$ syntax ASP EmbperlHTML $] <% $a = 1 ; %> > <% foreach (1..5) { %> <% } %>
    <%= $_ %> <%= $a += 2 %>
    <% $esc = 'p%u&g=äöü' ; %> href="xxx"> esc = <%= $esc %> Embperl-2.5.0/test/html/PaxHeaders.14966/loopperl.htm0000644000000000000000000000005012023276646020412 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/loopperl.htm0000755000076400000000000000261412023276646020107 0ustar00richterroot00000000000000 Test for Embperl - Loop Metacommand [- $i = 0 -] [* while ($i <= $#ffld) { *] [+ $ffld[$i] +] = [+ $fdat{$ffld[$i]} +] [- $j = 0 -] [* while ($j <= $i) { *] [+ $j++ +] [* } *]
    [- $i++ -] [* } *] [- $i = 0 -] [* while($i <= 2) {*] [+ $i++ +] [* } *] [- %h = ('A' => 1, 'B' => 2, 'C' => 3) ; -] [- @a = ('a', 'b', 'c', 'd') ; -] [* @hh = map { $_ => $h{$_} } sort keys %h ; while ($v = shift @hh, $k = shift @hh) { *] [+ "$v = $k" +]
    [* } *] [- $i = 0 -] [* while ($i <= $#a) { *] [+ "\@a[$i] = $a[$i]" +]
    [- $i++ -] [* } *] [- $i = 0 -] [* do { *] [+ "\@a[$i] = $a[$i]" +]
    [- $i++ -] [* } until ($i > $#a) ; *] [* foreach $v (@a) { *] [+ $v +]
    [* } *] [* foreach $v (1, 3, 5, 7, 9) { *] [+ $v +]
    [* } *] [* foreach $v (1..10) { *] [+ $v +]
    [* } *] [- $i = 0 -] [* do { *] [+ "\@a[$i] = $a[$i]" +]
    [* @hh = map { $_ => $h{$_} } sort keys %h ; while (($v = shift @hh, $k = shift @hh)) { *] [+ "$v = $k" +]
    [* foreach $fv (1, 3, 5, 7, 9) { *] [+ $fv +]
    [* } *] [* foreach $fv (1) { *] [+ $fv +]
    [- @hhh = map { $_ => $h{$_} } sort keys %hhh ; -] [* while (($wv = shift @hhh, $wk = shift @hhh)) { *] [+ "$wv = $wk" +]
    [* } *] [* } *] [* } *] [- $i++ -] [* } until ($i > $#a) ; *] Embperl-2.5.0/test/html/PaxHeaders.14966/http.htm0000644000000000000000000000005012023276646017535 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/http.htm0000755000076400000000000000064612023276646017235 0ustar00richterroot00000000000000 Setup http header [- $http_headers_out{'Locationx'} = "http://www.ecos.de/embperl/" ; $http_headers_out{'h1'} = "v0" ; $http_headers_out{'h2'} = ['v1', 'v2'] ; -] [- @ks = sort keys %http_headers_out -]
    [+ $ks[$row] +][+ $http_headers_out{$ks[$row]} +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/execviamod.htm0000644000000000000000000000005012023276646020702 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/execviamod.htm0000644000076400000000000000051512023276646020372 0ustar00richterroot00000000000000 Tests for Embperl - Execute via an intermediate module

    Tests for Embperl - Execute via an intermediate module

    [- my $dir = $_[0] -> component -> cwd ; require "$dir/execviamod.pm" ; execviamod() ; -] Now without output [- execviamod2() ; -] And done! Embperl-2.5.0/test/html/PaxHeaders.14966/escape.htm0000644000000000000000000000005012023276646020016 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/escape.htm0000755000076400000000000001757212023276646017524 0ustar00richterroot00000000000000[- $r = shift -] Some tests for Embperl escaping Here it starts with some HTML Text

    First of all assign a value: [- $a = '(this is the value in $a)' -]
    Now we have some 'Umlaute': [- $b = "$a äöüäöü???<\&+ " -] [- $id = "abcdefghijklmnopqrstuvwxyz" ; $text = "This is a text ? \& + - %21" -] Now lets look what we are getting from this:
    [+ $a +] [+ $b +]
    What is the EscMode? [+ $escmode +] Let's set the EscMode to [+ $escmode = 3 +] What is the EscMode now? [+ $escmode +] Now a Url:     Here it goes A Tag 2: a2 A Tag 3: a3 A Tag 4: a4 A Tag 5: a5 A Tag 6: a6 A Tag 7: x A Tag 8: x A Tag 9: x A Tag 10: x A Tag 11: x A Tag 12: x A Tag 12b: x A Tag 13: x A Tag 14: x FRAME: IFRAME: [$endif$] [$endif$]

    [$endsub$] [$ sub abort_button $] [* my $r = shift ; *]     [$if $r -> {aborturl} $]   [$endif$] [$ endsub $] [$ sub prev_button $] [* my $r = shift ; *] [$ endsub $] [$ sub next_button $] [* my $r = shift ; *] [$ endsub $] [$ sub prevnext $] [* my $r = shift ; *]

    [- $r -> SUPER::prevnext -]
    [$ endsub $] [! sub run_setup { my $data = $r -> {data} ; my $action = $data -> {action} ; # # add action herer # } !] Embperl-2.5.0/eg/forms/PaxHeaders.14966/css0000644000000000000000000000005012323454053016346 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/eg/forms/css/0000755000000000000000000000000012323454053015414 5ustar00rootroot00000000000000Embperl-2.5.0/eg/forms/css/PaxHeaders.14966/EmbperlForm.css0000644000000000000000000000005012023276646021356 xustar000000000000000020 atime=1397535905 20 ctime=1397643307 Embperl-2.5.0/eg/forms/css/EmbperlForm.css0000644000076400000000000003605612023276646021057 0ustar00richterroot00000000000000table { font-family: Geneva,Arial,Helvetica; font-size: 11px; empty-cells:show; } .cBody { background: #ffffff; font-family: Geneva,Arial,Helvetica; font-size: 11px; margin: 0px 0px 0px 0px; height: 100%; border-left:solid 1px; /* overflow: scroll; */ } .cStd {background: #ffffff; color: #000000; font-family: Geneva,Arial,Helvetica; font-size: 11px; margin: 0px 0px 0px 0px; } .cStdInput {background: #d4d4d4; color: #000000; font-family: Geneva,Arial,Helvetica; font-size: 11px; margin: 0px 0px 0px 0px; } .cStdNoFrame {background: #ffffff; color: #000000; font-family: Geneva,Arial,Helvetica; font-size: 11px; } .cStdText {background: #ffffff; color: #000000; font-family: Geneva,Arial,Helvetica; font-size: 13px; } .cCenter { text-align: center ;} .cFooterText, .cFooterTextCenter {background: #ffffff; font-family: Geneva,Arial,Helvetica; font-size: 10px; color: #444444;} .cFooterTextCenter {text-align: center;} .cFooterTextBold {font-weight: bold; color: #000000; } .cObjectDN {font-size: 11px; color: #bbbbbb; } .cObjectInfo {font-size: 11px; color: #ff0000; font-weight: bold ;} .cObjectText {font-size: 11px; color: #000000; margin-right: 17px } .cError {font-size: 11px; color: #ff0000;} .cWarn {font-size: 11px; color: #ff6600;} .cOK {font-size: 11px; color: black;} .cHeadH1 {color: #fdd11a; font-size: 27px; font-weight: bold; margin: 10px; padding: 0px;} .cHeadH2 {color: #ffffff; font-size: 17px; font-weight: bold; margin: 10px; padding: 0px;} .cWizardDiv {margin-left: auto; width: 850px ;margin-right: auto ; margin-top: 20px ;} .cSetupWizardDiv {margin-left: auto; width: 730px ;margin-right: auto ; margin-top: 20px ;} .cPopupDiv {margin-left: 20px; ;margin-right: 20px ; margin-top: 20px ;} /* --- Embperl::Form --- */ #topdiv { width: 850px ; margin-left: auto; margin-right: auto } .cBase {font-family: Geneva,Arial,Helvetica; font-size: 11px; } .cTableDiv {background: #ffffff; border: black 1px solid; padding: 2px; padding-left: 4px ; width: 100% ; margin: 0px } .cTableDivU {background: #ffffff; border: black 1px solid; border-top: 0px ; padding: 2px; padding-left: 4px ; width: 100% ; margin: 0px } .cTable {background: #ffffff; border-collapse: collapse; width: 100% ; margin: 0px; padding: 0px ;} .cTableInput {table-layout: fixed ; } .cLabelGroup { width: 150px } .cControlGroup { width: 208px ; } .cTableRow1 {background: #ffffff; } .cTableRow {background: #ffffff; } .cControlBox {background: #d4d4d4; color: #000000; margin: 0px 0px 0px 0px; padding: 2px 3px 2px 3px; border: 2px white solid; vertical-align: middle ; text-align: left ; } .xcControlBoxWidth1 { width: 570px ; /*80% ; */} .xcControlBoxWidth2 { width: 214px ; /*30% ; */ } .cControlBoxWidth4 { width: 40px ; /* 5% ; */ } .cControlBoxWidth5 { width: 40px ; /* 5% ; */ } .cControlBoxWidth6 { width: 40px ; /* 5% ; */ } .cControlBoxWidth7 { width: 40px ; /* 5% ; */ } .cControlButtonBox { text-align: center ; border: 2px white solid; padding: 6px;} .cControlAddRemoveBox { text-align: center ; border: 0px ; margin-left: auto; margin-right: auto} .cTransparentBox {margin: 0px 0px 0px 0px; padding: 2px 3px 2px 3px; } .cControl {border: 1px black solid; padding-left: 2px ; font-family: Geneva,Arial,Helvetica; font-size: 11px;} .cGridCell .cControl { border: 0px; padding: 0px ;} .cControlWidthInput {margin-left: 0px ; width: 98%; } .cControlWidthSelect {margin-left: 0px ; width: 85%; } .cControlWidthNumber {margin-left: 0px ; width: 50%; text-align: right ; padding-right: 2px} .cControlButton {background-image: url(/images/button_bg_off.gif); background-position: 0px -4px ; padding: 3px; padding-left: 25px ; height: 20px ; font-size: 11px; white-space: nowrap ; margin: 0px ; cursor:pointer; width: 150px ; } .cControlButton:hover {background-image: url(/images/button_bg_on.gif);} .cControlButtonDiv {background-image: url(/images/button_bg_off.gif); background-position: -22px -2px ; padding: 2px; padding-left: 5px ; border: 1px black solid; font-size: 11px; white-space: nowrap ; margin: 0px ; cursor:pointer; width: 150px ; text-align: left ; } .cControlButtonDiv img { margin-bottom: -3px ; margin-right: 3px ;} .cControlButtonDiv:hover {background-image: url(/images/button_bg_on.gif);background-position: -22px -2px ;} .xcControlLine { border: 1px; color: black ; } .cControlAddonImg { border: 0px ; vertical-align: middle; position: relative; top: -3px ;} .cControlAddonA { border: 0px ; } .cLabelBox {background: #fdd11a; color: #000000; text-align: right; margin: 0px 0px 0px 0px; padding: 2px 3px 2px 3px; border: 2px white solid; vertical-align: middle ;} .xcLabelBoxWidth1 { width: 20% ; } .xcLabelBoxWidth2 { width: 20% ; } .xcLabelBoxWidth4 { width: 20% ; } .cTabTable {background: #ffffff; padding: 0px; margin: 0px; border-collapse: collapse; } .cTabRow {background: #ffffff; padding: 0px; margin: 0px; width: 100%; border-collapse: collapse; vertical-align: bottom; } .cTabTD {padding: 0px; margin: 0px; } .cTabCellOn {background: white ; padding: 0px ; margin: 0px; border: 0px ; vertical-align: bottom; } .cTabCellOff {background: white ; padding: 0px ; margin: 0px; border: 0px ; vertical-align: bottom; } .cTabCellBlank {background: white ; padding: 0px ; margin: 0px; border: 0px ; border-bottom: 1px black solid; vertical-align: bottom; width: 95%;} .cTabDivOn {background-image: url(/images/bg_tab_on.gif) ; background-repeat: repeat-x ; border: black 1px solid; border-bottom: none ; border-left: #FFFFFF 1px solid; padding: 4px; font-weight: bold ; font-size: 16px; white-space: nowrap ; } .cTabDivOff {background-image: url(/images/bg_tab_off.gif); background-repeat: repeat-x ; border: black 1px solid; padding: 4px; border-left: #FFFFFF 1px solid; font-size: 11px; white-space: nowrap ; } .cAutoCompDiv {position:relative;margin:0px;width:99%;} .cAutoCompInput {position:relative;} .cAutoCompContainer {width:300px;border:1px solid #404040;overflow:auto;height:200px;background-color:white;z-index:9999;} .cAutoCompContainer ul {list-style-type:none; margin:0px; padding:0px;width:300px;} .cAutoCompContainer li {list-style-type:none; display:block; margin:0; padding:2px; white-space:nowrap; cursor:pointer;} .cAutoCompContainer li.selected {background:highlight;color: white;} .cAutoCompArrow {cursor:default; display: inline ; background-image: url(/images/todown.gif) ; width: 18px; height: 18px; background-position: center; } .cControlWidthSelectDyn {margin-left: 0px ; width: 99%; } .cGridTable {background: #ffffff; border-collapse: collapse; width: 100%; border: 1px solid black; position: relative; } .cGridTable td {background: #ffffff; padding: 0px; margin: 0px; border: 1px solid black; } .cGridTitle {background: #ffffff; padding: 0px; margin: 0px; border-collapse: collapse; width: 100% ; } .cGridControlBox {background: #fdd11a; text-align: right ; margin: 0px 0px 0px 0px; padding: 2px 3px 2px 3px; border: 0px; } .cGridLabelBox {background: #fdd11a; text-align: left; margin: 0px 0px 0px 0px; padding: 2px 3px 2px 3px; border: 0px; } .cGridHeader td {background: #d4d4d4; padding: 2px; margin: 0px; height: 16px ; border: 1px solid black;} .cGridTable input, .cGridTable select { font-size: 11px; border: 0px; padding: 1px; margin: 0px; width: 98%;} .cGridRowSelected, .cGridRowSelected input, .cGridRowSelected select, .cGridRowSelected td { background-color: lightblue} /* ---------- The main calendar widget. DIV containing a table. ------------- */ .calendar { position: relative; display: none; border-top: 2px solid #fff; border-right: 2px solid #000; border-bottom: 2px solid #000; border-left: 2px solid #fff; font-size: 11px; color: #000; cursor: default; background: #c8d4d0; font-family: tahoma,verdana,sans-serif; } .calendar table { border-top: 1px solid #000; border-right: 1px solid #fff; border-bottom: 1px solid #fff; border-left: 1px solid #000; font-size: 11px; color: #000; cursor: default; background: #c8d4d0; font-family: tahoma,verdana,sans-serif; } /* Header part -- contains navigation buttons and day names. */ .calendar .button { /* "<<", "<", ">", ">>" buttons have this class */ text-align: center; padding: 1px; border-top: 1px solid #fff; border-right: 1px solid #000; border-bottom: 1px solid #000; border-left: 1px solid #fff; } .calendar .nav { background: transparent url(menuarrow.gif) no-repeat 100% 100%; } .calendar thead .title { /* This holds the current "month, year" */ font-weight: bold; padding: 1px; border: 1px solid #000; background: #788480; color: #fff; text-align: center; } .calendar thead .headrow { /* Row containing navigation buttons */ } .calendar thead .daynames { /* Row containing the day names */ } .calendar thead .name { /* Cells containing the day names */ border-bottom: 1px solid #000; padding: 2px; text-align: center; background: #e8f4f0; } .calendar thead .weekend { /* How a weekend day name shows in header */ color: #f00; } .calendar thead .hilite { /* How do the buttons in header appear when hover */ border-top: 2px solid #fff; border-right: 2px solid #000; border-bottom: 2px solid #000; border-left: 2px solid #fff; padding: 0px; background-color: #d8e4e0; } .calendar thead .active { /* Active (pressed) buttons in header */ padding: 2px 0px 0px 2px; border-top: 1px solid #000; border-right: 1px solid #fff; border-bottom: 1px solid #fff; border-left: 1px solid #000; background-color: #b8c4c0; } /* The body part -- contains all the days in month. */ .calendar tbody .day { /* Cells containing month days dates */ width: 2em; text-align: right; padding: 2px 4px 2px 2px; } .calendar tbody .day.othermonth { font-size: 80%; color: #aaa; } .calendar tbody .day.othermonth.oweekend { color: #faa; } .calendar table .wn { padding: 2px 3px 2px 2px; border-right: 1px solid #000; background: #e8f4f0; } .calendar tbody .rowhilite td { background: #d8e4e0; } .calendar tbody .rowhilite td.wn { background: #c8d4d0; } .calendar tbody td.hilite { /* Hovered cells */ padding: 1px 3px 1px 1px; border-top: 1px solid #fff; border-right: 1px solid #000; border-bottom: 1px solid #000; border-left: 1px solid #fff; } .calendar tbody td.active { /* Active (pressed) cells */ padding: 2px 2px 0px 2px; border-top: 1px solid #000; border-right: 1px solid #fff; border-bottom: 1px solid #fff; border-left: 1px solid #000; } .calendar tbody td.selected { /* Cell showing selected date */ font-weight: bold; border-top: 1px solid #000; border-right: 1px solid #fff; border-bottom: 1px solid #fff; border-left: 1px solid #000; padding: 2px 2px 0px 2px; background: #d8e4e0; } .calendar tbody td.weekend { /* Cells showing weekend days */ color: #f00; } .calendar tbody td.today { /* Cell showing today date */ font-weight: bold; color: #00f; } .calendar tbody .disabled { color: #999; } .calendar tbody .emptycell { /* Empty cells (the best is to hide them) */ visibility: hidden; } .calendar tbody .emptyrow { /* Empty row (some months need less than 6 rows) */ display: none; } /* The footer part -- status bar and "Close" button */ .calendar tfoot .footrow { /* The in footer (only one right now) */ } .calendar tfoot .ttip { /* Tooltip (status bar) cell */ background: #e8f4f0; padding: 1px; border: 1px solid #000; background: #788480; color: #fff; text-align: center; } .calendar tfoot .hilite { /* Hover style for buttons in footer */ border-top: 1px solid #fff; border-right: 1px solid #000; border-bottom: 1px solid #000; border-left: 1px solid #fff; padding: 1px; background: #d8e4e0; } .calendar tfoot .active { /* Active (pressed) style for buttons in footer */ padding: 2px 0px 0px 2px; border-top: 1px solid #000; border-right: 1px solid #fff; border-bottom: 1px solid #fff; border-left: 1px solid #000; } /* Combo boxes (menus that display months/years for direct selection) */ .calendar .combo { position: absolute; display: none; width: 4em; top: 0px; left: 0px; cursor: default; border-top: 1px solid #fff; border-right: 1px solid #000; border-bottom: 1px solid #000; border-left: 1px solid #fff; background: #d8e4e0; font-size: 90%; padding: 1px; z-index: 100; } .calendar .combo .label, .calendar .combo .label-IEfix { text-align: center; padding: 1px; } .calendar .combo .label-IEfix { width: 4em; } .calendar .combo .active { background: #c8d4d0; padding: 0px; border-top: 1px solid #000; border-right: 1px solid #fff; border-bottom: 1px solid #fff; border-left: 1px solid #000; } .calendar .combo .hilite { background: #048; color: #aef; } .calendar td.time { border-top: 1px solid #000; padding: 1px 0px; text-align: center; background-color: #e8f0f4; } .calendar td.time .hour, .calendar td.time .minute, .calendar td.time .ampm { padding: 0px 3px 0px 4px; border: 1px solid #889; font-weight: bold; background-color: #fff; } .calendar td.time .ampm { text-align: center; } .calendar td.time .colon { padding: 0px 2px 0px 3px; font-weight: bold; } .calendar td.time span.hilite { border-color: #000; background-color: #667; color: #fff; } .calendar td.time span.active { border-color: #f00; background-color: #000; color: #0f0; } Embperl-2.5.0/eg/forms/PaxHeaders.14966/lib0000644000000000000000000000005012323454053016324 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/eg/forms/lib/0000755000000000000000000000000012323454053015372 5ustar00rootroot00000000000000Embperl-2.5.0/eg/forms/lib/PaxHeaders.14966/wizard.epl0000644000000000000000000000005012023276646020412 xustar000000000000000020 atime=1397535905 20 ctime=1397643307 Embperl-2.5.0/eg/forms/lib/wizard.epl0000644000076400000000000000616712023276646020113 0ustar00richterroot00000000000000 [! sub formname { 'myform' } sub form_enctype {''} sub on_submit { '' } !] [$ sub hidden $] [* my $r = shift ; *] [$ endsub $] [$ sub abort_button $] [* my $r = shift ; *] [$if $r -> {aborturl} $]   [$endif$] [$ endsub $] [$ sub prev_button $] [* my $r = shift ; *] [$if $r -> {page} > 0 $][$endif$] [$ endsub $] [$ sub next_button $] [* my $r = shift ; *] [$if $r -> {page} + 1 < @{$r -> {pages}} $][$endif$] [$ endsub $] [$ sub prevnext $] [* my $r = shift ; *]

    [- $r -> abort_button -] [- $r -> prev_button -] [- $r -> next_button -]

    [$ endsub $] [$ sub after_form $] [$ endsub $] [$ sub display $] [* my $r = shift ; *] [- $formname = $r->{fields_epf_formname} = $r -> formname -]
    [- $r -> show -]
    [- $r -> prevnext -] [- delete $fdat{-page} ; delete $fdat{-prev} ; delete $fdat{-next} ; -] [- $r -> hidden ; @ffld = keys %fdat ; -] [$ hidden $]
    [- $r -> after_form -] [$ endsub $] Embperl-2.5.0/eg/forms/lib/PaxHeaders.14966/wizard.pl0000644000000000000000000000005012023276646020245 xustar000000000000000020 atime=1397535905 20 ctime=1397643307 Embperl-2.5.0/eg/forms/lib/wizard.pl0000644000076400000000000001053712023276646017742 0ustar00richterroot00000000000000 # ----------------------------------------------------------------------- # # verify - prüfen ob alle Eingaben ok sind # # ruft für alle Seiten vor der aktuellen die method preverfiy auf # und für die Seite von der die Daten abgesendet wurden die methode # verify # # in $page index der aktuellen Seite # ret bei Fehler: Seitenobjekt # sonst: undef # sub verify { my ($self, $page, $r) = @_ ; my $pages = $self -> {pages} ; #my $r = $self -> curr_req ; my $i = 0 ; while ($i < $page) { $pageobj = Execute ({object => $pages -> [$page]}) ; $i++ ; next if ($pageobj -> can('condition') && !$pageobj -> condition($r)) ; next if (!$pageobj -> can('preverify')) ; if (!$pageobj -> preverify($r)) { return ($i-1, $pageobj) ; } } $pageobj = Execute ({object => $pages -> [$page]}) ; if ($pageobj -> can('verify') && !$pageobj -> verify($r, $self)) { return ($page, $pageobj) ; } return ; } # ----------------------------------------------------------------------- # # callpages - ruft eine Methode in allen Seiten auf # # in $method Name der Methode # ... Argumente # ret Summe der Rückgabewerte # sub callpages { my $self = shift ; my $method = shift ; my $pages = $self -> {pages} ; my $ret = 0 ; foreach my $page (@$pages) { my $pageobj = Execute ({object => $page}) ; $i++ ; next if (!$pageobj -> can($method)) ; $ret += $pageobj -> $method (@_) ; } return ; } # ----------------------------------------------------------------------- # # get_page_to_show - liefert das Seitenobjekt für die anzuzeigende Seite # # in $page index der aktuellen Seite # $backwards wenn gesetzt wird rückwärtz geblättert # sub get_page_to_show { my ($self, $page, $step) = @_ ; my $pages = $self -> {pages} ; my $r = $self -> curr_req ; while (1) { $page += $step ; #warn "page=$page, step = $step" ; die "Seite nicht verfügbar" if ($page >= @$pages || $page < 0) ; $pageobj = Execute ({object => $pages -> [$page]}) ; last if (!$pageobj -> can('condition') || $pageobj -> condition($r)) ; $step ||= 1 ; } return ($page, $pageobj) ; } # ----------------------------------------------------------------------- sub init { my ($self, $r) = @_ ; my $cfgobj = $self -> {cfgobj} ||= Execute ({object => 'wizconfig.pl'}) ; if ($cfgobj -> can('app_isa')) { my $isa = $cfgobj -> app_isa ; Execute ({isa => $isa}) ; } $cfgobj -> init($self, $r) if ($cfgobj -> can('init')); my $pages = $self -> {pages} ||= $cfgobj -> getpages ; $r -> {aborturl} = $cfgobj -> can('aborturl') && $cfgobj -> aborturl ; if ($fdat{-abort} && $r -> {aborturl}) { $epreq -> apache_req -> err_header_out('location', $r -> {aborturl}) ; return 301 ; } if ($fdat{-start}) { delete $fdat{-page} ; delete $fdat{-prev} ; delete $fdat{-next} ; delete $fdat{-start} ; } $r -> {data} = \%fdat ; my $page = $fdat{-page} || 0 ; my $showpage = $page ; if (!defined ($fdat{-page}) || !(($page, $pageobj) = $self -> verify ($page, $r))) { ($page, $pageobj) = $self -> get_page_to_show ($showpage, $fdat{-prev}?-1:($fdat{-next}?1:0)) ; } $r -> {pageobj} = $pageobj ; $r -> {page} = $page ; $r -> {pages} = $pages ; $r -> param -> filename ($pages -> [$page]) ; my $rc = 0 ; $rc = $pageobj -> init($r) if ($pageobj -> can('init')); return 0 ; } #------------------------------------------------------------------------------------------ # # get_recipe # sub get_recipe { my ($class, $r, $recipe) = @_ ; my $self ; my $param = $r -> component -> param ; my ($src) = $param -> inputfile =~ /^.*\.(.*?)$/ ; if ($src eq 'pl') { $r -> component -> config -> syntax('Perl') ; } return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ; } Embperl-2.5.0/eg/forms/lib/PaxHeaders.14966/header.epl0000644000000000000000000000005012023276646020342 xustar000000000000000020 atime=1397535905 20 ctime=1397643307 Embperl-2.5.0/eg/forms/lib/header.epl0000644000076400000000000000054312023276646020033 0ustar00richterroot00000000000000[- eval { $textonly = $epreq -> {textonly} ; $title = $epreq -> gettext ($epreq -> title) ; $subtitle = $epreq -> subtitle ; $subhead = $epreq -> subhead ; $frames = $epreq -> frames ; } ; -] [$if $title $]

    [+ $title +]

    [$endif$] [$if $subtitle $]

    [+ $subtitle +]

    [$endif$] Embperl-2.5.0/eg/forms/lib/PaxHeaders.14966/footer.epl0000644000000000000000000000005012023276646020410 xustar000000000000000020 atime=1397535905 20 ctime=1397643307 Embperl-2.5.0/eg/forms/lib/footer.epl0000644000076400000000000000140612023276646020100 0ustar00richterroot00000000000000 [# style="position: absolute; bottom: 0px">#]
    [= txt:logged_in_as =]  [+ $user || $epreq -> gettext('txt:') +]     Copyright © [+ $oem -> {copyrighttime} +]   [+ $oem -> {copyright} || 'Gerald Richter' +]   u.a.   
    Embperl-2.5.0/eg/forms/PaxHeaders.14966/js0000644000000000000000000000005012323454053016172 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/eg/forms/js/0000755000000000000000000000000012323454053015240 5ustar00rootroot00000000000000Embperl-2.5.0/eg/forms/js/PaxHeaders.14966/prototype.js0000644000000000000000000000005012023276646020661 xustar000000000000000020 atime=1397535905 20 ctime=1397643307 Embperl-2.5.0/eg/forms/js/prototype.js0000644000076400000000000036375312023276646020371 0ustar00richterroot00000000000000/* Prototype JavaScript framework, version 1.6.0 * (c) 2005-2007 Sam Stephenson * * Prototype is freely distributable under the terms of an MIT-style license. * For details, see the Prototype web site: http://www.prototypejs.org/ * *--------------------------------------------------------------------------*/ var Prototype = { Version: '1.6.0', Browser: { IE: !!(window.attachEvent && !window.opera), Opera: !!window.opera, WebKit: navigator.userAgent.indexOf('AppleWebKit/') > -1, Gecko: navigator.userAgent.indexOf('Gecko') > -1 && navigator.userAgent.indexOf('KHTML') == -1, MobileSafari: !!navigator.userAgent.match(/Apple.*Mobile.*Safari/) }, XBrowserFeatures: { XPath: !!document.evaluate, ElementExtensions: !!window.HTMLElement, SpecificElementExtensions: document.createElement('div').__proto__ && document.createElement('div').__proto__ !== document.createElement('form').__proto__ }, // Make it work with frames... BrowserFeatures: { XPath: !!document.evaluate, ElementExtensions: false, SpecificElementExtensions: false }, ScriptFragment: ']*>([\\S\\s]*?)<\/script>', JSONFilter: /^\/\*-secure-([\s\S]*)\*\/\s*$/, emptyFunction: function() { }, K: function(x) { return x } }; if (Prototype.Browser.MobileSafari) Prototype.BrowserFeatures.SpecificElementExtensions = false; if (Prototype.Browser.WebKit) Prototype.BrowserFeatures.XPath = false; /* Based on Alex Arnell's inheritance implementation. */ var Class = { create: function() { var parent = null, properties = $A(arguments); if (Object.isFunction(properties[0])) parent = properties.shift(); function klass() { this.initialize.apply(this, arguments); } Object.extend(klass, Class.Methods); klass.superclass = parent; klass.subclasses = []; if (parent) { var subclass = function() { }; subclass.prototype = parent.prototype; klass.prototype = new subclass; parent.subclasses.push(klass); } for (var i = 0; i < properties.length; i++) klass.addMethods(properties[i]); if (!klass.prototype.initialize) klass.prototype.initialize = Prototype.emptyFunction; klass.prototype.constructor = klass; return klass; } }; Class.Methods = { addMethods: function(source) { var ancestor = this.superclass && this.superclass.prototype; var properties = Object.keys(source); if (!Object.keys({ toString: true }).length) properties.push("toString", "valueOf"); for (var i = 0, length = properties.length; i < length; i++) { var property = properties[i], value = source[property]; if (ancestor && Object.isFunction(value) && value.argumentNames().first() == "$super") { var method = value, value = Object.extend((function(m) { return function() { return ancestor[m].apply(this, arguments) }; })(property).wrap(method), { valueOf: function() { return method }, toString: function() { return method.toString() } }); } this.prototype[property] = value; } return this; } }; var Abstract = { }; Object.extend = function(destination, source) { for (var property in source) destination[property] = source[property]; return destination; }; Object.extend(Object, { inspect: function(object) { try { if (object === undefined) return 'undefined'; if (object === null) return 'null'; return object.inspect ? object.inspect() : object.toString(); } catch (e) { if (e instanceof RangeError) return '...'; throw e; } }, toJSON: function(object) { var type = typeof object; switch (type) { case 'undefined': case 'function': case 'unknown': return; case 'boolean': return object.toString(); } if (object === null) return 'null'; if (object.toJSON) return object.toJSON(); if (Object.isElement(object)) return; var results = []; for (var property in object) { var value = Object.toJSON(object[property]); if (value !== undefined) results.push(property.toJSON() + ': ' + value); } return '{' + results.join(', ') + '}'; }, toQueryString: function(object) { return $H(object).toQueryString(); }, toHTML: function(object) { return object && object.toHTML ? object.toHTML() : String.interpret(object); }, keys: function(object) { var keys = []; for (var property in object) keys.push(property); return keys; }, values: function(object) { var values = []; for (var property in object) values.push(object[property]); return values; }, clone: function(object) { return Object.extend({ }, object); }, isElement: function(object) { return object && object.nodeType == 1; }, isArray: function(object) { return object && object.constructor === Array; }, isHash: function(object) { return object instanceof Hash; }, isFunction: function(object) { return typeof object == "function"; }, isString: function(object) { return typeof object == "string"; }, isNumber: function(object) { return typeof object == "number"; }, isUndefined: function(object) { return typeof object == "undefined"; } }); Object.extend(Function.prototype, { argumentNames: function() { var names = this.toString().match(/^[\s\(]*function[^(]*\((.*?)\)/)[1].split(",").invoke("strip"); return names.length == 1 && !names[0] ? [] : names; }, bind: function() { if (arguments.length < 2 && arguments[0] === undefined) return this; var __method = this, args = $A(arguments), object = args.shift(); return function() { return __method.apply(object, args.concat($A(arguments))); } }, bindAsEventListener: function() { var __method = this, args = $A(arguments), object = args.shift(); return function(event) { return __method.apply(object, [event || window.event].concat(args)); } }, curry: function() { if (!arguments.length) return this; var __method = this, args = $A(arguments); return function() { return __method.apply(this, args.concat($A(arguments))); } }, delay: function() { var __method = this, args = $A(arguments), timeout = args.shift() * 1000; return window.setTimeout(function() { return __method.apply(__method, args); }, timeout); }, wrap: function(wrapper) { var __method = this; return function() { return wrapper.apply(this, [__method.bind(this)].concat($A(arguments))); } }, methodize: function() { if (this._methodized) return this._methodized; var __method = this; return this._methodized = function() { return __method.apply(null, [this].concat($A(arguments))); }; } }); Function.prototype.defer = Function.prototype.delay.curry(0.01); Date.prototype.toJSON = function() { return '"' + this.getUTCFullYear() + '-' + (this.getUTCMonth() + 1).toPaddedString(2) + '-' + this.getUTCDate().toPaddedString(2) + 'T' + this.getUTCHours().toPaddedString(2) + ':' + this.getUTCMinutes().toPaddedString(2) + ':' + this.getUTCSeconds().toPaddedString(2) + 'Z"'; }; var Try = { these: function() { var returnValue; for (var i = 0, length = arguments.length; i < length; i++) { var lambda = arguments[i]; try { returnValue = lambda(); break; } catch (e) { } } return returnValue; } }; RegExp.prototype.match = RegExp.prototype.test; RegExp.escape = function(str) { return String(str).replace(/([.*+?^=!:${}()|[\]\/\\])/g, '\\$1'); }; /*--------------------------------------------------------------------------*/ var PeriodicalExecuter = Class.create({ initialize: function(callback, frequency) { this.callback = callback; this.frequency = frequency; this.currentlyExecuting = false; this.registerCallback(); }, registerCallback: function() { this.timer = setInterval(this.onTimerEvent.bind(this), this.frequency * 1000); }, execute: function() { this.callback(this); }, stop: function() { if (!this.timer) return; clearInterval(this.timer); this.timer = null; }, onTimerEvent: function() { if (!this.currentlyExecuting) { try { this.currentlyExecuting = true; this.execute(); } finally { this.currentlyExecuting = false; } } } }); Object.extend(String, { interpret: function(value) { return value == null ? '' : String(value); }, specialChar: { '\b': '\\b', '\t': '\\t', '\n': '\\n', '\f': '\\f', '\r': '\\r', '\\': '\\\\' } }); Object.extend(String.prototype, { gsub: function(pattern, replacement) { var result = '', source = this, match; replacement = arguments.callee.prepareReplacement(replacement); while (source.length > 0) { if (match = source.match(pattern)) { result += source.slice(0, match.index); result += String.interpret(replacement(match)); source = source.slice(match.index + match[0].length); } else { result += source, source = ''; } } return result; }, sub: function(pattern, replacement, count) { replacement = this.gsub.prepareReplacement(replacement); count = count === undefined ? 1 : count; return this.gsub(pattern, function(match) { if (--count < 0) return match[0]; return replacement(match); }); }, scan: function(pattern, iterator) { this.gsub(pattern, iterator); return String(this); }, truncate: function(length, truncation) { length = length || 30; truncation = truncation === undefined ? '...' : truncation; return this.length > length ? this.slice(0, length - truncation.length) + truncation : String(this); }, strip: function() { return this.replace(/^\s+/, '').replace(/\s+$/, ''); }, stripTags: function() { return this.replace(/<\/?[^>]+>/gi, ''); }, stripScripts: function() { return this.replace(new RegExp(Prototype.ScriptFragment, 'img'), ''); }, extractScripts: function() { var matchAll = new RegExp(Prototype.ScriptFragment, 'img'); var matchOne = new RegExp(Prototype.ScriptFragment, 'im'); return (this.match(matchAll) || []).map(function(scriptTag) { return (scriptTag.match(matchOne) || ['', ''])[1]; }); }, evalScripts: function(doc) { if (doc) return this.extractScripts().map(function(script) { return eval(script, doc) }); else return this.extractScripts().map(function(script) { return eval(script) }); }, escapeHTML: function() { var self = arguments.callee; self.text.data = this; return self.div.innerHTML; }, unescapeHTML: function() { var div = new Element('div'); div.innerHTML = this.stripTags(); return div.childNodes[0] ? (div.childNodes.length > 1 ? $A(div.childNodes).inject('', function(memo, node) { return memo+node.nodeValue }) : div.childNodes[0].nodeValue) : ''; }, toQueryParams: function(separator) { var match = this.strip().match(/([^?#]*)(#.*)?$/); if (!match) return { }; return match[1].split(separator || '&').inject({ }, function(hash, pair) { if ((pair = pair.split('='))[0]) { var key = decodeURIComponent(pair.shift()); var value = pair.length > 1 ? pair.join('=') : pair[0]; if (value != undefined) value = decodeURIComponent(value); if (key in hash) { if (!Object.isArray(hash[key])) hash[key] = [hash[key]]; hash[key].push(value); } else hash[key] = value; } return hash; }); }, toArray: function() { return this.split(''); }, succ: function() { return this.slice(0, this.length - 1) + String.fromCharCode(this.charCodeAt(this.length - 1) + 1); }, times: function(count) { return count < 1 ? '' : new Array(count + 1).join(this); }, camelize: function() { var parts = this.split('-'), len = parts.length; if (len == 1) return parts[0]; var camelized = this.charAt(0) == '-' ? parts[0].charAt(0).toUpperCase() + parts[0].substring(1) : parts[0]; for (var i = 1; i < len; i++) camelized += parts[i].charAt(0).toUpperCase() + parts[i].substring(1); return camelized; }, capitalize: function() { return this.charAt(0).toUpperCase() + this.substring(1).toLowerCase(); }, underscore: function() { return this.gsub(/::/, '/').gsub(/([A-Z]+)([A-Z][a-z])/,'#{1}_#{2}').gsub(/([a-z\d])([A-Z])/,'#{1}_#{2}').gsub(/-/,'_').toLowerCase(); }, dasherize: function() { return this.gsub(/_/,'-'); }, inspect: function(useDoubleQuotes) { var escapedString = this.gsub(/[\x00-\x1f\\]/, function(match) { var character = String.specialChar[match[0]]; return character ? character : '\\u00' + match[0].charCodeAt().toPaddedString(2, 16); }); if (useDoubleQuotes) return '"' + escapedString.replace(/"/g, '\\"') + '"'; return "'" + escapedString.replace(/'/g, '\\\'') + "'"; }, toJSON: function() { return this.inspect(true); }, unfilterJSON: function(filter) { return this.sub(filter || Prototype.JSONFilter, '#{1}'); }, isJSON: function() { var str = this.replace(/\\./g, '@').replace(/"[^"\\\n\r]*"/g, ''); return (/^[,:{}\[\]0-9.\-+Eaeflnr-u \n\r\t]*$/).test(str); }, evalJSON: function(sanitize) { var json = this.unfilterJSON(); try { if (!sanitize || json.isJSON()) return eval('(' + json + ')'); } catch (e) { } throw new SyntaxError('Badly formed JSON string: ' + this.inspect()); }, include: function(pattern) { return this.indexOf(pattern) > -1; }, startsWith: function(pattern) { return this.indexOf(pattern) === 0; }, endsWith: function(pattern) { var d = this.length - pattern.length; return d >= 0 && this.lastIndexOf(pattern) === d; }, empty: function() { return this == ''; }, blank: function() { return /^\s*$/.test(this); }, interpolate: function(object, pattern) { return new Template(this, pattern).evaluate(object); } }); if (Prototype.Browser.WebKit || Prototype.Browser.IE) Object.extend(String.prototype, { escapeHTML: function() { return this.replace(/&/g,'&').replace(//g,'>'); }, unescapeHTML: function() { return this.replace(/&/g,'&').replace(/</g,'<').replace(/>/g,'>'); } }); String.prototype.gsub.prepareReplacement = function(replacement) { if (Object.isFunction(replacement)) return replacement; var template = new Template(replacement); return function(match) { return template.evaluate(match) }; }; String.prototype.parseQuery = String.prototype.toQueryParams; Object.extend(String.prototype.escapeHTML, { div: document.createElement('div'), text: document.createTextNode('') }); with (String.prototype.escapeHTML) div.appendChild(text); var Template = Class.create({ initialize: function(template, pattern) { this.template = template.toString(); this.pattern = pattern || Template.Pattern; }, evaluate: function(object) { if (Object.isFunction(object.toTemplateReplacements)) object = object.toTemplateReplacements(); return this.template.gsub(this.pattern, function(match) { if (object == null) return ''; var before = match[1] || ''; if (before == '\\') return match[2]; var ctx = object, expr = match[3]; var pattern = /^([^.[]+|\[((?:.*?[^\\])?)\])(\.|\[|$)/, match = pattern.exec(expr); if (match == null) return before; while (match != null) { var comp = match[1].startsWith('[') ? match[2].gsub('\\\\]', ']') : match[1]; ctx = ctx[comp]; if (null == ctx || '' == match[3]) break; expr = expr.substring('[' == match[3] ? match[1].length : match[0].length); match = pattern.exec(expr); } return before + String.interpret(ctx); }.bind(this)); } }); Template.Pattern = /(^|.|\r|\n)(#\{(.*?)\})/; var $break = { }; var Enumerable = { each: function(iterator, context) { var index = 0; iterator = iterator.bind(context); try { this._each(function(value) { iterator(value, index++); }); } catch (e) { if (e != $break) throw e; } return this; }, eachSlice: function(number, iterator, context) { iterator = iterator ? iterator.bind(context) : Prototype.K; var index = -number, slices = [], array = this.toArray(); while ((index += number) < array.length) slices.push(array.slice(index, index+number)); return slices.collect(iterator, context); }, all: function(iterator, context) { iterator = iterator ? iterator.bind(context) : Prototype.K; var result = true; this.each(function(value, index) { result = result && !!iterator(value, index); if (!result) throw $break; }); return result; }, any: function(iterator, context) { iterator = iterator ? iterator.bind(context) : Prototype.K; var result = false; this.each(function(value, index) { if (result = !!iterator(value, index)) throw $break; }); return result; }, collect: function(iterator, context) { iterator = iterator ? iterator.bind(context) : Prototype.K; var results = []; this.each(function(value, index) { results.push(iterator(value, index)); }); return results; }, detect: function(iterator, context) { iterator = iterator.bind(context); var result; this.each(function(value, index) { if (iterator(value, index)) { result = value; throw $break; } }); return result; }, findAll: function(iterator, context) { iterator = iterator.bind(context); var results = []; this.each(function(value, index) { if (iterator(value, index)) results.push(value); }); return results; }, grep: function(filter, iterator, context) { iterator = iterator ? iterator.bind(context) : Prototype.K; var results = []; if (Object.isString(filter)) filter = new RegExp(filter); this.each(function(value, index) { if (filter.match(value)) results.push(iterator(value, index)); }); return results; }, include: function(object) { if (Object.isFunction(this.indexOf)) if (this.indexOf(object) != -1) return true; var found = false; this.each(function(value) { if (value == object) { found = true; throw $break; } }); return found; }, inGroupsOf: function(number, fillWith) { fillWith = fillWith === undefined ? null : fillWith; return this.eachSlice(number, function(slice) { while(slice.length < number) slice.push(fillWith); return slice; }); }, inject: function(memo, iterator, context) { iterator = iterator.bind(context); this.each(function(value, index) { memo = iterator(memo, value, index); }); return memo; }, invoke: function(method) { var args = $A(arguments).slice(1); return this.map(function(value) { return value[method].apply(value, args); }); }, max: function(iterator, context) { iterator = iterator ? iterator.bind(context) : Prototype.K; var result; this.each(function(value, index) { value = iterator(value, index); if (result == undefined || value >= result) result = value; }); return result; }, min: function(iterator, context) { iterator = iterator ? iterator.bind(context) : Prototype.K; var result; this.each(function(value, index) { value = iterator(value, index); if (result == undefined || value < result) result = value; }); return result; }, partition: function(iterator, context) { iterator = iterator ? iterator.bind(context) : Prototype.K; var trues = [], falses = []; this.each(function(value, index) { (iterator(value, index) ? trues : falses).push(value); }); return [trues, falses]; }, pluck: function(property) { var results = []; this.each(function(value) { results.push(value[property]); }); return results; }, reject: function(iterator, context) { iterator = iterator.bind(context); var results = []; this.each(function(value, index) { if (!iterator(value, index)) results.push(value); }); return results; }, sortBy: function(iterator, context) { iterator = iterator.bind(context); return this.map(function(value, index) { return {value: value, criteria: iterator(value, index)}; }).sort(function(left, right) { var a = left.criteria, b = right.criteria; return a < b ? -1 : a > b ? 1 : 0; }).pluck('value'); }, toArray: function() { return this.map(); }, zip: function() { var iterator = Prototype.K, args = $A(arguments); if (Object.isFunction(args.last())) iterator = args.pop(); var collections = [this].concat(args).map($A); return this.map(function(value, index) { return iterator(collections.pluck(index)); }); }, size: function() { return this.toArray().length; }, inspect: function() { return '#'; } }; Object.extend(Enumerable, { map: Enumerable.collect, find: Enumerable.detect, select: Enumerable.findAll, filter: Enumerable.findAll, member: Enumerable.include, entries: Enumerable.toArray, every: Enumerable.all, some: Enumerable.any }); function $A(iterable) { if (!iterable) return []; if (iterable.toArray) return iterable.toArray(); var length = iterable.length, results = new Array(length); while (length--) results[length] = iterable[length]; return results; } if (Prototype.Browser.WebKit) { function $A(iterable) { if (!iterable) return []; if (!(Object.isFunction(iterable) && iterable == '[object NodeList]') && iterable.toArray) return iterable.toArray(); var length = iterable.length, results = new Array(length); while (length--) results[length] = iterable[length]; return results; } } Array.from = $A; Object.extend(Array.prototype, Enumerable); if (!Array.prototype._reverse) Array.prototype._reverse = Array.prototype.reverse; Object.extend(Array.prototype, { _each: function(iterator) { for (var i = 0, length = this.length; i < length; i++) iterator(this[i]); }, clear: function() { this.length = 0; return this; }, first: function() { return this[0]; }, last: function() { return this[this.length - 1]; }, compact: function() { return this.select(function(value) { return value != null; }); }, flatten: function() { return this.inject([], function(array, value) { return array.concat(Object.isArray(value) ? value.flatten() : [value]); }); }, without: function() { var values = $A(arguments); return this.select(function(value) { return !values.include(value); }); }, reverse: function(inline) { return (inline !== false ? this : this.toArray())._reverse(); }, reduce: function() { return this.length > 1 ? this : this[0]; }, uniq: function(sorted) { return this.inject([], function(array, value, index) { if (0 == index || (sorted ? array.last() != value : !array.include(value))) array.push(value); return array; }); }, intersect: function(array) { return this.uniq().findAll(function(item) { return array.detect(function(value) { return item === value }); }); }, clone: function() { return [].concat(this); }, size: function() { return this.length; }, inspect: function() { return '[' + this.map(Object.inspect).join(', ') + ']'; }, toJSON: function() { var results = []; this.each(function(object) { var value = Object.toJSON(object); if (value !== undefined) results.push(value); }); return '[' + results.join(', ') + ']'; } }); // use native browser JS 1.6 implementation if available if (Object.isFunction(Array.prototype.forEach)) Array.prototype._each = Array.prototype.forEach; if (!Array.prototype.indexOf) Array.prototype.indexOf = function(item, i) { i || (i = 0); var length = this.length; if (i < 0) i = length + i; for (; i < length; i++) if (this[i] === item) return i; return -1; }; if (!Array.prototype.lastIndexOf) Array.prototype.lastIndexOf = function(item, i) { i = isNaN(i) ? this.length : (i < 0 ? this.length + i : i) + 1; var n = this.slice(0, i).reverse().indexOf(item); return (n < 0) ? n : i - n - 1; }; Array.prototype.toArray = Array.prototype.clone; function $w(string) { if (!Object.isString(string)) return []; string = string.strip(); return string ? string.split(/\s+/) : []; } if (Prototype.Browser.Opera){ Array.prototype.concat = function() { var array = []; for (var i = 0, length = this.length; i < length; i++) array.push(this[i]); for (var i = 0, length = arguments.length; i < length; i++) { if (Object.isArray(arguments[i])) { for (var j = 0, arrayLength = arguments[i].length; j < arrayLength; j++) array.push(arguments[i][j]); } else { array.push(arguments[i]); } } return array; }; } Object.extend(Number.prototype, { toColorPart: function() { return this.toPaddedString(2, 16); }, succ: function() { return this + 1; }, times: function(iterator) { $R(0, this, true).each(iterator); return this; }, toPaddedString: function(length, radix) { var string = this.toString(radix || 10); return '0'.times(length - string.length) + string; }, toJSON: function() { return isFinite(this) ? this.toString() : 'null'; } }); $w('abs round ceil floor').each(function(method){ Number.prototype[method] = Math[method].methodize(); }); function $H(object) { return new Hash(object); }; var Hash = Class.create(Enumerable, (function() { if (function() { var i = 0, Test = function(value) { this.key = value }; Test.prototype.key = 'foo'; for (var property in new Test('bar')) i++; return i > 1; }()) { function each(iterator) { var cache = []; for (var key in this._object) { var value = this._object[key]; if (cache.include(key)) continue; cache.push(key); var pair = [key, value]; pair.key = key; pair.value = value; iterator(pair); } } } else { function each(iterator) { for (var key in this._object) { var value = this._object[key], pair = [key, value]; pair.key = key; pair.value = value; iterator(pair); } } } function toQueryPair(key, value) { if (Object.isUndefined(value)) return key; return key + '=' + encodeURIComponent(String.interpret(value)); } return { initialize: function(object) { this._object = Object.isHash(object) ? object.toObject() : Object.clone(object); }, _each: each, set: function(key, value) { return this._object[key] = value; }, get: function(key) { return this._object[key]; }, unset: function(key) { var value = this._object[key]; delete this._object[key]; return value; }, toObject: function() { return Object.clone(this._object); }, keys: function() { return this.pluck('key'); }, values: function() { return this.pluck('value'); }, index: function(value) { var match = this.detect(function(pair) { return pair.value === value; }); return match && match.key; }, merge: function(object) { return this.clone().update(object); }, update: function(object) { return new Hash(object).inject(this, function(result, pair) { result.set(pair.key, pair.value); return result; }); }, toQueryString: function() { return this.map(function(pair) { var key = encodeURIComponent(pair.key), values = pair.value; if (values && typeof values == 'object') { if (Object.isArray(values)) return values.map(toQueryPair.curry(key)).join('&'); } return toQueryPair(key, values); }).join('&'); }, inspect: function() { return '#'; }, toJSON: function() { return Object.toJSON(this.toObject()); }, clone: function() { return new Hash(this); } } })()); Hash.prototype.toTemplateReplacements = Hash.prototype.toObject; Hash.from = $H; var ObjectRange = Class.create(Enumerable, { initialize: function(start, end, exclusive) { this.start = start; this.end = end; this.exclusive = exclusive; }, _each: function(iterator) { var value = this.start; while (this.include(value)) { iterator(value); value = value.succ(); } }, include: function(value) { if (value < this.start) return false; if (this.exclusive) return value < this.end; return value <= this.end; } }); var $R = function(start, end, exclusive) { return new ObjectRange(start, end, exclusive); }; var Ajax = { getTransport: function() { return Try.these( function() {return new XMLHttpRequest()}, function() {return new ActiveXObject('Msxml2.XMLHTTP')}, function() {return new ActiveXObject('Microsoft.XMLHTTP')} ) || false; }, activeRequestCount: 0 }; Ajax.Responders = { responders: [], _each: function(iterator) { this.responders._each(iterator); }, register: function(responder) { if (!this.include(responder)) this.responders.push(responder); }, unregister: function(responder) { this.responders = this.responders.without(responder); }, dispatch: function(callback, request, transport, json) { this.each(function(responder) { if (Object.isFunction(responder[callback])) { try { responder[callback].apply(responder, [request, transport, json]); } catch (e) { } } }); } }; Object.extend(Ajax.Responders, Enumerable); Ajax.Responders.register({ onCreate: function() { Ajax.activeRequestCount++ }, onComplete: function() { Ajax.activeRequestCount-- } }); Ajax.Base = Class.create({ initialize: function(options) { this.options = { method: 'post', asynchronous: true, contentType: 'application/x-www-form-urlencoded', encoding: 'UTF-8', parameters: '', evalJSON: true, evalJS: true }; Object.extend(this.options, options || { }); this.options.method = this.options.method.toLowerCase(); if (Object.isString(this.options.parameters)) this.options.parameters = this.options.parameters.toQueryParams(); } }); Ajax.Request = Class.create(Ajax.Base, { _complete: false, initialize: function($super, url, options) { $super(options); this.transport = Ajax.getTransport(); this.request(url); }, request: function(url) { this.url = url; this.method = this.options.method; var params = Object.clone(this.options.parameters); if (!['get', 'post'].include(this.method)) { // simulate other verbs over post params['_method'] = this.method; this.method = 'post'; } this.parameters = params; if (params = Object.toQueryString(params)) { // when GET, append parameters to URL if (this.method == 'get') this.url += (this.url.include('?') ? '&' : '?') + params; else if (/Konqueror|Safari|KHTML/.test(navigator.userAgent)) params += '&_='; } try { var response = new Ajax.Response(this); if (this.options.onCreate) this.options.onCreate(response); Ajax.Responders.dispatch('onCreate', this, response); this.transport.open(this.method.toUpperCase(), this.url, this.options.asynchronous); if (this.options.asynchronous) this.respondToReadyState.bind(this).defer(1); this.transport.onreadystatechange = this.onStateChange.bind(this); this.setRequestHeaders(); this.body = this.method == 'post' ? (this.options.postBody || params) : null; this.transport.send(this.body); /* Force Firefox to handle ready state 4 for synchronous requests */ if (!this.options.asynchronous && this.transport.overrideMimeType) this.onStateChange(); } catch (e) { this.dispatchException(e); } }, onStateChange: function() { var readyState = this.transport.readyState; if (readyState > 1 && !((readyState == 4) && this._complete)) this.respondToReadyState(this.transport.readyState); }, setRequestHeaders: function() { var headers = { 'X-Requested-With': 'XMLHttpRequest', 'X-Prototype-Version': Prototype.Version, 'Accept': 'text/javascript, text/html, application/xml, text/xml, */*' }; if (this.method == 'post') { headers['Content-type'] = this.options.contentType + (this.options.encoding ? '; charset=' + this.options.encoding : ''); /* Force "Connection: close" for older Mozilla browsers to work * around a bug where XMLHttpRequest sends an incorrect * Content-length header. See Mozilla Bugzilla #246651. */ if (this.transport.overrideMimeType && (navigator.userAgent.match(/Gecko\/(\d{4})/) || [0,2005])[1] < 2005) headers['Connection'] = 'close'; } // user-defined headers if (typeof this.options.requestHeaders == 'object') { var extras = this.options.requestHeaders; if (Object.isFunction(extras.push)) for (var i = 0, length = extras.length; i < length; i += 2) headers[extras[i]] = extras[i+1]; else $H(extras).each(function(pair) { headers[pair.key] = pair.value }); } for (var name in headers) this.transport.setRequestHeader(name, headers[name]); }, success: function() { var status = this.getStatus(); return !status || (status >= 200 && status < 300); }, getStatus: function() { try { return this.transport.status || 0; } catch (e) { return 0 } }, respondToReadyState: function(readyState) { var state = Ajax.Request.Events[readyState], response = new Ajax.Response(this); if (state == 'Complete') { try { this._complete = true; (this.options['on' + response.status] || this.options['on' + (this.success() ? 'Success' : 'Failure')] || Prototype.emptyFunction)(response, response.headerJSON); } catch (e) { this.dispatchException(e); } var contentType = response.getHeader('Content-type'); if (this.options.evalJS == 'force' || (this.options.evalJS && contentType && contentType.match(/^\s*(text|application)\/(x-)?(java|ecma)script(;.*)?\s*$/i))) this.evalResponse(); } try { (this.options['on' + state] || Prototype.emptyFunction)(response, response.headerJSON); Ajax.Responders.dispatch('on' + state, this, response, response.headerJSON); } catch (e) { this.dispatchException(e); } if (state == 'Complete') { // avoid memory leak in MSIE: clean up this.transport.onreadystatechange = Prototype.emptyFunction; } }, getHeader: function(name) { try { return this.transport.getResponseHeader(name); } catch (e) { return null } }, evalResponse: function() { try { return eval((this.transport.responseText || '').unfilterJSON()); } catch (e) { this.dispatchException(e); } }, dispatchException: function(exception) { (this.options.onException || Prototype.emptyFunction)(this, exception); Ajax.Responders.dispatch('onException', this, exception); } }); Ajax.Request.Events = ['Uninitialized', 'Loading', 'Loaded', 'Interactive', 'Complete']; Ajax.Response = Class.create({ initialize: function(request){ this.request = request; var transport = this.transport = request.transport, readyState = this.readyState = transport.readyState; if((readyState > 2 && !Prototype.Browser.IE) || readyState == 4) { this.status = this.getStatus(); this.statusText = this.getStatusText(); this.responseText = String.interpret(transport.responseText); this.headerJSON = this._getHeaderJSON(); } if(readyState == 4) { var xml = transport.responseXML; this.responseXML = xml === undefined ? null : xml; this.responseJSON = this._getResponseJSON(); } }, status: 0, statusText: '', getStatus: Ajax.Request.prototype.getStatus, getStatusText: function() { try { return this.transport.statusText || ''; } catch (e) { return '' } }, getHeader: Ajax.Request.prototype.getHeader, getAllHeaders: function() { try { return this.getAllResponseHeaders(); } catch (e) { return null } }, getResponseHeader: function(name) { return this.transport.getResponseHeader(name); }, getAllResponseHeaders: function() { return this.transport.getAllResponseHeaders(); }, _getHeaderJSON: function() { var json = this.getHeader('X-JSON'); if (!json) return null; json = decodeURIComponent(escape(json)); try { return json.evalJSON(this.request.options.sanitizeJSON); } catch (e) { this.request.dispatchException(e); } }, _getResponseJSON: function() { var options = this.request.options; if (!options.evalJSON || (options.evalJSON != 'force' && !(this.getHeader('Content-type') || '').include('application/json'))) return null; try { return this.transport.responseText.evalJSON(options.sanitizeJSON); } catch (e) { this.request.dispatchException(e); } } }); Ajax.Updater = Class.create(Ajax.Request, { initialize: function($super, container, url, options) { this.container = { success: (container.success || container), failure: (container.failure || (container.success ? null : container)) }; options = options || { }; var onComplete = options.onComplete; options.onComplete = (function(response, param) { this.updateContent(response.responseText); if (Object.isFunction(onComplete)) onComplete(response, param); }).bind(this); $super(url, options); }, updateContent: function(responseText) { var receiver = this.container[this.success() ? 'success' : 'failure'], options = this.options; if (!options.evalScripts) responseText = responseText.stripScripts(); if (receiver = $(receiver)) { if (options.insertion) { if (Object.isString(options.insertion)) { var insertion = { }; insertion[options.insertion] = responseText; receiver.insert(insertion); } else options.insertion(receiver, responseText); } else receiver.update(responseText); } if (this.success()) { if (this.onComplete) this.onComplete.bind(this).defer(); } } }); Ajax.PeriodicalUpdater = Class.create(Ajax.Base, { initialize: function($super, container, url, options) { $super(options); this.onComplete = this.options.onComplete; this.frequency = (this.options.frequency || 2); this.decay = (this.options.decay || 1); this.updater = { }; this.container = container; this.url = url; this.start(); }, start: function() { this.options.onComplete = this.updateComplete.bind(this); this.onTimerEvent(); }, stop: function() { this.updater.options.onComplete = undefined; clearTimeout(this.timer); (this.onComplete || Prototype.emptyFunction).apply(this, arguments); }, updateComplete: function(response) { if (this.options.decay) { this.decay = (response.responseText == this.lastText ? this.decay * this.options.decay : 1); this.lastText = response.responseText; } this.timer = this.onTimerEvent.bind(this).delay(this.decay * this.frequency); }, onTimerEvent: function() { this.updater = new Ajax.Updater(this.container, this.url, this.options); } }); function $(element) { if (arguments.length > 1) { for (var i = 0, elements = [], length = arguments.length; i < length; i++) elements.push($(arguments[i])); return elements; } if (Object.isString(element)) element = document.getElementById(element); return Element.extend(element); } if (Prototype.BrowserFeatures.XPath) { document._getElementsByXPath = function(expression, parentElement) { var results = []; var query = document.evaluate(expression, $(parentElement) || document, null, XPathResult.ORDERED_NODE_SNAPSHOT_TYPE, null); for (var i = 0, length = query.snapshotLength; i < length; i++) results.push(Element.extend(query.snapshotItem(i))); return results; }; } /*--------------------------------------------------------------------------*/ if (!window.Node) var Node = { }; if (!window.Element) var Element = { }; if (!Node.ELEMENT_NODE) { // DOM level 2 ECMAScript Language Binding Object.extend(Node, { ELEMENT_NODE: 1, ATTRIBUTE_NODE: 2, TEXT_NODE: 3, CDATA_SECTION_NODE: 4, ENTITY_REFERENCE_NODE: 5, ENTITY_NODE: 6, PROCESSING_INSTRUCTION_NODE: 7, COMMENT_NODE: 8, DOCUMENT_NODE: 9, DOCUMENT_TYPE_NODE: 10, DOCUMENT_FRAGMENT_NODE: 11, NOTATION_NODE: 12 }); } (function() { var element = this.Element; this.Element = function(tagName, attributes, doc) { if (doc == null) doc = document ; attributes = attributes || { }; tagName = tagName.toLowerCase(); var cache = Element.cache; if (Prototype.Browser.IE && attributes.name) { tagName = '<' + tagName + ' name="' + attributes.name + '">'; delete attributes.name; return Element.writeAttribute(doc.createElement(tagName), attributes); } if (!cache[tagName]) cache[tagName] = Element.extend(doc.createElement(tagName)); return Element.writeAttribute(cache[tagName].cloneNode(false), attributes); }; Object.extend(this.Element, element || { }); }).call(window); Element.cache = { }; Element.Methods = { visible: function(element) { return $(element).style.display != 'none'; }, toggle: function(element) { element = $(element); Element[Element.visible(element) ? 'hide' : 'show'](element); return element; }, hide: function(element) { $(element).style.display = 'none'; return element; }, show: function(element) { $(element).style.display = ''; return element; }, remove: function(element) { element = $(element); element.parentNode.removeChild(element); return element; }, update: function(element, content) { element = $(element); if (content && content.toElement) content = content.toElement(); if (Object.isElement(content)) return element.update().insert(content); content = Object.toHTML(content); element.innerHTML = content.stripScripts(); content.evalScripts.bind(content).defer(element.ownerDocument); return element; }, replace: function(element, content) { element = $(element); if (content && content.toElement) content = content.toElement(); else if (!Object.isElement(content)) { content = Object.toHTML(content); var range = element.ownerDocument.createRange(); range.selectNode(element); content.evalScripts.bind(content).defer(element.ownerDocument); content = range.createContextualFragment(content.stripScripts()); } element.parentNode.replaceChild(content, element); return element; }, insert: function(element, insertions) { element = $(element); if (Object.isString(insertions) || Object.isNumber(insertions) || Object.isElement(insertions) || (insertions && (insertions.toElement || insertions.toHTML))) insertions = {bottom:insertions}; var content, t, range; for (position in insertions) { content = insertions[position]; position = position.toLowerCase(); t = Element._insertionTranslations[position]; if (content && content.toElement) content = content.toElement(); if (Object.isElement(content)) { t.insert(element, content); continue; } content = Object.toHTML(content); range = element.ownerDocument.createRange(); t.initializeRange(element, range); t.insert(element, range.createContextualFragment(content.stripScripts())); content.evalScripts.bind(content).defer(element.ownerDocument); } return element; }, wrap: function(element, wrapper, attributes) { element = $(element); if (Object.isElement(wrapper)) $(wrapper).writeAttribute(attributes || { }); else if (Object.isString(wrapper)) wrapper = new Element(wrapper, attributes, element.ownerDocument); else wrapper = new Element('div', wrapper, element.ownerDocument); if (element.parentNode) element.parentNode.replaceChild(wrapper, element); wrapper.appendChild(element); return wrapper; }, inspect: function(element) { element = $(element); var result = '<' + element.tagName.toLowerCase(); $H({'id': 'id', 'className': 'class'}).each(function(pair) { var property = pair.first(), attribute = pair.last(); var value = (element[property] || '').toString(); if (value) result += ' ' + attribute + '=' + value.inspect(true); }); return result + '>'; }, recursivelyCollect: function(element, property) { element = $(element); var elements = []; while (element = element[property]) if (element.nodeType == 1) elements.push(Element.extend(element)); return elements; }, ancestors: function(element) { return $(element).recursivelyCollect('parentNode'); }, descendants: function(element) { return $A($(element).getElementsByTagName('*')).each(Element.extend); }, firstDescendant: function(element) { element = $(element).firstChild; while (element && element.nodeType != 1) element = element.nextSibling; return $(element); }, immediateDescendants: function(element) { if (!(element = $(element).firstChild)) return []; while (element && element.nodeType != 1) element = element.nextSibling; if (element) return [element].concat($(element).nextSiblings()); return []; }, previousSiblings: function(element) { return $(element).recursivelyCollect('previousSibling'); }, nextSiblings: function(element) { return $(element).recursivelyCollect('nextSibling'); }, siblings: function(element) { element = $(element); return element.previousSiblings().reverse().concat(element.nextSiblings()); }, match: function(element, selector) { if (Object.isString(selector)) selector = new Selector(selector); return selector.match($(element)); }, up: function(element, expression, index) { element = $(element); if (arguments.length == 1) return $(element.parentNode); var ancestors = element.ancestors(); return expression ? Selector.findElement(ancestors, expression, index) : ancestors[index || 0]; }, down: function(element, expression, index) { element = $(element); if (arguments.length == 1) return element.firstDescendant(); var descendants = element.descendants(); return expression ? Selector.findElement(descendants, expression, index) : descendants[index || 0]; }, previous: function(element, expression, index) { element = $(element); if (arguments.length == 1) return $(Selector.handlers.previousElementSibling(element)); var previousSiblings = element.previousSiblings(); return expression ? Selector.findElement(previousSiblings, expression, index) : previousSiblings[index || 0]; }, next: function(element, expression, index) { element = $(element); if (arguments.length == 1) return $(Selector.handlers.nextElementSibling(element)); var nextSiblings = element.nextSiblings(); return expression ? Selector.findElement(nextSiblings, expression, index) : nextSiblings[index || 0]; }, select: function() { var args = $A(arguments), element = $(args.shift()); return Selector.findChildElements(element, args); }, adjacent: function() { var args = $A(arguments), element = $(args.shift()); return Selector.findChildElements(element.parentNode, args).without(element); }, identify: function(element) { element = $(element); var id = element.readAttribute('id'), self = arguments.callee; if (id) return id; do { id = 'anonymous_element_' + self.counter++ } while ($(id)); element.writeAttribute('id', id); return id; }, readAttribute: function(element, name) { element = $(element); if (Prototype.Browser.IE) { var t = Element._attributeTranslations.read; if (t.values[name]) return t.values[name](element, name); if (t.names[name]) name = t.names[name]; if (name.include(':')) { return (!element.attributes || !element.attributes[name]) ? null : element.attributes[name].value; } } return element.getAttribute(name); }, writeAttribute: function(element, name, value) { element = $(element); var attributes = { }, t = Element._attributeTranslations.write; if (typeof name == 'object') attributes = name; else attributes[name] = value === undefined ? true : value; for (var attr in attributes) { var name = t.names[attr] || attr, value = attributes[attr]; if (t.values[attr]) name = t.values[attr](element, value); if (value === false || value === null) element.removeAttribute(name); else if (value === true) element.setAttribute(name, name); else element.setAttribute(name, value); } return element; }, getHeight: function(element) { return $(element).getDimensions().height; }, getWidth: function(element) { return $(element).getDimensions().width; }, classNames: function(element) { return new Element.ClassNames(element, null, element.ownerDocument); }, hasClassName: function(element, className) { if (!(element = $(element))) return; var elementClassName = element.className; return (elementClassName.length > 0 && (elementClassName == className || new RegExp("(^|\\s)" + className + "(\\s|$)").test(elementClassName))); }, addClassName: function(element, className) { if (!(element = $(element))) return; if (!element.hasClassName(className)) element.className += (element.className ? ' ' : '') + className; return element; }, removeClassName: function(element, className) { if (!(element = $(element))) return; element.className = element.className.replace( new RegExp("(^|\\s+)" + className + "(\\s+|$)"), ' ').strip(); return element; }, toggleClassName: function(element, className) { if (!(element = $(element))) return; return element[element.hasClassName(className) ? 'removeClassName' : 'addClassName'](className); }, // removes whitespace-only text node children cleanWhitespace: function(element) { element = $(element); var node = element.firstChild; while (node) { var nextNode = node.nextSibling; if (node.nodeType == 3 && !/\S/.test(node.nodeValue)) element.removeChild(node); node = nextNode; } return element; }, empty: function(element) { return $(element).innerHTML.blank(); }, descendantOf: function(element, ancestor) { element = $(element), ancestor = $(ancestor); if (element.compareDocumentPosition) return (element.compareDocumentPosition(ancestor) & 8) === 8; if (element.sourceIndex && !Prototype.Browser.Opera) { var e = element.sourceIndex, a = ancestor.sourceIndex, nextAncestor = ancestor.nextSibling; if (!nextAncestor) { do { ancestor = ancestor.parentNode; } while (!(nextAncestor = ancestor.nextSibling) && ancestor.parentNode); } if (nextAncestor) return (e > a && e < nextAncestor.sourceIndex); } while (element = element.parentNode) if (element == ancestor) return true; return false; }, scrollTo: function(element) { element = $(element); var pos = element.cumulativeOffset(); window.scrollTo(pos[0], pos[1]); return element; }, getStyle: function(element, style) { element = $(element); style = style == 'float' ? 'cssFloat' : style.camelize(); var value = element.style[style]; var doc = element.ownerDocument ; if (!value) { var css = doc.defaultView.getComputedStyle(element, null); value = css ? css[style] : null; } if (style == 'opacity') return value ? parseFloat(value) : 1.0; return value == 'auto' ? null : value; }, getOpacity: function(element) { return $(element).getStyle('opacity'); }, setStyle: function(element, styles) { element = $(element); var elementStyle = element.style, match; if (Object.isString(styles)) { element.style.cssText += ';' + styles; return styles.include('opacity') ? element.setOpacity(styles.match(/opacity:\s*(\d?\.?\d*)/)[1]) : element; } for (var property in styles) if (property == 'opacity') element.setOpacity(styles[property]); else elementStyle[(property == 'float' || property == 'cssFloat') ? (elementStyle.styleFloat === undefined ? 'cssFloat' : 'styleFloat') : property] = styles[property]; return element; }, setOpacity: function(element, value) { element = $(element); element.style.opacity = (value == 1 || value === '') ? '' : (value < 0.00001) ? 0 : value; return element; }, getDimensions: function(element) { element = $(element); var display = $(element).getStyle('display'); if (display != 'none' && display != null) // Safari bug return {width: element.offsetWidth, height: element.offsetHeight}; // All *Width and *Height properties give 0 on elements with display none, // so enable the element temporarily var els = element.style; var originalVisibility = els.visibility; var originalPosition = els.position; var originalDisplay = els.display; els.visibility = 'hidden'; els.position = 'absolute'; els.display = 'block'; var originalWidth = element.clientWidth; var originalHeight = element.clientHeight; els.display = originalDisplay; els.position = originalPosition; els.visibility = originalVisibility; return {width: originalWidth, height: originalHeight}; }, makePositioned: function(element) { element = $(element); var pos = Element.getStyle(element, 'position'); if (pos == 'static' || !pos) { element._madePositioned = true; element.style.position = 'relative'; // Opera returns the offset relative to the positioning context, when an // element is position relative but top and left have not been defined if (window.opera) { element.style.top = 0; element.style.left = 0; } } return element; }, undoPositioned: function(element) { element = $(element); if (element._madePositioned) { element._madePositioned = undefined; element.style.position = element.style.top = element.style.left = element.style.bottom = element.style.right = ''; } return element; }, makeClipping: function(element) { element = $(element); if (element._overflow) return element; element._overflow = Element.getStyle(element, 'overflow') || 'auto'; if (element._overflow !== 'hidden') element.style.overflow = 'hidden'; return element; }, undoClipping: function(element) { element = $(element); if (!element._overflow) return element; element.style.overflow = element._overflow == 'auto' ? '' : element._overflow; element._overflow = null; return element; }, cumulativeOffset: function(element) { var valueT = 0, valueL = 0; do { valueT += element.offsetTop || 0; valueL += element.offsetLeft || 0; element = element.offsetParent; } while (element); return Element._returnOffset(valueL, valueT); }, positionedOffset: function(element) { var valueT = 0, valueL = 0; do { valueT += element.offsetTop || 0; valueL += element.offsetLeft || 0; element = element.offsetParent; if (element) { if (element.tagName == 'BODY') break; var p = Element.getStyle(element, 'position'); if (p == 'relative' || p == 'absolute') break; } } while (element); return Element._returnOffset(valueL, valueT); }, absolutize: function(element) { element = $(element); if (element.getStyle('position') == 'absolute') return; // Position.prepare(); // To be done manually by Scripty when it needs it. var offsets = element.positionedOffset(); var top = offsets[1]; var left = offsets[0]; var width = element.clientWidth; var height = element.clientHeight; element._originalLeft = left - parseFloat(element.style.left || 0); element._originalTop = top - parseFloat(element.style.top || 0); element._originalWidth = element.style.width; element._originalHeight = element.style.height; element.style.position = 'absolute'; element.style.top = top + 'px'; element.style.left = left + 'px'; element.style.width = width + 'px'; element.style.height = height + 'px'; return element; }, relativize: function(element) { element = $(element); if (element.getStyle('position') == 'relative') return; // Position.prepare(); // To be done manually by Scripty when it needs it. element.style.position = 'relative'; var top = parseFloat(element.style.top || 0) - (element._originalTop || 0); var left = parseFloat(element.style.left || 0) - (element._originalLeft || 0); element.style.top = top + 'px'; element.style.left = left + 'px'; element.style.height = element._originalHeight; element.style.width = element._originalWidth; return element; }, cumulativeScrollOffset: function(element) { var valueT = 0, valueL = 0; do { valueT += element.scrollTop || 0; valueL += element.scrollLeft || 0; element = element.parentNode; } while (element); return Element._returnOffset(valueL, valueT); }, getOffsetParent: function(element) { if (element.offsetParent) return $(element.offsetParent); var doc = element.ownerDocument ; if (element == doc.body) return $(element); while ((element = element.parentNode) && element != doc.body) if (Element.getStyle(element, 'position') != 'static') return $(element); return $(doc.body); }, viewportOffset: function(forElement) { var valueT = 0, valueL = 0; var element = forElement; do { valueT += element.offsetTop || 0; valueL += element.offsetLeft || 0; // Safari fix if (element.offsetParent != null && element.offsetParent.tagName == 'BODY' && Element.getStyle(element, 'position') == 'absolute') break; } while (element = element.offsetParent); element = forElement; do { if (!Prototype.Browser.Opera || element.tagName == 'BODY') { valueT -= element.scrollTop || 0; valueL -= element.scrollLeft || 0; } } while (element = element.parentNode); return Element._returnOffset(valueL, valueT); }, clonePosition: function(element, source) { var options = Object.extend({ setLeft: true, setTop: true, setWidth: true, setHeight: true, offsetTop: 0, offsetLeft: 0 }, arguments[2] || { }); // find page position of source source = $(source); var p = source.viewportOffset(); // find coordinate system to use element = $(element); var delta = [0, 0]; var parent = null; // delta [0,0] will do fine with position: fixed elements, // position:absolute needs offsetParent deltas if (Element.getStyle(element, 'position') == 'absolute') { parent = element.getOffsetParent(); delta = parent.viewportOffset(); } // correct by body offsets (fixes Safari) if (parent == document.body) { delta[0] -= document.body.offsetLeft; delta[1] -= document.body.offsetTop; } // set position if (options.setLeft) element.style.left = (p[0] - delta[0] + options.offsetLeft) + 'px'; if (options.setTop) element.style.top = (p[1] - delta[1] + options.offsetTop) + 'px'; if (options.setWidth) element.style.width = source.offsetWidth + 'px'; if (options.setHeight) element.style.height = source.offsetHeight + 'px'; return element; } }; Element.Methods.identify.counter = 1; Object.extend(Element.Methods, { getElementsBySelector: Element.Methods.select, childElements: Element.Methods.immediateDescendants }); Element._attributeTranslations = { write: { names: { className: 'class', htmlFor: 'for' }, values: { } } }; if (!document.createRange || Prototype.Browser.Opera) { Element.Methods.insert = function(element, insertions) { element = $(element); if (Object.isString(insertions) || Object.isNumber(insertions) || Object.isElement(insertions) || (insertions && (insertions.toElement || insertions.toHTML))) insertions = { bottom: insertions }; var t = Element._insertionTranslations, content, position, pos, tagName; for (position in insertions) { content = insertions[position]; position = position.toLowerCase(); pos = t[position]; if (content && content.toElement) content = content.toElement(); if (Object.isElement(content)) { pos.insert(element, content); continue; } content = Object.toHTML(content); tagName = ((position == 'before' || position == 'after') ? element.parentNode : element).tagName.toUpperCase(); if (t.tags[tagName]) { var fragments = Element._getContentFromAnonymousElement(tagName, content.stripScripts(), element.ownerDocument); if (position == 'top' || position == 'after') fragments.reverse(); fragments.each(pos.insert.curry(element)); } else element.insertAdjacentHTML(pos.adjacency, content.stripScripts()); content.evalScripts.bind(content).defer(element.ownerDocument); } return element; }; } if (Prototype.Browser.Opera) { Element.Methods._getStyle = Element.Methods.getStyle; Element.Methods.getStyle = function(element, style) { switch(style) { case 'left': case 'top': case 'right': case 'bottom': if (Element._getStyle(element, 'position') == 'static') return null; default: return Element._getStyle(element, style); } }; Element.Methods._readAttribute = Element.Methods.readAttribute; Element.Methods.readAttribute = function(element, attribute) { if (attribute == 'title') return element.title; return Element._readAttribute(element, attribute); }; } else if (Prototype.Browser.IE) { $w('positionedOffset getOffsetParent viewportOffset').each(function(method) { Element.Methods[method] = Element.Methods[method].wrap( function(proceed, element) { element = $(element); var position = element.getStyle('position'); if (position != 'static') return proceed(element); element.setStyle({ position: 'relative' }); var value = proceed(element); element.setStyle({ position: position }); return value; } ); }); Element.Methods.getStyle = function(element, style) { element = $(element); style = (style == 'float' || style == 'cssFloat') ? 'styleFloat' : style.camelize(); var value = element.style[style]; if (!value && element.currentStyle) value = element.currentStyle[style]; if (style == 'opacity') { if (value = (element.getStyle('filter') || '').match(/alpha\(opacity=(.*)\)/)) if (value[1]) return parseFloat(value[1]) / 100; return 1.0; } if (value == 'auto') { if ((style == 'width' || style == 'height') && (element.getStyle('display') != 'none')) return element['offset' + style.capitalize()] + 'px'; return null; } return value; }; Element.Methods.setOpacity = function(element, value) { function stripAlpha(filter){ return filter.replace(/alpha\([^\)]*\)/gi,''); } element = $(element); var currentStyle = element.currentStyle; if ((currentStyle && !currentStyle.hasLayout) || (!currentStyle && element.style.zoom == 'normal')) element.style.zoom = 1; var filter = element.getStyle('filter'), style = element.style; if (value == 1 || value === '') { (filter = stripAlpha(filter)) ? style.filter = filter : style.removeAttribute('filter'); return element; } else if (value < 0.00001) value = 0; style.filter = stripAlpha(filter) + 'alpha(opacity=' + (value * 100) + ')'; return element; }; Element._attributeTranslations = { read: { names: { 'class': 'className', 'for': 'htmlFor' }, values: { _getAttr: function(element, attribute) { return element.getAttribute(attribute, 2); }, _getAttrNode: function(element, attribute) { var node = element.getAttributeNode(attribute); return node ? node.value : ""; }, _getEv: function(element, attribute) { var attribute = element.getAttribute(attribute); return attribute ? attribute.toString().slice(23, -2) : null; }, _flag: function(element, attribute) { return $(element).hasAttribute(attribute) ? attribute : null; }, style: function(element) { return element.style.cssText.toLowerCase(); }, title: function(element) { return element.title; } } } }; Element._attributeTranslations.write = { names: Object.clone(Element._attributeTranslations.read.names), values: { checked: function(element, value) { element.checked = !!value; }, style: function(element, value) { element.style.cssText = value ? value : ''; } } }; Element._attributeTranslations.has = {}; $w('colSpan rowSpan vAlign dateTime accessKey tabIndex ' + 'encType maxLength readOnly longDesc').each(function(attr) { Element._attributeTranslations.write.names[attr.toLowerCase()] = attr; Element._attributeTranslations.has[attr.toLowerCase()] = attr; }); (function(v) { Object.extend(v, { href: v._getAttr, src: v._getAttr, type: v._getAttr, action: v._getAttrNode, disabled: v._flag, checked: v._flag, readonly: v._flag, multiple: v._flag, onload: v._getEv, onunload: v._getEv, onclick: v._getEv, ondblclick: v._getEv, onmousedown: v._getEv, onmouseup: v._getEv, onmouseover: v._getEv, onmousemove: v._getEv, onmouseout: v._getEv, onfocus: v._getEv, onblur: v._getEv, onkeypress: v._getEv, onkeydown: v._getEv, onkeyup: v._getEv, onsubmit: v._getEv, onreset: v._getEv, onselect: v._getEv, onchange: v._getEv }); })(Element._attributeTranslations.read.values); } else if (Prototype.Browser.Gecko && /rv:1\.8\.0/.test(navigator.userAgent)) { Element.Methods.setOpacity = function(element, value) { element = $(element); element.style.opacity = (value == 1) ? 0.999999 : (value === '') ? '' : (value < 0.00001) ? 0 : value; return element; }; } else if (Prototype.Browser.WebKit) { Element.Methods.setOpacity = function(element, value) { element = $(element); element.style.opacity = (value == 1 || value === '') ? '' : (value < 0.00001) ? 0 : value; if (value == 1) if(element.tagName == 'IMG' && element.width) { element.width++; element.width--; } else try { var n = document.createTextNode(' '); element.appendChild(n); element.removeChild(n); } catch (e) { } return element; }; // Safari returns margins on body which is incorrect if the child is absolutely // positioned. For performance reasons, redefine Position.cumulativeOffset for // KHTML/WebKit only. Element.Methods.cumulativeOffset = function(element) { var valueT = 0, valueL = 0; do { valueT += element.offsetTop || 0; valueL += element.offsetLeft || 0; if (element.offsetParent == document.body) if (Element.getStyle(element, 'position') == 'absolute') break; element = element.offsetParent; } while (element); return Element._returnOffset(valueL, valueT); }; } if (Prototype.Browser.IE || Prototype.Browser.Opera) { // IE and Opera are missing .innerHTML support for TABLE-related and SELECT elements Element.Methods.update = function(element, content) { element = $(element); if (content && content.toElement) content = content.toElement(); if (Object.isElement(content)) return element.update().insert(content); content = Object.toHTML(content); var tagName = element.tagName.toUpperCase(); if (tagName in Element._insertionTranslations.tags) { $A(element.childNodes).each(function(node) { element.removeChild(node) }); Element._getContentFromAnonymousElement(tagName, content.stripScripts(), element.ownerDocument) .each(function(node) { element.appendChild(node) }); } else element.innerHTML = content.stripScripts(); content.evalScripts.bind(content).defer(element.ownerDocument); return element; }; } if (document.createElement('div').outerHTML) { Element.Methods.replace = function(element, content) { element = $(element); if (content && content.toElement) content = content.toElement(); if (Object.isElement(content)) { element.parentNode.replaceChild(content, element); return element; } content = Object.toHTML(content); var parent = element.parentNode, tagName = parent.tagName.toUpperCase(); if (Element._insertionTranslations.tags[tagName]) { var nextSibling = element.next(); var fragments = Element._getContentFromAnonymousElement(tagName, content.stripScripts(), element.ownerDocument); parent.removeChild(element); if (nextSibling) fragments.each(function(node) { parent.insertBefore(node, nextSibling) }); else fragments.each(function(node) { parent.appendChild(node) }); } else element.outerHTML = content.stripScripts(); content.evalScripts.bind(content).defer(element.ownerDocument); return element; }; } Element._returnOffset = function(l, t) { var result = [l, t]; result.left = l; result.top = t; return result; }; Element._getContentFromAnonymousElement = function(tagName, html, doc) { var div = new Element('div', null, doc), t = Element._insertionTranslations.tags[tagName]; div.innerHTML = t[0] + html + t[1]; t[2].times(function() { div = div.firstChild }); return $A(div.childNodes); }; Element._insertionTranslations = { before: { adjacency: 'beforeBegin', insert: function(element, node) { element.parentNode.insertBefore(node, element); }, initializeRange: function(element, range) { range.setStartBefore(element); } }, top: { adjacency: 'afterBegin', insert: function(element, node) { element.insertBefore(node, element.firstChild); }, initializeRange: function(element, range) { range.selectNodeContents(element); range.collapse(true); } }, bottom: { adjacency: 'beforeEnd', insert: function(element, node) { element.appendChild(node); } }, after: { adjacency: 'afterEnd', insert: function(element, node) { element.parentNode.insertBefore(node, element.nextSibling); }, initializeRange: function(element, range) { range.setStartAfter(element); } }, tags: { TABLE: ['', '
    ', 1], TBODY: ['', '
    ', 2], TR: ['', '
    ', 3], TD: ['
    ', '
    ', 4], SELECT: ['', 1] } }; (function() { this.bottom.initializeRange = this.top.initializeRange; Object.extend(this.tags, { THEAD: this.tags.TBODY, TFOOT: this.tags.TBODY, TH: this.tags.TD }); }).call(Element._insertionTranslations); Element.Methods.Simulated = { hasAttribute: function(element, attribute) { attribute = Element._attributeTranslations.has[attribute] || attribute; var node = $(element).getAttributeNode(attribute); return node && node.specified; } }; Element.Methods.ByTag = { }; Object.extend(Element, Element.Methods); if (!Prototype.BrowserFeatures.ElementExtensions && document.createElement('div').__proto__) { window.HTMLElement = { }; window.HTMLElement.prototype = document.createElement('div').__proto__; // Make it work with frames... //Prototype.BrowserFeatures.ElementExtensions = true; } Element.extend = (function() { if (Prototype.BrowserFeatures.SpecificElementExtensions) return Prototype.K; var Methods = { }, ByTag = Element.Methods.ByTag; var extend = Object.extend(function(element) { if (!element || element._extendedByPrototype || element.nodeType != 1 || element == window) return element; var methods = Object.clone(Methods), tagName = element.tagName, property, value; // extend methods for specific tags if (ByTag[tagName]) Object.extend(methods, ByTag[tagName]); for (property in methods) { value = methods[property]; if (Object.isFunction(value) && !(property in element)) element[property] = value.methodize(); } element._extendedByPrototype = Prototype.emptyFunction; return element; }, { refresh: function() { // extend methods for all tags (Safari doesn't need this) if (!Prototype.BrowserFeatures.ElementExtensions) { Object.extend(Methods, Element.Methods); Object.extend(Methods, Element.Methods.Simulated); } } }); extend.refresh(); return extend; })(); Element.hasAttribute = function(element, attribute) { if (element.hasAttribute) return element.hasAttribute(attribute); return Element.Methods.Simulated.hasAttribute(element, attribute); }; Element.addMethods = function(methods) { var F = Prototype.BrowserFeatures, T = Element.Methods.ByTag; if (!methods) { Object.extend(Form, Form.Methods); Object.extend(Form.Element, Form.Element.Methods); Object.extend(Element.Methods.ByTag, { "FORM": Object.clone(Form.Methods), "INPUT": Object.clone(Form.Element.Methods), "SELECT": Object.clone(Form.Element.Methods), "TEXTAREA": Object.clone(Form.Element.Methods) }); } if (arguments.length == 2) { var tagName = methods; methods = arguments[1]; } if (!tagName) Object.extend(Element.Methods, methods || { }); else { if (Object.isArray(tagName)) tagName.each(extend); else extend(tagName); } function extend(tagName) { tagName = tagName.toUpperCase(); if (!Element.Methods.ByTag[tagName]) Element.Methods.ByTag[tagName] = { }; Object.extend(Element.Methods.ByTag[tagName], methods); } function copy(methods, destination, onlyIfAbsent) { onlyIfAbsent = onlyIfAbsent || false; for (var property in methods) { var value = methods[property]; if (!Object.isFunction(value)) continue; if (!onlyIfAbsent || !(property in destination)) destination[property] = value.methodize(); } } function findDOMClass(tagName) { var klass; var trans = { "OPTGROUP": "OptGroup", "TEXTAREA": "TextArea", "P": "Paragraph", "FIELDSET": "FieldSet", "UL": "UList", "OL": "OList", "DL": "DList", "DIR": "Directory", "H1": "Heading", "H2": "Heading", "H3": "Heading", "H4": "Heading", "H5": "Heading", "H6": "Heading", "Q": "Quote", "INS": "Mod", "DEL": "Mod", "A": "Anchor", "IMG": "Image", "CAPTION": "TableCaption", "COL": "TableCol", "COLGROUP": "TableCol", "THEAD": "TableSection", "TFOOT": "TableSection", "TBODY": "TableSection", "TR": "TableRow", "TH": "TableCell", "TD": "TableCell", "FRAMESET": "FrameSet", "IFRAME": "IFrame" }; if (trans[tagName]) klass = 'HTML' + trans[tagName] + 'Element'; if (window[klass]) return window[klass]; klass = 'HTML' + tagName + 'Element'; if (window[klass]) return window[klass]; klass = 'HTML' + tagName.capitalize() + 'Element'; if (window[klass]) return window[klass]; window[klass] = { }; window[klass].prototype = document.createElement(tagName).__proto__; return window[klass]; } if (F.ElementExtensions) { copy(Element.Methods, HTMLElement.prototype); copy(Element.Methods.Simulated, HTMLElement.prototype, true); } if (F.SpecificElementExtensions) { for (var tag in Element.Methods.ByTag) { var klass = findDOMClass(tag); if (Object.isUndefined(klass)) continue; copy(T[tag], klass.prototype); } } Object.extend(Element, Element.Methods); delete Element.ByTag; if (Element.extend.refresh) Element.extend.refresh(); Element.cache = { }; }; document.viewport = { getDimensions: function() { var dimensions = { }; $w('width height').each(function(d) { var D = d.capitalize(); dimensions[d] = self['inner' + D] || (document.documentElement['client' + D] || document.body['client' + D]); }); return dimensions; }, getWidth: function() { return this.getDimensions().width; }, getHeight: function() { return this.getDimensions().height; }, getScrollOffsets: function() { return Element._returnOffset( window.pageXOffset || document.documentElement.scrollLeft || document.body.scrollLeft, window.pageYOffset || document.documentElement.scrollTop || document.body.scrollTop); } }; /* Portions of the Selector class are derived from Jack Slocum’s DomQuery, * part of YUI-Ext version 0.40, distributed under the terms of an MIT-style * license. Please see http://www.yui-ext.com/ for more information. */ var Selector = Class.create({ initialize: function(expression) { this.expression = expression.strip(); this.compileMatcher(); }, compileMatcher: function() { // Selectors with namespaced attributes can't use the XPath version if (Prototype.BrowserFeatures.XPath && !(/(\[[\w-]*?:|:checked)/).test(this.expression)) return this.compileXPathMatcher(); var e = this.expression, ps = Selector.patterns, h = Selector.handlers, c = Selector.criteria, le, p, m; if (Selector._cache[e]) { this.matcher = Selector._cache[e]; return; } this.matcher = ["this.matcher = function(root) {", "var r = root, h = Selector.handlers, c = false, n;"]; while (e && le != e && (/\S/).test(e)) { le = e; for (var i in ps) { p = ps[i]; if (m = e.match(p)) { this.matcher.push(Object.isFunction(c[i]) ? c[i](m) : new Template(c[i]).evaluate(m)); e = e.replace(m[0], ''); break; } } } this.matcher.push("return h.unique(n);\n}"); eval(this.matcher.join('\n')); Selector._cache[this.expression] = this.matcher; }, compileXPathMatcher: function() { var e = this.expression, ps = Selector.patterns, x = Selector.xpath, le, m; if (Selector._cache[e]) { this.xpath = Selector._cache[e]; return; } this.matcher = ['.//*']; while (e && le != e && (/\S/).test(e)) { le = e; for (var i in ps) { if (m = e.match(ps[i])) { this.matcher.push(Object.isFunction(x[i]) ? x[i](m) : new Template(x[i]).evaluate(m)); e = e.replace(m[0], ''); break; } } } this.xpath = this.matcher.join(''); Selector._cache[this.expression] = this.xpath; }, findElements: function(root) { root = root || document; if (this.xpath) return document._getElementsByXPath(this.xpath, root); return this.matcher(root); }, match: function(element) { this.tokens = []; var e = this.expression, ps = Selector.patterns, as = Selector.assertions; var le, p, m; while (e && le !== e && (/\S/).test(e)) { le = e; for (var i in ps) { p = ps[i]; if (m = e.match(p)) { // use the Selector.assertions methods unless the selector // is too complex. if (as[i]) { this.tokens.push([i, Object.clone(m)]); e = e.replace(m[0], ''); } else { // reluctantly do a document-wide search // and look for a match in the array return this.findElements(document).include(element); } } } } var match = true, name, matches; for (var i = 0, token; token = this.tokens[i]; i++) { name = token[0], matches = token[1]; if (!Selector.assertions[name](element, matches)) { match = false; break; } } return match; }, toString: function() { return this.expression; }, inspect: function() { return "#"; } }); Object.extend(Selector, { _cache: { }, xpath: { descendant: "//*", child: "/*", adjacent: "/following-sibling::*[1]", laterSibling: '/following-sibling::*', tagName: function(m) { if (m[1] == '*') return ''; return "[local-name()='" + m[1].toLowerCase() + "' or local-name()='" + m[1].toUpperCase() + "']"; }, className: "[contains(concat(' ', @class, ' '), ' #{1} ')]", id: "[@id='#{1}']", attrPresence: "[@#{1}]", attr: function(m) { m[3] = m[5] || m[6]; return new Template(Selector.xpath.operators[m[2]]).evaluate(m); }, pseudo: function(m) { var h = Selector.xpath.pseudos[m[1]]; if (!h) return ''; if (Object.isFunction(h)) return h(m); return new Template(Selector.xpath.pseudos[m[1]]).evaluate(m); }, operators: { '=': "[@#{1}='#{3}']", '!=': "[@#{1}!='#{3}']", '^=': "[starts-with(@#{1}, '#{3}')]", '$=': "[substring(@#{1}, (string-length(@#{1}) - string-length('#{3}') + 1))='#{3}']", '*=': "[contains(@#{1}, '#{3}')]", '~=': "[contains(concat(' ', @#{1}, ' '), ' #{3} ')]", '|=': "[contains(concat('-', @#{1}, '-'), '-#{3}-')]" }, pseudos: { 'first-child': '[not(preceding-sibling::*)]', 'last-child': '[not(following-sibling::*)]', 'only-child': '[not(preceding-sibling::* or following-sibling::*)]', 'empty': "[count(*) = 0 and (count(text()) = 0 or translate(text(), ' \t\r\n', '') = '')]", 'checked': "[@checked]", 'disabled': "[@disabled]", 'enabled': "[not(@disabled)]", 'not': function(m) { var e = m[6], p = Selector.patterns, x = Selector.xpath, le, m, v; var exclusion = []; while (e && le != e && (/\S/).test(e)) { le = e; for (var i in p) { if (m = e.match(p[i])) { v = Object.isFunction(x[i]) ? x[i](m) : new Template(x[i]).evaluate(m); exclusion.push("(" + v.substring(1, v.length - 1) + ")"); e = e.replace(m[0], ''); break; } } } return "[not(" + exclusion.join(" and ") + ")]"; }, 'nth-child': function(m) { return Selector.xpath.pseudos.nth("(count(./preceding-sibling::*) + 1) ", m); }, 'nth-last-child': function(m) { return Selector.xpath.pseudos.nth("(count(./following-sibling::*) + 1) ", m); }, 'nth-of-type': function(m) { return Selector.xpath.pseudos.nth("position() ", m); }, 'nth-last-of-type': function(m) { return Selector.xpath.pseudos.nth("(last() + 1 - position()) ", m); }, 'first-of-type': function(m) { m[6] = "1"; return Selector.xpath.pseudos['nth-of-type'](m); }, 'last-of-type': function(m) { m[6] = "1"; return Selector.xpath.pseudos['nth-last-of-type'](m); }, 'only-of-type': function(m) { var p = Selector.xpath.pseudos; return p['first-of-type'](m) + p['last-of-type'](m); }, nth: function(fragment, m) { var mm, formula = m[6], predicate; if (formula == 'even') formula = '2n+0'; if (formula == 'odd') formula = '2n+1'; if (mm = formula.match(/^(\d+)$/)) // digit only return '[' + fragment + "= " + mm[1] + ']'; if (mm = formula.match(/^(-?\d*)?n(([+-])(\d+))?/)) { // an+b if (mm[1] == "-") mm[1] = -1; var a = mm[1] ? Number(mm[1]) : 1; var b = mm[2] ? Number(mm[2]) : 0; predicate = "[((#{fragment} - #{b}) mod #{a} = 0) and " + "((#{fragment} - #{b}) div #{a} >= 0)]"; return new Template(predicate).evaluate({ fragment: fragment, a: a, b: b }); } } } }, criteria: { tagName: 'n = h.tagName(n, r, "#{1}", c); c = false;', className: 'n = h.className(n, r, "#{1}", c); c = false;', id: 'n = h.id(n, r, "#{1}", c); c = false;', attrPresence: 'n = h.attrPresence(n, r, "#{1}"); c = false;', attr: function(m) { m[3] = (m[5] || m[6]); return new Template('n = h.attr(n, r, "#{1}", "#{3}", "#{2}"); c = false;').evaluate(m); }, pseudo: function(m) { if (m[6]) m[6] = m[6].replace(/"/g, '\\"'); return new Template('n = h.pseudo(n, "#{1}", "#{6}", r, c); c = false;').evaluate(m); }, descendant: 'c = "descendant";', child: 'c = "child";', adjacent: 'c = "adjacent";', laterSibling: 'c = "laterSibling";' }, patterns: { // combinators must be listed first // (and descendant needs to be last combinator) laterSibling: /^\s*~\s*/, child: /^\s*>\s*/, adjacent: /^\s*\+\s*/, descendant: /^\s/, // selectors follow tagName: /^\s*(\*|[\w\-]+)(\b|$)?/, id: /^#([\w\-\*]+)(\b|$)/, className: /^\.([\w\-\*]+)(\b|$)/, pseudo: /^:((first|last|nth|nth-last|only)(-child|-of-type)|empty|checked|(en|dis)abled|not)(\((.*?)\))?(\b|$|(?=\s)|(?=:))/, attrPresence: /^\[([\w]+)\]/, attr: /\[((?:[\w-]*:)?[\w-]+)\s*(?:([!^$*~|]?=)\s*((['"])([^\4]*?)\4|([^'"][^\]]*?)))?\]/ }, // for Selector.match and Element#match assertions: { tagName: function(element, matches) { return matches[1].toUpperCase() == element.tagName.toUpperCase(); }, className: function(element, matches) { return Element.hasClassName(element, matches[1]); }, id: function(element, matches) { return element.id === matches[1]; }, attrPresence: function(element, matches) { return Element.hasAttribute(element, matches[1]); }, attr: function(element, matches) { var nodeValue = Element.readAttribute(element, matches[1]); return Selector.operators[matches[2]](nodeValue, matches[3]); } }, handlers: { // UTILITY FUNCTIONS // joins two collections concat: function(a, b) { for (var i = 0, node; node = b[i]; i++) a.push(node); return a; }, // marks an array of nodes for counting mark: function(nodes) { for (var i = 0, node; node = nodes[i]; i++) node._counted = true; return nodes; }, unmark: function(nodes) { for (var i = 0, node; node = nodes[i]; i++) node._counted = undefined; return nodes; }, // mark each child node with its position (for nth calls) // "ofType" flag indicates whether we're indexing for nth-of-type // rather than nth-child index: function(parentNode, reverse, ofType) { parentNode._counted = true; if (reverse) { for (var nodes = parentNode.childNodes, i = nodes.length - 1, j = 1; i >= 0; i--) { var node = nodes[i]; if (node.nodeType == 1 && (!ofType || node._counted)) node.nodeIndex = j++; } } else { for (var i = 0, j = 1, nodes = parentNode.childNodes; node = nodes[i]; i++) if (node.nodeType == 1 && (!ofType || node._counted)) node.nodeIndex = j++; } }, // filters out duplicates and extends all nodes unique: function(nodes) { if (nodes.length == 0) return nodes; var results = [], n; for (var i = 0, l = nodes.length; i < l; i++) if (!(n = nodes[i])._counted) { n._counted = true; results.push(Element.extend(n)); } return Selector.handlers.unmark(results); }, // COMBINATOR FUNCTIONS descendant: function(nodes) { var h = Selector.handlers; for (var i = 0, results = [], node; node = nodes[i]; i++) h.concat(results, node.getElementsByTagName('*')); return results; }, child: function(nodes) { var h = Selector.handlers; for (var i = 0, results = [], node; node = nodes[i]; i++) { for (var j = 0, children = [], child; child = node.childNodes[j]; j++) if (child.nodeType == 1 && child.tagName != '!') results.push(child); } return results; }, adjacent: function(nodes) { for (var i = 0, results = [], node; node = nodes[i]; i++) { var next = this.nextElementSibling(node); if (next) results.push(next); } return results; }, laterSibling: function(nodes) { var h = Selector.handlers; for (var i = 0, results = [], node; node = nodes[i]; i++) h.concat(results, Element.nextSiblings(node)); return results; }, nextElementSibling: function(node) { while (node = node.nextSibling) if (node.nodeType == 1) return node; return null; }, previousElementSibling: function(node) { while (node = node.previousSibling) if (node.nodeType == 1) return node; return null; }, // TOKEN FUNCTIONS tagName: function(nodes, root, tagName, combinator) { tagName = tagName.toUpperCase(); var results = [], h = Selector.handlers; if (nodes) { if (combinator) { // fastlane for ordinary descendant combinators if (combinator == "descendant") { for (var i = 0, node; node = nodes[i]; i++) h.concat(results, node.getElementsByTagName(tagName)); return results; } else nodes = this[combinator](nodes); if (tagName == "*") return nodes; } for (var i = 0, node; node = nodes[i]; i++) if (node.tagName.toUpperCase() == tagName) results.push(node); return results; } else return root.getElementsByTagName(tagName); }, id: function(nodes, root, id, combinator) { var targetNode = $(id), h = Selector.handlers; if (!targetNode) return []; if (!nodes && root == document) return [targetNode]; if (nodes) { if (combinator) { if (combinator == 'child') { for (var i = 0, node; node = nodes[i]; i++) if (targetNode.parentNode == node) return [targetNode]; } else if (combinator == 'descendant') { for (var i = 0, node; node = nodes[i]; i++) if (Element.descendantOf(targetNode, node)) return [targetNode]; } else if (combinator == 'adjacent') { for (var i = 0, node; node = nodes[i]; i++) if (Selector.handlers.previousElementSibling(targetNode) == node) return [targetNode]; } else nodes = h[combinator](nodes); } for (var i = 0, node; node = nodes[i]; i++) if (node == targetNode) return [targetNode]; return []; } return (targetNode && Element.descendantOf(targetNode, root)) ? [targetNode] : []; }, className: function(nodes, root, className, combinator) { if (nodes && combinator) nodes = this[combinator](nodes); return Selector.handlers.byClassName(nodes, root, className); }, byClassName: function(nodes, root, className) { if (!nodes) nodes = Selector.handlers.descendant([root]); var needle = ' ' + className + ' '; for (var i = 0, results = [], node, nodeClassName; node = nodes[i]; i++) { nodeClassName = node.className; if (nodeClassName.length == 0) continue; if (nodeClassName == className || (' ' + nodeClassName + ' ').include(needle)) results.push(node); } return results; }, attrPresence: function(nodes, root, attr) { if (!nodes) nodes = root.getElementsByTagName("*"); var results = []; for (var i = 0, node; node = nodes[i]; i++) if (Element.hasAttribute(node, attr)) results.push(node); return results; }, attr: function(nodes, root, attr, value, operator) { if (!nodes) nodes = root.getElementsByTagName("*"); var handler = Selector.operators[operator], results = []; for (var i = 0, node; node = nodes[i]; i++) { var nodeValue = Element.readAttribute(node, attr); if (nodeValue === null) continue; if (handler(nodeValue, value)) results.push(node); } return results; }, pseudo: function(nodes, name, value, root, combinator) { if (nodes && combinator) nodes = this[combinator](nodes); if (!nodes) nodes = root.getElementsByTagName("*"); return Selector.pseudos[name](nodes, value, root); } }, pseudos: { 'first-child': function(nodes, value, root) { for (var i = 0, results = [], node; node = nodes[i]; i++) { if (Selector.handlers.previousElementSibling(node)) continue; results.push(node); } return results; }, 'last-child': function(nodes, value, root) { for (var i = 0, results = [], node; node = nodes[i]; i++) { if (Selector.handlers.nextElementSibling(node)) continue; results.push(node); } return results; }, 'only-child': function(nodes, value, root) { var h = Selector.handlers; for (var i = 0, results = [], node; node = nodes[i]; i++) if (!h.previousElementSibling(node) && !h.nextElementSibling(node)) results.push(node); return results; }, 'nth-child': function(nodes, formula, root) { return Selector.pseudos.nth(nodes, formula, root); }, 'nth-last-child': function(nodes, formula, root) { return Selector.pseudos.nth(nodes, formula, root, true); }, 'nth-of-type': function(nodes, formula, root) { return Selector.pseudos.nth(nodes, formula, root, false, true); }, 'nth-last-of-type': function(nodes, formula, root) { return Selector.pseudos.nth(nodes, formula, root, true, true); }, 'first-of-type': function(nodes, formula, root) { return Selector.pseudos.nth(nodes, "1", root, false, true); }, 'last-of-type': function(nodes, formula, root) { return Selector.pseudos.nth(nodes, "1", root, true, true); }, 'only-of-type': function(nodes, formula, root) { var p = Selector.pseudos; return p['last-of-type'](p['first-of-type'](nodes, formula, root), formula, root); }, // handles the an+b logic getIndices: function(a, b, total) { if (a == 0) return b > 0 ? [b] : []; return $R(1, total).inject([], function(memo, i) { if (0 == (i - b) % a && (i - b) / a >= 0) memo.push(i); return memo; }); }, // handles nth(-last)-child, nth(-last)-of-type, and (first|last)-of-type nth: function(nodes, formula, root, reverse, ofType) { if (nodes.length == 0) return []; if (formula == 'even') formula = '2n+0'; if (formula == 'odd') formula = '2n+1'; var h = Selector.handlers, results = [], indexed = [], m; h.mark(nodes); for (var i = 0, node; node = nodes[i]; i++) { if (!node.parentNode._counted) { h.index(node.parentNode, reverse, ofType); indexed.push(node.parentNode); } } if (formula.match(/^\d+$/)) { // just a number formula = Number(formula); for (var i = 0, node; node = nodes[i]; i++) if (node.nodeIndex == formula) results.push(node); } else if (m = formula.match(/^(-?\d*)?n(([+-])(\d+))?/)) { // an+b if (m[1] == "-") m[1] = -1; var a = m[1] ? Number(m[1]) : 1; var b = m[2] ? Number(m[2]) : 0; var indices = Selector.pseudos.getIndices(a, b, nodes.length); for (var i = 0, node, l = indices.length; node = nodes[i]; i++) { for (var j = 0; j < l; j++) if (node.nodeIndex == indices[j]) results.push(node); } } h.unmark(nodes); h.unmark(indexed); return results; }, 'empty': function(nodes, value, root) { for (var i = 0, results = [], node; node = nodes[i]; i++) { // IE treats comments as element nodes if (node.tagName == '!' || (node.firstChild && !node.innerHTML.match(/^\s*$/))) continue; results.push(node); } return results; }, 'not': function(nodes, selector, root) { var h = Selector.handlers, selectorType, m; var exclusions = new Selector(selector).findElements(root); h.mark(exclusions); for (var i = 0, results = [], node; node = nodes[i]; i++) if (!node._counted) results.push(node); h.unmark(exclusions); return results; }, 'enabled': function(nodes, value, root) { for (var i = 0, results = [], node; node = nodes[i]; i++) if (!node.disabled) results.push(node); return results; }, 'disabled': function(nodes, value, root) { for (var i = 0, results = [], node; node = nodes[i]; i++) if (node.disabled) results.push(node); return results; }, 'checked': function(nodes, value, root) { for (var i = 0, results = [], node; node = nodes[i]; i++) if (node.checked) results.push(node); return results; } }, operators: { '=': function(nv, v) { return nv == v; }, '!=': function(nv, v) { return nv != v; }, '^=': function(nv, v) { return nv.startsWith(v); }, '$=': function(nv, v) { return nv.endsWith(v); }, '*=': function(nv, v) { return nv.include(v); }, '~=': function(nv, v) { return (' ' + nv + ' ').include(' ' + v + ' '); }, '|=': function(nv, v) { return ('-' + nv.toUpperCase() + '-').include('-' + v.toUpperCase() + '-'); } }, matchElements: function(elements, expression) { var matches = new Selector(expression).findElements(), h = Selector.handlers; h.mark(matches); for (var i = 0, results = [], element; element = elements[i]; i++) if (element._counted) results.push(element); h.unmark(matches); return results; }, findElement: function(elements, expression, index) { if (Object.isNumber(expression)) { index = expression; expression = false; } return Selector.matchElements(elements, expression || '*')[index || 0]; }, findChildElements: function(element, expressions) { var exprs = expressions.join(','), expressions = []; exprs.scan(/(([\w#:.~>+()\s-]+|\*|\[.*?\])+)\s*(,|$)/, function(m) { expressions.push(m[1].strip()); }); var results = [], h = Selector.handlers; for (var i = 0, l = expressions.length, selector; i < l; i++) { selector = new Selector(expressions[i].strip()); h.concat(results, selector.findElements(element)); } return (l > 1) ? h.unique(results) : results; } }); function $$() { return Selector.findChildElements(document, $A(arguments)); } var Form = { reset: function(form) { $(form).reset(); return form; }, serializeElements: function(elements, options) { if (typeof options != 'object') options = { hash: !!options }; else if (options.hash === undefined) options.hash = true; var key, value, submitted = false, submit = options.submit; var data = elements.inject({ }, function(result, element) { if (!element.disabled && element.name) { key = element.name; value = $(element).getValue(); if (value != null && (element.type != 'submit' || (!submitted && submit !== false && (!submit || key == submit) && (submitted = true)))) { if (key in result) { // a key is already present; construct an array of values if (!Object.isArray(result[key])) result[key] = [result[key]]; result[key].push(value); } else result[key] = value; } } return result; }); return options.hash ? data : Object.toQueryString(data); } }; Form.Methods = { serialize: function(form, options) { return Form.serializeElements(Form.getElements(form), options); }, getElements: function(form) { return $A($(form).getElementsByTagName('*')).inject([], function(elements, child) { if (Form.Element.Serializers[child.tagName.toLowerCase()]) elements.push(Element.extend(child)); return elements; } ); }, getInputs: function(form, typeName, name) { form = $(form); var inputs = form.getElementsByTagName('input'); if (!typeName && !name) return $A(inputs).map(Element.extend); for (var i = 0, matchingInputs = [], length = inputs.length; i < length; i++) { var input = inputs[i]; if ((typeName && input.type != typeName) || (name && input.name != name)) continue; matchingInputs.push(Element.extend(input)); } return matchingInputs; }, disable: function(form) { form = $(form); Form.getElements(form).invoke('disable'); return form; }, enable: function(form) { form = $(form); Form.getElements(form).invoke('enable'); return form; }, findFirstElement: function(form) { var elements = $(form).getElements().findAll(function(element) { return 'hidden' != element.type && !element.disabled; }); var firstByIndex = elements.findAll(function(element) { return element.hasAttribute('tabIndex') && element.tabIndex >= 0; }).sortBy(function(element) { return element.tabIndex }).first(); return firstByIndex ? firstByIndex : elements.find(function(element) { return ['input', 'select', 'textarea'].include(element.tagName.toLowerCase()); }); }, focusFirstElement: function(form) { form = $(form); form.findFirstElement().activate(); return form; }, request: function(form, options) { form = $(form), options = Object.clone(options || { }); var params = options.parameters, action = form.readAttribute('action') || ''; if (action.blank()) action = window.location.href; options.parameters = form.serialize(true); if (params) { if (Object.isString(params)) params = params.toQueryParams(); Object.extend(options.parameters, params); } if (form.hasAttribute('method') && !options.method) options.method = form.method; return new Ajax.Request(action, options); } }; /*--------------------------------------------------------------------------*/ Form.Element = { focus: function(element) { $(element).focus(); return element; }, select: function(element) { $(element).select(); return element; } }; Form.Element.Methods = { serialize: function(element) { element = $(element); if (!element.disabled && element.name) { var value = element.getValue(); if (value != undefined) { var pair = { }; pair[element.name] = value; return Object.toQueryString(pair); } } return ''; }, getValue: function(element) { element = $(element); var method = element.tagName.toLowerCase(); return Form.Element.Serializers[method](element); }, setValue: function(element, value) { element = $(element); var method = element.tagName.toLowerCase(); Form.Element.Serializers[method](element, value); return element; }, clear: function(element) { $(element).value = ''; return element; }, present: function(element) { return $(element).value != ''; }, activate: function(element) { element = $(element); try { element.focus(); if (element.select && (element.tagName.toLowerCase() != 'input' || !['button', 'reset', 'submit'].include(element.type))) element.select(); } catch (e) { } return element; }, disable: function(element) { element = $(element); element.blur(); element.disabled = true; return element; }, enable: function(element) { element = $(element); element.disabled = false; return element; } }; /*--------------------------------------------------------------------------*/ var Field = Form.Element; var $F = Form.Element.Methods.getValue; /*--------------------------------------------------------------------------*/ Form.Element.Serializers = { input: function(element, value) { switch (element.type.toLowerCase()) { case 'checkbox': case 'radio': return Form.Element.Serializers.inputSelector(element, value); default: return Form.Element.Serializers.textarea(element, value); } }, inputSelector: function(element, value) { if (value === undefined) return element.checked ? element.value : null; else element.checked = !!value; }, textarea: function(element, value) { if (value === undefined) return element.value; else element.value = value; }, select: function(element, index) { if (index === undefined) return this[element.type == 'select-one' ? 'selectOne' : 'selectMany'](element); else { var opt, value, single = !Object.isArray(index); for (var i = 0, length = element.length; i < length; i++) { opt = element.options[i]; value = this.optionValue(opt); if (single) { if (value == index) { opt.selected = true; return; } } else opt.selected = index.include(value); } } }, selectOne: function(element) { var index = element.selectedIndex; return index >= 0 ? this.optionValue(element.options[index]) : null; }, selectMany: function(element) { var values, length = element.length; if (!length) return null; for (var i = 0, values = []; i < length; i++) { var opt = element.options[i]; if (opt.selected) values.push(this.optionValue(opt)); } return values; }, optionValue: function(opt) { // extend element because hasAttribute may not be native return Element.extend(opt).hasAttribute('value') ? opt.value : opt.text; } }; /*--------------------------------------------------------------------------*/ Abstract.TimedObserver = Class.create(PeriodicalExecuter, { initialize: function($super, element, frequency, callback) { $super(callback, frequency); this.element = $(element); this.lastValue = this.getValue(); }, execute: function() { var value = this.getValue(); if (Object.isString(this.lastValue) && Object.isString(value) ? this.lastValue != value : String(this.lastValue) != String(value)) { this.callback(this.element, value); this.lastValue = value; } } }); Form.Element.Observer = Class.create(Abstract.TimedObserver, { getValue: function() { return Form.Element.getValue(this.element); } }); Form.Observer = Class.create(Abstract.TimedObserver, { getValue: function() { return Form.serialize(this.element); } }); /*--------------------------------------------------------------------------*/ Abstract.EventObserver = Class.create({ initialize: function(element, callback) { this.element = $(element); this.callback = callback; this.lastValue = this.getValue(); if (this.element.tagName.toLowerCase() == 'form') this.registerFormCallbacks(); else this.registerCallback(this.element); }, onElementEvent: function() { var value = this.getValue(); if (this.lastValue != value) { this.callback(this.element, value); this.lastValue = value; } }, registerFormCallbacks: function() { Form.getElements(this.element).each(this.registerCallback, this); }, registerCallback: function(element) { if (element.type) { switch (element.type.toLowerCase()) { case 'checkbox': case 'radio': Event.observe(element, 'click', this.onElementEvent.bind(this)); break; default: Event.observe(element, 'change', this.onElementEvent.bind(this)); break; } } } }); Form.Element.EventObserver = Class.create(Abstract.EventObserver, { getValue: function() { return Form.Element.getValue(this.element); } }); Form.EventObserver = Class.create(Abstract.EventObserver, { getValue: function() { return Form.serialize(this.element); } }); if (!window.Event) var Event = { }; Object.extend(Event, { KEY_BACKSPACE: 8, KEY_TAB: 9, KEY_RETURN: 13, KEY_ESC: 27, KEY_LEFT: 37, KEY_UP: 38, KEY_RIGHT: 39, KEY_DOWN: 40, KEY_DELETE: 46, KEY_HOME: 36, KEY_END: 35, KEY_PAGEUP: 33, KEY_PAGEDOWN: 34, KEY_INSERT: 45, cache: { }, relatedTarget: function(event) { var element; switch(event.type) { case 'mouseover': element = event.fromElement; break; case 'mouseout': element = event.toElement; break; default: return null; } return Element.extend(element); } }); Event.Methods = (function() { var isButton; if (Prototype.Browser.IE) { var buttonMap = { 0: 1, 1: 4, 2: 2 }; isButton = function(event, code) { return event.button == buttonMap[code]; }; } else if (Prototype.Browser.WebKit) { isButton = function(event, code) { switch (code) { case 0: return event.which == 1 && !event.metaKey; case 1: return event.which == 1 && event.metaKey; default: return false; } }; } else { isButton = function(event, code) { return event.which ? (event.which === code + 1) : (event.button === code); }; } return { isLeftClick: function(event) { return isButton(event, 0) }, isMiddleClick: function(event) { return isButton(event, 1) }, isRightClick: function(event) { return isButton(event, 2) }, element: function(event) { var node = Event.extend(event).target; return Element.extend(node.nodeType == Node.TEXT_NODE ? node.parentNode : node); }, findElement: function(event, expression) { var element = Event.element(event); return element.match(expression) ? element : element.up(expression); }, pointer: function(event) { return { x: event.pageX || (event.clientX + (document.documentElement.scrollLeft || document.body.scrollLeft)), y: event.pageY || (event.clientY + (document.documentElement.scrollTop || document.body.scrollTop)) }; }, pointerX: function(event) { return Event.pointer(event).x }, pointerY: function(event) { return Event.pointer(event).y }, stop: function(event) { Event.extend(event); event.preventDefault(); event.stopPropagation(); event.stopped = true; } }; })(); Event.extend = (function() { var methods = Object.keys(Event.Methods).inject({ }, function(m, name) { m[name] = Event.Methods[name].methodize(); return m; }); if (Prototype.Browser.IE) { Object.extend(methods, { stopPropagation: function() { this.cancelBubble = true }, preventDefault: function() { this.returnValue = false }, inspect: function() { return "[object Event]" } }); return function(event) { if (!event) return false; if (event._extendedByPrototype) return event; event._extendedByPrototype = Prototype.emptyFunction; var pointer = Event.pointer(event); Object.extend(event, { target: event.srcElement, relatedTarget: Event.relatedTarget(event), pageX: pointer.x, pageY: pointer.y }); return Object.extend(event, methods); }; } else { Event.prototype = Event.prototype || document.createEvent("HTMLEvents").__proto__; Object.extend(Event.prototype, methods); return Prototype.K; } })(); Object.extend(Event, (function() { var cache = Event.cache; function getEventID(element) { if (element._eventID) return element._eventID; arguments.callee.id = arguments.callee.id || 1; return element._eventID = ++arguments.callee.id; } function getDOMEventName(eventName) { if (eventName && eventName.include(':')) return "dataavailable"; return eventName; } function getCacheForID(id) { return cache[id] = cache[id] || { }; } function getWrappersForEventName(id, eventName) { var c = getCacheForID(id); return c[eventName] = c[eventName] || []; } function createWrapper(element, eventName, handler) { var id = getEventID(element); var c = getWrappersForEventName(id, eventName); if (c.pluck("handler").include(handler)) return false; var wrapper = function(event) { if (!Event || !Event.extend || (event.eventName && event.eventName != eventName)) return false; Event.extend(event); handler.call(element, event) }; wrapper.handler = handler; c.push(wrapper); return wrapper; } function findWrapper(id, eventName, handler) { var c = getWrappersForEventName(id, eventName); return c.find(function(wrapper) { return wrapper.handler == handler }); } function destroyWrapper(id, eventName, handler) { var c = getCacheForID(id); if (!c[eventName]) return false; c[eventName] = c[eventName].without(findWrapper(id, eventName, handler)); } function destroyCache() { for (var id in cache) for (var eventName in cache[id]) cache[id][eventName] = null; } if (window.attachEvent) { window.attachEvent("onunload", destroyCache); } return { observe: function(element, eventName, handler) { element = $(element); var name = getDOMEventName(eventName); var wrapper = createWrapper(element, eventName, handler); if (!wrapper) return element; if (element.addEventListener) { element.addEventListener(name, wrapper, false); } else { element.attachEvent("on" + name, wrapper); } return element; }, stopObserving: function(element, eventName, handler) { element = $(element); var id = getEventID(element), name = getDOMEventName(eventName); if (!handler && eventName) { getWrappersForEventName(id, eventName).each(function(wrapper) { element.stopObserving(eventName, wrapper.handler); }); return element; } else if (!eventName) { Object.keys(getCacheForID(id)).each(function(eventName) { element.stopObserving(eventName); }); return element; } var wrapper = findWrapper(id, eventName, handler); if (!wrapper) return element; if (element.removeEventListener) { element.removeEventListener(name, wrapper, false); } else { element.detachEvent("on" + name, wrapper); } destroyWrapper(id, eventName, handler); return element; }, fire: function(element, eventName, memo) { element = $(element); if (element == document && document.createEvent && !element.dispatchEvent) element = document.documentElement; if (document.createEvent) { var event = document.createEvent("HTMLEvents"); event.initEvent("dataavailable", true, true); } else { var event = document.createEventObject(); event.eventType = "ondataavailable"; } event.eventName = eventName; event.memo = memo || { }; if (document.createEvent) { element.dispatchEvent(event); } else { element.fireEvent(event.eventType, event); } return event; } }; })()); Object.extend(Event, Event.Methods); Element.addMethods({ fire: Event.fire, observe: Event.observe, stopObserving: Event.stopObserving }); Object.extend(document, { fire: Element.Methods.fire.methodize(), observe: Element.Methods.observe.methodize(), stopObserving: Element.Methods.stopObserving.methodize() }); (function() { /* Support for the DOMContentLoaded event is based on work by Dan Webb, Matthias Miller, Dean Edwards and John Resig. */ var timer, fired = false; function fireContentLoadedEvent() { if (fired) return; if (timer) window.clearInterval(timer); document.fire("dom:loaded"); fired = true; } if (document.addEventListener) { if (Prototype.Browser.WebKit) { timer = window.setInterval(function() { if (/loaded|complete/.test(document.readyState)) fireContentLoadedEvent(); }, 0); Event.observe(window, "load", fireContentLoadedEvent); } else { document.addEventListener("DOMContentLoaded", fireContentLoadedEvent, false); } } else { document.write("

    Embperl Example - Input Form Validation

    This example simply validates the form input when you hit submit. If your input is correct, the form is redisplay with your input, otherwise the error message is shown. If you turn off JavaScript the validation is still done one the server-side. Any validation for which no JavaScript validation is defined (like regex matches), only the server-side validation is performed.
    [$if @$errors $]

    Please correct the following errors

    [$foreach $e (@$errors)$] [+ $e +]
    [$endforeach$] [$else$]

    Please enter your data

    [$endif$]
    Name
    Id (1-9)
    E-Mail
    Message

    Embperl (c) 1997-2005 G.Richter / ecos gmbh www.ecos.de Embperl-2.5.0/eg/x/PaxHeaders.14966/while.htm0000644000000000000000000000005012023276646016605 xustar000000000000000020 atime=1397535905 20 ctime=1397643307 Embperl-2.5.0/eg/x/while.htm0000644000076400000000000000104612023276646016275 0ustar00richterroot00000000000000 While Metacommand in Embperl This is a example of using the while metacommand in embperl to show the environment

    [- $i = 0; @k = keys %ENV -] [$ while ($i < $#k) $] [+ $k[$i] +] = [+ $ENV{$k[$i]} +]
    [- $i++ -] [$ endwhile $]

    This is a example of using the while metacommand in embperl to show the loaded modules

    [- $i = 0; @k = keys %INC -] [$ while ($i < $#k) $] [+ $k[$i] +] = [+ $INC{$k[$i]} +]
    [- $i++ -] [$ endwhile $] Embperl-2.5.0/eg/x/PaxHeaders.14966/recordset.htm0000644000000000000000000000005012023276646017467 xustar000000000000000020 atime=1397535905 20 ctime=1397643307 Embperl-2.5.0/eg/x/recordset.htm0000755000076400000000000000227712023276646017171 0ustar00richterroot00000000000000 Embperl Examples - DBIx::Recordset

    Embperl Examples - DBIx::Recordset

    NOTE:
    You must set the database and table to something which exists on your system. Also this example presumes that the table contains the fields id and name. If not you have to change the field-names in the table below
    Maybe it's necessary to insert a PerlModule DBIx::Recordset into your srm.conf to get this working

    You may specify search parameters: For example request this document with
    recordset.htm?id=5
    to get all records where the id = 5
    [- $DSN = 'dbi:mysql:test' ; $table = 'dbixrs1' ; use DBIx::Recordset ; *set = DBIx::Recordset -> Search ({%fdat, ('!DataSource' => $DSN, '!Table' => $table, '$max' => 5,)}) ; -]
    IDNAME
    [+ $set[$row]{id} +] [+ $set[$row]{name} +]
    [+ $set -> PrevNextForm ('Previous Records', 'Next Records', \%fdat) +]

    HTML::Embperl (c) 1997-1998 G.Richter Embperl-2.5.0/eg/x/PaxHeaders.14966/config.htm0000644000000000000000000000005012023276646016742 xustar000000000000000020 atime=1397535905 20 ctime=1397643307 Embperl-2.5.0/eg/x/config.htm0000644000076400000000000000037512023276646016436 0ustar00richterroot00000000000000 Perl config (like perl -V) [- use Config qw (myconfig) ; -] [- $c = myconfig () -] [- $c =~ s/\n/\\\/g -] [+ $c +] Embperl-2.5.0/eg/x/PaxHeaders.14966/Execute.pl0000644000000000000000000000005012023276646016722 xustar000000000000000020 atime=1397535905 20 ctime=1397643307 Embperl-2.5.0/eg/x/Execute.pl0000644000076400000000000000632712023276646016421 0ustar00richterroot00000000000000# # Example for using HTML::Embperl::Execute # # run this under mod_perl / Apache::Registry # or standalone # use HTML::Embperl ; my($r) = @_; $HTML::Embperl::DebugDefault = 811005 ; $tst1 = '

    Here is some text

    ' ; $r -> status (200) ; $r -> send_http_header () ; print "Test for HTML::Embperl::Execute\n" ; print "

    1.) Include from memory

    \n" ; HTML::Embperl::Execute ({input => \$tst1, mtime => 1, inputfile => 'Some text', req_rec => $r}) ; print "

    2.) Include from memory with some Embperl code

    \n" ; HTML::Embperl::Execute ({input => \'[- @ar = (a1, b2, c3) -]
    [+$ar[$col]+]

    ', mtime => 1, inputfile => 'table', req_rec => $r}) ; print "

    3.) Include from memory with passing of variables

    \n" ; $MyPackage::Interface::Var = 'Some Var' ; HTML::Embperl::Execute ({input => \'

    Transfer some vars [+ $Var +] !

    ', inputfile => 'Var', mtime => 1, 'package' => 'MyPackage::Interface', req_rec => $r}) ; print "

    4.) Change the variable, but not the code

    \n" ; $MyPackage::Interface::Var = 'Do it again' ; # code is the same, so give the same mtime and inputfile to avoid recompile # Note you get problems is you change the code, but did not restart the server or # change the value in mtime. So make sure if you change something also change mtime! HTML::Embperl::Execute ({input => \'

    Transfer some vars [+ $Var +] !

    ', inputfile => 'Var2', mtime => 1, 'package' => 'MyPackage::Interface', req_rec => $r}) ; print "

    5.) Use \@param to pass parameters

    \n" ; HTML::Embperl::Execute ({input => \'

    Use \@param to transfer some data ([+ " @param " +]) !

    ', inputfile => 'Param', req_rec => $r, param => [1, 2, 3, 4] } ) ; print "

    6.) Use \@param to pass parameters and return it

    \n" ; my @p = ('vara', 'varb') ; print "

    \$p[0] is $p[0] and \$p[1] is $p[1]

    " ; HTML::Embperl::Execute ({input => \'

    Got data in @param ([+ "@param" +]) !

    [- $param[0] = "newA" ; $param[1] = "newB" ; -]

    Change data in @param to ([+ "@param" +]) !

    ', inputfile => 'Param & Return', req_rec => $r, param => \@p } ) ; print "

    \$p[0] is now $p[0] and \$p[1] is now $p[1]

    " ; print "

    7.) Presetup \%fdat and \@ffld

    \n" ; my %myfdat = ('test' => 'value', 'fdat' => 'text') ; my @myffld = sort keys %myfdat ; HTML::Embperl::Execute ({input => \'

    [+ $k = $ffld[$row] +][+ $fdat{$k} +]

    ', inputfile => 'fdat & ffld', req_rec => $r, fdat => \%myfdat, ffld => \@myffld} ) ; print "

    8.) Inculde a file

    \n" ; HTML::Embperl::Execute ({inputfile => '../inc.htm', req_rec => $r}) ; print "

    9.) Inculde a file and return output in a scalar

    \n" ; my $out ; HTML::Embperl::Execute ({inputfile => '../inc.htm', output => \$out, req_rec => $r}) ; print "

    $out

    \n" ; print "

    10.) Done :-)

    \n" ; print "\n"; Embperl-2.5.0/eg/x/PaxHeaders.14966/neu.htm0000644000000000000000000000005012023276646016264 xustar000000000000000020 atime=1397535905 20 ctime=1397643307 Embperl-2.5.0/eg/x/neu.htm0000644000076400000000000003017412023276646015760 0ustar00richterroot00000000000000 Example for creating a wizard with Embperl

    [- $escmode = 7 -][- $b = defined($fdat{back})-][- $c = defined($fdat{cont})-][-$kn = $fdat{Kundennummer} eq 'Ja'-][-$p = $fdat{page}
    -][$if $p==0 or ($p==2 and $b) or ($p==4 and $b and !$kn)$]

    Eintragen eines neuen Objekts

    Um eine neues Objekt welches Sie anbieten, mieten oder kaufen möchten einzutragen benötigen wir zuerst Ihre persönlichen Daten.

    Haben Sie bereits eine Kundennummer bei uns?

    Ja, ich habe bereits eine Kundennummer
    Nein, ich habe keine Kundennummer

    [$hidden$]

     

     [$elsif $kn and (($p==1 and $c) or ($p==3 and $b))$]

    Geben Sie bitte Ihre Kundennummer ein, wenn Sie diese nicht zur Hand haben können Sie auch nach Ihrere Kundennummer suchen, indem Sie die Felder Name und/oder Firma ausfüllen.

     

    Kundennummer:

    Name:

    Firma:

    [$hidden$]

     

     

     [$elsif $kn and (($p==2 and $c) or ($p==5 and $b))$]

     

    Es wurden mehere Personen gefunden die auf Ihrer Angaben zutreffen. Bitte wählen Sie die richtige aus.
    [- $AdrData[0]{Kdnr} = 123; $AdrData[0]{Name} = 'Mr. X'; $AdrData[0]{Ort} = 'Somewhere'; $AdrData[1]{Kdnr} = 234; $AdrData[1]{Name} = 'Mr. Y'; $AdrData[1]{Ort} = 'Anywhere'; $AdrData[2]{Kdnr} = 345; $AdrData[2]{Name} = 'Note: Database query is missing'; $AdrData[2]{Ort} = ''; $AdrData[3]{Kdnr} = 456; $AdrData[3]{Name} = 'This are only '; $AdrData[3]{Ort} = 'dummys'; -]
    [+$AdrData[$row]{Name}+] [+$AdrData[$row]{Ort} +]

    [$hidden$]

     

     

     [$elsif !$kn and
    (($p==1 and $c) or
    ($p==5 and $b))$]

    Geben Sie bitte hier persönnlichen Daten ein.
    Firma:

     
    Anrede:

     
    Name:

    Vorname:

    Straße:

    Postfach:

    Plz:

    Ort:

    Telefon:

    Telefax:

    E-Mail:

    WWW Adresse:

    [$hidden$]

     

    [$elsif ($p==4 && $c) || ($p==3 && $c)$]

    Wenn Sie jetzt auf Abspeichern klicken, werden folgende Daten von Ihnen gespeichert:
    Firma: [+$fdat{Firma}+]

     
    Anrede: [+$fdat{Anrede}+]

     
    Name: [+$fdat{Name}+]

    Vorname:

    		[+$fdat{Vorname}+]
    Straße: [+$fdat{Strasse}+]

    Postfach:

    		[+$fdat{Postfach}+]
    Plz: [+$fdat{Plz}+]

    Ort:

    		[+$fdat{Ort}+]
    Telefon: [+$fdat{Telefon}+]

    Telefax:

    		[+$fdat{Telefax}+]
    E-Mail: [+$fdat{EMail}+]

    WWW Adresse:

    		 [+$fdat{WWW}+]

    [$hidden$]

     

    [$endif$] 

     

     

    Embperl-2.5.0/eg/x/PaxHeaders.14966/dbi2.htm0000644000000000000000000000005012023276646016315 xustar000000000000000020 atime=1397535905 20 ctime=1397643307 Embperl-2.5.0/eg/x/dbi2.htm0000755000076400000000000000215612023276646016013 0ustar00richterroot00000000000000 Embperl Examples - DBI access using Loops

    Embperl Examples - DBI access using Loops

    NOTE:
    You must set the database and table to something which exists on your system
    Maybe it's necessary to insert a PerlModule DBI into your srm.conf to get this working
    [- $DSN = 'dbi:mysql:test' ; $table = 'dbixrs1' ; use DBI ; # connect to database $dbh = DBI->connect($DSN) or die "Cannot connect to '$DSN'" ; # prepare the sql select $sth = $dbh -> prepare ("SELECT * from $table") or die "Cannot SELECT from '$table'" ; # excute the query $sth -> execute or die "Cannot execute SELECT from '$table'"; # get the fieldnames for the heading in $head $head = $sth -> {NAME} ; -] [$ foreach $h @$head $] [$ endforeach $] [$ while $dat = $sth -> fetchrow_arrayref $] [$ foreach $v @$dat $] [$ endforeach $] [$ endwhile $]
    [+ $h +]
    [+ $v +]

    HTML::Embperl (c) 1997-1998 G.Richter Embperl-2.5.0/eg/x/PaxHeaders.14966/loop.htm0000644000000000000000000000005012023276646016446 xustar000000000000000020 atime=1397535905 20 ctime=1397643307 Embperl-2.5.0/eg/x/loop.htm0000755000076400000000000000234012023276646016137 0ustar00richterroot00000000000000 Embperl Examples - Loop Metacommands

    Embperl Examples - Loop Metacommands

    This is a example of using the while metacommand in embperl to show the environment

    [$ while ($k, $v) = each (%ENV) $] [+ $k +] = [+ $v +]
    [$ endwhile $]

    This is a example of using the while metacommand to show the loaded modules, with using an index

    [- $i = 0; @k = keys %INC -] [$ while ($i < $#k) $] [+ $k[$i] +] = [+ $INC{$k[$i]} +]
    [- $i++ -] [$ endwhile $]

    This is a example of using the do .. until metacommand to show the array @arr = (3,5,7)

    [- @arr = (3, 5, 7); $i = 0 -] [$ do $] [+ $arr[ $i++ ] +] [$ until $i > $#arr $]

    This is a example of using the foreach metacommand to show the list (1..10)

    [$ foreach $v (1..10) $] [+ $v +] [$ endforeach $] [$ if $ENV{MOD_PERL} $]

    This is a example of using the while metacommand in embperl to show the http headers send from the browser

    [- %hdr = $req_rec -> headers_in ; -] [$ while ($k, $v) = each (%hdr) $] [+ $k +] = [+ $v +]
    [$ endwhile $] [$endif$]

    HTML::Embperl (c) 1997-1998 G.Richter Embperl-2.5.0/PaxHeaders.14966/TipsAndTricks.pod0000644000000000000000000000005012023276646017347 xustar000000000000000020 atime=1397643245 20 ctime=1397643307 Embperl-2.5.0/TipsAndTricks.pod0000644000076400000000000003550012023276646017041 0ustar00richterroot00000000000000=pod =head1 NAME Embperl::TipsAndTricks - Embperl Tips and Tricks =head1 Contents =over 4 =item Tips and Tricks =item Alternative Way To Do Global Variables, using __PACKAGE__ =item Global Variables Via Namespaces =item Handling Queries in DBI =item Handling Exits =item Handling Errors =item Development and Production Websites =back =head1 NAME Embperl::TipsAndTricks - Embperl Tips and Tricks =head1 Tips and Tricks This document follows on from the Embperl/EmbperlObject introductory tutorial. As you can see from that, Embperl/EmbperlObject enables extremely powerful websites to be built using a very intuitive object-oriented structure. Now, we'll look at some additional, "unofficial" techniques which may also be useful in certain circumstances. This is a small collection of personal tricks which I have developed over the course of months using EmbperlObject in my own websites. I hope they are useful, or at least spur you on to develop your own frameworks and share these with others. If you have any Tips & Tricks you want to share with the public please send them to richter at embperl dot org . =head1 Alternative Way To Do Global Variables, using __PACKAGE__ In the process of developing a large website I have found it can be a little onerous at times to use the Request object to pass around global data. I would like to just create variables like $xxx rather than typing $req->{xxx} all the time. It may not seem like much, but after a while your code can start looking a lot more complex because of all the extra brackets and suchlike. As a typical lazy programmer, I looked for a way to simplify this. The method I am going to describe should be used with caution, because it can increase memory useage rather dramatically if you're not careful. The way I use it, no extra memory is used, but you do need to be aware of the issues. Basically, you change the way you include files from F, so that they are included into the same package as F: [- Execute ({inputfile => '*', package => __PACKAGE__}) -] You should only do this with HTML files which are included from F, not with the files such as F - those files have to be in their own packages in order for Perl inheritance to work. You can't use this technique with any files which are accessed via method calls. So how does this make things better? Well, since all these files now share the same package, any variables which are created in one of the files is accessible to any of the other files. This means that if you create $xxx in F, then you can access $xxx in F or any other file. This effectively gives you global variables across all the files which are included from F into the same package as F. The thing you need to be careful of here is that if one of these files is included more than once elsewhere on the website, then it will be separately compiled for that instance - thus taking up more memory. This is the big caveat. As a rule, if your files are all just included once by F, then you should be fine. Note that you'll also need to change any calls to parent files, for example: F [- Execute ({inputfile => '../init.html', package => __PACKAGE__}) -] [- # Do some setup specific to this subdirectory -] This is ok, since F<../init.html> will still be compiled into the same package as the rest of the files included from F, and so only one version of it will exist in the Embperl cache. Thus memory usage is not increased. I like this technique because it simplifies the look of my code, which is important for projects containing complex algorithms. It is not the "official" way to implement globals though, and should be used with care. =head1 Global Variables Via Namespaces The previous section described a way to share variables between different files which are included from F, by using the same package across all the files. However this doesn't help us much when dealing with the method files such as F, because these files have to have their own packages - so we are back to square one. There is another way to share variables across even different packages, and that is by using namespaces. For variables that need to be accessible even from F, you could use a namespace which is specific to your website. For example, if your website domain is mydomain.com, then you could create variables using the form $mydomain::xxx = "hello"; As long as you then make sure that you only use this namespace on this website (and other websites on the same Apache web server use their own namespaces), then you shouldn't get any conflicts. Once again, use this with caution, since you introduce the possibility of inadvertently sharing variables between completely different websites. For example, if you cut and paste some useful code from one website to another, you will need to make sure you change the namespace of any globals. Otherwise, you could get some very obscure bugs, since different requests to the various websites could conflict. You also need to be careful about variable initialization, since these globals will now exist between different requests. So, it's possible that if you don't re-initialize a global variable, then it may contain some random value from a previous request. This can result in obscure bugs. Just be careful to initialize all variables properly and you'll be fine. Finally, note that Embperl will only clean up variables which don't have an explicit package (i.e. are in one of the packages automatically set up by Embperl). Variables in other namespaces are not automatically cleaned up. As a result, you need to pay closer attention to cleaning up if you use your own namespaces. The safe way to clean up a variable is simply to 'undef' it. =head1 Handling Queries in DBI If you are like me, you probably use DBI extensively to enable your dynamic websites. I have found the cleanup of queries to be onerous - e.g. calling finish() on queries. If you don't do that, then you tend to get warnings in your error log about unfinished queries. What I do these days is use a global hash, called e.g. %domain::query (see the previous section for using namespaces to safely implement global variables). Then, whenever I create a query, I use this variable. For example: $domain::query{first_page} = $domain::dbh->prepare (qq{ SELECT * FROM pages WHERE page = 1 }); $domain::query{first_page}->execute(); my $first_page = $domain::query{first_page}->fetchrow_hashref(); This little pattern, I find, makes all my queries easier to read and keep track of. You give each one a name in the %domain::query hash that makes sense. Then, at the end of each request, in the F file, you can do something like this: while (($name, $query) = each (%domain::query)) { $query->finish(); } $domain::dbh->disconnect(); Once again, this method is not really the "official" way of doing things in Embperl. You should use the Request object to pass around global variables if you're not comfortable with the risks involved with namespaces (e.g. conflicting websites on the same web server). =head1 Handling Exits You will often find that you want to terminate a page before the end. This doesn't necessarily indicate an error condition; it can be just that you've done all you want to do. When you do this, it is good to first clean up, otherwise you can get annoying warnings showing up in your error logs. I use the following framework. F is Executed from F, and it is the last thing that is done. It calls the cleanup() function in the F file: F [- $subs->cleanup (); -] F [! sub cleanup { while (($name, $query) = each (%domain::query)) { $query->finish(); } $domain::dbh->disconnect(); } sub clean_exit { cleanup(); exit(); } !] Now, whenever I want to exit prematurely, I use a call to $subs->clean_exit() rather than just exit(). This makes sure that the queries and database connections are shut down nicely. =head1 Handling Errors The EMBPERL_OBJECT_FALLBACK directive in F allows you to set a file which will be loaded in the event that the requested file is not found. This file should be relative to the same directory as F. I have found that making a special /errors/ directory is useful, because it enables that special subdirectory to define its own F file, F and so on. So, I then just put this in F: [- $http_headers_out{'Location'} = "/errors/"; clean_exit(); -] See the previous section, "Handling Exits" for more on clean_exit(). =head1 Development and Production Websites When I am developing a website, I usually use at least two machines. I have a workstation where I do developing and testing, and a separate production server, which is accessed by the public. When I am finished making changes to the development version of the website, I move it over to the production server for testing there. However when I do this, I usually don't copy it immediately over the existing production version, because there are sometimes issues with Perl modules which haven't been installed on the server, or other issues which break the code on a different machine. So I use a separate virtual server and subdomain (which is easy if you run your own DNS) to test the new version. For example if the production version of the server is at www.mydomain.com, then I might do testing on the production server under test.mydomain.com, or beta. or whatever subdomain you like. This means you have to create a new virtual server in the httpd.conf file. You also obviously create a new directory for the test server (see below for an example). When you do all this, you end up with a very nice, isolated testing environment on the same server as production. Obviously you hopefully did all your major testing on your workstation, where you can crash the machine and it doesn't matter too much. The production server testbed is a last staging area before production, to get rid of any lingering glitches or omissions. When you're sure it's all working correctly you just copy the files from one directory tree (test) to another (production) on the same machine. This test server can also be used as a beta of the new production version. Friendly users can be given access to the new version, while the old version is still running. One issue that comes up when you do this is that of databases. It is very likely that you will be using a special test database rather than the live one to test your new version. It would be very unwise to use a production database for testing. So your production database might be called "mydatabase", and the test one called "mydatabase_test". This is fine, but it means that you have to remember to change the database name in your code when you copy the files over to production. This is very error prone. The solution is to set variables like the database name in httpd.conf, by setting an environment variable. You just add it to the virtual server section. Here is a real example of two virtual servers on the same production machine, which use two different directories, separate log files and different databases. The website is crazyguyonabike.com, which is a journal of a bicycle ride I did across America in 1998. I decided to expand the site to allow other cyclists to upload their own journals, which resulted in substantial changes to the code. I wanted to keep the original site up while testing the new version, which I put under new.crazyguyonabike.com. Here are the relevant apache settings: F # The production server ServerName www.crazyguyonabike.com SSLDisable ServerAdmin neil@nilspace.com DocumentRoot /www/crazyguyonabike/com/htdocs DirectoryIndex index.html ErrorLog /www/crazyguyonabike/com/logs/error_log TransferLog /www/crazyguyonabike/com/logs/access_log ErrorDocument 403 / ErrorDocument 404 / PerlSetEnv WEBSITE_DATABASE crazyguyonabike PerlSetEnv WEBSITE_ROOT /www/crazyguyonabike/com/htdocs PerlSetEnv EMBPERL_DEBUG 0 PerlSetEnv EMBPERL_ESCMODE 0 PerlSetEnv EMBPERL_OPTIONS 16 PerlSetEnv EMBPERL_MAILHOST mail.nilspace.com PerlSetEnv EMBPERL_OBJECT_BASE base.html PerlSetEnv EMBPERL_OBJECT_FALLBACK notfound.html ServerName crazyguyonabike.com Redirect / http://www.crazyguyonabike.com # Set EmbPerl handler for main directory SetHandler perl-script PerlHandler HTML::EmbperlObject Options ExecCGI # The test server ServerName new.crazyguyonabike.com SSLDisable ServerAdmin neil@nilspace.com DocumentRoot /www/crazyguyonabike/com/new Alias /pics /www/crazyguyonabike/com/pics DirectoryIndex index.html ErrorLog /www/crazyguyonabike/com/logs/new_error_log TransferLog /www/crazyguyonabike/com/logs/new_access_log ErrorDocument 401 /user/register/ ErrorDocument 403 / ErrorDocument 404 / PerlSetEnv WEBSITE_DATABASE crazyguyonabike_new PerlSetEnv WEBSITE_ROOT /www/crazyguyonabike/com/new PerlSetEnv EMBPERL_DEBUG 0 PerlSetEnv EMBPERL_ESCMODE 0 PerlSetEnv EMBPERL_OPTIONS 16 PerlSetEnv EMBPERL_MAILHOST mail.nilspace.com PerlSetEnv EMBPERL_OBJECT_BASE base.html PerlSetEnv EMBPERL_OBJECT_FALLBACK notfound.html # Set EmbPerl handler for new directory SetHandler perl-script PerlHandler HTML::EmbperlObject Options ExecCGI # Restrict access to test server AuthType Basic AuthName CrazyTest Auth_MySQL_DB http_auth Auth_MySQL_Encryption_Types Plaintext require valid-user PerlSetEnv EMBPERL_OPTIONS 16 PerlSetEnv EMBPERL_MAILHOST mail.nilspace.com Note that the test and production servers each get their own databases, directories and log files. You can also see that I restrict access to the test server (which is generally wise, unless you actually like hackers potentially screwing with your head while testing). For basic authentication I use mod_auth_mysql, which is available from the MySQL website. It is nice because it allows you to authenticate based on a MySQL database. When you use PerlSetEnv to pass in variables, you access these variables in your code as follows: $db_name = $ENV{WEBSITE_DATABASE}; If you move those constants which differ between the test and production versions of the same code into the httpd.conf file, then you can just copy the files over from the test directories to the production directory without any alterations. This cuts down on editing errors and also documents specific constants in one place. =head1 Author Neil Gunton neil@nilspace.com Embperl-2.5.0/PaxHeaders.14966/Config.pod0000644000000000000000000000005012323445676016036 xustar000000000000000020 atime=1397643245 20 ctime=1397643307 Embperl-2.5.0/Config.pod0000644000076400000000000020617012323445676015533 0ustar00richterroot00000000000000 =head1 NAME Embperl::Config - Embperl configuration and calling =head1 Operating-Modes Embperl can operate in one of four modes: =over =item mod_perl The mostly used way is to use Embperl together with mod_perl and Apache. This gives the best performance and the most possibilities. =item CGI/FastCGI When you want to run Embperl on a machine that doesn't have mod_perl, you can run Embperl also as normal CGI script. Due to the overhead of CGI, this mode is much slower. To get a better performance you should consider using Embperl together with FastCGI. (http://www.fastcgi.com). =item Offline You can use Embperl also on the command line. This is useful for generating static content out of dynamic pages and can sometime be helpful for testing. =item Call it from other Perl programs If you have your own application and want to use Embperl's capbilities you can do so by calling Embperl::Execute. This allows you to build your own application logic and use Embperl possibilities for rendering content. =back =head2 mod_perl To use Embperl under mod_perl you must have installed Apache and mod_perl on your system. Then you add some directives to your F to load Embperl and add C as the C. The following directives will cause all file with extetion F to be handled by Embperl: PerlModule Embperl AddType text/html .epl SetHandler perl-script PerlHandler Embperl Options ExecCGI Another possibility is to have all files under a special location processed by Embperl: PerlModule Embperl Alias /embperl /path/to/embperl/eg SetHandler perl-script PerlHandler Embperl Options ExecCGI In this setup you should make sure that non Embperl files like images doesn't served from this directory. For B you need addtionaly to load the dynamic object library of Embperl. This is necessary so Embperl is loaded early enough to register the configuration directives with Apache. After installing, search underneath your Perl site directory for the library. On Unix it is mostly called F on Windows it is called C. Now add the following line to your httpd.conf B any of the Embperl configuration directives, but B F is loaded: LoadModule embperl_module /path/to/perl/site/lib/Embperl/Embperl.so To use I you use the C as C: Embperl_AppName unique-name Embperl_Object_Base base.htm Embperl_UriMatch "\.htm.?|\.epl$" SetHandler perl-script PerlHandler Embperl::Object Options ExecCGI Addtionaly you can setup other parameters for I. If you do so inside a container (like C<, , >) you need to set C to a unique-name (the actual value doesn't matter). The C makes sure that only files of the requested type are served by I, while all others are served by Apache as usual. For more information see: L<"perldoc Embperl::Object"|"EmbperlObject.pod">. Embperl accepts a lot of configuration directives to customize it's behaviour. See the next section for a description. B If mod_perl is statically linked into Apache you can not use B in your httpd.conf =head3 Preloading pages To optimize memory usage you can preload your pages during the initialization. If you do so they will get loaded into the parent process and the memory will be shared by all child processes. To let Embperl preload your files, you have to supply all the filename into the key B of the hash B<%initparam>, B you load Embperl. Example: BEGIN { $Embperl::initparam{preloadfiles} = [ '/path/to/foo.epl', '/path/to/bar.epl', { inputfile => "/path/to/other.epl", input_escmode => 7 }, ] ; } use Embperl ; As you see for the third file, it is also possible to give a hashref and supply the same parameter like L accpets (see below). B Preloading is not supported under Apache 1.3, when mod_perl is loaded as DSO. To use preloading under Apache 1.3 you need to compile mod_perl statically into Apache. =head2 CGI/FastCGI To use this mode you must copy B to your cgi-bin directory. You can invoke it with the URL http://www.domain.xyz/cgi-bin/embpcgi.pl/url/of/your/document. The /url/of/your/document will be passed to Embperl by the web server. Normal processing (aliasing, etc.) takes place before the URI makes it to PATH_TRANSLATED. If you are running the Apache httpd, you can also define B as a handler for a specific file extension or directory. Example of Apache C: Action text/html /cgi-bin/embperl/embpcgi.pl B: Via CGI Scripts it maybe possible to bypass some of the Apache setup. To avoid this use L to restrict access to the files, which should be processed by Embperl. For I you have to use F instead of F. You can also run Embperl with B, in this case use embpfastcgi.pl as cgi script. You must have FCGI.pm installed. =head2 Offline Run Embperl from the comannd line use F on unix and F on windows: B B =over 4 =item B The full pathname of the source file which should be processed by Embperl. =item B Optional. Has the same meaning as the environment variable QUERY_STRING when invoked as a CGI script. That is, QUERY_STRING contains everything following the first "?" in a URL. should be URL-encoded. The default is no query string. =back Options: =over =item -o outputfile Optional. Gives the filename to which the output is written. The default is stdout. =item -l logfile Optional. Gives the filename of the logfile. The default is F on unix and F<\embperl.log> on windows. =item -d debugflags Optional. Specifies the level of debugging (what is written to the log file). The default is nothing. See L<"EMBPERL_DEBUG"> for exact values. =item -t options See L<"EMBPERL_OPTIONS"> for option values. =item -s syntax Defines the syntax of the source. See See L<"EMBPERL_SYNTAX"> =item -p param Gives a value which is passed in the @param array to the executed page. Can be given multiple times. =item -f fdat value Gives a name/value pair which is passed in the %fdat hash to the executed page. Can be given multiple times. =back =head2 By calling Embperl::Execute (\%param) C can be used to call Embperl from your own modules/scripts (for example from a Apache::Registry or CGI script) or from within another Embperl page to nest multiple Embperl pages (for example to store a common header or footer in a different file). (See B for more detailed examples) When you want to use I call C, when you want I, call C. There are two forms you can use for calling Execute. A short form which only takes a filename and optional additional parameters or a long form which takes a hash reference as its argument. Execute($filename, $p1, $p2, $pn) ; This will cause Embperl to interpret the file with the name C<$filename> and, if specified, pass any additional parameters in the array C<@param> (just like C<@_> in a Perl subroutine). The above example could also be written in the long form: Execute ({inputfile => $filename, param => [$p1, $p2, $pn]}) ; The possible items for hash of the long form are are descriped in the configuration section and parameter section. =head3 EXAMPLES for Execute: # Get source from /path/to/your.html and # write output to /path/to/output' Embperl::Execute ({ inputfile => '/path/to/your.html', outputfile => '/path/to/output'}) ; # Get source from scalar and write output to stdout # Don't forget to modify mtime if $src changes $src = 'Page [+ $no +]' ; Embperl::Execute ({ inputfile => 'some name', input => \$src, mtime => 1 }) ; # Get source from scalar and write output to another scalar my $src = 'Page [+ $no +]' ; my $out ; Embperl::Execute ({ inputfile => 'another name', input => \$src, mtime => 1, output => \$out }) ; print $out ; # Include a common header in an Embperl page, # which is stored in /path/to/head.html [- Execute ('/path/to/head.html') -] =head2 Debugging Starting with 2.0b2 Embperl files can debugged via the interactive debugger. The debugger shows the Embperl page source along with the correct linenumbers. You can do anything you can do inside a normal Perl program via the debugger, e.g. show variables, modify variables, single step, set breakpoints etc. You can use the Perl interacive command line debugger via perl -d embpexec.pl file.epl or if you prefer a graphical debugger, try ddd (http://www.gnu.org/software/ddd/) it's a great tool, also for debugging any other perl script: ddd --debugger 'perl -d embpexec.pl file.epl' NOTE: embpexec.pl could be found in the Embperl source directory If you want to debug your pages, while running under mod_perl, Apache::DB is the right thing. Apache::DB is available from CPAN. =head1 Configuration Configuration can be setup in different ways, depending how you run Embperl. When you run under mod_perl, Embperl add a set of new configuration directives to the Apache configuration, so you can set them in your F. When you run Embperl as CGI it takes the configuration from environment variables. For compatibility reason that can also be turned on under mod_perl, by adding C in your F. When you call Embperl from another Perl program, by calling the C function, you can pass your configuration along with other parameters as a hash reference. If you pass C als parameter Embperl will also scan the environment for configuration information. Last but not least you can pass configuration information as options when you run Embperl via embpexec.pl from the command line. Some of the configuration options are also setable inside the page via the Empberl objects and you can read the current configuration from these objects. You can not only pass configuration in different ways, there are also three different contexts: I, I and I. A application describes a set of pages/files that belongs together and form the application. Application level configuration are the same for all files that belongs to an application. These configuration information need to be known before any request processing takes place, so they can't be modified during a request. Every application has it's own name. You can refer the configuration of an application, by simply setting the name of the application to use. Request level configuration information applies to one request, some of them must be known before the request starts, some of them can still be modified during the request. Configuration for components can be setup before the request, but can also be passed as argument when you call the component via C. =head2 Embperl_Useenv =over =item Env: EMBPERL_USEENV =item Method: $application -> config -> use_env I<[read only]> =item Default: off unless runing as CGI script =item Since: 2.0b6 =back Tells Embperl to scan the enviromemt for configuration settings. =head2 use_redirect_env =over =item Method: $application -> config -> use_redirect_env I<[read only]> =item Default: off unless runing as CGI script =item Since: 2.0b6 =back Tells Embperl to scan the enviromemt for configuration settings which has the prefix C. This is normally the case when the request is not the main request, but a subrequest. =head2 Embperl_Appname =over =item Env: EMBPERL_APPNAME =item Method: $application -> config -> app_name I<[read only]> =item Since: 2.0b6 =back Specifies the name for an application. The name is basicly used to refer to this application elsewhere in httpd.conf without the need to setup the parameters for the apllication again. =head2 Embperl_App_Handler_Class =over =item Env: EMBPERL_APP_HANDLER_CLASS =item Method: $application -> config -> app_handler_class I<[read only]> =item Since: 2.0b6 =back Embperl will call the C method of the given class at the start of the request, but after all request parameters are setup. This give the class a chance to do any necessary computation and modify the request parameters, before the request is actualy executed. See L for an example. =head2 Embperl_Session_Handler_Class =over =item Env: EMBPERL_SESSION_HANDLER_CLASS =item Method: $application -> config -> session_handler_class I<[read only]> =item Default: Apache::SessionX =item Since: 1.3b3 =item See also: Session Handling =back Set the class that performs the Embperl session handling. This gives you the possibility to implement your own session handling. NOTE: Default until 1.3.3 was C, starting with 1.3.4 it is C. To get the old session behaviour set it to C. =head2 Embperl_Session_Args =over =item Env: EMBPERL_SESSION_ARGS =item Method: $application -> config -> session_args I<[read only]> =item Since: 1.3b3 =item See also: Session Handling =back List of arguments for Apache::Session classes Arguments that contains spaces can be quoted. Example: EMBPERL_SESSION_ARGS "DataSource=dbi:mysql:session UserName=www 'Password=secret word'" =head2 Embperl_Session_Classes =over =item Env: EMBPERL_SESSION_CLASSES =item Method: $application -> config -> session_classes I<[read only]> =item Since: 1.3b3 =item See also: Session Handling =back Space separated list of object store and lock manager (and optionally the serialization and id generating class) for Apache::Session (see L<"Session handling">) =head2 Embperl_Session_Config =over =item Env: EMBPERL_SESSION_CONFIG =item Method: $application -> config -> session_config I<[read only]> =item Default: given when running Makefile.PL of Apache::SessionX =item Since: 1.3.3 =item See also: Session Handling =back Selects a session configuration from the configurations you have defined when running I's C. NOTE: Use either C or C and C =head2 Embperl_Cookie_Name =over =item Env: EMBPERL_COOKIE_NAME =item Method: $application -> config -> cookie_name I<[read only]> =item Default: EMBPERL_UID =item Since: 1.2b4 =item See also: Session Handling =back Set the name that Embperl uses when it sends the cookie with the session id. =head2 Embperl_Cookie_Domain =over =item Env: EMBPERL_COOKIE_DOMAIN =item Method: $application -> config -> cookie_domain I<[read only]> =item Default: none =item Since: 1.2b4 =item See also: Session Handling =back Set the domain that Embperl uses for the cookie with the session id. =head2 Embperl_Cookie_Path =over =item Env: EMBPERL_COOKIE_PATH =item Method: $application -> config -> cookie_path I<[read only]> =item Default: none =item Since: 1.2b4 =item See also: Session Handling =back Set the path that Embperl uses for the cookie with the session id. =head2 Embperl_Cookie_Expires =over =item Env: EMBPERL_COOKIE_EXPIRES =item Method: $application -> config -> cookie_expires I<[read only]> =item Default: at the end of the session =item Since: 1.3b5 =item See also: Session Handling =back Set the expiration date that Embperl uses for the cookie with the session id. You can specify the full date or relativ values. The following forms are all valid times: +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 Thu, 25-Apr-1999 00:40:33 GMT at the indicated time & date =head2 Embperl_Cookie_Secure =over =item Env: EMBPERL_COOKIE_SECURE =item Method: $application -> config -> cookie_secure I<[read only]> =item Default: at the end of the session =item Since: 2.0b9 =item See also: Session Handling =back Set the secure flag of cookie that Embperl uses for the session id. If set the cookie will only be transferred over a secured connection. =head2 Embperl_Log =over =item Env: EMBPERL_LOG =item Method: $application -> config -> log I<[read only]> =item Default: Unix: /tmp/embperl.log Windows: /embperl.log =back Gives the location of the log file. This will contain information about what Embperl is doing. The amount of information depends on the debug settings (see L<"EMBPERL_DEBUG"> below). The log output is intended to show what your embedded Perl code is doing and to help debug it. =head2 Embperl_Debug =over =item Env: EMBPERL_DEBUG =item Method: $application -> config -> debug =back This is a bitmask which specifies what should be written to the log. To specify multiple debugflags, simply add the values together. You can give the value a decimal, octal (prefix 0) or hexadecimal (prefix 0x) value. You can also use the constants defined in I. The following values are defined: =over 4 =item dbgStd = 1 (0x1) Show minimum information. =item dbgMem = 2 (0x2) Show memory and scalar value allocation. =item dbgEval = 4 (0x4) Show arguments to and results of evals. =item dbgEnv = 16 (0x10) List every request's environment variables. =item dbgForm = 32 (0x20) List posted form data. =item dbgInput = 128 (0x80) Show processing of HTML input tags. =item dbgFlushOutput = 256 (0x100) Flush Embperl's output after every write. This should only be set to help debug Embperl crashes, as it drastically slows down Embperl's operation. =item dbgFlushLog = 512 (0x200) Flush Embperl's logfile output after every write. This should only be set to help debug Embperl crashes, as it drastically slows down Embperl's operation. =item dbgLogLink = 8192 (0x2000) This feature is not yet implemented in Embperl 2.0! Inserts a link at the top of each page which can be used to view the log for the current HTML file. See also L<"EMBPERL_VIRTLOG">. Example: EMBPERL_DEBUG 10477 EMBPERL_VIRTLOG /embperl/log.htm SetHandler perl-script PerlHandler Embperl Options ExecCGI =item dbgDefEval = 16384 (0x4000) Shows every time new Perl code is compiled. =item dbgHeadersIn = 262144 (0x40000) Log all HTTP headers which are sent from and to the browser. =item dbgShowCleanup = 524288 (0x80000) Show every variable which is undef'd at the end of the request. For scalar variables, the value before undef'ing is logged. =item dbgSession = 2097152 (0x200000) Enables logging of session transactions. =item dbgImport = 4194304 (0x400000) Show how subroutines are imported in other namespaces. =item dbgOutput = 0x08000 Logs the process of converting the internal tree strcuture to plain text for output =item dbgDOM = 0x10000 Logs things related to processing the internal tree data structure of documents =item dbgRun = 0x20000 Logs things related to execution of a document =item dbgBuildToken = 0x800000 Logs things related to creating the token tables for source parsing =item dbgParse = 0x1000000 Logs the parseing of the source =item dbgObjectSearch = 0x2000000 Shows how Embperl::Objects seraches sourcefiles =item dbgCache = 0x4000000 Logs cache related things =item dbgCompile = 0x8000000 Gives information about compiling the parsed source to Perl code =item dbgXML = 0x10000000 Logs things related to XML processing =item dbgXSLT = 0x20000000 Logs things related to XSLT processing =item dbgCheckpoint = 0x40000000 Logs things related to checkpoints which are internaly used during execution. This information is only useful if you have a deep knowledge of Embperl internals. =back =head2 Embperl_Maildebug =over =item Env: EMBPERL_MAILDEBUG =item Method: $application -> config -> maildebug =item Since: 1.2.1 =back Debug value pass to Net::SMTP. =head2 Embperl_Mailhost =over =item Env: EMBPERL_MAILHOST =item Method: $application -> config -> mailhost =item Default: localhost =back Specifies which host the mail related functions of Embperl uses as SMTP server. =head2 Embperl_Mailhelo =over =item Env: EMBPERL_MAILHELO =item Method: $application -> config -> mailhelo =item Default: chosen by Net::SMTP =item Since: 1.3b4 =back Specifies which host/domain all mailrealted function uses in the HELO/EHLO command. A reasonable default is normally chosen by I, but depending on your installation it may necessary to set it manualy. =head2 Embperl_Mailfrom =over =item Env: EMBPERL_MAILFROM =item Method: $application -> config -> mailfrom =item Default: www-server@ =item Since: 1.2.1 =back Specifies the email address that is used as sender all mailrelted function. =head2 Embperl_Mail_Errors_To =over =item Env: EMBPERL_MAIL_ERRORS_TO =item Method: $application -> config -> mail_errors_to =back If set all errors will be send to the email address given. =head2 Embperl_Mail_Errors_Limit =over =item Env: EMBPERL_MAIL_ERRORS_LIMIT =item Method: $application -> config -> mail_errors_limit I<[read only]> =item Since: 2.0b6 =back Do not mail more then errors. Set to 0 for no limit. =head2 Embperl_Mail_Errors_Reset_Time =over =item Env: EMBPERL_MAIL_ERRORS_RESET_TIME =item Method: $application -> config -> mail_errors_reset_time I<[read only]> =item Since: 2.0b6 =back Reset error counter if for seconds no error has occured. =head2 Embperl_Mail_Errors_Resend_Time =over =item Env: EMBPERL_MAIL_ERRORS_RESEND_TIME =item Method: $application -> config -> mail_errors_resend_time I<[read only]> =item Since: 2.0b6 =back Mail errors of seconds regardless of the error counter. =head2 Embperl_Object_Base =over =item Env: EMBPERL_OBJECT_BASE =item Method: $application -> config -> object_base I<[read only]> =item Default: _base.epl =item Since: 1.3b1 =back Name of the base page that Embperl::Objects searches for. =head2 Embperl_Object_App =over =item Env: EMBPERL_OBJECT_APP =item Method: $application -> config -> object_app =item Since: 2.0b6 =back Filename of the application object that Embperl::Object searches for. The file should contain the Perl code for the application object. There must be no package name given (as the package is set by Embperl::Object) inside the file, but the @ISA should point to Embperl::App. If set this file is searched through the same search path as any content file. After a successfull load the init method is called with the Embperl request object as parameter. The init method can change the parameters inside the request object to influence the current request. =head2 Embperl_Object_Addpath =over =item Env: EMBPERL_OBJECT_ADDPATH =item Method: $application -> config -> object_addpath =item Since: 1.3b1 =back Additional directories where Embperl::Object searches for pages. This search through the searchpath is always performed if in a call to Execute no path for the file is given. In F or as evironment variable directories are separated by C<;> (on Unix C<:> works also). The parameter for C and the application object method expects/returns an array reference. This path is B appended to the searchpath. =head2 Embperl_Object_Reqpath =over =item Env: EMBPERL_OBJECT_REQPATH =item Method: $application -> config -> object_reqpath =item Since: 2.0b12 =back Additional directories where Embperl::Object searches for files for the inital request. If a file is requested, but cannot be found at the given location, the directories given in the this path are additionally searched for the file. This applies only to the initial filename given to Embperl::Object and B to files called via Execute. In F or as evironment variable directories are separated by C<;> (on Unix C<:> works also). The parameter for C and the application object method expects/returns an array reference. Example: if you say Embperl_Object_Reqpath /a:/b:/c and you request /x/index.epl it will try /x/index.epl /a/index.epl /b/index.epl /c/index.epl and take the first one that is found. =head2 Embperl_Object_Stopdir =over =item Env: EMBPERL_OBJECT_STOPDIR =item Method: $application -> config -> object_stopdir =item Since: 1.3b1 =back Directory where Embperl::Object stops searching for the base page. =head2 Embperl_Object_Fallback =over =item Env: EMBPERL_OBJECT_FALLBACK =item Method: $application -> config -> object_fallback =item Since: 1.3b1 =back If the requested file is not found by Embperl::Object, the file given by C is displayed instead. If C isn't set a staus 404, NOT_FOUND is returned as usual. If the fileame given in C doesn't contain a path, it is searched thru the same directories as C. =head2 Embperl_Object_Handler_Class =over =item Env: EMBPERL_OBJECT_HANDLER_CLASS =item Method: $application -> config -> object_handler_class =item Since: 1.3b1 =back If you specify this, the template base and the requested page inherit all methods from this class. This class must contain C in his @ISA array. =head2 Embperl_Useenv =over =item Env: EMBPERL_USEENV =item Method: $request -> config -> use_env I<[read only]> =item Default: off unless runing as CGI script =item Since: 2.0b6 =back Tells Embperl to scan the enviromemt for configuration settings. =head2 use_redirect_env =over =item Method: $request -> config -> use_redirect_env I<[read only]> =item Default: off unless runing as CGI script =item Since: 2.0b6 =back Tells Embperl to scan the enviromemt for configuration settings which has the prefix C. This is normally the case when the request is not the main request, but a subrequest. =head2 Embperl_Allow =over =item Env: EMBPERL_ALLOW =item Method: $request -> config -> allow I<[read only]> =item Default: no restrictions =item Since: 1.2b10 =back If specified, only files which match the given B will be processed by Embperl. All other files will return FORBIDDEN. This is especially useful in a CGI environment by making the server more secure. =head2 Embperl_Urimatch =over =item Env: EMBPERL_URIMATCH =item Method: $request -> config -> urimatch I<[read only]> =item Default: process all files =item Since: 2.0b6 =back If specified, only files which match the given B will be processed by Embperl, all other files will be handled by the standard Apache handler. This can be useful if you have Embperl documents and non Embperl documents (e.g. gifs) residing in the same directory. Example: # Only files which end with .htm will processed by Embperl EMBPERL_URIMATCH \.htm$ =head2 Embperl_Multfieldsep =over =item Env: EMBPERL_MULTFIELDSEP =item Method: $request -> config -> mult_field_sep I<[read only]> =item Default: \t =item Since: 2.0b6 =back Specifies the character that is used to separate multiple form values with the same name. =head2 Embperl_Path =over =item Env: EMBPERL_PATH =item Method: $request -> config -> path I<[read only]> =item Since: 1.3b6 =back Can contain a semicolon (also colon under Unix) separated file search path. When a file is processed and the filename isn't an absolute path or does not start with ./ (or .\ under windows), I searches all the specified directories for that file. A special handling is done if the filename starts with any number of C<../> i.e. refers to an upper directory. Then I strips the same number of entries at the start of the searchpath as the filename contains C<../>. C and the method of the request object expects/returns a array ref. =head2 Embperl_Debug =over =item Env: EMBPERL_DEBUG =item Method: $request -> config -> debug =back See application configuration for an describtion of possible values =head2 Embperl_Options =over =item Env: EMBPERL_OPTIONS =item Method: $request -> config -> options =back This bitmask specifies some options for the execution of Embperl. To specify multiple options, simply add the values together. =over 4 =item optDisableVarCleanup = 1 Disables the automatic cleanup of variables at the end of each request. =item optDisableEmbperlErrorPage = 2 Tells Embperl not to send its own errorpage in case of failure, but instead show as much of the page as possible. Errors are only logged to the log file. Without this option, Embperl sends its own error page, showing all the errors which have occurred. If you have dbgLogLink enabled, every error will be a link to the corresponding location in the log file. This option has no effect if optReturnError is set. =item optReturnError = 262144 With this option set, Embperl sends no output in case of an error. It returns the error back to Apache or the calling program. When running under mod_perl this gives you the chance to use the Apache I directive to show a custom error-document. Inside the ErrorDocument you can retrieve the error messages with $errors = $req_rec -> prev -> pnotes('EMBPERL_ERRORS') ; where C<$errors> is a array reference. (1.3b5+) =item optShowBacktrace = 0x8000000 When set every error message not only show the sourcefiles, but all files from which this file was called by Execute. =back =head2 Embperl_Output_Mode =over =item Env: EMBPERL_OUTPUT_MODE =item Method: $request -> config -> output_mode =item Default: HTML =item Since: 2.0b9 =back Set the desired output format. 0 for HTML and 1 XML. If set to XML all tags that are generated by Embperl will contain a closing slash to conform to XML specs. e.g. B If you set output_mode to XML you should also change L to XML escaping. =head2 Embperl_Output_Esc_Charset =over =item Env: EMBPERL_OUTPUT_ESC_CHARSET =item Method: $request -> config -> output_esc_charset I<[read only]> =item Default: ocharsetLatin1 = 1 =item Since: 2.0.2 =back Set the charset which to assume when escaping. This can only be set before the request starts (e.g. httpd.conf or top of the page). Setting it inside the page has undefined results. =over =item ocharsetUtf8 = 0 UTF-8 or any non known charset. Characters with codes above 128 will not be escaped at all =item ocharsetLatin1 = 1 ISO-8859-1, the default. When a Perl string has it's utf-8 bit set, this mode will behave the same as mode 0, i.e. will not escape anything above 128. =item ocharsetLatin2 = 2 ISO-8859-2. When a Perl string has it's utf-8 bit set, this mode will behave the same as mode 0, i.e. will not escape anything above 128. =back =head2 Embperl_Session_Mode =over =item Env: EMBPERL_SESSION_MODE =item Method: $request -> config -> session_mode I<[read only]> =item Default: smodeUDatCookie = 1 =item Since: 2.0b6 =back Specifies how the id for the session data is passed between requests. Possible values are: =over =item smodeNone = 0 No session id will be passed =item smodeUDatCookie = 1 The session id for the user session will be passed via cookie =item smodeUDatParam = 2 The session id for the user session will append as parameter to any URL and inserted as a hidden field in any form. =item smodeUDatUrl = 4 The session id for the user session will passed as a part of the URL. NOT YET IMPLEMENTED!! =item smodeSDatParam = 0x20 The session id for the state session will append as parameter to any URL and inserted as a hidden field in any form. =back You may add the UDat and SDat values together to get both sorts of sessions, for example the value 0x21 will pass the id for the user session inside a cookie and the id for the state session as parameters. =head2 Embperl_Useenv =over =item Env: EMBPERL_USEENV =item Method: $component -> config -> use_env I<[read only]> =item Default: off unless runing as CGI script =item Since: 2.0b6 =back Tells Embperl to scan the enviromemt for configuration settings. =head2 use_redirect_env =over =item Method: $component -> config -> use_redirect_env I<[read only]> =item Default: off unless runing as CGI script =item Since: 2.0b6 =back Tells Embperl to scan the enviromemt for configuration settings which has the prefix C. This is normally the case when the request is not the main request, but a subrequest. =head2 Embperl_Package =over =item Env: EMBPERL_PACKAGE =item Method: $component -> config -> package =back The name of the package where your code will be executed. By default, Embperl generates a unique package name for every file. This ensures that variables and functions from one file do not conflict with those of another file. (Any package's variables will still be accessible with explicit package names.) =head2 Embperl_Debug =over =item Env: EMBPERL_DEBUG =item Method: $component -> config -> debug =back See application configuration for an describtion of possible values =head2 Embperl_Options =over =item Env: EMBPERL_OPTIONS =item Method: $component -> config -> options =back This bitmask specifies some options for the execution of Embperl. To specify multiple options, simply add the values together. =over 4 =item optDisableVarCleanup = 1 Disables the automatic cleanup of variables at the end of each request. =item optDisableEmbperlErrorPage = 2 Tells Embperl not to send its own errorpage in case of failure, but instead show as much of the page as possible. Errors are only logged to the log file. Without this option, Embperl sends its own error page, showing all the errors which have occurred. If you have dbgLogLink enabled, every error will be a link to the corresponding location in the log file. This option has no effect if optReturnError is set. =item optReturnError = 262144 With this option set, Embperl sends no output in case of an error. It returns the error back to Apache or the calling program. When running under mod_perl this gives you the chance to use the Apache I directive to show a custom error-document. Inside the ErrorDocument you can retrieve the error messages with $errors = $req_rec -> prev -> pnotes('EMBPERL_ERRORS') ; where C<$errors> is a array reference. (1.3b5+) =item optShowBacktrace = 0x8000000 When set every error message not only show the sourcefiles, but all files from which this file was called by Execute. =item optSafeNamespace = 4 Tells Embperl to execute the embedded code in a safe namespace so the code cannot access data or code in any other package. (See the chapter about L<"(Safe-)Namespaces and opcode restrictions"> below for more details.) =item optOpcodeMask = 8 Tells Embperl to apply an operator mask. This gives you the chance to disallow special (unsafe) opcodes. (See the Chapter about L<"(Safe-)Namespaces and opcode restrictions"> below for more details.) =item optDisableFormData = 256 This option disables the setup of %fdat and @Z<>ffld. Embperl will not do anything with the posted form data. Set this when using Execute from your perl script and you have already read the Form Data (via eg. CGI.pm). =item optFormDataNoUtf8 = 0x2000000 By default Embperl checks all formfields in %fdat if they contain valid UTF-8 strings and if yes sets Perl's internals UTF-8 flag. If this option is set Embperl will never set the UTF-8 on any data in %fdat. =item optAllFormData = 8192 This option will cause Embperl to insert all formfields in %fdat and @Z<>ffld, even if they are empty. Empty formfields will be inserted with an empty string. Without this option, empty formfields will be absent from %fdat and @Z<>ffld. =item optRedirectStdout = 16384 Redirects STDOUT to the Embperl output stream before every request and resets it afterwards. If set, you can use a normal Perl B inside any Perl block to output data. Without this option you can only use output data by using the [+ ... +] block, or printing to the filehandle B. =item optNoHiddenEmptyValue = 65536 (only 1.2b2 and above) Normally, if there is a value defined in %fdat for a specific input field, Embperl will output a hidden input element for it when you use B. When this option is set, Embperl will not output a hidden input element for this field when the value is a blank string. =item optKeepSpaces = 1048576 (only 1.2b5 and above) = 0x100000, Disable the removal of spaces and empty lines from the output. This is useful for sources other than HTML. =item optChdirToSource = 0x10000000 (only 2.5 and above) Change current working directory to the directory of the sourcefile, before executing the source. =back =head2 Embperl_Escmode =over =item Env: EMBPERL_ESCMODE =item Method: $component -> config -> escmode =item Default: 7 =back Turn HTML and URL escaping on and off. NOTE: If you want to output binary data, you must set the escmode to zero. For convenience you can change the escmode inside a page by setting the variable C<$escmode>. =over 4 =item escXML = 8 (or 15) (2.0b4 and above) The result of a Perl expression is always XML-escaped (e.g., `>' becomes `>' and ' become '). =item escUrl + escHtml = 3 (or 7) The result of a Perl expression is HTML-escaped (e.g., `>' becomes `>') in normal text and URL-escaped (e.g., `&' becomes `%26') within of C, C, C, C

    Embperl-2.5.0/test/html/PaxHeaders.14966/reqrec.htm0000644000000000000000000000005012023276646020037 xustar000000000000000020 atime=1397643273 20 ctime=1397643307 Embperl-2.5.0/test/html/reqrec.htm0000644000076400000000000000107112023276646017525 0ustar00richterroot00000000000000 Test for $req_rec in Embperl $conf = [+ defined ($conf)?$conf:'' +]
    $_[0] = [+ defined ($_[0])?$_[0]:'' +]
    $_[1] = [+ defined ($_[1])?$_[1]:'' +]
    $rec_rec = [+ $req_rec +]
    $$rec_rec = [+ $$req_rec +]
    [- $ar = $Embperl::modperlapi < 2?Apache->request:Apache2::RequestUtil -> request -] Apache->request = [+ $ar +]
    ${Apache->request} = [+ $$ar +]
    ${Apache->request} = $$req_rec ? [+ ($$ar == $$req_rec)?'yes':'no' +]
    [+ $req_rec -> filename +] Embperl-2.5.0/test/html/PaxHeaders.14966/SSIEP0000644000000000000000000000005012323454053016643 xustar000000000000000020 atime=1397643307 20 ctime=1397643307 Embperl-2.5.0/test/html/SSIEP/0000755000000000000000000000000012323454053015711 5ustar00rootroot00000000000000Embperl-2.5.0/test/html/SSIEP/PaxHeaders.14966/ssiep.htm0000644000000000000000000000005012023276646020564 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/SSIEP/ssiep.htm0000644000076400000000000000102212023276646020246 0ustar00richterroot00000000000000 Embperl Tests - Mixed Embperl and SSI syntax EPSSITEST 1 SSI: EPSSITEST 1 EP: [+ $ENV{EPSSITEST} +] [- @X = ('a', 'b', 'c') ; -]
    Embperl[+ $ENV{X} = $X[$row] +] SSI
    Embperl inside SSI: Embperl-2.5.0/test/html/PaxHeaders.14966/incerr.htm0000644000000000000000000000005012023276646020040 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/incerr.htm0000755000076400000000000000026612023276646017536 0ustar00richterroot00000000000000[+ "Start include" +] [- @a = ('s1', 's2', 's3') -]
    [+ Syntax error is here "$param[0] - " +][+ $a[$col] +]
    [+ "End include" +] Embperl-2.5.0/test/html/PaxHeaders.14966/java.htm0000644000000000000000000000005012023276646017477 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/java.htm0000644000076400000000000000126612023276646017173 0ustar00richterroot00000000000000 Embperl-2.5.0/test/html/PaxHeaders.14966/tagscandisable.htm0000644000000000000000000000005012023276646021522 xustar000000000000000020 atime=1397535904 20 ctime=1397643307 Embperl-2.5.0/test/html/tagscandisable.htm0000755000076400000000000000345712023276646021225 0ustar00richterroot00000000000000 optDisableHtmlScan is now: [+ $optDisableHtmlScan +]
    optDisableHtmlScan is set now to: [+ $optDisableHtmlScan = 1 +]
    optDisableHtmlScan is now: [+ $optDisableHtmlScan +]
    [+ $fdat{feld2} = 'blabla2' ; +] [+ $fdat{feld6} = 'blabla6' ; +] [- @ks = sort keys %idat -]
    [+ $ks[$i=$row] +][+ $idat{$ks[$i]} || '' +]
    [- @ks = sort keys %fdat -]
    [+ $ks[$i=$row] +][+ $fdat{$ks[$i]} || '' +]
    optDisableHtmlScan is now: [+ $optDisableHtmlScan +]
    optDisableHtmlScan is set now to: [+ $optDisableHtmlScan = 0 +]
    optDisableHtmlScan is now: [+ $optDisableHtmlScan +]
    [- @ks = sort keys %fdat -]
    [+ $ks[$i=$row] +][+ $fdat{$ks[$i]} || '' +]
    [- @ks = sort keys %idat -]
    [+ $ks[$i=$row] +][+ $idat{$ks[$i]} || '' +]
    [- @ks = sort keys %fdat -]
    [+ $ks[$i=$row] +][+ $fdat{$ks[$i]} || '' +]
    Embperl-2.5.0/test/html/PaxHeaders.14966/escutf8.htm0000644000000000000000000000005012023276646020137 xustar000000000000000020 atime=1397643263 20 ctime=1397643307 Embperl-2.5.0/test/html/escutf8.htm0000755000076400000000000000626012023276646017635 0ustar00richterroot00000000000000 Some tests for Embperl UTF8 escaping [- use Encode ; $fdat{test} = "abc!'\"$%&()<>=äöüÄÖÜß©" ; $fdat{utf8} = decode("iso-8859-1", $fdat{test}) ; $escmodestd = $escmode ; -] ------------------------------------------------ $epreq -> config -> output_esc_charset = 1 [- $epreq -> config -> output_esc_charset (1) -] $escmode = $escmodestd ; [- $escmode = $escmodestd ; -] abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{test} +] utf8: abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{utf8} +] poststd: postutf8: $escmode = 8 ; [- $escmode = 8 ; -] abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{test} +] utf8: abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{utf8} +] $escmode = 2 ; [- $escmode = 2 ; -] abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{test} +] utf8: abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{utf8} +] ------------------------------------------------ $epreq -> config -> output_esc_charset = 2 [- $epreq -> config -> output_esc_charset (2) -] $escmode = $escmodestd ; [- $escmode = $escmodestd ; -] abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{test} +] utf8: abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{utf8} +] poststd: postutf8: $escmode = 8 ; [- $escmode = 8 ; -] abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{test} +] utf8: abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{utf8} +] $escmode = 2 ; [- $escmode = 2 ; -] abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{test} +] utf8: abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{utf8} +] ------------------------------------------------ $epreq -> config -> output_esc_charset = 0 [- $epreq -> config -> output_esc_charset (0) -] $escmode = $escmodestd ; [- $escmode = $escmodestd ; -] abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{test} +] utf8: abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{utf8} +] poststd: postutf8: $escmode = 8 ; [- $escmode = 8 ; -] abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{test} +] utf8: abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{utf8} +] $escmode = 2 ; [- $escmode = 2 ; -] abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{test} +] utf8: abc!"$%&()<>=äöüÄÖÜß -> [+ $fdat{utf8} +] ------------------------------------------------ $epreq -> config -> output_esc_charset = 1 [- $epreq -> config -> output_esc_charset (1) -] $escmode = $escmodestd ; [- $escmode = $escmodestd ; -] Embperl-2.5.0/test/html/PaxHeaders.14966/xhtml.htm0000644000000000000000000000005012023276646017712 xustar000000000000000020 atime=1397643264 20 ctime=1397643307 Embperl-2.5.0/test/html/xhtml.htm0000644000076400000000000000176612023276646017413 0ustar00richterroot00000000000000[- $r = shift ; $r -> config -> output_mode (1) ; $escmode = 12 ; -] Embperl Tests - XHTML output [- $a = 1 -] [$if $a$] a
    [$ endif$] [- @c = ([1,"'2'"],['"3"',4]) ; -]
    [+ $c[$row][$col] +]
    [- %fdat = ( a => 1, b => "'2'", c => '"3"') ; @ffld = sort keys %fdat ; -] [$hidden$] --- NO slashes in the source ---     bla --- slashes in the source --- bla Embperl-2.5.0/test/html/PaxHeaders.14966/taint.htm0000644000000000000000000000005012023276646017675 xustar000000000000000020 atime=1397643276 20 ctime=1397643307 Embperl-2.5.0/test/html/taint.htm0000644000076400000000000000047212023276646017367 0ustar00richterroot00000000000000 Check Tainiting for Embperl This is a test if tainting works with Embperl