# Base.pm - The Base Class that the FrameSet and Normal HTML document Objects # are derived from. # Created by James Pattie, 04/27/2000. # Copyright (c) 2000 PC & Web Xperience, Inc. http://www.pcxperience.com/ # All rights reserved. This program is free software; you can redistribute it # and/or modify it under the same terms as Perl itself. # updated 02/24/2001 - Converted to new method and variable naming convention. # updated 06/05/2001 - Add non-Buffering mode. # updated 10/06/2001 - Added debug display code and tag substitution support. # updated 10/08/2001 - Started to fix the indentation problem with textareas. # updated 10/15/2001 - Removing the error if the tag doesn't exist in printTag. # updated 10/23/2001 - Added support to decode a string which has form encoded chars in it. # updated 11/20/2001 - Added support for selecting the version of HTML to generate a DOCTYPE for. package HTMLObject::Base; use strict; use POSIX qw(strftime); use Date::Manip qw(ParseDate UnixDate DateCalc Date_ConvTZ); use vars qw($AUTOLOAD $VERSION @ISA @EXPORT @EXPORT_OK); require Exporter; =head1 NAME HTMLObject::Base - Perl extension for HTMLObject. =head1 SYNOPSIS use HTMLObject::Base; my $doc = HTMLObject::Base->new(); $doc->setTitle("Test of HTMLObject::Base"); $doc->setFocus("body"); $doc->print(<<"END_OF_BODY");

HTMLObject::Base


