in reply to What does your old Perl code look like?
#!/usr/bin/perl -w use strict; use warnings; ############################### # CONSTANTS my $ABSOLUTE_PATH = '/home/lentnews05/public_html'; my $SUCCESS = 0; my $FAILURE = 1; ############################### # PROGRAM STARTS HERE my $INPUT = $ENV{"QUERY_STRING"}; if (!$INPUT) { FAILED("Please provide the Event Number in the address +bar followed by a question mark."); exit; } if (isNaN($INPUT)) { FAILED("Please provide the Event Number in the address bar."); exit; + } if (length($INPUT) > 10) { FAILED("The Event Number cannot be longer than 10 digits."); exit; } my $NEW_EVENT = $INPUT; ############################### # MAIN PROGRAM UPDATE($ABSOLUTE_PATH . '/main.htm'); UPDATE($ABSOLUTE_PATH . '/index.htm'); UPDATE($ABSOLUTE_PATH . '/index.html'); # Success print "Content-type: text/html\n\n"; print "<HTML><HEAD><TITLE>Update Successful</TITLE></HEAD>\n"; print "<BODY BGCOLOR=006600 TEXT=FFFFCC LINK=CCFFCC ALINK=CCFFCC VLINK +=CCFFCC>\n"; print "<H1>Update Successful.</H1>\n"; print "<H3>Event Number = $NEW_EVENT</H3>\n"; print "<H3><A TARGET='_blank' HREF='http://www.lentnews05.org'>www.len +tnews05.org</A></H3>\n"; exit; ############################### # This function displays an # error message. # sub FAILED { my $MSG = shift; # Error message print "Content-type: text/html\n\n"; print "<HTML><HEAD><TITLE>Error</TITLE></HEAD>\n"; print "<BODY BGCOLOR=550000 TEXT=FFFFFF LINK=FFFFCC ALINK=FFFFCC VLI +NK=FFFFCC>\n"; print "<H1>Website did not update.</H1>\n"; print "<H3>Error: $MSG</H3>\n"; print "<H3><A TARGET='_blank' HREF='http://www.lentnews05.org'>www.l +entnews05.org</A></H3>\n"; } ############################### # This function overwrites the # Event Number in the index file. # sub UPDATE { my $P; my $DATA1; my $DATA2; my $FileName = shift; my $DATA = ReadFile($FileName); if (length($DATA) == 0) { FAILED("Couldn't read $FileName"); exit; } $P = index($DATA, 'EVENT_NO = '); if ($P < 0) { FAILED("Couldn't find EVENT_NO in $FileName"); exit; } $DATA1 = substr($DATA, 0, $P); $P = index($DATA, ';', $P); if ($P < 0) { FAILED("$FileName doesn't have a proper text body."); +exit; } $DATA2 = substr($DATA, $P+1); $DATA = $DATA1 . "EVENT_NO = $NEW_EVENT;" . $DATA2; if (WriteFile($FileName, $DATA)) { FAILED("Couldn't write to file - $FileName"); exit; } } ################################################ # # This function reads an entire file silently # in raw binary mode and returns the contents # in one big string. If an error occurs, # an empty string is returned. # # Usage: STRING = ReadFile( FILE_NAME ) # sub ReadFile { my $N; my $DATA; my $filename = shift; return '' if !(-f $filename); my $filesize = -s $filename; if ($filesize == 0) { return ''; } open(my $FILE, '<:raw', $filename) or return ''; $N = read($FILE, $DATA, $filesize); close $FILE; if (!defined $N) { return ''; } return substr $DATA, 0, $N; } ################################################ # This function adds some text to the end of # a file or returns 1 if something went wrong. # # Usage: STATUS = AppendFile( FILE_NAME, STRING ) # sub AppendFile { my ($filename, $DATA) = @_; open(my $FILE, '>>', $filename) or return 1; print $FILE $DATA or return 1; close $FILE or return 1; return 0; } ################################################ sub WriteFile { my ($filename, $DATA) = @_; open(my $FILE, '>', $filename) or return 1; print $FILE $DATA or return 1; close $FILE or return 1; return 0; } ################################################ # Prints a horizontal line to STDOUT. # # Usage: HR(OPTIONAL_STRING_BYTE) # # HR(); ---> ---------------------------- # HR('='); ---> ============================ # # sub HR { my $C = '-'; if ((scalar @_) > 0) { $C = shift; } print "\n" . (substr($C, 0, 1)) x 80; } ################################################ # This function extracts arguments from an URL # string and returns them in pairs. # # Example: @R = getArgsURL("http://www.lentnews05.org/g/ar.cgi?c=12305 +5&s=%28Top+Stories+%29#PGTOP"); # R[0] ---> "c" # R[1] ---> "123055" # R[2] ---> "s" # R[3] ---> "(Top Stories)" # sub getArgsURL { my $S = shift; my @OUTPUT; my @X; my $P; $S = strAfter($S, '?'); $S = strBefore($S, '#'); @X = split('&', $S); foreach $S (@X) { splitAB($S, '='); push(@OUTPUT, decodeURLstr($a)); push(@OUTPUT, decodeURLstr($b)); } return @OUTPUT; } ################################################ # This function works almost like split() # however it will only split STRING into two # chunks. If the pattern is found, the section before # the first occurrence of PATTERN goes into $a, # and rest goes into $b. # # (This function has no return value. It just # simply changes the values of $a and $b.) # # Usage : splitAB(STRING, PATTERN) # sub splitAB { my $S = shift; my $P = shift; $a = $b = ''; if (length($S) == 0) { return; } if (length($P) == 0) { $a = $S; return; } my $N = index($S, $P); if ($N < 0) { $a = $S; return; } $a = substr $S, 0, $N; $b = substr $S, $N + length($P); } ################################################ # This function returns the first half of STRING # that comes before the first occurrence of PATTERN. # If PATTERN is not found, then returns an empty string. # # Usage: STRING strBefore(STRING, PATTERN) # sub strBefore { my $STRING = shift; my $PATTERN = shift; my $P = index($STRING, $PATTERN); return '' if ($P < 0); return substr($STRING, 0, $P); } ################################################ # This function returns the last half of STRING # that comes after the first occurrence of PATTERN. # If PATTERN is not found, then returns an empty string. # # Usage: STRING strAfter(STRING, PATTERN) # sub strAfter { my $STRING = shift; my $PATTERN = shift; my $P = index($STRING, $PATTERN); return '' if ($P < 0); return substr($STRING, $P + length($PATTERN)); } ############################################ # # This function works like the index() function, # except it looks for individual characters # instead of an exact string match. It returns # the position of the first single character in # STRING that matches any of the characters in # CHRS. If none of the characters in STRING # match any character in CHRS, -1 is returned. # Matching is case sensitive. # # If a third argument is supplied, this function # works the opposite way: it returns the position # of the first NON-matching character. # # Usage: INTEGER strchr(STRING, CHRS) # INTEGER strchr(STRING, CHRS, MODE) # # Example: strchr("cat5hr", "0123456789") ---> 3 # strchr("sharks", "0123456789") ---> -1 # strchr("2,587.91", "0123456789.,", 0) ---> -1 # strchr("2,5?7.91", "0123456789.,", 0) ---> 3 # sub strchr { my $STRING = shift; my $CHRS = shift; my $MODE = ((scalar @_) > 0) ? 1 : 0; my $C; for (my $i = 0; $i < length($STRING); $i++) { $C = substr($STRING, $i, 1); if (((index($CHRS, $C)) < 0 ? 1 : 0) == $MODE) { return $i; } } return -1; } ############################################ # # This function compares characters in STRING1 # against a list of legal characters listed # in STRING2 to see if any character in STRING1 # is not found in STRING2. If all match, the # return value is 1. If even just one of the # characters in STRING1 is not found anywhere # in STRING2, the return value is 0. # Matching is case sensitive. # # Usage: INTEGER chrset(STRING1, STRING2) # # Example: chrset("221", "12345") ---> 1 # chrset("21x", "12345") ---> 0 # chrset("box", "abcdef") ---> 0 # sub chrset { my ($S, $SET) = @_; for (my $i = 0; $i < length($S); $i++) { return 0 if (index($SET, substr($S, $i, 1)) < 0); } return 1; } ############################################ # # This function returns 0 if the input string # is a decimal number, or otherwise returns 1. # Use this function to test small numbers only # (less than 15 digits is safe)! # # Usage: INTEGER isNaN( STRING ) # # Example: # isNaN('.0009') ---> 0 # isNaN('12345') ---> 0 # isNaN('-1234.5717') ---> 0 # isNaN('abc55') ---> 1 # sub isNaN { my $N = shift; return 1 unless (defined $N); return 1 unless (length($N) > 0); for (my ($i, $C, $D) = 0; $i < length($N); $i++) { $C = ord(substr($N, $i, 1)); if ($C < 48 || $C > 57) { if ($C == 43 || $C == 45) { next if ($i == 0); } elsif ($C == 46) { next if ($D++ == 0); } return 1; } } return 0; } ############################################ # # This function removes leading and trailing # spaces, tabs, and new-line characters # from a string and returns a new string. # It can also be used to trim other characters # such as leading and trailing zeroes. # # Usage: STRING trim(STRING) # STRING trim(STRING, CHRS) # # Example: trim("\t a b c \r\n"); ---> "a b c" # trim('$000090.50', '$0'); ---> "90.5" # trim('CABxxAxABBCC', 'ABC'); ---> "xxAx" # sub trim { my $j = 0; my $i = -1; my $STR = shift; my $REMOVE = ((scalar @_) > 0) ? shift : " \t\r\n"; if (length($STR) == 0) { return ''; } for (my $x = 0; $x < length($STR); $x++) { if (index($REMOVE, substr($STR, $x, 1)) < 0) { if ($i < 0) { $i = $x; } $j = $x - $i + 1; } } return substr($STR, $i, $j); } ############################################ # # This function converts an integer (0-255) # to a two-digit hexadecimal string. # # Usage: STRING toHex( NUMBER ) # sub toHex { my $N = int( shift ); return '00' if ($N <= 0); return 'FF' if ($N >= 255); my $X = '0123456789ABCDEF'; my $LO = $N & 0x0F; my $HI = $N >> 4; return substr($X, $HI, 1) . substr($X, $LO, 1); } ############################################ # # This function is the same as the escape() # function in JavaScript. It takes the input # string and leaves letters and numbers and # 7 special characters intact but converts # all the other characters to %XX format # where XX is a hex number. # # Only the following 7 special characters # are left intact : /@+*-._ # # Usage: STRING escape( STRING ) # # Example: "Hello World!" --> "Hello%20World%21" # sub escape { my $C; my $BYTE; my $ENCODE; my $INPUT = shift; my @OUTPUT; for (my $i = 0; $i < length($INPUT); $i++) { $ENCODE = 0; $BYTE = substr($INPUT, $i, 1); $C = ord($BYTE); if ($C < 42 || $C > 122) { $ENCODE = 1; } elsif ($C > 57 && $C < 64) { $ENCODE = 1; } elsif ($C > 90 && $C < 95) { $ENCODE = 1; } elsif ($C == 44 || $C == 96) { $ENCODE = 1; } $BYTE = ($ENCODE) ? '%' . toHex($C) : $BYTE; push(@OUTPUT, $BYTE); } return join("", @OUTPUT); } ############################################ # This is the opposite of the escape() function. # sub unescape { my $XX; my $BYTE; my $INPUT = shift; my @OUTPUT; for (my $i = 0; $i < length($INPUT); $i++) { $BYTE = substr($INPUT, $i, 1); if (ord($BYTE) == 37) { $BYTE = ''; $XX = substr($INPUT, $i+1, 2); if (length($XX) == 2) { $i += 2; $BYTE = chr(hex($XX)); } } push(@OUTPUT, $BYTE); } return join("", @OUTPUT); } ################################################ # This function decodes an URL-style string. # Works like the unescape function, however # it will also convert '+' signs to spaces. # sub decodeURLstr { my $S = shift; $S =~ tr /+/ /; return unescape($S); }
|
|---|