#!/usr/local/bin/perl ## ## index.VGCGI.pl ## ## (often copied or linked as index.pl or index.cgi or other .cgi) ## ## Part of the Visius(tm) Generalized CGI (VGCGI) system. ## Copyright 1996-1998, Ignition, Inc. ## All Rights Reserved. ## Confidential property of Ignition, Inc. ## ## License to use this and related files is granted to certain ## customers of Ignition, Inc on a per-customer, per-project basis. ## ## Modifications to this code must be sent to Ignition, Inc; however, ## customizations made to configuration files outside the VGCGI ## directory are the property of their maker and do not need ## to be contributed back to Ignition. ## ## Summary: ## ## This perl 5.0 script implements a generalized CGI system that can ## handle anything from a single page to a multi-page form in ## a template-driven and extremely extensible manner -- in general, ## it is intended to serve as the foundation for ANY CGI application. ## ## This script is meant to be linked or copied into the directory ## from which it will be used. (Usually under the name index.cgi). ## ## At the same time, ## ## For this script to compile, the directory from which it is run/ ## compiled must have a link to or a copy of the Ignition directory in ## it because this program uses several of the Ignition utility modules. ## ## Change history: ## ## 01/08/03 16 wcs Fixed bug in MakeHTMLInputField routine that converted upper-ascii char set to &#Hex encoding for NonRoman languages... not anymore. ## ## 98/03/30 15 cpt Fixed bug in hidden field calculation (SELECTs missed). ## 98/03/05 14 cpt More logging changes; also some INPUT processing, and ## time stamp modernizations (eliminated `date` calls). ## 98/02/10 13 cpt Updated logging mechanism. ## 97/08/12 12 cpt Updated directory hierarchy mechanism. ## 97/07/18 11 cpt Added mail-merge alternative for dataformats. ## 97/07/10 10 cpt Fixed bug in Checkbox stuff introduced by cookie changes. ## 97/07/03 9 cpt Imporoved cookie handling; added Redirect feature, ## removed FieldVals; changed to uses DoSubstitutions ## callbacks (hence moving back several features that ## properly belonged in this module all along). ## 97/06/10 8 cpt Modified some callback parameters for more flexibility. ## 97/02/16 7 cpt Fixed upper-ascii character handling in localized msgs ## and in e-mail forms. ## 97/02/03 6 cpt Made major changes while working on IFAW site. ## 96/12/17 5 cpt Added non-persistent fields setting. ## 96/11/15 4 cpt Added support for generic & custom settings.txt file. ## 96/11/15 3 cpt Added cookies. ## Moved method of specifying required fields ## into the settings.txt file. ## Made upper-Ascii characters work correctly. ## Changed method of cleaning up input fields. ## Now handle multi-line fields more gracefully. ## Added option for writing log in Mac upper-ascii. ## 96/10/10 2 cpt Added features in support of Ignition website. ## 96/08/09 1 cpt Started based on earlier index.pl. ### VGCGI likes to look in all of these directories, in order, for ### its various files, including other modules. BEGIN {unshift @INC, (<.>, <./VGCGI_data>, <./VGCGI_site>, <./VGCGI>);} ### The following Ignition, Inc. modules are typically found under the ./VGCGI/ directory. use Ignition::Util; use Ignition::Cgiutf8; use Ignition::Sendmail; use Ignition::Fmpread; use Ignition::File; ### These standard perl modules are usually part of the perl system installation. use strict; use CGI::Carp qw(fatalsToBrowser); ### We use this mechanism to locate files that this script opens... ### it searches each directory in @INC in order; if a readable file ### by the given name is found, then the full path is returned. sub FindFile { my ($FileName) = @_; foreach (@INC) { my $Path = "$_/$FileName"; return($Path) if ((-f $Path) && (-r $Path)); } return(undef); } ### Read (require) in any files containing callback routines. foreach ('callbacks.site.pl', 'callbacks.pl') { my $Path = &FindFile($_); require $Path if $Path; } ### Read the settings from a succession of settings*.txt files: ### 1) settings.defaults.txt ## A specification of all settings; plus defaults. ### 2) settings.site.txt ## Site-based overrides of the defaults. ### 3) settings.txt ## Any overridden items for the particular form at hand. foreach ('settings.defaults.txt', 'settings.site.txt', 'settings.txt') { my $Path = &FindFile($_); &ReadSettingsFile($Path, \%Settings) if $Path; } ### Figure out the path we're going to use for the log file and/or ### cookies. We find it by searching three files in order, stopping ### as soon as we find a match for the server name or host name we're ### executing on. Then, if the returned directory can't be written, ### we undef $LogDir. my $LogDir = &FindLogDir(); sub FindLogDir { my $LogDir; $LogDir = &GetHostDependentPath(map{my $Path = &FindFile($_); ($Path ? $Path : ());} ('logdir.txt', 'logdir.site.txt', 'logdir.defaults.txt')) || './'; $LogDir =~ s/([^\/])$/\1\//; ## Make sure $LogDir ends in a slash. $LogDir = undef if (!((-d $LogDir) && (-w $LogDir)) && !$Settings{'SETTING_FORCE_LOG'}); return($LogDir); } ### We take a similar approach with the cookies directory; if it is left unspecified, ### then we'll use the $LogDir as the default (necessary for backward compatibility, ### when logdir was used for both logs and cookies. my $CookieDir = &GetHostDependentPath(map{my $Path = &FindFile($_); ($Path ? $Path : ());} ('cookiedir.txt', 'cookiedir.site.txt', 'cookiedir.defaults.txt')); $CookieDir =~ s/([^\/])$/\1\//; ## Make sure $CookieDir ends in a slash. $CookieDir = $LogDir if (!((-d $CookieDir) && (-w $CookieDir))); ### Set the callback routines that allow this program to extend the behavior ### of DoSubstitutions: &AddDoSubstitutionsCallback('PreWrapper', \&HTML_ENCODINGSubsCallback); &AddDoSubstitutionsCallback('PostSimple', \&INPUT_andOUTPUT_SubsCallback); ## This is a hash whose keys indicate languages that are non-Roman, ## and therefore should not have their upper-ASCII characters mapped ## to the ISO Latin1 character set. (right now, this setting probably ## only includes "Japanese"). my %NonRomanLanguages = map {($_, 1)} split(/\s+/, $Settings{'SETTING_NON_ROMAN_LANGUAGES'}); ## ('Japanese') ### Read the CGI query pairs. my %CGIQueryPairs = &ReadQueryStrings(); ### COOKIE STUFF: RETRIEVAL STAGE ### ### We retrieve the user's persistent data from the cookie database. my $UseCookies = ($Settings{'SETTING_USE_COOKIE'}); my %CookieStateFileHash; my $CookieStateFile; my %CookieHash; my ($SendCookie, $NewCookie, $RawCookie, $CookieName, $CookieExpires, $CookiePath); $main::CookieValue = 0; if ($UseCookies && $CookieDir) { if ($Settings{'SETTING_OVERRIDE_PER_URL_COOKIE_PATH'}) { $CookiePath = $Settings{'SETTING_COOKIE_PER_SITE_PATH'}; ## If the cookie path is entirely contained in the url of this script ## as given by the SCRIPT_NAME environment variable, then change CookiePath ## to be that entire URL, up to and including the $CookiePath portion. ## ## For example, say that $CookiePath is /seals, but the ## actual URL is /staging/seals/foo/index.cgi. We'll convert ## $CookiePath to be /staging/seals $CookiePath = $1 if ($ENV{'SCRIPT_NAME'} =~ /^(.*?\Q$CookiePath\E)/i); } $CookieName = $Settings{'SETTING_COOKIE_NAME'} || "form_data_id"; ## Either retrieve the current cookie or make up a new, random one. if (($RawCookie = $ENV{'HTTP_COOKIE'}) =~ /\Q$CookieName\E/) { my @CookieArray = split(/; /,$ENV{'HTTP_COOKIE'}); foreach(@CookieArray) { if($_ =~ /$CookieName/) { ($CookieName, $main::CookieValue) = split (/=/,$_); } } } ## We're going to create a new cookie since one wasn't found. ## We also implement a little debugging feature: passing ?ForceNewCookie=1 in ## the URL forces a new cookie to be set (and the old cookie entry effectively orphaned). $NewCookie = ((exists($CGIQueryPairs{'ForceNewCookie'})) || (!$main::CookieValue)); ## If that didn't yield a cookie value, make up a new one. if ($NewCookie) { ### The cookie value is srand(unpack("%16C*", $ENV{'REMOTE_ADDR'})); $main::CookieValue = time() . 'X' . (int(rand(99999))); } ## Our cookies last forever. Or until the year 2019, anyway. $CookieExpires = "Wednesday, 09-Sep-2019 09:09:09 GMT"; ## Determine the host-dependent file name of the cookie database. $CookieStateFile = "$CookieDir$Settings{'SETTING_COOKIE_DB_FILE'}"; ### Open the cookie database and get the current cookie: either indirectly ### by using the dbmglue.pl script, or directly by using the GDBM_File module. my $CookieDatabaseEntry; if ($Settings{'SETTING_USE_DBM_GLUE_SCRIPT'}) { $CookieDatabaseEntry = `perl dbmglue.pl $CookieStateFile -retrieve $main::CookieValue`; } else { require GDBM_File; import GDBM_File; ## Does not compile properly in Compiler-a3 tie (%CookieStateFileHash, "GDBM_File", $CookieStateFile, &GDBM_WRCREAT, 0777) || die "Failed to open cookie file $CookieStateFile"; $CookieDatabaseEntry = $CookieStateFileHash{$main::CookieValue}; } ### Convert the cookie database entry into a hash. $QueryPairs{'!!Debug_CookieDBEntry'} = $CookieDatabaseEntry; foreach (split(/\002\002/, $CookieDatabaseEntry)) {my ($key,$value) = split(/\001/, $_); $CookieHash{$key} = $value;} } ### This special CGI query value is only used to reset the cookies; we delete ### it here so it doesn't persist and cause them to keep getting reset. delete $CGIQueryPairs{'ForceNewCookie'}; ### Fix check box values in the incoming CGI query pairs -- The way ### this system implements checkboxes, they initially arrive as ### multiple keys: Check_Item_1, Check_ItemName_2, etc; this routine ### puts them back into a single item. &ReAggregateCheckBoxPairs(\%CGIQueryPairs); ### Initialize the global QueryPairs hash with the cookie values, overlaid ### by the values that came in from the CGI interface. This allows any ### values from the command line or from a form Submit action to override ### any that might have been stored in the cookies. ### ### The QueryPairs hash is actually currently owned by the Util module. %QueryPairs = (%CookieHash, %CGIQueryPairs); ### Clean up the entries by removing leading or trailing whitespace or returns ### and by converting various newline combinations into newline characters foreach (keys(%QueryPairs)) { $QueryPairs{$_} =~ s/(\x0D\x0A)|([\x0D\x0A\x0B])/\n/gs; $QueryPairs{$_} =~ s/^\s+//s; $QueryPairs{$_} =~ s/\s+$//s; $QueryPairs{$_} =~ s/\t/ /gs; } ## If necessary, any QueryPairs values can be hard-coded here to ## test the script from the command line. if (0) ### DEBUGGING! { $QueryPairs{'foo'} =1; } ## Another debugging feature: If there is a writeable file in the ## current directory called ".lastquery", it will be overwritten with ## a dump of the key/value pairs in QueryPairs that were in effect the ## last time the script was run from a non-TTY interface (likely from ## a CGI interface). ## ## Then, if the script is later called from the command-line interface ## with "redo" passed as the first command-line argument, the saved query ## pairs will be used, allowing command-line testing of a failing set ## of queries. if ($ARGV[0] eq 'redo') { eval &ReadEntireFile('.lastquery'); } else { if ((! (-t STDIN)) && ((-e '.lastquery') && (-w '.lastquery'))) { my $QPairsDump = join("\n", map {"\$QueryPairs{\'$_\'} = \'".&HTMLQuoteMeta($QueryPairs{$_})."\'\;"} (sort keys(%QueryPairs))); &WriteEntireFile('.lastquery', \$QPairsDump); chmod (0777, (<.lastquery>)); } } ### Figure out the name of the script that is currently running. ### This variable will be inserted into the
tag ### using the syntax VARIABLE_ScriptName ($ENV{'SCRIPT_NAME'} =~ m/([^\/]+)$/) && ($main::ScriptName = $1) || ($main::ScriptName = $Settings{'SETTING_SCRIPT_NAME'}); ### If the scrpt name is "index.cgi", assume that the server treats ### this as the "index" program, and that therefore we can just ### refer to "./" in order to get us back to this same script. $main::FormAction = ($Settings{'SETTING_USE_INDEX_CGI_SHORTCUT'} ? ## Should we abbrev "index.cgi" as ./ ??? ($main::ScriptName eq 'index.cgi' ? './' : $main::ScriptName) : ## If so, do so. $main::ScriptName); ## Otherwise, use index.cgi. ### First read in the simple, non-localized message files to start ### building the %Messages lookup hash. All of these files are ### in tab-delimited "settings file" format. foreach ('messages.defaults.txt', 'messages.generic.site.txt', 'messages.generic.txt') { my $Path = &FindFile($_); &ReadSettingsFile($Path, \%Messages, "", 1) if $Path; } ### Get the SETTING_LANG_ACCEPT_MAP into a few useful forms.a my @LangMapItems = split(/\s+/, $Settings{'SETTING_LANG_ACCEPT_MAP'}); my %LangAcceptMap = @LangMapItems; my %LangAbbrevMap; @LangAbbrevMap{values %LangAcceptMap} = keys(%LangAcceptMap); my @PreferredLangs = @LangMapItems[map {($_ * 2) + 1} ($[ .. int($#LangMapItems / 2))]; ## odd-numbered entries. ### Get default language from a setting. my $DefaultLanguage = $Settings{'SETTING_DEFAULT_LANGUAGE'} || 'English'; ### Set our target language based on the request implied by ### the query pairs, or lacking that, based on the file ### 'settings.targetlang.txt', or, lacking that, by matching ### up a language from HTTP_ACCEPT_LANGUAGE, or, finally, ### set it to $DefaultLanguage. my $TargetLanguage = ($QueryPairs{$Settings{'SETTING_DEFAULT_LANGUAGE_QUERY'}} || &ReadEntireFile('settings.targetlang.txt') || $LangAcceptMap{substr($ENV{HTTP_ACCEPT_LANGUAGE}, 0, 2)} || $DefaultLanguage); ### Read Merge file(s) containing a databases of localized versions of ### UI strings in various languages, including English. ### This could have the side effect of switching the $TargetLanguage ### in the case where the $TargetLanguage is not found in one of the ### databases. foreach ('messages.local.site.txt', 'messages.local.txt') { my $MessagesFile = &FindFile($_); if ($MessagesFile) { my ($DBRef) = &ReadFMPMergeFile($MessagesFile, 1); ### Verify that the target language is available in the ### localizations database. If it is not, then back it off to ### $DefaultLanguage. $TargetLanguage = $DefaultLanguage if ($DBRef && !exists($$DBRef{$TargetLanguage})); ### Read in localized versions of UI strings. &FillHashFromFMProDatabase("", 'Message' => $TargetLanguage, \%Messages, 0, ## Do not map Upper-ASCII chars now; wait to do entire page. $DBRef ) if ($DBRef && exists($$DBRef{$TargetLanguage})); } } ### Remember the $TargetLanguage setting in the query pairs so it becomes persistent. $QueryPairs{$Settings{'SETTING_DEFAULT_LANGUAGE_QUERY'}} = $TargetLanguage; ### Now, choose a two-character language abbreviation that matches the ### $TargetLanguage, or "en" if none is found. $main::LA = $LangAbbrevMap{$TargetLanguage} || 'en'; ## Now all the messages have been read in. This includes many human-readable ## strings that may have Mac upper-ascii characters in them. ## Convert all Mac upper-ascii characters in the Messages hash to ISO. ## if (($QueryPairs{'lang'} ne 'TW') && ($QueryPairs{'lang'} ne 'CN')){ map {&MacToISO(\$Messages{$_});} (keys(%Messages)) unless $NonRomanLanguages{$TargetLanguage}; } ### Set some useful date-formatting variables that can later ### be included via the VARIABLE_XXX mechanisms (e.g. VARIABLE_LongDate) if ($Settings{'SETTING_USE_LOCALIZED_TIME_STAMPS'}) { ## First translate the $TargetLanugage setting into a $Locale setting using the ## locale table setting, overridden by any overrides. my $Locale = $ {{split(/\s+/, "$Settings{'SETTING_LOCALE_TABLE'} $Settings{'SETTING_LOCALE_OVERRIDES'}")}} {$TargetLanguage}; ## Then get the time stamps by calling GetLocalizedTimeStamps in Ignition::Util. (($main::TimeStamp, $main::ShortDate, $main::LongDate) = &GetLocalizedTimeStamps($Locale)); $Settings{'A_LOCALE'} = $Locale; $Settings{'A_TIMESTAMP'} = $main::TimeStamp; $Settings{'A_SHORTDATE'} = $main::ShortDate; $Settings{'A_LONGDATE'} = $main::LongDate; } else { my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); $main::ShortDate = sprintf("%02d/%02d/%04d", $mon+1, $mday, $year+1900); $main::TimeStamp = sprintf("%02d:%02d:%02d", $hour, $min, $sec); use POSIX; ($main::LongDate = strftime("%B %e, %Y", $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst)) =~ s/\s+/ /g; } ### Read in the info that describes the format and content of the data input fields. foreach ('dataformat.defaults.txt', 'dataformat.site.txt', 'dataformat.txt') { my $Path = &FindFile($_); &ReadDataFormatDescription($Path, \%main::MaxLens, \%main::MinLens, \%main::FieldTypes, \%main::DefaultVals, \%main::ValueHashRefs, \%main::ValueArrayRefs) if $Path; } ## The program state is now considered to be more or less fully initialized. ## If this script was called from the command line with a first ## argument of "init", then we call any "init" code in if (-t STDIN && ($ARGV[0] eq 'init')) { &RunCallbackRoutine('OneTimeInit'); } ## Run the post-init callback routine (if any). We let it have a crack at the ## QueryPairs, and also at the data format descriptions, in case it wants to adjust ## anything. &RunCallbackRoutine('PostInitCallback', \%QueryPairs, \%main::ValueHashRefs, \%main::ValueArrayRefs, $LogDir); ### Get hash whose keys and values list the required fields mentioned in the ### settings file. %main::RequiredFields = map {($_, $_);} split(/\s+/, $Settings{'SETTING_REQUIRED_FIELDS'}); ## These arrays of hashes keep track of which INPUT_ and OUTPUT_ fields ## are present on which pages. my %AllINPUTFields; my %AllOUTPUTFields; my @PageINPUTFields; my @PageOUTPUTFields; ## Figure out what the names of our page files will be. ## We prefer page*.html in the current directory, then the VGCGI_data ## directory. If no such files are found, then we look for index*.html in ## the same manner. my @PageFileNames = sort(<./page*.html>,<./page*.htm>, <./VGCGI_data/page*.html>, <./VGCGI_data/page*.htm>); @PageFileNames = sort(<./index*.html>, <./index*.htm>, <./VGCGI_data/index*.html>, <./VGCGI_data/index*.htm>) unless @PageFileNames; $main::NumPages = @PageFileNames; die "No page templates found" unless $main::NumPages; ### Read in the HTML pages (we need them all because we have to ### be sure to insert the correct hidden fields in each page ### which doesn't mention any field that is mentioned in other ### pages. my @PageFileContents; my $PageNum; for $PageNum (1..$main::NumPages) { my $FileContents = &ReadEntireFile($PageFileNames[$PageNum-1]); ### We assume that any incoming upper-ASCII chars, if any, in the incoming file contents ### are in Mac format and need to be HTML-ized. ### ### Map upper-ASCII characters to their HTML equivalents unless this language is ### a non-Roman language. if (($QueryPairs{'lang'} ne 'TW') && ($QueryPairs{'lang'} ne 'CN')){ &MacToHTML(\$FileContents) unless $NonRomanLanguages{$TargetLanguage}; } $PageFileContents[$PageNum] = $FileContents; ### Extract the field name of any input or output fields mentioned on the page ### and remember them in some appropriate hashes. while ($FileContents =~ m/(?:(INPUT_)|(OUTPUT_))([A-Za-z0-9\.]+)/g) { ($1 ? do { $AllINPUTFields{$3} = 1; $PageINPUTFields[$PageNum]{$3} = 1} : ## An input field do { $AllOUTPUTFields{$3} = 1; $PageOUTPUTFields[$PageNum]{$3} = 1} ## An output field ); } while ($FileContents =~ m/<(?:(?:INPUT)|(?:TEXTAREA))\b.*?NAME\s*=\s*(\")?([A-Za-z0-9_]+)\1/ig) { ## An input field $AllINPUTFields{$2} = 1; $PageINPUTFields[$PageNum]{$2} = 1; } } ### If any fields have not been supplied, fill in the default values: my $FirstTime = (!(exists($QueryPairs{'CUR_PAGE'}))); if ($FirstTime) { ### If any fields have not been supplied, fill in the default values: my $FieldName; foreach $FieldName (keys(%main::DefaultVals)) { if (exists($AllINPUTFields{$FieldName}) && !exists($QueryPairs{$FieldName})) { $QueryPairs{$FieldName} = $main::DefaultVals{$FieldName}; } } } ### Figure out which page we are trying to go to. $main::CurPage = ($QueryPairs{'CUR_PAGE'} < 1 ? 1 : $QueryPairs{'CUR_PAGE'}); # Remember the page we were on because we will have to return here # if the data validation fails. my $PrevPage; if (exists($QueryPairs{'CUR_PAGE'})) { $PrevPage = $main::CurPage; } else { $PrevPage = 0; } ### Special case for check boxes: If the check box is on the current ### page, but not checked, its field will be absent from ### QueryPairs. Add it to QueryPairs and set it to zero. my $CheckBoxFields = [grep {$main::FieldTypes{$_} =~ m/(Check Box\b)|(Boolean)/i} keys %main::FieldTypes]; foreach (@$CheckBoxFields) { if (exists($PageINPUTFields[$main::CurPage]{$_}) && !exists($QueryPairs{$_})) { $QueryPairs{$_} = 0; } } ### If this is not the first page, we have to validate the user's data. ### Validate the fields; making note of any fields that don't match ### their respective requirements; during the upcoming validation block ### we also call the validation callback, which is where most customization ### work will be accomplished, including, but not limited to, custom validation ### routines for certain fields. my @BadFields; my @EmptyFields; my @ShortFields; my @LongFields; my ($CallbackInvalidFields, $CallbackValidationErrorDescs, $CallbackValidationErrorMarks); if ($PrevPage != 0) { # First: check that required fields have length > 0 my $tag; foreach $tag (keys(%main::RequiredFields)) { next if (!exists($PageINPUTFields[$main::CurPage]{$tag})); if (length($QueryPairs{$tag}) < 1) { push @EmptyFields, $tag; push @BadFields, $tag; } } # Next: check that fields obey the minimum length requirements foreach $tag (keys(%main::MinLens)) { next if (!exists($PageINPUTFields[$main::CurPage]{$tag})); if ((length($QueryPairs{$tag}) > 0) && (length($QueryPairs{$tag}) < $main::MinLens{$tag})) { push @ShortFields, $tag; push @BadFields, $tag; } } # Then make sure fields with maximum lengths are not too long. foreach $tag (keys(%main::MaxLens)) { next if (!exists($PageINPUTFields[$main::CurPage]{$tag})); if (length($QueryPairs{$tag}) > $main::MaxLens{$tag}) { push @LongFields, $tag; push @BadFields, $tag; } } ## Let the field validation callback have a crack at validating fields that ## were to have been entered on this page ($CallbackInvalidFields, ## Names of invalid fields must be pushed onto this array. $CallbackValidationErrorDescs, $CallbackValidationErrorMarks) = &RunCallbackRoutine('FieldValidationCallBack', \%QueryPairs, ## These are the key/value pairs the routine must validate $main::CurPage, ## Page # user was on; usually 1 for a two-page form. $PageINPUTFields[$main::CurPage], ## Hash of which INPUT fields are on the cur. page. $PageOUTPUTFields[$main::CurPage],## Hash of which OUTPUT fields are on the cur. page. $main::NumPages, ## Total number of pages. ); push @BadFields, @$CallbackInvalidFields if $CallbackInvalidFields; } ## If we are here because the user hit the Prev or Next buttons, ## increment or decrement the page counter appropriately. if ((exists($QueryPairs{'SUBMIT_PREV'})) || (exists($QueryPairs{'SUBMIT_PREV.x'}))) { $main::CurPage--; undef @BadFields; ## forget validation problems ## no need to validate when prev button is hit. } ## ... but if any fields have been marked as bad, ## Do NOT change the page number, since something went wrong with the validation. elsif (@BadFields) { } ## ...otherwise, check whether the submit button was hit; if so, advance the page number. elsif ((exists($QueryPairs{'SUBMIT_NEXT'})) || (exists($QueryPairs{'SUBMIT_NEXT.x'}))) { $main::CurPage++; } ## Make sure the page number bounds are still reasonable $main::CurPage = ($QueryPairs{'CUR_PAGE'} < 1 ? 1 : $main::CurPage); $main::CurPage = ($main::CurPage > $main::NumPages ? $main::NumPages : $main::CurPage); ### Set the query pair value CUR_PAGE so we'll know next time which page we came from. $QueryPairs{'CUR_PAGE'} = $main::CurPage; # Now that validation has been accomplished, if we have agreed that # we're about to display the final page of the sequence, it means this # is the session in which we'll need to log the transaction and/or # submit the results of the form. my $FinalPageSubmitAttempt = ($main::CurPage == $main::NumPages); ### Remember that this page has been submitted ### ### If this is the final page submit attempt, AND the user requested it, ### set a field which indicates the form has been successfully completed. ### ### This feature is mainly useful if a different form which shares the same ### cookie file wants to know that the other form was completed, OR, if ### the NEXT time the form is run, we the form might want to let the user ### know that they've already submitted the form N times before. my $FieldValToIncrementOnFinalPageSubmit = $Settings{'SETTING_FIELDVAL_TO_INCREMENT_ON_PAGE_SUBMIT'}; if ($FinalPageSubmitAttempt && $FieldValToIncrementOnFinalPageSubmit) { $QueryPairs{$FieldValToIncrementOnFinalPageSubmit}++; } ## Now we know which page we are going to show. Retrieve it and ## start preparing it for display my $FileContents = $PageFileContents[$main::CurPage]; ## contents of file "pageX.[Lang].html" ### This is the callback which allows the customization module to take care of its special ### purpose when the page has been submitted and validated. if ($FinalPageSubmitAttempt) { my ($AlternateFileContentsRef) = &RunCallbackRoutine('PageSubmissionCallback', $main::CurPage); ### Allow the callback routine to replace the entire file contents if it desires. ### This is NOT typically done. if ($AlternateFileContentsRef && $$AlternateFileContentsRef) { $FileContents = $$AlternateFileContentsRef; } } ## Perform substitutions as appropriate. This handles MESSAGE_*, ## SETTING_* INPUT_*, VARIABLE__*, and other automatically-replaceable values. $FileContents = &DoSubstitutions($FileContents); ## Replace the special symbol ?APPEND_QUERY_STRING with an HTTP query string ## sufficient to re-create the behavior of the form as it was originally referred to. $FileContents =~ s/\?APPEND_QUERY_STRING/($ENV{'QUERY_STRING'} && "?$ENV{'QUERY_STRING'}")/egis; ## If there are any bad fields, we calculate relevant error messages ## and put marks next to each field containing bad data. ### Calculation / insertion of error messages my $ErrorMessage = ""; if (@BadFields) { $Debug::Validation_InvalidFields = "@BadFields (@$CallbackInvalidFields)" if $CallbackInvalidFields && ($QueryPairs{'Debug'}); $Debug::Validation_CallbackErrorDescs = "@{[%$CallbackValidationErrorDescs]}" if $CallbackValidationErrorDescs && ($QueryPairs{'Debug'}); $ErrorMessage = &MessageLookup('MESSAGE_REQUIRED_FIELDS_INTRO_HTML') || "Certain fields are required."; $ErrorMessage .= &MessageLookup('MESSAGE_REQUIRED_FIELDS_NOT_ENTERED_HTML') if @EmptyFields; $ErrorMessage .= &MessageLookup('MESSAGE_REQUIRED_FIELDS_TOO_SHORT_HTML') if @ShortFields; $ErrorMessage .= &MessageLookup('MESSAGE_REQUIRED_FIELDS_TOO_LONG_HTML') if @LongFields; ## Now, handle any error messages & markers generated by the callback routine. if ($CallbackInvalidFields) { foreach (@$CallbackInvalidFields) { $ErrorMessage .= &Localize($$CallbackValidationErrorDescs{$_}); my $ErrorMark .= &Localize($$CallbackValidationErrorMarks{$_}); &MarkInputFields(\$FileContents, $ErrorMark, $_); } } $ErrorMessage .= &MessageLookup('MESSAGE_REQUIRED_FIELDS_TRAILER_HTML') || "Please make the indicated corrections."; &MarkInputFields(\$FileContents, &MessageLookup('MESSAGE_MISSING_FIELD_INDICATOR'), @EmptyFields); &MarkInputFields(\$FileContents, &MessageLookup('MESSAGE_TOO_SHORT_FIELD_INDICATOR_HTML'), @ShortFields); &MarkInputFields(\$FileContents, &MessageLookup('MESSAGE_TOO_LONG_FIELD_INDICATOR_HTML'), @LongFields); } ### Insert any error message into the space that is otherwise occupied ### by introductory material. ### !!@ TO DO: Is there possibly a cleaner way to do this in the future? if ($ErrorMessage) { $ErrorMessage = &DoSubstitutions($ErrorMessage); my $IntroMsgTag = 'INTRO_MSG_THAT_GETS_REPLACED_WITH_ERROR_MSGS'; $FileContents =~ s/<$IntroMsgTag>.*?<\/$IntroMsgTag>\s*?\n?/$ErrorMessage/igs; } ### Calculate the hidden fields for the page we are on: my %NonHiddenFields; @NonHiddenFields{split(/\s+/, $Settings{SETTING_NON_HIDDEN_FIELDS})} = (1); my %NonPersistentFields; @NonPersistentFields{split(/\s+/, $Settings{SETTING_NON_PERSISTENT_FIELDS})} = (1) if $FinalPageSubmitAttempt; ## Figure out which INPUT fields are still on the page (following the ## DoSubstitutions that might have removed or added some). my %InputFieldsStillOnPage; while ($FileContents =~ m/<(?:(?:INPUT)|(?:TEXTAREA)|(?:SELECT))\b.*?NAME\s*=\s*(\")?([A-Za-z0-9_]+)\1/ig) { $InputFieldsStillOnPage{$2} = 1; } ## Calculate the list of hidden fields that should be included on this ## form. my @HiddenFields = (grep { !(/SUBMIT_/i || ## Don't propagate any submit_ buttons. /ERROR_/i || ## Don't propagate Error_ flags. exists($PageINPUTFields[$main::CurPage]{$_}) || ## Don't put hidden if there's an INPUT_ on this page. exists($InputFieldsStillOnPage{$_}) || ## Don't put a hidden field if the real field is on this page. exists($NonHiddenFields{$_}) || ## Don't put a hidden field if specifically omitted by user. exists($NonPersistentFields{$_})); ## Don't save certain fields if this is last page. } grep {!/^Check_/} (keys(%QueryPairs))); ## Create the HTML markups for the hidden items. my $HiddenFields = join("\n", (map { my $QuotedFieldVal = &HTMLQuoteMeta($QueryPairs{$_}); &ISOCharsToHTMLQuoted(\$QuotedFieldVal); qq||; } @HiddenFields)); ## Support archaic BEGIN_FORM_HERE and END_FORM_HERE syntax. $FileContents =~ s/\bBEGIN_FORM_HERE(_TARGET\((.+?)\))?/ ""/egs; $FileContents =~ s/\bEND_FORM_HERE\b/<\/FORM>\n/gs; ## Adjust the beginning FORM so it has the proper ACTION and METHOD. $FileContents =~ s{} { my $Params = $1; my %Attributes; &ParseAttributes($Params, \%Attributes); $Attributes{'METHOD'} = 'POST'; $Attributes{'ACTION'} = $Attributes{'FORCEACTION'} || $main::FormAction; delete $Attributes{'FORCEACTION'}; $Params = &UnparseAttributes(\%Attributes); ""; }eigos; $FileContents =~ s/\bBEGIN_FORM_HERE(_TARGET\((.+?)\))?/ ""/egs; ## Finally, we insert hidden fields are inserted right before the tag. $FileContents =~ s{}{$HiddenFields\n\n}ig; ## Insert the code for next/back buttons, if any. ## Default titles for the buttons are determined by looking up two messages. ## The page template can override the defaults by adding the optional "Name" attribute ## to the XXXX_BUTTON_HERE markup. my $NextButtonTitle = &MessageLookup('MESSAGE_NEXT_BUTTON_TITLE_HTML'); my $PrevButtonTitle = &MessageLookup('MESSAGE_PREV_BUTTON_TITLE_HTML'); $FileContents =~ s// ''/egis; $FileContents =~ s// ''/egis; ## Process any server-side include directives in the source file. ## Calculate $DocRoot either from an environment variable or from a ## successive search of docroot.* files. my $DocRoot = $ENV{'DOCUMENT_ROOT'}; if (!$DocRoot) { $DocRoot = &GetHostDependentPath(map{my $Path = &FindFile($_); ($Path ? $Path : ());} ('docroot.txt', 'docroot.site.txt', 'docroot.defaults.txt')); $DocRoot =~ s/([^\/])$/\1\//; ## Make sure $DocRoot ends in a slash. } $DocRoot = undef if (!((-d $DocRoot) && (-r $DocRoot))); ## Make sure it's a readable directory. =head my($IncludeFile); my($IncludeFileContents); my($RelativePath); while ($FileContents =~ m//i) { $RelativePath = $1; $IncludeFile = $DocRoot . $RelativePath; ($IncludeFileContents = &output_included_file($IncludeFile)) || ( ## If the include file was not found, insert an error message ## in place of virtual include statement. $FileContents =~ s// [CGI-Processed Server-Side Include ERROR: $IncludeFile not found.]/i, next ); ## Insert the contents of the virtual include file in place of the virtual include statement. $FileContents =~ s//$IncludeFileContents/i; } # clechner: added support for wwwimages while ($FileContents =~ m//i) { print "clechner\n"; $FileContents =~ s//wwwimages.adobe.com/i; } =cut &ProcessServerSideIncludes(\$FileContents, $ENV{'DOCUMENT_ROOT'} || $DocRoot) if ($DocRoot); while ($FileContents =~ m//i) { $FileContents =~ s//http:\/\/wwwimages.adobe.com/i; } ### COOKIE STUFF: STORAGE STAGE ### ### At this stage, we store the info from the $QueryPairs into %CookieHash ### and write it out. if ($UseCookies) { if (!$FirstTime) { ## This is not the first the page has been run this session: save cookie data. ## The data being saved will include any items in any fields on the page, plus ## any items that were already in the cookie hash, but may not be used on this form. ### Calculate which fields the designer/programmer doesn't ### want stored in the cookies. The code below allows a * to ### appear in any entry in SETTING_NON_COOKIED_FIELDS to match ### a class of field names, such as FOO_* or BAR_* my %NonCookiedFields = map {($_ , 1);} split(' ', $Settings{'SETTING_NON_COOKIED_FIELDS'}); my $AllFields = "@{[keys(%QueryPairs)]}"; ## Get a string of all the fields. foreach (map {(s/\*/\.\*\?/ ? ($_) : ())} keys(%NonCookiedFields)) ## Make FOO_* and BAR_* into patterns {map {$NonCookiedFields{$_} = 1} ($AllFields =~ m/\b($_)\b/g)} ## Then add any matching fields into %NCF ## $Debug::NonCookiedFields = "@{[keys(%NonCookiedFields)]}"; ## Insert/replace into the cookie hash all of the field vals for the fields relevant to this form set. my $key; foreach $key (keys(%QueryPairs)) { next if ($key =~ m/CUR_PAGE/); ## Skip the CUR_PAGE parameter; it is used internally. next if ($key =~ m/^SUBMIT_/i); ## Skip the SUBMIT_ buttons. next if ($key =~ m/^Debug/i); ## Skip the debugging field. next if ($key =~ m/^$Settings{'SETTING_DEFAULT_LANGUAGE_QUERY'}/i); ## Skip the language setting. next if (exists($NonPersistentFields{$key})); ## Skip fields that are never supposed to persist. next if (exists($NonCookiedFields{$key})); ## Skip fields that are not supposed to be in cookie db. next if ($key =~ /[\001\002]/); ## Skip any keys with control chars 1 or 2 in them. next if ($QueryPairs{$key} =~ /[\001\002]/); ## Skip any fields with control chars 1 or 2 in them. $CookieHash{$key} = $QueryPairs{$key}; }; ## Finally, create a single text field with all the key/value pairs... my $CookieDatabaseEntry = join("\002\002", map {"$_\001$CookieHash{$_}"} keys(%CookieHash)); ## ... and write that entry back out to the cookie database. if ($Settings{'SETTING_USE_DBM_GLUE_SCRIPT'}) { my $DBMGluePath; if ($DBMGluePath = &FindFile('dbmglue.pl')) { ## This is the grungy, but compilable way to do it using the dbmglue.pl script: open COOKIEPIPE, "| perl $DBMGluePath $CookieStateFile -store $main::CookieValue 0777"; print COOKIEPIPE $CookieDatabaseEntry; close COOKIEPIPE; my $Success = (($?>>8) == 0); die "Failed while writing cookie file $CookieStateFile: $!\n" unless $Success; } else { die "Failed to find dbmglue.pl."; } } else { ## This is the nice, easy way to do it directly: $CookieStateFileHash{$main::CookieValue} = $CookieDatabaseEntry; } } ## Close the cookie state database unless ($Settings{'SETTING_USE_DBM_GLUE_SCRIPT'}) { untie(%CookieStateFileHash); ## Give the cookie file liberal permissions. chmod (0777, <$CookieStateFile*>); } } #### Log the Data (send it as an e-mail message) ### If the SETTING_LOG_ENTRY_ONLY_ON_COMPLETION preference is false, write the log ### entry every time. Otherwise, only write it on the occasion of the ### final page submission. my $LogFile; my $LogWritten; my $LogEntry; ## If we are about to make a log entry, call the PreLogCallback. The callback ## will have an opportunity to set $OKToLog to false, preventing the log entry from ## being written. my $OKToLog = ($Settings{'SETTING_LOG_ENTRY'} && ((!$Settings{'SETTING_LOG_ENTRY_ONLY_ON_COMPLETION'}) || $FinalPageSubmitAttempt)); if ($OKToLog) { &RunCallbackRoutine('PreLogCallback', \%QueryPairs, $main::CurPage, $FinalPageSubmitAttempt, \$OKToLog); } if ($OKToLog) { my $DoingMergeFormat = $Settings{SETTING_LOG_FILE_MERGE_FORMAT}; my $MergeQuotes = $Settings{SETTING_LOG_FILE_MERGE_QUOTED_QUOTES}; my ($LinePrefix, $Delimiter, $LineSuffix, $RecordSep) = ($DoingMergeFormat ? ('"', '","', '"', "\n") : ## Merge format delimiters ('', "\t", '', "\n")); ## Tab-delimited format delimiters ## Calculate the log entry by running DoSubstitutions on each item ## listed in SETTING_LOG_FILE_FORMAT (also mapping returns to ASCII 11 and tabs to spaces), ## then concatening all the items with tabs between them. $LogEntry = ($LinePrefix . join($Delimiter, map {my($Field) = &DoSubstitutions($_); $Field =~ s/\t/ /gs if !$DoingMergeFormat; ## Kill tabs if tab-delim. $Field =~ s/\"/\"\"/gs if ($DoingMergeFormat || $MergeQuotes); ## Fix quotes $Field;} split(/\s+/, $Settings{'SETTING_LOG_FILE_FORMAT'})) . $LineSuffix); ## Map any line returns in the log entry to ASCII 11 $LogEntry =~ s/(\x0D\x0A)|([\x0D\x0A])/\x0B/gs; ## Add the $RecordSep, which might be a return. $LogEntry .= $RecordSep; ## Create the log header line, if any. my $LogHeader; if ($Settings{SETTING_LOG_FILE_HEADER_LINE}) { if ($Settings{SETTING_LOG_FILE_HEADER_LINE} == -1) { $LogHeader = ($LinePrefix . join($Delimiter, map {(my $X=$_)=~ s/.*?_(.*)/$1/g; ($X||$_);} split (/\s+/, $Settings{SETTING_LOG_FILE_FORMAT})) . $LineSuffix . $RecordSep); } else { $LogHeader = ($Settings{SETTING_LOG_FILE_HEADER_LINE} . $RecordSep); } } ## If the settings file calls for saving the upper-ascii characters ## (that are presumably coming in as ISO) in Mac format, then we do the mapping now. if ($Settings{'SETTING_MAC_UPPER_ASCII_IN_LOG_FILE'}) { ## This is Chris Thorman's ISO 8859 to Mac table based on Eudora's 100% reversible mapping. $LogEntry =~ tr/\200-\377/\xA5\xAA\xAD\xB0\xB3\xB7\xBA\xBD\xC3\xC5\xC9\xD1\xD4\xD9\xDA\xB6\xC6\xCE\xE2\xE3\xE4\xF0\xF6\xF7\xF9\xFA\xFB\xFD\xFE\xFF\xF5\xC4\xCA\xC1\xA2\xA3\xDB\xB4\xCF\xA4\xAC\xA9\xBB\xC7\xC2\xD0\xA8\xF8\xA1\xB1\xD3\xD2\xAB\xB5\xA6\xE1\xFC\xD5\xBC\xC8\xB9\xB8\xB2\xC0\xCB\xE7\xE5\xCC\x80\x81\xAE\x82\xE9\x83\xE6\xE8\xED\xEA\xEB\xEC\xDC\x84\xF1\xEE\xEF\xCD\x85\xD7\xAF\xF4\xF2\xF3\x86\xA0\xDE\xA7\x88\x87\x89\x8B\x8A\x8C\xBE\x8D\x8F\x8E\x90\x91\x93\x92\x94\x95\xDD\x96\x98\x97\x99\x9B\x9A\xD6\xBF\x9D\x9C\x9E\x9F\xE0\xDF\xD8/; ### This is Bart Lateur's mapping. Commented out for now. ### tr/\200-\377/��������������������ӥ�ј����������#�|������Шѡ����������ȼ���ˇ��������������Є�����ׯ����Y���������؏�����������������y��/; } ## Get the name of the log file and append the log entry to it. $LogFile = "$LogDir$Settings{'SETTING_LOG_FILE'}"; if ($Settings{'SETTING_FORCE_LOG'}) { ## In "Force" mode, we basically insist that the log get written and ## do everything possible to create the log file if necessary. $LogWritten = &WriteLogEntryOrDie($LogFile, $LogEntry, 10, $Settings{'SETTING_FORCE_LOG_EMERGENCY_DIRECTORY'}, $Settings{'SETTING_FORCE_LOG_FAILURE_EMAIL_ADDRESSES'}, $LogHeader, ); } else { ## In non-force mode, we just try to append to the given file ## name, and ignore any failures. $LogWritten = &AppendLogFileEntryWithRetry($LogFile, $LogEntry, 10, $LogHeader); } } ### WriteLogEntryOrDie ($LogFile, $LogEntry, $MaxTries, $TmpDirectory, $EmergencyMailAddresses) ### ### Writes a log entry either to its intended $LogFile, or to an ### alternate location in $TmpDirectory if there are errors. Any sort ### of error (even if there is a success in writing to $TmpDirectory) ### results in a warning messsage being mailed to the address or ### addresses specified in $EmergencyMailAddresses. ### ### If mailing the error messages fails, then this routine dies ### with an informative error message, that will be logged into ### the server's error log. sub WriteLogEntryOrDie { my ($LogFile, $LogEntry, $MaxTries, $TmpDirectory, $EmergencyMailAddresses, $LogHeader) = @_; ## First try to write the log file in its intended location. my ($LogSuccess, $LogErrorMessage) = &AppendOrCreateLogFile($LogFile, $LogEntry, $MaxTries, $LogHeader); goto done if $LogSuccess; ## If the caller did not specify a $TmpDirectory, then give up. goto done unless $TmpDirectory; my $TriedTmpDirectory = 1; ## Try to create a new path by concatening the old path components ## onto the temporary path that was provided. In doing the ## concatenation, we are careful to preserve an initial slash in ## $TmpDirectory (e.g. in /tmp), but we don't preserve any ## "initialness" in $LogFile; also we omit any ".." or "." ## components from $LogFile since they will now be meaningless in ## the context of the new path. my $NewPath = join("/", (split(/\//, $TmpDirectory), grep {((length($_)) && ($_ ne '..') && ($_ ne '.'))} split(/\//, $LogFile))); ## Now write the new entry in a temporary location. my ($TmpSuccess, $TmpErrorMessage) = &AppendOrCreateLogFile($NewPath, $LogEntry, $MaxTries, $LogHeader); done: ## If we're exiting in a failure condition, and the caller ## specified e-mail addresses to be notified, then do the ## notification now. if (!$LogSuccess && $EmergencyMailAddresses) { my $MailSubject = "WARNING: CGI error writing log file $LogFile"; my $MailMessage = "You are receiving this message because you're listed as an administrator in the configuration file for the CGI script located at $ENV{'SCRIPT_NAME'} . There was an error creating the log file in the location $LogFile: $LogErrorMessage "; $MailMessage .= ($TmpSuccess ? "As a backup mechanism, a temporary copy of the log data was saved to the file $NewPath, located under the specified temporary directory $TmpDirectory. You should immediately seek out that file and retrieve its contents before the data is removed by regular disk-cleaning processes." : "UNFORTUNATELY, there was also an error in creating an emergency backup copy of the data in the following location: $NewPath The error encountered was: $TmpErrorMessage Because of this second error, THE E-MAIL MESSAGE YOU ARE READING NOW CONTAINS THE ONLY COPY OF THIS LOG DATA. DON'T DELETE THIS MESSAGE UNTIL YOU HAVE CAPTURED THE DATA."); $MailMessage .= "Between the dotted lines below is a copy of the log data, exactly as it would have appeared in the log file: ----------------------------------------------- $LogEntry ----------------------------------------------- "; ## Now send the warning message to the administrator my ($SendMailSuccess, $SendMailErrorMessage) = &SendMailMessage ('', $Settings{'SETTING_MAIL_FROM_ADDRESS'}, '', $EmergencyMailAddresses, $MailSubject, $MailMessage); ## If there was a failure to send the warning message, then we ## just die here. It's better to cause an error than to let ## the problem go unnoticed. If fatalsToBrowser is turned on, ## then the user will see the message below. In any case, it ## will be logged to the web server's error log, and could be ## retrieved from there. if (!$SendMailSuccess) { die ("There was a problem creating a log entry for this transaction, and a second problem in notifying the administrator of the logging error. The logging error was: $LogErrorMessage The mail error was: $SendMailErrorMessage The log entry was: $LogEntry This transaction cannot continue."); } } return($LogSuccess); } ## If we are about to send a mail message, call the PreMailCallback. The callback ## will have an opportunity to set $OKToSendMail to false, preventing the mail from ## being sent. ## Figure out what the names of our e-mail files will be. ## We prefer mailform*.html in the current directory, then the VGCGI_data ## directory. my @EMailFormFilePaths = sort(<./mailform*.txt>, <./VGCGI_data/mailform*.txt>); my $OKToSendMail = ($FinalPageSubmitAttempt && $Settings{'SETTING_SEND_EMAIL'} && @EMailFormFilePaths && (@EMailFormFilePaths == grep {-f} @EMailFormFilePaths) && (@EMailFormFilePaths == grep {-r} @EMailFormFilePaths) ); $QueryPairs{Debug_OKToSend} .= "$OKToSendMail: $FinalPageSubmitAttempt, $main::CurPage == $main::NumPages, $Settings{'SETTING_SEND_EMAIL'}, @EMailFormFilePaths "; my $EMailFormFile; foreach $EMailFormFile (@EMailFormFilePaths) { my $OKThisMessage = $OKToSendMail; if ($OKThisMessage) { &RunCallbackRoutine('PreMailCallback', \%QueryPairs, $main::CurPage, $FinalPageSubmitAttempt, \$OKThisMessage, $EMailFormFile); } if ($OKThisMessage) { if ($EMailFormFile) { my($EMailMessage) = &ReadEntireFile($EMailFormFile); ## The incoming e-mail message template file is assumed to be in ## Mac format. If it has any upper-ascii characters, map them to ISO. ## Ideally, any such characters would be part of the localized messages ## file, and would already have been taken care of, but then again, this ## could be a form that isn't planned for localization... if (($QueryPairs{'lang'} ne 'TW') && ($QueryPairs{'lang'} ne 'CN')){ &MacToISO(\$EMailMessage) unless $NonRomanLanguages{$TargetLanguage}; } $EMailMessage = &DoSubstitutions($EMailMessage); ## Now fix Nestscape's broken ISO mappings: &NetscapeISOToEudoraISO8859(\$EMailMessage) unless $NonRomanLanguages{$TargetLanguage}; ## And finally send the message. my ($SendMailSuccess, $SendMailErrorMessage) = &SendEntireMailMessage("From: $Settings{'SETTING_MAIL_FROM_ADDRESS'}\n$EMailMessage"); $QueryPairs{Debug_MailSent} .= "$EMailFormFile: $SendMailSuccess \n"; } } } ### Extract any optional HTML headers, such as redirects. ### These can be specified in the page template using the syntax . ### This allows the simple creation of redirect behavior. my @AdditionalHeaders; $FileContents =~ s//push @AdditionalHeaders, $1; '';/egois; ## $Debug::AdditionalHeaders = "@AdditionalHeaders" if @AdditionalHeaders; ### Return the form & exit. &ReturnHTMLFormToCGI(\$FileContents, ($NewCookie ? ($CookieName, $main::CookieValue, $CookieExpires, $CookiePath) : (undef, undef, undef, undef)), undef, undef, \@AdditionalHeaders); done: #### DEBUGGING INFO: append "?Debug=1" or a password if specified #### to the opening URL to turn it on. #if (1) if ($QueryPairs{'Debug'} eq ($Settings{'SETTING_DEBUG_PASSWORD'} || '1')) { ## In case this hasn't been done before we get here... print("Content-Type: text/html\n\n"); print "DEBUGGING INFORMATION: (PLEASE IGNORE)
\n"; print "Query Pairs:
\n"; my $key; foreach $key (sort keys(%QueryPairs)) { print "\$QueryPairs{\'$key\'} = \'" . &HTMLQuoteMeta($QueryPairs{$key}) . "\'\;
\n"; } ## Dump every variable in the Debug:: namespace: if (keys(%Debug:: )) { print "
Debug:: Variables:
\n"; foreach $key (sort keys(%Debug::)) { no strict 'refs'; print "\$Debug::{\'$key\'} = \'" . &HTMLQuoteMeta(${"Debug::$key"}) . "\'\;
\n"; } } print "
Environment Variables:
\n"; foreach $key (sort keys(%ENV)) { print "\$ENV{\'$key\'} = \'" . &HTMLQuoteMeta($ENV{$key}) . "\'\;
\n"; } print "
Cookie Hash:
\n"; foreach $key (sort keys(%CookieHash)) { print "\$CookieHash{\'$key\'} = \'" . &HTMLQuoteMeta($CookieHash{$key}) . "\'\;
\n"; } ## Turn this on to dump the main:: namespace. ## ## foreach $key (sort keys(%main::)) ## { ## no strict 'refs'; ## print "\$main::{\'$key\'} = \'" . &HTMLQuoteMeta(${"main::$key"}) . "\'\;
\n"; ## } dump_settings: print "
Settings:
\n"; foreach $key (sort keys(%Settings)) { print "\$Settings{\'$key\'} = \'" . &HTMLQuoteMeta($Settings{$key}) . "\'\;
\n"; } print "
Default Values:
\n"; foreach $key (sort keys(%main::DefaultVals)) { print "\$main::DefaultVals{\'$key\'} = \'" . &HTMLQuoteMeta($main::DefaultVals{$key}) . "\'\;
\n"; } dump_messages: print "
Messages:
\n"; foreach $key (sort keys(%Messages)) { print "\$Messages{\'$key\'} = \'" . &HTMLQuoteMeta($Messages{$key}) . "\'\;
\n"; } print "\$LogFile: $LogFile
\n"; print "\$LogWritten: $LogWritten
\n"; print "\$LogEntry: $LogEntry
\n"; } exit; #################################### END ##################################### ### RunCallbackRoutine ### ### Calls a given named callback routine in the 'main' package, ### passing on arguments as specified. ### ### Does nothing (and generates no error) if the routine is undefined. sub RunCallbackRoutine { my ($RoutineName, @Args) = @_; return(&{$main::{$RoutineName}}(@Args)) if (exists($main::{$RoutineName})); return(); } ### INPUT_andOUTPUT_SubsCallback ### ### This is the callback routine that DoSubstitutions calls in order ### to process the INPUT_ and OUTPUT_ syntaxes. sub INPUT_andOUTPUT_SubsCallback { my ($AStringRef) = @_; $$AStringRef =~ s/(\+?)INPUT_([A-Za-z_0-9_,\.]+)(\+?)/&MakeHTMLInputField($2)/ego; $$AStringRef =~ s/(\+?)HOUTPUT_([A-Za-z_0-9\.]+)(\+?)/&MakeHTMLOutputField($2)/ego; $$AStringRef =~ s/(\+?)OUTPUT_([A-Za-z_0-9\.]+)(\+?)/&MakeOutputField($2)/ego; } ### HTML_ENCODINGSubsCallback ### ### This is the callback routine that DoSubstitutions calls in order ### to process the ... callbacks. sub HTML_ENCODINGSubsCallback { my ($AStringRef) = @_; $$AStringRef =~ s/(.*?)<\/HTML_ENCODED>/&HTMLQuoteMeta(&DoSubstitutions($1))/egos; $$AStringRef =~ s/(.*?)<\/URL_ENCODED>/&HTMLURLSafe(&DoSubstitutions($1))/egos; $$AStringRef =~ s/(.*?)<\/META_ENCODED>/&HTMLMETASafe(&DoSubstitutions($1))/egos; } sub MakeHTMLInputField ## ($FieldDesc) ## Returns an HTML input field for the field whose name is indicated in ## $FieldDesc (which has the format fieldname[_width[,height]], e.g. ## FName or FName_20 or FName_20,4). ## ## Uses several global tables to get information about the field, its type, ## its values, etc. See ReadDataFormatDescription for details on how ## those variables are initialized from a data file { my($FieldDesc) = @_; my $key; return("") unless $FieldDesc =~ /(([A-Za-z0-9]+)((_([0-9]+)(,([0-9]+))?)|(_ITEM_([0-9]+)))?(_VALUE_(.*?)\b)?)/; my($EntireMatch, $FieldName, $TextFieldWidth, $TextFieldHeight, $ItemNum, $ItemVal) = ($1, $2, $5, $7, $9, $11); my $FieldType = $main::FieldTypes{$FieldName}; my $ValsTableRef = $main::ValueHashRefs{$FieldName}; my $HTMLInputSyntax = ""; my $QuotedValue = $ItemVal || $QueryPairs{$FieldName}; $QuotedValue = &HTMLQuoteMeta($QuotedValue); ### This next line killed Double-Byte language display in INPUT box QV's. ### &ISOCharsToHTMLQuoted(\$QuotedValue); &ISOCharsToHTMLQuoted(\$QuotedValue) unless $NonRomanLanguages{$TargetLanguage}; if ($FieldType =~ m/Text Field/i) { $HTMLInputSyntax = " "; ## Fill with current value } elsif ($FieldType =~ m/Hidden/i) { $HTMLInputSyntax = " "; ## Fill with current value. ## In the case of explicitly hidden fields, the only way for ## them to get an initial value is as a default or ## from the cookie file. } elsif ($FieldType =~ m/Ret Field/i) { ## Format the text so that embedded returns (CR/LF and/or \r and/or ASCII 11) are output as \n ## (my $OutputText = $QueryPairs{$FieldName}) =~ s/(\x0D\x0A)|([\x0B\x0A])/\n/gs; $HTMLInputSyntax = "