This is cool! END_OF_BODY $doc->setCookie(name => 'cookie name', value => 'This rocks!'); # Actually generate the entire document, cookie and all! $doc->display(); =head1 DESCRIPTION HTMLObject::Base provides the Base methods needed to create a generic HTML document dynamically. See documentation.html for complete details. It now supports Internationalization via the lang and charset attributes of the html tag and the Content-type. =head1 Exported FUNCTIONS =over 4 =cut @ISA = qw(Exporter AutoLoader); @EXPORT = qw( ); $VERSION = '2.28'; # pre-declare the variables so that I can access them from the HTMLObject::Form module, etc. use vars qw($formEncodedCharacters %formEncodedCharactersHash $formUnEncodedCharacters %formUnEncodedCharactersHash @htmlTags @htmlTagArgs $encodeCharacters %codeToCharset %codeToLanguage %doctypesHash %xhtmlDocTypesHash); # Internationalization support %codeToLanguage = ( "ab" => "Abkhazian", "om" => "Afan", "aa" => "Afar", "af" => "Afrikaans", "sq" => "Albanian", "am" => "Amharic", "ar" => "Arabic", "hy" => "Armenian", "as" => "Assamese", "ay" => "Aymara", "az" => "Azerbaijani", "ba" => "Bashkir", "eu" => "Basque", "bn" => "Bengali", "dz" => "Bhutani", "bh" => "Bihari", "bi" => "Bislama", "br" => "Breton", "bg" => "Bulgarian", "my" => "Burmese", "be" => "Byelorussian", "km" => "Cambodian", "ca" => "Catalan", "zh" => "Chinese", "co" => "Corsican", "hr" => "Croatian", "cs" => "Czech", "da" => "Danish", "nl" => "Dutch", "en" => "English", "eo" => "Esperanto", "et" => "Estonian", "fo" => "Faroese", "fj" => "Fiji", "fi" => "Finnish", "fr" => "French", "fy" => "Frisian", "gl" => "Galician", "ka" => "Georgian", "de" => "German", "el" => "Greek", "kl" => "Greenlandic", "gn" => "Guarani", "gu" => "Gujarati", "ha" => "Hausa", "he" => "Hebrew", # used to be iw "hi" => "Hindi", "hu" => "Hungarian", "is" => "Icelandic", "id" => "Indonesian", "ia" => "Interlingua", "ie" => "Interlingue", "iu" => "Inuktitut", "ik" => "Inupiak", "ga" => "Irish", "it" => "Italian", "ja" => "Japanese", "jv" => "Javanese", "kn" => "Kannada", "ks" => "Kashmiri", "kk" => "Kazakh", "rw" => "Kinyarwanda", "ky" => "Kirghiz", "rn" => "Kurundi", "ko" => "Korean", "ku" => "Kurdish", "lo" => "Laothian", "la" => "Latin", "lv" => "Latvian", "ln" => "Lingala", "lt" => "Lithuanian", "mk" => "Macedonian", "mg" => "Malagasy", "ms" => "Malay", "ml" => "Malayalam", "mt" => "Maltese", "mi" => "Maori", "mr" => "Marathi", "mo" => "Moldavian", "mn" => "Mongolian", "na" => "Nauru", "ne" => "Nepali", "no" => "Norwegian", "oc" => "Occitan", "or" => "Oriya", "ps" => "Pashto", "fa" => "Persian", "pl" => "Polish", "pt" => "Portuguese", "pa" => "Punjabi", "qu" => "Quechua", "rm" => "Rhaeto-Romance", "ro" => "Romanian", "ru" => "Russian", "sm" => "Samoan", "sg" => "Sangho", "sa" => "Sanskrit", "gd" => "Scots Gaelic", "sr" => "Serbian", "sh" => "Serbo-Croatian", "st" => "Sesotho", "tn" => "Setswana", "sn" => "Shona", "sd" => "Sindhi", "si" => "Singhalese", "ss" => "Siswati", "sk" => "Slovak", "sl" => "Slovenian", "so" => "Somali", "es" => "Spanish", "su" => "Sundanese", "sw" => "Swahili", "sv" => "Swedish", "tl" => "Tagalog", "tg" => "Tajik", "ta" => "Tamil", "tt" => "Tatar", "te" => "Telugu", "th" => "Thai", "bo" => "Tibetan", "ti" => "Tigrinya", "to" => "Tonga", "ts" => "Tsonga", "tr" => "Turkish", "tk" => "Turkmen", "tw" => "Twi", "ug" => "Uigur", "uk" => "Ukrainian", "ur" => "Urdu", "uz" => "Uzbek", "vi" => "Vietnamese", "vo" => "Volapuk", "cy" => "Welsh", "wo" => "Wolof", "xh" => "Xhosa", "yi" => "Yiddish", "yo" => "Yoruba", "za" => "Zhuang", "zu" => "Zulu", ); # This hash takes the 2 letter abreviation and returns the charset encoding to use with it. It is possible to return an array if there is more than # one possible encoding that is standard for that language. %codeToCharset = ( "af" => [ "iso-8859-1", "windows-1252" ], "sq" => [ "iso-8859-1", "windows-1252" ], "ar" => "iso-8859-6", "eu" => [ "iso-8859-1", "windows-1252" ], "bg" => "iso-8859-5", "be" => "iso-8859-5", "ca" => [ "iso-8859-1", "windows-1252" ], "hr" => "iso-8859-2", "cs" => "iso-8859-2", "da" => [ "iso-8859-1", "windows-1252" ], "nl" => [ "iso-8859-1", "windows-1252" ], "en" => [ "iso-8859-1", "windows-1252" ], "eo" => "iso-8859-3", "et" => "iso-8859-10", "fo" => [ "iso-8859-1", "windows-1252" ], "fi" => [ "iso-8859-1", "windows-1252" ], "fr" => [ "iso-8859-1", "windows-1252" ], "gl" => [ "iso-8859-1", "windows-1252" ], "de" => [ "iso-8859-1", "windows-1252" ], "el" => "iso-8859-7", "he" => "iso-8859-8", "hu" => "iso-8859-2", "is" => [ "iso-8859-1", "windows-1252" ], "ga" => [ "iso-8859-1", "windows-1252" ], "it" => [ "iso-8859-1", "windows-1252" ], "ja" => [ "shift_jis", "iso-2022", "euc-jp" ], "lv" => "iso-8859-10", "lt" => "iso-8859-10", "mk" => "iso-8859-5", "mt" => "iso-8859-3", "no" => [ "iso-8859-1", "windows-1252" ], "pl" => "iso-8859-2", "pt" => [ "iso-8859-1", "windows-1252" ], "ro" => "iso-8859-2", "ru" => [ "koi-8-r", "windows-1252" ], "sr" => "iso-8859-5", "sk" => "iso-8859-2", "sl" => "iso-8859-2", "es" => [ "iso-8859-1", "windows-1252" ], "sv" => [ "iso-8859-1", "windows-1252" ], "tr" => [ "iso-8859-9", "windows-1254" ], "uk" => "iso-8859-5", ); $encodeCharacters = ';,=&: \n"#$\/?<>@'; # removed the \$ => \$\$ conversions as they don't appear to be needed and removed ' => ' $formEncodedCharacters = '&|<|>|"'; %formEncodedCharactersHash = ( '<' => '<', '>' => '>', '"' => '"', '&' => '&', ); $formUnEncodedCharacters = '<>"'; %formUnEncodedCharactersHash = ( '<' => '<', '>' => '>', '"' => '"', '&' => '&', ); @htmlTags = qw /a abbr acronym address area b base basefont bdo big blockquote br button caption center cite code col colgroup dd del dfn dir div dl dt em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input ins isindex kbd label legend li map menu object ol optgroup option p param pre q s samp script select small span strike strong sub sup table tbody td textarea tfoot th thead tr tt u ul var/; @htmlTagArgs = qw/abbr accept-charset accept accesskey action align alt archive axis bgcolor border cellpadding cellspacing char charoff charset checked cite class clear codebase color cols colspan compact coords datetime dir disabled enctype face for frame headers height href hreflang hspace id ismap label lang longdesc marginheight marginwidth maxlength method multiple name nohref noshade nowrap onblur onchange onclick ondblclick onfocus onkeydown onkeypress onkeyup onmousedown onmousemove onmouseout onmouseover onmouseup onselect onsubmit prompt readonly rel rows rowspan rules scope scrolling selected shape size span src start style summary tabindex target title type usemap valign value valuetype vspace width/; # supported DOCTYPE's %doctypesHash = ( "4.0" => { "strict" => "", "loose" => "", }, "4.01" => { "strict" => "", "loose" => "", }, ); %xhtmlDocTypesHash = ( "1.0" => { "strict" => "", "loose" => "", }, ); =item scalar new(displayOnExit) Creates a new instance of the HTMLObject::Base document type. Optional: displayOnExit - boolean (1 or 0). If true (1), when the object goes out of scope and the display() or startDisplaying() methods have not been called and we have not been instructed to not display via the doNotDisplay() method, then we call display() thus transparently making sure the object is output to the user. displayOnExit defaults to 0 (false). =cut sub new { my $that = shift; my $class = ref($that) || $that; my $self = bless {}, $class; my %args = ( displayOnExit => 0, @_ ); $self->{error} = 0; # no error initially. $self->{errorMessages} = { 1002 => 'Required Parameter missing', 1007 => 'Error Code already being used', }; $self->setErrorMessage(code => '-1', message => 'No error occurred'); $self->setErrorMessage(code => '1000', message => 'Invalid Content-Type Specified'); $self->setErrorMessage(code => '1001', message => 'Invalid Focus Specified'); $self->setErrorMessage(code => '1003', message => "Eval'ing setCookie command failed"); $self->setErrorMessage(code => '1004', message => 'Invalid Date for Cookie Expires'); $self->setErrorMessage(code => '1005', message => 'Invalid Domain for Cookie'); $self->setErrorMessage(code => '1006', message => 'Invalid Section used when Content-Type not equal to "text/html"'); $self->setErrorMessage(code => '1008', message => 'Error Code does not exist'); $self->setErrorMessage(code => '1009', message => "Invalid Language Code"); $self->setErrorMessage(code => '1010', message => "Recognized Language Code but No Charset Encoding Known"); $self->setErrorMessage(code => '1011', message => "Charset Encoding Not Valid"); $self->setErrorMessage(code => '1012', message => "In Buffering Mode"); $self->setErrorMessage(code => '1013', message => "In non-Buffering Mode"); $self->setErrorMessage(code => '1014', message => "Invalid variable or function"); $self->setErrorMessage(code => '3000', message => 'Parameters and Options are both required if they are to be used'); $self->setErrorMessage(code => '3001', message => 'Invalid Decoration type specified'); $self->setErrorMessage(code => '3002', message => 'Value must be specified'); $self->setErrorMessage(code => '3010', message => "Tag not found"); $self->setErrorMessage(code => '1015', message => 'Invalid HTML Version'); $self->setErrorMessage(code => '1016', message => 'Invalid HTML DTD'); $self->setErrorMessage(code => '1017', message => 'Invalid Value'); $self->{errorCode} = -1; $self->{displayOnExit} = $args{displayOnExit}; $self->{doNotDisplay} = 0; # by default we want to display, if displayOnExit = 1. $self->{weHaveDisplayed} = 0; # by default we haven't displayed yet. $self->{currentSection} = "body"; $self->{titleString} = "HTMLObject::Base"; $self->{contentTypeString} = "text/html"; $self->{language} = "en"; $self->{charsetEncoding} = "iso-8859-1"; $self->{headString} = ""; $self->{bodyString} = ""; $self->{bodyBgcolor} = "white"; $self->{bodyFgcolor} = "black"; $self->{bodyImage} = ""; $self->{bodyLinkColor} = "blue"; $self->{bodyVlinkColor} = "blue"; $self->{bodyAlinkColor} = "blue"; $self->{bodyClass} = ""; $self->{bodyID} = ""; $self->{bodyStyle} = ""; $self->{bodyTitle} = ""; $self->{bodyCustomArgs} = ""; # stores user defined attributes for the body tag. $self->{cookies} = []; $self->{metaTags} = []; $self->{encodeCharacters} = $encodeCharacters; $self->{formEncodedCharacters} = $formEncodedCharacters; $self->{formUnEncodedCharacters} = $formUnEncodedCharacters; $self->{formEncodedCharactersHash} = \%formEncodedCharactersHash; $self->{formUnEncodedCharactersHash} = \%formUnEncodedCharactersHash; $self->{linkTag} = []; $self->{baseHrefString} = ""; $self->{baseTargetString} = ""; $self->{cssEntries} = []; $self->{codeToLanguageHash} = \%codeToLanguage; $self->{codeToCharsetHash} = \%codeToCharset; $self->{bufferMode} = 1; # we default to buffer the data. $self->{allreadyClosed} = 0; # we default to not yet closing the document. $self->{tagBuffers} = (); $self->{tagBufferModes} = (); # define the DOCTYPE's possible. $self->{doctypes} = \%doctypesHash; $self->{xhtmlDoctypes} = \%xhtmlDocTypesHash; $self->{htmlVersion} = "4.01"; $self->{htmlDTD} = "loose"; $self->{xhtml} = 0; # by default we do not use xhtml code. $self->{docEncoding} = "iso-8859-1"; $self->{displayDTD} = 1; # by default we always display the DTD. # define the htmlTags we know about. $self->{htmlTags} = \@htmlTags; $self->{htmlTagArgs} = \@htmlTagArgs; # Add Location: support $self->{location} = ""; return $self; } =item void setErrorMessage(code => '', message => '') This adds the error message associated with code to the errorMessages hash. Modifies %errorMessages. =cut sub setErrorMessage { my $self = shift; my %args = ( @_, ); if (!exists $args{'code'}) { $self->doRequiredParameterError('setErrorMessage', 'code'); } if (!exists $args{'message'}) { $self->doRequiredParameterError('setErrorMessage', 'message'); } my $code = $args{'code'}; my $message = $args{'message'}; if (exists $self->{errorMessages}{$code}) { $self->setError(code => '1007'); $self->displayError(title => 'Error: setErrorMessage', message => "Error Code = '$code' already exists!"); } # otherwise assign this message and code to the hash. $self->{errorMessages}{$code} = $message; } =item void clearErrorMessage(code => '') This removes the message associated with code from the errorMessages hash. Modifies %errorMessages. =cut sub clearErrorMessage { my $self = shift; my $code; if (scalar @_ == 1) { $code = shift; } else { my %args = ( @_, ); if (!exists $args{'code'}) { $self->doRequiredParameterError('setErrorMessage', 'code'); } $code = $args{'code'}; } if (!exists $self->{errorMessages}{$code}) { $self->set_error(code => '1008'); $self->displayError(title => 'Error: setErrorMessage', message => "Error Code = '$code' does not exist in the errorMessages hash!"); } # otherwise remove this message and code from the hash. delete($self->{errorMessages}{$code}); } =item void setError(code => '') This takes the code and sets $self->{error}=1, $self->{errorCode} = $code. This is a helper function for the derived classes to use to signal when an error has occurred. Modifies $self->{error} and $self->{errorCode}. =cut sub setError { my $self = shift; my $code; if (scalar @_ == 1) { $code = shift; } else { my %args = ( @_, ); if (!exists $args{'code'}) { $self->doRequiredParameterError('setError', 'code'); } $code = $args{'code'}; } $self->{error} = 1; $self->{errorCode} = $code; } =item scalar didErrorOccurr() - (This is gone in 2.x series.) See didErrorOccur(). =item scalar didErrorOccur() Returns 1 if an error occurred, 0 otherwise. =cut sub didErrorOccur { my $self = shift; return $self->{error}; } =item scalar getErrorMessage() Returns the message that was generated via the code that was set. =cut sub getErrorMessage { my $self = shift; return $self->{errorMessages}{$self->{errorCode}}; } =item scalar getErrorCode() Returns the code that was set to indicate the error that occurred. =cut sub getErrorCode { my $self = shift; return $self->{errorCode}; } =item void reset() Resets the HTMLObject::Base document back to the defaults. =cut sub reset { my $self = shift; $self->{error} = 0; # no error initially. %{$self->{errorMessages}} = ( 1002 => 'Required Parameter missing', 1007 => 'Error Code already being used', ); $self->setErrorMessage(code => '-1', message => 'No error occurred'); $self->setErrorMessage(code => '1000', message => 'Invalid Content-Type Specified'); $self->setErrorMessage(code => '1001', message => 'Invalid Focus Specified'); $self->setErrorMessage(code => '1003', message => "Eval'ing setCookie command failed"); $self->setErrorMessage(code => '1004', message => 'Invalid Date for Cookie Expires'); $self->setErrorMessage(code => '1005', message => 'Invalid Domain for Cookie'); $self->setErrorMessage(code => '1006', message => 'Invalid Section used when Content-Type not equal to "text/html"'); $self->setErrorMessage(code => '1008', message => 'Error Code does not exist'); $self->setErrorMessage(code => '1009', message => "Invalid Language Code"); $self->setErrorMessage(code => '1010', message => "Recognized Language Code but No Charset Encoding Known"); $self->setErrorMessage(code => '1011', message => "Charset Encoding Not Valid"); $self->setErrorMessage(code => '1012', message => "In Buffering Mode"); $self->setErrorMessage(code => '1013', message => "In non-Buffering Mode"); $self->setErrorMessage(code => '1014', message => "Invalid variable or function"); $self->setErrorMessage(code => '3000', message => 'Parameters and Options are both required if they are to be used'); $self->setErrorMessage(code => '3001', message => 'Invalid Decoration type specified'); $self->setErrorMessage(code => '3002', message => 'Value must be specified'); $self->setErrorMessage(code => '3010', message => "Tag not found"); $self->setErrorMessage(code => '1015', message => 'Invalid HTML Version'); $self->setErrorMessage(code => '1016', message => 'Invalid HTML DTD'); $self->setErrorMessage(code => '1017', message => 'Invalid Value'); $self->{errorCode} = -1; $self->{currentSection} = "body"; $self->{titleString} = "HTMLObject::Base"; $self->{contentTypeString} = "text/html"; $self->{language} = "en"; $self->{charsetEncoding} = "iso-8859-1"; $self->{headString} = ""; $self->{bodyString} = ""; $self->{bodyBgcolor} = "white"; $self->{bodyFgcolor} = "black"; $self->{bodyImage} = ""; $self->{bodyLinkColor} = "blue"; $self->{bodyVlinkColor} = "blue"; $self->{bodyAlinkColor} = "blue"; $self->{bodyClass} = ""; $self->{bodyID} = ""; $self->{bodyStyle} = ""; $self->{bodyTitle} = ""; $self->{bodyCustomArgs} = ""; # stores user defined attributes for the body tag. $self->{cookies} = []; $self->{metaTags} = []; $self->{encodeCharacters} = $encodeCharacters; $self->{formEncodedCharacters} = $formEncodedCharacters; $self->{formUnEncodedCharacters} = $formUnEncodedCharacters; $self->{formEncodedCharactersHash} = \%formEncodedCharactersHash; $self->{formUnEncodedCharactersHash} = \%formUnEncodedCharactersHash; $self->{linkTag} = []; $self->{baseHrefString} = ""; $self->{baseTargetString} = ""; $self->{cssEntries} = []; $self->{codeToLanguageHash} = \%codeToLanguage; $self->{codeToCharsetHash} = \%codeToCharset; # we can't reset these if they have already happened! #$self->{bufferMode} = 1; # we default to buffer the data. #$self->{allreadyClosed} = 0; # we default to not yet closing the document. $self->{tagBuffers} = (); $self->{tagBufferModes} = (); # define the DOCTYPE's possible. $self->{doctypes} = \%doctypesHash; $self->{xhtmlDoctypes} = \%xhtmlDocTypesHash; $self->{htmlVersion} = "4.01"; $self->{htmlDTD} = "loose"; $self->{xhtml} = 0; # by default we do not use xhtml code. $self->{docEncoding} = "iso-8859-1"; $self->{displayDTD} = 1; # by default we always display the DTD. # define the htmlTags we know about. $self->{htmlTags} = \@htmlTags; $self->{htmlTagArgs} = \@htmlTagArgs; # Add Location: support $self->{location} = ""; } =item void setDocumentEncoding(encoding => "UTF-8") requires: encoding - document encoding value default of UTF-8 This function sets the documents encoding format. Your document defaults to iso-8859-1 if you do not use this method to change it. This is only available if working with an XHTML document. =cut sub setDocumentEncoding { my $self = shift; my $encoding; if (scalar @_ == 1) { $encoding = shift; } else { my %args = (encoding => "UTF-8", @_); $encoding = $args{encoding}; } if (strlen $encoding == 0) { $self->doRequiredParameterError('Base::setDocumentEncoding', 'encoding'); } $self->{docEncoding} = $encoding; } =item scalar getDocumentEncoding() returns the current document encoding value. This is only available if working with an XHTML document. =cut sub getDocumentEncoding { my $self = shift; return $self->{docEncoding}; } =item void displayError(title => '', message => '', debug => 0|1) optional: debug (defaults to 0) Creates a HTML document that displays the user specified error message along with the error message generated by the program. The user specified title is used also. The program is exited after the document is displayed. Uses display() to generate the actual document. If debug is specified and equals 1, then the contents of the calling Document will be output in a viewable format so that the user can determine what would have been generated. =cut sub displayError { my $self = shift; my %args = ( title => 'Error: HTMLObject::Base', message => 'An Error Occurred!', debug => 0, @_ # arguments passed in go here. ); my $debug = $args{debug}; if ($self->{bufferMode}) { $self->doNotDisplay(1); # don't try and display ourselves since an error occured. my $doc = HTMLObject::Base->new(); $doc->setTitle($args{'title'}); $doc->setFocus("body"); $doc->print("

