;
chop($customer_data);
($id, $ip, $date, $time, $title, $first, $last, $company, $street1, $street2, $city, $state, $zip, $country, $email, $dphone, $dexten, $nphone, $nexten,$fax,$Shiptype,$Payby,$Cardtype, $Cardno, $Expyr, $Expmo, $Source, $Suggest) = split(/$delim/, $customer_data);
if (&UnQuote($ip) ne $ENV{'REMOTE_ADDR'})
{&Transmission_error(6);}
&UnQuote($id);&UnQuote($date);&UnQuote($time);&UnQuote($title);&UnQuote($first);&UnQuote($last);&UnQuote($company);&UnQuote($street1);&UnQuote($street2);&UnQuote($city);&UnQuote($state);
&UnQuote($zip);&UnQuote($country);&UnQuote($email);&UnQuote($dphone);&UnQuote($dexten);&UnQuote($nphone);&UnQuote($nexten);&UnQuote($fax);&UnQuote($Shiptype);&UnQuote($Payby);&UnQuote($Cardtype);&UnQuote($Cardno);&UnQuote($Expyr);&UnQuote($Expmo);&UnQuote($Source);&UnQuote($Suggest);
if ($Payby eq 'FIRST VIRTUAL') {
if ( $input{'X-OUTCOME'} eq "buy") {
if ($ENV{'HTTP_REFERER'} ne "http://$cgi_prog_location")
{&Transmission_error(7);}
}
elsif ($input{'X-OUTCOME'} eq "apply") {
print "\n";
print "Enter First Virtual vPIN\n";
print "\n";
print "Please check your email to activate your VirtualPIN!
";
print "and when you have completed the First Virtual application process,
";
print "press your browser's BACK button to go back to the registration
";
print "form and enter your new First Virtual vPIN press SUBMIT,
";
print "then press PLACE ORDER again.
";
print "Thank you.
\n";
exit;
} else
{
print "Unknown First Virtual Result: $input{'X-OUTCOME'} ???
";
exit;
}
}
$confirm .= "
" . ¢er('SALES INVOICE') . '
';
($hh, $mm, $ss) = split(/:/, $time);
$mm = sprintf("%02d", $mm);
if ($hh > 12)
{$hh -= 12; $time = "$hh:$mm" . 'pm';}
else
{
if ($hh == 0) {$hh = 12;}
$time = "$hh:$mm" . 'am';
}
$confirm .= "Invoice #: $id Invoice Date: $date Time: $time $local_time
";
$confirm .= "Sold To: $title $first $last
";
if ($company ne "")
{$confirm .= " $company
";}
$confirm .= " $street1
";
if ($street2 ne "")
{$confirm .= " $street2
";}
if (uc $country ne uc $catalog_country)
{$confirm .= " $city, $state $zip $country
";}
else
{$confirm .= " $city, $state $zip
";}
if ($dphone ne "") {
$confirm .= " Daytime Phone: $dphone";
if ($dexten ne "")
{$confirm .= " Ext: $dexten";}
$confirm .= "
";
}
if ($nphone ne "") {
$confirm .= " Evening Phone: $nphone";
if ($nexten ne "")
{$confirm .= " Ext: $nexten";}
$confirm .= "
";
}
if ($fax ne "")
{$confirm .= " Fax: $fax
";}
if ($email ne "")
{$confirm .= " Email: $email
";}
if ($Payby eq 'CREDIT') {
$confirm .= "
Paid by: $Payby $Cardtype ";
if (lc $online_credit_verify eq 'no')
{$confirm .= '(Subject to Verification) ';}
if (lc $cardno_on_email eq 'yes' && lc $use_secure_server ne 'yes')
{$confirm .= "
Card #: $Cardno Expires: $Expyr/$Expmo ";}
}
else
{$confirm .= "Paid by: $Payby ";}
$confirm .= "
Ship by: $Shiptype";
$confirm .= '
';
print "\n";
print "Order Confirmation\n";
print "\n";
print "Thank you very much for your order, you may print this screen out as a record ";
print "of your order, a copy has also been emailed to you.
";
if ($Payby eq 'CHECK') {
print "Send a copy of this form to the address below along with your check.
";
print "Make checks payable to: $Pay_checks_to
";
}
elsif ($Payby eq 'CREDIT') {
if ($online_credit_verify eq 'no')
{print "You will receive an email confirmation once your payment information has been verified.
";}
else
{print "Your Credit Card has been charged the Grand Total shown below.
";}
}
elsif ($Payby eq 'COD') {
print "Your order will be shipped COD for the Grand Total shown below. If you refuse delivery, you will still be charged for the COD charge shown below.
";
}
elsif ($Payby eq 'FIRST VIRTUAL') {
if ( $input{'X-OUTCOME'} eq "apply" ) {
print "Please check your email to activate your VirtualPIN!
";
print "after you have completed the First Virtual application process.
";
} else ### $input{'X-OUTCOME'} eq "buy"
{print "Please check your email from First Virtual to confirm your purchase.
";}
}
print "If you have any questions about your order, please reference your ";
print "order number when calling.
";
print "We appreciate your business and hope you will return soon.
";
print "-----------------------------------------------------------------------------------------------
";
$order_total = 0;
$total_quantity = 0;
$total_weight = 0;
$total_discount = 0;
$confirm .= "";
$confirm .= "------------------------------------------------------------------------
";
$confirm .= "Product ID Product Name Unit Price Qty Item Total
";
$confirm .= "------------------------------------------------------------------------
";
&load_orders; ##load orders file into an array
foreach $taxtype (@taxtypes) { ### first display taxable items, then other taxtype (e.g. non-taxable) items
if ($#orders > 0) {
if ($taxtype eq "" && $#taxtypes > 0)
{
$padlen = 10;
$confirm .= '-------------------- ** Taxable Items ** -------------------------------' . ('-' x $padlen) . '
';
}
elsif ($taxtype eq 'none')
{
$padlen = 10;
$confirm .= '------------------- ** NON Taxable Items **-----------------------------' . ('-' x $padlen) . '
';
}
elsif ($taxtype ne "")
{
$padlen = 10;
$confirm .= "------------------- ** $taxtype Tax Items ** ---------------------------" . ('-' x $padlen) . '
';
}
}
$sub_total = 0;
LOOP: foreach $i (0 .. $#orders) {
($order_id, $item_id, $item_name, $price, $quantity, $weight, $item_taxtype, $option1, $option2, $option3) = @{$orders[$i]};
if (lc $item_taxtype ne $taxtype)
{next LOOP;}
$item_id = &right($item_id,10);
$item_name_part = &left($item_name,20);
$total_weight += $weight * $quantity;
$item_total = $price * $quantity;
$quantity = &right($quantity,4);
$sub_total = $sub_total + $item_total;
$item_total = &right(&Currency($item_total),13);
$price = &right(&Currency($price),13);
$confirm .= "$item_id $item_name_part $price $quantity $item_total
";
$item_name = substr($item_name, 20);
while ($item_name ne "")
{
$item_name_part = &left($item_name,20);
$confirm .= " $item_name_part
";
$item_name = substr($item_name, 20);
}
if ($weight_caption ne "")
{
if ($weight > 0)
{$confirm .= " $weight_caption ($local_weight): $weight
"}
}
if ($option1_caption ne "")
{
if ($option1 ne "")
{$confirm .= " $option1_caption: $option1
"}
}
if ($option2_caption ne "")
{
if ($option2 ne "")
{$confirm .= " $option2_caption: $option2
"}
}
if ($option3_caption ne "")
{
if ($option3 ne "")
{$confirm .= " $option3_caption: $option3
"}
}
} ###foreach order detail
$sub_tot = &right(&Currency($sub_total),15);
$confirm .= '------------------------------------------------------------------------
';
$confirm .= " Sub Total: $sub_tot
";
if (&calculate_discount != 0) {
$discount_currency = &right($discount_currency,15);
$confirm .= ' Discount of ' . &right($Disc_Rate, 5) . "%: $discount_currency
";
$sub_tot = &right(&Currency($discount_total),15);
$confirm .= ' -------------------------------------------
';
$confirm .= " Sub Total: $sub_tot
";
}
if (&calculate_tax > 0) {
$tax_currency = &right($tax_currency,15);
$confirm .= ' ' . $state . ' State Tax @ ' . &right($Tax_Rate, 5) . "%: $tax_currency
";
}
if ($#taxtypes > 0) {
$tax_tot = &right(&Currency($tax_total),15);
$confirm .= ' -------------------------------------------' . ('-' x $padlen) . '
';
$confirm .= " Sub Total: " . (' ' x $padlen) . "$tax_tot
";
}
} ###foreach $taxtype
if (&calculate_shipping > 0) {
$shipping_currency = &right($shipping_currency,15);
$confirm .= " Shipping: " . (' ' x $padlen) . "$shipping_currency
";
}
if ($Payby eq 'COD') {
$cod_currency = &right($cod_currency,15);
$confirm .= " COD Charge: " . (' ' x $padlen) . "$cod_currency
";
}
if ($Handling > 0) {
$Handling_currency = &right($Handling_currency,15);
$confirm .= " Handling: " . (' ' x $padlen) . "$Handling_currency
";
}
$grand_total_currency = &right($grand_total_currency,15);
$confirm .= ' -------------------------------------------' . ('-' x $padlen) . '
';
$confirm .= ' Grand Total: ' . (' ' x $padlen) . "$grand_total_currency
";
$confirm .= "
" . ¢er('RETURN POLICY') . "
";
$confirm .= $return_policy;
print $confirm;
print "\n";
print "\n";
######### Now send email confirmation to Catalog Company and to Customer #######
$confirm =~ s'''g;
$confirm =~ s/<\/pre>|
/\n/g;
&sendmail($email, $company_email, "Order", $confirm); ### to Customer
if ($Source ne "")
{$confirm .= "\n\nHow did you find us? $Source\n";}
if ($Suggest ne "")
{$confirm .= "\n\nSuggestions? $Suggest\n";}
&sendmail($mail_order_to, $server_address, "Order", $confirm); ### to Catalog Company
}
#------------------------------------------------------------------#
sub load_orders
{
open (order_file, $order_file_name) || &err_trap("Cannot open $order_file_name for reading\n");
$index = 0;
@taxtypes = ();
while () { ### load the Orders file into an Array
chop;
($order_id, $item_id, $item_name, $price, $quantity, $weight, $item_taxtype, $option1, $option2, $option3) = split(/$delim/,$_);
&UnQuote($order_id); &UnQuote($item_id); &UnQuote($item_name); &UnQuote($price); &UnQuote($quantity); &UnQuote($weight); &UnQuote($item_taxtype); &UnQuote($option1); &UnQuote($option2); &UnQuote($option3);
$orders[$index] = [($order_id, $item_id, $item_name, $price, $quantity, $weight, $item_taxtype, $option1, $option2, $option3)];
$total_quantity += $quantity;
$total_price += $price * $quantity;
$found = 0;
foreach $taxtype (@taxtypes)
{
if (lc $item_taxtype eq $taxtype)
{$found = 1;}
}
if ($found == 0)
{push(@taxtypes, lc $item_taxtype);}
$index++;
}
close order_file;
}
#------------------------------------------------------------------#
sub sendmail
{
my($to, $from, $subject, $body) = @_;
if (lc $mail_via eq 'sendmail')
{
open (MAIL, "|$sendmail_loc -t -oi") || &err_trap("Can't open $sendmail_loc!\n");
print MAIL "To: $to\n";
print MAIL "From: $from\n";
print MAIL "Subject: $subject\n";
print MAIL "$body\n";
close MAIL;
}
else
{
if (lc $mail_via eq 'blat')
{
open (MAIL, "|$blat_loc - -t $to -s $subject") || &err_trap("Can't open $blat_loc!\n");
print MAIL "To: $to\n";
print MAIL "From: $from\n";
print MAIL "Subject: $subject\n"; print MAIL "$body\n\x1a";
close MAIL;
}
else
{
$err = &sockets_mail($to, $from, $subject, $body);
if ($err < 1)
{print "
\nSendmail error # $err
\n";}
}
}
}
#------------------------------------------------------------------#
sub sockets_mail
{
my ($to, $from, $subject, $message) = @_;
my ($replyaddr) = $from;
if (!$to) { return -8; }
my ($proto, $port, $smptaddr);
my ($AF_INET) = 2;
my ($SOCK_STREAM) = 1;
my ($sockaddr) = 'SnC4x8';
$proto = (getprotobyname('tcp'))[2];
$port = 25;
$smtpaddr = ($smtp_addr =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/)
? pack('C4',$1,$2,$3,$4)
: (gethostbyname($smtp_addr))[4];
if (!defined($smtpaddr)) { return -1; }
if (!socket(S, $AF_INET, $SOCK_STREAM, $proto)) { return -2; }
if (!connect(S, pack($sockaddr, $AF_INET, $port, $smtpaddr))) { return -3; }
my($oldfh) = select(S); $| = 1; select($oldfh);
$_ = ; if (/^[45]/) { close S; return -4; }
print S "helo localhost\r\n";
$_ = ; if (/^[45]/) { close S; return -5; }
print S "mail from: $from\r\n";
$_ = ; if (/^[45]/) { close S; return -5; }
print S "rcpt to: $to\r\n";
$_ = ; if (/^[45]/) { close S; return -6; }
print S "data\r\n";
$_ = ; if (/^[45]/) { close S; return -5; }
print S "X-Mailer: PerlShop Sendmail \r\n";
print S "Mime-Version: 1.0\r\n";
print S "Content-Type: text/plain; charset=us-ascii\r\n";
print S "To: $to\r\n";
print S "From: $from\r\n";
print S "Reply-to: $replyaddr\r\n" if $replyaddr;
print S "Subject: $subject\r\n\r\n";
print S "$message";
print S "\r\n.\r\n";
$_ = ; if (/^[45]/) { close S; return -7; }
print S "quit\r\n";
$_ = ;
close S;
return 1;
}
#------------------------------------------------------------------#
sub center
{
my $field = $_[0];
$padlen = ($line_length / 2) - (length($field) / 2);
$padding = " " x $padlen;
return $padding . $field;
}
#------------------------------------------------------------------#
sub right
{
my $field = $_[0];
my $field_size = $_[1];
$padlen = $field_size - length($field);
$padding = " " x $padlen;
return $padding . $field;
}
#------------------------------------------------------------------#
sub left
{
my $field = $_[0];
my $field_size = $_[1];
my $result;
if (length($field) > $field_size) {
$result = substr($field,0,$field_size);
}
else { $padlen = $field_size - length($field);
$padding = " " x $padlen;
$result = $field . $padding;
}
while (substr($result,0, 1) eq ' ')
{$result = substr($result, 1) . ' ';}
return $result;
}
#------------------------------------------------------------------#
sub zero_fill
{
my $field = $_[0];
my $field_size = $_[1];
if (length($field) > $field_size) {
return substr($field,0,$field_size);
}
else { $padlen = $field_size - length($field);
$padding = "0" x $padlen;
return $field . $padding;
}
}
#------------------------------------------------------------------#
sub require
{
my $field_name = $_[0];
my $field_val = $_[1];
if ($field_val eq "")
{
$error_msg .= "The field: \"$field_name\" is a required field.
";
return 0;
}
else
{return 1;}
}
#------------------------------------------------------------------#
sub check_email
{
my $mail_addr = $_[0];
if ($mail_addr eq "")
{return 0;}
if ($mail_addr =~ /^[\s]*[\w-.]+\@[\w-]+([\.]{1}[\w-]+)+[\s]*$/ )
{
return 1;
}
else {
$error_msg .= "Email address is not in the form: \"nobody\@nowhere.com\"
";
return 0;
}
}
#------------------------------------------------------------------#
sub check_file_title
{
my $file_title = $_[0];
if ($file_title eq "")
{
$error_msg = "Missing File Title\n";
return 0;
}
if ($file_title !~ /\.\./ )
{
return 1;
}
else {
$error_msg = "File Title '$file_title' is Invalid - Cannot contain '..' \n";
return 0;
}
}
#------------------------------------------------------------------#
sub check_zip { #Must be 5 or 9 digits for a US Zip Code
my $zip_code = $_[0];
my $zip_type = $_[1];
if (uc $zip_type eq 'US') {
if (!((length($zip_code) == 5) || (length($zip_code) == 9))) {
$error_msg .= 'Zip code must have 5 or 9 digits
';
return 0;
}
}
}
#------------------------------------------------------------------#
sub check_state {
my $state_code = $_[0];
my $state_type = $_[1];
if (uc $state_type eq 'US') {
$state_code = uc($state_code);
$sc{'AL'} = 'ok';$sc{'AK'} = 'ok';$sc{'AZ'} = 'ok';$sc{'AR'} = 'ok';$sc{'AS'} = 'ok';
$sc{'CA'} = 'ok';$sc{'CO'} = 'ok';$sc{'CT'} = 'ok';$sc{'DE'} = 'ok';$sc{'DC'} = 'ok';
$sc{'FL'} = 'ok';$sc{'GA'} = 'ok';$sc{'GU'} = 'ok';$sc{'HI'} = 'ok';$sc{'ID'} = 'ok';
$sc{'IL'} = 'ok';$sc{'IN'} = 'ok';$sc{'IA'} = 'ok';$sc{'KS'} = 'ok';$sc{'KY'} = 'ok';
$sc{'LA'} = 'ok';$sc{'ME'} = 'ok';$sc{'MD'} = 'ok';$sc{'MA'} = 'ok';$sc{'MI'} = 'ok';
$sc{'MN'} = 'ok';$sc{'MS'} = 'ok';$sc{'MO'} = 'ok';$sc{'MT'} = 'ok';$sc{'NE'} = 'ok';
$sc{'NV'} = 'ok';$sc{'NH'} = 'ok';$sc{'NJ'} = 'ok';$sc{'NM'} = 'ok';$sc{'NY'} = 'ok'; $sc{'NC'} = 'ok';$sc{'ND'} = 'ok';$sc{'OH'} = 'ok';$sc{'OK'} = 'ok';$sc{'OR'} = 'ok';
$sc{'PA'} = 'ok';$sc{'PR'} = 'ok';$sc{'RI'} = 'ok';$sc{'SC'} = 'ok';$sc{'SD'} = 'ok'; $sc{'TN'} = 'ok';$sc{'TT'} = 'ok';$sc{'TX'} = 'ok';$sc{'UT'} = 'ok';$sc{'VT'} = 'ok';
$sc{'VA'} = 'ok';$sc{'VI'} = 'ok';$sc{'WA'} = 'ok';$sc{'WV'} = 'ok';$sc{'WI'} = 'ok';
$sc{'WY'} = 'ok';
if ($sc{$state_code} eq 'ok')
{
return $state_code;
}
else
{
$error_msg .= 'State must be a valid 2 letter State abbreviation
';
return 0;
}
}
}
#------------------------------------------------------------------#
sub check_country {
my $country_code = $_[0];
if (length($country_code) != 2) {
$error_msg .= "$country_code is not a valid 2 letter Country Code.
";
return 0;
}
$country_code = lc $country_code;
$vc{'ad'} = 'ok';$vc{'ae'} = 'ok';$vc{'af'} = 'ok';$vc{'ag'} = 'ok';$vc{'ai'} = 'ok';
$vc{'al'} = 'ok';$vc{'am'} = 'ok';$vc{'an'} = 'ok';$vc{'ao'} = 'ok';$vc{'aq'} = 'ok';
$vc{'ar'} = 'ok';$vc{'as'} = 'ok';$vc{'at'} = 'ok';$vc{'au'} = 'ok';$vc{'aw'} = 'ok';
$vc{'az'} = 'ok';$vc{'ba'} = 'ok';$vc{'bb'} = 'ok';$vc{'bd'} = 'ok';$vc{'be'} = 'ok';
$vc{'bf'} = 'ok';$vc{'bg'} = 'ok';$vc{'bh'} = 'ok';$vc{'bi'} = 'ok';$vc{'bj'} = 'ok';
$vc{'bm'} = 'ok';$vc{'bn'} = 'ok';$vc{'bo'} = 'ok';$vc{'br'} = 'ok';$vc{'bs'} = 'ok';
$vc{'bt'} = 'ok';$vc{'bv'} = 'ok';$vc{'bw'} = 'ok';$vc{'by'} = 'ok';$vc{'bz'} = 'ok';
$vc{'ca'} = 'ok';$vc{'cc'} = 'ok';$vc{'cf'} = 'ok';$vc{'cg'} = 'ok';$vc{'ch'} = 'ok';
$vc{'ci'} = 'ok';$vc{'ck'} = 'ok';$vc{'cl'} = 'ok';$vc{'cm'} = 'ok';$vc{'cn'} = 'ok';
$vc{'co'} = 'ok';$vc{'cr'} = 'ok';$vc{'cs'} = 'ok';$vc{'cu'} = 'ok';$vc{'cv'} = 'ok';
$vc{'cx'} = 'ok';$vc{'cy'} = 'ok';$vc{'cz'} = 'ok';$vc{'de'} = 'ok';$vc{'dj'} = 'ok';
$vc{'dk'} = 'ok';$vc{'dm'} = 'ok';$vc{'do'} = 'ok';$vc{'dz'} = 'ok';$vc{'ec'} = 'ok';
$vc{'ee'} = 'ok';$vc{'eg'} = 'ok';$vc{'eh'} = 'ok';$vc{'er'} = 'ok';$vc{'es'} = 'ok';
$vc{'et'} = 'ok';$vc{'fi'} = 'ok';$vc{'fj'} = 'ok';$vc{'fk'} = 'ok';$vc{'fm'} = 'ok';
$vc{'fo'} = 'ok';$vc{'fr'} = 'ok';$vc{'ga'} = 'ok';$vc{'gb'} = 'ok';$vc{'gd'} = 'ok';
$vc{'ge'} = 'ok';$vc{'gf'} = 'ok';$vc{'gh'} = 'ok';$vc{'gi'} = 'ok';$vc{'gl'} = 'ok';
$vc{'gm'} = 'ok';$vc{'gn'} = 'ok';$vc{'gp'} = 'ok';$vc{'gq'} = 'ok';$vc{'gr'} = 'ok';
$vc{'gs'} = 'ok';$vc{'gt'} = 'ok';$vc{'gu'} = 'ok';$vc{'gw'} = 'ok';$vc{'gy'} = 'ok';
$vc{'hk'} = 'ok';$vc{'hm'} = 'ok';$vc{'hn'} = 'ok';$vc{'hr'} = 'ok';$vc{'ht'} = 'ok';
$vc{'hu'} = 'ok';$vc{'id'} = 'ok';$vc{'ie'} = 'ok';$vc{'il'} = 'ok';$vc{'in'} = 'ok';
$vc{'io'} = 'ok';$vc{'is'} = 'ok';$vc{'it'} = 'ok';$vc{'jm'} = 'ok';$vc{'jo'} = 'ok';
$vc{'jp'} = 'ok';$vc{'ke'} = 'ok';$vc{'kg'} = 'ok';$vc{'kh'} = 'ok';$vc{'ki'} = 'ok';
$vc{'km'} = 'ok';$vc{'kn'} = 'ok';$vc{'kp'} = 'ok';$vc{'kr'} = 'ok';$vc{'kw'} = 'ok';
$vc{'ky'} = 'ok';$vc{'kz'} = 'ok';$vc{'la'} = 'ok';$vc{'lb'} = 'ok';$vc{'lc'} = 'ok';
$vc{'li'} = 'ok';$vc{'lk'} = 'ok';$vc{'lr'} = 'ok';$vc{'ls'} = 'ok';$vc{'lt'} = 'ok';
$vc{'lu'} = 'ok';$vc{'lv'} = 'ok';$vc{'ly'} = 'ok';$vc{'ma'} = 'ok';$vc{'mc'} = 'ok';
$vc{'md'} = 'ok';$vc{'mg'} = 'ok';$vc{'mh'} = 'ok';$vc{'mk'} = 'ok';$vc{'ml'} = 'ok';
$vc{'mm'} = 'ok';$vc{'mn'} = 'ok';$vc{'mo'} = 'ok';$vc{'mp'} = 'ok';$vc{'mq'} = 'ok';
$vc{'mr'} = 'ok';$vc{'ms'} = 'ok';$vc{'mt'} = 'ok';$vc{'mu'} = 'ok';$vc{'mv'} = 'ok';
$vc{'mw'} = 'ok';$vc{'mx'} = 'ok';$vc{'my'} = 'ok';$vc{'mz'} = 'ok';$vc{'na'} = 'ok';
$vc{'nc'} = 'ok';$vc{'ne'} = 'ok';$vc{'nf'} = 'ok';$vc{'ng'} = 'ok';$vc{'ni'} = 'ok';
$vc{'nl'} = 'ok';$vc{'no'} = 'ok';$vc{'np'} = 'ok';$vc{'nr'} = 'ok';$vc{'nu'} = 'ok';
$vc{'nz'} = 'ok';$vc{'om'} = 'ok';$vc{'pa'} = 'ok';$vc{'pe'} = 'ok';$vc{'pf'} = 'ok';
$vc{'pg'} = 'ok';$vc{'ph'} = 'ok';$vc{'pk'} = 'ok';$vc{'pl'} = 'ok';$vc{'pm'} = 'ok';
$vc{'pn'} = 'ok';$vc{'pr'} = 'ok';$vc{'pt'} = 'ok';$vc{'pw'} = 'ok';$vc{'py'} = 'ok';
$vc{'qa'} = 'ok';$vc{'re'} = 'ok';$vc{'ro'} = 'ok';$vc{'ru'} = 'ok';$vc{'rw'} = 'ok';
$vc{'sa'} = 'ok';$vc{'sb'} = 'ok';$vc{'sc'} = 'ok';$vc{'sd'} = 'ok';$vc{'se'} = 'ok';
$vc{'sg'} = 'ok';$vc{'sh'} = 'ok';$vc{'si'} = 'ok';$vc{'sj'} = 'ok';$vc{'sk'} = 'ok';
$vc{'sl'} = 'ok';$vc{'sm'} = 'ok';$vc{'sn'} = 'ok';$vc{'so'} = 'ok';$vc{'sr'} = 'ok';
$vc{'st'} = 'ok';$vc{'su'} = 'ok';$vc{'sv'} = 'ok';$vc{'sy'} = 'ok';$vc{'sz'} = 'ok';
$vc{'tc'} = 'ok';$vc{'td'} = 'ok';$vc{'tf'} = 'ok';$vc{'tg'} = 'ok';$vc{'th'} = 'ok';
$vc{'tj'} = 'ok';$vc{'tk'} = 'ok';$vc{'tm'} = 'ok';$vc{'tn'} = 'ok';$vc{'to'} = 'ok';
$vc{'tp'} = 'ok';$vc{'tr'} = 'ok';$vc{'tt'} = 'ok';$vc{'tv'} = 'ok';$vc{'tw'} = 'ok';
$vc{'tz'} = 'ok';$vc{'ua'} = 'ok';$vc{'ug'} = 'ok';$vc{'uk'} = 'ok';$vc{'um'} = 'ok';
$vc{'us'} = 'ok';$vc{'uy'} = 'ok';$vc{'uz'} = 'ok';$vc{'va'} = 'ok';$vc{'vc'} = 'ok';
$vc{'ve'} = 'ok';$vc{'vg'} = 'ok';$vc{'vi'} = 'ok';$vc{'vn'} = 'ok';$vc{'vu'} = 'ok';
$vc{'wf'} = 'ok';$vc{'ws'} = 'ok';$vc{'ye'} = 'ok';$vc{'yt'} = 'ok';$vc{'yu'} = 'ok';
$vc{'za'} = 'ok';$vc{'zm'} = 'ok';$vc{'zr'} = 'ok';$vc{'zw'} = 'ok';
if ($vc{$country_code} ne 'ok') {
$error_msg .= "$country_code is not a valid 2 letter Country Code.
";
return 0;
}
}
#--------------------------------------------------------------#
sub check_phone { #Must be 6-18 digits with possible leading "+".
my $phone_no = $_[0];
my $phone_type = $_[1];
if ($phone_no eq "")
{return "";}
unless ((uc $phone_type eq 'US') || (uc $phone_type eq 'CA')) #check international phone (Must be 6-18 digits with possible leading "+")
{
if ($phone_no =~ /^[\s]*(\+?[\d\s]{6,26})[\s]*$/) {
$phone_no =~ tr/0-9\(\)\- /0-9/d; #Remove Non-digits
return $phone_no;
}
else {
$error_msg .= 'International Phone # is Not Valid
';
return 0;
}
}
else { #check US phone #
$phone_no =~ tr/0-9\(\)\- /0-9/d; #Remove Non-digits
### First Virtual requires Country Code even for US & Canada
if ((length($phone_no) == 11) && (substr($phone_no, 0, 1) eq '1')) {
$phone_no =~ /\d{1}([\d]{3})([\d]{3})([\d]{4})/;
$phone_no = sprintf("1(%3.3d)%3.3d-%4.4d", $1, $2, $3);
return $phone_no;
}
elsif (length($phone_no) != 10) {
$error_msg .= "Phone # \"$phone_no\" has: " . length($phone_no) . ' digits, Must Have 10 or 11 Digits
';
return 0;
}
else {
$phone_no =~ /([\d]{3})([\d]{3})([\d]{4})/;
$phone_no = sprintf("1(%3.3d)%3.3d-%4.4d", $1, $2, $3);
return $phone_no;
}
}
}
#------------------------------------------------------------------#
sub check_expire_date # check credit card expiration date
{
my $expire_month = $_[0];
my $expire_year = $_[1];
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
$mon++;
&Year2000($expire_year);
&Year2000($year);
if ($expire_year < $year || $expire_year == 99)
{
$error_msg .= 'Expiration year has passed
';
return 0;
}
elsif ($expire_year == $year)
{
if ($expire_month < $mon)
{
$error_msg .= 'Expiration Month has passed
';
return 0;
}
}
if ($expire_month > 12 || $expire_month < 1)
{
$error_msg .= 'Invalid Expiration Month
';
return 0;
}
return 1;
}
#------------------------------------------------------------------#
sub check_card_num #check credit card length, prefix and checkdigit
{ #See ANSI/ISO/IEC 7812-1-1993 Identification of Issuers - Part 1: Numbering System.
my $card_num = $_[0];
my $card_type = $_[1];
if ($card_num eq "")
{return 0;}
$card_num =~ tr/0-9 -/0-9/d; #Remove spaces and dashes.
if ($card_num =~ /\D{1,}?/) #Check for any other non-digits
{
$error_msg .= "Credit Card Number cannot contain a \"$1\" Character.
";
return 0;
}
$card_len = length($card_num);
unless ( ($card_type eq 'MasterCard' && $card_len == 16)
|| ($card_type eq 'Visa' && ($card_len == 13 || $card_len == 16))
|| ($card_type eq 'American Express' && $card_len == 15)
|| ($card_type eq 'Optima' && $card_len == 15)
|| ($card_type eq 'Carte Blanche' && $card_len == 15)
|| ($card_type eq 'Diners Club' && $card_len == 15)
|| ($card_type eq 'Discover' && $card_len == 16)
|| ($card_type eq 'JCB' && ($card_len == 15 || $card_len == 16)) )
{
$error_msg .= "A $card_type Credit Card # cannot have $card_len digits.
";
return 0;
}
$prefix_type{'35'} = 'JCB';
$prefix_type{'21'} = 'JCB';
$prefix_type{'18'} = 'JCB';
$prefix_type{'51'} = 'MasterCard';
$prefix_type{'52'} = 'MasterCard';
$prefix_type{'53'} = 'MasterCard';
$prefix_type{'54'} = 'MasterCard';
$prefix_type{'55'} = 'MasterCard';
$prefix_type{'4'} = 'Visa';
$prefix_type{'34'} = 'American Express';
$prefix_type{'37'} = 'American Express';
$prefix_type{'3707'} = 'Optima';
$prefix_type{'3717'} = 'Optima';
$prefix_type{'3727'} = 'Optima';
$prefix_type{'3737'} = 'Optima';
$prefix_type{'3747'} = 'Optima';
$prefix_type{'3757'} = 'Optima';
$prefix_type{'3767'} = 'Optima';
$prefix_type{'3777'} = 'Optima';
$prefix_type{'3787'} = 'Optima';
$prefix_type{'3797'} = 'Optima';
$prefix_type{'94'} = 'Carte Blanche';
$prefix_type{'95'} = 'Carte Blanche';
$prefix_type{'38'} = 'Carte Blanche';
$prefix_type{'30'} = 'Diners Club';
$prefix_type{'31'} = 'Diners Club';
$prefix_type{'35'} = 'Diners Club';
$prefix_type{'36'} = 'Diners Club';
$prefix_type{'38'} = 'Diners Club';
$prefix_type{'6011'} = 'Discover';
if ($card_type eq 'MasterCard') {$card_prefix = substr($card_num, 0, 2);}
elsif ($card_type eq 'Visa') {$card_prefix = substr($card_num, 0, 1);}
elsif ($card_type eq 'American Express') {$card_prefix = substr($card_num, 0, 2);}
elsif ($card_type eq 'Optima') {$card_prefix = substr($card_num, 0, 4);}
elsif ($card_type eq 'Carte Blanche') {$card_prefix = substr($card_num, 0, 2);}
elsif ($card_type eq 'Diners Club') {$card_prefix = substr($card_num, 0, 2);}
elsif ($card_type eq 'Discover') {$card_prefix = substr($card_num, 0, 4);}
elsif ($card_type eq 'JCB') {$card_prefix = substr($card_num, 0, 2);}
if ($prefix_type{$card_prefix} ne $card_type)
{
$error_msg .= "Invalid Credit Card # for a \"$card_type\" Card
";
return 0;
}
### Now do a LUHN MOD 10 check digit check on the card number.
$weight = 2;
$sum = 0;
for ($i = $card_len - 2; $i >= 0; $i--)
{
$curr_digit = substr($card_num, $i, 1);
$product = $weight * $curr_digit;
$ones= chop($product);
$sum += $ones + $product;
$weight = $weight % 2 + 1; ### 2->1, 1->2
}
if (substr($card_num, $card_len - 1, 1) == (10 - ($sum % 10)) % 10)
{
return 1;
}
else
{
$error_msg .= 'The Credit Card Number is Invalid
';
return 0;
}
}
#------------------------------------------------------------------#
sub SHA { ### This algorithm is based on the implementation of SHA
### written by: John Allen (allen@grumman.com).
### &SHA("squeamish ossifrage\n");
### Should return 82055066 4cf29679 2b38d164 7a4d8c0e 1966af57
my ($msg, $p, $l) = @_; #$p=0; $l=0
local $_;
$temp = 'D9T4C`>_-JXF8NMS^$#)4=L/2X?!:@GF9;MGKH8\;O-S*8L\'6';
$m = 4294967296;
###$m=1+~0;
@A=unpack"N*",unpack u,$temp;
@K=splice@A,5,4;
sub M{($x=pop)-($m)*int$x/$m};
sub L{$n=pop;($x=pop)<<$n|2**$n-1&$x>>32-$n}
@F=(sub{$b&($c^$d)^$d},$S=sub{$b^$c^$d},sub{($b|$c)&$d|$b&$c},$S);
do{
$msg=~s/.{0,64}//s;$_=$&;
$l+=$r=length;
$r++,$_.="\x80"if$r<64&&!$p++;@W=unpack N16,$_."\0"x7;$W[15]=$l*8
if$r<57; for(16..79){push@W,L$W[$_
-3]^$W[$_-8]^$W[$_-14]^$W[$_-16],1}($a,$b,$c,$d,$e)=@A;
for(0..79){$t=M&{$F[$_/ 20]}+$e+$W[$_]+$K[$_/20]+L$a,5; $e=$d; $d=$c;
$c=L$b,30; $b=$a; $a=$t}$v='a'; @A=map{ M$_+${$v++}}@A
}while$r>56;
return sprintf'%8x 'x4 . '%8x',@A;
}
#------------------------------------------------------------------#
sub calculate_tax {
$tax = 0;
$tax_total = $discount_total;
if (lc $taxtype eq 'none')
{return 0;}
else { #### Calculate for the Default Tax Type
#### Add Tax if tax should be added for the customer's State ####
if (uc $country eq 'US') {
foreach $Tax_State_Rate (@Tax_States) {
($Tax_State, $Tax_Rate) = split(/ /,$Tax_State_Rate);
if ($state eq $Tax_State) {
$tax = $sub_total * ($Tax_Rate / 100);
$tax = sprintf("%.2f", $tax);
$tax_currency = &Currency($tax);
$tax_total = $discount_total + $tax;
$order_total += $tax;
last;
}
}
}
return $tax;
}
}#sub
#------------------------------------------------------------------#
sub calculate_shipping {
$shipping = 0;
$grand_total = $order_total;
if (! ($shipping_type eq 'included' || $shipping_type eq 'none') )
{
if ($shipping_type eq 'quantity')
{$ship_amount = $total_quantity;}
elsif ($shipping_type eq 'weight')
{$ship_amount = $total_weight;}
else ##$shipping_type eq 'price'
{$ship_amount = $order_total;}
$country_uc = uc($country);
$country_found = 0;
### If Country not in shippping table use 'OTHER' entry for rates.
foreach $index(0..$#Shipping_Rates) {
($Ship_Country, $Shipper, $Ship_Min, $Ship_Max, $Ship_Mul, $Ship_Amt) = @{$Shipping_Rates[$index]};
if ($country_uc eq uc $Ship_Country)
{$country_found = 1;}
}
if ($country_found == 0)
{$country_uc = 'OTHER';}
foreach $index(0..$#Shipping_Rates) {
($Ship_Country, $Shipper, $Ship_Min, $Ship_Max, $Ship_Mul, $Ship_Amt) = @{$Shipping_Rates[$index]};
if ( ((($country_uc eq uc $Ship_Country) || ($Ship_Country eq 'ALL')) && ($Shiptype eq $Shipper) )
&& ($ship_amount >= $Ship_Min)
&& ($ship_amount <= $Ship_Max) )
{
if ($Ship_Mul eq '+')
{$shipping = $Ship_Amt}
elsif ($Ship_Mul eq '*')
{$shipping = $ship_amount * $Ship_Amt}
else ## $Ship_Mul eq '%' ##
{$shipping = $ship_amount * ($Ship_Amt / 100)}
$shipping = sprintf("%.2f", $shipping);
$shipping_total = $order_total + $shipping;
$shipping_currency = &Currency($shipping);
$grand_total = $shipping_total;
last;
} #if
} #foreach
} #else
if ($Payby eq 'COD') {
$grand_total += $cod_charge;
$cod_currency = &Currency($cod_charge);
}
$Handling = 0;
$country_found = 0;
foreach $index(0..$#Handling_table) {
($Handling_Country, $Handling_Amt) = @{$Handling_table[$index]};
if ( uc($country) eq uc($Handling_Country) )
{
$Handling = $Handling_Amt;
$country_found = 1;
last;
}
}
if ($country_found == 0)
{
($Handling_Country, $Handling_Amt) = @{$Handling_table[$#Handling_table]};
$Handling = $Handling_Amt;
}
$grand_total += $Handling;
$Handling_currency = &Currency($Handling);
$grand_total_currency = &Currency($grand_total);
return $shipping;
}#sub
#------------------------------------------------------------------#
sub calculate_discount {
$discount = 0;
$discount_total = $sub_total;
$order_total += $sub_total;
if (lc $discount_type eq 'quantity')
{$discount_amount = $total_quantity;}
elsif (lc $discount_type eq 'price')
{$discount_amount = $total_price;}
else
{return 0;}
foreach $index(0..$#Discount_Rates) {
($Disc_Min, $Disc_Max, $Disc_Rate) = @{$Discount_Rates[$index]};
if ( ($discount_amount >= $Disc_Min) && ($discount_amount <= $Disc_Max) )
{
$discount = - ($Disc_Rate * ($sub_total / 100) );
$discount = sprintf("%.2f", $discount);
$discount_total = $sub_total + $discount;
$order_total += $discount;
$total_discount += $discount;
$discount_currency = &Currency($discount);
last;
} #if
} #foreach
return $discount;
}#sub
#------------------------------------------------------------------#
sub show_shipping_rates {
print "\n";
print "Shipping Rates\n";
&add_company_header;
print "Shipping Rates
(based on $shipping_type)";
print "| Country | Shipper | Minimum $shipping_type | Maximum $shipping_type | Function | Amount |
";
$examples = 0;
foreach $index(0..$#Shipping_Rates) {
($Ship_Country, $Shipper, $Ship_Min, $Ship_Max, $Ship_Mul, $Ship_Amt) = @{$Shipping_Rates[$index]};
if ($Ship_Mul eq '%')
{$Ship_Amt = sprintf("%.2f", $Ship_Amt) . '%';}
else
{$Ship_Amt = &Currency($Ship_Amt) . ' ';}
print "| $Ship_Country | $Shipper | $Ship_Min | $Ship_Max | $Ship_Mul | $Ship_Amt |
";
if (($Ship_Mul eq '+' && $has_plus == 0) || ($Ship_Mul eq '*' && $has_mul == 0) || ($Ship_Mul eq '%' && $has_percent == 0)) {
$example[$examples] = "For example: If the Country is $Ship_Country and the Shipper is $Shipper and the total $shipping_type ordered was between $Ship_Min and $Ship_Max ";
if ($shipping_type eq 'quantity')
{$example[$examples] .= 'items';}
elsif ($shipping_type eq 'price')
{$example[$examples] .= $local_currency;}
elsif ($shipping_type eq 'weight')
{$example[$examples] .= $local_weight;}
$example[$examples] .= ', then you would ';
if ($Ship_Mul eq '+') {
$example[$examples] .= "add $Ship_Amt to your order.";
$has_plus = 1;
}
elsif ($Ship_Mul eq '*') {
$example[$examples] .= "multiply the $shipping_type times $Ship_Amt and add it to your order.";
$has_mul = 1;
}
elsif ($Ship_Mul eq '%') {
$example[$examples] .= "take $Ship_Amt of the $shipping_type and add it to your order.";
$has_percent = 1;
}
$examples += 1;
}
}
print '
';
print "Function '+' means add the Amount shown.
";
if ($shipping_type eq 'quantity')
{print " '*' means multiply the Quantity ordered times the Amount Shown.
";}
elsif ($shipping_type eq 'price')
{print " '%' means take the given percentage (shown as Amount) of the total order price.
";}
elsif ($shipping_type eq 'weight')
{print " '*' means multiply the total Weight times the Amount Shown.
";
print " '%' means take the given percentage (shown as Amount) of the total Weight
";}
print "
The rate shown for Country 'OTHER' applies to any country not explicitly listed.
";
foreach $index(0..$examples) {
print "
$example[$index]
";
}
print '
';
&add_company_footer;
}
#------------------------------------------------------------------#
sub add_button_bar {
my @buttons = @_;
print '';
if (($prev_page ne "") && ($catalog_page ne "") && ($prev_page ne $input{'THISPAGE'})) {
print " | ';
}
foreach $button(@buttons) {
print " | ';
}
print " | ";
if (($next_page ne "") && ($catalog_page ne "") && ($next_page ne $input{'THISPAGE'})) {
print " | ';
}
print '
';
}
#------------------------------------------------------------------#
sub add_menu_bar {
my @menus = @_;
$menu_bar = '';
if (($prev_page ne "") && ($catalog_page ne "") && ($prev_page ne $input{'THISPAGE'}))
{$menu_bar .= "[< Prev Page] ";}
foreach $menu(@menus) {
$menu_name = $menu;
$menu =~ tr / /+/; ### URL encode
$menu_bar .= "[$menu_name] ";
}
$menu_bar .= "[HOME] ";
if (($next_page ne "") && ($catalog_page ne "") && ($next_page ne $input{'THISPAGE'}))
{$menu_bar .= "[Next Page >] ";}
$menu_bar .= '
';
}
#------------------------------------------------------------------#
# Perl Routines to Manipulate CGI input
# S.E.Brenner@bioc.cam.ac.uk
# $Header: /people/seb1005/http/cgi-bin/RCS/cgi-lib.pl,v 1.2 1994/01/10 15:05:40 seb1005 Exp $
#
# Copyright 1993 Steven E. Brenner
# Unpublished work.
# Permission granted to use and modify this library so long as the
# copyright above is maintained, modifications are documented, and
# credit is given for any use of the library.
# ReadParse
# Reads in GET or POST data, converts it to unescaped text, and puts
# one key=value in each member of the list "@in"
# Also creates key/value pairs in %in, using '\0' to separate multiple
# selections
# If a variable-glob parameter (e.g., *cgi_input) is passed to ReadParse,
# information is stored there, rather than in $in, @in, and %in.
sub ReadParse {
local (*in) = @_;
local ($i, $loc, $key, $val);
# Read in text
if ($ENV{'REQUEST_METHOD'} eq "GET") {
$in = $ENV{'QUERY_STRING'};
} elsif ($ENV{'REQUEST_METHOD'} eq "POST") {
for ($i = 0; $i < $ENV{'CONTENT_LENGTH'}; $i++) {
$in .= getc;
}
}
else {
print "PerlShop version $PerlShop_version copyright (c) 1996-2000 by ARPAnet Corp.\n";
exit;
}
@in = split(/&/,$in);
foreach $i (0 .. $#in) {
# Convert plus's to spaces
$in[$i] =~ s/\+/ /g;
# Convert %XX from hex numbers to alphanumeric
$in[$i] =~ s/%(..)/pack("c",hex($1))/ge;
# Split into key and value.
$loc = index($in[$i],"=");
$key = uc substr($in[$i],0,$loc); ### uc function added by E.T.
$val = substr($in[$i],$loc+1);
$in{$key} .= '\0' if (defined($in{$key})); # \0 is the multiple separator
$in{$key} .= $val;
}
return 1; # just for fun
}
#------------------------------------------------------------------#
sub create_cookie {
my ($cookie_name, $cookie_value, $expire_days) = @_;
my $cookie;
$expiration_date = &create_expire_date($expire_days);
if ($use_cgiwrap eq 'yes')
{$minimum_cookie_path = $cgiwrap_directory;}
else
{$minimum_cookie_path = $cgi_directory;}
$cookie = "Set-Cookie: $cookie_name=$cookie_value; ";
$cookie .= "expires=$expiration_date; ";
$cookie .= "path=$minimum_cookie_path; ";
$cookie .= "domain=$server_address;";
print "$cookie\n";
}
#------------------------------------------------------------------#
sub create_expire_date {
my ($expire_days) = @_;
my (@day_of_week) = ( "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" );
my (@day_of_month) = ( "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" );
if ($expire_days < 0)
{$expiration_date = "Thu, 01-Jan-1970 00:00:01 GMT";}
else
{
$newtime = 86400 * $expire_days + time;
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($newtime);
&Year2000($year);
$expiration_date = "$day_of_week[$wday], $mday-$day_of_month[$mon]-$year 23:59:59 GMT";
}
return $expiration_date;
}
#------------------------------------------------------------------#
sub Year2000 {
my $year = $_[0];
if ($year < 100) {
if ($year < 90)
{$_[0] = 2000 + $year;}
else
{$_[0] = 1900 + $year;}
}
else ## >= 100 means getting year from localtime function
{$_[0] += 1900;}
if ($date_format !~ /yyyy/i ) ## if format is yy, take last 2 digits.
{
$_[0] = $_[0] % 100;
if ($_[0] < 10)
{$_[0] = "0" . $_[0];}
}
}
#------------------------------------------------------------------#
sub matchfile {
local($_,$file);
local(@list);
FILE: while (defined ($file = shift(@_))) {
if (-d $file) {
if (!opendir(DIR, $file))
{next FILE;}
@list = ();
for (readdir(DIR)) {
push(@list, "$file/$_") unless /^\.{1,2}$/;
}
closedir(DIR);
&matchfile(@list);
next FILE;
}
if (-B "$file") ### Don't search binary files
{next FILE;}
if (!open(FILE, $file))
{next FILE;}
LINE: while () {
if ( /((<([^A-Za-z]|[!\/]){1}?[^<]*?)|(^|>)[^<]*?)$pattern/o ) {
if ($matches == 0) {
print "
The pattern: \"$input{'SEARCH STRING'}\" was found on the following pages:
";
print '| Page | Pattern |
|---|
';
}
s{<([A-Za-z]|[!\/]){1}?[^<]*?($|>)}{}gs; ### remove html tags
s/$pattern/${SO}$&${SE}/go; ### highlight all matches on line
$filename = substr($file, rindex($file, '/') + 1);
print "
| $filename | $_ |
";
$matches++;
}
else
{next LINE;}
if ($input{'MATCHALL'} ne 'TRUE')
{next FILE;}
}
} continue {
}
}
#------------------------------------------------------------------#
sub create_log {
my $logfile = shift(@_);
my $TotalLockTime = 0;
### open the logfile for exclusive use, use a lock file as a semaphore,
$locktitle = "$logfile.lock";
while (-e $locktitle) ### check if lock file is in currently in use,
{
sleep 1; ### (i.e. wait until lock file does not exist)
$TotalLockTime++;
if ($TotalLockTime > 20) {unlink $locktitle;last;} ### failsafe mechanism for stray lock files
}
open (LOCKFILE, ">$locktitle"); ### if it doesn't exist, create it, thus locking the logfile exclusively.
open(log_file, ">>$log_directory/$logfile") || &err_trap("Cannot open $log_file_name for writing\n");
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
$mon++;
while (defined ($loginfo = shift(@_)))
{print(log_file "\"$loginfo\",");}
print(log_file "\"$mon/$mday/$year\",");
print(log_file "\"$ENV{'REMOTE_ADDR'}\"\n");
close log_file;
close LOCKFILE;
unlink $locktitle; ### now release the lock on the logfile.
}
#------------------------------------------------------------------#
sub format_time {
my $nowtime = $_[0];
local $_ = $_[1];
my $timetype = $_[2];
$x = "%A, %d-%b-%y";
$X = "%H:%M:%S %Z";
$c = "%A, %d-%b-%y %H:%M:%S %Z";
s/%x/$x/;
s/%c/$c/;
s/%X/$X/;
@sday=('Mon','Tue','Wed','Thu','Fri','Sat','Sun');
@lday=('Monday','Tuesday','Wednesday',
'Thursday','Friday','Saturday','Sunday');
@smon=('Jan','Feb','Mar','Apr','May','Jun',
'Jul','Aug','Sep','Oct','Nov','Dec');
@lmon=('January','February','March','April','May','June',
'July','August','September','October','November','December');
if ($timetype == 0)
{($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=gmtime($nowtime);}
else
{($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime($nowtime);}
if ($hour > 12)
{
$ampm = 'pm';
$hour12 = $hour - 12;
}
else {
$ampm = 'am';
if ($hour == 0)
{$hour12 = 12;}
else
{$hour12 = $hour;}
}
$yr2000 = &Year2000($year);
$yr = substr($year, 2);
$dweek = $yday / 7;
$dweek = sprintf("%u", $dweek);
s/%a/$sday[$day]/;
s/%A/$lday[$day]/;
s/%b/$smon[$mon]/;
s/%B/$lmon[$mon]/;
s/%d/$mday/;
s/%H/$hour/;
s/%I/$hour12/;
s/%j/$yday/;
s/%m/$mon/;
s/%M/$min/;
s/%p/$ampm/;
s/%S/$sec/;
s/%w/$wday/;
s/(%U|%W)/$dweek/;
s/%y/$yr/;
if ($timetype == 0)
{s/%Z/GMT/;}
else
{s/%Z/$local_time/;}
s/%Y/$yr2000/;
return $_;
}
#------------------------------------------------------------------#
sub err_trap {
my $errmsg = $_[0];
unlink "$logfile.lock";
print "\n\nA serious error has occured.
Please contact: $Reptile Isle and tell them ";
print "the error message below, and the exact sequence of events that led to the error.
Thank you.
$errmsg";
exit;
}