[19999] in Perl-Users-Digest
Perl-Users Digest, Issue: 2194 Volume: 10
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Sat Nov 24 03:10:32 2001
Date: Sat, 24 Nov 2001 00:10:11 -0800 (PST)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Message-Id: <1006589411-v10-i2194@ruby.oce.orst.edu>
Content-Type: text
Perl-Users Digest Sat, 24 Nov 2001 Volume: 10 Number: 2194
Today's topics:
Perl Programmer Needed to modify shopping cart (Gary)
Re: Problems with Mirror - ftp.pl doesn't get the right (Garry Williams)
Re: Traversing directories (Tad McClellan)
Re: Which ISPs support perl scripts? (George Jempty)
Re: Which ISPs support perl scripts? (Tad McClellan)
Digest Administrivia (Last modified: 6 Apr 01) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: 24 Nov 2001 00:01:46 -0800
From: healthrx@yahoo.com (Gary)
Subject: Perl Programmer Needed to modify shopping cart
Message-Id: <495321b5.0111240001.e27a47f@posting.google.com>
Please review the folling perl program and provide an estimate for
your services by sending me an e-mail at healthrx@yahoo.com . The
program needs to be modified to enable a database search for any given
string. Let me know if you need anything for testing purposes.
Thanks!
Gary
http://www.healthfooddepot.com/
===============================================================================
Here is the database structure in a text file:
itemid|name|price|descrip|image|weight|itemurl|group
Actual items in database (6 out of 13,000):
073970102067|DR BROWNS (Item 490599)|21.44|SODA ROOT BEER 6PK 12 OZ
BOX OF 4|images/t.jpg|20.0||Grocery|
018787761656|DR. BRONNERS SOAPS (Item 41384)|22.99|SOAP ALMOND 128oz =
1 gallon|images/bronner.gif|9.9||Beauty|
018787761168|DR. BRONNERS SOAPS (Item 41343)|4.11|SOAP PEPPERMINT 16
OZ|images/bronner.gif|1.5||Beauty|
018787761045|DR. BRONNERS SOAPS (Item 41327)|1.49|SOAP LAVENDER 4
OZ|images/bronner.gif|0.6||Beauty|
032602011504|EARTHRISE (Item 95406)|8.37|CHLORELLA 300GM 150
TB|images/t.jpg|0.7||Vitamins|
032602251481|EARTHRISE (Item 372110)|23.17|ORGANIC SPIRULINA 500GM 360
TB|images/t.jpg|0.7||Vitamins|
Right now I can do a URL search for any group name and it will list
all the items in that group (example Vitamins) as follows:
http://www.healthfooddepot.com/cgi-bin/redicart/smart.cgi?command=listitems&pos=0&type=group&group=Vitamins
this will return:
EARTHRISE (Item 95406) $ 8.37
CHLORELLA 300GM 150 TB
EARTHRISE (Item 372110) $ 23.17
ORGANIC SPIRULINA 500GM 360 TB
I can also list all items in the database starting at any given point
(example show list starting at record 2355):
http://www.healthfooddepot.com/cgi-bin/redicart/smart.cgi?command=listitems&pos=2355&type=search
this will return:
DR. BRONNERS SOAPS (Item 41384) $ 22.99
SOAP ALMOND 128oz = 1 gallon
DR. BRONNERS SOAPS (Item 41343) $ 4.11
SOAP PEPPERMINT 16 OZ
What I want is to list the items based on any search query (example
peppermint) and the URL should look something like this:
http://www.healthfooddepot.com/cgi-bin/redicart/smart.cgi?command=listitems&pos=0&type=search&search=peppermint
and it should return all items with peppermint:
AURA CACIA (Item 697326) $ 5.83
ESSENTIAL OIL PEPPERMINT 0.5 OZ
AURA CACIA (Item 226183) $ 19.21
ESSENTIAL OIL PEPPERMINT 2 OZ
I can do this through the search box at our website, but I want a URL.
The search should look in all fields of data, not just the item
name...it should look in
itemid|name|price|descrip|image|weight|itemurl|group and should not be
case sensitive.
Here is the perl program:
#!/usr/bin/perl
# ^^ The line above needs to point to the Perl intrepreter on your
system.
# Ask your sys admin for the correct path, or type 'which perl' at the
unix
# prompt. You need Perl 5 or higher. type 'perl -v' to get your
version.
############################################################################
##################
# RediCart v3.9.5
##################
###############################################################################
# THIS SCRIPT IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
# EXPRESS OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES
# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
NON-INFRINGEMENT.
#
# THE PROVIDERS OF THIS SOFTWARE ASSUME NO RESPONSIBILITY FOR ANY
DAMAGES
# SUFFERED AS A RESULT OF USING, MODIFYING OR DISTRIBUTING THIS
SOFTWARE. IN NO
# EVENT WILL ANY PROVIDERS OF THIS SOFTWARE BE LIABLE FOR ANY LOST
REVENUE, PROFIT
# OR DATA, OR FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL
OR PUNITIVE
# DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
# ARISING OUT OF THE USE OF OR INABILITY TO USE SOFTWARE, EVEN IF THE
# PROVIDERS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
##############################################################################
############################################################################
# AUTHOR INFORMATION
############################################################################
# S-Mart Shopping Cart Script v1.9
# Shop smart. Shop S-Mart.
# Written by Barry Robison. (brobison@rcinet.com)
# This script uses code written by Matt Wright.
# Please visit his site at http://worldwidemart.com
# Selling the code for this program without prior written consent of
the
# author(s) is expressly forbidden. Obtain permission before
# redistributing this software over the Internet or in any other
medium.
# In all cases copyright and header must remain intact.
#
# All customization requests to be sent to brobinson@rcinet.com.
############################################################################
############################################################################
# MAKE NO CHANGES BELOW THIS LINE.
############################################################################
$ENV{'REMOTE_HOST'} = $ENV{'REMOTE_ADDR'};
# Measure CPU time usage;
$start = (times)[0];
# Get rid of NULL;
$zero - '0';
require 'smart.cfg';
use vars qw($tmpdir $storename %shipping2 %shipping3 $trackurl
$useverify $usertime $orderdir $usercurr $trackdb);
my($incoming, @pairs, %FORM);
$incoming = $ENV{'QUERY_STRING'};
@pairs = split(/&/, $incoming);
foreach $pair (@pairs) {
my($name, $value) = split(/=/, $pair);
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$FORM{$name} = $value;
}
# Get command variables
$command = $FORM{'command'};
$pos = $FORM{'pos'};
$type = $FORM{'type'};
$cmdlinegroup = $FORM{'group'};
# Parse form input
&parse_form;
# Get the date
&get_date;
# Get their hostname
#if ($usecookie eq '1') {
#require 'cookie.lib';
#&get_cookie;
#}
#else {
&get_host;
#}
# See if they have a cart already, if not, make one
&check_file;
# See what they want to do.
# Add an item to the cart.
if ($command eq 'add') {
&add_item;
}
# Change a quantity of an item in the cart, if at zero, delete it
elsif ($command eq 'change') {
&change_items;
}
# Show the order form. Get their name, phone number, CC info, etc..
elsif ($command eq 'buy1') {
&buy_items1;
}
# Process the order form info, mail out receipt, and order
elsif ($command eq 'buy2') {
&buy_items1;
}
# Show current cart
elsif ($command eq 'review') {
&review_items;
}
# List items, based on database call
elsif ($command eq 'listitems') {
&gen_page;
}
# Show a databae frontend.
elsif ($command eq 'showstore') {
&show_store;
}
# Delete a whole cart
elsif ($command eq 'delete') {
&delete_cart;
}
# Calculate shipping
elsif ($command eq 'calcship') {
&calc_shipping;
}
elsif ($command eq 'setship') {
&set_shipping;
}
elsif ($command eq 'removetax') {
&remove_tax;
}
elsif ($command eq 'addtax') {
&add_tax;
}
elsif ($command eq 'removetax2') {
&remove_tax2;
}
elsif ($command eq 'addtax2') {
&add_tax2;
}
elsif ($command eq 'retaddr') {
&ret_addr;
}
elsif ($command eq 'calccurr') {
&calc_currency;
}
elsif ($command eq 'setcurr') {
&set_currency;
}
else { &show_store; }
###########################################################################
# Subroutines:
###########################################################################
# Generate page, based on database search
sub gen_page {
my($SIZE,$max,$i,$itemid,$name,$price,$descrip,$image,$weight,$itemurl,$group);
&print_header;
# Table header, change this for table options!
print "<center><table cellpadding=5 border=1>\n";
print "<tr>\n";
open (FILE,"$resourcedb") || die "Content-type: text/html\n\nCan't
Open $resourcedb(r): $!\n";
my(@LINES)=<FILE>;
close(FILE);
$SIZE=@LINES;
if ($type eq 'all') {
$max = $pos + $numtolist;
if ($max > $SIZE) {
$max = $SIZE;
}
for ($i=$pos;$i<$max;$i++) {
$_=$LINES[$i];
($itemid, $name, $price, $descrip, $image, $weight, $itemurl,
$group) = split(/\|/,$_);
&print_item;
}
print "</table>\n";
if ($max < $SIZE) {
print "<center><a href=\"$cgiurl\?command=listitems\&pos=$max&type=all\">Next
$numtolist items</a></center>\n";
}
}
if ($type eq 'search') {
my($matches) = 0;
my($i) = $pos;
while (($matches < $numtolist) && ($i < $SIZE)) {
$_=$LINES[$i];
if (m/$FORM{'search'}/i) {
$matches++;
($itemid, $name, $price, $descrip, $image, $weight, $itemurl,
$group) = split(/\|/,$_);
&print_item;
}
$i++;
}
print "</table>\n";
if ($i < $SIZE) {
print "<form method=post
action=\"$cgiurl\?command=listitems\&pos=$i\&type=search\">\n";
print "<input type=hidden name=itemid value=\"$itemid\">\n";
print "<input type=hidden name=search value=\"$FORM{'search'}\">\n";
print "<center><input type=submit value=\"Continue
Search\"></form>\n";
}
}
if ($type eq 'group') {
# generate 'a' .. 'z' listing
#print "<CENTER><FONT SIZE=4>Click On A Letter To View The Titles
That Start With That Letter.</FONT></CENTER><CENTER>";
#foreach $i ('a' .. 'z') {
#print "<a href=\"/cgi-bin/redicart/smart.cgi\?command=listitems\&pos=0\&type=group\&group=",
substr($cmdlinegroup,0,2), $i, "\">", uc $i, "</a>";
#&myTabs(6);
#}
#print "</CENTER><br>";
my($matches) = 0;
my($i) = $pos;
while (($matches < $numtolist) && ($i < $SIZE)) {
$_=$LINES[$i];
($itemid, $name, $price, $descrip, $image, $weight, $itemurl,
$group) = split(/\|/,$_);
if ($group eq $FORM{'group'} || $group eq $cmdlinegroup) {
$matches++;
&print_item;
}
$i++;
}
print "</table>\n";
if ($i < $SIZE) {
if ($cmdlinegroup) {
print "<a href=\"$cgiurl\?command=listitems\&pos=$i\&type=group\&group=$cmdlinegroup\">Continue
Search</a>\n";
}
else {
print "<a href=\"$cgiurl\?command=listitems\&pos=$i\&type=group\&group=$FORM{'group'}\">Continue
Search</a>\n";
}
}
}
&print_footer;
sub print_item {
print "<form method=post action=\"$cgiurl\?command=add\">\n";
# Hide the weight for later use
print "<input type=hidden name=weight value=\"$weight\">\n";
print "<input type=hidden name=itemid value=\"$itemid\">\n";
# If you want to redirect, keep this in!
if ($useredirect eq '1') {
print "<input type=hidden name=redirect value=\"referrer\">\n";
}
# For showing product images
if ($image) {
print "<td rowspan=2><img src=\"$imageurl/$image\"></td>\n";
}
else {
print "<td rowspan=2></td>\n";
}
# If the item has a URL, make it a link
if ($itemurl) {
print "<td><a href=\"$itemurl\">$name</a><input type=hidden
name=itemname value=\"$name\"></td>\n";
}
else {
print "<td>$name<input type=hidden name=itemname
value=\"$name\"></td>\n";
}
# Print other info
#Price
print "<td>\$ $price<input type=hidden name=itemprice
value=\"$price\"></td>\n";
#Quantity
print "<td><input type=text size=2 name=itemquant value=1></td>\n";
#Add button
print "<td rowspan=2><input type=submit value=\"Buy Me!\"></td>\n";
#Description
print "</tr><tr><td colspan=3>$descrip</td>\n";
# Close
print "</form></tr><tr>\n";
}
## END print_item
}
## END gen_page
# Show front end of database store.
sub show_store {
&print_header;
print "<center>\n";
print "<table width=80%><td>\n";
print "<a href=\"$cgiurl\?command=listitems\&type=all\&pos=0\">List
all items available</a><br>\n
<Br>\n
<table>
<td>Search for a particular item(s):</td>
<td>
<form method=post action=\"$cgiurl\?command=listitems\&pos=0\&type=search\">
<input type=text name=search size=30></td>
<td><input type=submit value=Search></form></tD>
</table>\n";
print "<table>
<td>List all:</td>
<td>
<form method=post action=\"$cgiurl/smart/smart.cgi\?command=listitems\&pos=0\&type=group\">
<select name=group><option selected>Select a Group</option>\n";
foreach $group (keys %groups){
print "<OPTION value=\"$group\"> $groups{$group} </option>\n";
}
print "</select></td><td>\n";
print "<center><input type=submit
value=\"List\"</form></td>\n</table>\n<br>";
if ($usetrack eq 1) {
print "<br><a href=\"$trackurl\">Track an Order</a><br>\n";
}
print "</td></table>\n";
&print_footer;
}
## END show_store
# Print the HTML header
sub print_header {
print "Content-type: text/html\n\n";
open (HEADER,"$basepath/$header") || print "Could not open
$basepath/$header $! \n";
while (<HEADER>) {
print $_;
}
close(HEADER);
}
#Print the HTML footer
sub print_footer {
open (FOOTER,"$basepath/$footer") || print "Could not open
$basepath/$footer $! \n";
while (<FOOTER>) {
print $_;
}
close(FOOTER);
}
## END print_footer
# List items in cart.
sub list_items {
my($totalprice,$totalquant,$totalweight) = 0;
open (REFFILE,"$reffile") || die "Content-type: text/html\n\nCan't
Open $reffile(r): $!\n";
my(@LINES)=<REFFILE>;
close(REFFILE);
$SIZE=@LINES;
$rcitem=1;
print "<form name=select1 method=POST
action=\"$cgiurl?command=change\">\n";
##### INCLUDE REQUIRED MERCHANT TAGS #####
print "<INPUT type='hidden' name='vendor_id' value='$mid'>\n";
print "<INPUT type='hidden' name='home_page' value='$hp'>\n";
print "<INPUT type='hidden' name='ret_addr' value='$retaddr'>\n";
print "<INPUT type='hidden' name='email_text' value='$etext'>\n";
print "<INPUT type='hidden' name='lookup' value='first_name'>\n";
print "<INPUT type='hidden' name='lookup' value='last_name'>\n";
print "<INPUT type='hidden' name='lookup' value='address'>\n";
print "<INPUT type='hidden' name='lookup' value='city'>\n";
print "<INPUT type='hidden' name='lookup' value='state'>\n";
print "<INPUT type='hidden' name='lookup' value='zip'>\n";
print "<INPUT type='hidden' name='lookup' value='ctry'>\n";
print "<INPUT type='hidden' name='lookup' value='phone'>\n";
print "<INPUT type='hidden' name='lookup' value='email'>\n";
#print "<INPUT type='hidden' name='passback' value='good'>\n";
#print "<INPUT type='hidden' name='good' value='1'>\n";
##### INCLUDE SPLIT-FORM TAGS IF REQUIRED #####
if ($split eq '1') {
print "\n<INPUT type='hidden' name='mername' value='$mname'>\n";
print "<INPUT type='hidden' name='mertext' value='$mtext'>\n";
print "<INPUT type='hidden' name='acceptchecks' value='$checks'>\n";
print "<INPUT type='hidden' name='allowreg' value='$creg'>\n";
print "<INPUT type='hidden' name='checkguar' value='$cguar'>\n";
print "<INPUT type='hidden' name='acceptcards' value='$cards'>\n";
print "<INPUT type='hidden' name='altaddr' value='$creg'>\n";
}
print "\n";
print "<table border=1 cellpadding=5><tr>\n";
if ($useimage eq '1') {
print "<th></th>";
}
if ($useid eq '1') {
print "<th><font size=-1 color=blue>ITEM ID</font></th>";
}
print "<TR BGCOLOR='#000000'><TH COLSPAN=5 ALIGN=center><FONT SIZE=3
COLOR=white> <B>$mname</B> </FONT></TH></TR>
<th><font size=-1 color=blue>ITEM NAME</FONT></th><th><font size=-1
color=blue>QUANTITY</font></th><th><font size=-1
color=blue>PRICE</font></th><th><font size=-1
color=blue>AMOUNT</font></th></tr>";
for ($i=1;$i<$SIZE;$i++) {
$_=$LINES[$i];
($itemname, $itemprice, $itemquant, $weight, $itemid) =
split(/\|/,$_);
$tmpprice = ($itemprice*$itemquant);
$tmpprice = int($tmpprice * (10 ** 2) + .5) / (10 ** 2);
$totalprice += $tmpprice;
$totalquant += $itemquant;
$totalweight = ($weight*$itemquant) + $totalweight;
print "<tr>";
if ($useimage eq '1') {
if ($FORM{'image'}) {
print "<td><img src=\"$imageurl/$FORM{'image'}\"></td>\n";
}
else {
print "<td></td>";
}
}
if ($useid eq '1') {
print "<td>$itemid <input type=hidden name=itemid
value=\"$itemid\"></td>\n";
}
$tmpprice = &format_price($tmpprice);
#$_ = $tmpprice;
#if (/\./) {
# my($left,$right) = split(/\./,$tmpprice);
# if (length($right) == 0) {
# $tmpprice = $tmpprice . "00";
# }
# elsif (length($right) == 1) { $tmpprice = $tmpprice . "0"; }
# }
# else { $tmpprice = $tmpprice . ".00"; }
#print "<td>$itemname</td><td align=right>\$ $itemprice</td><td
align=center><input type=number size=2 value=\"$itemquant\"
name=item$i></td><td align=right>\$ $tmpprice</tr>\n";
print "<td>$itemname</td><td align=center><input type=number size=2
value=\"$itemquant\" name=item$i></td><td align=right>\$
$itemprice</td><td align=right>\$ $tmpprice</tr>\n";
########## INCLUDE REQUIRED FIELD NAMES ###########
print "<input type=hidden name='$rcitem-desc' value='$itemname'>\n";
print "<input type=hidden name='$rcitem-qty' value='$itemquant'>\n";
print "<input type=hidden name='$rcitem-cost'
value='$itemprice'>\n\n";
$rcitem=$rcitem+1;
}
print "<tr><td><b>Subtotal:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$totalprice = &format_price($totalprice);
#$_ = $totalprice;
#if (/\./) {
# my($left,$right) = split(/\./,$totalprice);
# if (length($right) == 0) {
# $totalprice = $totalprice . "00";
# }
# elsif (length($right) == 1) { $totalprice = $totalprice . "0"; }
# }
# else { $totalprice = $totalprice . ".00"; }
print "<td></td><td></td><td align=right><b>\$
$totalprice</b></td></tr>\n";
if ($tax eq '2') {
$temptax=$tax }
if ($temptax <=> '0') {
if ($tax eq '0') {
# print nothing
}
elsif ($tax eq '1') {
$taxtotal = $totalprice * $taxper;
$taxtotal = int($taxtotal * (10 ** 2) + .5) / (10 ** 2);
$totalprice = $totalprice + $taxtotal;
print "<tr><td><b>Taxes:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$taxtotal = &format_price($taxtotal);
#$_ = $taxtotal;
#if (/\./) {
# my($left,$right) = split(/\./,$taxtotal);
# if (length($right) == 0) {
# $taxtotal = $taxtotal . "00";
# }
# elsif (length($right) == 1) { $taxtotal = $taxtotal . "0"; }
# }
# else { $taxtotal = $taxtotal . ".00"; }
print "<td></td><td></td><td align=right><b>\$
$taxtotal</center></b></td></tr>\n";
##### INCLUDE TAX TAG #####
print "<input type=hidden name='$rcitem-desc' value='Tax'>\n";
print "<input type=hidden name='$rcitem-qty' value='1'>\n";
print "<input type=hidden name='$rcitem-cost' value='$taxtotal'>\n\n";
}
elsif ($tax eq '2') {
$taxtotal = $totalprice * $taxamt;
$taxtotal = int($taxtotal * (10 ** 2) + .5) / (10 ** 2);
$totalprice = $totalprice + $taxtotal;
print "<tr><td><b>Taxes:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$taxtotal = &format_price($taxtotal);
#$_ = $taxtotal;
#$rcitem=$rcitem+1;
#if (/\./) {
# my($left,$right) = split(/\./,$taxtotal);
# if (length($right) == 0) {
# $taxtotal = $taxtotal . "00";
# }
# elsif (length($right) == 1) { $taxtotal = $taxtotal . "0"; }
# }
# else { $taxtotal = $taxtotal . ".00"; }
print "<td></td><td></td><td align=right><b>\$
$taxtotal</center></b></td></tr>\n";
##### INCLUDE TAX TAG #####
print "<input type=hidden name='$rcitem-desc' value='Tax'>\n";
print "<input type=hidden name='$rcitem-qty' value='1'>\n";
print "<input type=hidden name='$rcitem-cost' value='$taxtotal'>\n\n";
}
}
if ($multiship eq 1) {
print "<tr><td><b>Shipping/Handling:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
print "<td></td><td></td><td align=right>";
if ($usership eq 'NULL') {
print "<a href=\"$cgiurl\?command=calcship\">Calculate<br>Shipping</a>";
}
else {
print "<b>\$ $usership</b>";
$totalprice += $usership;
}
print "</td></tr>\n";
}
else {
if ($shipping eq '0') {
# print nothing
}
elsif ($shipping eq '1') {
local($low,@prices,$price);
@prices = sort number keys %shipping;
$low = $prices[0];
foreach $price (@prices) {
if (($price > $low) && ($price <= $totalquant)) {$low = $price};
}
$shipamt = $shipping{$low};
$totalprice += $shipamt;
print "<tr><td><b>Shipping/Handling:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$shipamt = &format_price($shipamt);
#$_ = $shipamt;
#if (/\./) {
# my($left,$right) = split(/\./,$shipamt);
# if (length($right) == 0) {
# $shipamt = $shipamt . "00";
# }
# elsif (length($right) == 1) { $shipamt = $shipamt . "0"; }
# }
# else { $shipamt = $shipamt . ".00"; }
print "<td></td><td></td><td align=right><b>\$
$shipamt</b></td></tr>\n";
##### INCLUDE SHIPPING TAG (BY NUMBER OF ITEMS ORDERED.) #####
print "<input type=hidden name='$rcitem-desc' value='Shipping'>\n";
print "<input type=hidden name='$rcitem-qty' value='1'>\n";
print "<input type=hidden name='$rcitem-cost' value='$shipamt'>\n\n";
}
elsif ($shipping eq '2') {
$totalprice += $shipamt;
print "<tr><td><b>Shipping/Handling:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$shipamt = &format_price($shipamt);
#$_ = $shipamt;
#if (/\./) {
# my($left,$right) = split(/\./,$shipamt);
# if (length($right) == 0) {
# $shipamt = $shipamt . "00";
# }
# elsif (length($right) == 1) { $shipamt = $shipamt . "0"; }
# }
# else { $shipamt = $shipamt . ".00"; }
# print "<td></td><td></td><td align=right><b>\$
$shipamt</b></td></tr>\n";
##### INCLUDE SHIPPING TAG (NON-VARIABLE) #####
print "<input type=hidden name='$rcitem-desc' value='Shipping'>\n";
print "<input type=hidden name='$rcitem-qty' value='1'>\n";
print "<input type=hidden name='$rcitem-cost' value='$shipamt'>\n\n";
}
elsif ($shipping eq '3') {
my($low,@weights,$weight);
@weights = sort number keys %shipping;
$low = $weights[0];
foreach $weight (@weights) {
if ($weight > $low && $weight <= $totalweight) {$low =
$weight};
}
$shipamt = $shipping{$low};
$totalprice += $shipamt;
print "<tr><td><b>Shipping/Handling:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$shipamt = &format_price($shipamt);
#$_ = $shipamt;
#if (/\./) {
# my($left,$right) = split(/\./,$shipamt);
# if (length($right) == 0) {
# $shipamt = $shipamt . "00";
# }
# elsif (length($right) == 1) { $shipamt = $shipamt . "0"; }
# }
# else { $shipamt = $shipamt . ".00"; }
print "<td align=center>";
if ($totalquant > '0') { print "<B>$totalweight lbs.</B>"; }
print "</td><td></td><td align=right><b>\$ $shipamt</b></td></tr>\n";
# print "<td align=center><B>$totalweight lbs.</B></td><td></td><td
align=right><b>\$ $shipamt</b></td></tr>\n";
##### INCLUDE SHIPPING TAG (BY WEIGHT) #####
print "<input type=hidden name='$rcitem-desc' value='Shipping'>\n";
print "<input type=hidden name='$rcitem-qty' value='1'>\n";
print "<input type=hidden name='$rcitem-cost' value='$shipamt'>\n\n";
}
elsif ($shipping eq '4') {
my($low,@prices);
@prices = sort number keys %shipping;
$low = $prices[0];
foreach $price (@prices) {
if ($price > $low && $price <= $totalprice) {$low = $price};
}
$shipamt = $shipping{$low};
$totalprice += $shipamt;
print "<tr><td><b>Shipping/Handling:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$shipamt = &format_price($shipamt);
#$_ = $shipamt;
#if (/\./) {
# my($left,$right) = split(/\./,$shipamt);
# if (length($right) == 0) {
# $shipamt = $shipamt . "00";
# }
# elsif (length($right) == 1) { $shipamt = $shipamt . "0"; }
# }
# else { $shipamt = $shipamt . ".00"; }
print "<td></td><td></td><td align=right><b>\$
$shipamt</b></td></tr>\n";
##### INCLUDE SHIPPING TAG (BY TOTAL) #####
print "\n<input type=hidden name='$rcitem-desc' value='Shipping'>\n";
print "<input type=hidden name='$rcitem-qty' value='1'>\n";
print "<input type=hidden name='$rcitem-cost' value='$usership'>\n\n";
}
}
$totalprice = int($totalprice * (10 ** 2) + .5) / (10 ** 2);
$totalprice = &format_price($totalprice);
#$_ = $totalprice;
#if (/\./) {
# my($left,$right) = split(/\./,$totalprice);
# if (length($right) == 0) {
# $totalprice = $totalprice . "00";
# }
# elsif (length($right) == 1) { $totalprice = $totalprice . "0"; }
# }
# else { $totalprice = $totalprice . ".00"; }
print "<tr><td><b>Total price:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
print "<td></td><td></td><td align=right><b>\$
$totalprice</b></td></tr>\n";
if ($multicurr eq 1) {
$totalprice *= $usercurr;
$totalprice = int($totalprice * (10 ** 2) + .5) / (10 ** 2);
$totalprice = &format_price($totalprice);
# $_ = $totalprice;
# if (/\./) {
# my($left,$right) = split(/\./,$totalprice);
# if (length($right) == 0) {
# $totalprice = $totalprice . "00";
# }
# elsif (length($right) == 1) { $totalprice = $totalprice . "0"; }
# }
# else { $totalprice = $totalprice . ".00"; }
print "<tr><td><b>Total price in selected currency:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
print "<td colspan=2>Exchange Rate: $usercurr</td><td
align=right><b>\$ $totalprice</b></td></tr>\n";
}
print "</table><br>\n";
}
# Review all items in cart. Can modify quantities.
sub review_items {
if ( ($multicurr eq 1) && ($usercurr eq 'NULL') ) { print "Location:
$cgiurl\?command=calccurr \n\n"; }
&print_header;
&list_items;
print "<center><input type=submit value=\"Re-Calculate\"></form>\n";
&print_footer;
}
# Add a item to the cart, show review page, unless they included a
redirect variable.
sub add_item {
open (REFFILE,"$reffile") || print "Content-type: text/html\n\n Can't
Open $reffile(r): $!\n";
@LINES=<REFFILE>;
close(REFFILE);
$SIZE=@LINES;
open (REFFILE,">$reffile") || print "Content-type: text/html\n\n Can't
Open $reffile(r): $!\n";
print REFFILE "$date\| $ENV{'REMOTE_HOST'}\|
$ENV{'HTTP_USER_AGENT'}\|$usercurr\|NULL\|\n";
for ($i=1;$i<$SIZE;$i++) {
$_=$LINES[$i];
my($itemname, $itemprice, $itemquant, $weight, $itemid) =
split(/\|/,$_);
print REFFILE join "\|",
$itemname,$itemprice,$itemquant,$weight,$itemid,"\|\n";
}
print REFFILE join "\|",
$FORM{'itemname'},$FORM{'itemprice'},$FORM{'itemquant'},$FORM{'weight'},$FORM{'itemid'};
print REFFILE "\|\n";
close(REFFILE);
if ($useredirect eq '1') {
print "Content-type: text/html\n\n <html><body bgcolor=\#ffffff
onload=\"history.back()\">Item added.<br>If your browser does not
support Javascript, please press BACK now.\n";
}
if ($FORM{'redirect'}) {
print "Location: $FORM{'redirect'} \n\n";
}
else {
&review_items;
}
}
# Change quanities of items, delete zero quantity items.
sub change_items {
open (REFFILE,"$reffile") || print "Content-type: text/html\n\n Can't
Open $reffile(r): $!\n";
my(@LINES)=<REFFILE>;
close(REFFILE);
$SIZE=@LINES;
open (REFFILE,">$reffile") || print "Content-type: text/html\n\n Can't
Open $reffile(r): $!\n";
print REFFILE "$date\| $ENV{'REMOTE_HOST'}\|
$ENV{'HTTP_USER_AGENT'}\|$usercurr\|NULL\|\n";
for ($i=1;$i<$SIZE;$i++) {
local($itemq) = "item$i";
$_=$LINES[$i];
my($itemname, $itemprice, $itemquant, $weight, $itemid) =
split(/\|/,$_);
if ($FORM{$itemq} > 0) {
print REFFILE join "\|",
$itemname,$itemprice,$FORM{$itemq},$weight,$itemid,"\|\n";
}
}
close(REFFILE);
print "Location: $cgiurl\?command=review\n\n";
}
# Show the order form
sub buy_items1 {
if (($usership eq 'NULL') && ($multiship eq 1)) {
print "Location: $cgiurl\?command=calcship \n\n";
}
&print_header;
print "<FORM METHOD='POST'
ACTION='https://secure.paymentclearing.com/cgi-bin/mas/split.cgi'>";
if ($tax eq '2') {
$temptax=$tax }
&list_items_final;
##### TAX INFO ON ORDER PAGE #####
if ($tax eq '1') {
if ($taxtotal > '0') {
print "<a href=\"$cgiurl\?command=removetax2\"><font size=-1><B>CLICK
HERE</a> if you are not a resident of $taxstate.</font><P>";
}
else {
print "<a href=\"$cgiurl\?command=addtax2\"><font size=-1><B>CLICK
HERE</a></font> <B>if you are a resident of $taxstate.</B><P>";
}
}
##### TAX INFO ENDS HERE #####
### THIS WHERE THE ORDER FORM IS DISPLAYED ###
if ($defaultform eq '1') {
&order_form;
}
else {
open (ORDER,"$basepath/$split_order") || print "Could not open
$basepath/$split_order $! \n";
while (<ORDER>) {
print $_;
}
close(ORDER);
&print_footer;
}
}
# Process the order form
sub buy_items2 {
&OrdParse;
$in{good}=$good;
&print_header;
if( $in{good} eq "1")
{
print "You have successfully ordered the following:<br><br>\n";
&list_items;
}
print "<br><br>\n";
&print_footer;
unlink($reffile);
}
# parse form input
sub parse_form {
my(@pairs);
if ($ENV{'REQUEST_METHOD'} eq 'GET') {
# Split the name-value pairs
@pairs = split(/&/, $ENV{'QUERY_STRING'});
}
elsif ($ENV{'REQUEST_METHOD'} eq 'POST') {
# Get the input
read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
# Split the name-value pairs
@pairs = split(/&/, $buffer);
}
else {
&error('request_method');
}
foreach $pair (@pairs) {
my($name, $value) = split(/=/, $pair);
$name =~ tr/+/ /;
$name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
# If they try to include server side includes, erase them, so
they
# arent a security risk if the html gets returned. Another
# security hole plugged up.
$value =~ s/<!--(.|\n)*-->//g;
# Create two associative arrays here. One is a configuration
array
# which includes all fields that this form recognizes. The
other
# is for fields which the form does not recognize and will
report
# back to the user in the html return page and the e-mail
message.
# Also determine required fields.
if ($name eq 'bgcolor' ||
$name eq 'background' ||
$name eq 'link_color' ||
$name eq 'vlink_color' ||
$name eq 'text_color' ||
$name eq 'alink_color' ||
$name eq 'title' ||
$name eq 'sort' ||
$name eq 'print_config' ||
$name eq 'return_link_title' ||
$name eq 'return_link_url' && ($value)) {
$CONFIG{$name} = $value;
}
elsif ($name eq 'required') {
@required = split(/,/,$value);
}
elsif ($name eq 'exclude') {
@exclude = split(/,/,$value);
}
else {
if ($FORM{$name} && ($value)) {
$FORM{$name} = "$FORM{$name}, $value";
}
elsif ($value) {
$FORM{$name} = $value;
}
}
}
}
# Get the hostname, for file reference
sub get_host {
$host = $ENV{'REMOTE_HOST'};
$reffile = "$tmpdir/$storename-$host";
}
sub check_file {
$exists = '1' if -e "$reffile";
if ($exists eq '1') {
&parse_file;
}
else {
&make_file;
}
}
# Parse the cart
sub parse_file {
open (REFFILE,"$reffile") || die "Can't Open $reffile(r): $!\n";
@LINES=<REFFILE>;
close(REFFILE);
$SIZE=@LINES;
$_=$LINES[0];
($usertime, $userhost, $useragent, $usercurr, $usership) =
split(/\|/,$_);
}
# If they don't have a cart, make them one.
sub make_file {
open(REFFILE,">$reffile");
print REFFILE "$date\| $ENV{'REMOTE_HOST'}\|
$ENV{'HTTP_USER_AGENT'}\|";
if ($multicurr eq 1) { print REFFILE "NULL\|"; } else { print REFFILE
"1\|"; }
print REFFILE "NULL\|\n";
close(REFFILE);
}
#Delete a cart
sub delete_cart {
unlink($reffile);
}
# Delete an item from the cart
sub delete_item {
open (REFFILE,"$reffile") || print "Content-type: text/html\n\n Can't
Open $reffile(r): $!\n";
@LINES=<REFFILE>;
close(REFFILE);
$SIZE=@LINES;
open (REFFILE,">$reffile") || print "Content-type: text/html\n\n Can't
Open $reffile(r): $!\n";
print REFFILE "$date\| $ENV{'REMOTE_HOST'}\|
$ENV{'HTTP_USER_AGENT'}\|NULL\|NULL\|\n";
for ($i=1;$i<$SIZE;$i++) {
$_=$LINES[$i];
my($itemname, $itemprice, $itemquant, $weight, $itemid) =
split(/\|/,$_);
if ($FORM{$itemname} eq $itemname) {
# Do nothing
}
else { print REFFILE $_; }
}
close(REFFILE);
print "Location: $cgiurl\?command=review\n\n";
}
# Get the date.
sub get_date {
@days =
('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
@months = ('January','February','March','April','May','June','July',
'August','September','October','November','December');
($sec,$min,$hour,$mday,$mon,$year,$wday) =
localtime(time);
if ($hour < 10) { $hour = "0$hour"; }
if ($min < 10) { $min = "0$min"; }
if ($sec < 10) { $sec = "0$sec"; }
$date = "$days[$wday], $months[$mon] $mday, 19$year at
$hour\:$min\:$sec";
}
# Did they fill out all necessary info?
sub check_required {
foreach $require (@required) {
if ($require eq 'bgcolor' ||
$require eq 'background' ||
$require eq 'link_color' ||
$require eq 'vlink_color' ||
$require eq 'alink_color' ||
$require eq 'text_color' ||
$require eq 'sort' ||
$require eq 'title' ||
$require eq 'print_config' ||
$require eq 'return_link_title' ||
$require eq 'return_link_url') {
if (!($CONFIG{$require}) || $CONFIG{$require} eq ' ') {
push(@ERROR,$require);
}
}
elsif (!($FORM{$require}) || $FORM{$require} eq ' ') {
push(@ERROR,$require);
}
}
if (@ERROR) {
&error('missing_fields', @ERROR);
}
}
# Warning Warning.
sub error {
&print_header;
($error,@error_fields) = @_;
if ($error eq 'missing_fields') {
print " <h1>Error: Blank Fields</h1>\n\n";
print "The following fields were left blank in your submission
form:<p>\n";
# Print Out Missing Fields in a List.
print "<ul>\n";
foreach $missing_field (@error_fields) {
print "<li>$missing_field\n";
}
print "</ul>\n";
# Provide Explanation for Error and Offer Link Back to Form.
print "<p><hr size=7 width=75\%><p>\n";
print "These fields must be filled out before you can
successfully submit\n";
print "the form. Please return to the <a
href=\"$ENV{'HTTP_REFERER'}\">Fill Out Form</a> and try again.\n";
}
elsif ($error eq 'noship') {
print "<h2>Error: Shipping not Set!</h2><br> Please go back and
calcualte shipping!\n";
}
&print_footer;
exit;
}
sub print_script {
print <<"JAVA";
<SCRIPT LANGUAGE="JavaScript">
<!--
function MakeArray()
{
this.length = MakeArray.arguments.length
for (var i = 0; i < this.length; i++)
this[i+1] = MakeArray.arguments[i]
}
function jumpPage1(form)
{
i = document.select1.SelectMenu.selectedIndex;
form.ship.value = url1[i+1];
form.total.value = url1[i+1]+total;
}
JAVA
print "url1 = new MakeArray($shipping1{$low}, $shipping2{$low},
$shipping3{$low});\n";
print "total = $totalprice \- $shipping1{$low};\n";
print <<"JAVA";
// -->
</script>
JAVA
}
sub calc_shipping {
&print_header;
local ($totalprice,$totalquant,$totalweight) = 0;
open (REFFILE,"$reffile") || die "Content-type: text/html\n\nCan't
Open $reffile(r): $!\n";
@LINES=<REFFILE>;
close(REFFILE);
$SIZE=@LINES;
print "<form method=POST name=select1
action=\"$cgiurl?command=setship\">\n";
print "<table border=1 cellpadding=5><tr>\n";
if ($useimage eq '1') {
print "<th></th>";
}
if ($useid eq '1') {
print "<th><font size=-1 color=blue>ITEM ID</font></th>";
}
print "<TR BGCOLOR='#000000'><TH COLSPAN=5 ALIGN=center><FONT SIZE=3
COLOR=white> <B>$mname</B> </FONT></TH></TR>
<th><font size=-1 color=blue>ITEM NAME</FONT></th><th><font size=-1
color=blue>QUANTITY</font></th><th><font size=-1
color=blue>PRICE</font></th><th><font size=-1
color=blue>AMOUNT</font></th></tr>";
for ($i=1;$i<$SIZE;$i++) {
$_=$LINES[$i];
($itemname, $itemprice, $itemquant, $weight, $itemid) =
split(/\|/,$_);
$tmpprice = $itemprice*$itemquant;
$tmpprice = int($tmpprice * (10 ** 2) + .5) / (10 ** 2);
$totalprice=$totalprice + $tmpprice;
$totalquant=$totalquant + $itemquant;
$totalweight = ($weight*$itemquant) + $totalweight;
print "<tr>";
if ($useimage eq '1') {
if ($FORM{'image'}) {
print "<td><img src=\"$imageurl/$FORM{'image'}\"></td>\n";
}
else {
print "<td></td>";
}
}
if ($useid eq '1') {
print "<td>$itemid <input type=hidden name=itemid
value=\"$itemid\"></td>\n";
}
$tmpprice = &format_price($tmpprice);
#$_ = $tmpprice;
#if (/\./) {
# my($left,$right) = split(/\./,$tmpprice);
# if (length($right) == 0) {
# $tmpprice = $tmpprice . "00";
# }
# elsif (length($right) == 1) { $tmpprice = $tmpprice . "0"; }
# }
# else { $tmpprice = $tmpprice . ".00"; }
print "<td>$itemname</td><td align=center>$itemquant</td><td
align=right>\$ $itemprice</td><td align=right>\$ $tmpprice</tr>\n";
}
print "<tr><td><b>Subtotal:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$totalprice = &format_price($totalprice);
#$_ = $totalprice;
#if (/\./) {
# my($left,$right) = split(/\./,$totalprice);
# if (length($right) == 0) {
# $totalprice = $totalprice . "00";
# }
# elsif (length($right) == 1) { $totalprice = $totalprice . "0"; }
# }
# else { $totalprice = $totalprice . ".00"; }
print "<td></td><td></td><td align=right><b>\$
$totalprice</b></td></tr>\n";
if ($tax eq '0') {
# print nothing
}
elsif ($tax eq '1') {
$taxtotal = $totalprice * $taxper;
$taxtotal = int($taxtotal * (10 ** 2) + .5) / (10 ** 2);
$totalprice = $totalprice + $taxtotal;
#print "<tr><td><b>Taxes:</b></td>";
#if ($useimage eq '1') {
# print "<td></td>";
# }
#if ($useid eq '1') {
# print "<td></td>";
# }
#
#$_ = $taxtotal;
#
#if (/\./) {
# my($left,$right) = split(/\./,$taxtotal);
# if (length($right) == 0) {
# $taxtotal = $taxtotal . "00";
# }
# elsif (length($right) == 1) { $taxtotal = $taxtotal . "0"; }
# }
# else { $taxtotal = $taxtotal . ".00"; }
#print "<td></td><td></td><td align=right><b>\$
$taxtotal</center></b></td></tr>\n";
##### INCLUDE TAX TAG #####
#print "<input type=hidden name='$rcitem-desc' value='Tax'>\n";
#print "<input type=hidden name='$rcitem-qty' value='1'>\n";
#print "<input type=hidden name='$rcitem-cost'
value='$taxtotal'>\n\n";
}
elsif ($tax eq '2') {
$taxtotal = $totalprice * $taxamt;
$taxtotal = int($taxtotal * (10 ** 2) + .5) / (10 ** 2);
$totalprice += $taxtotal;
print "<tr><td><b>Taxes:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$taxtotal = &format_price($taxtotal);
#$_ = $taxtotal;
#if (/\./) {
# my($left,$right) = split(/\./,$taxtotal);
# if (length($right) == 0) {
# $taxtotal = $taxtotal . "00";
# }
# elsif (length($right) == 1) { $taxtotal = $taxtotal . "0"; }
# }
# else { $taxtotal = $taxtotal . ".00"; }
print "<td></td><td></td><td align=right><b>\$
$taxtotal</center></b></td></tr>\n";
}
if ($shipping eq '0') {
# print nothing
}
elsif ($shipping eq '1') {
local(@prices,$price);
@prices = sort number keys %shipping;
$low = $prices[0];
foreach $price (@prices) {
if ($price < $low && $price >= $totalquant) {$low = $price};
}
$shipamt = $shipping{$low};
$totalprice += $shipamt;
}
elsif ($shipping eq '2') {
$totalprice += $shipamt;
}
elsif ($shipping eq '3') {
my(@weights,$weight);
@weights = sort number keys %shipping;
$low = $weights[0];
foreach $weight (@weights) {
if ($weight > $low && $weight <= $totalweight) {$low =
$weight};
}
$shipamt = $shipping{$low};
$totalprice += $shipamt;
}
elsif ($shipping eq '4') {
my(@prices);
@prices = sort number keys %shipping1;
$low = $prices[0];
foreach $price (@prices) {
if ($price > $low && $price <= $totalprice) {$low = $price};
}
$shipamt = $shipping1{$low};
$totalprice += $shipamt;
}
print "<tr><td><b>Shipping/Handling:</b></td>";
$totalprice = int($totalprice * (10 ** 2) + .5) / (10 ** 2);
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
print "<td>";
&print_script;
$shipamt = &format_price($shipamt);
#$_ = $shipamt;
#if (/\./) {
# my($left,$right) = split(/\./,$shipamt);
# if (length($right) == 0) {
# $shipamt = $shipamt . "00";
# }
# elsif (length($right) == 1) { $shipamt = $shipamt . "0"; }
# }
# else { $shipamt = $shipamt . ".00"; }
# print "<td></td><td></td><td align=right><b>\$
$shipamt</b></td></tr>\n";
print "</td><td>
<select name=\"SelectMenu\" onChange=\"jumpPage1(this.form)\">
<option>Standard</option>
<option>2nd Day</option>
<option>Next Day</option>
</select></td><td align=right><b>\$ <input type=text name=ship size=8
maxlength=0 value=\"$shipamt\" onFocus=\"form.ship.blur()\"
onSelect=\"form.ship.blur()\"></b></td></tr>\n";
$totalprice = int($totalprice * (10 ** 2) + .5) / (10 ** 2);
$_ = $totalprice;
if (/\./) {
($left,$right) = split(/\./,$totalprice);
if (length($right) == 0) {
$totalprice = $totalprice . "00";
}
elsif (length($right) == 1) { $totalprice = $totalprice . "0"; }
}
else { $totalprice = $totalprice . ".00"; }
print "<tr><td><b>Total price:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
print "<td></td><td></td><td align=right><b>\$ <input type=text
name=total size=8 maxlength=0 value=\"$totalprice\"
onFocus=\"form.total.blur()\"
onSelect=\"form.total.blur()\"></b></td></tr>\n";
print "</table><br>\n";
print "<center><input type=submit value=\"Set Shipping\"></form>\n";
&print_footer;
}
sub set_shipping {
open (REFFILE,"$reffile") || print "Content-type: text/html\n\n Can't
Open $reffile(r): $!\n";
my(@LINES)=<REFFILE>;
close(REFFILE);
$SIZE=@LINES;
open (REFFILE,">$reffile") || print "Content-type: text/html\n\n Can't
Open $reffile(r): $!\n";
print REFFILE "$date\| $ENV{'REMOTE_HOST'}\|
$ENV{'HTTP_USER_AGENT'}\|$usercurr\|$FORM{'ship'}\|\n";
for ($i=1;$i<$SIZE;$i++) {
$_=$LINES[$i];
my($itemname, $itemprice, $itemquant, $weight, $itemid) =
split(/\|/,$_);
print REFFILE join "\|",
$itemname,$itemprice,$itemquant,$weight,$itemid,"\|\n";
}
print "Location: $cgiurl\?command=review\n\n";
}
sub calc_currency {
sub print_curr_script {
print <<"JAVA";
<SCRIPT LANGUAGE="JavaScript">
<!--
function MakeArray()
{
this.length = MakeArray.arguments.length
for (var i = 0; i < this.length; i++)
this[i+1] = MakeArray.arguments[i]
}
function jumpPage1(form)
{
i = document.select1.SelectMenu.selectedIndex;
form.exchange.value = url1[i+1];
}
JAVA
print "url1 = new MakeArray(";
my(@currs) = sort number keys %currency;
foreach $curr (@currs) { print "$currency{$curr},"; }
print "1);\n";
print <<"JAVA";
// -->
</script>
JAVA
}
&print_header;
print "<form method=POST name=select1
action=\"$cgiurl?command=setcurr\">\n";
print "<table border=1><tr>";
print "<th></th><th>Currency</th><th>Exchange
Rate</th></tr><tr><td>\n";
&print_curr_script;
print "</td><td><select name=\"SelectMenu\"
onChange=\"jumpPage1(this.form)\">";
@currs = sort number keys %currency;
foreach $curr (@currs) { print "<option> $curr </option>\n"; }
print "<option selected>Pick a Currency</option></select></td><td>\n";
print "<input type=text name=exchange size=8 maxlength=0 value=\"1\"
onFocus=\"form.total.blur()\" onSelect=\"form.total.blur()\">";
print "</td></tr></table>\n";
print "<center><input type=submit value=\"Set Currency\"></form>\n";
&print_footer;
}
sub set_currency {
open (REFFILE,"$reffile") || print "Content-type: text/html\n\n Can't
Open $reffile(r): $!\n";
my(@LINES)=<REFFILE>;
close(REFFILE);
$SIZE=@LINES;
open (REFFILE,">$reffile") || print "Content-type: text/html\n\n Can't
Open $reffile(r): $!\n";
print REFFILE "$date\| $ENV{'REMOTE_HOST'}\|
$ENV{'HTTP_USER_AGENT'}\|$FORM{'exchange'}\|$usership\|\n";
for ($i=1;$i<$SIZE;$i++) {
$_=$LINES[$i];
my($itemname, $itemprice, $itemquant, $weight, $itemid) =
split(/\|/,$_);
print REFFILE join "\|",
$itemname,$itemprice,$itemquant,$weight,$itemid,"\|\n";
}
print "Location: $cgiurl\?command=review\n\n";
}
sub track_order {
$orderid = time() . "-" . $$;
open (TRACK, ">>$trackdb");
print TRACK $orderid . "\|";
foreach $key (%FORM) {
print TRACK "$key\=$FORM{$key}\&";
}
print TRACK "\|pending\|NONE\|\n";
close(TRACK);
}
sub order_form {
print "<strong><center><HR width=590><font size=-1 color=blue><B>SHIP
TO:</b></FONT><HR width=590></strong></center></TD>
<TABLE width=590>
<TR>
<TD ALIGN='right'><B>First Name: </B> </TD>
<TD><INPUT NAME='first_name' SIZE=17> <B>Last Name: </B>
<INPUT NAME='last_name' SIZE=17> <BR> </TD>
</TR>
<TR>
<TD ALIGN='right'><B>Address: </B> </TD>
<TD><INPUT NAME='address' SIZE=48><BR></TD>
</TR>
<TR>
<TD ALIGN='right'><B>City: </B> </TD>
<TD><INPUT NAME='city' SIZE=20> <B> State: </B>
<INPUT NAME='state' SIZE=3 MAXLENGTH=2> <B> Zip: </B>
<INPUT NAME='zip' SIZE=10><BR></TD>
</TR>
<TR>
<TD ALIGN='right'><B>Country: </B> </TD>
<TD><INPUT NAME='country' SIZE=48 value='USA'><BR></TD>
</TR>
<TR>
<TD ALIGN='right'><B>Phone Number: </B> </TD>
<TD><strong><INPUT NAME='phone' SIZE=15><BR></TD>
</TR>
<TR>
<TD ALIGN='right'><B>E-Mail Address: </B> </TD>
<TD><INPUT NAME='email' SIZE=48></TD>
</TR>
</TABLE>
<TD><HR width=590></TD>
<TR><TD>
</CENTER>
<CENTER>
<B><font color=blue size=-1>TO PAY BY CHECK, SIMPLY PRINT THIS PAGE
AND REMIT TO:<BR><P>
<B>HEALTH FOOD DEPOT, INC.<BR>
<B>11157 TAMPA AVENUE<BR>
<B>NORTHRIDGE, CA 91326-2254<BR>
<B>USA<BR><P>
<B>TO PAY BY CREDIT CARD, PROCEED TO THE SECURE SERVER AND ENTER YOUR
CREDIT CARD INFORMATION USING THE FOLLOWING DATA ENTRY
FORMAT:<BR></font>
<table width=590 align=center valign=top>
<TD>
<table width=530 border=0 valign=top>
<HR width=280>
<TD align=center><font size=-1><B>CREDIT CARD DEMO<BR>
Credit Card Number: 545454545454545454<BR>
Exp. Date: 12/01</B><BR>
<HR width=280>
</font></TD>
</table>
</TD>
</table>
</B></font>
<!--<!BR><font size=-1><B>TO COMPLETE YOUR ORDER, PRESS CONTINUE AND
YOU WILL BE TAKEN TO A SECURE SERVER.--><BR>
<INPUT TYPE='submit' VALUE='PROCEED TO SECURE SERVER'>
</form>"
}
sub remove_tax {
$temptax = '0';
&review_items;
}
sub add_tax {
$temptax = $tax;
&review_items;
}
sub remove_tax2 {
$temptax = '0';
&buy_items1;
}
sub add_tax2 {
$temptax = $tax;
&buy_items1;
}
sub list_items_final {
my($totalprice,$totalquant,$totalweight) = 0;
open (REFFILE,"$reffile") || die "Content-type: text/html\n\nCan't
Open $reffile(r): $!\n";
my(@LINES)=<REFFILE>;
close(REFFILE);
$SIZE=@LINES;
$rcitem=1;
if ($usership eq 'NULL') {
$usership='0';
}
#print "<form name=select1 method=POST
action=\"$cgiurl?command=change\">\n";
##### INCLUDE REQUIRED MERCHANT TAGS #####
#print "<FORM METHOD='POST'
ACTION='https://secure.paymentclearing.com/cgi-bin/mas/split.cgi'>\n";
print "\n";
print "<INPUT type='hidden' name='vendor_id' value='$mid'>\n";
print "<INPUT type='hidden' name='home_page' value='$hp'>\n";
print "<INPUT type='hidden' name='ret_addr' value='$retaddr'>\n";
print "<INPUT type='hidden' name='email_text' value='$etext'>\n";
#print "<INPUT type='hidden' name='ret_mode' value='$ret_mode'>\n";
print "<INPUT type='hidden' name='lookup' value='first_name'>\n";
print "<INPUT type='hidden' name='lookup' value='last_name'>\n";
print "<INPUT type='hidden' name='lookup' value='address'>\n";
print "<INPUT type='hidden' name='lookup' value='city'>\n";
print "<INPUT type='hidden' name='lookup' value='state'>\n";
print "<INPUT type='hidden' name='lookup' value='zip'>\n";
print "<INPUT type='hidden' name='lookup' value='ctry'>\n";
print "<INPUT type='hidden' name='lookup' value='phone'>\n";
print "<INPUT type='hidden' name='lookup' value='email'>\n";
#print "<INPUT type='hidden' name='passback' value='good'>\n";
#print "<INPUT type='hidden' name='good' value='1'>\n";
#print "<INPUT type='hidden' name='passback' value='desc1'>\n";
#print "<INPUT type='hidden' name='desc1' value='$itemname'>\n";
##### INCLUDE SPLIT-FORM TAGS IF REQUIRED #####
if ($split eq '1') {
print "\n<INPUT type='hidden' name='mername' value='$mname'>\n";
print "<INPUT type='hidden' name='mertext' value='$mtext'>\n";
print "<INPUT type='hidden' name='acceptchecks' value='$checks'>\n";
print "<INPUT type='hidden' name='allowreg' value='$creg'>\n";
print "<INPUT type='hidden' name='checkguar' value='$cguar'>\n";
print "<INPUT type='hidden' name='acceptcards' value='$cards'>\n";
print "<INPUT type='hidden' name='altaddr' value='$creg'>\n";
}
print "\n";
print "<table border=1 cellpadding=5><tr>\n";
if ($useimage eq '1') {
print "<th></th>";
}
if ($useid eq '1') {
print "<th><font size=-1 color=blue>ITEM ID</font></th>";
}
print "<TR BGCOLOR='#000000'><TH COLSPAN=5 ALIGN=center><FONT SIZE=3
COLOR=white> <B>$mname</B> </FONT></TH></TR>
<th><font size=-1 color=blue>ITEM NAME</FONT></th><th><font size=-1
color=blue>QUANTITY</font></th><th><font size=-1
color=blue>PRICE</font></th><th><font size=-1
color=blue>AMOUNT</font></th></tr>";
for ($i=1;$i<$SIZE;$i++) {
$_=$LINES[$i];
($itemname, $itemprice, $itemquant, $weight, $itemid) =
split(/\|/,$_);
$tmpprice = ($itemprice*$itemquant);
$tmpprice = int($tmpprice * (10 ** 2) + .5) / (10 ** 2);
$totalprice += $tmpprice;
$totalquant += $itemquant;
$totalweight = ($weight*$itemquant) + $totalweight;
print "<tr>";
if ($useimage eq '1') {
if ($FORM{'image'}) {
print "<td><img src=\"$imageurl/$FORM{'image'}\"></td>\n";
}
else {
print "<td></td>";
}
}
if ($useid eq '1') {
print "<td>$itemid <input type=hidden name=itemid
value=\"$itemid\"></td>\n";
}
$tmpprice = &format_price($tmpprice);
#$_ = $tmpprice;
#if (/\./) {
# my($left,$right) = split(/\./,$tmpprice);
# if (length($right) == 0) {
# $tmpprice = $tmpprice . "00";
# }
# elsif (length($right) == 1) { $tmpprice = $tmpprice . "0"; }
# }
# else { $tmpprice = $tmpprice . ".00"; }
#print "<td>$itemname</td><td align=right>\$ $itemprice</td><td
align=center><input type=number size=2 value=\"$itemquant\"
name=item$i></td><td align=right>\$ $tmpprice</tr>\n";
print "<td>$itemname</td><td align=center>$itemquant</td><td
align=right>\$ $itemprice</td><td align=right>\$ $tmpprice</tr>\n";
########## INCLUDE REQUIRED FIELD NAMES ###########
print "<input type=hidden name='$rcitem-desc' value='$itemname'>\n";
print "<input type=hidden name='$rcitem-qty' value='$itemquant'>\n";
print "<input type=hidden name='$rcitem-cost' value='$itemprice'>\n";
print "<INPUT type='hidden' name='passback' value='desc$rcitem'>\n";
print "<INPUT type='hidden' name='desc$rcitem'
value='$itemname'>\n\n";
print "<INPUT type='hidden' name='passback' value='qty$rcitem'>\n";
print "<INPUT type='hidden' name='qty$rcitem'
value='$itemquant'>\n\n";
print "<INPUT type='hidden' name='passback' value='cost$rcitem'>\n";
print "<INPUT type='hidden' name='cost$rcitem'
value='$itemprice'>\n\n";
### SUBTOTAL PASSBACKS ###
print "<INPUT type='hidden' name='passback' value='sub$rcitem'>\n";
print "<INPUT type='hidden' name='sub$rcitem' value='$tmpprice'>\n\n";
$rcitem=$rcitem+1;
}
### QUANTITY FIGURED ###
print "<P><INPUT type='hidden' name='passback'
value='finalquant'><BR>\n";
print "<INPUT type='hidden' name='finalquant'
value='$rcitem'><P>\n\n";
print "<tr><td><b>Subtotal:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$totalprice = &format_price($totalprice);
#$_ = $totalprice;
#if (/\./) {
# my($left,$right) = split(/\./,$totalprice);
# if (length($right) == 0) {
# $totalprice = $totalprice . "00";
# }
# elsif (length($right) == 1) { $totalprice = $totalprice . "0"; }
# }
# else { $totalprice = $totalprice . ".00"; }
print "<td></td><td></td><td align=right><b>\$
$totalprice</b></td></tr>\n";
### FULL ORDER SUBTOTAL PASSBACKS ###
print "<INPUT type='hidden' name='passback' value='subtotal'>\n";
print "<INPUT type='hidden' name='subtotal' value='$totalprice'>\n\n";
if ($temptax <=> '0') {
if ($tax eq '0') {
# print nothing
}
elsif ($tax eq '1') {
$taxtotal = $totalprice * $taxper;
$taxtotal = int($taxtotal * (10 ** 2) + .5) / (10 ** 2);
$totalprice = $totalprice + $taxtotal;
print "<tr><td><b>";
if ($tax eq '1') {print "$taxstate "};
print "Taxes:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$taxtotal = &format_price($taxtotal);
#$_ = $taxtotal;
#if (/\./) {
# my($left,$right) = split(/\./,$taxtotal);
# if (length($right) == 0) {
# $taxtotal = $taxtotal . "00";
# }
# elsif (length($right) == 1) { $taxtotal = $taxtotal . "0"; }
# }
# else { $taxtotal = $taxtotal . ".00"; }
print "<td></td><td></td><td align=right><b>\$
$taxtotal</center></b></td></tr>\n";
### TAX PASSBACKS ###
print "<INPUT type='hidden' name='passback' value='taxes'>\n";
print "<INPUT type='hidden' name='taxes' value='$taxtotal'>\n\n";
##### TAX TAG #####
print "<input type=hidden name='$rcitem-desc' value='Tax'>\n";
print "<input type=hidden name='$rcitem-qty' value='1'>\n";
print "<input type=hidden name='$rcitem-cost' value='$taxtotal'>\n\n";
}
elsif ($tax eq '2') {
$taxtotal = $totalprice * $taxamt;
$taxtotal = int($taxtotal * (10 ** 2) + .5) / (10 ** 2);
$totalprice = $totalprice + $taxtotal;
print "<tr><td><b>";
if ($tax eq '1') {print "$taxstate "};
print "Taxes:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$taxtotal = &format_price($taxtotal);
#$_ = $taxtotal;
#if (/\./) {
# my($left,$right) = split(/\./,$taxtotal);
# if (length($right) == 0) {
# $taxtotal = $taxtotal . "00";
# }
# elsif (length($right) == 1) { $taxtotal = $taxtotal . "0"; }
# }
# else { $taxtotal = $taxtotal . ".00"; }
print "<td></td><td></td><td align=right><b>\$
$taxtotal</center></b></td></tr>\n";
### TAX PASSBACKS ###
print "<INPUT type='hidden' name='passback' value='taxes'>\n";
print "<INPUT type='hidden' name='taxes' value='$taxtotal'>\n\n";
##### INCLUDE TAX TAGT #####
print "<input type=hidden name='$rcitem-desc' value='Tax'>\n";
print "<input type=hidden name='$rcitem-qty' value='1'>\n";
print "<input type=hidden name='$rcitem-cost' value='$taxtotal'>\n\n";
}
}
$rcitem=$rcitem+1;
if ($multiship eq 1) {
print "<tr><td><b>Shipping/Handling:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
print "<td></td><td></td><td align=right>";
print "<input type=hidden name='$rcitem-desc' value='Shipping'>\n";
print "<input type=hidden name='$rcitem-qty' value='1'>\n";
print "<input type=hidden name='$rcitem-cost' value='$usership'>\n\n";
if ($usership eq 'NULL') {
print "<a href=\"$cgiurl\?command=calcship\">Calculate<br>Shipping</a>";
}
else {
print "<b>\$ $usership</b>";
$totalprice += $usership;
}
print "</td></tr>\n";
}
else {
if ($shipping eq '0') {
# print nothing
}
elsif ($shipping eq '1') {
local($low,@prices,$price);
@prices = sort number keys %shipping;
$low = $prices[0];
foreach $price (@prices) {
if (($price > $low) && ($price <= $totalquant)) {$low = $price};
}
$shipamt = $shipping{$low};
$totalprice += $shipamt;
print "<tr><td><b>Shipping/Handling:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$shipamt = &format_price($shipamt);
#$_ = $shipamt;
#if (/\./) {
# my($left,$right) = split(/\./,$shipamt);
# if (length($right) == 0) {
# $shipamt = $shipamt . "00";
# }
# elsif (length($right) == 1) { $shipamt = $shipamt . "0"; }
# }
# else { $shipamt = $shipamt . ".00"; }
print "<td></td><td></td><td align=right><b>\$
$shipamt</b></td></tr>\n";
##### INCLUDE SHIPPING TAG (BY NUMBER OF ITEMS ORDERED.) #####
print "<input type=hidden name='$rcitem-desc' value='Shipping'>\n";
print "<input type=hidden name='$rcitem-qty' value='1'>\n";
print "<input type=hidden name='$rcitem-cost' value='$shipamt'>\n\n";
}
elsif ($shipping eq '2') {
$totalprice += $shipamt;
print "<tr><td><b>Shipping/Handling:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$shipamt = &format_price($shipamt);
#$_ = $shipamt;
#if (/\./) {
# my($left,$right) = split(/\./,$shipamt);
# if (length($right) == 0) {
# $shipamt = $shipamt . "00";
# }
# elsif (length($right) == 1) { $shipamt = $shipamt . "0"; }
# }
# else { $shipamt = $shipamt . ".00"; }
print "<td></td><td></td><td align=right><b>\$
$shipamt</b></td></tr>\n";
##### INCLUDE SHIPPING TAG (NON-VARIABLE) #####
print "<input type=hidden name='$rcitem-desc' value='Shipping'>\n";
print "<input type=hidden name='$rcitem-qty' value='1'>\n";
print "<input type=hidden name='$rcitem-cost' value='$shipamt'>\n\n";
}
elsif ($shipping eq '3') {
my($low,@weights,$weight);
@weights = sort number keys %shipping;
$low = $weights[0];
foreach $weight (@weights) {
if ($weight > $low && $weight <= $totalweight) {$low =
$weight};
}
$shipamt = $shipping{$low};
$totalprice += $shipamt;
print "<tr><td><b>Shipping/Handling:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$shipamt = &format_price($shipamt);
#$_ = $shipamt;
#if (/\./) {
# my($left,$right) = split(/\./,$shipamt);
# if (length($right) == 0) {
# $shipamt = $shipamt . "00";
# }
# elsif (length($right) == 1) { $shipamt = $shipamt . "0"; }
# }
# else { $shipamt = $shipamt . ".00"; }
print "<td align=center>";
if ($totalquant > '0') { print "<B>$totalweight lbs.</B>"; }
print "</td><td></td><td align=right><b>\$ $shipamt</b></td></tr>\n";
##### INCLUDE SHIPPING TAG (BY WEIGHT) #####
print "<input type=hidden name='$rcitem-desc' value='Shipping'>\n";
print "<input type=hidden name='$rcitem-qty' value='1'>\n";
print "<input type=hidden name='$rcitem-cost' value='$shipamt'>\n\n";
$passship=$shipamt;
}
elsif ($shipping eq '4') {
my($low,@prices);
@prices = sort number keys %shipping;
$low = $prices[0];
foreach $price (@prices) {
if ($price > $low && $price <= $totalprice) {$low = $price};
}
$shipamt = $shipping{$low};
$totalprice += $shipamt;
print "<tr><td><b>Shipping/Handling:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
$shipamt = &format_price($shipamt);
#$_ = $shipamt;
#if (/\./) {
# my($left,$right) = split(/\./,$shipamt);
# if (length($right) == 0) {
# $shipamt = $shipamt . "00";
# }
# elsif (length($right) == 1) { $shipamt = $shipamt . "0"; }
# }
# else { $shipamt = $shipamt . ".00"; }
print "<td></td><td></td><td align=right><b>\$
$shipamt</b></td></tr>\n";
##### INCLUDE SHIPPING TAG (BY WEIGHT) #####
print "\n<input type=hidden name='$rcitem-desc' value='Shipping'>\n";
print "<input type=hidden name='$rcitem-qty' value='1'>\n";
#print "<input type=hidden name='$rcitem-cost'
value='$usership'>\n\n";
print "<input type=hidden name='$rcitem-cost' value='$shipamt'>\n\n";
}
}
$totalprice = int($totalprice * (10 ** 2) + .5) / (10 ** 2);
$totalprice = &format_price($totalprice);
#$_ = $totalprice;
#if (/\./) {
# my($left,$right) = split(/\./,$totalprice);
# if (length($right) == 0) {
# $totalprice = $totalprice . "00";
# }
# elsif (length($right) == 1) { $totalprice = $totalprice . "0"; }
# }
# else { $totalprice = $totalprice . ".00"; }
print "<tr><td><b>Total price:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
print "<td></td><td></td><td align=right><b>\$
$totalprice</b></td></tr>\n";
if ($multicurr eq 1) {
$totalprice *= $usercurr;
$totalprice = int($totalprice * (10 ** 2) + .5) / (10 ** 2);
$totalprice = &format_price($totalprice);
# $_ = $totalprice;
# if (/\./) {
# my($left,$right) = split(/\./,$totalprice);
# if (length($right) == 0) {
# $totalprice = $totalprice . "00";
# }
# elsif (length($right) == 1) { $totalprice = $totalprice . "0"; }
# }
# else { $totalprice = $totalprice . ".00"; }
print "<tr><td><b>Total price in selected currency:</b></td>";
if ($useimage eq '1') {
print "<td></td>";
}
if ($useid eq '1') {
print "<td></td>";
}
print "<td colspan=2>Exchange Rate: $usercurr</td><td
align=right><b>\$ $totalprice</b></td></tr>\n";
}
print "</table><br>\n";
print "<INPUT type='hidden' name='passback' value='totalprice'>\n";
print "<INPUT type='hidden' name='totalprice'
value='$totalprice'>\n\n";
print "<INPUT type='hidden' name='passback' value='totalship'>\n";
#print "<INPUT type='hidden' name='totalship' value='$usership'>\n\n";
if ($multiship = 0) {
print "<INPUT type='hidden' name='totalship' value='$shipamt'>\n\n";
}
if ($multiship = 1) {
print "<INPUT type='hidden' name='totalship' value='$usership'>\n\n";
}
#print "<input type='hidden' name='test' value='$passship'>\n\n";
#print "<INPUT type='hidden' name='passback' value='test'>\n";
#print "<INPUT type='hidden' name='test' value='0'>\n\n";
}
#######################################################################
# format_price
#
#######################################################################
# format_price is used to format prices to two decimal
# places. It takes one argumnet, the price to be formatted
# and is called with the following syntax:
#
# $price =&format_price(xxx.yyyyy);
#
# Notice that the main calling routine must assign the
# returned formatted price to some variable for its own
# use.
#
# Also notice that this routine takes a value even if it
# is longer than two decimal places and formats it with
# rounding. Thus, you can utilize price calculations such
# as 12.99 * 7.985 (where 7.985 might be some tax value.
sub format_price
{
# The incoming price is set to a local variables and a few
# wroking local variables are defined.
local ($unformatted_price) = @_;
local ($formatted_price);
# The script then uses the rounding method in EXCEL. If
# the 3rd decimal place is > 4, then we round the 2nd
# decimal place up 1. Otherwise, we leave the number
# alone. Notice that we will use the substr function to
# pull off the last value in the three decimal place
# number and compare it using the EXCEL logic.
#
# Basically, the routine uses the rounding rules of
# sprintf.
# The unformatted_price is rounded to
# to two decimal places and returned to the calling
# routine.
$formatted_price = sprintf ("%.2f", $unformatted_price);
return $formatted_price;
}
sub OrdParse {
# Disable warnings as this code deliberately uses local and
environment
# variables which are preset to undef (i.e., not explicitly
initialized)
local ($perlwarn);
$perlwarn = $^W;
$^W = 0;
local (*in) = shift if @_; # CGI input
local (*incfn, # Client's filename (may not be
provided)
*inct, # Client's content-type (may not be provided)
*insfn) = @_; # Server's filename (for spooled files)
local ($len, $type, $meth, $errflag, $cmdflag, $got, $name);
binmode(STDIN); # we need these for DOS-based systems
binmode(STDOUT); # and they shouldn't hurt anything else
binmode(STDERR);
# Get several useful env variables
$type = $ENV{'CONTENT_TYPE'};
$len = $ENV{'CONTENT_LENGTH'};
$meth = $ENV{'REQUEST_METHOD'};
if ($len > $cgi_lib'maxdata) { #'
&CgiDie("cgi-lib.pl: Request to receive too much data: $len
bytes\n");
}
if (!defined $meth || $meth eq '' || $meth eq 'GET' ||
$meth eq 'HEAD' ||
$type eq 'application/x-www-form-urlencoded') {
local ($key, $val, $i);
# Read in text
if (!defined $meth || $meth eq '') {
$in = $ENV{'QUERY_STRING'};
$cmdflag = 1; # also use command-line options
} elsif($meth eq 'GET' || $meth eq 'HEAD') {
$in = $ENV{'QUERY_STRING'};
} elsif ($meth eq 'POST') {
if (($got = read(STDIN, $in, $len) != $len))
{$errflag="Short Read: wanted $len, got $got\n";};
} else {
&CgiDie("cgi-lib.pl: Unknown request method: $meth\n");
}
@in = split(/[&;]/,$in);
push(@in, @ARGV) if $cmdflag; # add command-line parameters
foreach $i (0 .. $#in) {
# Convert plus to space
$in[$i] =~ s/\+/ /g;
# Split into key and value.
($key, $val) = split(/=/,$in[$i],2); # splits on the first =.
# Convert %XX from hex numbers to alphanumeric
$key =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge;
$val =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge;
# Associate key and value
$in{$key} .= "\0" if (defined($in{$key})); # \0 is the multiple
separator
$in{$key} .= $val;
}
} elsif ($ENV{'CONTENT_TYPE'} =~ m#^multipart/form-data#) {
# for efficiency, compile multipart code only if needed
$errflag = !(eval <<'END_MULTIPART');
local ($buf, $boundary, $head, @heads, $cd, $ct, $fname, $ctype,
$blen);
local ($bpos, $lpos, $left, $amt, $fn, $ser);
local ($bufsize, $maxbound, $writefiles) =
($cgi_lib'bufsize, $cgi_lib'maxbound, $cgi_lib'writefiles);
# The following lines exist solely to eliminate spurious warning
messages
$buf = '';
($boundary) = $type =~ /boundary="([^"]+)"/; #"; # find boundary
($boundary) = $type =~ /boundary=(\S+)/ unless $boundary;
&CgiDie ("Boundary not provided: probably a bug in your server")
unless $boundary;
$boundary = "--" . $boundary;
$blen = length ($boundary);
if ($ENV{'REQUEST_METHOD'} ne 'POST') {
&CgiDie("Invalid request method for multipart/form-data:
$meth\n");
}
if ($writefiles) {
local($me);
stat ($writefiles);
$writefiles = "/tmp" unless -d _ && -w _;
# ($me) = $0 =~ m#([^/]*)$#;
$writefiles .= "/$cgi_lib'filepre";
}
# read in the data and split into parts:
# put headers in @in and data in %in
# General algorithm:
# There are two dividers: the border and the '\r\n\r\n' between
# header and body. Iterate between searching for these
# Retain a buffer of size(bufsize+maxbound); the latter part is
# to ensure that dividers don't get lost by wrapping between two
bufs
# Look for a divider in the current batch. If not found, then
# save all of bufsize, move the maxbound extra buffer to the front
of
# the buffer, and read in a new bufsize bytes. If a divider is
found,
# save everything up to the divider. Then empty the buffer of
everything
# up to the end of the divider. Refill buffer to bufsize+maxbound
# Note slightly odd organization. Code before BODY: really goes
with
# code following HEAD:, but is put first to 'pre-fill' buffers.
BODY:
# is placed before HEAD: because we first need to discard any
'preface,'
# which would be analagous to a body without a preceeding head.
$left = $len;
PART: # find each part of the multi-part while reading data
while (1) {
die $@ if $errflag;
$amt = ($left > $bufsize+$maxbound-length($buf)
? $bufsize+$maxbound-length($buf): $left);
$errflag = (($got = read(STDIN, $buf, $amt, length($buf))) !=
$amt);
die "Short Read: wanted $amt, got $got\n" if $errflag;
$left -= $amt;
$in{$name} .= "\0" if defined $in{$name};
$in{$name} .= $fn if $fn;
$name=~/([-\w]+)/; # This allows $insfn{$name} to be untainted
if (defined $1) {
$insfn{$1} .= "\0" if defined $insfn{$1};
$insfn{$1} .= $fn if $fn;
}
BODY:
while (($bpos = index($buf, $boundary)) == -1) {
if ($left == 0 && $buf eq '') {
foreach $value (values %insfn) {
unlink(split("\0",$value));
}
&CgiDie("cgi-lib.pl: reached end of input while seeking boundary "
.
"of multipart. Format of CGI input is wrong.\n");
}
die $@ if $errflag;
if ($name) { # if no $name, then it's the prologue -- discard
if ($fn) { print FILE substr($buf, 0, $bufsize); }
else { $in{$name} .= substr($buf, 0, $bufsize); }
}
$buf = substr($buf, $bufsize);
$amt = ($left > $bufsize ? $bufsize : $left);
#$maxbound==length($buf);
$errflag = (($got = read(STDIN, $buf, $amt, length($buf))) !=
$amt);
die "Short Read: wanted $amt, got $got\n" if $errflag;
$left -= $amt;
}
if (defined $name) { # if no $name, then it's the prologue --
discard
if ($fn) { print FILE substr($buf, 0, $bpos-2); }
else { $in {$name} .= substr($buf, 0, $bpos-2); } # kill
last \r\n
}
close (FILE);
last PART if substr($buf, $bpos + $blen, 2) eq "--";
substr($buf, 0, $bpos+$blen+2) = '';
$amt = ($left > $bufsize+$maxbound-length($buf)
? $bufsize+$maxbound-length($buf) : $left);
$errflag = (($got = read(STDIN, $buf, $amt, length($buf))) !=
$amt);
die "Short Read: wanted $amt, got $got\n" if $errflag;
$left -= $amt;
undef $head; undef $fn;
HEAD:
while (($lpos = index($buf, "\r\n\r\n")) == -1) {
if ($left == 0 && $buf eq '') {
foreach $value (values %insfn) {
unlink(split("\0",$value));
}
&CgiDie("cgi-lib: reached end of input while seeking end of " .
"headers. Format of CGI input is wrong.\n$buf");
}
die $@ if $errflag;
$head .= substr($buf, 0, $bufsize);
$buf = substr($buf, $bufsize);
$amt = ($left > $bufsize ? $bufsize : $left);
#$maxbound==length($buf);
$errflag = (($got = read(STDIN, $buf, $amt, length($buf))) !=
$amt);
die "Short Read: wanted $amt, got $got\n" if $errflag;
$left -= $amt;
}
$head .= substr($buf, 0, $lpos+2);
push (@in, $head);
@heads = split("\r\n", $head);
($cd) = grep (/^\s*Content-Disposition:/i, @heads);
($ct) = grep (/^\s*Content-Type:/i, @heads);
($name) = $cd =~ /\bname="([^"]+)"/i; #";
($name) = $cd =~ /\bname=([^\s:;]+)/i unless defined $name;
($fname) = $cd =~ /\bfilename="([^"]*)"/i; #"; # filename can be
null-str
($fname) = $cd =~ /\bfilename=([^\s:;]+)/i unless defined
$fname;
$incfn{$name} .= (defined $in{$name} ? "\0" : "") .
(defined $fname ? $fname : "");
($ctype) = $ct =~ /^\s*Content-type:\s*"([^"]+)"/i; #";
($ctype) = $ct =~ /^\s*Content-Type:\s*([^\s:;]+)/i unless
defined $ctype;
$inct{$name} .= (defined $in{$name} ? "\0" : "") . $ctype;
if ($writefiles && defined $fname) {
$ser++;
$fn = $writefiles . ".$$.$ser";
open (FILE, ">$fn") || &CgiDie("Couldn't open $fn\n");
binmode (FILE); # write files accurately
}
substr($buf, 0, $lpos+4) = '';
undef $fname;
undef $ctype;
}
1;
END_MULTIPART
if ($errflag) {
local ($errmsg, $value);
$errmsg = $@ || $errflag;
foreach $value (values %insfn) {
unlink(split("\0",$value));
}
&CgiDie($errmsg);
} else {
# everything's ok.
}
} else {
&CgiDie("cgi-lib.pl: Unknown Content-type:
$ENV{'CONTENT_TYPE'}\n");
}
# no-ops to avoid warnings
$insfn = $insfn;
$incfn = $incfn;
$inct = $inct;
$^W = $perlwarn;
return ($errflag ? undef : scalar(@in));
}
sub OrdParse_old {
local (*in) = @_ if @_;
local ($i, $key, $val);
if ( $ENV{'REQUEST_METHOD'} eq "GET" ) {
$in = $ENV{'QUERY_STRING'};
} elsif ($ENV{'REQUEST_METHOD'} eq "POST") {
read(STDIN,$in,$ENV{'CONTENT_LENGTH'});
} else {
# Added for command line debugging
# Supply name/value form data as a command line
argument
# Format: name1=value1\&name2=value2\&...
# (need to escape & for shell)
# Find the first argument that's not a switch (-)
$in = ( grep( !/^-/, @ARGV )) [0];
$in =~ s/\\&/&/g;
}
@in = split(/&/,$in);
foreach $i (0 .. $#in) {
# Convert plus's to spaces
$in[$i] =~ s/\+/ /g;
# Split into key and value.
($key, $val) = split(/=/,$in[$i],2); # splits on the
first =.
# Convert %XX from hex numbers to alphanumeric
$key =~ s/%(..)/pack("c",hex($1))/ge;
$val =~ s/%(..)/pack("c",hex($1))/ge;
# Associate key and value. \0 is the multiple
separator
$in{$key} .= "\0" if (exists($in{$key}));
$in{$key} .= $val;
}
return length($in);
}
sub number { $a <=> $b }
##############################
# mySubroutines
##############################
sub myTabs {
local($num) = @_;
for (local($i) = 1; $i < $num; $i++) {
print " ";
}
}
# END smart.cgi
------------------------------
Date: Sat, 24 Nov 2001 05:38:35 GMT
From: garry@ifr.zvolve.net (Garry Williams)
Subject: Re: Problems with Mirror - ftp.pl doesn't get the right octal for chmod
Message-Id: <slrn9vucj2.377.garry@zfw.zvolve.net>
On 23 Nov 2001 14:49:11 GMT, Anno Siegel
<anno4000@lublin.zrz.tu-berlin.de> wrote:
> According to Garry Williams <garry@zvolve.com>:
>> On 23 Nov 2001 11:13:05 GMT, Anno Siegel
>> <anno4000@lublin.zrz.tu-berlin.de> wrote:
>>
>> > According to Dirk <dirk.drexler@web.de>:
>>
>> [ snip ]
>>
>> >> &send( sprintf( "SITE CHMOD %o $path", $mode ) );
>> >
>> > This is bad code. The author doesn't know how to use sprintf. In
>> > particular, variable strings ($path) do *not* belong in the sprintf
>> > format. The line should read
>> >
>> > &send( sprintf( "SITE CHMOD %o %s", $mode, $path ) );
>>
>> I suppose this is a matter of style. The Perl manual page for
>> sprintf() and sprintf(3) certainly don't agree with you. Assuming
>> that the interpolation results in no "conversion specification"
>> characters, the stuff in $path will be treated as "ordinary
>> characters", according to the manual pages.
>
> Oh, it certainly works in most cases. The point is that you have to
> make sure that no % (anything else?) appears in the interpolated
> string.
Okay, I agree it is not style here. The case at hand should not be
coded the way it is for the reason you (and Bart) cite.
--
Garry Williams
------------------------------
Date: Sat, 24 Nov 2001 04:08:51 GMT
From: tadmc@augustmail.com (Tad McClellan)
Subject: Re: Traversing directories
Message-Id: <slrn9vtvps.1v5.tadmc@tadmc26.august.net>
Rafal Konopka <rafalk@home.com> wrote:
>
>
>Tad McClellan wrote:
>>
>> I expect you meant error _message_?
>>
>> Care to share the error message text with us?
>print "$_\n" foreach find_htm($dir);
>The error message it produces is:
>
> Missing $ on loop variable at test1.pl line 6.
It is your Perl-of-only-historical-interest that is biting you.
Upgrade!
Perl is free. It installs in minutes.
Or, write the foreach loop the old-fashioned way with lots of
punctuation to get in the way of reading and understanding it:
foreach ( find_htm($dir) ) {
print "$_\n";
}
>I have not had an opportunity to test your code on my work PC, where I
>have installed Active Perl 5_6_?. It seems like my (work) alter ego did
>get with the times more than my home one :-).
>
>When I get back to my office (10 days or so),
You seem to be overly patient :-)
You won't have 15 free minutes to spend in the next week and a half?
>I'll test it and let you
>know.
Please clearly state what version of Perl you are using.
I want to skip your posts if it is not 5.005_03 or better.
I don't want to have to keep remembering how you used to have
to do things.
>BTW, how would you amend the above code to allow for filtering some
>parent-level directories from search--i.e. out of say six folders in "."
>I only really want to search through 2 or 3, disregarding the rest.
Take them out of the @_ array before you call find() if you
don't want them to be searched.
--
Tad McClellan SGML consulting
tadmc@augustmail.com Perl programming
Fort Worth, Texas
------------------------------
Date: 23 Nov 2001 18:29:49 -0800
From: jemptyg@rwmc.net (George Jempty)
Subject: Re: Which ISPs support perl scripts?
Message-Id: <2ecd96e6.0111231829.4e528e35@posting.google.com>
owain@nospam.demon.co.uk (Owain McGuire) wrote in message news:<3bfd4b80.174598719@news.demon.co.uk>...
> The thing that took the time was ibuilding a local development
> environment i.e. Apache, MySql, DBI and various modules etc. Oh and I
> had never used Linux before so I had to install that too.
For a complete environment as such you might investigate "Indigo" Perl
available at indigostar.com: Apache, Perl and mod_perl, or, better
yet, Nusphere (nusphere.com): Apache, Perl, mod_perl, mySQL, PHP, the
necessary DBI, ODBC and JDBC drivers, etc. Warning, you may have to
dig on their site a bit for the free download, toward the bottom of
the "download/freebies" page I think. And they'll want you to
"register", and it's 30 MEG or so
HTH
------------------------------
Date: Sat, 24 Nov 2001 04:08:52 GMT
From: tadmc@augustmail.com (Tad McClellan)
Subject: Re: Which ISPs support perl scripts?
Message-Id: <slrn9vu3tq.1v5.tadmc@tadmc26.august.net>
E.Chang <echang@netstorm.net> wrote:
>tadmc@augustmail.com (Tad McClellan) wrote in
>news:slrn9vq1fp.sk5.tadmc@tadmc26.august.net:
>
>> Chris Clarke <mad-biker@couplands-well.freeserve.co.uk> wrote:
>>
>>>As an absolute perl beginner... how do I find an ISP which supports
>>>perl scripts?
>>
>> I recommend that you don't try to learn both the application area
>> (CGI) and the programming language at the same time.
>>
>> Learn Perl first. When you are comfortable with Perl, then move
>> on to whatever application area you wish to apply Perl to.
>
>I humbly disagree.
You seem to disagree only in the order that things should be tackled.
Me: Perl then CGI
You: CGI then Perl
Either would be better than both at once.
>It's almost impossible to learn a new programming
>language without writing practice programs applying it to something,
You (generic "you" as in "the OP") can apply it to your real
web page thingy without doing it in a CGI environment.
Assume that you will have "everything available in a hash".
Write a little code that loads the hash (replace it with
a call to CGI.pm later). Do your "real stuff" and save the
HTML output to a file.
Do "Open file" on it with a browser to see what it looks like.
You can get 95% of the code debugged without the added variable
of a web server between your perl and the browser.
>Many learners find the assumed
>application area as much of a stumbling block as the language, which in
>one sense supports your statement,
That is exactly why I said what I said.
On the one hand, CGI is just input/output. The "guts" of the
program that does the interesting work will be (or can be anyway)
the same whether it runs from the command line or in a CGI
environment.
On the other hand, CGI adds some advanced things (multitasking,
file locking, performance may matter more than usual, etc...)
that are all lined up to trip you up, in addition to the
programming language used.
Whatever order you do it in, I think the primary thing to
strive for is to reduce the number of "variables" so you
can more easily find the problem(s).
Test it from the command line and bugs are either in your
Perl code or your OS/setup.
Test it in a CGI environment and bugs are in those places,
or in the web server setup, or in "someone else's OS"
(where you can't make significant changes), or in the
network, or...
>If the learner already knows something about programming, I believe
>that it is very possible to learn Perl in the context of CGI
>programming
I didn't say it was not possible. I did say it would be
sub-optimal though.
>as long as the CGI standards and constraints are clearly
>laid out in the study materials or otherwise learned before plunging
>into coding.
With my scenario above, you can plunge into coding without
knowing diddly-do about CGI/HTTP, you need only know your
"real" application area.
:-)
>One problem with many CGI tutorials (and some books) is
>that they just show code examples without discussing the CGI interface
>(and the HTTP protocol, especially its statelessness) in more than a
>few sentences.
I agree.
(it is no revelation that there are a lot of crappy "web books")
--
Tad McClellan SGML consulting
tadmc@augustmail.com Perl programming
Fort Worth, Texas
------------------------------
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.
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 V10 Issue 2194
***************************************
