=head1 NAME ismclib.pl =head1 DESCRIPTION General ISMC perl library Function list: ismctop ismcbottom Local_Date_YYYYMMDD GMT_Date_YYYYMMDD FormatDate escapeHTML ascii2hex hex2ascii get_args un_meta IMPORTANT NOTE: The "master source" for this file is /solsrvr1-u/intelink/toc/bin/ismclib.pl. If you make any changes make them in the master as updates across the systems will involve copying the master to the appropriate directories (without looking first) Read and heed. =head2 CHANGES 1997 03 17 - New (RB) 1997 04 08 - Added un_meta (KDH) 1997 12 12 - Added FormatDate (TCB) =head1 FUNCTIONS =over 4 =cut package ismclib; use Sys::Hostname; $thishost = hostname(); $doc_root = "/$thishost/intelink"; $basedir = "$doc_root/toc/includes"; $caller = $main::0; $document_class; # This is global to package and is set in ismctop() =item ismctop Print out an ISMC document header. This prints required metadata elements and prints them then takes the ISMC standard server side includes and expands them for use within a cgi script. There are THREE manadatory args - TITLE, CLASS_ABBREV and KEYWORDS and ONE optional arg - COUNTRIES. syntax - &ismclib::ismctop("Your Document Title","syshigh","keyword1 keyword2"); &ismclib::ismctop("Your Document Title","syshigh","keyword1 keyword2","US UK KO"); =cut sub ismctop { my($title,$class_abbrev,$keywords,$countries) = @_; my($class_file) = "$basedir/$class_abbrev" . "_top.html"; $countries = "" unless $countries; $document_class = $class_abbrev; my($line,$line2); die "$caller ismctop() ERROR - Title must be supplied\n" unless $title; die "$caller ismctop() ERROR - Classification must be supplied\n" unless $class_abbrev; die "$caller ismctop() ERROR - Keywords must be supplied\n" unless $keywords; die "$caller ismctop() ERROR - include directory missing. Is this an ISMC web server?\n" unless -d $basedir; die "$caller ismctop() ERROR - Classification is not valid\n" unless -e $class_file; my($postdate) = &Local_Date_YYYYMMDD; my($class_upper) = $class_abbrev; $class_upper =~ tr/a-z/A-Z/; my(@keyword_list) = split(/ /,$keywords); $keywords = join(",",@keyword_list); print < $title EOM ; # Read in the classification file - expand any server side includes open(CLASS,$class_file) || die "$caller ismctop() ERROR - Can't open $class_file: $!\n"; foreach $line (){ while ($line =~ s'^(.*?)(.*?)$''ios) { my($prefix) = $1; my($included_file) = $2; my($suffix) = $3; $included_file =~ s#\s##g; $included_file =~ s#\"-->##; $included_file = "$doc_root/$included_file"; print $prefix; open(INCLUDE,$included_file) || die "$caller ismctop() ERROR - Can't open $included_file: $!\n"; foreach $line2 (){ print $line2; } close(INCLUDE); print $suffix; } print $line; } close(CLASS); print "

$title