HTMLObject


\n"); $doc->print("

Error:  " . $self->getErrorCode() . " Occurred!

\n"); $doc->print("Message:  " . $self->getErrorMessage() . "\n
\n"); $doc->print("
\n
\n$args{'message'}\n
\n"); $doc->setStyleEntry(tag => "body", string => "color: #000000; background-color: #ffffff;") if ($self->{xhtml}); # set the HTMLInfo based upon what was previously set. my %docInfo = $self->getHTMLInfo(); $docInfo{dtd} = "loose" if ($docInfo{dtd} eq "frameset"); $doc->setHTMLInfo(%docInfo); if ($debug == 1) { my $output = $self->display(debug => 1); $output =~ s/^(.*)$/  $1/mg; $output =~ s/^(.*)$/ $1/mg; # need to use css in the future. $doc->print(<<"END_OF_CODE");
Your Document would have generated:
$output
END_OF_CODE } $doc->display(); } else { $self->print("

HTMLObject


\n"); $self->print("
\n

Error:  " . $self->getErrorCode() . " Occurred!

\n"); $self->print("Message:  " . $self->getErrorMessage() . "\n
\n"); $self->print("
\n
\n$args{'message'}\n
\n"); $self->print(" \n\n"); } exit 0; } # displayCookies sub displayCookies { my $self = shift; my $output = ""; if (scalar @{$self->{cookies}} > 0) { foreach my $cookie (@{$self->{cookies}}) { $output .= "Set-Cookie: $cookie\n"; } } return $output; } # displayMetaTags sub displayMetaTags { my $self = shift; my $output .= ""; if (scalar @{$self->{metaTags}} > 0) { foreach my $metaTag (@{$self->{metaTags}}) { $output .= " $metaTag\n"; } } return $output; } # displayLinks sub displayLinks { my $self = shift; my $output = ""; if (scalar @{$self->{linkTag}} > 0) { foreach my $link (@{$self->{linkTag}}) { $output .= " $link\n"; } } return $output; } # displayCSS sub displayCSS { my $self = shift; my $output = ""; if (scalar @{$self->{cssEntries}} > 0) { my $tempCSS = "\n"; $tempCSS =~ s/^(.*)$/ $1/mg; $output = $tempCSS; } return $output; } # displayBase sub displayBase { my $self = shift; my $output = ""; if (length $self->{baseHrefString} > 0 || length $self->{baseTargetString} > 0) { $output = "{baseHrefString} > 0) { $output .= " href=\"$self->{baseHrefString}\""; } if (length $self->{baseTargetString} > 0) { $output .= " target=\"$self->{baseTargetString}\""; } $output .= " />\n"; } return $output; } =item scalar display(debug => 0|1, print => 0|1) optional: debug (defaults to 0), print (defaults to 1) returns: the string that represents the Document. This function generates the Base Document displaying any cookies, plus the contents of the Body that the user created. This function prints the generated document to standard out which is then hopefully being sent to a web server to process, if print = 1. If debug is defined (and equals 1), then the contents of the current Document are returned in a format ready to display in another Document so that the user can see what would have been generated and the string is not printed out. The generated output is always returned to the caller. =cut sub display { my $self = shift; my %args = ( debug => 0, print => 1, @_ ); my $debug = $args{debug}; my $print = $args{print}; my $language = $self->getLanguage(); my $output = ""; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call display when in non-Buffer mode!"); } if ($self->{weHaveDisplayed}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call display when we have already displayed ourselves!"); } $self->{weHaveDisplayed} = 1; # signal we have displayed ourselves. my ($tempHeadString, $tempBodyString); $tempHeadString = $self->getHeadString(); $tempBodyString = $self->getBodyString(); # do any replacement for the tagBuffers that have been defined. foreach my $tag (keys %{$self->{tagBuffers}}) { if ($self->{tagBufferModes}->{$tag} eq "single") { $tempBodyString =~ s/($tag)/$self->{tagBuffers}->{$tag}/; } else { $tempBodyString =~ s/($tag)/$self->{tagBuffers}->{$tag}/g; } } if ($self->{contentTypeString} =~ /^(text\/html)$/i) { # display Cookies if needed (they must come before the Content-Type header) my $tempStr = $self->displayCookies(); $output .= $tempStr if (length $tempStr > 0); if (length $self->{location} > 0) { $output .= "Location: $self->{location}\n\n"; print $output if (!$debug && $print); if ($debug == 1) { $output = $self->formEncodeString(string => $output); # fixup all special characters. $output =~ s/ / /g; $output =~ s/\t/    /g; # replace each tab with 4 spaces $output =~ s/\n/
\n/gm; # make all line breaks be
's. } return $output; } #make sure that all output is properly indented, this way the user doesn't have to do any indentation to fit our output indentation. $tempHeadString =~ s/^(.*)$/ $1/mg; # currently 4 spaces. $tempBodyString =~ s/^(.*)$/ $1/mg; $tempBodyString =~ s/()((?s).*?<\/textarea>)/$1 . eval{(my $temp = $2) =~ s{^(\s{4})(.*?)$}{$2}mg; return $temp}/mxge if ($tempBodyString =~ //); $tempBodyString =~ s/(
)((?s).*?<\/pre>)/$1 . eval{(my $temp = $2) =~ s{^(\s{4})(.*?)$}{$2}mg; return $temp}/mxge if ($tempBodyString =~ /
/);

    $output .= "Content-Type: $self->{contentTypeString}; charset=$self->{charsetEncoding}\n\n";  # Display the Content-Type block.

    # output the Document Type header.
    if ($self->{xhtml})
    {
      $output .= "{docEncoding}\"?>\n";
      $output .= $self->{xhtmlDoctypes}->{$self->{htmlVersion}}->{$self->{htmlDTD}} . "\n" if ($self->{displayDTD});
    }
    else
    {
      $output .= $self->{doctypes}->{$self->{htmlVersion}}->{$self->{htmlDTD}} . "\n" if ($self->{displayDTD});
    }
    $output .= "{xhtml} ? "xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"$language\" " : "") . "lang=\"$language\">\n";
    $output .= "  \n";

    # display Meta Tags if needed.
    $tempStr = $self->displayMetaTags();
    $output .= $tempStr if (length $tempStr > 0);

    # display Base if needed.
    $tempStr = $self->displayBase();
    $output .= "    $tempStr\n" if (length $tempStr > 0);

    $output .= "    $self->{titleString}\n";

    # display Links if needed.
    $tempStr = $self->displayLinks();
    $output .= $tempStr if (length $tempStr > 0);

    # display CSS entries if needed.
    $tempStr = $self->displayCSS();
    $output .= "$tempStr\n" if (length $tempStr > 0);

    $output .= "    $tempHeadString" if (length $self->{headString} > 0);
    $output .= "  \n\n";
    $output .= "  {xhtml})
    {
      $output .= " bgcolor=\"$self->{bodyBgcolor}\" text=\"$self->{bodyFgcolor}\" link=\"$self->{bodyLinkColor}\" vlink=\"$self->{bodyVlinkColor}\" alink=\"$self->{bodyAlinkColor}\"";
      $output .= " background=\"$self->{bodyImage}\"" if (length $self->{bodyImage} > 0);
    }
    $output .= " class=\"$self->{bodyClass}\"" if (length $self->{bodyClass} > 0);
    $output .= " id=\"$self->{bodyID}\"" if (length $self->{bodyID} > 0);
    $output .= " style=\"$self->{bodyStyle}\"" if (length $self->{bodyStyle} > 0);
    $output .= " title=\"$self->{bodyTitle}\"" if (length $self->{bodyTitle} > 0);
    $output .= $self->{bodyCustomArgs} if (length $self->{bodyCustomArgs} > 0);
    $output .= ">\n";
    $output .= "$tempBodyString\n" if (length $self->{bodyString} > 0);
    $output .= "  \n";
    $output .= "\n";
  }
  else
  {
    $output .= "Content-Type: $self->{contentTypeString}\n";
    $output .= "\n";  # Close the Content-Type block.
    $output .= $self->{bodyString};
  }

  print $output if (!$debug && $print);

  if ($debug == 1)
  {
    $output = $self->formEncodeString(string => $output);  # fixup all special characters.
    $output =~ s/ / /g;
    $output =~ s/\t/    /g;  # replace each tab with 4 spaces
    $output =~ s/\n/
\n/gm; # make all line breaks be
's. } return $output; } =item void startDisplaying() This function generates the Base Document displaying any cookies, plus the contents of the Body that the user created. This function prints the generated document to standard out which is then hopefully being sent to a web server to process. This also sets a flag bufferMode to 0 so that the methods know that we are no longer buffering user input but should just print it to the standard output. The only valid commands are error related, endDisplaying and print. =cut sub startDisplaying { my $self = shift; my $language = $self->getLanguage(); my $output = ""; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call startDisplaying again when in non-Buffer mode!"); } if ($self->{weHaveDisplayed}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call startDisplaying when we have already displayed ourselves!"); } $self->{weHaveDisplayed} = 1; # signal we have displayed ourselves. my ($tempHeadString, $tempBodyString); $tempHeadString = $self->getHeadString(); $tempBodyString = $self->getBodyString(); # do any replacement for the tagBuffers that have been defined. foreach my $tag (keys %{$self->{tagBuffers}}) { if ($self->{tagBufferModes}->{$tag} eq "single") { $tempBodyString =~ s/($tag)/$self->{tagBuffers}->{$tag}/; } else { $tempBodyString =~ s/($tag)/$self->{tagBuffers}->{$tag}/g; } } if ($self->{contentTypeString} =~ /^(text\/html)$/i) { #make sure that all output is properly indented, this way the user doesn't have to do any indentation to fit our output indentation. $tempHeadString =~ s/^(.*)$/ $1/mg; # currently 4 spaces. $tempBodyString =~ s/^(.*)$/ $1/mg; $tempBodyString =~ s/()((?s).*?<\/textarea>)/$1 . eval{(my $temp = $2) =~ s{^(\s{4})(.*?)$}{$2}mg; return $temp}/mxge if ($tempBodyString =~ //); $tempBodyString =~ s/(
)((?s).*?<\/pre>)/$1 . eval{(my $temp = $2) =~ s{^(\s{4})(.*?)$}{$2}mg; return $temp}/mxge if ($tempBodyString =~ /
/);

    # display Cookies if needed  (they must come before the Content-Type header)
    my $tempStr = $self->displayCookies();
    $output .= $tempStr if (length $tempStr > 0);

    $output .= "Content-Type: $self->{contentTypeString}; charset=$self->{charsetEncoding}\n\n";  # Display the Content-Type block.

    # output the Document Type header.
    if ($self->{xhtml})
    {
      $output .= "{docEncoding}\"?>\n";
      $output .= $self->{xhtmlDoctypes}->{$self->{htmlVersion}}->{$self->{htmlDTD}} . "\n" if ($self->{displayDTD});
    }
    else
    {
      $output .= $self->{doctypes}->{$self->{htmlVersion}}->{$self->{htmlDTD}} . "\n" if ($self->{displayDTD});
    }
    $output .= "{xhtml} ? "xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"$language\" " : "") . "lang=\"$language\">\n";
    $output .= "  \n";

    # display Meta Tags if needed.
    $tempStr = $self->displayMetaTags();
    $output .= $tempStr if (length $tempStr > 0);

    # display Base if needed.
    $tempStr = $self->displayBase();
    $output .= "    $tempStr\n" if (length $tempStr > 0);

    $output .= "    $self->{titleString}\n";

    # display Links if needed.
    $tempStr = $self->displayLinks();
    $output .= $tempStr if (length $tempStr > 0);

    # display CSS entries if needed.
    $tempStr = $self->displayCSS();
    $output .= "$tempStr\n" if (length $tempStr > 0);

    $output .= "    $tempHeadString" if (length $self->{headString} > 0);
    $output .= "  \n\n";
    $output .= "  {xhtml})
    {
      $output .= " bgcolor=\"$self->{bodyBgcolor}\" text=\"$self->{bodyFgcolor}\" link=\"$self->{bodyLinkColor}\" vlink=\"$self->{bodyVlinkColor}\" alink=\"$self->{bodyAlinkColor}\"";
      $output .= " background=\"$self->{bodyImage}\"" if (length $self->{bodyImage} > 0);
    }
    $output .= " class=\"$self->{bodyClass}\"" if (length $self->{bodyClass} > 0);
    $output .= " id=\"$self->{bodyID}\"" if (length $self->{bodyID} > 0);
    $output .= " style=\"$self->{bodyStyle}\"" if (length $self->{bodyStyle} > 0);
    $output .= " title=\"$self->{bodyTitle}\"" if (length $self->{bodyTitle} > 0);
    $output .= ">\n";
    $output .= "$tempBodyString" if (length $self->{bodyString} > 0);
  }
  else
  {
    $output .= "Content-Type: $self->{contentTypeString}\n";
    $output .= "\n";  # Close the Content-Type block.
    $output .= $self->{bodyString};
  }

  $self->{bufferMode} = 0;  # signal we are no longer buffering!
  $self->{currentSection} = "body";
  $|=1;  # turn buffering off in perls print code.

  print $output;
}

