HTML and Perl CGI, HTML and Perl CGI |
HTML and Perl CGI, HTML and Perl CGI |
citabriabob |
Jul 27 2020, 04:32 PM
Post
#1
|
Newbie Group: Members Posts: 11 Joined: 27-July 20 Member No.: 27,457 |
I have html <form method="post" action="cgi-bin/order.cgi"> where inputs are <input autocomplete="off" type="text" size="1" maxlength="2" name="MI-527" value="">.
cgi script is perl. Random orders come in with unspecified inputs and all are very high quantities. I wrote this off as a chrome problem, but need to fix regardless. Thanks, |
pandy |
Jul 27 2020, 04:38 PM
Post
#2
|
🌟Computer says no🌟 Group: WDG Moderators Posts: 20,753 Joined: 9-August 06 Member No.: 6 |
You need to show a little, or rather a lot, more if someone is going to be able to help you.
|
citabriabob |
Jul 27 2020, 04:51 PM
Post
#3
|
Newbie Group: Members Posts: 11 Joined: 27-July 20 Member No.: 27,457 |
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 #!/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; "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__ This post has been edited by citabriabob: Jul 27 2020, 04:53 PM |
Christian J |
Jul 28 2020, 07:35 AM
Post
#4
|
. Group: WDG Moderators Posts: 9,722 Joined: 10-August 06 Member No.: 7 |
The W3C validator reports several HTML problems that may or may not contribute: https://validator.w3.org/check?uri=https%3A...ine&group=0
|
pandy |
Jul 28 2020, 08:04 AM
Post
#5
|
🌟Computer says no🌟 Group: WDG Moderators Posts: 20,753 Joined: 9-August 06 Member No.: 6 |
It's strange that it only happens occasionally.
|
citabriabob |
Jul 28 2020, 03:39 PM
Post
#6
|
Newbie Group: Members Posts: 11 Joined: 27-July 20 Member No.: 27,457 |
I'm sorry that I didn't do the validation of the html; I thought that I was perfect -
Corrected most errors and cut out a lot of the commented out sections. Still don't understand why autocomplete and hspace are flagged. Unfortunately, I cannot test this due to the random nature of the problem. Thanks to all. |
Christian J |
Jul 28 2020, 04:06 PM
Post
#7
|
. Group: WDG Moderators Posts: 9,722 Joined: 10-August 06 Member No.: 7 |
Still don't understand why autocomplete and hspace are flagged. Edit: Only HSPACE is proprietary and ignored. AUTOCOMPLETE is valid HTML, but since the page uses an older HTML4 Doctype (that does not include AUTOCOMPLETE or HSPACE) the validator complains. If you changed to a newer Doctype the error would go away, but since the page is otherwise made up of HTML4 elements and attributes the validator might flag other errors instead (that are no longer valid in HTML5). Browsers should not be affected by any of this though. QUOTE Unfortunately, I cannot test this due to the random nature of the problem. Are you sure the form submissions are done by real customers, and not some kind of bot? You could also check if some particular browser is causing this. You mentioned a "chrome problem"? This post has been edited by Christian J: Nov 2 2020, 08:42 PM |
citabriabob |
Jul 28 2020, 04:26 PM
Post
#8
|
Newbie Group: Members Posts: 11 Joined: 27-July 20 Member No.: 27,457 |
Are you sure the form submissions are done by real customers, and not some kind of bot? Absolutely. They are known club members.
You could also check if some particular browser is causing this. You mentioned a "chrome problem" I was told that Chrome ignores the autocomplete settings, but another customer used another browser, same result. Wish I had noted what he used. |
pandy |
Jul 28 2020, 04:38 PM
Post
#9
|
🌟Computer says no🌟 Group: WDG Moderators Posts: 20,753 Joined: 9-August 06 Member No.: 6 |
I don't think some old attributes can cause this anyway.
One thing, is the number of items ordered always 28 when it goes wrong? |
citabriabob |
Jul 28 2020, 05:40 PM
Post
#10
|
Newbie Group: Members Posts: 11 Joined: 27-July 20 Member No.: 27,457 |
No. I just checked another order and it was 85. Quantities are uniform per order. I thought that some text might be bleeding through ASCII 28 is a file separator; 85 is a capital U. Just guessing.
|
pandy |
Jul 28 2020, 06:35 PM
Post
#11
|
🌟Computer says no🌟 Group: WDG Moderators Posts: 20,753 Joined: 9-August 06 Member No.: 6 |
OK. Another thing. Did the customer actually order all those items but of course a more reasonably amount of them, or are parts of the order a total fake?
Just trying to find some kind of logic here... |
citabriabob |
Jul 28 2020, 06:48 PM
Post
#12
|
Newbie Group: Members Posts: 11 Joined: 27-July 20 Member No.: 27,457 |
Those items were NOT ordered; they appeared totally out of the blue.
If you have a mix of browsers, I welcome you to place orders. Use 4111 1111 1111 1111 as credit card. Your name and address are not required to be correct. If you do, please say browser name in comments. Thanks, |
pandy |
Jul 28 2020, 07:29 PM
Post
#13
|
🌟Computer says no🌟 Group: WDG Moderators Posts: 20,753 Joined: 9-August 06 Member No.: 6 |
Oh! So the affected member weren't there at all? This is beginning to sound really serious. Are the CC numbers stored on the server?
|
pandy |
Jul 28 2020, 07:39 PM
Post
#14
|
🌟Computer says no🌟 Group: WDG Moderators Posts: 20,753 Joined: 9-August 06 Member No.: 6 |
I filled out the form a couple of times. The confirmation page was correct.
|
citabriabob |
Jul 28 2020, 07:41 PM
Post
#15
|
Newbie Group: Members Posts: 11 Joined: 27-July 20 Member No.: 27,457 |
|
pandy |
Jul 28 2020, 08:33 PM
Post
#16
|
🌟Computer says no🌟 Group: WDG Moderators Posts: 20,753 Joined: 9-August 06 Member No.: 6 |
But when you get those fishy form submissions there is a CC number entered, isn't it? Is it a real number and does the card belong to the member who's name is used? If so, it must come from somewhere.
|
citabriabob |
Jul 29 2020, 02:20 PM
Post
#17
|
Newbie Group: Members Posts: 11 Joined: 27-July 20 Member No.: 27,457 |
Can you recommend someone who is paid to fix this?
|
pandy |
Jul 29 2020, 02:37 PM
Post
#18
|
🌟Computer says no🌟 Group: WDG Moderators Posts: 20,753 Joined: 9-August 06 Member No.: 6 |
Sorry, don't know.
Please answer my question about the CC numbers. I worry about that bit. |
citabriabob |
Nov 1 2020, 01:14 PM
Post
#19
|
Newbie Group: Members Posts: 11 Joined: 27-July 20 Member No.: 27,457 |
OK. Given that I am unable to find the source of this issue and most orders are received correctly, I would like to eliminate (set qty to 0)? any item with a quantity greater than 9. Is this easy to do?
|
Christian J |
Nov 1 2020, 06:31 PM
Post
#20
|
. Group: WDG Moderators Posts: 9,722 Joined: 10-August 06 Member No.: 7 |
I would like to eliminate (set qty to 0)? any item with a quantity greater than 9. Is this easy to do? The time-consuming part should be to understand where in the script to add it, otherwise it's trivial. An simpler alternative might be to use an INPUT TYPE=RANGE or (more compact) INPUT TYPE=NUMBER form field instead of an ordinary text field in the HTML code. That way you can limit the max value submitted by normal users. However it does not prevent bots, malware or malicious users from submitting bogus form data. See also https://www.w3schools.com/tags/att_input_type_range.asp and https://www.w3schools.com/tags/att_input_type_number.asp But I'm not sure what you meant with this reply from July 29th: QUOTE Those items were NOT ordered; they appeared totally out of the blue. Did you mean that: 1. The customer did place an order, but extra items in the order appeared out of the blue? 2. Or did the entire order including the CC number appears out of the blue? |
Lo-Fi Version | Time is now: 21st September 2024 - 03:46 PM |