Posted by: citabriabob Jul 27 2020, 04:51 PM
This is the output of the Perl script. Only the last item was actually ordered; he rest are phantoms. All items come from the html as mentioned.
Your order was received; please let us know immediately if there are
any errors. Otherwise, we thank you for supporting the Club and we
will ship as follows:
To: Name / address
Email: cxxxx@yyyyyy.com
Member ID: 7393
Credit card ending with: 3853
----------------------------------------------------------------------
Qty Item Description Price Total
----------------------------------------------------------------------
28 MI-531K [Khaki] $15.95 $446.60
28 MI-531N [Navy] $15.95 $446.60
28 MI-531S [Stone] $15.95 $446.60
28 MI-531T [Taupe] $15.95 $446.60
28 MI-541N [Navy] $15.95 $446.60
28 MI-541S [Stone] $15.95 $446.60
28 MI-561K [Khaki] $15.95 $446.60
28 MI-561N C [Navy] $15.95 $446.60
28 MI-561S [Stone] $15.95 $446.60
28 MI-561T [Taupe] $15.95 $446.60
1 MI-970 Actual Item $99.95 $99.95
----------------------------------------------------------------------
Subtotal: $4565.95
Shipping: $18.00
----------------------------------------------------------------------
Total: $4583.95
This is the Perl code. it's been working weel for years except the occasional problem above
#!/usr/bin/perl
# order.cgi
#use DLSTools;
use CGI::Carp qw(fatalsToBrowser);
use strict;
use warnings;
#
# Variables and configuration
#
# Who.
my $salesman = 'orders@xxx.com';
my $make_receipt_contact_email = $salesman;
# What. Database file
my $pricelist = "prices.dat";
# Where.
my $homepage = "http://www.bellanca-championclub.com/";
# Why. Optional, used in all calls to print_errors().
my $print_errors_title = 'Order form error';
# Map field names to human-friendly titles.
my %form_field_title = (
# quotes, else leading zeros mean octal notation
'01last' => 'Last name',
'02first' => 'First name',
'03address1' => 'Address 1',
'04address2' => 'Address 2',
'05city' => 'City',
'06state' => 'State',
'07zip' => 'ZIP/P.C.',
'08country' => 'Country',
'09member' => 'Member ID',
'51CardNum' => 'Card num',
'57CardExpMonth' => 'Expiration month',
'58CardExpYear' => 'Expiration year',
'17email' => 'Email',
'21emailconfirm' => 'Email confirm',
'18tax' => 'Tax county',
'19comments1' => 'Comments 1',
'20comments2' => 'Comments 2',
'home_tel' => 'Home Telephone',
'bus_tel' => 'Business Telephone',
'32personalization' => 'Personalization',
);
# Items returned from the HTML form by item ID => qty. eg:
# 'MI-101' => 2,
# 'MI-321M' => '',
# 'MI-321S' => 1,
# Map stash names to human-friendly titles.
my %stash_field_title = (
last => 'Last name',
first => 'First name',
address1 => 'Address 1',
address2 => 'Address 2',
city => 'City',
state => 'State',
zip => 'ZIP/P.C.',
country => 'Country',
member_id => 'Member ID',
email => 'Email',
cc_num => 'CC Num digits',
cc_type => 'CC Type',
cc_num_formatted => 'CC Num',
cc_exp_mo => 'CC Exp Mo',
cc_exp_yr => 'CC Exp Yr',
cc_num_last_four => 'CC Last 4',
cc_exp_yr_yy => 'CC Exp Year',
tax => 'Tax county',
comments1 => 'Comments 1',
comments2 => 'Comments 2',
home_tel => 'Home Telephone',
bus_tel => 'Business Telephone',
personalization => 'Personalization',
);
# Map field names between form and stash
my @fts = (
'01last' => 'last',
'02first' => 'first',
'03address1' => 'address1',
'04address2' => 'address2',
'05city' => 'city',
'06state' => 'state',
'07zip' => 'zip',
'17email' => 'email',
'18tax' => 'tax',
'19comments1' => 'comments1',
'20comments2' => 'comments2',
'home_tel' => 'home_tel',
'bus_tel' => 'bus_tel',
'32personalization' => 'personalization',
);
my %form_to_stash = @fts;
my %stash_to_form = reverse @fts;
# Fields from stash to be used in sending order to purveyor.
# See delimited_report()
my @purveyor_report_fields = qw(
last
first
member_id
personalization
);
# Regular expression for Domestic or Foreign membership dues.
my $re_signup_dues = qr/^MI-(?:DOM|FOR|M)/;
# Regular expression for items which receive free shipping.
my $re_free_shipping_items = qr/^[AB]-418$/;
my $helper = DLSTools->new(
stash => {
},
);
#
# Execution
#
my $items = load_item_data($pricelist);
if ( !process_form(scalar $helper->http_data(), my $errors=[]) )
{
$helper->print_errors($errors, $print_errors_title);
}
else
{
my $receipt = make_receipt();
mail_order($salesman, $receipt);
mail_customer($helper->{stash}->{email}, $salesman, $receipt, $homepage);
display( $receipt, $homepage );
}
#
# Functions
#
# Check form for correctness, map values into $helper->{stash}
# $ok = process_form(\%form_data, \@errors);
# FUTURE: The stash is getting used for other data, perhaps the form data
# should be moved to stash->{form}? 2016-11-01 --rodney.broom
sub process_form
{
my ($data, $errors) = @_;
my @e;
my $s = $helper->{stash};
if (sanity_checks($data, \@e))
{
# Check credit card
my $card_num = $data->{'51CardNum'};
my ($exp_mo, $exp_yr) = @{$data}{qw(57CardExpMonth 58CardExpYear)};
my $cc_info = $helper->validate_card($card_num, $exp_mo, $exp_yr, \@e);
if ($cc_info)
{
$s->{'cc_'.$_} = $cc_info->{$_} foreach keys %{$cc_info};
}
# Have they ordered anything? This will add other meta to the stash.
if ( my $ordered = order_list($data, \@e))
{
$s->{ordered} = $ordered;
}
else
{
push @e, "It appears that no items were ordered.";
}
# Foreign or domestic?
my $country = $data->{'08country'} || '';
# is country some varient of United States of America?
if (
length($country) == 0
|| $country =~ /^\s*u\.?s\.?a?/i
|| $country =~ /united\s*states/i
)
{
$s->{foreign} = 0;
$s->{domestic} = 1;
$s->{country} = '';
}
else
{
$s->{foreign} = 1;
$s->{domestic} = 0;
$s->{country} = $country;
}
# Map remaining fields into the stash
for my $sname (keys %stash_to_form)
{
$s->{$sname} ||= $data->{ $stash_to_form{$sname} };
}
# Add formatting as needed
for my $k (qw(home_tel bus_tel))
{
$s->{$k} = $helper->format_phone($s->{$k});
}
}
push @{$errors}, @e;
return @e ? 0 : 1;
}
# Basic form checks
sub sanity_checks
{
my ($data, $errors) = @_;
my @e;
my $s = $helper->{stash};
# Required fields
# my @required = qw(01last 02first 03address1 05city 06state 07zip 17email);
my @required = qw(01last 02first 03address1 05city 17email);
my @missing;
for my $f (@required)
{
# exists() to quiet warnings
if ( !(exists($data->{$f}) and length($data->{$f})) )
{
push @missing, $f;
}
}
if (@missing)
{
push @e, sprintf qq|Missing some required fields: %s|,
join(', ', map $form_field_title{$_}, @missing);
}
# Email address
if ($data->{'17email'})
{
# email addr looks good (Email::Valid)
if ( ( $data->{'17email'} =~ /.+@.+\..+/ ) )
{
# doesn't match confirmation entry
if ( $data->{'17email'} ne $data->{'21emailconfirm'} )
{
push @e, "The email address was not entered the same on both lines. Please enter the same email address twice so that we can be sure to avoid typos.";
}
}
else
{
push @e, "The email address entered does not appear to be a valid address. Please enter an address in the form \"who\@where.com\".";
}
}
# If member is populated, then validata datum
if ( exists($data->{'09member'}) && length($data->{'09member'}) )
{
# Looks good, put it in the stash
if ( $data->{'09member'} =~ /^[0-9]{1,4}$/ )
{
$s->{member_id} = $data->{'09member'};
}
else
{
push @e, "The member ID number does not seem to be entered correctly.";
}
}
# '18tax' is required if '06state' eq 'NY'
if ($data->{'06state'} =~ /NY/i)
{
# reformat for easier testing later.
$data->{'06state'} = 'NY';
if (!$data->{'18tax'})
{
push @e, "If you live in New York State, we need to know your county for sales tax purposes.";
}
}
push @{$errors}, @e;
return @e ? 0 : 1;
}
# Load item data, return hashref.
# $data = load_item_data($file_name);
# Can terminate_to_browser().
sub load_item_data
{
my $file = shift;
open( DATA, $file ) || do {
warn qq|open($file): $!|;
terminate_to_browser(qq|CGI error: Could not open item data file.|);
};
my @data = <DATA>;
close(DATA);
my %item_data;
my $sequence = 0;
foreach (@data)
{
next if /^#/;
# Remove line endings be they DOS or UNIX or Mac
s/\r//g;
s/\n//g;
# Get the fields of data from this record
my ( $item_id, $desc, $memprice, $pubprice ) = split(/::/);
$item_data{$item_id} = {
sequence => ++$sequence,
item_id => $item_id,
desc => $desc,
memprice => $memprice,
pubprice => $pubprice,
};
# Is this item "shippable"?
if ( $item_id =~ m/$re_signup_dues/ || $item_id =~ m/$re_free_shipping_items/ )
{
$item_data{$item_id}->{'shippable'} = 0;
}
else
{
$item_data{$item_id}->{'shippable'} = 1;
}
}
return \%item_data;
}
# Build list of the items ordered, with quantities and prices.
# Determine several characteristics and note them in the stash.
# Returns undef on fail, else hashref of ordered items.
# $ordered = order_list(\%form_data, \@errors);
# $ordered = {
# $item_id1 => {qty => 2, price => 9.99},
# $item_id2 => {qty => 1, price => 55 },
# }
# Adds to errors:
# * Invalid quantity requested
#
# Stash items added:
# has_membership_dues
# is_membership_renewal
# is_new_signup
# is_non_member
# These are all boolean values that are either 0 or 1 (zero or one).
sub order_list
{
my ($data, $errors) = @_;
my $s = $helper->{stash};
my (%out, @e);
# Membership dues can be selected for both renewals and new signups
$s->{'has_membership_dues'} = (
grep {/$re_signup_dues/ && $data->{$_} > 0} keys( %{$data} )
) ? 1 : 0;
# Set defaults of zero for these, then calculate which will be set to one.
for ( qw(is_membership_renewal is_new_signup is_non_member) )
{
$s->{$_} = 0;
}
# Is this a membership renewal?
if ( $s->{'member_id'} and $s->{'has_membership_dues'} )
{
$s->{'is_membership_renewal'} = 1;
}
# Is this a NEW signup?
elsif ( $s->{'has_membership_dues'} )
{
$s->{'is_new_signup'} = 1;
}
# Else, is a non-member
else
{
$s->{'is_non_member'} = 1;
}
# Members and new signups get special pricing.
my $apply_member_price = ($s->{'member_id'} or $s->{'is_new_signup'}) ? 1 : 0;
# Look for items in the form data
for my $key ( keys %{$data} )
{
if ($items->{$key})
{
my $item = $items->{$key};
if (my $qty = $data->{$key})
{
# Confirm valid HTML form usage
if ($qty =~ /\D/)
{
push @e, "Please enter only numbers for the quantity of item $item->{desc}.";
}
# All OK; add data to our list and apply any special logic.
else
{
my $price = $apply_member_price ? $item->{memprice} : $item->{pubprice};
$out{$item->{item_id}} = {qty => $qty, price => $price};
# XXX future could check $item->{qty_in_stock}, etc. 2016-01-14 --rrb
# Knit shirts - count
if ($item->{'item_id'} =~ /^MI-3/)
{
$s->{'knit_shirt_count'} += $qty;
}
}
}
}
# looks like and item_id, but isn't in database
# XXX This does happen. 2016-01-14 --rrb
elsif ($key =~ /^(?:B-|FI-|MI-|A-)/)
{
# noop at the moment
}
}
push @{$errors}, @e;
return @e ? undef : (%out ? \%out : undef);
}
# wrapper to make reading easier
sub as_dollars
{
sprintf '$%.02f', $_[0];
}
# Build and send report to purveyor as attached file.
# This works, but was ultimately rejected for a more simple format.
sub delimited_report
{
my ($to, $receipt) = @_;
my $s = $helper->{stash};
my (@header, @rowone);
my @vertical;
for my $sname (@purveyor_report_fields)
{
push @header, $stash_field_title{$sname};
# Add datum, default to empty string to quiet warnings.
push @rowone, defined($s->{$sname}) ? $s->{$sname} : '';
# "Title: Datum\n"
next if $sname =~ /comment/;
push @vertical, swrite_nl('@<<<<<<<<<<<<<<<<<<< @*', $header[-1].':', $rowone[-1]);
}
my $comments = join "\n", map {defined($s->{$_}) ? ' '.$s->{$_} : ()} qw(comments1 comments2);
push @vertical, qq|Comments:\n$comments\n| if $comments;
my @item_header = qw(Item Qty Price Sub Description);
my @item_rows;
my $item_total = 0;
for my $item_id (sort keys %{$s->{ordered}})
{
my $oi = $s->{ordered}->{$item_id};
my $subtotal = $oi->{qty}*$oi->{price};
$item_total += $subtotal;
push @item_rows, [$item_id, $oi->{qty}, $oi->{price}, $subtotal, $items->{$item_id}->{desc}];
}
push @item_rows, ['', 'Item total:', '', '', sprintf('%.02f', $item_total), ''];
# XXX This would be better/safer with CSV. (Text::CSV) 2016-01-14 --rrb
my $delim = "\t";
my $file_content = '';
$file_content .= join($delim, @header)."\n";
$file_content .= join($delim, @rowone)."\n";
$file_content .= "\n";
$file_content .= join($delim, @item_header)."\n";
for my $i (@item_rows)
{
$file_content .= join($delim, @{$i})."\n";
}
my $customer_name = join(' ', $s->{first}, $s->{last});
(my $safe_name = $customer_name) =~ s/\W//g;
my @ymd = (localtime)[5, 4, 3];
$ymd[0] += 1900; $ymd[1] += 1;
my $today = sprintf('%04u-%02u-%02u', @ymd);
my $filename = sprintf('cgi-order-%s-%s.tsv', $today, $safe_name);
my $body = sprintf(qq|Order for %s is attached.\n\n%s\n%s\n%s\n|,
$customer_name,
q|----------------------------------------------------------------------
Customer Info
----------------------------------------------------------------------
|,
join('', @vertical),
$s->{item_table}
);
$helper->send_mail_attach_file({
to => $to,
from => $to,
subject => sprintf(qq|CGI Generated Order for %s|, $customer_name),
body => $body,
file_content => $file_content,
filename => $filename,
content_type => 'text/tab-separated-values',
}) || terminate_to_browser(qq|CGI error: Order was not sent.|);
}
# Email order to the purveyor for processing.
sub mail_order
{
my $to = shift;
my $receipt = shift;
my $s = $helper->{stash};
my $subject = sprintf(qq|CGI Generated Order for %s|, join(' ', $s->{first}, $s->{last}));
# Build CSV record of the order
my (@csv_header, @csv_fields);
# Customer information
for my $sname (@purveyor_report_fields)
{
my $title = stash_field_title($sname);
push @csv_header, qq|"$title"|;
my $datum = $s->{$sname};
# Display situation in 'member_id' for new signups
if ( $sname eq 'member_id' and $s->{'is_new_signup'} )
{
$datum = 'Membership Pending';
}
# Personalization in uppercase
elsif ( $sname eq 'personalization' )
{
$datum = uc($datum);
}
push @csv_fields, csv_escape_and_quote($datum);
}
# We want a blank column, used in the office with Excel
push @csv_header, csv_escape_and_quote('');
push @csv_fields, csv_escape_and_quote('');
my @item_header;
my @item_fields;
for my $item_id (
# sort items by sequence found in item-data file
sort { $items->{$a}->{'sequence'} <=> $items->{$b}->{'sequence'} }
keys %{$items}
)
{
my $quantity = ''; # Robert wants blank, not zero.
if ( my $order_item = $s->{ordered}->{$item_id} )
{
$quantity = $order_item->{'qty'};
}
push @item_header, csv_escape_and_quote($item_id);
push @item_fields, csv_escape_and_quote($quantity);
}
push @csv_header, @item_header;
push @csv_fields, @item_fields;
# Should the CSV content include the header record?
# Set to one to turn on the header record, zero to turn off.
my $include_csv_header = 0;
my $csv_data = $include_csv_header
? join(',', @csv_header) . "\n" . join(',', @csv_fields)
: join(',', @csv_fields);
my $body = sprintf qq|%s %s Exp: %s/%s Zip: %s Total: %s\n\n%s\n%s\n\n%s\n|,
($s->{cc_type}, $s->{cc_num_formatted}, $s->{cc_exp_mo}, $s->{cc_exp_yr}),
$s->{zip}, as_dollars($s->{order_total}),
$csv_data,
$receipt;
$helper->send_mail({
to => $to,
from => $to, # XXX DLSTools can provide a default. 2016-01-14 --rrb
subject => $subject,
body => $body,
}) || terminate_to_browser(qq|CGI error: Order was not sent.|);
}
# Find a title for stash field name, failing to alternates.
sub stash_field_title
{
my $sname = shift;
$stash_field_title{$sname} || $form_field_title{ $stash_to_form{$sname} } || $sname;
}
# Format a value to be valid as a field in a CSV record.
sub csv_escape_and_quote
{
my $datum = shift;
$datum = '' unless defined($datum);
$datum =~ s/"/""/g;
qq|"$datum"|;
}
# Send email to the customer, currently only used for the receipt.
sub mail_customer
{
my ( $to, $from, $receipt, $website ) = @_;
return $helper->send_mail({
to => $to,
from => $from,
subject => "Your order on $website",
body => $receipt,
}) || terminate_to_browser(q|CGI error: Was unable to send the customer's copy of the receipt.|);
}
# Make a formatted text receipt.
sub make_receipt
{
my $s = $helper->{stash};
# Formats and strings for rendering the plain text receipt.
#
# 70 chars wide
my $row_width = 70;
# horizontal rule
my $hr = sprintf '-' x $row_width;
# Line item layout, five columns.
my $desc_fmt = sprintf '@%s...', '<' x (38 - 4);
# 3 10 38 7 8
my $item_fmt = sprintf q|@## @<<<<<<<<< %s @>>>>>> @>>>>>>>|, $desc_fmt;
# Header record, same as item with numeric changed to text
(my $head_fmt = $item_fmt) =~ s/#/>/g;
# Two inputs; one left the other right.
my $pair_fmt = sprintf(q|@%s@%s|, '<'x(15-1), '>'x($row_width-15-1));
# Entire line justified left or right, respectively
my $line_left_fmt = sprintf('@%s', '<'x($row_width-1));
my $line_right_fmt = sprintf('@%s', '>'x($row_width-1));
# Build receipt
#
#- Customer information, etc.
# NB This content is set by hand to be inside the width of $row_width
# rather than writing fancy wrapping logic for three lines.
# Template Toolkit would help. 2016-01-14 --rrb
my $disp_addr2 = $s->{address2} ? "\n $s->{address2}" : '';
# Display Member ID or member status
my $disp_member;
if ( $s->{'member_id'} )
{
$disp_member = $s->{'member_id'};
}
elsif ( $s->{'is_new_signup'} )
{
$disp_member = 'New Member';
}
else
{
$disp_member = 'Non-member';
}
my $receipt = <<CUST_INFO_BLOCK;
Please note: If you are using Chrome and autofill, you may notice unordered items with unusual quantities;
this is a Chrome issue and we will eliminate them on receipt.
Your order was received; please let us know immediately if there are
any errors. Otherwise, we thank you for supporting the Club and we
will ship as follows:
To: $s->{'first'} $s->{'last'}
$s->{'address1'}$disp_addr2
$s->{'city'}, $s->{'state'}, $s->{'zip'}
$s->{country}
Email: $s->{email}
Member ID: $disp_member
Credit card ending with: $s->{cc_num_last_four}
CUST_INFO_BLOCK
#- Financial
# Column headers
$receipt .= "$hr\n";
$receipt .= swrite_nl($head_fmt, qw(Qty Item Description Price Total));
$receipt .= "$hr\n";
my $ordered = $s->{ordered};
# Calculate base item price and write items to the receipt
#
my $cumulative; # cummulative price
my $not_shippable; # Dollar total of items which are not shippable.
for my $item_id ( sort keys %{$ordered} )
{
my $oi = $ordered->{$item_id}; # Ordered Item
if ( my $qty = $oi->{qty} ) # should always be true
{
my $item_total = $qty * $oi->{price};
$cumulative += $item_total;
# Items that are "not shippable"
if ( not $items->{$item_id}->{'shippable'} )
{
$not_shippable += $item_total;
}
my $pf = as_dollars($oi->{price});
my $itf = as_dollars($item_total);
$receipt .= swrite_nl($item_fmt, $qty, $item_id, $items->{$item_id}->{desc}, $pf, $itf);
}
}
# Personalization of knit shirts
if ( $s->{'knit_shirt_count'} and $s->{'personalization'} )
{
my $personalization_fee_per_shirt = 5.00; # Dollars
my $personalization_total = $s->{'knit_shirt_count'} * $personalization_fee_per_shirt;
$receipt .= swrite_nl($item_fmt,
$s->{'knit_shirt_count'}, '', 'Personalization (Knit Shirts Only)',
as_dollars($personalization_fee_per_shirt), as_dollars($personalization_total)
);
# Using header record format since it allows completely empty fields.
$receipt .= swrite_nl($head_fmt, '', '', qq|To read: "$s->{'personalization'}"|, '', '');
$cumulative += $personalization_total;
}
# Subtotal
$receipt .= "$hr\n";
$receipt .= swrite_nl($pair_fmt, 'Subtotal:', as_dollars($cumulative));
$receipt .= "\n";
# Calculate domestic shipping
my $shipping = 0;
if ( $s->{domestic} )
{
# Special case, this product always incurs a shipping fee. Sun Shield
if ($ordered->{'MI-970'})
{
$shipping = $ordered->{'MI-970'}->{qty} * 18;
}
else
{
# Count of all shippable items
my $count_shippable;
for my $item_id (keys %{$ordered})
{
$count_shippable += $ordered->{$item_id}->{'qty'} if $items->{$item_id}->{'shippable'};
}
$s->{'shippable_subtotal'} = ($cumulative - $not_shippable);
# Shipping is charged for orders under $200, but we only include
# tangible (shippable) items when considering free shipping.
# Items like dues can't be shipped, so are deducted.
if ( $s->{'shippable_subtotal'} > 0 && $s->{'shippable_subtotal'} < 200 )
{
# Calculate shipping fee by number of items
# 5 or more
if ($count_shippable >= 5)
{
$shipping = 14.50;
}
# 3 or 4
elsif ($count_shippable >= 3)
{
$shipping = 9.00;
}
# 2 or less, default shipping fee
else
{
$shipping = 7.50;
}
}
else
{
# noop, free
}
}
$cumulative += $shipping;
$receipt .= swrite_nl($pair_fmt, 'Shipping:', $shipping ? as_dollars($shipping) : 'Free');
}
# Total
$receipt .= "$hr\n";
$receipt .= swrite_nl($pair_fmt, 'Total:', as_dollars($cumulative));
$s->{order_total} = $cumulative;
# Special case shipping notes
if ($s->{foreign})
{
$receipt .= swrite_nl($line_right_fmt, '* plus shipping costs (added at cost)');
}
if ( $s->{domestic} && $s->{state} eq 'NY' )
{
$receipt .= swrite_nl($line_right_fmt, '* plus Sales Tax (NY only)');
}
#- Notes to and from the customer
$receipt .= qq|
Comments: $s->{comments1}
$s->{comments2}
Please note: If you are using Chrome and autofill, you may notice unordered items with unusual quantities; this is a Chrome issue and we will eliminate them on receipt.
If you have any questions or corrections, please contact us at $make_receipt_contact_email anytime,
or call 518-731-6800 (Mon-Fri 11-6 Eastern Time.)
Thanks for shopping with us!
Bellanca-Champion Club
|;
return $receipt;
}
sub display
{
my ( $receipt, $website ) = @_;
my $s = $helper->{'stash'};
my $email_bodies;
if ( $s->{'email_bodies'} )
{
$email_bodies = qq|<hr/><h2>Email Bodies:</h2><hr/>\n|;
for my $body ( @{$s->{'email_bodies'}} )
{
$email_bodies .= qq|<pre>$body</pre>\n<hr/>\n|;
}
}
print <<"ENDOFBLOCK";
Content-type: text/html
<HTML>
<HEAD>
<TITLE>Your order has been processed</TITLE>
</HEAD>
<BODY bgcolor=#FFFFFF>
<CENTER><B>Bellanca-Champion Club</B></CENTER>
<P> </p>
<HR width=90% />
<P> </p>
<PRE>
$receipt
</PRE>
<P> </p>
<HR width=90% />
<P>
Feel free to continue looking through the <A href="$website">Bellanca-ChampionClub.com</A> web site!
</p>
$email_bodies
</BODY>
</HTML>
ENDOFBLOCK
}
# swrite() with a newline
sub swrite_nl
{
$helper->swrite(@_) ."\n";
}
# Send a formatted message and exit.
# terminate_to_browser($string)
# terminate_to_browser(@strings)
# terminate_to_browser(\@strings)
#
# Wrapper to DLSTools::print_exceptions()
sub terminate_to_browser
{
$helper->print_exceptions(ref($_[0]) ? $_[0] : [@_]);
exit;
}
package DLSTools;
=pod
=head1 NAME
DLSTools - Collection of functionality and configuration.
=head1 SYNOPSIS
use DLSTools;
$obj = DLSTools->new(%options);
$obj->send_mail(\%args);
=cut
use POSIX 'strftime';
use strict;
=pod
=head1 VARIABLES
Package globals that I<can> be adjusted, but should probably be left as is.
=over 4
=item *
sendmail_opts
Options to pass to sendmail. Default:
Default:
$sendmail_opts =
'-O DeliveryMode=b'; # Asynchronous delivery (faster return to browser)
=back
=cut
use vars qw(
$sendmail_opts
);
$sendmail_opts =
'-O DeliveryMode=b'; # Asynchronous delivery (faster return to browser)
# XXX This value was taken from order.cgi, likely a better option available. 2016-01-07 --rrb
my $site_admin_email = 'gifts@bellanca-championclub.com';
# Default 'From' address when none is included in args.
my $email_sender = 'emailsender@bellanca-championclub.com';
=pod
=head1 METHODS
=head2 new()
Create an object instance.
$obj = Class->new(\%opt);
=head3 %opt specifically supports:
=over 4
=item *
safe_email_recip
For safe testing, makes all mail go to address given.
safe_email_recip => 'recipient@example.com'
No default.
=item *
site_admin_email
Address used in some messaging.
Default: gifts@bellanca-championclub.com
=item *
email_sender
Default 'From' address when none is included in args.
Default: 'emailsender@abellanca-championclub.com';
=item *
me
A name for the object to use when needed.
Default is the root file name of executor. eg:
That is, if $0='/path/to/script.fil', then I<me> = "script.fil".
=back
=head3 Other parameters to C<new()>.
Since there are no accessors/mutators, any other fields may be used as desired.
For instance, to stash values to carry around in a script you could:
$obj = DSLTools->new(
stash => {title => 'My Title'},
);
print $obj->{stash}->{title};
=cut
sub new
{
my $class = shift;
(my $me = $0) =~ s/.*?([^\/\\]+)$/$1/;
return bless {
site_admin_email => $site_admin_email,
email_sender => $email_sender,
me => $me,
@_
}, $class;
}
=pod
=head2 print_errors()
Send a list of messages as HTML.
$obj->print_errors(\@messages, $title);
$title is optional, defaults to 'Form Error'
=cut
sub print_errors
{
my $self = shift;
my $errors = shift;
my $title = shift || 'Form Error';
my $error_list_items
= join("\n", map sprintf(qq|<li style="font-weight: bold;">%s</li>|, $_), @{$errors});
print <<"ENDOFBLOCK";
Content-type: text/html
<HTML>
<HEAD>
<TITLE>$title</TITLE>
</HEAD>
<BODY bgcolor=#FFFFFF>
<CENTER><H1>Bellanca-Champion Club</H1></CENTER>
There appears to be a problem with the information that you entered.
<P>
<ul>
$error_list_items
</ul>
</p>
<P>
Please press the "Back" button on your web browser and make
the appropriate changes so that we can process your application.
</p>
<P>
If you continue to have problems, feel free to email $self->{site_admin_email}
for assistance.
</p>
</BODY>
</HTML>
ENDOFBLOCK
}
=pod
=head2 print_exceptions()
Send a list of messages as HTML.
$obj->print_exceptions(\@messages, $title);
# do some cleanup work...
exit();
$title is optional, defaults to 'Exception'
Note: The name is 'exceptions' to differentiate from 'errors', but this method
does not actually die(), or even exit().
=cut
sub print_exceptions
{
my $self = shift;
my $msgs = shift;
my $title = shift || 'Exception';
my $exception_list_items
= join("\n", map sprintf(qq|<li style="font-weight: bold;">%s</li>|, $_), @{$msgs});
print <<"ENDOFBLOCK";
Content-type: text/html
<HTML>
<HEAD>
<TITLE>$title</TITLE>
</HEAD>
<BODY bgcolor=#FFFFFF>
<CENTER><H1>Bellanca-Champion Club</H1></CENTER>
There appears to have been one or more exceptional conditions:
<P>
<ul>
$exception_list_items
</ul>
</p>
<P>
Please notify $self->{site_admin_email} so that this can be fixed.<br/>
Thank you.
</p>
</BODY>
</HTML>
ENDOFBLOCK
}
=pod
=head2 send_mail()
Send text email to recipient.
$obj->send_mail(\%args)
For backwards compatability, list context is also supported:
$obj->send_mail($to, $cc, $from, $subject, $body)
%args supports:
- Required:
to
subject
body
- Optional:
from # Defaults to $obj->{email_sender}
cc
Returns _send_mail()
See _envelope_headers()
Honors $helper->{'stash'}:
email_bodies_to_stash
If true, push email bodies into @{$helper->{'stash'}->{'email_bodies'}}
do_not_send_email
If true, do not actually send email.
=cut
sub send_mail
{
my $self = shift;
my $param;
if (ref $_[0])
{
$param = shift;
}
else
{
@{$param}{qw(to cc from subject body)} = @_;
}
if ( $helper->{'stash'}->{'email_bodies_to_stash'} )
{
push @{$helper->{'stash'}->{'email_bodies'}}, $param->{'body'};
}
return 1 if $helper->{'stash'}->{'do_not_send_email'};
my $headers = $self->_envelope_headers($param);
$self->_send_mail(join("\n", $headers, '', $param->{body}));
}
=pod
=head2 send_mail_attach_file()
Sends an email message with a single attached file.
$obj->send_mail_attach_file(\%args);
%args supports:
- Required:
to
subject
body
file_content
- Optional:
from # Defaults to $obj->{email_sender}
cc
filename # default: "unnameded-" . $obj->{me} . ".txt"
content_type # default: text/plain
Returns _send_mail()
See _envelope_headers()
=cut
sub send_mail_attach_file
{
my $self = shift;
my $param = shift;
my $envelope_headers = $self->_envelope_headers($param);
my $boundary = join('_', '_----------=', $self->{me}, time());
my $body_length = length($param->{body});
my $filename = $param->{filename} || "unnammed-$self->{me}.txt";
my $content_length = length($param->{file_content});
my $content_type = $param->{content_type} || 'text/plain';
my $message = <<EOC;
Content-Transfer-Encoding: 7bit
Content-Type: multipart/mixed; boundary="$boundary"
MIME-Version: 1.0
$envelope_headers
This is a multi-part message in MIME format.
--$boundary
Content-Disposition: inline
Content-Length: $body_length
Content-Transfer-Encoding: binary
Content-Type: text/plain
$param->{body}
--$boundary
Content-Disposition: attachment; filename="$filename"
Content-Length: $content_length
Content-Transfer-Encoding: binary
Content-Type: text/plain; name="$filename"
$param->{file_content}
--$boundary--
EOC
$self->_send_mail($message);
}
=pod
=head2 _send_mail()
Send content into sendmail.
$obj->_send_mail($complete_message)
This means headers, body, the break between them.
Returns success on closing a handle, which should be useful.
Can raise an exception, which is formatted for CGI when applicable.
This messaging is to support being used from the shell.
=cut
sub _send_mail
{
my $self = shift;
my $message = shift;
# Redirect stdout to stderr, since stdout confuses apache
# The mess around die() is to send messaging based on CGI or not.
open( MAIL, "|/usr/sbin/sendmail $sendmail_opts -t 1>&2" )
|| do {
my $warning = "Sendmail failed: $! ($?)";
if ($ENV{GATEWAY_INTERFACE})
{
# get the message into the logs
warn $warning;
print
"Content-type: text/text\n"
. "\n"
. "CGI error: Can not open sendmail.\n"
. "Please report this error to $self->{site_admin_email} so that it may be fixed.\n"
. "Thank you.\n\n";
exit;
}
else
{
die $message;
}
};
print MAIL $message."\n";
return close(MAIL);
}
=pod
=head2 _envelope_headers()
Assemble standard envelope headers.
Return is list of headers or string of new line separated, based on call
context.
@headers = $obj->_envelope_headers(\%params);
$string = $obj->_envelope_headers(\%params);
# $string is: join("\n", @headers)
print qq|$string\n$more_headers\n\n$body|;
Supported input fields: to, cc, from, subject
Honors: safe_email_recip, email_sender.
Adds: "X-Mailer: $obj->{me}", "Date"
>From header defaults to $obj->{email_sender}
=cut
sub _envelope_headers
{
my $self = shift;
my $param = shift;
my $to = $param->{to};
my $cc = $param->{cc};
my $from = $param->{from} || $self->{email_sender};
# For testing, makes all mail go to safe_email_recip.
if ($self->{safe_email_recip})
{
$to = $self->{safe_email_recip};
$cc &&= $self->{safe_email_recip};
}
my $date = strftime '%a, %e %b %Y %H:%M:%S %Z', localtime;
my @headers = (
"To: $to",
"From: $from",
"Subject: $param->{subject}",
"Date: $date",
"X-Mailer: $self->{me}",
);
push @headers, "Cc: $cc" if $cc;
return wantarray ? @headers : join("\n", @headers);
}
=pod
=head2 http_data()
Get data using the CGI (Common Gateway Interface).
Returns in a hash or ref based on call context. List context is supported
for backward compatibility.
$data = $obj->http_data();
%data = $obj->http_data();
Return can be an empty ref.
=cut
sub http_data
{
my $self = shift;
my ( %results, $string, $key_value_pair, @key_value_sets, $key, $value );
if ( $ENV{'REQUEST_METHOD'} eq "POST" )
{
read( STDIN, $string, $ENV{'CONTENT_LENGTH'} );
}
else
{
$string = $ENV{'QUERY_STRING'};
}
$string =~ s/\+/ /g;
@key_value_sets = split( /&/, $string );
foreach $key_value_pair (@key_value_sets)
{
( $key, $value ) = split( /=/, $key_value_pair );
$key =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/ge;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/ge;
$results{$key} = $value;
}
return wantarray ? %results : \%results;
}
=pod
=head2 swrite()
Format text based on a picture.
$formatted = swrite($picture, @data);
Supports object notation for consistency.
$formatted = $obj->swrite($picture, @data);
See: perlform
=cut
sub swrite
{
my $this = shift if UNIVERSAL::isa($_[0], __PACKAGE__); # Polymorphic
my $pic = shift;
$^A = '';
formline($pic, @_);
my $ret = $^A;
$^A = '';
return $ret;
}
=pod
=head2 format_phone()
Format a (US) telephone number for humans, area code is optional.
$formatted = $obj->format_phone('12223334444');
# $formatted = '222-333-4444'
Any extra characters are stripped out, meaning input may be messy.
=cut
sub format_phone
{
my $this = shift if UNIVERSAL::isa($_[0], __PACKAGE__); # Polymorphic
my $phone = shift;
$phone =~ s/\D//g;
$phone =~ s/^1?((?:\d{3})?)(\d{3})(\d{4})/my $s = "$1-" if $1;"$s$2-$3"/e;
$phone;
}
=pod
=head1 Credit card handling
=head2 validate_card()
Validate credit card information.
$validated = $obj->validate_card($card_num, $exp_mo, $exp_y, \@errors);
Returns hashref of well formatted values, undef on failure.
$validated = {
num => '4111111111111111',
type => 'Visa',
exp_yr => 2015,
exp_mo => '03',
num_last_four => 1111,
num_formatted => '4111-1111-1111-1111',
num_parts => [qw(4111 1111 1111 1111)],
exp_yr_yy => 15,
}
Adds to @errors.
Checks card number, expiration.
Card number may be a string or a ref to a list of parts. eg:
'4111111111111111'
['4111', '1111', '1111', '1111']
Sample CC numbers to test with:
4111-1111-1111-1111 : Visa
5555-5555-5555-4444 : MasterCard
6011-1111-1111-1117 : Discover
=cut
sub validate_card
{
my $self = shift;
my ( $cardNum, $exp_m, $exp_y, $errors ) = @_;
my %ret;
if (UNIVERSAL::isa($cardNum, 'ARRAY'))
{
$cardNum = join('', @{$cardNum});
}
# remove all but digits
$cardNum =~ s/\D//g;
my @e;
if ( ! ((length($cardNum) == 16 ) && $self->luhn10_ok($cardNum)) )
{
push @e, "Credit Card Number Invalid";
}
else
{
# undef == bad card type
if (my $cc_type = $self->get_cc_type( $cardNum ))
{
$ret{type} = $cc_type;
}
else
{
push @e, "Credit Card Number type unkown";
}
}
if (my $exp = $self->check_cc_exp( $exp_m, $exp_y, \@e ))
{
$ret{$_} = $exp->{$_} foreach keys %{$exp};
}
if (@e)
{
push @{$errors}, @e;
}
# card is good
else
{
$ret{num} = $cardNum;
# Add other formats
my @parts = $ret{num} =~ m/(\d{4})(\d{4})(\d{4})(\d{4})/;
$ret{num_parts} = \@parts;
$ret{num_formatted} = join('-', @parts);
$ret{num_last_four} = $parts[3];
}
return @e ? undef : \%ret;
}
=pod
=head2 luhn10_ok()
Luhn 10 check.
$ok = $obj->luhn10_ok($cc_num);
Returns 1 on success, 0 on failure.
Input is expected to be a 16 digit string.
=cut
sub luhn10_ok
{
my $self = shift;
my @cardNum = split //, shift;
for my $i ( map { $_ * 2 } 0 .. $#cardNum / 2 ) {
$cardNum[$i] *= 2;
$cardNum[$i] -= 9 if $cardNum[$i] >= 10;
}
my $total = 0;
$total += $_ for (@cardNum);
return +($total % 10 == 0) ? 1 : 0;
}
=pod
=head2 check_cc_exp()
Check expiration for valid, not expired, etc.
$formatted = $obj->check_cc_exp($exp_mo, $exp_yr, \@errors)
Month is expected to be 1-2 digits long, year is 2 or 4 digits.
Returns: undef on fail, else hashref of well formatted
$formatted = {
exp_yr => 2015,
exp_mo => '03',
exp_yr_yy => 15,
}
Adds to @errors.
Invalid
Expired
Too far in future
=cut
sub check_cc_exp
{
my $self = shift;
my ( $month, $year, $errors ) = @_;
my %ret;
my $invalid = 1; # guilty until proven inocent
if ( $year > 0 && $month > 0 && $month <= 12 )
{
# Convert 2 digit year to 4 digit and ensure 2 digit month.
$year += 2000 if $year < 100;
$month = sprintf('%02u', $month);
my $expiration = join('-', $year, $month);
my ( $y, $m ) = (localtime)[ 5, 4 ];
$y += 1900; $m += 1;
my $today = sprintf( '%u-%02u', $y, $m );
if ( $expiration lt $today )
{
$invalid = 2;
}
else {
# Allow 10 years into future, since a human will be confirming later.
my $future = sprintf('%u-%02u', $y + 10, $m);
if ( $expiration ge $future )
{
$invalid = 3;
}
else
{
$invalid = 0;
%ret = (exp_yr => $year, exp_mo => $month, exp_yr_yy => substr($year, 2));
}
}
}
if ($invalid)
{
my %reasons = (
1 => 'Invalid',
2 => 'Expired',
3 => 'Too far in future'
);
push @{$errors}, 'Expiration date: '. $reasons{$invalid};
}
return $invalid ? undef : \%ret;
}
=pod
=head2 get_cc_type()
Determine credit card type based on the card number.
$cc_type = $obj->get_cc_type($cc_number);
Returns CC type as a string, undef if type isn't recognized.
=cut
sub get_cc_type
{
my $self = shift;
my $cc_num = shift;
# Taken from Business::CreditCard
my $cc_type;
if ($cc_num =~ /^5[1-5]/) {
$cc_type = 'MasterCard';
}
elsif ($cc_num =~ /^6011/)
{
$cc_type = 'Discover';
}
elsif ($cc_num =~ /^4/)
{
$cc_type = 'Visa';
}
return $cc_type;
}
=pod
=head1 VERSION
2016-11-02-002
=cut
1;
__END__