=item void endDisplaying()

 This function closes the document that is currently being displayed
 in non-Buffering mode.  It is not valid to call this more than once.

=cut
sub endDisplaying
{
  my $self = shift;

  if ($self->{bufferMode})
  {
    $self->setError(code => "1012");
    $self->displayError(message => "You can not call endDisplaying when in Buffer mode!");
  }
  elsif ($self->{allreadyClosed})
  {
    $self->setError(code => "1013");
    $self->displayError(message => "You have already closed out the document!");
  }
  print "  \n\n" if ($self->{contentTypeString} =~ /^(text\/html)$/i);
  $self->{allreadyClosed} = 1;
}

=item void doRequiredParameterError(title => '', message => '')

 Creates an Error document using the customized title to display the
 error of Required Parameter missing. The specified message is also
 included in the body so that the program can notify the user of what
 variable is missing. Uses displayError() to generate the Error
 document.

=cut
sub doRequiredParameterError
{
  my $self = shift;
  my $titleName = shift;
  my $messageName = shift;

  $self->setError(code => '1002');
  $self->displayError(title => "Error:  $titleName", message => "$messageName is required!");
}

=item void setContentType(contentType) (scalar value)

 Uses the specified string to set the content-type: header with.
 Modifies $contentTypeString. If $contentType not equal to
 "text/html" then the focus is automatically set to "body".

=cut
sub setContentType
{
  my $self = shift;

  if (!$self->{bufferMode})
  {
    $self->setError(code => "1013");
    $self->displayError(message => "You can not call setContentType when in non-Buffer mode!");
  }

  if (!defined $_[0])
  {
    $self->doRequiredParameterError('setContentType', 'Content-Type');
  }

  my $temp = shift;

  if ($temp !~ /^(text\/html)$/i)
  {
    $self->{currentSection} = "body"; # make sure the only valid section is the body.
  }

  $self->{contentTypeString} = $temp;
}

