[29720] in Perl-Users-Digest
Perl-Users Digest, Issue: 964 Volume: 11
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Mon Oct 22 00:14:16 2007
Date: Sun, 21 Oct 2007 21:14:06 -0700 (PDT)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Perl-Users Digest Sun, 21 Oct 2007 Volume: 11 Number: 964
Today's topics:
need help with a cart I inherited, need to increase num fbspector@excaliburit.com
Re: perl standard sln@netherlands.co
Re: perl standard <tadmc@seesig.invalid>
Re: perl standard <zaxfuuq@invalid.net>
Re: perl standard <zaxfuuq@invalid.net>
sockets problem <stanciutheone@gmail.com>
Re: splitting a line <rkb@i.frys.com>
Re: splitting a line <zaxfuuq@invalid.net>
Digest Administrivia (Last modified: 6 Apr 01) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: Sun, 21 Oct 2007 19:59:04 -0700
From: fbspector@excaliburit.com
Subject: need help with a cart I inherited, need to increase number of total characters allowed
Message-Id: <1193021944.694415.20070@t8g2000prg.googlegroups.com>
#!/usr/bin/perl
# use strict;
# ************************** #
# Misc. setups and variables #
# ************************** #
&parse_input;
close(STDERR);
$BASEDATA =3D $root_dir . '/shopcart/data/base_data.txt';
eval "require '$BASEDATA'";
if ($@) {
&sc_popup_msg("STARTUP ERROR SC01: Basic database not found or is in
error. Be sure the SCdatabase ADMIN function was completed
correctly");
}
(@cards) =3D split(/,/, $CARD_TYPES);
($credit_card,$mail_check,$c_o_d) =3D split(/,/, $PYMT_OPTIONS);
if ($credit_card eq "") {
$credit_card =3D 1;
}
if ($mail_check eq "") {
$mail_check =3D 0;
}
if ($c_o_d eq "") {
$c_o_d =3D 0;
}
$security =3D 0;
$pa_tax =3D 0;
$pa_amt =3D 0;
$tellit =3D "";
$SUBTOTAL =3D 0;
$ITEMCOUNT =3D 0;
$FILE_LOCK_WAIT =3D 10; # in seconds #
$ORDER_DATA_KEEP =3D 20; # in minutes #
$BASE_DIR =3D $root_dir . '/shopcart/';
$USERDATA =3D $root_dir . '/shopvar/user_data.txt';
$PRODDATA =3D $root_dir . '/shopcart/data/product_data.txt';
$SHIPDATA =3D $root_dir . '/shopcart/data/shipping_data.txt';
$TEMP_DIR =3D $root_dir . '/shopvar/';
$TEMP_DATA =3D $root_dir . '/shopvar/rlist_data.txt';
$TEMP_FILE =3D $root_dir . '/shopvar/r' . "$$" . '.html';
$TEMP_PAGE =3D $SITE_URL . '/shopvar/r' . "$$" . '.html';
$EMAIL_ORDER =3D $root_dir . '/shopcart/data/email_order.txt';
$EMAIL_THANKS =3D $root_dir . '/shopcart/data/email_thanks.txt';
#
***************************************************************************=
****************
#
# Remove any expired info in the userdata file #
# ******************************************** #
if (&lock("userdata")) {
&sc_popup_msg($Popup_Message);
}
if (!(-e $USERDATA)) {
open(USERDATA, "+>$USERDATA"); close USERDATA;
}
open(USERDATA, $USERDATA) || &sc_popup_msg("SYSTEM ERROR SC02: Unable
to access $USERDATA for cart storage: $!");
@userdata =3D <USERDATA>;
close(USERDATA);
$current_time =3D time;
foreach $data_line (@userdata) {
($uid, $expire_time, $SUBTOTAL, $order_info) =3D split(/\|\|/,
$data_line);
if ($current_time < $expire_time) {
push(@NOT_EXPIRED, $data_line);
}
else {
$expired_flag =3D 1;
}
}
if ($expired_flag =3D=3D 1) {
open(USERDATA, ">$USERDATA") || &sc_popup_msg("SYSTEM ERROR SC03:
Unable to access $USERDATA for cart storage: $!");
foreach $data_line (@NOT_EXPIRED) {
print USERDATA $data_line;
}
close(USERDATA);
}
&unlock("userdata");
#
***************************************************************************=
****************
#
# If a UID was in QUERY_STRING set $uid and find their #
# info in the userdata file, otherwise set new user uid #
# ***************************************************** #
if ($FORM{'uid'}) {
$uid =3D $FORM{'uid'};
if (&lock("userdata")) {
&sc_popup_msg($Popup_Message);
}
open(USERDATA, $USERDATA) || &sc_popup_msg("SYSTEM ERROR SC04: Unable
to access $USERDATA for cart storage: $!");
while (<USERDATA>) {
if (/^$uid\|\|(.*)/) {
($expire_time, $SUBTOTAL, $order_info) =3D split(/\|\|/, $1);
$entry_flag =3D 1;
@items =3D split(/\|/, $order_info);
foreach $item (@items)
{
($c_prod, $c_qty, $junk) =3D split(/=A4/, $item);
$ITEMCOUNT +=3D $c_qty;
}
last;
}
}
close(USERDATA);
&unlock("userdata");
if (!$entry_flag) {
&new_user;
}
}
else {
&new_user;
}
#
***************************************************************************=
****************
#
# Load the database & init global lists
# ***************************************** #
&read_products_database;
#
***************************************************************************=
****************
#
# If HOME in QUERY_STRING pull in and parse the home.html template #
# ***************************************** #
if ($FORM{'home'})
{
if ($FORM{'uid'})
{
&update_expire_time;
&home_html_parse;
}
else
{
# no UID in URL, so fix & reload
$link =3D $SHOPCART_URL . "?uid=3D" . $uid . "&rootdir=3D" . $root_dir .
"&home=3D1";
print "Content-type: text/html\n\n";
print "<html><head>\n<meta http-equiv=3D\"refresh\" content=3D\"1;url=3D" .
$link . "\">\n</head>\n";
print "<body bgcolor=3D\"fad6b0\"><font color=3D\"fad6b0\">\n";
print "click <a href=3D\"" . $link . "\"></a></font>.\n";
print "</body></html>\n";
}
exit;
}
#
***************************************************************************=
****************
#
# If ITEM was in QUERY_STRING set $item and #
# pull in and parse the item.html template #
# ***************************************** #
if ($FORM{'item'}) {
$item =3D $FORM{'item'};
$columns =3D $FORM{'columns'};
&update_expire_time;
&item_html_parse;
exit;
}
#
***************************************************************************=
****************
#
# If home was in QUERY_STRING
# pull in and parse the home.html template #
# ***************************************** #
if ($FORM{'home'}) {
&update_expire_time;
&generic_html_parse('home.html');
exit;
}
#
***************************************************************************=
****************
#
# If contact was in QUERY_STRING
# pull in and parse the contact.html template #
# ***************************************** #
if ($FORM{'contact'}) {
&update_expire_time;
&generic_html_parse('contact.html');
exit;
}
#
***************************************************************************=
****************
#
# If terms was in QUERY_STRING
# pull in and parse the terms.html template #
# ***************************************** #
if ($FORM{'terms'}) {
&update_expire_time;
&generic_html_parse('terms.html');
exit;
}
#
***************************************************************************=
****************
#
# If GROUP was in QUERY_STRING set $group & #
# pull in and parse the group.html template #
# ***************************************** #
if ($FORM{'group'}) {
$group =3D $FORM{'group'};
$columns =3D $FORM{'columns'};
if ($FORM{'pagenum'})
{
$pagenum =3D 1 * $FORM{'pagenum'};
}
else
{
$pagenum =3D 1;
}
&update_expire_time;
&group_html_parse;
exit;
}
#
***************************************************************************=
****************
#
# If CHECKOUT or EDIT was in the QUERY_STRING #
# pull in and parse checkout.html & any changes #
# ********************************************* #
if ( ($FORM{'checkout'}) || ($FORM{'edit'}) )
{
&update_expire_time;
&checkout_html_parse;
exit;
}
#
***************************************************************************=
****************
#
# If the command is advanced search, pull in and parse advsearch.html
#
#*************************************************#
if ($FORM{'advsearch'})
{
&update_expire_time;
&advsearch_html_parse;
exit;
}
#
***************************************************************************=
****************
#
# If the command is to search the database, run the search #
# and create a results page. #
#*************************************************#
if ($FORM{'search'})
{
# basic search in all of prodname, part code, description
$search_for =3D $FORM{'searchfor'};
if ($FORM{'pagenum'})
{
$pagenum =3D 1 * $FORM{'pagenum'};
}
else
{
$pagenum =3D 1;
}
&update_expire_time;
$search_for =3D~ s/^ +//;
$search_for =3D~ s/ +$//;
if ($search_for eq "")
{
&sc_popup_msg('MISSING: Please enter something to search for!');
}
$search_link =3D $search_for;
$search_link =3D~ s/ /%20/g;
$PAGELINK =3D "<a href=3D\"$SHOPCART_URL?uid=3D$uid&rootdir=3D
$root_dir&search=3D1&searchfor=3D$search_link";
undef(@results);
@keywords =3D split(' ', $search_for);
ITEM: foreach $key (sort(keys %ITEMS_CODE))
{
($groupcode, $itemcode, $littlepic, $bigpic, $prodname, $shortdesc,
$longdesc, $price, $vprice, $sprice, $mprice, $lprice, $xprice,
$mancode, $distributor, $junk) =3D split(/=A4/, $ITEMS_CODE{$key}, 16);
my $data =3D $prodname . " " . $mancode . " " . $distributor;
foreach $word (@keywords)
{
next ITEM if (!($data =3D~ /$word/i));
}
$itemcode =3D~ tr/a-z/A-Z/;
push @results, $itemcode;
}
&results_html_parse;
exit;
}
# ********************************************************* #
# If the command is to search the database, run the search #
# and create a results page. #
#***********************************************************#
if ($FORM{'advanced_search'})
{
if ($FORM{'pagenum'})
{
$pagenum =3D 1 * $FORM{'pagenum'};
}
else
{
$pagenum =3D 1;
}
$cats =3D $FORM{'categories'};
$manu =3D $FORM{'distributor'};
$search_for =3D $FORM{'keywords'};
$search_for =3D~ s/^ +//;
$search_for =3D~ s/ +$//;
$price_from =3D $FORM{'pricefrom'};
$price_from =3D~ s/^ +//;
$price_from =3D~ s/ +$//;
$price_to =3D $FORM{'priceto'};
$price_to =3D~ s/^ +//;
$price_to =3D~ s/ +$//;
$search_link =3D $search_for;
$search_link =3D~ s/ /%20/g;
$PAGELINK =3D "<a href=3D\"$SHOPCART_URL?uid=3D$uid&rootdir=3D
$root_dir&advanced_search=3D1&categories=3D$cats&distributor=3D
$manu&keywords=3D$search_link&pricefrom=3D$price_from&priceto=
=3D
$price_to";
my $price_lower =3D 0.0;
my $price_higher =3D 999999999999.0;
if ($price_from ne "")
{
$price_lower =3D 1.0 * $price_from;
}
if ($price_to ne "")
{
$price_higher =3D 1.0 * $price_to;
}
if ($price_lower >=3D $price_higher)
{
&sc_popup_msg('INCORRECT: Lowest price greater than highest price!');
}
undef(@results);
@keywords =3D split(' ', $search_for);
ITEM: foreach $key (sort(keys %ITEMS_CODE))
{
($groupcode, $itemcode, $littlepic, $bigpic, $prodname, $shortdesc,
$longdesc, $price, $vprice, $sprice, $mprice, $lprice, $xprice,
$mancode, $distributor, $junk) =3D split(/=A4/, $ITEMS_CODE{$key}, 16);
if ($cats ne "All")
{
($junk, $junk, $junk, $title, $junk) =3D split(/=A4/, $GROUPS{$groupcode},
5);
next ITEM unless ($title eq $cats);
}
if ($manu ne "All")
{
next ITEM unless ($distributor eq $manu);
}
next unless ($price >=3D $price_lower);
next unless ($price <=3D $price_higher);
if ($search_for ne "")
{
my $data =3D $prodname . " " . $mancode . " " . $shortdesc . " " .
$longdesc;
foreach $word (@keywords)
{
next ITEM if (!($data =3D~ /$word/i));
}
}
$itemcode =3D~ tr/a-z/A-Z/;
push @results, $itemcode;
}
&results_html_parse;
exit;
}
#
***************************************************************************=
****************
#
# If the command is to GOTO to a page, check for #
# the page, read it in and parse the output page. #
#*************************************************#
if ($FORM{'goto'}) {
$goto =3D $FORM{'goto'};
&update_expire_time;
&goto_html_parse;
exit;
}
#
***************************************************************************=
****************
#
# If the command is to link to another PERL #
# program, setup the parameters and exec it #
#*******************************************#
if ($FORM{'link'}) {
$link =3D $FORM{'link'};
$parm =3D $FORM{'parm'};
&update_expire_time;
$temp =3D $ENV{'SCRIPT_FILENAME'};
$x =3D rindex($temp,"/");
$x =3D $x + 1;
$call =3D substr($temp, 0, $x) . $link;
$ENV{'QUERY_STRING'} =3D $parm;
exec "$call";
exit;
}
#
***************************************************************************=
****************
#
# If the command is QUICKADD, search for item by code, add one to #
# userdata UID and return review sheet. #
# ************************************** #
if ( $FORM{'quickadd'} )
{
# this can be an item code or a distributor code
$search =3D $FORM{'additem'};
$search =3D~ s/ //g;
$search =3D~ tr/a-z/A-Z/;
if ($search eq "")
{
&sc_popup_msg('MISSING: Please enter a valid item or distributor part
code');
}
my $item =3D $ITEMS_CODE{$search};
if (!defined($item))
{
$item =3D $ITEMS_MANCODE{$search};
}
if (!defined($item))
{
&sc_popup_msg('MISSING:' . $search . 'was not found. Please enter a
valid item or distributor part code');
}
($groupcode, $itemcode, $littlepic, $bigpic, $prodname, $shortdesc,
$longdesc, $price, $vprice, $sprice, $mprice, $lprice, $xprice,
$mancode, $distributor, $available, $condition, $PMCcode, $junk) =3D
split(/=A4/, $item, 19);
$prodcode =3D $itemcode . " " . $prodname;
$qty =3D 1;
$idrop =3D "";
$text1 =3D "";
$text2 =3D "";
$text3 =3D "";
$select =3D "";
$new_order_info =3D &add_item_internal;
&review_cart($new_order_info);
exit;
}
#
***************************************************************************=
****************
#
# If the command is ADDTOCART, add it to #
# userdata UID and return review sheet. #
# ************************************** #
if ( $FORM{'addtocart'} )
{
$itemcode =3D $FORM{'additem'};
my $item =3D $ITEMS_CODE{$itemcode};
if (!defined($item))
{
&sc_popup_msg('INTERNAL ERROR: item does not exist in database');
}
($groupcode, $itemcode, $littlepic, $bigpic, $prodname, $shortdesc,
$longdesc, $price, $vprice, $sprice, $mprice, $lprice, $xprice,
$mancode, $distributor, $available, $condition, $PMCcode, $junk) =3D
split(/=A4/, $item, 19);
$prodcode =3D $itemcode . " " . $prodname;
# read price from form due to combined sizeprice field -- JKR
if ($FORM{'price'}) {
$price =3D $FORM{'price'};
}
if ($FORM{'idrop'}) {
$idrop =3D $FORM{'idrop'};
$workspace =3D substr($idrop,0,1);
$whatbox =3D substr($idrop,1);
if ($workspace eq "0") {
&sc_popup_msg("MISSING: " . $whatbox);
}
}
else {
$idrop =3D "";
}
if (!$FORM{'qty'}) {
&sc_popup_msg('MISSING: Unable to add the item to your cart, please
enter a quantity');
}
$qty =3D 0 + $FORM{'qty'};
#if ($qty < 1 || $qty > $available ) {
#&sc_popup_msg('INVALID: Unable to add the item to your cart, please
enter a valid quantity');
#}
if (!$FORM{'text1'}) {
$text1 =3D "";
}
if ($FORM{'text1'}) {
$text1 =3D $FORM{'text1'};
}
if (!$FORM{'text2'}) {
$text2 =3D "";
}
if ($FORM{'text2'}) {
$text2 =3D $FORM{'text2'};
}
$text2 =3D~ tr/\x0A/>/;
$text2 =3D~ tr/\x0D/>/;
if (!$FORM{'text3'}) {
$text3 =3D "";
}
if ($FORM{'text3'}) {
$text3 =3D $FORM{'text3'};
}
$text3 =3D~ tr/\x0A/>/;
$text3 =3D~ tr/\x0D/>/;
# Get Size into $size variable
&split_pricePM("$price");
if (!$FORM{'select'}) {
$select =3D "";
}
if ($FORM{'select'}) {
$select =3D $FORM{'select'};
}
$new_order_info =3D &add_item_internal;
&review_cart($new_order_info);
exit;
}
#
***************************************************************************=
****************
#
# If the command is REVIEW, get the UID #
# read in the data and 'print' it out. #
# ************************************* #
if ($FORM{'review'}) {
$uid =3D $FORM{'uid'};
if (&lock("userdata")) {
&sc_popup_msg($Popup_Message);
}
open(USERDATA, $USERDATA) || &sc_popup_msg("SYSTEM ERROR SC07: Unable
to access $USERDATA for cart storage: $!");
@userdata =3D <USERDATA>;
close(USERDATA);
&unlock("userdata");
foreach $data_line (@userdata) {
if ($data_line =3D~ /^$uid\|\|(.*)/) {
($expire_time, $SUBTOTAL, $order_info) =3D split(/\|\|/, $1);
&review_cart($order_info);
exit;
}
}
exit;
}
#
***************************************************************************=
****************
#
# If the command is EMPTY your cart #
# get the info, delete all. #
# ********************************* #
if ($FORM{'empty'}) {
if (&lock("userdata")) {
&sc_popup_msg($Popup_Message);
}
open(USERDATA, $USERDATA) || &sc_popup_msg("SYSTEM ERROR SC08: Unable
to access $USERDATA for cart storage: $!");
@userdata =3D <USERDATA>;
close(USERDATA);
open(USERDATA, ">$USERDATA") || &sc_popup_msg("SYSTEM ERROR SC09:
Unable to access $USERDATA for cart storage: $!");
foreach $data_line (@userdata) {
if ($data_line =3D~ /^$uid\|\|(.*)/) {
$new_expire_time =3D (time + ($ORDER_DATA_KEEP * 60));
$SUBTOTAL =3D 0;
print USERDATA "$uid||$new_expire_time||$SUBTOTAL||\n";
}
else {
print USERDATA $data_line;
}
}
close(USERDATA);
&unlock("userdata");
# &sc_popup_msg("* Your shopping cart has been emptied *");
&review_cart("");
exit;
}
#
***************************************************************************=
****************
#
# If the command is SENDORDER #
# check all input and do it. #
# *************************** #
if ($FORM{'sendorder'}) {
open(EO, $EMAIL_ORDER) || &sc_popup_msg("SYSTEM ERROR SC10: 'Email
Setup data' from SCdatabase unable to be accessed: $!");
@emailorder =3D <EO>;
close(EO);
open(ET, $EMAIL_THANKS) || &sc_popup_msg("SYSTEM ERROR SC11: 'Email
Setup data' from SCdatabase unable to be accessed: $!");
@emailthanks =3D <ET>;
close(ET);
$uid =3D $FORM{'uid'};
$shipping =3D $FORM{'shipping'};
if ($shipping eq "0") {
&sc_popup_msg("MISSING: Please select a shipping option");
}
$name =3D $FORM{'name'};
if ( ((length $name) <=3D 0) || ( (substr($name,0,1)) eq " ") ) {
&sc_popup_msg("MISSING: Please enter your name");
}
$email =3D $FORM{'email'};
if ( ($email =3D~ /(@.*@)|(\.\.)|(@\.)|(\.@)|(^\.)|(\.$)/) ||
($email !~ /^.+\@\[?(\w|[-.])+\.[a-zA-Z]{2,3}|[0-9]{1,3}\]?$/) ) {
&sc_popup_msg("MISSING: Please enter a valid email addrress");
}
$address =3D $FORM{'address'};
if ( ((length $address) <=3D 0) || ( (substr($address,0,1)) eq " ") ) {
&sc_popup_msg("MISSING: Please enter your address");
}
$address =3D~ tr/\x0A/>/;
$address =3D~ tr/\x0D/>/;
$city =3D $FORM{'city'};
if ( ((length $city) <=3D 0) || ( (substr($city,0,1)) eq " ") ) {
&sc_popup_msg("MISSING: Please enter your city");
}
$state =3D $FORM{'state'};
if ( ((length $state) <=3D 0) || ( (substr($state,0,1)) eq " ") ) {
&sc_popup_msg("MISSING: Please enter your state");
}
$zip =3D $FORM{'zip'};
if ( ((length $zip) <=3D 0) || ( (substr($zip,0,1)) eq " ") ) {
&sc_popup_msg("MISSING: Please enter your zipcode");
}
$phone =3D $FORM{'phone'};
if ( ((length $phone) <=3D 0) || ( (substr($phone,0,1)) eq " ") ) {
&sc_popup_msg("MISSING: Please enter your phone number");
}
$pymtopt =3D $FORM{'pymtopt'};
$pychk =3D $FORM{'pychk'};
if ( $pymtopt eq "" && $pychk ) {
&sc_popup_msg("MISSING: Please choose a payment option");
}
$pa_tax =3D $FORM{'patax'};
if ($pymtopt eq "CreditCard" || $pymtopt eq "" || $pymtopt eq " ") {
$ccnumber =3D $FORM{'ccnumber'};
$ccard =3D $FORM{'cctype'};
$cctype =3D substr($ccard,0,1);
$ccdate =3D $FORM{'ccdate'};
if ( &cc_validate($cctype, $ccnumber, $ccdate)) {
&sc_popup_msg($Popup_Message);
}
}
&send_order;
$goto =3D $root_dir . "/shopcart/thankyou.html";
$uid =3D "ordersent";
$security =3D 1;
&goto_html_parse();
exit;
}
#
***************************************************************************=
****************
#
# No specific valid command. End of the line folks. #
# ************************************************** #
&sc_popup_msg("SYSTEM ERROR SC99: A recognized 'group' parameter must
be passed to invoke the shopping cart.");
###########################################################################=
##################
# SUBROUTINE adds an item to the cart
# ************************************ #
sub add_item_internal
{
local ($i_prod, $i_qty, $i_pmc, $i_price, $i_select, $i_text1,
$i_text2, $i_text3, $i_idrop);
local (@lines, $line);
# FIXME decrement available count???
if (&lock("userdata")) {
&sc_popup_msg($Popup_Message);
}
open(USERDATA, $USERDATA) || &sc_popup_msg("SYSTEM ERROR SC05: Unable
to access $USERDATA for cart storage: $!");
@userdata =3D <USERDATA>;
close(USERDATA);
# find user info
my $expire_time;
my $subtotal =3D 0;
my $order_info;
foreach $data_line (@userdata)
{
if ($data_line =3D~ /^$uid\|\|(.*)/)
{
($expire_time, $subtotal, $order_info) =3D split(/\|\|/, $1);
}
}
# reset expiry time
$expire_time =3D (time + ($ORDER_DATA_KEEP * 60));
my $not_found =3D 1;
@lines =3D split(/\|/, $order_info);
# look for existing product and modify quantity
foreach $line (@lines)
{
($i_prod, $i_qty, $i_pmc, $i_price, $i_select, $i_text1, $i_text2,
$i_text3, $i_idrop) =3D split(/=A4/, $line);
if (($i_prod eq $prodcode) && ($i_price eq $price) && ($i_prod ne
"CM001 Custom Mix Chocolates"))
{
# modify in place
$save_price =3D $i_price;
&split_price("$i_price");
$price =3D~ tr/ //d;
$i_qty +=3D $qty;
$subtotal +=3D (1 * $price * $qty);
$line =3D join('=A4', $i_prod, $i_qty, $i_pmc, $save_price, $i_select,
$i_text1, $i_text2, $i_text3, $i_idrop);
$not_found =3D 0;
# sanity check (GLOBAL!)
# if ($i_qty > $available)
# {
# &sc_popup_msg("ERROR: you have already purchased all available
items.");
# }
last;
}
}
if ($not_found)
{
# new order line
$save_price =3D $price;
&split_price("$price");
$price =3D~ tr/ //d;
$subtotal +=3D (1 * $price * $qty);
$line =3D join('=A4', $prodcode, $qty, $PMCcode, $save_price, $select,
$text1, $text2, $text3, $idrop, $cmtext);
push @lines, $line;
}
# rebuild order_info
$order_info =3D join('|', @lines);
$SUBTOTAL =3D sprintf "%5.2f", $subtotal; # GLOBAL!
open(USERDATA, ">$USERDATA") || &sc_popup_msg("SYSTEM ERROR SC06:
Unable to access $USERDATA for cart storage: $!");
foreach $data_line (@userdata)
{
if ($data_line =3D~ /^$uid\|\|(.*)/)
{
print USERDATA $uid . "||" . $expire_time . "||" . $SUBTOTAL . "||" .
$order_info . "\n";
}
else
{
print USERDATA $data_line;
}
}
close(USERDATA);
&unlock("userdata");
return $order_info;
}
###########################################################################=
##################
# SUBROUTINE creates a unique shopper #
# UID and adds it to the userdata file #
# ************************************ #
sub new_user {
local $rpid =3D reverse $$;
$uid =3D $ENV{'REMOTE_ADDR'};
$uid =3D pack("C4", split(/\./, $uid));
$uid =3D substr(pack("u", $uid), 1);
chop($uid);
$uid =3D~ tr| -_`|A-Za-z0-9*_A|;
$uid =3D substr($rpid,0,2) . $uid . substr(time,4);
$uid =3D~ tr|a-z|A-Z|;
$uid =3D~ tr|*|8|;
$expire_time =3D time + (60 * $ORDER_DATA_KEEP);
$SUBTOTAL =3D 0;
if (&lock("userdata")) {
&sc_popup_msg($Popup_Message);
}
open(USERDATA, ">>$USERDATA") || &sc_popup_msg("SYSTEM ERROR SC13:
Unable to access $USERDATA for cart storage: $!");
print USERDATA "$uid||$expire_time||$SUBTOTAL||\n";
close(USERDATA);
&unlock("userdata");
}
# ******************************************************** #
# SUBROUTINE updates a user's expire time in userdata file #
# ******************************************************** #
sub update_expire_time {
if (&lock("userdata")) {
&sc_popup_msg($Popup_Message);
}
open(USERDATA, $USERDATA) || &sc_popup_msg("SYSTEM ERROR SC14: Unable
to access $USERDATA for cart storage: $!");
@userdata =3D <USERDATA>;
close(USERDATA);
open(USERDATA, ">$USERDATA") || &sc_popup_msg("SYSTEM ERROR SC15:
Unable to access $USERDATA for cart storage: $!");
foreach $data_line (@userdata) {
if ($data_line =3D~ /^$uid\|\|\d+\|\|(.*)/) {
$order_info =3D $1;
$new_expire_time =3D (time + ($ORDER_DATA_KEEP * 60));
print USERDATA "$uid||$new_expire_time||$order_info\n";
}
else {
print USERDATA $data_line;
}
}
close(USERDATA);
&unlock("userdata");
}
#
***************************************************************************=
****************
#
# SUBROUTINE reads in ITEM data and item.html page, #
# checks for shopcart markers and href commands, then #
# replaces / changes as needed and outputs the page. #
# *************************************************** #
sub item_html_parse {
local(@idd);
$group_chk =3D 0; $item_chk =3D 1; $checkout_chk =3D 0;
if (&lock("proddata")) {
&scd_popup_msg("$Error_Message", 1);
}
open(PRODUCTS, $PRODDATA) || &sc_popup_msg("SYSTEM ERROR SC16: MAIN
database unable to be accessed: $!");
$not_found =3D 1;
while ($record =3D <PRODUCTS>)
{
($groupcode, $itemcode, $remainder) =3D split(/=A4/, $record, 3);
if ($itemcode eq "AA000")
{
($groupdescr, $grouptitle, $groupimage, $junk) =3D split(/=A4/,
$remainder, 4);
$groupname =3D $groupcode;
}
else
{
($littlepic, $bigpic, $prodname, $shortdesc, $longdesc, $price,
$vprice, $sprice, $mprice, $lprice, $xprice, $mancode, $distributor,
$available, $condition, $PMCcode, $packaging, $shipdate, $weight,
$selectA, $selectB, $selectC, $selectD, $selectE, $text1, $text2,
$text3, $idrop) =3D split(/=A4/, $remainder);
$idrop =3D~ tr/\x0A//d;
$idrop =3D~ tr/\x0D//d;
if ($itemcode eq $item)
{
close(PRODUCTS);
&unlock("proddata");
$not_found =3D 0;
last;
}
}
}
if ($not_found) {
close(PRODUCTS);
&unlock("proddata");
&sc_popup_msg("SYSTEM ERROR SC17: item $item not found in the
database.");
return(0);
}
local ($goto) =3D "item.html";
local $filename =3D $BASE_DIR.$goto;
open(HTMLPAGE, $filename) || &sc_popup_msg("ERROR SC18: item.html
unable to be accessed in shopcart folder: $!");
print "Content-type: text/html\n\n";
$have_no_body =3D 1;
$closed_form =3D 0;
while ($html_line =3D <HTMLPAGE>) {
$line_copy =3D "";
if (($html_line =3D~ /<\/body/) || ($html_line =3D~ /<\!\-\- *endform *\-\-
>/)) {
if (!$closed_form) {
print "</form>\n";
}
$closed_form =3D 1;
}
if ( $html_line =3D~ /<\+idropdown\+>/ && ( $idrop eq "" || $idrop eq "
") ) {
$html_line =3D "\n";
}
if ( $html_line =3D~ /<\+idropdown\+>/ && $idrop ne "" && $idrop ne " ")
{
$line_copy .=3D $`;
@ibb =3D split(/,/, $idrop);
$line_copy .=3D "<select name=3D\"idrop\" size=3D\"1\">\n";
$x =3D 0;
foreach $data_line (@ibb) {
if ($x eq 0) {
$line_copy .=3D "<option value=3D\"0$ibb[$x]\">$data_line\n";
}
else {
$line_copy .=3D "<option value=3D\"$ibb[$x]\">$data_line\n";
}
$x =3D $x + 1;
}
$line_copy .=3D "</select>\n";
$html_line =3D $';
}
while ( $html_line =3D~ /(<\+(.+?)\+>)/ ) {
$symbol_all =3D $1;
$symbol_replace =3D &token_replace($symbol_all);
if ($symbol_replace eq "*DEL*") {
$symbol_replace =3D "\n";
}
$line_copy .=3D $` . $symbol_replace;
$html_line =3D $';
}
$line_copy .=3D $html_line;
$html_line =3D $line_copy;
&check_href;
print $html_line;
if ($html_line =3D~ /<head/) {
print "<script language=3D\"JavaScript\">var cart_uid=3D\"" . $uid . "\"</
script>\n";
}
if ($have_no_body) {
if ($html_line =3D~ /<\!\-\- *startform *\-\->/ ) {
print "<form method=3DGET action=3D\"$SHOPCART_URL\">\n";
print "<input type=3Dhidden name=3D\"uid\" value=3D\"$uid\">\n";
print "<input type=3Dhidden name=3D\"rootdir\" value=3D\"$root_dir\">\n";
print "<input type=3Dhidden name=3D\"additem\" value=3D\"$itemcode\">\n";
$have_no_body =3D 0;
}
}
}
print $version;
print "\n\n";
close(HTMLPAGE);
}
# ***************************************************************** #
# SUBROUTINE reads in products data and initialises global data,
# %GROUPS - hash of groups by groupcode
# @DISTRIBUTORS - array of distributors
# %ITEMS_CODE - hash of items by item code
# %ITEMS_MANCODE - hash of items by distributor code
# $HORIZ_CATS - HTML formatted horizontal list of all groups
# $VERT_CATS - HTML formatted vertical list of all groups
# $MANU_LIST - HTML formatted vertical list of all groups
# ***************************************************************** #
sub read_products_database {
local($littlepic, $bigpic, $prodname, $shortdesc, $longdesc, $price,
$vprice, $sprice, $mprice, $lprice, $xprice, $mancode, $distributor,
$available, $condition, $PMCcode, $packaging, $shipdate, $weight,
$selectA, $selectB, $selectC, $selectD, $selectE, $text1, $text2,
$text3, $idrop);
local ($groupcode, $itemcode, $remainder, $junk, $key, $manu, $link);
local (@groups, %distributors, %categories);
undef(@DISTRIBUTORS);
undef($HORIZ_CATS);
undef($VERT_CATS);
undef($MANU_LIST);
if (&lock("proddata")) {
&scd_popup_msg("$Error_Message", 1);
}
open(PRODUCTS, $PRODDATA) || &sc_popup_msg("SYSTEM ERROR SC20: Main
database unable to be accessed");
# build groups & hashes of things
while ($product =3D <PRODUCTS>) {
($groupcode, $itemcode, $remainder) =3D split(/=A4/, $product, 3);
$itemcode =3D~ tr/a-z/A-Z/;
$itemcode =3D~ s/^ +//g;
$itemcode =3D~ s/ +$//g;
if ($itemcode eq "AA000")
{
($descr, $title, $image, $droplist, $cols, $rows, $junk) =3D split(/=A4/,
$remainder, 6);
push @groups, $title;
$categories{$title} =3D $groupcode;
$images{$title} =3D $image;
$GROUPS{$groupcode} =3D $product;
} else {
($littlepic, $bigpic, $prodname, $shortdesc, $longdesc, $price,
$vprice, $sprice, $mprice, $lprice, $xprice, $mancode, $distributor,
$junk) =3D split(/=A4/, $remainder, 14);
$distributor =3D~ s/^ +//g;
$distributor =3D~ s/ +$//g;
if ($distributor ne "") {
$distributors{$distributor} =3D 1;
}
$mancode =3D~ tr/a-z/A-Z/;
$mancode =3D~ s/^ +//g;
$mancode =3D~ s/ +$//g;
$ITEMS_CODE{$itemcode} =3D $product;
$ITEMS_MANCODE{$mancode} =3D $product;
}
}
@DISTRIBUTORS =3D sort(keys %distributors);
close(PRODUCTS);
&unlock("proddata");
# build lists of things
# $MANU_LIST, $HORIZ_CATS, $VERT_CATS
$MANU_LIST =3D " ";
$HORIZ_CATS =3D "";
$VERT_CATS =3D " ";
$i =3D 0;
foreach $key (@groups)
{
$itemcode =3D $categories{$key};
if (!($itemcode eq "Custom Mix"))
{
$link =3D "<a href=3D'".$SHOPCART_URL."?uid=3D".$uid."&rootdir=3D".
$root_dir."&group=3D".$itemcode."'>";
$link =3D $link . $key . "</a>";
if ($i !=3D 0) {
$HORIZ_CATS =3D $HORIZ_CATS . " | ";
$VERT_CATS =3D $VERT_CATS . "<br> ";
}
$HORIZ_CATS =3D $HORIZ_CATS . $link;
$VERT_CATS =3D $VERT_CATS . $link;
$i++;
}
}
$i =3D 0;
foreach $manu (@DISTRIBUTORS)
{
$link =3D "<a href=3D'".$SHOPCART_URL."?uid=3D".$uid."&rootdir=3D".
$root_dir."&search=3D1&searchfor=3D".$manu."'>";
$link =3D $link . $manu . "</a>";
if ($i !=3D 0) {
$MANU_LIST =3D $MANU_LIST . "<br> ";
}
$MANU_LIST =3D $MANU_LIST . $link;
$i++;
}
}
#
***************************************************************************=
****************
#
# SUBROUTINE reads in specified page, #
# checks for shopcart markers and enter commands then #
# replaces / changes as needed and outputs the page. #
# *************************************************** #
sub generic_html_parse {
local ($goto) =3D shift;
local $filename =3D $BASE_DIR.$goto;
print "Content-type: text/html\n\n";
$group_chk =3D 0; $item_chk =3D 0; $checkout_chk =3D 0;
open(HTMLPAGE, $filename) || &sc_popup_msg("ERROR SC19: $goto unable
to be accessed in shopcart folder: $!");
$have_no_body =3D 1;
$closed_form =3D 0;
while ($html_line =3D <HTMLPAGE>)
{
$line_copy =3D "";
if (($html_line =3D~ /<\/body/) || ($html_line =3D~ /<\!\-\- *endform *\-\-
>/)) {
if (!$closed_form) {
print "</form>\n";
}
$closed_form =3D 1;
}
while ($html_line =3D~ /(<\+(.+?)\+>)/)
{
$symbol_all =3D $1;
$symbol_replace =3D &token_replace($symbol_all);
$line_copy .=3D $` . $symbol_replace;
$html_line =3D $';
}
$line_copy .=3D $html_line;
$html_line =3D $line_copy;
&check_href;
print $html_line;
if ($html_line =3D~ /<head/) {
print "<script language=3D\"JavaScript\">var cart_uid=3D\"" . $uid . "\"</
script>\n";
}
if ($have_no_body)
{
if ($html_line =3D~ /<\!\-\- *startform *\-\->/ )
{
print "<form method=3DGET action=3D\"$SHOPCART_URL\">\n";
print "<input type=3Dhidden name=3D\"uid\" value=3D\"$uid\">\n";
print "<input type=3Dhidden name=3D\"rootdir\" value=3D\"$root_dir\">\n";
$have_no_body =3D 0;
}
}
}
}
# *************************************************** #
# SUBROUTINE reads in HOME data and home.html page, #
# checks for shopcart markers and enter commands then #
# replaces / changes as needed and outputs the page. #
# *************************************************** #
sub home_html_parse {
local ($goto) =3D "home.html";
local ($product, @groups);
local ($html_save, $check_end, $thisgroup, $dbgroup, $pn, $dl, $i, $x,
$j, $k, $l, $m);
local (%distributors, %categories, %images, $manu);
local $filename =3D $BASE_DIR.$goto;
print "Content-type: text/html\n\n";
$group_chk =3D 0; $item_chk =3D 0; $checkout_chk =3D 0;
open(HTMLPAGE, $filename) || &sc_popup_msg("ERROR SC19: home.html
unable to be accessed in shopcart folder: $!");
$have_no_body =3D 1; $home_found =3D 0; $do_home =3D 0; $closed_form =3D 0;
while ($html_line =3D <HTMLPAGE>)
{
$line_copy =3D "";
if (($html_line =3D~ /<\/body/) || ($html_line =3D~ /<\!\-\- *endform *\-\-
>/)) {
if (!$closed_form) {
print "</form>\n";
}
$closed_form =3D 1;
}
while ($html_line =3D~ /(<\+(.+?)\+>)/)
{
$symbol_all =3D $1;
$symbol_replace =3D &token_replace($symbol_all);
$line_copy .=3D $` . $symbol_replace;
$html_line =3D $';
}
$line_copy .=3D $html_line;
$html_line =3D $line_copy;
&check_href;
print $html_line;
if ($html_line =3D~ /<head/) {
print "<script language=3D\"JavaScript\">var cart_uid=3D\"" . $uid . "\"</
script>\n";
}
if ($have_no_body)
{
if ($html_line =3D~ /<\!\-\- *startform *\-\->/ )
{
print "<form method=3DGET action=3D\"$SHOPCART_URL\">\n";
print "<input type=3Dhidden name=3D\"uid\" value=3D\"$uid\">\n";
print "<input type=3Dhidden name=3D\"rootdir\" value=3D\"$root_dir\">\n";
$have_no_body =3D 0;
}
}
}
}
# *************************************************** #
# SUBROUTINE reads in GROUP data and group.html page, #
# checks for shopcart markers and group commands then #
# replaces / changes as needed and outputs the page. #
# *************************************************** #
sub group_html_parse {
local ($goto) =3D "group.html";
local (@group_items, @item_html, @gdd_array, @gdd_name, @gdd_items);
local ($html_save, $check_end, $thisgroup, $dbgroup, $pn, $dl, $i, $x,
$j, $k, $l, $m);
local $filename =3D $BASE_DIR.$goto;
$group_chk =3D 1; $item_chk =3D 0; $checkout_chk =3D 0;
open(HTMLPAGE, $filename) || &sc_popup_msg("ERROR SC19: group.html
unable to be accessed in shopcart folder: $!");
if (&lock("proddata")) {
&scd_popup_msg("$Error_Message", 1);
}
open(PRODUCTS, $PRODDATA) || &sc_popup_msg("SYSTEM ERROR SC20: Main
database unable to be accessed: $!");
$not_found =3D 1;
$numitems =3D 0;
$dropitems =3D 0;
$thisgroup =3D $group;
$thisgroup =3D~ tr/a-z/A-Z/;
while ($product =3D <PRODUCTS>)
{
($groupcode, $itemcode, $remainder) =3D split(/=A4/, $product, 3);
$dbgroup =3D $groupcode;
$dbgroup =3D~ tr/a-z/A-Z/;
next unless ($dbgroup eq $thisgroup);
$groupname =3D $groupcode;
if ($itemcode eq "AA000")
{
# process group
($groupdescr, $grouptitle, $groupimage, $droplist, $cols, $rows,
$junk) =3D split(/=A4/, $remainder, 6);
$not_found =3D 0;
@gdd_array =3D split(/,/, $droplist);
$cols =3D~ tr/\x0A//d;
$cols =3D~ tr/\x0D//d;
$cols =3D~ tr/ //d;
$rows =3D~ tr/\x0A//d;
$rows =3D~ tr/\x0D//d;
$rows =3D~ tr/ //d;
if ($cols eq "") {
$cols =3D "3";
}
if ($rows eq "") {
$rows =3D -1;
}
}
else
{
# process items
($littlepic, $bigpic, $prodname, $junk) =3D split(/=A4/, $remainder, 4);
if (!($prodname =3D~ "=B6"))
{
push @group_items, $product;
$numitems++;
$pn =3D $prodname;
$pn =3D~ tr/a-z/A-Z/;
foreach $data_line (@gdd_array) {
$dl =3D $data_line;
$dl =3D~ tr/a-z/A-Z/;
if ( $dl eq $pn ) {
$gdd_name[$dropitems] =3D $prodname;
$gdd_items[$dropitems] =3D $itemcode;
$dropitems++;
}
}
}
}
}
close(PRODUCTS);
&unlock("proddata");
if ($not_found) {
&sc_popup_msg("CODING ERROR: group $group not found in the product
data file.");
}
$PAGELINK =3D "<a href=3D\"$SHOPCART_URL?uid=3D$uid&rootdir=3D
$root_dir&group=3D$group";
$items_per_page =3D $numitems;
$num_of_pages =3D 1;
$workspace =3D $numitems;
$min_items =3D 0;
$max_items =3D $numitems;
if ($rows > 0)
{
$items_per_page =3D $cols * $rows;
$num_of_pages =3D 0;
$workspace =3D $numitems;
while ($workspace > 0) {
$num_of_pages =3D $num_of_pages + 1;
$workspace -=3D $items_per_page;
}
if ( (¬_a_number($pagenum)) ) {
$pagenum =3D 1;
}
$min_items =3D ($pagenum - 1) * $items_per_page;
$max_items =3D $min_items + $items_per_page;
if ($max_items > $numitems) {
$max_items =3D $numitems;
}
}
print "Content-type: text/html\n\n";
$have_no_body =3D 1; $group_found =3D 0; $do_group =3D 0; $closed_form =3D =
0;
$do_drop =3D 0; $del_drop =3D 0;
$j =3D 0; $x =3D 0;
while ($html_line =3D <HTMLPAGE>)
{
if ($group_found)
{
# save the HTML lines
if ($html_line =3D~ /\+endgroup\+/)
{
# emit group HTML
$group_found =3D 0;
# process the saved HTML lines, once per item in this group
# with token replacement.
# if ($empty_group)
# {
# $itemdescr =3D "No products are available in this group.";
# }
my $cur_row =3D 0;
my $cur_col =3D 0;
# emit table header
print "<table border =3D \"0\" width=3D\"100%\">\n<tr>";
# list items, starting at index $min_items, up to $max_items
for (my $index =3D $min_items; $index < $max_items; $index++)
{
# get item data
($groupcode, $itemcode, $littlepic, $bigpic, $prodname, $shortdesc,
$longdesc, $price, $vprice, $sprice, $mprice, $lprice, $xprice,
$mancode, $distributor, $available, $condition, $PMCcode, $packaging,
$shipdate, $weight, $selectA, $selectB, $selectC, $selectD, $selectE,
$text1, $text2, $text3, $idrop) =3D split(/=A4/, $group_items[$index]);
print " <!-- Item $index ($itemcode $prodname) -->\n";
# build item description link
$itemdescr =3D "<a href=3D'".$SHOPCART_URL."?uid=3D".$uid."&rootdir=3D".
$root_dir."&item=3D".$itemcode."&columns=3D".$cols."'> " .
$prodname . "</a>\n";
$itemprice =3D $price;
# emit cell in the table
print "<td>\n";
# print HTML for each item
foreach $item_line (@item_html)
{
# replace all tokens
$html_line =3D $item_line;
$line_copy =3D "";
while ($html_line =3D~ /(<\+(.+?)\+>)/)
{
$symbol_all =3D $1;
$symbol_replace =3D &token_replace($symbol_all);
if ($symbol_replace eq "*DEL*") {
$symbol_replace =3D "N/A";
}
$line_copy .=3D $` . $symbol_replace;
$html_line =3D $';
}
$line_copy .=3D $html_line;
$html_line =3D $line_copy;
&check_href;
print $html_line;
}
print "</td>\n";
$cur_col++;
if ($cur_col =3D=3D $cols)
{
$cur_col =3D 0;
$cur_row++;
print "</tr>\n<tr>\n";
}
}
# emit table footer
print "</tr>\n</table>\n";
}
else
{
push @item_html, $html_line;
}
}
elsif ($html_line =3D~ /\+group\+/)
{
# save everything until we see an endgroup
$group_found =3D 1;
}
elsif ( $html_line =3D~ /\+dropdown\+/ )
{
if ($gddlist ne "") {
$do_drop =3D 1;
}
else {
$del_drop =3D 1;
}
}
elsif ( $html_line =3D~ /\+enddropdown\+/ )
{
$del_drop =3D 0; $do_drop =3D 0;
}
elsif ( $do_drop && ($html_line =3D~ /\+list\+/) )
{
print "<select name=3D\"item\" size=3D\"1\">\n";
$x =3D 0;
foreach $data_line (@gdd_name)
{
print "<option value=3D\"$gdd_items[$x]\">$data_line\n";
$x =3D $x + 1;
}
print "</select><br>\n";
print "<input type=3Dhidden name=3D\"columns\" value=3D\"$cols\">\n";
print "<input type=3Dsubmit value=3D\"View Selection\">\n";
}
elsif ( $do_drop )
{
print $html_line;
}
elsif ( $del_drop )
{
$do_nothing =3D "yes";
}
else
{
# replace tokens in HTML, add FORM tags to body
$line_copy =3D "";
if (($html_line =3D~ /<\/body/) || ($html_line =3D~ /<\!\-\- *endform *\-\-
>/)) {
if (!$closed_form) {
print "</form>\n";
}
$closed_form =3D 1;
}
while ( $html_line =3D~ /(<\+(.+?)\+>)/ )
{
$symbol_all =3D $1;
$symbol_replace =3D &token_replace($symbol_all);
$line_copy .=3D $` . $symbol_replace;
$html_line =3D $';
}
$line_copy .=3D $html_line;
$html_line =3D $line_copy;
&check_href;
print $html_line;
if ($html_line =3D~ /<head/) {
print "<script language=3D\"JavaScript\">var cart_uid=3D\"" . $uid . "\"</
script>\n";
}
if ($have_no_body)
{
if ($html_line =3D~ /<\!\-\- *startform *\-\->/ )
{
print "<form method=3DGET action=3D\"$SHOPCART_URL\">\n";
print "<input type=3Dhidden name=3D\"uid\" value=3D\"$uid\">\n";
print "<input type=3Dhidden name=3D\"rootdir\" value=3D\"$root_dir\">\n";
$have_no_body =3D 0;
}
}
}
}
print $version;
print "\n\n";
close(HTMLPAGE);
}
#
***************************************************************************=
****************
#
# SUBROUTINE reads in advsearch.html page, #
# checks for shopcart markers and enter commands then #
# replaces / changes as needed and outputs the page. #
# *************************************************** #
sub advsearch_html_parse
{
local ($goto) =3D "advsearch.html";
local $filename =3D $BASE_DIR.$goto;
local ($have_no_body);
open(HTMLPAGE, $filename) || &sc_popup_msg("ERROR SC19: $goto unable
to be accessed in shopcart folder: $!");
print "Content-type: text/html\n\n";
$have_no_body =3D 1; $closed_form =3D 0;
while ($html_line =3D <HTMLPAGE>)
{
$line_copy =3D "";
if (($html_line =3D~ /<\/body/) || ($html_line =3D~ /<\!\-\- *endform *\-\-
>/)) {
if (!$closed_form) {
print "</form>\n";
}
$closed_form =3D 1;
}
while ($html_line =3D~ /(<\+(.+?)\+>)/)
{
$symbol_all =3D $1;
$symbol_replace =3D &token_replace($symbol_all);
$line_copy .=3D $` . $symbol_replace;
$html_line =3D $';
}
$line_copy .=3D $html_line;
$html_line =3D $line_copy;
&check_href;
print $html_line;
if ($html_line =3D~ /<head/) {
print "<script language=3D\"JavaScript\">var cart_uid=3D\"" . $uid . "\"</
script>\n";
}
if ($have_no_body)
{
if ($html_line =3D~ /<\!\-\- *startform *\-\->/ )
{
print "<form method=3DGET action=3D\"$SHOPCART_URL\">\n";
print "<input type=3Dhidden name=3D\"uid\" value=3D\"$uid\">\n";
print "<input type=3Dhidden name=3D\"rootdir\" value=3D\"$root_dir\">\n";
$have_no_body =3D 0;
}
}
}
}
#
***************************************************************************=
****************
#
# SUBROUTINE reads in reults data and results.html page, #
# checks for shopcart markers and commands then #
# replaces / changes as needed and outputs the page. #
# *************************************************** #
sub results_html_parse {
local ($goto) =3D "results.html";
local (@item_html, $html_save);
local $filename =3D $BASE_DIR.$goto;
open(HTMLPAGE, $filename) || &sc_popup_msg("ERROR SC19: $goto unable
to be accessed in shopcart folder: $!");
# FIXME
$rows =3D 12;
$numitems =3D $#results + 1;
$items_per_page =3D $rows;
$num_of_pages =3D 0;
$workspace =3D $numitems;
while ($workspace > 0) {
$num_of_pages =3D $num_of_pages + 1;
$workspace -=3D $items_per_page;
}
if ( (¬_a_number($pagenum)) ) {
$pagenum =3D 1;
}
$min_items =3D ($pagenum - 1) * $items_per_page;
$max_items =3D $min_items + $items_per_page;
if ($max_items > $numitems)
{
$max_items =3D $numitems;
}
print "Content-type: text/html\n\n";
# DEBUG
for (my $index =3D 0; $index < $numitems; $index++)
{
print "<!-- " . $results[$index] . " -->\n";
}
$have_no_body =3D 1; $results_found =3D 0; $do_results =3D 0;
$closed_form =3D 0;
while ($html_line =3D <HTMLPAGE>)
{
if ($results_found)
{
# save the HTML lines
if ($html_line =3D~ /\+endresults\+/)
{
# emit results HTML
$results_found =3D 0;
# process the saved HTML lines, once per item in this group
# with token replacement.
# if ($empty_group)
# {
# $itemdescr =3D "No products are available in this group.";
# }
# list items, starting at index $item_start, up to $items_per_page
for (my $index =3D $min_items; $index < $max_items; $index++)
{
# get item data
($groupcode, $itemcode, $littlepic, $bigpic, $prodname, $shortdesc,
$longdesc, $price, $vprice, $sprice, $mprice, $lprice, $xprice,
$mancode, $distributor, $available, $condition, $PMCcode, $packaging,
$shipdate, $weight, $selectA, $selectB, $selectC, $selectD, $selectE,
$text1, $text2, $text3, $idrop) =3D split(/=A4/,
$ITEMS_CODE{$results[$index]});
if (!($prodname =3D~ "=B6"))
{
print " <!-- Item $index ($itemcode $prodname) -->\n";
$itemprice =3D $price;
# print HTML for each item
foreach $item_line (@item_html)
{
# replace all tokens
$html_line =3D $item_line;
$line_copy =3D "";
while ($html_line =3D~ /(<\+(.+?)\+>)/)
{
$symbol_all =3D $1;
$symbol_replace =3D &token_replace($symbol_all);
$line_copy .=3D $` . $symbol_replace;
$html_line =3D $';
}
$line_copy .=3D $html_line;
$html_line =3D $line_copy;
&check_href;
print $html_line;
}
}
}
}
else
{
push @item_html, $html_line;
}
}
elsif ($html_line =3D~ /\+results\+/)
{
# save everything until we see an endresults
$results_found =3D 1;
}
else
{
# replace tokens in HTML, add FORM tags to body
$line_copy =3D "";
if (($html_line =3D~ /<\/body/) || ($html_line =3D~ /<\!\-\- *endform *\-\-
>/)) {
if (!$closed_form) {
print "</form>\n";
}
$closed_form =3D 1;
}
while ( $html_line =3D~ /(<\+(.+?)\+>)/ )
{
$symbol_all =3D $1;
$symbol_replace =3D &token_replace($symbol_all);
$line_copy .=3D $` . $symbol_replace;
$html_line =3D $';
}
$line_copy .=3D $html_line;
$html_line =3D $line_copy;
&check_href;
print $html_line;
if ($html_line =3D~ /<head/) {
print "<script language=3D\"JavaScript\">var cart_uid=3D\"" . $uid . "\"</
script>\n";
}
if ($have_no_body)
{
if ($html_line =3D~ /<\!\-\- *startform *\-\->/ )
{
print "<form method=3DGET action=3D\"$SHOPCART_URL\">\n";
print "<input type=3Dhidden name=3D\"uid\" value=3D\"$uid\">\n";
print "<input type=3Dhidden name=3D\"rootdir\" value=3D\"$root_dir\">\n";
$have_no_body =3D 0;
}
}
}
}
print $version;
print "\n\n";
close(HTMLPAGE);
}
#
***************************************************************************=
****************
#
# SUBROUTINE reads in uid data and CHECKOUT.html page, #
# replaces / changes as needed and outputs the page. #
# **************************************************** #
sub checkout_html_parse {
$group_chk =3D 0; $item_chk =3D 0; $checkout_chk =3D 1;
local ($new_line, $new_order_info, @s_table);
local ($sh_list, @sh_cost);
$uid =3D $FORM{'uid'};
$gbgroup =3D $FORM{'gbgroup'};
if ($FORM{'edit'}) {
$qtyerror =3D 0;
$edititem =3D $FORM{'edititem'};
if (&lock("userdata")) {
&sc_popup_msg($Popup_Message);
}
open(USERDATA, $USERDATA) || &sc_popup_msg("SYSTEM ERROR SC21: Unable
to access $USERDATA for cart storage: $!");
@userdata =3D <USERDATA>;
close(USERDATA);
$new_order_info =3D "";
open(USERDATA, ">$USERDATA") || &sc_popup_msg("SYSTEM ERROR SC22:
Unable to access $USERDATA for cart storage: $!");
foreach $data_line (@userdata) {
if ($data_line =3D~ /^$uid\|\|(.*)/) {
($expire_time, $SUBTOTAL, $order_info) =3D split(/\|\|/, $1);
@each_item =3D split(/\|/, $order_info);
foreach $bought (@each_item) {
($c_prod, $c_qty, $c_pmc, $c_price, $c_select, $c_text1, $c_text2,
$c_text3, $c_idrop) =3D split(/=A4/, $bought);
$c_idrop =3D~ tr/\x0A//d;
$c_idrop =3D~ tr/\x0D//d;
if ($bought eq $edititem) {
($key, $junk) =3D split(' ', $bought, 2);
($i_groupcode, $i_itemcode, $i_littlepic, $i_bigpic, $i_prodname,
$i_shortdesc, $i_longdesc, $i_price, $i_vprice, $i_sprice, $i_mprice,
$i_lprice, $i_xprice, $i_mancode, $i_manufacturer, $i_available,
$i_condition, $i_PMCcode, $i_junk) =3D split(/=A4/, $ITEMS_CODE{$key},
19);
$maxqty =3D $i_available;
&split_price("$c_price");
$price =3D~ tr/ //d;
$SUBTOTAL -=3D ( 1 * $c_qty * $price );
$SUBTOTAL =3D sprintf "%5.2f", $SUBTOTAL;
$SUBTOTAL =3D~ tr/ //d;
if ( ($FORM{'edit'}) eq "Cha") {
$newqty =3D $FORM{'newqty'};
# if ( ($newqty eq "") || (¬_a_number($newqty)) || ($newqty >
$maxqty) ) {
if ( ($newqty eq "") || (¬_a_number($newqty)) ) {
$qtyerror =3D 1;
$newqty =3D $c_qty;
}
$SUBTOTAL +=3D ( 1 * $newqty * $price );
$bought =3D join('=A4', $c_prod, $newqty, $c_pmc, $c_price, $c_select,
$c_idrop);
$new_order_info .=3D $bought . '|';
}
}
else {
$new_order_info .=3D $bought . '|';
}
}
print USERDATA $uid . '||' . $expire_time . '||' . $SUBTOTAL . '||' .
$new_order_info . "\n";
}
else {
print USERDATA $data_line;
}
}
close(USERDATA);
&unlock("userdata");
# if ($qtyerror) {
# &sc_popup_msg("You have entered an invalid number in the quantity
field. Try again.");
#}
}
if (&lock("userdata")) {
&sc_popup_msg($Popup_Message);
}
open(USERDATA, $USERDATA) || &sc_popup_msg("SYSTEM ERROR SC23: Unable
to access $USERDATA for cart storage: $!");
@userdata =3D <USERDATA>;
close(USERDATA);
&unlock("userdata");
foreach $data_line (@userdata) {
if ($data_line =3D~ /^$uid\|\|(.*)/) {
($expire_time, $SUBTOTAL, $order_info) =3D split(/\|\|/, $1);
}
}
@each_item =3D split(/\|/, $order_info);
open(SHIPTABLE, $SHIPDATA) || &sc_popup_msg("SYSTEM ERROR SC24:
'Shipping' SCdatabase incomplete or unable to be accessed: $!");
$x =3D 0;
$y =3D 0;
while ($s_input =3D <SHIPTABLE>) {
($s_type, $lownum, $highnum, $s_amt) =3D split(/=A4/, $s_input);
$lownum =3D~ tr/\$//d; $highnum =3D~ tr/\$//d; $s_amt =3D~ tr/\$//d;
if ( $s_amt =3D~ /\%/ ) {
$s_amt =3D ( $` * .01 ) * $SUBTOTAL;
$s_amt =3D sprintf "%5.2f", $s_amt;
$s_amt =3D~ tr/ //d;
}
if ( ( ($SUBTOTAL - $lownum) >=3D 0) && ( ($SUBTOTAL - $highnum) <=3D 0) )
{
$tot_order =3D $SUBTOTAL + $s_amt;
$tot_order =3D sprintf "%5.2f", $tot_order;
$tot_order =3D~ tr/ //d;
sprintf "%5.2f", $c_price;
$s_type .=3D ' :';
$len =3D length($s_type);
$z =3D 20 - $len;
while ($z > 0) {
$s_type =3D $s_type . ' ';
$z =3D $z - 1;
}
$s_table[$x] =3D "Shipping by $s_type \$ $s_amt";
$s_amt =3D~ tr/\x0D//d;
$s_amt =3D~ tr/\x0A//d;
$s_amt =3D~ tr/ //d;
$sh_cost[$y] =3D $s_amt;
$x =3D $x + 1;
$y =3D $y + 1;
}
}
local ($goto) =3D "checkout.html";
local $filename =3D $BASE_DIR.$goto;
open(HTMLPAGE, $filename) || &sc_popup_msg("SYSTEM ERROR SC25:
checkout.html unable to be accessed in the shopcart folder: $!");
&TEMP_stuff();
while ($html_line =3D <HTMLPAGE>) {
$line_copy =3D "";
if ($html_line =3D~ /<\/body/ ) {
print TEMPFILE "<script language=3D\"JavaScript\">\n";
print TEMPFILE "function compute(coform) {\n";
print TEMPFILE "subtotal =3D 'Subtotal - \$$SUBTOTAL'\n";
if ( $pa_tax ) {
print TEMPFILE "taxamt =3D .005 + ( ( 1 * $SUBTOTAL ) * .06 )\n";
print TEMPFILE "string =3D '' + taxamt\n";
print TEMPFILE "separation =3D string.length - string.indexOf('.')\n";
print TEMPFILE "if (separation =3D=3D 2) taxamt =3D string + '0'\n";
print TEMPFILE "if (separation > 3) taxamt =3D
string.substring(0,string.length-separation+3)\n";
print TEMPFILE "patax =3D ' PA tax : \$ ' + taxamt + ', '\n";
print TEMPFILE "taxamt =3D ( 1 * taxamt )\n";
}
else {
print TEMPFILE "taxamt =3D 0\n";
print TEMPFILE "patax =3D ''\n";
}
print TEMPFILE "statecode =3D
document.coform.state.value.substring(0,2)\n";
print TEMPFILE "if (statecode !=3D 'PA' && statecode !=3D 'Pa' &&
statecode !=3D 'pa' && statecode !=3D 'PE' && statecode !=3D 'Pe' &&
statecode !=3D 'pe') {\n";
print TEMPFILE "taxamt =3D 0; patax =3D ''; }\n";
print TEMPFILE "if (document.coform.shipping.selectedIndex =3D=3D 0)
{ shipcost =3D 0 }\n";
print TEMPFILE "if (document.coform.shipping.selectedIndex =3D=3D 1)
{ shipcost =3D '$sh_cost[0]' }\n";
print TEMPFILE "if (document.coform.shipping.selectedIndex =3D=3D 2)
{ shipcost =3D '$sh_cost[1]' }\n";
print TEMPFILE "if (document.coform.shipping.selectedIndex =3D=3D 3)
{ shipcost =3D '$sh_cost[2]' }\n";
print TEMPFILE "if (document.coform.shipping.selectedIndex =3D=3D 4)
{ shipcost =3D '$sh_cost[3]' }\n";
print TEMPFILE "shipping =3D '\\nShipping - \$' + shipcost\n";
print TEMPFILE "subsub =3D 1 * $SUBTOTAL\n";
print TEMPFILE "shipcost =3D 1 * shipcost\n";
print TEMPFILE "orderamt =3D subsub + shipcost + taxamt + .005\n";
print TEMPFILE "string =3D '' + orderamt\n";
print TEMPFILE "if (string.indexOf('.') =3D=3D -1) orderamt =3D string + '.
00'\n";
print TEMPFILE "separation =3D string.length - string.indexOf('.')\n";
print TEMPFILE "if (separation =3D=3D 2) orderamt =3D string + '0'\n";
print TEMPFILE "if (separation > 3) orderamt =3D
string.substring(0,string.length-separation+3)\n";
print TEMPFILE "if (patax =3D=3D '') { totot =3D 'ORDER TOTAL : \$ ' +
orderamt } \n ";
print TEMPFILE "else { totot =3D 'ORDER TOTAL : \$ ' + orderamt }\n";
print TEMPFILE "document.coform.finalinfo.value =3D patax + totot\n}\n";
print TEMPFILE "</script>\n";
print TEMPFILE "</form>\n";
}
if ($html_line =3D~ /<!--patax-->/ ) {
$pa_tax =3D 1;
}
while ( $html_line =3D~ /(<\+(.+?)\+>)/ ) {
$symbol_all =3D $1;
$symbol_replace =3D &token_replace($symbol_all);
if ($symbol_replace eq "*DEL*") {
$html_line =3D "\n";
}
if ($symbol_replace ne "*DEL*") {
$line_copy .=3D $` . $symbol_replace;
$html_line =3D $';
}
$html_line =3D $';
if ($symbol_replace eq "=A4") {
$new_line =3D "<center><table width=3D\"778\" border=3D\"1\" bgcolor=3D\"D1=
BFAB
\"><tr><td align=3Dcenter>\n";
$new_line .=3D "<table width=3D\"760\" border=3D\"0\"\n";
$new_line .=3D "<tr><td align=3Dcenter><font size=3D3 color=3D43261F
face=3Darial><u>Cha</u>nge</font></td>\n";
$new_line .=3D "<td align=3Dcenter><font size=3D3 color=3D43261F
face=3Darial><u>Qty</u></font></td>\n";
$new_line .=3D "<td align=3Dleft><font size=3D3 color=3D43261F
face=3Darial> <u>Item</u></font></td>\n";
$new_line .=3D "<td align=3Dleft colspan=3D\"2\"><font size=3D3 color=3D432=
61F
face=3Darial> <u>Special Information</u></font></td>\n";
$new_line .=3D "<td align=3Dcenter><font size=3D3 color=3D43261F
face=3Darial><u>Price Each</u></font></td>\n";
$new_line .=3D "<td align=3Dcenter><font size=3D3 color=3D43261F
face=3Darial><u>Cost</u></font></td>\n";
$new_line .=3D "<td align=3Dcenter><font size=3D3 color=3D43261F
face=3Darial><u>Del</u>ete</font></td></tr>\n";
$new_line .=3D "<tr><td colspan=3D8> </td></tr>\n";
foreach $bought (@each_item) {
$bought_copy =3D "";
while ( $bought =3D~ /'/ ) {
$bought_copy .=3D $` . "'"; $bought =3D $';
}
$bought_copy .=3D $bought;
$bought =3D $bought_copy;
$bought_copy =3D "";
while ( $bought =3D~ /"/ ) {
$bought_copy .=3D $` . """; $bought =3D $';
}
$bought_copy .=3D $bought;
$bought =3D $bought_copy;
($c_prod, $c_qty, $c_pmc, $price, $c_select, $c_idrop) =3D split(/=A4/,
$bought);
$c_idrop =3D~ tr/\x0A//d;
$c_idrop =3D~ tr/\x0D//d;
&split_price("$price");
$price =3D~ tr/ //d;
$c_size =3D $size;
$c_price =3D $price;
$c_price =3D 1 * $c_price;
$workspace =3D sprintf "%5.2f", $c_price;
$c_price =3D $workspace;
$c_price =3D~ tr/ //d;
$c_total =3D ( 1 * $c_qty ) * ( 1 * $c_price );
$workspace =3D sprintf "%5.2f", $c_total;
$c_total =3D $workspace;
$c_total =3D~ tr/ //d;
$size_chk =3D substr($c_size,0,1);
$new_line .=3D "<tr valign=3Dtop><form method=3DGET action=3D\"$SHOPCART_SE=
C\">
\n";
$new_line .=3D "<td align=3Dcenter valign=3Dtop><font size=3D2 color=3D4326=
1F
face=3Darial>\n";
$new_line .=3D "<input type=3Dhidden name=3D\"uid\" value=3D\"$uid\">\n";
$new_line .=3D "<input type=3Dhidden name=3D\"rootdir\" value=3D\"$root_dir=
\">
\n";
$new_line .=3D "<input type=3Dhidden name=3Dedititem value=3D\"$bought\">\n=
";
$new_line .=3D "<input type=3Dhidden name=3D\"gbgroup\" value=3D\"$gbgroup\=
">
\n";
$new_line .=3D "<input type=3Dsubmit name=3Dedit value=3D\"Cha\"></font></t=
d>
\n";
$new_line .=3D "<td align=3Dcenter><font size=3D2 color=3D43261F
face=3Darial><input type=3Dtext name=3Dnewqty value=3D\"$c_qty\" size=3D2
maxlength=3D2></font></td></form><td><font size=3D2 color=3D43261F
face=3Darial> <u>" . $c_prod . "</u></font></td>\n";
$new_line .=3D "<td align=3Dleft colspan=3D\"2\"><font size=3D3> </
font>";
if ($c_idrop ne "") {
$new_line .=3D "<font size=3D2 color=3D43261F face=3Darial><u>" . $c_idrop .
"</u></font>";
}
$workspace1 =3D substr($c_select,0,1);
if ($workspace1 ne "0" && $workspace1 ne "" ) {
$new_line .=3D "<font size=3D2 color=3D43261F face=3Darial>";
if ($c_idrop ne "") {
$new_line .=3D ", ";
}
$new_line .=3D "<u>" . $c_select . "</u></font>";
}
$workspace2 =3D substr($c_size,0,1);
if ($workspace2 ne "0" && $workspace2 ne "" ) {
$new_line .=3D "<font size=3D2 color=3D43261F face=3Darial>";
if ($workspace1 ne "" && $workspace1 ne "0" || $c_idrop ne "") {
$new_line .=3D ", ";
}
$new_line .=3D "<u>" . $c_size . "</u></font>";
}
$new_line .=3D " </td>\n<td align=3Dcenter>";
$new_line .=3D "<font size=3D2 color=3D43261F face=3Darial><u>\$" . $c_pric=
e .
"</u></font></td>\n<td align=3Dcenter><font size=3D2 color=3D43261F
face=3Darial>=3D <u>\$" . $c_total . "</u></font></td>\n";
$new_line .=3D "<form method=3DGET action=3D\"$SHOPCART_SEC\">\n";
$new_line .=3D "<td align=3Dcenter valign=3Dbottom><font size=3D2 color=3D5=
45803
face=3Darial>\n";
$new_line .=3D "<input type=3Dhidden name=3D\"uid\" value=3D\"$uid\">\n";
$new_line .=3D "<input type=3Dhidden name=3D\"rootdir\" value=3D\"$root_dir=
\">
\n";
$new_line .=3D "<input type=3Dhidden name=3D\"gbgroup\" value=3D\"$gbgroup\=
">
\n";
$new_line .=3D "<input type=3Dhidden name=3Dedititem value=3D\"$bought\">\n=
";
$new_line .=3D "<input type=3Dsubmit name=3Dedit value=3D\"Del\"></font></t=
d></
form></tr>\n";
$new_line .=3D "<tr><td><font size=3D2> </td></tr>\n";
}
$new_line .=3D "<br></table><form name=3Dcoform method=3DGET action=3D
\"$SHOPCART_SEC\">\n";
$new_line .=3D "<input type=3Dhidden name=3D\"uid\" value=3D\"$uid\">\n";
$new_line .=3D "<input type=3Dhidden name=3D\"rootdir\" value=3D\"$root_dir=
\">
\n";
$workspace =3D sprintf "%5.2f", $SUBTOTAL;
$SUBTOTAL =3D $workspace;
$SUBTOTAL =3D~ tr/ //d;
$new_line .=3D "<font size=3D3 color=3D43261F face=3Darial>Subtotal: =
\$
" . $SUBTOTAL . "<br></font>\n";
if ($pa_tax) {
$new_line .=3D "<font size=3D2 color=3D43261F face=3Darial>( PA residents, =
6%
sales tax will be added )<br><br></font>\n";
}
$new_line .=3D "<font size=3D3 color=3D43261F face=3Darial><select
name=3Dshipping size=3D1 onChange=3D\"compute(coform)\">\n";
$new_line .=3D "<option value=3D0 selected> Please Choose a Shipping
Method \n";
foreach $s_opt (@s_table) {
$new_line .=3D "<option>" . $s_opt . "\n";
}
$new_line .=3D "</select><br><br>\n</font><font size=3D3 color=3D43261F
face=3Darial><input type=3Dtext name=3Dfinalinfo size=3D30 value=3D\"ORDER
TOTAL :\"></font><br><br>\n";
$new_line .=3D "</td></tr></table></center>\n";
$line_copy =3D $new_line;
}
}
$line_copy .=3D $html_line;
$html_line =3D $line_copy;
&check_href;
print TEMPFILE $html_line;
if ($html_line =3D~ /<head/) {
print TEMPFILE "<script language=3D\"JavaScript\">var cart_uid=3D\"" .
$uid . "\"</script>\n";
}
}
close(HTMLPAGE);
close(TEMPFILE);
$goto =3D $TEMP_FILE;
$security =3D 1;
&goto_html_parse();
}
#
***************************************************************************=
****************
#
# SUBROUTINE reads in requested goto .html page, #
# checks for shopcart markers and href commands, then #
# replaces / changes as needed and outputs the page. #
# *************************************************** #
sub goto_html_parse {
local ($gopiece, $x, $where_is, $workspace, $sitename);
if ($goto !~ /^\// ) {
$goto =3D $root_dir . "/" . $goto;
}
$sURL =3D $SITE_URL;
if ($security) {
$workspace =3D $ENV{'SCRIPT_NAME'};
if ( $workspace =3D~ /[a-zA-Z0-9\-]+\.com/ ) {
$sURL =3D "https://www.dianneblair.com/$&";
}
elsif ( $workspace =3D~ /[a-zA-Z0-9\-]+\.net/ ) {
$sURL =3D "https://www.dianneblair.com/$&";
}
elsif ( $workspace =3D~ /[a-zA-Z0-9\-]+\.org/ ) {
$sURL =3D "https://www.dianneblair.com/$&";
}
}
$goto =3D~ /$root_dir/;
$gopiece =3D $';
$x =3D rindex($gopiece,"/");
$x =3D $x + 1;
$where_is =3D $sURL . substr($gopiece, 0, $x);
open(HTMLPAGE, $goto) || &sc_popup_msg("SYSTEM ERROR SC26: $goto
unable to be accessed: $!");
print "Content-type: text/html\n\n";
while ($html_line =3D <HTMLPAGE>) {
$html_copy =3D "";
$html_line =3D~ s/JPG/jpg/g;
$html_line =3D~ s/GIF/gif/g;
$html_line =3D~ s/\.\.\///g;
while ( $html_line =3D~ /[a-zA-Z0-9\.\/]+\.jpg/ ) {
if ($security) {
$html_copy .=3D $` . $sURL . "\/" . $&;
}
elsif ( index($&,"/") >=3D 0 ) {
$html_copy .=3D $` . $sURL . "\/" . $&;
}
else {
$html_copy .=3D $` . $where_is . $&;
}
$html_line =3D $';
}
$html_copy .=3D $html_line;
$html_line =3D $html_copy;
$html_copy =3D "";
while ( $html_line =3D~ /[a-zA-Z0-9\.\/]+\.gif/ ) {
if ($security) {
$html_copy .=3D $` . $sURL . "\/" . $&;
}
elsif ( index($&,"/") >=3D 0 ) {
$html_copy .=3D $` . $sURL . "\/" . $&;
}
else {
$html_copy .=3D $` . $where_is . $&;
}
$html_line =3D $';
}
$html_copy .=3D $html_line;
$html_line =3D $html_copy;
&check_href;
print $html_line;
if ($html_line =3D~ /<head/) {
print "<script language=3D\"JavaScript\">var cart_uid=3D\"" . $uid . "\"</
script>\n";
}
}
print $version;
print "\n\n";
close(HTMLPAGE);
}
#
***************************************************************************=
****************
#
# SUBROUTINE replaces html tokens #
# ******************************* #
sub token_replace {
local ($symbol_all) =3D @_;
local ($RCbutton) =3D '/shopcart/b-review.gif';
local ($ECbutton) =3D '/shopcart/b-empty.gif';
local ($ACbutton) =3D '/shopcart/b-add.gif';
local ($SEbutton) =3D '/shopcart/b-search.gif';
local ($CObutton) =3D '/shopcart/b-checkout.gif';
local ($len) =3D 0;
local ($image_src, $display_price, $goto_token, $web_page, $check_end,
$select, $price_list, @price_array, @select_array, $oneor,
$select_list, $cardtype, $wanted_types, $return_str, $p, $len );
# handle tokens & attributes in the form
# token attrib1 =3D "value1" attrib2 =3D "value2" ...
($replace_token, $attrs) =3D ($symbol_all =3D~ m/(\w+)(( *(\w+) *=3D *\"(.+=
?)
\")*)/);
while (($attr, $value) =3D ($attrs =3D~ m/^ *(\w+) *=3D *\"(.+?)\"/))
{
$ATTRS{$attr} =3D $value;
$attrs =3D $';
}
$workspace =3D $replace_token;
if ($workspace =3D~ /[_0-9]{2,3}/) {
if (substr($&,0,1) ne "_") {
&sc_popup_msg("CODING ERROR: $symbol_all is an invalid ShopCart html
token.");
}
$len =3D substr($&,1);
$replace_token =3D $`;
}
if ($replace_token eq "groupname") {
return($groupname);
}
elsif ($replace_token eq "grouptitle") {
return($grouptitle);
}
elsif ($replace_token eq "grouppic") {
$img_src =3D "<img src=3D\"../images/groups/".$groupimage."\" border=3D
\"0\">";
return($img_src);
}
elsif ($replace_token eq "itemdescr") {
return($itemdescr);
}
elsif ($replace_token eq "mancode") {
return($mancode);
}
elsif ($replace_token eq "distributor") {
return($distributor);
}
elsif ($replace_token eq "condition") {
return($condition);
}
elsif ($replace_token eq "PMCcode") {
return($PMCcode);
}
elsif ($replace_token eq "packaging") {
return($packaging);
}
elsif ($replace_token eq "shipdate") {
return($shipdate);
}
elsif ($replace_token eq "weight") {
return($weight);
}
elsif ($replace_token eq "itemcode") {
return($itemcode);
}
elsif ($replace_token eq "itemprice") {
return($itemprice);
}
elsif ($replace_token eq "littlepic") {
$img_src =3D "<img src=3D\"../images/little/".$littlepic."\" border=3D
\"0\">";
return($img_src);
}
elsif ($replace_token eq "bigpic") {
$img_src =3D "<img src=3D\"../images/big/".$bigpic."\" border=3D\"0\">";
return($img_src);
}
elsif ($replace_token eq "prodname") {
return($prodname);
}
elsif ($replace_token eq "shortdesc") {
return($shortdesc);
}
elsif ($replace_token eq "longdesc") {
return($longdesc);
}
elsif ($replace_token eq "blurb") {
return($groupdescr);
}
elsif ($replace_token eq "price") {
if ( !($price eq "0") ) {
&split_price("$price");
$price =3D~ tr/ //d;
return("\$ $price \n<input type=3Dhidden name=3D\"price\" value=3D\"$price
\">");
}
return("(by size)");
}
elsif ($replace_token eq "sizeprice") {
@price_array =3D ($vprice, $sprice, $mprice, $lprice, $xprice);
$nosize =3D 1;
foreach $select (@price_array) {
if ($select ne "0") {
$nosize =3D 0;
}
}
if ($nosize) {
return("*DEL*");
}
else {
$x =3D 1;
$first_time =3D 1;
# start table
$price_list =3D "<table border=3D\"0\" cellpadding=3D\"0\" cellspacing=3D\"=
0\"
width=3D\"100%\">\n";
# this font is used to format the sizes & prices
$font =3D "<font face=3D\"Verdana, Arial, Helvetica\" size=3D\"2\" color=3D
\"800000\">";
foreach $select (@price_array)
{
if (! ($select eq "0") )
{
&split_price("$select");
$price =3D sprintf "%5.2f", $price;
$price =3D~ tr/ //d;
$select =3D~ tr/ /\+/;
# start row
$price_list .=3D "<tr><td><input type=3D\"radio\" ";
if ($first_time)
{
$price_list .=3D "checked ";
}
$price_list .=3D "name=3D\"price\" value=3D\"$select\">\n";
$price_list .=3D "$font$size</font></td>\n";
$price_list .=3D "<td>$font\$$price</font></td></tr>\n";
}
}
# end table
$price_list .=3D "</table>\n";
return($price_list);
}
}
elsif ($replace_token eq "oneorother") {
if ($selectA eq "0") {
return("*DEL*");
}
$select_list =3D "";
@select_array =3D ($selectA, $selectB, $selectC, $selectD, $selectE);
$first_time =3D 1;
foreach $oneor (@select_array) {
$tester =3D substr($oneor,0,1);
if ($tester ne "0") {
if ( !($first_time) ) {
$select_list .=3D "<input type=3Dradio name=3Dselect value=3D\"" . $oneor .
"\">" . $oneor . " ";
}
if ($first_time) {
$select_list .=3D "<input type=3Dradio checked name=3Dselect value=3D\"" .
$oneor . "\">" . $oneor . " ";
$first_time =3D 0;
}
}
}
return($select_list);
}
elsif ($replace_token eq "goback") {
if ($item_chk) {
$use_group =3D $groupcode; $use_group =3D~ tr/ /+/;
return("<a href=3D'".$SHOPCART_URL."?group=3D".$use_group."'>");
}
if ($checkout_chk) {
$gbgroup =3D $FORM{'gbgroup'};
return("<a href=3D'".$SHOPCART_URL."?group=3D".$gbgroup."'>");
}
if ($group_chk) {
&sc_popup_msg("CODING ERROR: the <+goback+> token is invalid in
group.html");
}
}
elsif ($replace_token eq "categories_combo") {
$combo =3D "<select name=3D\"categories\">\n";
@groups =3D sort(keys %GROUPS);
$combo =3D $combo . "<option value=3D\"All\">All Categories\n";
foreach $opt (@groups)
{
($groupcode, $itemcode, $descr, $title, $image, $droplist, $cols,
$rows, $junk) =3D split(/=A4/, $GROUPS{$opt}, 9);
if ($title ne "Custom Mix") { $combo =3D $combo . "<option value=3D\"$opt
\">$title\n"; }
}
$combo =3D $combo . "</select>\n";
return $combo;
}
elsif ($replace_token eq "distributor_combo") {
$combo =3D "<select name=3D\"distributor\">\n";
$combo =3D $combo . "<option value=3D\"All\">All\n";
foreach $opt (@DISTRIBUTORS)
{
$combo =3D $combo . "<option value=3D\"$opt\">$opt\n";
}
$combo =3D $combo . "</select>\n";
return $combo;
}
elsif ($replace_token eq "qty") {
return("<input type=3Dtext name=3Dqty size=3D2 maxlength=3D2 value=3D\"1\">=
");
}
elsif ($replace_token eq "addtocart") {
$x =3D $root_dir . $ACbutton;
if (-e $x) {
return("<input type=3Dimage src=3D\"$SITE_URL.$ACbutton\" border=3D\"0\" al=
t=3D
\"Add this item to your shopping cart\" name=3D\"addtocart\">");
}
else {
return("<input type=3Dsubmit name=3D\"addtocart\" value=3D\" Add To Your
Cart \">");
}
}
elsif ($replace_token eq "quickadd") {
$x =3D $root_dir . $ACbutton;
if (-e $x) {
return("<input type=3Dimage src=3D\"$SITE_URL.$ACbutton\" border=3D\"0\" al=
t=3D
\"Add this item to your shopping cart\" name=3D\"quickadd\">");
}
else {
return("<input type=3Dsubmit name=3D\"quickadd\" value=3D\" Add To Your Cart
\">");
}
}
elsif ($replace_token eq "search") {
$x =3D $root_dir . $SEbutton;
if (-e $x) {
return("<input type=3Dimage src=3D\"$SITE_URL.$SEbutton\" border=3D\"0\" al=
t=3D
\"Search\" name=3D\"search\">");
}
else {
return("<input type=3Dsubmit name=3D\"search\" value=3D\" Search \">");
}
}
elsif ($replace_token eq "advsearch") {
$x =3D $root_dir . $SEbutton;
if (-e $x) {
return("<input type=3Dimage src=3D\"$SITE_URL.$SEbutton\" border=3D\"0\" al=
t=3D
\"Search\" name=3D\"advanced_search\">");
}
else {
return("<input type=3Dsubmit name=3D\"advanced_search\" value=3D\" Search
\">");
}
}
elsif ($replace_token eq "review") {
$x =3D $root_dir . $RCbutton;
if (-e $x) {
return("<input type=3Dimage src=3D\"$SITE_URL.$RCbutton\" border=3D\"0\" al=
t=3D
\"Review the contents of your shopping cart\" name=3Dreview>");
}
else {
return("<input type=3Dsubmit name=3Dreview value=3D\"Review your cart\">");
}
}
elsif ($replace_token eq "empty") {
$x =3D $root_dir . $ECbutton;
if (-e $x) {
return("<input type=3Dimage src=3D\"$SITE_URL.$ECbutton\" border=3D\"0\" al=
t=3D
\"Empty your shopping cart of all items\" name=3Dempty>");
}
else {
return("<input type=3Dsubmit name=3Dempty value=3D\"Empty your cart\">");
}
}
elsif ($replace_token eq "endgo") {
return("</a>");
}
elsif ($replace_token eq "text1") {
$workspace =3D substr($text1,0,1);
if ( $workspace ne "0") {
return($text1."<br><input type=3Dtext name=3Dtext1 size=3D30
maxlength=3D255><br><br>");
}
else {
return("*DEL*");
}
}
elsif ($replace_token eq "text2") {
$workspace =3D substr($text2,0,1);
if ( $workspace ne "0") {
return($text2."<br><textarea name=3Dtext2 cols=3D30 rows=3D2></
textarea><br><br>");
}
else {
return("*DEL*");
}
}
elsif ($replace_token eq "text3") {
$workspace =3D substr($text3,0,1);
if ( $workspace ne "0") {
return($text3."<br><textarea name=3Dtext3 cols=3D30 rows=3D3></
textarea><br><br>");
}
else {
return("*DEL*");
}
}
elsif ($replace_token eq "rootdir") {
$workspace =3D substr($root_dir,0,1);
if ( $workspace ne "0") {
return("<input type=3D\"hidden\" name=3D\"rootdir\" value=3D\"$root_dir
\">");
}
else {
return("*DEL*");
}
}
elsif ($replace_token eq "checkout") {
$return_str =3D "\n</form>\n<form method=3DGET action=3D\"$SHOPCART_SEC\"
onSubmit=3D\"return confirm(confirmtxt)\">\n";
$return_str .=3D "<input type=3Dhidden name=3D\"uid\" value=3D\"$uid\">\n";
$return_str .=3D "<input type=3Dhidden name=3D\"rootdir\" value=3D\"$root_d=
ir
\">\n";
$return_str .=3D "<input type=3Dhidden name=3D\"gbgroup\" value=3D\"$groupn=
ame
\">\n";
$x =3D $root_dir . $CObutton;
if (-e $x) {
$return_str .=3D "<input type=3Dimage src=3D\"$SITE_URL.$CObutton\" border=
=3D
\"0\" alt=3D\"All done shopping, time to checkout\" name=3Dcheckout>\n";
}
else {
$return_str .=3D "<input type=3Dsubmit name=3Dcheckout value=3D\"* C h e c=
k
o u t *\">\n";
}
$return_str .=3D "</form>\n<form method=3DGET action=3D\"$SHOPCART_URL\">
\n";
$return_str .=3D "<input type=3Dhidden name=3D\"uid\" value=3D\"$uid\">\n";
$return_str .=3D "<input type=3Dhidden name=3D\"rootdir\" value=3D\"$root_d=
ir
\">\n";
return("$return_str");
}
elsif ($replace_token eq "sendorder") {
$return_str =3D "\n</font></font></font>\n<font size=3D\"4\" color=3D\"black
\" face=3D\"Arial\">\n";
$return_str .=3D "</font><font size=3D3><br>\n<input type=3Dhidden
name=3Dpatax value=3D\"$pa_tax\">\n<input type=3Dsubmit name=3Dsendorder va=
lue=3D
\"* S u b m i t O r d e r *\">\n</font>";
return("$return_str");
}
elsif ($replace_token eq "name") {
if (!$len)
{
$len=3D30;
}
; return("<input type=3Dtext name=3Dname size=3D$len maxlength=3D50>");
}
elsif ($replace_token eq "address") {
if (!$len)
{
$len=3D30;
}
; return("<textarea name=3Daddress cols=3D$len rows=3D3></textarea>");
}
elsif ($replace_token eq "city") {
if (!$len)
{
$len=3D30;
}
; return("<input type=3Dtext name=3Dcity size=3D$len maxlength=3D50>");
}
elsif ($replace_token eq "state") {
if (!$len)
{
$len=3D2;
}
; return("<input type=3Dtext name=3Dstate size=3D$len maxlength=3D20 onChan=
ge=3D
\"compute(coform)\">");
}
elsif ($replace_token eq "zip") {
if (!$len)
{
$len=3D5;
}
; return("<input type=3Dtext name=3Dzip size=3D$len maxlength=3D10>");
}
elsif ($replace_token eq "cardholder") {
if (!$len)
{
$len=3D5;
}
; return("<input type=3Dtext name=3Dcardholder size=3D$len maxlength=3D50>"=
);
}
elsif ($replace_token eq "email") {
if (!$len)
{
$len=3D30;
}
; return("<input type=3Dtext name=3Demail size=3D$len maxlength=3D50>");
}
elsif ($replace_token eq "phone") {
if (!$len)
{
$len=3D12;
}
; return("<input type=3Dtext name=3Dphone size=3D$len maxlength=3D20>");
}
elsif ($replace_token eq "ccnumber") {
if (!$credit_card) {
return("*DEL*");
}
if (!$len) {
$len=3D19;
}
return("<input type=3Dtext name=3Dccnumber size=3D$len maxlength=3D50>");
}
elsif ($replace_token eq "ccdate") {
if (!$credit_card) {
return("*DEL*");
}
if (!$len) {
$len=3D5;
}
return("<input type=3Dtext name=3Dccdate size=3D$len maxlength=3D20>");
}
elsif ($replace_token eq "cctype") {
if (!$credit_card) {
return("*DEL*");
}
$wanted_types =3D "<select name=3Dcctype size=3D1>";
foreach $cardtype (@cards) {
$wanted_types .=3D "<option>" . $cardtype;
}
$wanted_types .=3D "</select>";
return($wanted_types);
}
elsif ($replace_token eq "itemsordered") {
return("=A4");
}
elsif ($replace_token eq "specialinfo") {
if (!$len)
{
$len=3D60;
}
; return("<textarea name=3Dspecialinfo cols=3D$len rows=3D4></textarea>");
}
elsif ($replace_token eq "paymentoptions") {
$p =3D $credit_card + $mail_check + $c_o_d;
if ($p lt 2) {
return("*DEL*");
}
$wanted_types =3D '';
if ($p ge 2) {
$wanted_types .=3D '<input type=3Dhidden name=3Dpychk value=3D1>';
}
$wanted_types .=3D 'Payment Options: ';
if ($credit_card) {
$wanted_types .=3D '<input type=3Dradio name=3Dpymtopt
value=3D"CreditCard">Credit Card ';
}
if ($mail_check)
{
$wanted_types .=3D '<input type=3Dradio name=3Dpymtopt
value=3D"MailCheck">Check or Money Order ';
}
if ($c_o_d)
{
$wanted_types .=3D '<input type=3Dradio name=3Dpymtopt value=3D"COD">C.O.D.
(cash only)';
}
return($wanted_types);
}
elsif ($replace_token eq "hcategories") {
return $HORIZ_CATS;
}
elsif ($replace_token eq "vcategories") {
return $VERT_CATS;
}
elsif ($replace_token eq "distributorlist") {
return $MANU_LIST;
}
elsif ($replace_token eq "itemcount") {
return $ITEMCOUNT;
}
elsif ($replace_token eq "subtotal") {
return "\$" . $SUBTOTAL;
}
elsif ($replace_token eq "pagecounts") {
if ($numitems > 0)
{
$ret =3D "Displaying " . ($min_items + 1) . " to $max_items (of
$numitems products)";
}
else
{
$ret =3D "No items to display.";
}
return $ret;
}
elsif ($replace_token eq "pagelinks") {
if ($numitems > 0) {
$ret =3D "Page: ";
if ($pagenum > 1) {
$prev =3D $pagenum - 1;
$ret =3D $ret . $PAGELINK . "&pagenum=3D$prev\">[<<Prev]</
a> ";
}
for ($i =3D 1; $i <=3D $num_of_pages; $i++) {
if ($i =3D=3D $pagenum) {
$ret =3D $ret . "<font color=3D\"761A23\">$i</font> ";
} else {
$ret =3D $ret . $PAGELINK . "&pagenum=3D$i\">$i</a> ";
}
}
if ($pagenum < $num_of_pages) {
$next =3D $pagenum + 1;
$ret =3D $ret . $PAGELINK . "&pagenum=3D$next\">[Next>>]</a>";
}
} else {
$ret =3D "";
}
return $ret;
}
elsif ($replace_token eq "uid") {
return $uid;
}
else {
&sc_popup_msg("CODING ERROR: $symbol_all is an invalid ShopCart html
token.");
}
}
#
***************************************************************************=
****************
#
# SUBROUTINE checks for, and replaces, necessary href #
# *************************************************** #
sub check_href {
local($html_copy, $tempa, $tempb);
$html_copy =3D "";
while ( $html_line =3D~ /href/ ) {
if ( $html_line =3D~ /ShopCart.pl\?/) {
if ( (substr($',0,3)) ne "uid" ) {
$html_copy .=3D $` . "ShopCart.pl?uid=3D" . $uid . "&rootdir=3D" .
$root_dir . "&" ;
$html_line =3D $';
}
else {
$html_copy .=3D $` . $&;
$html_line =3D $';
}
}
elsif ( $html_line =3D~ /[\w]{1,16}\.pl/ ) {
$html_copy .=3D $`;
$perl =3D $&;
$temp =3D $';
$temp =3D~ /([a-zA-Z0-9\/\.]{1,30})/;
$parm =3D $&;
$html_copy .=3D "ShopCart.pl?uid=3D$uid" . "&link=3D$perl" . "&parm=
=3D
$parm";
$html_line =3D $';
}
elsif ( (!($html_line =3D~ /href=3D"http/)) && (!($html_line =3D~ /
href=3D"mailto/)) && (!($html_line =3D~ /href=3D"javascript/)) ) {
if ( $html_line =3D~ /href=3D"..\//) {
$html_copy .=3D $` . "href=3D\"" . $SHOPCART_URL . "?uid=3D" . $uid .
"&goto=3D" . $root_dir . "/";
$html_line =3D $';
}
elsif ( $html_line =3D~ /href=3D"/) {
$html_copy .=3D $` . "href=3D\"" . $SHOPCART_URL . "?uid=3D" . $uid .
"&goto=3D" . $root_dir . "/";
$html_line =3D $';
}
}
else {
if ( $html_line =3D~ /href/) {
$html_copy .=3D $` . "href";
$html_line =3D $';
}
}
}
$html_copy .=3D $html_line;
$html_line =3D $html_copy;
}
#
***************************************************************************=
****************
#
# SUBROUTINE display shopping cart review window #
# ********************************************** #
sub review_cart
{
local ($whats_init) =3D @_;
local (@which_one, $bought, $prod_show, $prod_copy, $qty_show,
$item_amt, $item_stuff, $item_total, $chpid);
local ($goto) =3D "review.html";
local $filename =3D $BASE_DIR.$goto;
print "Content-type: text/html\n\n";
open(HTMLPAGE, $filename) || &sc_popup_msg("ERROR SC19: $goto unable
to be accessed in shopcart folder: $!");
while ($html_line =3D <HTMLPAGE>)
{
$line_copy =3D "";
if ($html_line =3D~ /<\+itemsordered\+>/)
{
if ($whats_init =3D~ /=A4/)
{
@which_one =3D split(/\|/, $whats_init);
foreach $bought (@which_one)
{
$bought_copy =3D "";
while ( $bought =3D~ /'/ ) {
$bought_copy .=3D $` . "'"; $bought =3D $';
}
$bought_copy .=3D $bought;
$bought =3D $bought_copy;
$bought_copy =3D "";
while ( $bought =3D~ /"/ ) {
$bought_copy .=3D $` . """; $bought =3D $';
}
$bought_copy .=3D $bought;
$bought =3D $bought_copy;
($prod_show, $qty_show, $pmc_show, $price, $select_show, $text1_show,
$text2_show, $text3_show, $idrop_show) =3D split(/=A4/, $bought);
$idrop_show =3D~ tr/\x0A//d;
$idrop_show =3D~ tr/\x0D//d;
if ($idrop_show ne "") {
$prod_show =3D $prod_show . ", " . $idrop_show;
}
&split_price("$price");
$price =3D~ tr/ //d;
$size_show =3D $size;
$item_amt =3D $price;
$item_amt =3D 1 * $item_amt;
$workspace =3D sprintf "%5.2f", $item_amt;
$item_amt =3D $workspace;
$item_amt =3D~ tr/ //d;
$item_total =3D ( 1 * $qty_show ) * ( 1 * $item_amt );
$workspace =3D sprintf "%5.2f", $item_total;
$item_total =3D $workspace;
$item_total =3D~ tr/ //d;
$size_chk =3D substr($size_show,0,1);
print "$prod_show";
if (($size_show ne "0") && ($size_show ne ""))
{
print ", $size_show";
}
if (($select_show ne "0") && ($select_show ne "")) {
print ", $select_show ";
}
print " ( $qty_show at $item_amt ) \$$item_total
$text_stuff<br><br>\n";
}
}
else
{
print "Your shopping cart is empty<br>\n";
}
next;
}
while ($html_line =3D~ /(<\+(.+?)\+>)/)
{
$symbol_all =3D $1;
$symbol_replace =3D &token_replace($symbol_all);
$line_copy .=3D $` . $symbol_replace;
$html_line =3D $';
}
$line_copy .=3D $html_line;
$html_line =3D $line_copy;
&check_href;
print $html_line;
if ($html_line =3D~ /<head/) {
print "<script language=3D\"JavaScript\">var cart_uid=3D\"" . $uid . "\"</
script>\n";
}
}
exit();
}
#
***************************************************************************=
****************
#
# SUBROUTINE temp file/page setups, opens and deletes #
# *************************************************** #
sub TEMP_stuff {
local($x, $y, $thisone, @tempdata);
if (&lock("tempdata")) {
&sc_popup_msg($Popup_Message);
}
if (!(-e $TEMP_DATA)) {
open(TEMPDATA, ">$TEMP_DATA") || &sc_popup_msg("SYSTEM ERROR SC28:
Unable to create $TEMP_DATA: $!");
print TEMPDATA "dummy.html\ndummy.html";
close(TEMPDATA);
}
open(TEMPDATA, $TEMP_DATA) || &sc_popup_msg("SYSTEM ERROR SC28: Unable
to access $TEMP_DATA: $!");
$x =3D 0; $y =3D 0;
while ($tempdata[$x] =3D <TEMPDATA>) {
$x =3D $x + 1;
}
close(TEMPDATA);
$x =3D $x - 1;
while ( $y < $x ) {
$thisone =3D $tempdata[$y];
$thisone =3D~ tr/\x0A//d;
$thisone =3D~ tr/\x0D//d;
$thisone =3D~ tr/ //d;
unlink($thisone);
$y =3D $y + 1;
}
open(TEMPFILE, ">$TEMP_FILE") || &sc_popup_msg("SYSTEM ERROR SC29:
Unable to create data in the shopvar folder.: $!");
open(TEMPDATA, ">$TEMP_DATA") || &sc_popup_msg("SYSTEM ERROR SC30:
Unable to access data in the shopvar folder.: $!");
print TEMPDATA "$tempdata[$x]\n";
print TEMPDATA "$TEMP_FILE";
close(TEMPDATA);
&unlock("tempdata");
}
#
***************************************************************************=
****************
#
# SUBROUTINES split price and size from same field #
# ************************************************ #
sub split_price {
local($thisone) =3D @_;
if ( $thisone =3D~ /=DE/ ) {
$x =3D index($thisone,"=DE");
$size =3D substr($thisone,0,$x);
$size =3D~ tr/+/ /d;
$price =3D substr($thisone,($x+1));
}
else {
$price =3D $thisone;
$size =3D "";
}
}
#
***************************************************************************=
****************
#
# SUBROUTINES split price and size from same field - Custom for
PremiseMaid #
# ************************************************ #
sub split_pricePM {
local($thisone) =3D @_;
if ( $thisone =3D~ /=DE/ ) {
$x =3D index($thisone,"=DE");
$sizeCheck =3D substr($thisone,0,$x);
$sizeCheck =3D~ tr/+/ /d;
$priceCheck =3D substr($thisone,($x+1));
}
else {
$priceCheck =3D $thisone;
$sizeCheck =3D "";
}
}
#
***************************************************************************=
****************
#
# SUBROUTINE debug tracking by a message #
# ************************************** #
sub de_bug {
local($tellit) =3D @_;
print "Content-type: text/html\n\n";
print "<script language=3D'JavaScript'>\n";
print "var winHandle =3D
window.open('' ,'Debug','top=3D100,left=3D100,width=3D400,height=3D400')\n";
print "winHandle.window.focus();\n";
print "winHandle.document.open();\n";
print "winHandle.document.write('".$tellit."');";
print "winHandle.document.close();\n";
print "winHandle.window.focus();\n";
print "</script></html>\n";
exit;
}
#
***************************************************************************=
****************
#
# SUBROUTINE number check #
# *********************** #
sub not_a_number {
local($thisnum) =3D @_;
local($len, $lenchk);
$thisnum =3D~ tr/$//d;
$thisnum =3D~ tr/.//d;
$thisnum =3D~ tr/,//d;
$len =3D length $thisnum;
$thisnum =3D~ tr/a-z//d; $thisnum =3D~ tr/A-Z//d;
$thisnum =3D~ tr/\-//d; $thisnum =3D~ tr/\=3D//d; $thisnum =3D~ tr/\\//d;
$thisnum =3D~ tr/-//d;
$thisnum =3D~ tr/\[//d; $thisnum =3D~ tr/\]//d; $thisnum =3D~ tr/;//d;
$thisnum =3D~ tr/'//d;
$thisnum =3D~ tr/\///d;
$lenchk =3D length $thisnum;
if ( $len ne $lenchk ) {
return(1);
}
return(0);
}
#
***************************************************************************=
****************
#
# SUBROUTINE error message display #
# ******************************** #
sub sc_popup_msg {
local($popup) =3D @_;
local($del_lock) =3D $root_dir . '/shopvar/userdata.lok';
unlink($del_lock);
$del_lock =3D $root_dir . '/shopvar/tempdata.lok'; unlink($del_lock);
$del_lock =3D $root_dir . '/shopvar/proddata.lok'; unlink($del_lock);
print "Content-type: text/html\n\n";
print "<script language=3D'JavaScript'>\n";
print "alert(\"$popup\");\n";
print "history.go(-1);\n";
print "</script>\n\n\n";
exit;
}
#
***************************************************************************=
****************
#
# SUBROUTINES lock and unlock userdata file #
# ***************************************** #
sub lock {
local($filename) =3D @_;
local($wait, $lock_pid);
$Popup_Message =3D '';
$lock_file =3D "$TEMP_DIR$filename.lok";
if (-e $lock_file) {
for ($wait =3D $FILE_LOCK_WAIT; $wait >=3D 1; $wait--) {
sleep 1;
if (!(-e $lock_file)) {
$wait =3D 1;
}
;
}
}
if ((-e $lock_file) && (-M $lock_file < 0)) {
$Popup_Message =3D "SC31: A lock file is currently in heavy use. Please
try again.";
return(1);
}
if (!open(LOCK, ">$lock_file")) {
$Popup_Message =3D "SYSTEM ERROR SC32: Unable to open a lock file: $!";
return(2);
}
else {
print LOCK $$; close LOCK;
}
if (!open(LOCK, "<$lock_file")) {
$Popup_Message =3D "SYSTEM ERROR SC33: Unable to open a lock file: $!";
return(3);
}
else {
$lock_pid =3D <LOCK>; close(LOCK);
}
if ($lock_pid ne $$) {
$Popup_Message =3D "SC34: A lock file is currently in heavy use. Please
try again.";
return(4);
}
else {
return(0);
}
}
# ***************************************************************** #
sub unlock {
local($filename) =3D @_;
local($lock_file) =3D "$TEMP_DIR$filename.lok";
$Popup_Message =3D '';
if (!open(LOCK, "<$lock_file")) {
$Popup_Message =3D "SYSTEM ERROR SC35: Unable to open a lock file for
clearing: $!";
return(1);
}
else {
$lock_pid =3D <LOCK>; close(LOCK);
}
if ($lock_pid ne $$) {
$Popup_Message =3D "SYSTEM ERROR SC36: Unable to open a lock file for
clearing: $!";
return(2);
}
if (!unlink($lock_file)) {
$Popup_Message =3D "SYSTEM ERROR SC37: Unable to clear a lock file:
$!";
return(3);
}
return(0);
}
# ************************************** #
# SUBROUTINE credit card number validate #
# ************************************** #
sub cc_validate {
local($card_type, $card_num, $exp_date) =3D @_;
local(%card_length) =3D ('V', '13,15,16', 'M', '16', 'A', '15', 'D',
'16');
local($entered_num, $card_length, $total, $d);
if ($card_num =3D=3D '1111222233334444') {
return(0);
}
$card_type =3D~ tr/a-z/A-Z/;
if (!$card_length{$card_type}) {
$Popup_Message =3D "MISSING: Please choose a credit card type.";
return(1);
}
$entered_num =3D $card_num;
$card_num =3D~ s/\D//g;
$card_length =3D length($card_num);
if (!($card_length{$card_type} =3D~ /(^|,)$card_length(,|$)/)) {
$Popup_Message =3D "RE-ENTER: Your card number $entered_num has the
incorrect number of digits.";
return(2);
}
local($month_now, $year_now) =3D (localtime)[4,5];
++$month_now;
if ($year_now < 50) {
$year_now +=3D 100;
}
$exp_date =3D~ m|(\d+)/(\d+)|;
$exp_month =3D $1;
$exp_year =3D ($2 < 50) ? $2 + 100 : $2;
if (!$exp_date || !$exp_month || (($year_now =3D=3D $exp_year) &&
($month_now > $exp_month))
|| ($exp_year - $year_now < 0) || ($exp_year - $year_now > 10)) {
$Popup_Message =3D "RE-ENTER: Please enter a valid credit card
expiration date in the form MM/YY.";
return(3);
}
while (length($card_num)) {
$total +=3D chop($card_num);
$total +=3D (($d =3D chop($card_num)) < 9) ? ($d * 2) % 9 : 9;
}
if ($total % 10) {
$Popup_Message =3D "RE-ENTER: $entered_num is not a valid credit card
number.";
return(4);
}
return(0);
}
# ************************************** #
# SUBROUTINE parse input to this program #
# ************************************** #
sub parse_input {
local($prename, $name, $value, $len, $pair, $x, $workspace, $formname,
@pairs);
@pairs =3D split(/&/, $ENV{'QUERY_STRING'});
foreach $pair (@pairs) {
($prename, $value) =3D split(/=3D/, $pair);
if ($prename =3D~ /\./) {
$x =3D index($prename,".");
$name =3D substr($prename,0,$x);
}
else {
$name =3D $prename;
}
$name =3D~ tr/+/ /;
$name =3D~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$name =3D~ s/\n//g;
$value =3D~ tr/+/ /;
$value =3D~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$value =3D~ s/\n//g;
$value =3D~ s/<!--(.|\n)*-->//g;
if ($FORM{$name}) {
$FORM{$name} .=3D ",$value";
}
else {
$FORM{$name} =3D $value;
}
}
if ($FORM{'rootdir'}) {
$root_dir =3D $FORM{'rootdir'};
}
else {
$root_dir =3D $ENV{'DOCUMENT_ROOT'};
}
return(1);
}
#
***************************************************************************=
****************
#
# SUBROUTINE sends email (UNIX sendmail) #
# ************************************** #
sub send_order {
open(MAIL, "|$MAIL_DIR -f $email -t");
select(MAIL);
$| =3D 1;
select(STDOUT);
print MAIL "To: $ORDER_TO\n";
print MAIL "From: $email\n";
print MAIL "CC: $ORDER_CC\n";
print MAIL "BCC: \n" if $bcc;
print MAIL "Subject: $ORDER_SUBJECT\n";
print MAIL "\n";
$body =3D &parse_email("order", @emailorder);
print MAIL $body;
print MAIL "\n";
close(MAIL);
sleep 2;
open(MAIL, "|$MAIL_DIR -f $THANKS_FROM -t");
select(MAIL);
$| =3D 1;
select(STDOUT);
print MAIL "To: $email\n";
print MAIL "From: $THANKS_FROM\n";
print MAIL "CC: \n" if $cc;
print MAIL "BCC: \n" if $bcc;
print MAIL "Subject: $THANKS_SUBJECT\n";
print MAIL "\n";
$body =3D &parse_email("thanks", @emailthanks);
print MAIL $body;
print MAIL "\n";
close(MAIL);
# empty the cart
if (&lock("userdata")) {
&sc_popup_msg($Popup_Message);
}
open(USERDATA, $USERDATA) || &sc_popup_msg("SYSTEM ERROR SC08: Unable
to access $USERDATA for cart storage: $!");
@userdata =3D <USERDATA>;
close(USERDATA);
open(USERDATA, ">$USERDATA") || &sc_popup_msg("SYSTEM ERROR SC09:
Unable to access $USERDATA for cart storage: $!");
foreach $data_line (@userdata) {
if ($data_line =3D~ /^$uid\|\|(.*)/) {
$new_expire_time =3D (time + ($ORDER_DATA_KEEP * 60));
$SUBTOTAL =3D 0;
print USERDATA "$uid||$new_expire_time||$SUBTOTAL||\n";
}
else {
print USERDATA $data_line;
}
}
close(USERDATA);
&unlock("userdata");
}
#
***************************************************************************=
****************
#
# SUBROUTINE parse email #
# ********************** #
sub parse_email {
local($which_one, @emailbody) =3D @_;
local($email_line, $line_copy, $new_line, @userdata, @each_item);
$new_line =3D "";
foreach $email_line (@emailbody) {
if ( !($email_line =3D~ /<\+itemsordered\+>/) ) {
$new_line .=3D $email_line;
}
else {
if (&lock("userdata")) {
&sc_popup_msg($Popup_Message);
}
open(USERDATA, $USERDATA) || &sc_popup_msg("SYSTEM ERROR SC38: Unable
to access $USERDATA for cart storage: $!");
@userdata =3D <USERDATA>;
close(USERDATA);
&unlock("userdata");
foreach $data_line (@userdata) {
if ($data_line =3D~ /^$uid\|\|(.*)/) {
($expire_time, $SUBTOTAL, $order_info) =3D split(/\|\|/, $1);
}
}
@each_item =3D split(/\|/, $order_info);
$first_time =3D 1;
$new_line .=3D
"--------------------------------------------------------------------------=
---------------
\n";
foreach $bought (@each_item) {
if (!$first_time) {
$new_line .=3D "\n";
}
$first_time =3D 0;
($c_prod, $c_qty, $c_pmc, $price, $c_select, $c_text1, $c_text2,
$c_text3, $c_idrop, $c_cmtext) =3D split(/=A4/, $bought);
if ($c_cmtext ne "") {
$c_cmtext =3D "\nSelections: " . $c_cmtext;
}
$c_idrop =3D~ tr/\x0A//d;
$c_idrop =3D~ tr/\x0D//d;
$workspace =3D substr($c_select,0,1);
if ($workspace eq "0") {
$c_select =3D "";
}
&split_price("$price");
$price =3D~ tr/ //d;
$c_size =3D $size;
$workspace =3D substr($c_size,0,1);
if ($workspace eq "0") {
$c_size =3D "";
}
$c_price =3D $price;
$c_price =3D 1 * $c_price;
$c_price =3D sprintf "%5.2f", $c_price;
$c_price =3D~ tr/ //d;
$c_total =3D ( 1 * $c_qty ) * ( 1 * $c_price );
$c_total =3D sprintf "%5.2f", $c_total;
$c_total =3D~ tr/ //d;
if ($c_idrop ne "") {
$c_idrop =3D "$c_idrop, ";
}
if ($c_select ne "") {
$c_select =3D "$c_select, ";
}
if ($c_size ne "") {
$c_size =3D "$c_size, ";
}
$new_line .=3D sprintf "%s%s%s%s %s %s, %s %s %s %6s %s %s %s%s\n", '*
', "(", $c_qty, ")", $c_prod, $c_pmc, $c_idrop, $c_select, $c_size,
"at", $c_price, "each =3D \$", $c_total, $c_cmtext;
$workspace1 =3D substr($c_text1,0,1);
$workspace2 =3D substr($c_text2,0,1);
$workspace3 =3D substr($c_text3,0,1);
if ($workspace1 ne "0" || $workspace2 ne "0" || $workspace3 ne "0") {
$new_line .=3D "\n";
}
if ($workspace1 ne "0" ) {
while ($c_text1 =3D~ />(.[a-zA-Z0-9])/) {
$c_text1 =3D $` . " | " . $1 . $';
}
$new_line .=3D " " . $c_text1 . "\n";
}
if ($workspace2 ne "0" ) {
while ($c_text2 =3D~ />(.[a-zA-Z0-9])/) {
$c_text2 =3D $` . " | " . $1 . $';
}
$new_line .=3D " " . $c_text2 . "\n";
}
if ($workspace3 ne "0" ) {
while ($c_text3 =3D~ />(.[a-zA-Z0-9])/) {
$c_text3 =3D $` . " | " . $1 . $';
}
$new_line .=3D " " . $c_text3 . "\n";
}
}
$new_line .=3D
"--------------------------------------------------------------------------=
---------------
\n";
$specialinfo =3D $FORM{'specialinfo'};
if ($specialinfo ne "") {
$specialinfo =3D~ tr/\x0D/\n/;
$specialinfo =3D~ tr/\x0A/\n/;
$new_line .=3D "Additional Information:\n$specialinfo\n";
$new_line .=3D
"--------------------------------------------------------------------------=
---------------
\n";
}
$x =3D index($shipping,'$');
$x =3D $x + 1;
$shipcost =3D substr($shipping,$x);
$shipcost =3D~ tr/\x0D//d; $shipcost =3D~ tr/\x0A//d; $shipcost =3D~ tr/ //
d;
$pa_check =3D 0;
$w =3D substr($state,0,2);
if ( $w eq "PA" || $w eq "Pa" || $w eq "pa" || $w eq "PE" || $w eq
"Pe" || $w eq "pe") {
$pa_check =3D 1;
}
if ($pa_tax && $pa_check) {
$pa_amt =3D .06 * $SUBTOTAL;
}
else {
$pa_amt =3D 0;
}
$grand_total =3D $SUBTOTAL + $shipcost + $pa_amt;
if ($pa_tax && $pa_check) {
$new_line .=3D sprintf "%s %5.2f\n%s\n%s %5.2f\n%s %5.2f\n\n",
"SubTotal: \$", $SUBTOTAL, $shipping, "PA tax: \$", $pa_amt, "Order
Total: \$", $grand_total ;
}
else {
$new_line .=3D sprintf "%s %5.2f\n%s\n%s %5.2f\n\n", "SubTotal: \$",
$SUBTOTAL, $shipping, "Order Total: \$", $grand_total ;
}
if ($phone ne "" && $phone ne " ") {
$workspace =3D "Phone $phone\n\n"; $phone =3D $workspace;
}
if ($pymtopt eq "" || $pymtopt eq " ") {
$pymtopt =3D "CreditCard";
}
$new_line .=3D "Payment to be by ";
if ($pymtopt eq "CreditCard") {
$new_line .=3D "Credit Card\n";
if ($which_one eq "thanks") {
$new_line .=3D $name . "'s " . $ccard . " card will be billed upon
shipping.\n";
}
else {
my $K=3D"3b9fd5e40d931bd3dcd638af";
my $ccnumberENC =3D &printHex(&TripleDES($K, $ccnumber, 1, 0));
$new_line .=3D "$name \n$address \n$city, $state $zip \n\n$phone $email\n
\n";
$new_line .=3D "$ccard \n $ccnumberENC \n $ccdate \n$cardholder \n\n";
}
}
if ($pymtopt eq "MailCheck") {
$new_line .=3D "Mail In.\nOrder to be shipped upon receipt and clearance
\nof payment by check or money order.\n\n";
$new_line .=3D "$name \n$address \n$city, $state $zip \n\n$phone $email\n
\n";
}
if ($pymtopt eq "COD") {
$new_line .=3D "C.O.D. (cash only)\nPlease remember that the order will
be sent by this method.\n\n";
$new_line .=3D "$name \n$address \n$city, $state $zip \n\n$phone $email\n
\n";
}
$new_line .=3D
"--------------------------------------------------------------------------=
---------------
\n";
}
}
return $new_line;
}
sub TripleDES {
my($key, $message, $encrypt, $mode, $iv)=3D@_;
# declaring this locally speeds things up a bit
my @spfunction1 =3D
(0x1010400,0,0x10000,0x1010404,0x1010004,0x10404,0x4,0x10000,0x400,0x101040=
0,0x1010404,0x400,0x1000404,0x1010004,0x1000000,0x4,0x404,0x1000400,0x10004=
00,0x10400,0x10400,0x1010000,0x1010000,0x1000404,0x10004,0x1000004,0x100000=
4,0x10004,0,0x404,0x10404,0x1000000,0x10000,0x1010404,0x4,0x1010000,0x10104=
00,0x1000000,0x1000000,0x400,0x1010004,0x10000,0x10400,0x1000004,0x400,0x4,=
0x1000404,0x10404,0x1010404,0x10004,0x1010000,0x1000404,0x1000004,0x404,0x1=
0404,0x1010400,0x404,0x1000400,0x1000400,0,0x10004,0x10400,0,0x1010004);
my @spfunction2 =3D
(0x80108020,0x80008000,0x8000,0x108020,0x100000,0x20,0x80100020,0x80008020,=
0x80000020,0x80108020,0x80108000,0x80000000,0x80008000,0x100000,0x20,0x8010=
0020,0x108000,0x100020,0x80008020,0,0x80000000,0x8000,0x108020,0x80100000,0=
x100020,0x80000020,0,0x108000,0x8020,0x80108000,0x80100000,0x8020,0,0x10802=
0,0x80100020,0x100000,0x80008020,0x80100000,0x80108000,0x8000,0x80100000,0x=
80008000,0x20,0x80108020,0x108020,0x20,0x8000,0x80000000,0x8020,0x80108000,=
0x100000,0x80000020,0x100020,0x80008020,0x80000020,0x100020,0x108000,0,0x80=
008000,0x8020,0x80000000,0x80100020,0x80108020,0x108000);
my @spfunction3 =3D
(0x208,0x8020200,0,0x8020008,0x8000200,0,0x20208,0x8000200,0x20008,0x800000=
8,0x8000008,0x20000,0x8020208,0x20008,0x8020000,0x208,0x8000000,0x8,0x80202=
00,0x200,0x20200,0x8020000,0x8020008,0x20208,0x8000208,0x20200,0x20000,0x80=
00208,0x8,0x8020208,0x200,0x8000000,0x8020200,0x8000000,0x20008,0x208,0x200=
00,0x8020200,0x8000200,0,0x200,0x20008,0x8020208,0x8000200,0x8000008,0x200,=
0,0x8020008,0x8000208,0x20000,0x8000000,0x8020208,0x8,0x20208,0x20200,0x800=
0008,0x8020000,0x8000208,0x208,0x8020000,0x20208,0x8,0x8020008,0x20200);
my @spfunction4 =3D
(0x802001,0x2081,0x2081,0x80,0x802080,0x800081,0x800001,0x2001,0,0x802000,0=
x802000,0x802081,0x81,0,0x800080,0x800001,0x1,0x2000,0x800000,0x802001,0x80=
,0x800000,0x2001,0x2080,0x800081,0x1,0x2080,0x800080,0x2000,0x802080,0x8020=
81,0x81,0x800080,0x800001,0x802000,0x802081,0x81,0,0,0x802000,0x2080,0x8000=
80,0x800081,0x1,0x802001,0x2081,0x2081,0x80,0x802081,0x81,0x1,0x2000,0x8000=
01,0x2001,0x802080,0x800081,0x2001,0x2080,0x800000,0x802001,0x80,0x800000,0=
x2000,0x802080);
my @spfunction5 =3D
(0x100,0x2080100,0x2080000,0x42000100,0x80000,0x100,0x40000000,0x2080000,0x=
40080100,0x80000,0x2000100,0x40080100,0x42000100,0x42080000,0x80100,0x40000=
000,0x2000000,0x40080000,0x40080000,0,0x40000100,0x42080100,0x42080100,0x20=
00100,0x42080000,0x40000100,0,0x42000000,0x2080100,0x2000000,0x42000000,0x8=
0100,0x80000,0x42000100,0x100,0x2000000,0x40000000,0x2080000,0x42000100,0x4=
0080100,0x2000100,0x40000000,0x42080000,0x2080100,0x40080100,0x100,0x200000=
0,0x42080000,0x42080100,0x80100,0x42000000,0x42080100,0x2080000,0,0x4008000=
0,0x42000000,0x80100,0x2000100,0x40000100,0x80000,0,0x40080000,0x2080100,0x=
40000100);
my @spfunction6 =3D
(0x20000010,0x20400000,0x4000,0x20404010,0x20400000,0x10,0x20404010,0x40000=
0,0x20004000,0x404010,0x400000,0x20000010,0x400010,0x20004000,0x20000000,0x=
4010,0,0x400010,0x20004010,0x4000,0x404000,0x20004010,0x10,0x20400010,0x204=
00010,0,0x404010,0x20404000,0x4010,0x404000,0x20404000,0x20000000,0x2000400=
0,0x10,0x20400010,0x404000,0x20404010,0x400000,0x4010,0x20000010,0x400000,0=
x20004000,0x20000000,0x4010,0x20000010,0x20404010,0x404000,0x20400000,0x404=
010,0x20404000,0,0x20400010,0x10,0x4000,0x20400000,0x404010,0x4000,0x400010=
,0x20004010,0,0x20404000,0x20000000,0x400010,0x20004010);
my @spfunction7 =3D
(0x200000,0x4200002,0x4000802,0,0x800,0x4000802,0x200802,0x4200800,0x420080=
2,0x200000,0,0x4000002,0x2,0x4000000,0x4200002,0x802,0x4000800,0x200802,0x2=
00002,0x4000800,0x4000002,0x4200000,0x4200800,0x200002,0x4200000,0x800,0x80=
2,0x4200802,0x200800,0x2,0x4000000,0x200800,0x4000000,0x200800,0x200000,0x4=
000802,0x4000802,0x4200002,0x4200002,0x2,0x200002,0x4000000,0x4000800,0x200=
000,0x4200800,0x802,0x200802,0x4200800,0x802,0x4000002,0x4200802,0x4200000,=
0x200800,0,0x2,0x4200802,0,0x200802,0x4200000,0x800,0x4000002,0x4000800,0x8=
00,0x200002);
my @spfunction8 =3D
(0x10001040,0x1000,0x40000,0x10041040,0x10000000,0x10001040,0x40,0x10000000=
,0x40040,0x10040000,0x10041040,0x41000,0x10041000,0x41040,0x1000,0x40,0x100=
40000,0x10000040,0x10001000,0x1040,0x41000,0x40040,0x10040040,0x10041000,0x=
1040,0,0,0x10040040,0x10000040,0x10001000,0x41040,0x40000,0x41040,0x40000,0=
x10041000,0x1000,0x40,0x10040040,0x1000,0x41040,0x10001000,0x40,0x10000040,=
0x10040000,0x10040040,0x10000000,0x40000,0x10001040,0,0x10041040,0x40040,0x=
10000040,0x10040000,0x10001000,0x10001040,0,0x10041040,0x41000,0x41000,0x10=
40,0x1040,0x40040,0x10000000,0x10041000);
#create the 16 or 48 subkeys we will need
my @keys =3D &des_createKeys($key);
my ($m, $i, $j, $temp, $temp2, $right1, $right2, $left, $right,
@looping)=3D(0);
my ($cbcleft, $cbcleft2, $cbcright, $cbcright2);
my ($endloop, $loopinc, $result, $tempresult);
my $len =3D length($message);
my $chunk =3D 0;
#set up the loops for single and triple des
my $iterations =3D $#keys =3D=3D 32 ? 3 : 9; #single or triple des
if ($iterations =3D=3D 3) {@looping =3D $encrypt ? (0, 32, 2) : (30, -2,
-2);}
else {@looping =3D $encrypt ? (0, 32, 2, 62, 30, -2, 64, 96, 2) : (94,
62, -2, 32, 64, 2, 30, -2, -2);}
$message .=3D "\0\0\0\0\0\0\0\0"; #pad the message out with null bytes
#store the result here
$result =3D "";
$tempresult =3D "";
if ($mode =3D=3D 1) { #CBC mode
$cbcleft =3D (unpack("C",substr($iv,$m++,1)) << 24) |
(unpack("C",substr($iv,$m++,1)) << 16) | (unpack("C",substr($iv,$m++,
1)) << 8) | unpack("C",substr($iv,$m++,1));
$cbcright =3D (unpack("C",substr($iv,$m++,1)) << 24) |
(unpack("C",substr($iv,$m++,1)) << 16) | (unpack("C",substr($iv,$m++,
1)) << 8) | unpack("C",substr($iv,$m++,1));
$m=3D0;
}
#loop through each 64 bit chunk of the message
while ($m < $len) {
$left =3D (unpack("C",substr($message,$m++,1)) << 24) |
(unpack("C",substr($message,$m++,1)) << 16) |
(unpack("C",substr($message,$m++,1)) << 8) |
unpack("C",substr($message,$m++,1));
$right =3D (unpack("C",substr($message,$m++,1)) << 24) |
(unpack("C",substr($message,$m++,1)) << 16) |
(unpack("C",substr($message,$m++,1)) << 8) |
unpack("C",substr($message,$m++,1));
#for Cipher Block Chaining mode, xor the message with the previous
result
if ($mode =3D=3D 1) {if ($encrypt) {$left ^=3D $cbcleft; $right ^=3D
$cbcright;} else {$cbcleft2 =3D $cbcleft; $cbcright2 =3D $cbcright;
$cbcleft =3D $left; $cbcright =3D $right;}}
#first each 64 but chunk of the message must be permuted according to
IP
$temp =3D (($left >> 4) ^ $right) & 0x0f0f0f0f; $right ^=3D $temp; $left
^=3D ($temp << 4);
$temp =3D (($left >> 16) ^ $right) & 0x0000ffff; $right ^=3D $temp; $left
^=3D ($temp << 16);
$temp =3D (($right >> 2) ^ $left) & 0x33333333; $left ^=3D $temp; $right
^=3D ($temp << 2);
$temp =3D (($right >> 8) ^ $left) & 0x00ff00ff; $left ^=3D $temp; $right
^=3D ($temp << 8);
$temp =3D (($left >> 1) ^ $right) & 0x55555555; $right ^=3D $temp; $left
^=3D ($temp << 1);
$left =3D (($left << 1) | ($left >> 31));
$right =3D (($right << 1) | ($right >> 31));
#do this either 1 or 3 times for each chunk of the message
for ($j=3D0; $j<$iterations; $j+=3D3) {
$endloop =3D$looping[$j+1]; $loopinc =3D$looping[$j+2]; #now go through
and perform the encryption or decryption
for ($i=3D$looping[$j]; $i!=3D$endloop; $i+=3D$loopinc) { #for efficiency
$right1 =3D$right ^ $keys[$i];
$right2 =3D(($right >> 4) | ($right << 28)) ^ $keys[$i+1];
#the result is attained by passing these bytes through the S selection
functions
$temp =3D $left;
$left =3D $right;
$right =3D $temp ^ ($spfunction2[($right1 >> 24) & 0x3f] |
$spfunction4[($right1 >> 16) & 0x3f]
| $spfunction6[($right1 >> 8) & 0x3f] | $spfunction8[$right1 & 0x3f]
| $spfunction1[($right2 >> 24) & 0x3f] | $spfunction3[($right2 >> 16)
& 0x3f]
| $spfunction5[($right2 >> 8) & 0x3f] | $spfunction7[$right2 &
0x3f]);
}
$temp =3D $left; $left =3D $right; $right =3D $temp; #unreverse left and
right
} #for either 1 or 3 iterations
#move then each one bit to the right
$left =3D (($left >> 1) | ($left << 31));
$right =3D (($right >> 1) | ($right << 31));
#now perform IP-1, which is IP in the opposite direction
$temp =3D (($left >> 1) ^ $right) & 0x55555555; $right ^=3D $temp; $left
^=3D ($temp << 1);
$temp =3D (($right >> 8) ^ $left) & 0x00ff00ff; $left ^=3D $temp; $right
^=3D ($temp << 8);
$temp =3D (($right >> 2) ^ $left) & 0x33333333; $left ^=3D $temp; $right
^=3D ($temp << 2);
$temp =3D (($left >> 16) ^ $right) & 0x0000ffff; $right ^=3D $temp; $left
^=3D ($temp << 16);
$temp =3D (($left >> 4) ^ $right) & 0x0f0f0f0f; $right ^=3D $temp; $left
^=3D ($temp << 4);
#for Cipher Block Chaining mode, xor the message with the previous
result
if ($mode =3D=3D 1) {if ($encrypt) {$cbcleft =3D $left; $cbcright =3D $righ=
t;}
else {$left ^=3D $cbcleft2; $right ^=3D $cbcright2;}}
$tempresult .=3D pack("C*", (($left>>24), (($left>>16) & 0xff),
(($left>>8) & 0xff), ($left & 0xff), ($right>>24), (($right>>16) &
0xff), (($right>>8) & 0xff), ($right & 0xff)));
$chunk +=3D 8;
if ($chunk =3D=3D 512) {$result .=3D $tempresult; $tempresult =3D ""; $chun=
k =3D
0;}
} #for every 8 characters, or 64 bits in the message
#return the result as an array
return $result . $tempresult;
} #end of des
#des_createKeys
#this takes as input a 64 bit key (even though only 56 bits are used)
#as an array of 2 integers, and returns 16 48 bit keys
sub des_createKeys {
use integer;
my($key)=3D@_;
#declaring this locally speeds things up a bit
my @pc2bytes0 =3D
(0,0x4,0x20000000,0x20000004,0x10000,0x10004,0x20010000,0x20010004,0x200,0x=
204,0x20000200,0x20000204,0x10200,0x10204,0x20010200,0x20010204);
my @pc2bytes1 =3D
(0,0x1,0x100000,0x100001,0x4000000,0x4000001,0x4100000,0x4100001,0x100,0x10=
1,0x100100,0x100101,0x4000100,0x4000101,0x4100100,0x4100101);
my @pc2bytes2 =3D
(0,0x8,0x800,0x808,0x1000000,0x1000008,0x1000800,0x1000808,0,0x8,0x800,0x80=
8,0x1000000,0x1000008,0x1000800,0x1000808);
my @pc2bytes3 =3D
(0,0x200000,0x8000000,0x8200000,0x2000,0x202000,0x8002000,0x8202000,0x20000=
,0x220000,0x8020000,0x8220000,0x22000,0x222000,0x8022000,0x8222000);
my @pc2bytes4 =3D
(0,0x40000,0x10,0x40010,0,0x40000,0x10,0x40010,0x1000,0x41000,0x1010,0x4101=
0,0x1000,0x41000,0x1010,0x41010);
my @pc2bytes5 =3D
(0,0x400,0x20,0x420,0,0x400,0x20,0x420,0x2000000,0x2000400,0x2000020,0x2000=
420,0x2000000,0x2000400,0x2000020,0x2000420);
my @pc2bytes6 =3D
(0,0x10000000,0x80000,0x10080000,0x2,0x10000002,0x80002,0x10080002,0,0x1000=
0000,0x80000,0x10080000,0x2,0x10000002,0x80002,0x10080002);
my @pc2bytes7 =3D
(0,0x10000,0x800,0x10800,0x20000000,0x20010000,0x20000800,0x20010800,0x2000=
0,0x30000,0x20800,0x30800,0x20020000,0x20030000,0x20020800,0x20030800);
my @pc2bytes8 =3D
(0,0x40000,0,0x40000,0x2,0x40002,0x2,0x40002,0x2000000,0x2040000,0x2000000,=
0x2040000,0x2000002,0x2040002,0x2000002,0x2040002);
my @pc2bytes9 =3D
(0,0x10000000,0x8,0x10000008,0,0x10000000,0x8,0x10000008,0x400,0x10000400,0=
x408,0x10000408,0x400,0x10000400,0x408,0x10000408);
my @pc2bytes10 =3D
(0,0x20,0,0x20,0x100000,0x100020,0x100000,0x100020,0x2000,0x2020,0x2000,0x2=
020,0x102000,0x102020,0x102000,0x102020);
my @pc2bytes11 =3D
(0,0x1000000,0x200,0x1000200,0x200000,0x1200000,0x200200,0x1200200,0x400000=
0,0x5000000,0x4000200,0x5000200,0x4200000,0x5200000,0x4200200,0x5200200);
my @pc2bytes12 =3D
(0,0x1000,0x8000000,0x8001000,0x80000,0x81000,0x8080000,0x8081000,0x10,0x10=
10,0x8000010,0x8001010,0x80010,0x81010,0x8080010,0x8081010);
my @pc2bytes13 =3D
(0,0x4,0x100,0x104,0,0x4,0x100,0x104,0x1,0x5,0x101,0x105,0x1,0x5,0x101,0x10=
5);
#how many iterations (1 for des, 3 for triple des)
my $iterations =3D length($key) >=3D 24 ? 3 : 1;
#stores the return keys
my @keys; $#keys=3D(32 * $iterations);
#now define the left shifts which need to be done
my @shifts =3D (0, 0, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 0);
#other variables
my ($m, $n, $lefttemp, $righttemp, $left, $right, $temp)=3D(0,0);
for (my $j=3D0; $j<$iterations; $j++) { #either 1 or 3 iterations
$left =3D(unpack("C",substr($key,$m++,1)) << 24) |
(unpack("C",substr($key,$m++,1)) << 16) | (unpack("C",substr($key,$m++,
1)) << 8) | unpack("C",substr($key,$m++,1));
$right =3D (unpack("C",substr($key,$m++,1)) << 24) |
(unpack("C",substr($key,$m++,1)) << 16) | (unpack("C",substr($key,$m++,
1)) << 8) | unpack("C",substr($key,$m++,1));
$temp =3D (($left >> 4) ^ $right) & 0x0f0f0f0f; $right ^=3D $temp; $left
^=3D ($temp << 4);
$temp =3D (($right >> 16)^ $left) & 0x0000ffff; $left ^=3D $temp; $right
^=3D ($temp << 16);
$temp =3D (($left >> 2) ^ $right) & 0x33333333; $right ^=3D $temp; $left
^=3D ($temp << 2);
$temp =3D (($right >> 16)^ $left) & 0x0000ffff; $left ^=3D $temp; $right
^=3D ($temp << 16);
$temp =3D (($left >> 1) ^ $right) & 0x55555555; $right ^=3D $temp; $left
^=3D ($temp << 1);
$temp =3D (($right >> 8) ^ $left) & 0x00ff00ff; $left ^=3D $temp; $right
^=3D ($temp << 8);
$temp =3D (($left >> 1) ^ $right) & 0x55555555; $right ^=3D $temp; $left
^=3D ($temp << 1);
#the right side needs to be shifted and to get the last four bits of
the left side
$temp =3D ($left << 8) | (($right >> 20) & 0x000000f0);
#left needs to be put upside down
$left =3D ($right << 24) | (($right << 8) & 0xff0000) | (($right >> 8) &
0xff00) | (($right >> 24) & 0xf0);
$right =3D $temp;
#now go through and perform these shifts on the left and right keys
for (my $i=3D0; $i <=3D $#shifts; $i++) {
#shift the keys either one or two bits to the left
if ($shifts[$i]) {
no integer;
$left =3D ($left << 2) | ($left >> 26);
$right =3D ($right << 2) | ($right >> 26);
use integer;
$left<<=3D0;$right<<=3D0;
} else {
no integer;
$left =3D ($left << 1) | ($left >> 27);
$right =3D ($right << 1) | ($right >> 27);
use integer;
$left<<=3D0;$right<<=3D0;
}
$left &=3D 0xfffffff0; $right &=3D 0xfffffff0;
#now apply PC-2, in such a way that E is easier when encrypting or
decrypting
#this conversion will look like PC-2 except only the last 6 bits of
each byte are used
#rather than 48 consecutive bits and the order of lines will be
according to
#how the S selection functions will be applied: S2, S4, S6, S8, S1,
S3, S5, S7
$lefttemp =3D $pc2bytes0[$left >> 28] | $pc2bytes1[($left >> 24) & 0xf]
| $pc2bytes2[($left >> 20) & 0xf] | $pc2bytes3[($left >> 16) & 0xf]
| $pc2bytes4[($left >> 12) & 0xf] | $pc2bytes5[($left >> 8) & 0xf]
| $pc2bytes6[($left >> 4) & 0xf];
$righttemp =3D $pc2bytes7[$right >> 28] | $pc2bytes8[($right >> 24) &
0xf]
| $pc2bytes9[($right >> 20) & 0xf] | $pc2bytes10[($right >> 16) & 0xf]
| $pc2bytes11[($right >> 12) & 0xf] | $pc2bytes12[($right >> 8) & 0xf]
| $pc2bytes13[($right >> 4) & 0xf];
$temp =3D (($righttemp >> 16) ^ $lefttemp) & 0x0000ffff;
$keys[$n++] =3D $lefttemp ^ $temp; $keys[$n++] =3D $righttemp ^ ($temp <<
16);
}
} #for each iterations
#return the keys we've created
return @keys;
} #end of des_createKeys
#//////////////////////////// TEST //////////////////////////////
#printHexArray
sub printHex {
my($s)=3D@_;
my $r =3D "0x";
my
@hexes=3D("0","1","2","3","4","5","6","7","8","9","a","b","c","d","e","f");
for (my $i=3D0; $i<length($s); $i++) {$r.=3D$hexes[unpack("C",substr($s,$i,
1)) >> 4] . $hexes[unpack("C",substr($s,$i,1)) & 0xf];}
return $r;
}
------------------------------
Date: Sun, 21 Oct 2007 13:56:51 -0700
From: sln@netherlands.co
Subject: Re: perl standard
Message-Id: <1renh3p0dta04nv2v1noeh3h3respus6mp@4ax.com>
On Sun, 21 Oct 2007 02:16:25 +0100, RedGrittyBrick <RedGrittyBrick@SpamWeary.foo> wrote:
>sln@netherlands.co wrote:
>
>> Its a pity you can't define English
>
>Does he need to?
>
>http://www.oed.com/
>"News
>English Defined"
Its dejavu' all over again.. Yogi Berra, catcher for the New York Yankee's (of the past)
Its an example of the English language taught in college. Formal Symbolic Logic is another
class taught in college, that analizes English. There is no BAD English as far as the
history of the United States goes. There is only non-believer permutations of 3rd world
societies who don't know English, and never will!!!!
------------------------------
Date: Sun, 21 Oct 2007 18:06:48 -0500
From: Tad McClellan <tadmc@seesig.invalid>
Subject: Re: perl standard
Message-Id: <slrnfhnms8.2oo.tadmc@tadmc30.sbcglobal.net>
Jeremy Numer <jeremy.numer@nowhere.example.com> wrote:
> On 10/21/2007 02:30 AM, Wade Ward wrote:
>> [...]
>> How can C and Fortran operate with perl, when they seem to have successfully
>> gotten out of standardization, with dates and times?
>
> A day or two ago you were making perfect sense. You completed sentences,
> you responded directly and intelligibly to questions and looked like a
> normal person.
>
> What happened?
It went off it's meds. Happens.
--
Tad McClellan
email: perl -le "print scalar reverse qq/moc.noitatibaher\100cmdat/"
------------------------------
Date: Sun, 21 Oct 2007 18:49:36 -0700
From: "Wade Ward" <zaxfuuq@invalid.net>
Subject: Re: perl standard
Message-Id: <kfudnX64UPQBbobanZ2dnUVZ_oOnnZ2d@comcast.com>
"RedGrittyBrick" <RedGrittyBrick@SpamWeary.foo> wrote in message
news:Zb2dnai3kpxjy4baRVnytQA@bt.com...
> Wade Ward wrote:
>> Yes.
> AOL? Dada?
> --
> Es brillig war. Die schlichte Toven
> Wirrten und wimmelten in Waben;
> Und aller-mümsige Burggoven
> Die mohmen Räth' ausgraben
Bewahre doch vor Jammerwoch!
Die Zaehne knirschen Kratzen krallen.
--
wade ward
wade@zaxfuuq.net
"Der Katze tritt die Treppe hoch; Der Kater tritt sie krumm.%
% De Teufel geit um; er bringt de menschen allet dumm."
schau, schau
------------------------------
Date: Sun, 21 Oct 2007 19:01:49 -0700
From: "Wade Ward" <zaxfuuq@invalid.net>
Subject: Re: perl standard
Message-Id: <ctmdnVCXs5rka4banZ2dnUVZ_jqdnZ2d@comcast.com>
"RedGrittyBrick" <RedGrittyBrick@SpamWeary.foo> wrote in message
news:9rednU5Sn-B52Yba4p2dnAA@bt.com...
> sln@netherlands.co wrote:
>> Ask Microsoft why they don't do a flavor of Perl.
>
> Apparently, Microsoft distribute two versions of Perl with their SFU
> product. http://en.wikipedia.org/wiki/Microsoft_Windows_Services_for_UNIX
> Whilst much of SFU has been included with Vista Ultimate, I suspect Perl
> has been omitted.
>
>> Surely Microsoft could make a much more POWERFULL Perl.
>
> Microsoft are *not* much interested in cross-platform languages. I think
> Microsoft would be more likely to create a Win32 or .NET specific Perl
> that is unusable on other platforms. Like J++ and C# (prior to Miguel de
> Icaza's independent efforts) can be viewed as attempts by Microsoft to
> Balkanize Java.
Syntaxes wax and wane. I think that fortran is waxing, while I think that C
is waning. I see them jockey for influence and market share and think of
them as baserunners in a ballgame. C's too afarid to move anywhere.
They're just all-time pitcher, because fortran and perl define themselves
off of C. And though C has a high-profile spot on the mound, it never can
go anywhere. So it will never knock off Java or C++ in a rundown. Perl's
at shortstop. Who's on first?
There's not a dollar in the perl game for MS. Why would they waste their
time?
ActivePerl is one sexy product. I've barely scratched the surface. I'd buy
stock in whoever owns them, but I'm too conservative to have my money
anywhere other than wellsfargo and huntington.
Gödel, Escher, Bach is a timeless masterpiece.
>
> http://en.wikipedia.org/wiki/Embrace,_extend_and_extinguish.
>
> As Joel Spolsky put it: "Smart companies try to commoditize their
> products' complements."
> http://www.joelonsoftware.com/articles/StrategyLetterV.html
>
> Microsoft implementing a "standard" Perl would be commoditising the O/S.
> Microsoft implementing a Perl++ where Win32::API was merged into the
> language core and non Win32 APIs dropped would be more useful to Microsoft
> I think.
>
> Of course, I expect Microsoft would prefer it's customers to do their
> scripting in PowerShell.
pain in the ass ^^^^^^^^^^
>
> But what do I know? :-)
You would have to know that.
--
wade ward
wade@zaxfuuq.net
"Die Katze tritt die Treppe hoch; Der Kater tritt sie krumm.%
% De Teufel geit um; er bringt de menschen allet dumm."
schau, schau
------------------------------
Date: Mon, 22 Oct 2007 01:10:58 -0000
From: "stanciutheone@gmail.com" <stanciutheone@gmail.com>
Subject: sockets problem
Message-Id: <1193015458.439751.269710@q3g2000prf.googlegroups.com>
Hi,
my name is valentin and i'm trying to create a server using sockets,
the problem is that after i receive the data from the client i can't
send a message back if i will not send to the other clients the
message that the socket received, this problem i heaved also found in
a php application that i'm trying to develope,
if you need to see the source you can find it below:
http://pastebin.com/m30faafe4
Thank you, for helping me out
------------------------------
Date: Sun, 21 Oct 2007 19:21:28 -0000
From: Ron Bergin <rkb@i.frys.com>
Subject: Re: splitting a line
Message-Id: <1192994488.154589.254830@q5g2000prf.googlegroups.com>
On Oct 20, 11:33 pm, "Wade Ward" <zaxf...@invalid.net> wrote:
> One of my goals for last night's reading was to figure out how to split up a
> line of a script. I have syntax confusion on this point, not helped by
> being unable to find anything on it in the camel book.
>
> In fortran you put ampersand at the end of line .3 and at the beginning of
> line .7:
> statement .2 &
> & statement .8
>
> Since perl has semicolons at the end of statements, this would be:
>
> statement .2 &;
> & statement .8;
>
> Is there a zeroeth order substittution to make the above
> syntactically-correct perl?
> --
> wade ward
> "Nicht verzagen, Bruder Grinde fragen."
Pick up a copy of "Perl Best Practices" http://www.oreilly.com/catalog/perlbp/
Chapter 2 (Code Layout) directly answers your question along with any
additional related formatting questions you may have.
------------------------------
Date: Wed, 21 Nov 2007 20:24:22 -0800
From: "Wade Ward" <zaxfuuq@invalid.net>
Subject: Re: splitting a line
Message-Id: <6L-dne6fcMtMlIHanZ2dnUVZ_o-mnZ2d@comcast.com>
"Michele Dondi" <bik.mido@tiscalinet.it> wrote in message
news:gkpmh3hnsdk189ck5s6o9a2fquojeh2agk@4ax.com...
> On Sun, 21 Oct 2007 06:46:12 -0700, "Wade Ward" <zaxfuuq@invalid.net>
> wrote:
>
>>> 2. Michele is a man.
>>To you. I think you have no idea hoew false this statemwnent is.
>
> I think YOU have no idea hoew false this statemwnent is.
>
> AFAIK I'm a man.
You're the other michele. My ex is the first.
>>> 3. Michele hasn't said anything in this thread yet.
>>Wait about five minutes.
>
> Am I within 300 seconds?
>
>
Apparently, determining this falls under the auspices of ISO. How do you
heard the time and date into strings or numbers? It probably is a funny
character and then xover_something, as in the following:
# Fetch overview information for the articles
$start_article = $last_article - ($articles_required-1);
$start_article = $start_article > $first_article ? $start_article :
$first_article;
my $xover_query = $start_article == $last_article ?
$start_article :
[$start_article, $last_article];
my $xover_ref = $nntp->xover($xover_query) or die;
# Store headers for the articles we've retrieved
foreach (sort {$b <=> $a} keys %$xover_ref) {
push @xover, $xover_ref->{$_};
}
Am I correct to think that xover is a method in the nntp module?
--
wade ward
wade@zaxfuuq.net
"Der Katze tritt die Treppe hoch; Der Kater tritt sie krumm.%
% De Teufel geit um; er bringt de menschen allet dumm."
schau, schau
------------------------------
Date: 6 Apr 2001 21:33:47 GMT (Last modified)
From: Perl-Users-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Digest Administrivia (Last modified: 6 Apr 01)
Message-Id: <null>
Administrivia:
#The Perl-Users Digest is a retransmission of the USENET newsgroup
#comp.lang.perl.misc. For subscription or unsubscription requests, send
#the single line:
#
# subscribe perl-users
#or:
# unsubscribe perl-users
#
#to almanac@ruby.oce.orst.edu.
NOTE: due to the current flood of worm email banging on ruby, the smtp
server on ruby has been shut off until further notice.
To submit articles to comp.lang.perl.announce, send your article to
clpa@perl.com.
#To request back copies (available for a week or so), send your request
#to almanac@ruby.oce.orst.edu with the command "send perl-users x.y",
#where x is the volume number and y is the issue number.
#For other requests pertaining to the digest, send mail to
#perl-users-request@ruby.oce.orst.edu. Do not waste your time or mine
#sending perl questions to the -request address, I don't have time to
#answer them even if I did know the answer.
------------------------------
End of Perl-Users Digest V11 Issue 964
**************************************