\n"; } =item ismcbottom Print out an ISMC trailer. This will expand the ISMC standard server side includes for use within a cgi script. Document classification is set as a package global in ismctop(). syntax - &ismclib::ismcbottom; =cut sub ismcbottom { my($class_file) = "$basedir/$document_class" . "_bottom.html"; my($line,$line2); die "$caller ismcbottom() ERROR - document classification not defined. Must use ismctop() first\n" unless length($document_class) > 0; die "$caller ismcbottom() ERROR - include directory missing. Is this an ISMC web server?\n" unless -e $basedir; die "$caller ismcbottom() ERROR - Problem with classification file\n" unless -e $class_file; # Read in the classifcation file - expand any server side includes open(CLASS,$class_file) || die "$caller ismcbottom() ERROR - Can't open $class_file: $!\n"; foreach $line (){ while ($line =~ s'^(.*?)(.*?)$''ios) { my($prefix) = $1; my($included_file) = $2; my($suffix) = $3; $included_file =~ s#\s##g; $included_file =~ s#\"-->##; $included_file = "$doc_root/$included_file"; print $prefix; open(INCLUDE,$included_file) || die "$caller ismcbottom() ERROR - Can't open $included_file: $!\n"; foreach $line2 (){ $line2 =~ s///gos; if ($line2 =~ m##) { my($lastupdate) = &Local_Date_YYYYMMDD; $line2 =~ s//$lastupdate/; } print $line2; } close(INCLUDE); print $suffix; } print $line; } close(CLASS); } =item Local_Date_YYYYMMDD Takes the local time and returns YYYYMMDD format. Note: This works for YR2000 as local time returns the current year minus 1900 (so for the year 2000, year = 100, set $indate to 946702800 if you would like to test it). syntax - $your_date_string = &ismclib::Local_Date_YYMMDD; $your_date_string = &ismclib::Local_Date_YYMMDD($some_arbitrary_unix_timestamp); =cut sub Local_Date_YYYYMMDD { my($indate) = @_; my($outdate); $indate = time unless $indate > 0; my($day,$mon,$year) = (localtime($indate))[3,4,5]; $year += 1900; $outdate = sprintf("%04d%02d%02d",$year,($mon + 1), $day); return($outdate); } =item GMT_Date_YYYYMMDD Takes the GMT time and returns YYYYMMDD format. Note: This works for YR2000 as local time returns the current year minus 1900 (so for the year 2000, year = 100, set $indate to 946702800 if you would like to test it). syntax - $your_date_string = &ismclib::GMT_Date_YYMMDD; $your_date_string = &ismclib::GMT_Date_YYMMDD($some_arbitrary_unix_timestamp); =cut sub GMT_Date_YYYYMMDD { my($indate) = @_; my($outdate); $indate = time unless $indate > 0; my($day,$mon,$year) = (gmtime($indate))[3,4,5]; $year += 1900; $outdate = sprintf("%04d%02d%02d",$year,($mon + 1), $day); return($outdate); } =item FormatDate Takes the GMT and local time and returns MMMDDYYYY HH:MM GMT $HH:MM LTZ) format. Note: This works for YR2000 as local time returns the current year minus 1900 (so for the year 2000, year = 100, set $indate to 946702800 if you would like to test it). syntax - $your_date_string = &ismclib::FormatDate; $your_date_string = &ismclib::FormatDate($some_arbitrary_unix_timestamp); =cut sub FormatDate { # Format date string my($indate) = @_; my($outdate); $indate = time unless $indate > 0; local(@months)=("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"); my($sec,$min,$hour,$day,$month,$year) = gmtime($indate); my($localhour) = (localtime($indate))[2]; my($localtimezone) = (EST,EDT)[(localtime($indate))[8]]; $month = @months[$month]; $year += 1900; $outdate = sprintf("$month %02d $year, %02d:%02d GMT \(%02d:%02d $localtimezone$", $day,$hour,$min,$localhour,$min); return ($outdate); } =item escapeHTML "escape" special HTML characters -- from ORA "Mouse Book" p.344 syntax - $your_variable = &ismclib::escapeHTML($your_variable); =cut sub escapeHTML { my($string)=@_; my(%html_chars, $html_string); %html_chars = ('&', '&', '>', '>', '<', '<', '"', '"'); $html_string= join("", keys %html_chars); # concatenate with no separator char # replace any char in 'html_string' with the corresponding escape sequence $string =~ s/([$html_string])/$html_chars{$1}/go; return($string); } =item hex2ascii Convert hex encoded characters to ASCII (from ORA "mouse book" page 65 ) ...special case: control chars with leading '0' ... [GLA] syntax - $your_variable = &ismclib::hex2ascii($your_variable); =cut sub hex2ascii { my($string) = @_ ; $string =~ s/%0([\dA-Fa-f])/pack("C", hex($1))/eg; # ...this is the ORA code: 'hex' won't do anything with leading '0' $string =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack("C", hex($1))/eg; return($string); } =item ascii2hex Convert ASCII characters to hex encoded from ORA "mouse book" page 61 ... BUT make a change ... add '02' to format to force 2 characters and pad with leading zero [GLA] ... substitute hex code for all "non-word" characters... syntax - $your_variable = &ismclib::ascii2hex($your_variable); =cut sub ascii2hex { my($string) = @_ ; $string =~ s/(\W)/sprintf("%%%02x", ord($1))/eg; # Explanation of '%%%' syntax: the first '%' is to define the format string # the last two '%' are to define one single literal '%' char. # this is overkill... let's NOT do spaces $string =~ s/%20/ /g; return($string); } =item get_args This subroutine parses CGI arguments whether in GET or POST format arguments are assumed to be in URL-encoded form: arguments are listed as "key=value" pairs... spaces are encoded with plus (+)... special characters are hex-encoded Modified: 8/1/1996 GLA syntax - %your_array = &ismclib::get_args; =cut sub get_args { my(%argsout); my ($in,$content_length, $i, $key, $val); my(@pairs); # Read in text from the 'QUERY_STRING' portion of the URL if using "GET" if ($ENV{'REQUEST_METHOD'} eq "GET") { $in = $ENV{'QUERY_STRING'}; } # Read in text from STDIN if using "POST" method elsif ($ENV{'REQUEST_METHOD'} eq "POST") { $content_length = $ENV{'CONTENT_LENGTH'}; read(STDIN, $in, $content_length); } # Read in from the command line if neither # ADD this result to $in $in .= $ARGV[0]; @pairs = split(/&/,$in); # Split into key/value entries foreach $i (@pairs) { # work through each key/value pair ... $i =~ s/\+/ /g; # Convert pluses to spaces $i = &hex2ascii($i); # convert hex encoded characters to ASCII ($key, $val) = split(/=/, $i, 2); # separate key and value from key=value pairs # NOTE: $val may be null when keyword stands alone # append separator char '\0' if item already exists $argsout{$key} .= "\0" if (defined($in{$key})); $argsout{$key} .= $val; # append the value } return %argsout; } =item un_meta Convert REGEX special characters and semi-colons to %00 format hex encoded characters. This prevents these characters from interfering with regular expressions embedded in code. ie: "s/$in_string/something else/" WILL have problems if $in_string contains any of these characters. syntax - $your_variable = &ismclib::un_meta($your_variable); =cut sub un_meta { my($string) = @_ ; # Convert regex meta-characters and semi-colons to HEX encoded $string =~ s/( \\| # check for '\' OR \|| # '|' OR $| # '(' OR $| # ')' OR \[| # '[' OR \{| # '{' OR \^| # '^' OR \$| # '$' OR \*| # '*' OR \+| # '+' OR \?| # '?' OR \;| # ';' OR \. # '.' )/sprintf("%%%02x", ord($1))/egx; # explanation of '%%%' syntax: the first '%' is to define the format string # the last two '%' are to define one single literal '%' char return($string); } 1; # Its a library so we must return a true value