# getContentType - Returns the charset encoding if valid.
sub getContentType
{
  my $self = shift;
  my $contentType = $self->{contentTypeString};

  if ($contentType =~ /^(text\/html)$/i)
  {
    $contentType .= "; charset=" . $self->{charsetEncoding};
  }

  return $contentType;
}

# setLanguageEncoding - Sets the language and charset encoding to work with.
sub setLanguageEncoding
{
  my $self = shift;
  my %args = ( language => 'en', encoding => 'iso-8859-1', @_, );
  my $language = $args{'language'};
  my $encoding = $args{'encoding'};

  if (!$self->{bufferMode})
  {
    $self->setError(code => "1013");
    $self->displayError(message => "You can not call setLanguageEncoding when in non-Buffer mode!");
  }

  # validate that we have valid language code and encoding values and then that they are valid together.
  if (!exists $codeToLanguage{$language})
  {
    $self->setError(code => '1009');
    $self->displayError(title => "Error: setLanguageEncoding", message => "Language Code = '$language' is not recognized!");
  }
  if (!exists $codeToCharset{$language})
  {
    $self->setError(code => '1010');
    $self->displayError(title => "Error: setLanguageEncoding", message => "Language Code = '$language' does not have a charset encoding!");
  }
  else
  {
    my $charEncoding = $codeToCharset{$language};
    if (ref($charEncoding) eq "ARRAY")
    {
      my @encodings = @{$codeToCharset{$language}};
      my $found = 0;
      for (my $i=0; $i < scalar @encodings && !$found; $i++)
      {
        if ($encodings[$i] eq $encoding)
        {
          $found = 1;
        }
      }
      if (!$found)
      {
        $self->setError(code => '1011');
        $self->displayError(title => "Error: setLanguageEncoding", message => "Charset Encoding = '$encoding' is not valid!");
      }
    }
    else
    {
      if ($charEncoding ne $encoding)
      {
        $self->setError(code => '1011');
        $self->displayError(title => "Error: setLanguageEncoding", message => "Charset Encoding = '$encoding' is not valid!");
      }
    }
  }

  $self->{language} = $language;
  $self->{charsetEncoding} = $encoding;
}

# getLanguage
sub getLanguage
{
  my $self = shift;

  return $self->{language};
}

# getLanguageName
sub getLanguageName
{
  my $self = shift;

  return $codeToLanguage{$self->{language}};
}

# lookupLanguageName
sub lookupLanguageName
{
  my $self = shift;
  my $code;
  if (scalar @_ == 1)
  {
    $code = shift;
  }
  else
  {
    my %args = (code => 'en', @_, );  # default to english.
    $code = $args{'code'};
  }

  my $name = $codeToLanguage{$code};

  return $name;
}

# getCharEncoding
sub getCharEncoding
{
  my $self = shift;

  return $self->{charsetEncoding};
}

# lookupCharEncoding
sub lookupCharEncoding
{
  my $self = shift;
  my $code;
  if (scalar @_ == 1)
  {
    $code = shift;
  }
  else
  {
    my %args = (code => 'en', @_, );  # default to english.
    $code = $args{'code'};
  }

  return $codeToCharset{$code};  # this could be an array ref.
}

# setTitle
sub setTitle
{
  my $self = shift;

  if (!$self->{bufferMode})
  {
    $self->setError(code => "1013");
    $self->displayError(message => "You can not call setTitle when in non-Buffer mode!");
  }

  if (!defined $_[0])
  {
    $self->doRequiredParameterError('setTitle', 'Title');
  }

  $self->{titleString} = shift;
}

# getTitle
sub getTitle
{
  my $self = shift;

  return $self->{titleString};
}

# getHeadString
sub getHeadString
{
  my $self = shift;

  return $self->{headString};
}

# getBodyString
sub getBodyString
{
  my $self = shift;

  return $self->{bodyString};
}

# scalar uriEncode(string)
#  calls encodeString(string).
sub uriEncode
{
  if (scalar @_ == 1)
  {
    return encodeString(@_);
  }
  else
  {
    my $self = shift;

    return $self->encodeString(@_);
  }
}

# encodeString
# parameters are: string
# returns: url encoded string
sub encodeString
{
  my $string = "";
  if (scalar @_ == 1)  # treat it as a function call.
  {
    $string = shift;
  }
  else # treat it as a method call.
  {
    my $self = shift;
    if (scalar @_ == 1)
    {
      $string = shift;
    }
    else
    {
      my %args = ( string => "", @_,  # arguments go here.
            );

      $string = $args{'string'};

      if (!exists $args{'string'})
      {
        $self->doRequiredParameterError('encodeString', 'string');
      }
    }
  }

  if (length $string > 0)
  {
    # handle the special cases first.
    foreach my $char (qw/% +/)
    {
      $string =~ s/[$char]/sprintf("%%%x", ord($char))/eg;
    }
    # now fixup the rest of the cases.
    $string =~ s/([$encodeCharacters])/($1 ne " " ? sprintf("%%%x", ord($1)) : "+")/eg;
  }

  return $string;
}

# scalar formEncode(string)
# shortcut to formEncodeString(string)
sub formEncode
{
  if (scalar @_ == 1)
  {
    return formEncodeString(@_);
  }
  else
  {
    my $self = shift;

    return $self->formEncodeString(@_);
  }
}

=item scalar formEncodeString(string, ignoreTags, sequence)

=item scalar formEncodeString(scalar)

 In scalar mode, takes the incoming string and encodes it to
 escape all <, > values as <, > unless they are \ escaped.

 To have the \ showup, you will have to do a \\ when defining this
 in perl, otherwise perl interprets the \whatever internally.

 In non-scalar mode, you specify the arguments by name.

 optional:
   string - string to encode all &, <, > characters to their html
     equivalents of &, <, >.
   ignoreTags - string of pipe (|) seperated tag names that should not
     be encoded.  Ex:  ignoreTags => "b|i|u|span" would ignore all
     , , , , , , ,  tags that were
     not \ escaped.
   sequence - a named set of ignoreTags values that you want used.
     If both sequence and ignoreTags are specified, the ignoreTags
     value is used.  If you want to apply multiple sequences, specify
     them in a comma delimited format.
     Ex: sequence => 'formatting,seperator'

     available sequences are:
       formatting - "b|i|u|span|sub|sup|big|code|font|h1|h2|h3|h4|h5|h6|pre|small|strike|strong"
       block - "p|div|form"
       tables - "table|tr|td|th|tbody|tfoot|thead"
       seperator - "br|hr"
       formItems - "input|textarea|select|option"
       grouping - "ol|ul|li"

 returns: form encoded string ignoring those entries defined in
   ignoreTags or sequence and where the &, <, > was not \ escaped.

   Any &, <, > that were \ escaped will have the \ removed on output.

=cut
sub formEncodeString
{
  my $string;
  my $ignoreTags;
  my $sequence;
  my %sequences = (
       "formatting" => "b|i|u|span|sub|sup|big|code|font|h1|h2|h3|h4|h5|h6|pre|small|strike|strong",
       "block" => "p|div|form",
       "tables" => "table|tr|td|th|tbody|tfoot|thead",
       "seperator" => "br|hr",
       "formItems" => "input|textarea|select|option",
       "grouping" => "ol|ul|li",
       );

  if (scalar @_ == 1)  # handle being called as function
  {
    $string = shift;
  }
  else # handle being called as method
  {
    my $self = shift;
    if (scalar @_ == 1)
    {
      $string = shift;
    }
    else
    {
      my %args = ( string => "", ignoreTags => "", sequence => "", @_ );
      $string = $args{string};
      $ignoreTags = (length $args{ignoreTags} > 0 ? $args{ignoreTags} : undef);
      $sequence = (length $args{sequence} > 0 ? $args{sequence} : undef);

      if (!defined $ignoreTags && defined $sequence)
      {
        my @sequences = split /,/, $sequence;
        foreach my $sequence (@sequences)
        {
          $ignoreTags .= "|" if (length $ignoreTags);  # make sure multiple sequences are | seperated for the regular expression.
          $ignoreTags .= $sequences{$sequence};
          if (!exists $sequences{$sequence})
          {
            $self->setError(code => "1017");
            $self->displayError(message => "sequence = '$sequence' does not exist!");
          }
        }
      }
    }
  }

  if (length $string > 0)
  {
    # handle the special cases first.
    foreach my $char (qw/&/)
    {
      $string =~ s/(?]+)?(\/)?>)/$formUnEncodedCharactersHash{$1}/emg;

      # handle the > case where we encode > if it is not \ escaped and does not have one of the ignoreTags before it.
      # escape the > tag when it is part of an ignoreTag entry.
      $string =~ s/(<(\/)?($ignoreTags)(\s+[^>]+)?(\/)?)(>)/$1\\$6/mg;
      # convert all non-escaped >'s.
      $string =~ s/(?)/$formUnEncodedCharactersHash{$1}/emg;

      # now remove the \ from any chars that were escaped.
      $string =~ s/(\\([$formUnEncodedCharacters]))/$2/mg;
    }
    else
    {
      $string =~ s/(?formDecodeString(@_);
  }
}

# formDecodeString
# takes: string
# returns: string which has all form encoded characters replaced with the un-encoded value
sub formDecodeString
{
  my $string;
  if (scalar @_ == 1) # being called as a function.
  {
    $string = shift;
  }
  else # being called as a method
  {
    my $self = shift;
    if (scalar @_ == 1)
    {
      $string = shift;
    }
    else
    {
      my %args = ( string => "", @_ );
      $string = $args{string};

      if (!exists $args{string})
      {
        $self->doRequiredParameterError('formDecodeString', 'string');
      }
    }
  }

  if (length $string > 0)
  {
    $string =~ s/(?formProtectString(@_);
  }
}

# formProtectString
# takes: string
# returns: string after decoding and then re-encoding the string to protect any special characters you
# created and want to redisplay in an edit field, etc.
# keeps any html form tags un-decoded after decoding and re-encoding the string.
# example: string => "This is a 
tag." would keep like so. # string => "This is a & &." would keep the string as is instead of turning the first & into &amp; sub formProtectString { my $string; if (scalar @_ == 1) # being called as function { $string = shift; } else # being called as method { my $self = shift; if (scalar @_ == 1) { $string = shift; } else { my %args = ( string => "", @_ ); $string = $args{string}; if (!exists $args{string}) { $self->doRequiredParametersError('formProtectString', 'string'); } } } if (length $string > 0) { # protect any \\ already in the document. $string =~ s/(?|"|&))/&$2/g; # remove any protected \\ in the document. $string =~ s/\\\\/\\/g; } return $string; } sub formatDateOutput { my $self = shift; my %args = ( @_ ); my $tm = $args{tm}; my $format = $args{format}; my $result = ""; $result = strftime($format, @{$tm}); return $result; } =item scalar getCurrentDate(format) Uses localtime to gather the current date and returns a string with the specified parameters output in the format specified by format. By default format = "%F" which returns YYYY-MM-DD. See strftime(3) for possible arguments. =cut sub getCurrentDate { my $self = shift; my %args = ( format => "%F", @_ ); my @tm = localtime; my $result = $self->formatDateOutput(tm => \@tm, %args); return $result; } =item scalar getCurrentLocalizedDate(tz, format) Uses gmtime to gather the current date and returns a string with the specified parameters output in the format specified by format. By specifying your TimeZone in tz, I can calculate your localized time. tz will default to "GMT". By default format = "%F" which returns YYYY-MM-DD. See strftime(3) for possible arguments. =cut sub getCurrentLocalizedDate { my $self = shift; my %args = ( format => "%F", tz => "GMT", @_ ); my @tm = gmtime; if ($args{tz} ne "GMT") { @tm = $self->calculateDateOffset(date => scalar(gmtime), offset => "0 hours", toTZ => $args{tz}, fromTZ => "GMT"); } my $result = $self->formatDateOutput(tm => \@tm, %args); return $result; } =item @tm calculateDateOffset(date, offset, toTZ, fromTZ) Takes the date as given by the user (can be "now" to indicate they want the current time used) and uses Date::Manip DateCalc method to calculate the new date. toTZ indicates the TimeZone to convert into. fromTZ indicates the TimeZone we are converting from. If "", then it is the servers default timezone. It defaults to "". toTZ defaults to "". This will calculate the date in the servers current TimeZone. If you specify a TimeZone, then we convert to that TimeZone from the fromTZ value. Returns the updated tm array representing the new date/time just calculated. =cut sub calculateDateOffset { my $self = shift; my %args = ( date => "now", offset => "0 hours", toTZ => "", fromTZ => "", @_ ); my $err; my @tm = (); my $time = DateCalc($args{date}, $args{offset}, \$err); if ($time) { # see if we have to convert to a specific TimeZone. if ($args{toTZ} ne "") { # get the number of seconds past the epoch. $time = UnixDate($time, "%s"); # convert back to the tm array. @tm = localtime($time); $time = $self->formatDateOutput(tm => \@tm, format => "%Y-%m-%d %H:%M:%S"); # force the format so that we always have a valid date/time back. $time = ParseDate($time); # I have to jump through hoops to have the input be a ParseDate object. :( $time = Date_ConvTZ($time, $args{fromTZ}, $args{toTZ}); } # get the number of seconds past the epoch. $time = UnixDate($time, "%s"); # convert back to the tm array. @tm = localtime($time); } return @tm; } =item scalar formatDateString(date, format) Runs the specified date through Date::Manip ParseDate and then returns it as specified by the format string. format defaults to "%F". date defaults to "now". =cut sub formatDateString { my $self = shift; my %args = ( date => "now", format => "%F", @_ ); my $result = ""; my $date = ParseDate($args{date}); if ($date) { my $time = UnixDate($date, "%s"); my @tm = localtime($time); $result = $self->formatDateOutput(tm => \@tm, %args); } return $result; } =item scalar getDateOffset(date, offset, format) Returns the date/time specified in the format string that is the current date/time or specified date offset by the specified offset string that is valid for Date::Manip::ParseDate() function. format defaults to "%F" - YYYY-MM-DD date defaults to "now" which will use the current time for any calculations. =cut sub getDateOffset { my $self = shift; my %args = ( format => "%F", date => "now", offset => "", @_ ); my @tm = $self->calculateDateOffset(%args); my $result = $self->formatDateOutput(tm => \@tm, %args); return $result; } # setCookie # parameters are: name, value, expires, path, domain, secure sub setCookie { my $self = shift; my %args = ( name => '', value => '', @_, # arguments go here. ); if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setCookie when in non-Buffer mode!"); } my $name = $args{'name'}; my $value = $args{'value'}; if (length $name == 0) { $self->doRequiredParameterError('setCookie', 'name'); } $name = $self->encodeString( string => "$name" ); $value = $self->encodeString( string => "$value" ); my $cookie = "$name=$value;"; if (exists $args{'expires'} && length $args{expires} > 0) { my $date = $args{'expires'}; # handle dates specified by human readable formats: 30 minutes, 2 days, yesterday, etc. if ($date !~ /^\w{3}\,\s\d{2}\-\w{3}-\d{4}\s\d{2}\:\d{2}\:\d{2}\sGMT$/) { # try to get the updated version $date = $self->getDateOffset(offset => $date, format => "%a, %d-%b-%Y %H:%M:%S", toTZ => "GMT"); $date .= " GMT"; } if ($date =~ /^\w{3}\,\s\d{2}\-\w{3}-\d{4}\s\d{2}\:\d{2}\:\d{2}\sGMT$/) { $cookie .= " expires=$date;"; } else { $self->setError(code => '1004'); $self->displayError(title => 'setCookie', message => "date = '$date' is invalid!"); } } if (exists $args{'path'}) { $cookie .= " path=$args{'path'};"; } if (exists $args{'domain'}) { my $domain = $args{'domain'}; if ($domain =~ /(.com|.edu|.net|.org|.gov|.mil|.int)$/i && $domain =~ /\..+\.\w{3}$/) { $cookie .= " domain=$args{'domain'};"; } elsif ($domain !~ /(.com|.edu|.net|.org|.gov|.mil|.int)$/i && $domain =~ /\..+\..+\..+/) { $cookie .= " domain=$args{'domain'};"; } else { $self->setError(code => '1005'); $self->displayError(title => 'setCookie', message => "domain = '$domain' is invalid!"); } } if (exists $args{'secure'}) { $cookie .= " secure"; } # first make sure this cookie has not already been set. foreach my $entry (@{$self->{cookies}}) { return if ($entry eq $cookie); } my $num = scalar @{$self->{cookies}}; $self->{cookies}[$num] = $cookie; # store the cookie string in the cookies array. } # setCompressedCookie # parameters: name, @cookies, expires, path, domain, secure sub setCompressedCookie { my $self = shift; my %args = ( name => '', @_, # arguments go here. ); if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setCompressedCookie when in non-Buffer mode!"); } if (!exists $args{'cookies'}) { $self->doRequiredParameterError('setCompressedCookie', 'cookies'); } my $name = $args{'name'}; my @localCookies = @{$args{'cookies'}}; my $cookieValue = ""; # The value for this compressed cookie to be set. if (length $name == 0) { $self->doRequiredParameterError('setCompressedCookie', 'name'); } if (scalar @localCookies == 0) { $self->doRequiredParameterError('setCompressedCookie', 'cookies'); } for (my $i=0; $i < scalar @localCookies; $i++) { my $subCookie = $localCookies[$i][0]; my $subValue = $localCookies[$i][1]; $subCookie = $self->encodeString( string => "$subCookie" ); $subValue = $self->encodeString( string => "$subValue" ); if (length $cookieValue > 0) { $cookieValue .= "&" . $subCookie . "::" . $subValue; } else { $cookieValue = $subCookie . "::" . $subValue; } } my $arguments = ""; if (exists $args{'path'}) { $arguments .= ", path => '$args{'path'}'"; } if (exists $args{'domain'}) { $arguments .= ", domain => '$args{'domain'}'"; } if (exists $args{'expires'}) { $arguments .= ", expires => '$args{'expires'}'"; } if (exists $args{'secure'}) { $arguments .= ", secure => ''"; } # now set the cookie by calling setCookie. eval("\$self->setCookie(name => \"$name\", value => \"$cookieValue\"$arguments);"); if ($@) { $self->setError(code => '1003'); $self->displayError(title => 'setCompressedCookie', message => "\$@ = $@"); } } # setMetaTag # parameters: http-equiv, content sub setMetaTag { my $self = shift; my %args = ( @_, # arguments go here. ); if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setMetaTag when in non-Buffer mode!"); } if (!exists $args{'http-equiv'}) { $self->doRequiredParameterError('setMetaTag', 'http-equiv'); } if (!exists $args{'content'}) { $self->doRequiredParameterError('setMetaTag', 'content'); } my $httpEquiv = $args{'http-equiv'}; my $content = $args{'content'}; if (length $httpEquiv == 0) { $self->doRequiredParameterError('setMetaTag', 'http-equiv'); } if (length $content == 0) { $self->doRequiredParameterError('setMetaTag', 'content'); } my $metaTag = ""; # first make sure this meta tag has not already been set. foreach my $entry (@{$self->{metaTags}}) { return if ($entry eq $metaTag); } my $num = scalar @{$self->{metaTags}}; $self->{metaTags}[$num] = $metaTag; # store the meta tag info for later display. } =item void refresh(url, seconds) requires: url - URI we should refresh to. This is either an empty string or must be a valid URI. Ex: http://www.xyz.com/index.html currently we check for ftp, http or https as the protocol. If you need a different protocol, let me know and I'll update the check, otherwise you will have to manually use setMetaTag(). optional: seconds - # of seconds we should wait before refreshing. Defaults to 0. Creates the Refresh meta tag. =cut sub refresh { my $self = shift; my %args = ( url => "", seconds => 0, @_ ); my $url = $args{url}; my $seconds = $args{seconds}; # validate the url. if ($url !~ /^(|(ftp|https?)(:\/\/\w+(\.\w+)+)(\/.+)?)$/) { $self->setError(code => "1017"); $self->displayError(message => "url = '$url' is invalid!"); } if ($seconds !~ /^(\d+)$/) { $self->setError(code => "1017"); $self->displayError(message => "seconds = '$seconds' is invalid!"); } $self->setMetaTag('http-equiv' => "Refresh", content => "$seconds" . ($url ? ";url=$url" : "")); } =item void setFocus(section) (scalar value) Validates the section name specified and then sets the internal pointer to the specified section. The output of any following print, read, or delete commands will work with the specified section. Modifies $currentSection. Valid sections are: body head =cut sub setFocus { my $self = shift; if (!defined $_[0]) { $self->doRequiredParameterError('setFocus', 'Section Name'); } if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setFocus when in non-Buffer mode!"); } my $focus = shift; if ($focus ne "head" && $focus ne "body") { $self->setError(code => '1001'); $self->displayError(title => 'Error: setFocus', message => 'Focus = "$focus" is invalid!'); } if ($self->{contentTypeString} !~ /^(text\/html)$/i && $focus ne "body") { $self->setError(code => '1006'); $self->displayError(title => 'Error: setFocus', message => 'Focus = "$focus" is invalid when Content-Type = "$self->{contentTypeString}" is used!'); } $self->{currentSection} = $focus; } # getFocus sub getFocus { my $self = shift; return $self->{currentSection}; } =item void print(string|hash) Appends the contents of string to the currently specified section, previously specified via setFocus(). If you specify a hash, then we use the keys to determine what sections to append text to. This allows you to work with the following sections and data structures by name: sections: - head - body - bodyClass - bodyID - bodyStyle - bodyTitle structures: - style or css - link - cookie - metaTag structures can be modified by sending in a single string or an arrayref of strings to be modified, thus you are not making one really long css entry, but able to split out the individual css entries. All structures are checked to make sure duplicates are not entered. Supported structure entries are not valid sections for the setFocus() function. The hash support was only implemented to allow the HTMLObject::Form code to output all the necessary html code and not force the user to pass in an HTMLObject instance when generating the form. Ex: $doc->print(body => "$bodyStr", head => "$headStr"); $doc->print(css => [ "a { color: red; }", "a { color: red; }" ]); would cause only one instance of the "a { color: red; }" to be output, whereas if you would have specified the css entry as one long string, then it would have done duplicate suppression checking on the entire string and not on it's parts. =cut sub print { my $self = shift; if (scalar @_ == 0) { # nothing to do, move along. return; } if (scalar @_ == 1) { my $text = shift; if (!$self->{bufferMode}) { print $text; return; } if ($self->{currentSection} eq "head") { $self->{headString} .= $text; } elsif ($self->{currentSection} eq "body") { $self->{bodyString} .= $text; } } else { my %args = ( @_ ); if (!$self->{bufferMode}) { print $args{body}; # we can only print to the "body". return; } foreach my $section (keys %args) { if ($section =~ /^(head|body)$/) { my $string = $section . "String"; $self->{$string} .= $args{$section}; } if ($section =~ /^(bodyClass|bodyID|bodyStyle|bodyTitle)$/) { $self->{$section} .= $args{$section}; } if ($section =~ /^(css|style|cookie|metaTag|link)$/) { my @tmpArray; if (ref ($args{$section}) eq "ARRAY") { @tmpArray = @{$args{$section}}; } else { @tmpArray = ($args{$section}); } my $sectionEntry; if ($section =~ /^(style|css)$/) { $sectionEntry = "cssEntries"; } if ($section eq "link") { $sectionEntry = "linkTag"; } if ($section eq "metaTag") { $sectionEntry = "metaTags"; } if ($section eq "cookie") { $sectionEntry = "cookies"; } foreach my $entry (@tmpArray) { my $found = 0; foreach my $tmpEntry (@{$self->{$sectionEntry}}) { if ($entry eq $tmpEntry) { $found = 1; last; } } push @{$self->{$sectionEntry}}, $entry if (!$found); } } } } } # printTag # requires: tag # optional: value, mode (global or single replace) # appends the contents of value to the tagBuffers->{tag} string. # The tagBufferMode is set for the tag # based upon the value of mode. If no mode is specified and a mode has not # yet been set for the tag, then it is defaulted to single replacement # mode, not global replacement. # Tags are only worked with in the BODY section. sub printTag { my $self = shift; my %args = ( tag => "", value => "", @_ ); my $tag = $args{tag}; my $value = $args{value}; my $mode = $args{mode}; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call printTag when in non-Buffer mode!"); } if (length $tag == 0) { $self->doRequiredParameterError('printTag', 'tag'); } # now append to the tagBuffers the string passed in. $self->{tagBuffers}->{$tag} .= $value; # check on the status of the mode if (length $mode > 0) { if ($mode !~ /^(single|global)$/) { $self->setError(code => 1014); $self->displayError(title => "Base::printTag", message => "tag replacement mode = '$mode' is invalid!"); } } else { # make sure we have a mode set. $self->{tagBufferModes}->{$tag} = "single" if (! exists $self->{tagBufferModes}->{$tag}); } } # read sub read { my $self = shift; my $text = ""; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call read when in non-Buffer mode!"); } if ($self->{currentSection} eq "head") { $text = $self->{headString}; } elsif ($self->{currentSection} eq "body") { $text = $self->{bodyString}; } return $text; } # readTag # requires: tag # returns the string from tagBuffers identified by tag sub readTag { my $self = shift; my $tag; if (scalar @_ == 1) { $tag = shift; } else { my %args = ( tag => "", @_ ); $tag = $args{tag}; } if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call readTag when in non-Buffer mode!"); } if (length $tag == 0) { $self->doRequiredParameterError('readTag', 'tag'); } if (! exists $self->{tagBuffers}->{$tag}) { $self->setError(code => "3010"); $self->displayError(title => "Base::readTag", message => "tag = $tag not found in Body of document!"); } # now return the content of tagBuffers for the specified tag. return $self->{tagBuffers}->{$tag}; } # delete sub delete { my $self = shift; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call delete when in non-Buffer mode!"); } if ($self->{currentSection} eq "head") { $self->{headString} = ""; } elsif ($self->{currentSection} eq "body") { $self->{bodyString} = ""; } } # deleteTag # required: tag # We remove the contents from tagBuffers for the tag. sub deleteTag { my $self = shift; my $tag; if (scalar @_ == 1) { $tag = shift; } else { my %args = ( tag => "", @_ ); $tag = $args{tag}; } if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call deleteTag when in non-Buffer mode!"); } if (length $tag == 0) { $self->doRequiredParameterError('deleteTag', 'tag'); } if (not exists $self->{tagBuffers}->{$tag}) { $self->setError(code => "3010"); $self->displayError(title => "Base::deleteTag", message => "tag = $tag not found in Body of document!"); } delete $self->{tagBuffers}->{$tag}; # remove it from the hash, it is now not around to be substitued on when you call display! delete $self->{tagBufferModes}->{$tag}; # remove the mode entry also. } # setBodyBgcolor sub setBodyBgcolor { my $self = shift; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setBodyColor when in non-Buffer mode!"); } if (!defined $_[0]) { $self->doRequiredParameterError('setBodyBgcolor', 'Background Color'); } $self->{bodyBgcolor} = shift; } # getBodyBgcolor sub getBodyBgcolor { my $self = shift; return $self->{bodyBgcolor}; } # setBodyFgcolor sub setBodyFgcolor { my $self = shift; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setBodyFgcolor when in non-Buffer mode!"); } if (!defined $_[0]) { $self->doRequiredParameterError('setBodyFgcolor', 'Text Color'); } $self->{bodyFgcolor} = shift; } # getBodyFgcolor sub getBodyFgcolor { my $self = shift; return $self->{bodyFgcolor}; } # setBodyLinkColor sub setBodyLinkColor { my $self = shift; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setBodyLinkColor when in non-Buffer mode!"); } if (!defined $_[0]) { $self->doRequiredParameterError('setBodyLinkColor', 'Link Color'); } $self->{bodyLinkColor} = shift; } # getBodyLinkColor sub getBodyLinkColor { my $self = shift; return $self->{bodyLinkColor}; } # setBodyVlinkColor sub setBodyVlinkColor { my $self = shift; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setBodyVlinkColor when in non-Buffer mode!"); } if (!defined $_[0]) { $self->doRequiredParameterError('setBodyVlinkColor', 'VLink Color'); } $self->{bodyVlinkColor} = shift; } # getBodyVlinkColor sub getBodyVlinkColor { my $self = shift; return $self->{bodyVlinkColor}; } # setBodyAlinkColor sub setBodyAlinkColor { my $self = shift; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setBodyAlinkColor when in non-Buffer mode!"); } if (!defined $_[0]) { $self->doRequiredParameterError('setBodyAlinkColor', 'ALink Color'); } $self->{bodyAlinkColor} = shift; } # getBodyAlinkColor sub getBodyAlinkColor { my $self = shift; return $self->{bodyAlinkColor}; } # setBodyImage sub setBodyImage { my $self = shift; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setBodyImage when in non-Buffer mode!"); } if (!defined $_[0]) { $self->doRequiredParameterError('setBodyImage', 'Image'); } $self->{bodyImage} = shift; } =item void setBodyClass(class) Specify the class="" value to set in the tag. This is a pass by value, not by name. Ex: $doc->setBodyClass("myBody"); =cut sub setBodyClass { my $self = shift; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setBodyClass when in non-Buffer mode!"); } if (!defined $_[0]) { $self->doRequiredParameterError('setBodyClass', 'class string'); } $self->{bodyClass} = shift; } =item scalar getBodyClass() returns the current value of bodyClass. =cut sub getBodyClass { my $self = shift; return $self->{bodyClass}; } =item void setBodyID(id) Specify the id="" value to set in the tag. This is a pass by value, not by name. Ex: $doc->setBodyID("myID"); =cut sub setBodyID { my $self = shift; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setBodyID when in non-Buffer mode!"); } if (!defined $_[0]) { $self->doRequiredParameterError('setBodyID', 'id string'); } $self->{bodyID} = shift; } =item scalar getBodyID() returns the current value of bodyID. =cut sub getBodyID { my $self = shift; return $self->{bodyID}; } =item void setBodyStyle(style) Specify the style="" value to set in the tag. This is a pass by value, not by name. Ex: $doc->setBodyStyle("color: red;"); =cut sub setBodyStyle { my $self = shift; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setBodyStyle when in non-Buffer mode!"); } if (!defined $_[0]) { $self->doRequiredParameterError('setBodyStyle', 'style string'); } $self->{bodyStyle} = shift; } =item scalar getBodyStyle() returns the current value of bodyStyle. =cut sub getBodyStyle { my $self = shift; return $self->{bodyStyle}; } =item void setBodyTitle(title) Specify the title="" value to set in the tag. This is a pass by value, not by name. Ex: $doc->setBodyTitle("This is a test."); =cut sub setBodyTitle { my $self = shift; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setBodyTitle when in non-Buffer mode!"); } if (!defined $_[0]) { $self->doRequiredParameterError('setBodyTitle', 'title string'); } $self->{bodyTitle} = shift; } =item scalar getBodyTitle() returns the current value of bodyTitle. =cut sub getBodyTitle { my $self = shift; return $self->{bodyTitle}; } # setBase # parameters: href, target sub setBase { my $self = shift; my %args = ( href => '', target => '', @_, ); if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setBase when in non-Buffer mode!"); } my $href = $args{'href'}; my $target = $args{'target'}; if (length $href == 0 && length $target == 0) { $self->doRequiredParameterError('setBase', 'href and/or target'); } $self->{baseHrefString} = $href; $self->{baseTargetString} = $target; } # setLink # required: href, rel, type # optional: name, rev, target, title, charset, hreflang, src, media sub setLink { my $self = shift; my %args = ( @_, ); if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setLink when in non-Buffer mode!"); } my $href = $args{'href'}; my $name = $args{'name'}; my $rel = $args{'rel'}; my $rev = $args{'rev'}; my $type = $args{'type'}; my $title = $args{'title'}; my $target = $args{'target'}; my $charset = $args{charset}; my $hreflang = $args{hreflang}; my $src = $args{src}; my $media = $args{media}; if (!exists $args{'href'}) { $self->doRequiredParameterError('setLink', 'href'); } if (!exists $args{'rel'}) { $self->doRequiredParameterError('setLink', 'rel'); } if (!exists $args{'type'}) { $self->doRequiredParameterError('setLink', 'type'); } my $link = " 0) { $link .= " title=\"$title\""; } if (length $rev > 0) { $link .= " rev=\"$rev\""; } if (length $name > 0) { $link .= " name=\"$name\""; } if (length $target > 0) { $link .= " target=\"$target\""; } if (length $src > 0) { $link .= " src=\"$src\""; } if (length $hreflang > 0) { $link .= " hreflang=\"$hreflang\""; } if (length $charset > 0) { $link .= " charset=\"$charset\""; } if (length $media > 0) { $link .= " media=\"$media\""; } $link .= " />\n"; # first make sure this link has not been set. foreach my $entry (@{$self->{linkTag}}) { return if ($entry eq $link); } my $num = scalar @{$self->{linkTag}}; $self->{linkTag}[$num] = $link; } =item void setStyleEntry(tag => '', attributes => undef, string => '') requires: tag optional: attributes (ref to hash of name, value pairs to apply to this tag), or string (name: value; - must be valid css) This generates a CSS entry to specify the style for the tag you specified. =cut sub setStyleEntry { my $self = shift; my %args = ( tag => '', attributes => undef, string => "", @_ ); my $tag = $args{tag}; my $attributes = $args{attributes}; # This is a hash ref. my $string = $args{string}; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setStyleEntry when in non-Buffer mode!"); } if (length $tag == 0) { $self->doRequiredParameterError('setStyleEntry', 'tag'); } if ((! defined $attributes) && (length $string == 0)) { $self->doRequiredParameterError('setStyleEntry', 'attributes or string'); } if (length $string == 0 && scalar keys %{$attributes} == 0) { $self->setError(code => '3000'); $self->displayError(title => 'setStyleEntry', message => 'You must specify attributes to set for tag = \'$tag\'!'); } # now generate the string that will be added to the css array. my $cssString = $tag . " { "; if (length $string > 0) { $cssString .= $string . " "; } else { foreach my $name (keys %{$attributes}) { my $value = $attributes->{$name}; $cssString .= $name . ": " . $value . "; "; } } $cssString .= "}\n"; # first make sure this style entry has not been made yet. foreach my $entry (@{$self->{cssEntries}}) { return if ($entry eq $cssString); } my $num = scalar @{$self->{cssEntries}}; $self->{cssEntries}[$num] = $cssString; } =item void setLinkDecorations(link => 'none', alink => 'none', vlink => 'none', hover => '') This function allows the user to specify the decorations that the link, visited link, active link and hover link have. If you specify nothing, then by default it turns off all decorations (no underline). This generates a CSS section to specify the link decorations you desire. You should really generate your own CSS using setStyleEntry(). =cut sub setLinkDecorations { my $self = shift; my %args = ( link => 'none', alink => 'none', vlink => 'none', hover => 'blue', @_, ); if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setLinkDecorations when in non-Buffer mode!"); } my $link = $args{'link'}; my $alink = $args{'alink'}; my $vlink = $args{'vlink'}; my $hover = $args{'hover'}; # make sure that the specified decorations are one of (none, underline, overline, line-through, blink) if ($link !~ /none|underline|overline|line-through|blink/i) { $self->setError(code => '3001'); $self->displayError(title => 'setLinkDecorations', message => "'$link' is invalid decoration for link!"); } if ($alink !~ /none|underline|overline|line-through|blink/i) { $self->setError(code => '3001'); $self->displayError(title => 'setLinkDecorations', message => "'$alink' is invalid decoration for alink!"); } if ($vlink !~ /none|underline|overline|line-through|blink/i) { $self->setError(code => '3001'); $self->displayError(title => 'setLinkDecorations', message => "'$vlink' is invalid decoration for vlink!"); } if (length $hover == 0) { $self->setError(code => '3002'); $self->displayError(title => 'setLinkDecorations', message => "hover must have a color!"); } # create the style sheet entries that defines our text decorations. # they must be done in the order of link, visited, hover, active for the # css properties to properly cascade! Found this out in the CSS2 documentation. $self->setStyleEntry(tag => "a:link", string => "text-decoration: $link;"); $self->setStyleEntry(tag => "a:visited", string => "text-decoration: $vlink;"); $self->setStyleEntry(tag => "a:hover", string => "color: $hover;"); my %attributes = ( "text-decoration" => $alink ); $self->setStyleEntry(tag => "a:active", attributes => \%attributes); } =item void setLocation(url) requires: url - url to redirect to. summary: When you call this method and then display(), any cookies defined will be output and then the Location: header. This will only be done if the contentType = text/html. All other content will be ignored. There is currently no extra checks being done to stop you from continuing to specify content and the startDisplaying() method does not check for or display the location property. Only the Base and Normal modules have been updated to honor this attribute when calling display(). Ex: $doc->setLocation("http://www.test.com/cgi-bin/index.cgi?cmd=hi"); =cut sub setLocation { my $self = shift; my $url = shift; if (!$self->{bufferMode}) { $self->setError(code => "1013"); $self->displayError(message => "You can not call setLocation when in non-Buffer mode!"); } if (length $url == 0) { $self->doRequiredParameterError('setLocation', 'url'); } # validate the url. if ($url !~ /^(ftp|https?)(:\/\/\w+(\.\w+)+)(\/.+)?$/) { $self->setError(code => "1017"); $self->displayError(message => "url = '$url' is invalid!"); } $self->{location} = $url; } =item scalar getLocation() returns the current location value. =cut sub getLocation { my $self = shift; return $self->{location}; } =item scalar makeValidHTML(string) requires: string - string to cleanup optional: returns: cleaned up string summary: basically converts all valid html tags to lowercase. converts
->
and
->
tries to make sure that all attributes are lowercase and double quoted. Adds an ="1" to any attributes that are alone, like a multiple attribute in a ->