develooper Front page | perl.perl5.porters | Postings from August 2001

[ID 20010801.063] seg fault parsing perl script

From:
Brian Herlihy
Date:
August 1, 2001 23:15
Subject:
[ID 20010801.063] seg fault parsing perl script
Message ID:
E15SBli-0000n0-00@btherl
This is a bug report for perl from brian@trellian.com,
generated with the help of perlbug 1.33 running under perl v5.6.1.


-----------------------------------------------------------------
[Please enter your report here]

Hi,

I'm running perl 5.6.1, installed from debian unstable.  The bug is that
perl seg faults attempting to parse my script (it should have been a parse
error anyway, which is why I left it at low priority).

I have also verified the bug on perl 5.6.1 on Solaris 7.

Here is the script in full, 'perl -c script' gives the seg fault.  The
offending code is:

sub print_edit_template ($) {
	sub $url_id = shift;

When fixed to 'my $url_id ...' it no longer seg faults.

Brian

-- BEGIN SCRIPT

#!/usr/bin/perl -w
#
# $Id: session.cgi,v 1.29 2001/08/02 05:41:12 btherl Exp $
#
###############################################################################
#
# This script is called after the user has logged in; it handles all the
# editing and option setting and stuff.  It remembers who the user is by
# a cookie, which is stored in the database.
#
###############################################################################

use warnings;
no warnings qw(once);
use strict;
require LWP;
require DBI;
require CGI;
require Config::IniFiles;
require Email::Valid;
require HTML::Template;
require Apache;

###############################################################################
## Configuration
###############################################################################

my $config_file =		"search_sub.ini";
my $cfg = new Config::IniFiles -file => $config_file;

my $templ_dir =			"./session_templates";
my $main_template =		"$templ_dir/main.html";
my $account_settings_templ =	"$templ_dir/account_settings.html";
my $change_settings_templ =	"$templ_dir/change_settings.html";
my $edit_urls_templ =		"$templ_dir/edit_urls.html";
my $transaction_hist_templ =	"$templ_dir/transaction_hist.html";
my $url_report_templ =		"$templ_dir/url_report.html";
my $submit_urls_templ =		"$templ_dir/submit_urls.html";
my $change_password_templ =	"$templ_dir/change_password.html";
my $transact_history_templ =	"$templ_dir/transact_history.html";
my $order_details_templ =	"$templ_dir/order_details.html";
my $mass_add_templ =		"$templ_dir/mass_add.html";
my $edit_url_templ =		"$templ_dir/edit.html";

my $global_data_dir =		"./global_data";
my $cc_type_file =		"$global_data_dir/card_types.txt";
my $cc_month_file =		"$global_data_dir/card_months.txt";
my $cc_year_file =		"$global_data_dir/card_years.txt";

my $database =		$cfg->val('database', 'name');
my $hostname =		$cfg->val('database', 'update_hostname');
my $port =		$cfg->val('database', 'port');

my $db_username =	$cfg->val('database', 'username');
my $db_password =	$cfg->val('database', 'password');

my $driver =	"mysql";
my $dsn =	"DBI:$driver:database=$database;host=$hostname;port=$port";

my $user_table = 		"Users";
my $templ_table =		"Templates";
my $cookie_table =		"Cookies";
my $url_table =			"URL";
my $order_table = 		"Orders";
my $order_details_table =	"Order_details";

my $text_header = "Content-type: text/plain\n\n";

###############################################################################
## Global Variables
###############################################################################
use vars qw($dbh $drh $q $status $errcount $cookie $username %user_info $action);
$status = "";			## The status string
$errcount = 0;			## How many errors we've had

###############################################################################
## Connect to the database
###############################################################################

sub db_connect() {
  $dbh = DBI->connect($dsn, $db_username, $db_password) or
    die("Can't make connection to mysql server.\n The error: $DBI::errstr");
  $drh = DBI->install_driver("mysql");
}

###############################################################################
## Convert a datetime into just a date in a nice format
## Input: mysql datetime
## Output: date in "7 Jan 1997" format
###############################################################################
sub dt_to_d ($) {
	my $datetime = shift;
	my $result = "";

	my ($date, undef) = split(/ /, $datetime);
	my ($year, $month, $day) = split(/-/, $date);

	my $monthnames = [ "Jan", "Feb", "Mar", "Apr", "May", "Jun",
			"Jul", "Aug", "Sep", "Oct", "Nov", "Dec" ];

	$result .= $day . " ";
	$result .= $$monthnames[$month] . " ";
	$result .= $year;

	return $result;
}

###############################################################################
## Prepares an HTML::Template substition.  This can be modified further
## by the caller before being applied.
## Input: Template file.
## Output: HTML::Template object
###############################################################################
sub prepare_template ($) {
	my $filename = shift;
	my $arrange_checked = "";
	if ($user_info{'arranged_payment'} eq "1") {
		$arrange_checked = " CHECKED ";
	}

	my $template = new HTML::Template filename => $filename,
		vanguard_compatibility_mode => 1;

	$template->param(
		STATUS => $status,
		USERNAME => $user_info{'username'},
		COMPANY => $user_info{'company'},
		EMAIL => $user_info{'email'},
		STREET => $user_info{'street'},
		CITY => $user_info{'city'},
		ZIP => $user_info{'zip'},
		COUNTRY => $user_info{'country'},
		PHONE => $user_info{'phone'},
		CC_TYPE => $user_info{'cc_type'},
		CC_NO => $user_info{'cc_no'},
		CC_NAME => $user_info{'cc_name'},
		CC_MONTH => $user_info{'cc_month'},
		CC_YEAR => $user_info{'cc_year'},
		NUM_URLS => $user_info{'num_urls'},
		ARRANGE_CHECKED => $arrange_checked,
		ACTION => $action
	);

	return $template;
}
###############################################################################
## Print out a template.
## Extra arguments will be interpreted as a hash of substitions to make in
## addition to the standard ones.
## Takes input from the global variable %user_info only
## Returns no value - prints to stdout
###############################################################################
sub print_template($;\%) {
	my $template = shift;
	my $subs = shift;

	$username = $username || "(undef)";

	my $templ_object = prepare_template ($template);
	if (defined($subs)) {
		foreach my $key (keys %$subs) {
			$templ_object->param( $key => $$subs{$key} );
		}
	}
	print $q->header;
	print $templ_object->output;
}

###############################################################################
## Confirms URL submission.
## Takes input from the global variable %user_info, and from the database.
## Returns no value - prints to stdout
###############################################################################
sub print_edit_urls () {
	my $urls;	## text string containing table of urls
	my @url_sub;	## array of substitions for URL list

	my $sth = $dbh->prepare("SELECT * FROM " . $url_table .
		" WHERE username = " . $dbh->quote($username));
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	while (my $ref = $sth->fetchrow_hashref) {
		my $delete_url = "$action?delete=" . $$ref{'id'};
		my $edit_url = "$action?edit=" . $$ref{'id'};
		my $submitted = $$ref{'submitted'} ? 
			"Submitted on " . dt_to_d ($$ref{'submitted'}) :
			"Not submitted";
		my %temphash;
		$temphash{'URL_ID'} = $$ref{'id'};
		$temphash{'URL'} = $$ref{'url'};
		$temphash{'SUBMITTED'} = $submitted;
		$temphash{'EDIT_URL'} = $edit_url;
		$temphash{'DELETE_URL'} = $delete_url;
		push @url_sub, \%temphash;
	}
	$sth->finish;

	my $new_url = $Q::new_url || "";

	my $template = prepare_template ($edit_urls_templ);
	$template->param(
		URLS => \@url_sub,
		NEW_URL => $new_url
	);

	print $q->header;
	print $template->output;

}

###############################################################################
## Prints out the URL report
## Takes input from the global variable %user_info, and from the database.
## Returns no value - prints to stdout
###############################################################################
sub print_url_report () {
	my $urls;	## text string containing table of urls
	my @url_sub;

	my $sth = $dbh->prepare("SELECT * FROM " . $url_table .
		" WHERE username = " . $dbh->quote($username));
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	while (my $ref = $sth->fetchrow_hashref) {
		my $processed = $$ref{'process_date'} ?
			dt_to_d ($$ref{'process_date'}) : "Never";
		my $status = $$ref{'status'} || "Not spidered";
		my $submitted = $$ref{'submitted'} ?
			dt_to_d ($$ref{'submitted'}) : "Not submitted";
		my $expires = $$ref{'expires'} ?
			dt_to_d ($$ref{'expires'}) : "Not submitted";
		my %temphash;
		$temphash{'URL_STATUS'} = $status;
		$temphash{'SUBMITTED'} = $submitted;
		$temphash{'EXPIRES'} = $expires;
		$temphash{'PROCESSED'} = $processed;
		$temphash{'URL'} = $$ref{'url'};
		push @url_sub, \%temphash;
	}
	$sth->finish;

	my $template = prepare_template ($url_report_templ);
	$template->param(
		URLS => \@url_sub
	);

	print $q->header;
	print $template->output;
}

###############################################################################
## Ask user to confirm their order.
## Takes input from the global variable %user_info, and Q::url_selection
## Returns no value - prints to stdout
###############################################################################
sub print_submit_urls () {
	my $urls;	## text string containing table of urls
	my $url_id_list;
	my @url_sub;
	my $count = 0;

	if (ref $Q::url_selection) {
		$url_id_list = $Q::url_selection;
	} else {
		$url_id_list = [ $Q::url_selection ];
	}

	my $sth = $dbh->prepare("SELECT * FROM " . $url_table .
		" WHERE id = ? " .
		" AND username = " . $dbh->quote($username));
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }

	foreach my $url_id (@$url_id_list) {
		if (!$sth->execute ($url_id)) {
			die "Error: " . $sth->errstr . "\n";
		}
		my $ref = $sth->fetchrow_hashref;
		my $processed = $$ref{'processed'} ?
			dt_to_d ($$ref{'processed'}) : "Never";
		my $status = $$ref{'status'} || "Not spidered";
		my $submitted = $$ref{'submitted'} ?
			dt_to_d ($$ref{'submitted'}) : "Not submitted";
		my $expires = $$ref{'expires'} ?
			dt_to_d ($$ref{'expires'}) : "Not submitted";
		my %temphash;
		$temphash{'URL_STATUS'} = $status;
		$temphash{'SUBMITTED'} = $submitted;
		$temphash{'EXPIRES'} = $expires;
		$temphash{'PROCESSED'} = $processed;
		$temphash{'URL'} = $$ref{'url'};
		$temphash{'URL_ID'} = $$ref{'id'};
		push @url_sub, \%temphash;
		$count++;
	}
	$sth->finish;

	my $template = prepare_template ($submit_urls_templ);
	$template->param(
		URLS => \@url_sub,
		NUM_URLS => $count,
		COST => $Q::TOTAL
	);

	print $q->header;
	print $template->output;
}

###############################################################################
## Prints out a user's transaction history.
## Input: from database (%user_info)
## Returns no value - prints to stdout
###############################################################################
sub print_transaction_history () {
	my $orders = "";
	my @orders_sub;

	my $sth = $dbh->prepare("SELECT * FROM " . $order_table .
			" WHERE username = " . $dbh->quote($username));
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	while (my $ref = $sth->fetchrow_hashref) {
		my $details = "$action?order_details=" . $$ref{'order_id'};

		my %temphash;
		$temphash{'SUBMITTED'} = $$ref{'submitted'};
		$temphash{'CHARGE'} = $$ref{'charge'};
		$temphash{'DETAILS'} = $details;
		push @orders_sub, \%temphash;
	}
	$sth->finish;

	my $template = prepare_template ($transact_history_templ);
	$template->param(
		ORDERS => \@orders_sub
	);

	print $q->header ();
	print $template->output;
}

###############################################################################
## Prints out details of a single transaction.
## Input: order id, and data from database (%user_info)
## Returns no value - prints to stdout
###############################################################################
sub print_order_details ($) {
	my $order_id = shift;
	my %order_row;	## row from the Orders table
	my @url_sub;
	my $urls = "";

	## Grab details from the Order table
	my $sth = $dbh->prepare("SELECT * FROM " . $order_table .
			" WHERE order_id = " . $dbh->quote($order_id));
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	my $ref = $sth->fetchrow_hashref;
	%order_row = %$ref;
	$sth->finish;

	## Now read all the entries from URL table, based on order_details
	$sth = $dbh->prepare("SELECT * FROM " . $order_details_table .
			" LEFT JOIN " . $url_table .
			" ON id = url_id " .
			" WHERE order_id = " . $dbh->quote($order_id));
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	while (my $ref = $sth->fetchrow_hashref) {
		my %temphash;
		$temphash{'SUBMITTED'} = $$ref{'submitted'};
		$temphash{'URL'} = $$ref{'url'};
		$temphash{'ORDER_NUM'} = $$ref{'order_id'};
		push @url_sub, \%temphash;
	}
	$sth->finish;

	my $template = prepare_template ($order_details_templ);
	$template->param(
		URLS => \@url_sub,
		ORDER_NUM => $order_id,
		CHARGE => $order_row{'charge'}
	);

	print $q->header ();
	print $template->output;
}

###############################################################################
## Deletes one URL from the database
## Input: id of the URL to be deleted
## Returns no value - updates the database
###############################################################################
sub delete_url ($) {
	my $url_id = shift;

	my $sth = $dbh->prepare("DELETE FROM " . $url_table . " WHERE " .
		" id = " . $dbh->quote($url_id) .
		" AND username = " . $dbh->quote($username)
		);
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	$sth->finish;
}

###############################################################################
## Checks if a URL can be accessed, using LWP.
## Input: one URL
## Returns true if accessible, undef otherwise
###############################################################################
sub check_access_url ($) {
	my $url = shift;

	my $ua = new LWP::UserAgent;
	$ua->timeout(10);
	$ua->env_proxy;
	my $req = new HTTP::Request HEAD => $url;
	my $res = $ua->request($req);

	if ($res->is_success) {
		return "success";
	} else {
		return undef;
	}
}

###############################################################################
## Checks if the URL is already in the database
## Input: one URL
## Returns true if it is present, false otherwise.
###############################################################################
sub check_url_dup ($) {
	my $url = shift;
	my $rows;

	my $sth = $dbh->prepare("SELECT url FROM " . $url_table .
			" WHERE url = " . $dbh->quote($url)
			);
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	$rows = $sth->rows;
	$sth->finish;

	if ($rows > 0) {
		return $rows;
	} else {
		return undef;
	}
}

###############################################################################
## Adds a URL for this user into the database.
## Takes the URL to be added as input
## Returns no value - writes to the database
###############################################################################
sub add_url ($) {
	my $url = shift;

	unless (check_access_url ($url)) {
		$status .= "<b>Warning: URL could not be accessed.  Please " .
			"verify before submitting.</b><br>";
	}
	if (check_url_dup ($url)) {
		$status .= "<b>URL already in database - URL not added." .
			"</b><br>";
		return undef;
	}

	my $sth = $dbh->prepare("INSERT INTO " . $url_table .
			" (username, url) " .
			" VALUES ( " .
			$dbh->quote($username) . ", " .
			$dbh->quote($url) .
			" ) "
			);
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	$sth->finish;
}

###############################################################################
## Gets a username from a cookie, so we can tell who's logged in.
## Input: Cookie
## Output: the username, or undef if the cookie is not found
###############################################################################
sub cookie_to_user($) {
	my ($cookie) = @_;
	my $username;

	my $sth = $dbh->prepare("SELECT Username FROM " . $cookie_table .
			" WHERE Cookie = " . $dbh->quote($cookie)
			);
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	my $ref = $sth->fetchrow_hashref;
	if ($ref) {
		$username = $ref->{'Username'};
	}
	$sth->finish;

	return $username;
}

###############################################################################
## Resets the inactivity timeout for a user's login session
## Input: cookie for user's login session
## Returns no value - updates database
###############################################################################
sub update_login ($) {
	my $cookie = shift;
	my $sth = $dbh->prepare("UPDATE Cookies SET added = NOW() " .
			" WHERE cookie = " . $dbh->quote($cookie));
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	$sth->finish;
}

###############################################################################
## Gets various info about the user, and returns it in a nice hash.
## Input: Username
## Output: Hash containing information about the user
###############################################################################
sub get_user_info($) {
	my $username = shift;
	my %results;

	my $sth = $dbh->prepare("SELECT * from " . $user_table . " WHERE " .
			" Username = " . $dbh->quote($username)
			);
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	my $ref = $sth->fetchrow_hashref;
	if (!$ref) {
		die "Fatal error - user " . $username . " not found\n";
	}
	%results = %$ref;
	$sth->finish;

	$sth = $dbh->prepare("SELECT count(*) from URL WHERE " .
			" username = " . $dbh->quote($username)
			);
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	$ref = $sth->fetchrow_arrayref;
	$results{'num_urls'} = $$ref[0];
	$sth->finish;

	return %results;
}

###############################################################################
## Write settings to database.  This is called from the change_settings screen.
## Input is taken from the cgi query, imported into "Q::", and the global
##	variable username.
## Returns no value - updates the database
###############################################################################
sub save_settings() {
	my $arranged = 0;
	if ($Q::arrange_payment eq "yes") {
		$arranged = 1;
	}
	my $sth = $dbh->prepare("UPDATE " . $user_table . " SET " .
			" company = " . $dbh->quote($Q::company) . ", " .
			" email = " . $dbh->quote($Q::email) . ", " .
			" street = " . $dbh->quote($Q::street) . ", " .
			" city = " . $dbh->quote($Q::city) . ", " .
			" zip = " . $dbh->quote($Q::zip) . ", " .
			" country = " . $dbh->quote($Q::country) . ", " .
			" phone = " . $dbh->quote($Q::phone) . ", " .
			" cc_type = " . $dbh->quote($Q::cc_type) . ", " .
			" cc_no = " . $dbh->quote($Q::cc_no) . ", " .
			" cc_name = " . $dbh->quote($Q::cc_name) . ", " .
			" cc_month = " . $dbh->quote($Q::cc_month) . ", " .
			" cc_year = " . $dbh->quote($Q::cc_year) . ", " .
			" arranged_payment = " . $dbh->quote($arranged) .
			" WHERE Username = " . $dbh->quote($username)
			);
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	$sth->finish;
}

###############################################################################
## Erase the user's cookie when they logout.
## Takes no input
## Returns no value - updates the database
###############################################################################
sub kill_cookie() {
	my $sth = $dbh->prepare("DELETE FROM " . $cookie_table .
			" WHERE Cookie = " . $dbh->quote($cookie)
			);
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	$sth->finish;
}

###############################################################################
## Attempts to change the user's password.  The change only succeeds if the
## old password matches that in the database, and both the new passwords match.
## Takes input from cgi variables "Q::"
## Returns true if successful, undef if failure.
###############################################################################
sub change_password() {
	my $rows;

	if ($Q::new_password cmp $Q::conf_new_password) {
		$status .= "<b>Passwords do not match.</b><br>";
		return undef;
	}

	my $sth = $dbh->prepare("UPDATE " . $user_table . " SET " .
		" password = " . $dbh->quote($Q::new_password) .
		" WHERE username = " . $dbh->quote($username) .
		" AND password = " . $dbh->quote($Q::old_password)
		);
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	$rows = $sth->rows;
	$sth->finish;

	return ($rows == 0) ? undef : $rows;
}

##
## temp function to pretend to calculate cost 
##
sub calc_cost () {
	return 20;
}

###############################################################################
## Adds an order to the order database, and marks URLs as submittable.
## Input: taken from CGI data and %user_info
## Returns no value - writes to the database
###############################################################################
sub submit_order () {
	my $url_id_list;
	my $order_id;

	## Make it an arrayref no matter what.  Stupid CGI library.
	if (ref $Q::url_selection) {
		$url_id_list = $Q::url_selection;
	} else {
		$url_id_list = [ $Q::url_selection ];
	}

	my $sth = $dbh->prepare("INSERT INTO " . $order_table .
		" ( username, submitted, charge, cc_no, cc_name, " .
		" cc_month, cc_year, cc_type ) VALUES ( " .
		$dbh->quote($username) . ", " .
		" NOW() " . ", " .
		$dbh->quote (calc_cost ()) . ", " .
		$dbh->quote ($user_info{'cc_no'}) . ", " .
		$dbh->quote ($user_info{'cc_name'}) . ", " .
		$dbh->quote ($user_info{'cc_month'}) . ", " .
		$dbh->quote ($user_info{'cc_year'}) . ", " .
		$dbh->quote ($user_info{'cc_type'}) .
		" ) "
		);
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	$sth->finish;

	## Get the id for the order to fill in the order details
	$sth = $dbh->prepare("SELECT LAST_INSERT_ID()");
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	my $ref = $sth->fetchrow_arrayref;
	$order_id = $$ref[0];
	$sth->finish;

	## Insert all the URL ids into the Order_details table
	$sth = $dbh->prepare("INSERT INTO " . $order_details_table .
		" (order_id, url_id) VALUES ( " .
		$dbh->quote($order_id) . ", ? ) "
		);
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	foreach my $url_id (@$url_id_list) {
		if (!$sth->execute($url_id)) {
			die "Error: " . $sth->errstr . "\n";
		}
	}
	$sth->finish;

	## Now mark all relevant URLs as submitted.
	$sth = $dbh->prepare("UPDATE " . $url_table . " SET " .
			" submitted = NOW() , " .
			" expires = date_add( NOW() , INTERVAL 1 YEAR ) " .
			" WHERE id = ? "
			);
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }

	foreach my $url_id (@$url_id_list) {
		if (!$sth->execute ($url_id)) {
			die "Error: " . $sth->errstr . "\n";
		}
	}
	$sth->finish;
}

###############################################################################
## Validates a credit card number (by algorithm)
## Input: credit card number as scalar
## Output: true if success, undef otherwise
###############################################################################
sub validate_cc ($) {
	my $cc = shift;
	my $multiplier = 1;
	my $sum = 0;

	my @cc_digits = split(//, $cc);
	while (defined(my $digit = pop @cc_digits)) {
		my $product = $digit * $multiplier;
		$sum += ($product % 10) + ($product >= 10 ? 1 : 0);
		$multiplier = 3 - $multiplier;	## 1 -> 2, 2 -> 1
	}

	if ($sum % 10 == 0) { return "success" }
	return undef
}

###############################################################################
## Checks that the user's changed settings are valid
## Input: take from CGI query
## Output: If failure, reprints change settings template.  If success, returns.
###############################################################################
sub validate_settings () {
	if (!Email::Valid->address($Q::email)) {
		$status .= "<b>Please enter a valid email address.</b><br>";
		print_template ($change_settings_templ);
		goto MYEXIT;
	}
	if (!validate_cc($Q::cc_no) && !$Q::arrange_payment) {
		$status .= "<b>Please enter a valid credit card number.</b><br>";
		print_template ($change_settings_templ);
		goto MYEXIT;
	}
}

###############################################################################
## Gets URLs from a text area, verifies them, and adds to the database.
## Input: data from $Q::urls
## Output: number of URLs added, and number of failures.
###############################################################################
sub process_textarea () {
	my $errors = 0;
	my $added = 0;

	my @urls = split(/\r?\n/, $Q::urls);
	my $ua = new LWP::UserAgent;

	$ua->timeout(10);
	$ua->env_proxy;
	foreach my $url (@urls) {
		unless ($url =~ /[[:alnum:]]+/) {
			## If no alnum chars, skip to next URL
			next;
		}
		my $req = new HTTP::Request HEAD => $url;
		my $res = $ua->request($req);
		unless ($res->is_success) {
			$status .= "<b>Failed to access $url.</b><br>";
			$errors++;
			next;
		}
		if (check_url_dup ($url)) {
			$status .= "<b>$url already in database - " .
				"URL not added.</b><br>";
			next;
		}
		my $sth = $dbh->prepare("INSERT INTO " . $url_table .
				" (username, url) " .
				" VALUES ( " .
				$dbh->quote($username) . ", " .
				$dbh->quote($url) .
				" ) "
				);
		if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
		if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
		$sth->finish;
		$added++;
	}

	return ($added, $errors);
}

###############################################################################
## Check if url is at least semi-valid
## THIS FUNCTION IS NOT USED
## Input: a URL
## Returns undef if invalid, or true if maybe valid
###############################################################################
sub check_url ($) {
	my $url = shift;

	unless ($url =~ /http:\/\//) {
		## Sorry, we only take http here.
		return undef;
	}

	return 1;
}

###############################################################################
## Generates a substitution list for credit card type options
## Input: from data files
## Output: arrayref suitable for passing to HTML::Template->param()
###############################################################################
sub mk_cc_type_subs () {
	my @subs;

	open (CC_TYPE, $cc_type_file)			|| die "open: $!\n";
	while (<CC_TYPE>) {
		chomp;
		my %temphash;
		$temphash{'CC_TYPE'} = $_;
		$temphash{'SELECTED'} = $user_info{'cc_type'} eq $_ ?
			" SELECTED " : "";
		push @subs, \%temphash;
	}
	close (CC_TYPE)					|| die "close: $!\n";

	return \@subs;
}

sub mk_cc_month_subs () {
	my @subs;

	open (CC_MONTH, $cc_month_file)			|| die "open: $!\n";
	while (<CC_MONTH>) {
		chomp;
		my %temphash;
		$temphash{'CC_MONTH'} = $_;
		$temphash{'SELECTED'} = $user_info{'cc_month'} eq $_ ?
			" SELECTED " : "";
		push @subs, \%temphash;
	}
	close (CC_MONTH)				|| die "close: $!\n";

	return \@subs;
}

sub mk_cc_year_subs () {
	my @subs;

	open (CC_YEAR, $cc_year_file)			|| die "open: $!\n";
	while (<CC_YEAR>) {
		chomp;
		my %temphash;
		$temphash{'CC_YEAR'} = $_;
		$temphash{'SELECTED'} = $user_info{'cc_year'} eq $_ ?
			" SELECTED " : "";
		push @subs, \%temphash;
	}
	close (CC_YEAR)					|| die "close: $!\n";

	return \@subs;
}

###############################################################################
## Print screen for editing a URL.  Only if it hasn't been submitted yet.
## Input: url id to edit
## Output: returns no value - prints form to stdout
###############################################################################
sub print_edit_template ($) {
	sub $url_id = shift;
	my %subs;

	my $sth = $dbh->prepare("SELECT url FROM URL WHERE " .
			" url_id = " . $dbh->quote($url_id)
			);
	if (!$sth) { die "Error: " . $dbh->errstr . "\n" }
	if (!$sth->execute) { die "Error: " . $sth->errstr . "\n" }
	my $ref = $sth->fetchrow_hashref;
	$subs{'OLD_URL'} = $$ref{'url'};
	$sth->finish;

	$subs{'URL_ID'} = $url_id;
	print_template ($edit_url_templ, \%subs);
}


###############################################################################
###############################################################################
##
## Main program
##
###############################################################################
###############################################################################

$q = new CGI;
$q->import_names('Q');	## Maps all CGI variables into the Q namespace

$action = $ENV{'SCRIPT_NAME'};		## So can call ourselves

db_connect ();

## Get all the user's info from the database, starting just with sessionID
$cookie = $q->cookie('sessionID');
$username = cookie_to_user($cookie);
update_login ($cookie);			## Reset login inactivity timeout
if (!$username) {
	Apache->internal_redirect(
		'https://btherl.off.trellian.com/sub-cgi/login.cgi');
#	print "Location: http://btherl.off.trellian.com/sub-cgi/login.cgi\n\n";
	goto MYEXIT;
}

## Mapped cookie to user OK - now get info from database for user
%user_info = get_user_info ($username);

###############################################################################
## PROCESS COMMANDS
###############################################################################
if ($Q::account_settings) {
	undef $Q::account_settings;
	print_template ($account_settings_templ);
	goto MYEXIT;
}
if ($Q::change_settings) {
	undef $Q::change_settings;
	my %subhash;
	$subhash{'CC_TYPE_LIST'} = mk_cc_type_subs ();
	$subhash{'CC_MONTH_LIST'} = mk_cc_month_subs ();
	$subhash{'CC_YEAR_LIST'} = mk_cc_year_subs ();
	print_template ($change_settings_templ, %subhash);
	goto MYEXIT;
}
if ($Q::update) {
	undef $Q::update;
	validate_settings ();
	save_settings ();
	%user_info = get_user_info ($username);
	$status .= "<b>Account settings saved.</b><br>";
	print_template ($account_settings_templ);
	goto MYEXIT;
}
if ($Q::change_password) {
	undef $Q::change_password;
	print_template ($change_password_templ);
	goto MYEXIT;
}
if ($Q::update_password) {
	undef $Q::update_password;
	if (change_password ()) {
		$status .= "<b>Password changed successfully.</b><br>";
		print_template ($account_settings_templ);
		goto MYEXIT;
	}
	$status .= "<b>Password change failed - please try again.</b><br>";
	print_template ($change_password_templ);
	goto MYEXIT;
}
if ($Q::edit_urls) {
	undef $Q::edit_urls;
	print_edit_urls ();
	goto MYEXIT;
}
if ($Q::delete) {
	undef $Q::delete;
	delete_url ($Q::delete);
	print_edit_urls ();
	goto MYEXIT;
}
if ($Q::delete_urls) {
	undef $Q::delete_urls;
	my $count = 0;
	if (ref $Q::url_selection) {
		foreach my $url_id (@$Q::url_selection) {
			delete_url($url_id);
			$count++;
		}
	} else {
		delete_url($Q::url_selection);
		$count++;
	}
	$status .= "<b> Deleted $count URLs </b><br>";
	print_edit_urls ();
	goto MYEXIT;
}
if ($Q::submit_urls) {
	undef $Q::submit_urls;
	print_submit_urls ();
	goto MYEXIT;
}
if ($Q::mass_add) {
	undef $Q::mass_add;
	print_template ($mass_add_templ);
	goto MYEXIT;
}
if ($Q::mass_submit_urls) {
	undef $Q::mass_submit_urls;
	my ($added, $errors) = process_textarea ();
	$status .= "<b>$added URLs successfully added.</b><br>";
	if ($errors > 0) {
		$status .= "<b>Warning: Some URLs were not accessible, and " .
			"have not been added.</b><br>";
	}
	print_edit_urls ();
	goto MYEXIT;
}
if ($Q::confirm_order) {
	undef $Q::confirm_order;
	submit_order ();
	$status .= "<b> Your order has been submitted, and will be fully " .
		"processed within 48 hours.</b><br>";
	print_edit_urls ();
	goto MYEXIT;
}
if ($Q::add_url) {
	undef $Q::add_url;
	add_url ($Q::new_url);
	print_edit_urls ();
	goto MYEXIT;
}
if ($Q::url_report) {
	undef $Q::url_report;
	print_url_report ();
	goto MYEXIT;
}
if ($Q::transaction_history) {
	undef $Q::transaction_history;
	print_transaction_history ();
	goto MYEXIT;
}
if ($Q::order_details) {
	print_order_details ($Q::order_details);
	undef $Q::order_details;
	goto MYEXIT;
}
if ($Q::logout) {
	undef $Q::logout;
	kill_cookie ();
	Apache->internal_redirect(
		'https://btherl.off.trellian.com/sub-cgi/login.cgi');
#	print "Location: http://btherl.off.trellian.com/sub-cgi/login.cgi\n\n";
	goto MYEXIT;
}
if ($Q::edit) {
	print_edit_template ($edit);
	undef $Q::edit;
	goto MYEXIT;
}
if ($Q::edit_url) {
	undef $Q::edit_url;
	goto MYEXIT;
}

# Fall through - print the main menu

print_template ($main_template);

## Added for mod_perl - instead of exit, goto here
MYEXIT:

-- END SCRIPT


[Please do not change anything below this line]
-----------------------------------------------------------------
---
Flags:
    category=core
    severity=low
---
This perlbug was built using Perl v5.6.1 - Tue Jun 12 11:59:50 EST 2001
It is being executed now by  Perl v5.6.1 - Fri Jun 22 18:58:01 EST 2001.

Site configuration information for perl v5.6.1:

Configured by bod at Fri Jun 22 18:58:01 EST 2001.

Summary of my perl5 (revision 5.0 version 6 subversion 1) configuration:
  Platform:
    osname=linux, osvers=2.4.5-ac9, archname=i386-linux
    uname='linux duende 2.4.5-ac9 #1 thu jun 21 00:52:39 est 2001 i686 unknown '
    config_args='-Dccflags=-DDEBIAN -Dcccdlflags=-fPIC -Darchname=i386-linux -Dprefix=/usr -Dprivlib=/usr/share/perl/5.6.1 -Darchlib=/usr/lib/perl/5.6.1 -Dvendorprefix=/usr -Dvendorlib=/usr/share/perl5 -Dvendorarch=/usr/lib/perl5 -Dsiteprefix=/usr/local -Dsitelib=/usr/local/share/perl/5.6.1 -Dsitearch=/usr/local/lib/perl/5.6.1 -Dman1dir=/usr/share/man/man1 -Dman3dir=/usr/share/man/man3 -Dman1ext=1 -Dman3ext=3perl -Dpager=/usr/bin/sensible-pager -Uafs -Ud_csh -Uusesfio -Dotherlibdirs=/usr/lib/perl5/5.6:/usr/lib/perl5/5.005 -Duseshrplib -Dlibperl=libperl.so.5.6.1 -Dd_dosuid -des'
    hint=recommended, useposix=true, d_sigaction=define
    usethreads=undef use5005threads=undef useithreads=undef usemultiplicity=undef
    useperlio=undef d_sfio=undef uselargefiles=define usesocks=undef
    use64bitint=undef use64bitall=undef uselongdouble=undef
  Compiler:
    cc='cc', ccflags ='-DDEBIAN -fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
    optimize='-O2',
    cppflags='-DDEBIAN -fno-strict-aliasing -I/usr/local/include'
    ccversion='', gccversion='2.95.4 20010604 (Debian prerelease)', gccosandvers=''
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
    ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
    alignbytes=4, usemymalloc=n, prototype=define
  Linker and Libraries:
    ld='cc', ldflags =' -L/usr/local/lib'
    libpth=/usr/local/lib /lib /usr/lib
    libs=-lgdbm -ldbm -ldb -ldl -lm -lc -lcrypt
    perllibs=-ldl -lm -lc -lcrypt
    libc=/lib/libc-2.2.3.so, so=so, useshrplib=true, libperl=libperl.so.5.6.1
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-rdynamic'
    cccdlflags='-fPIC', lddlflags='-shared -L/usr/local/lib'

Locally applied patches:
    

---
@INC for perl v5.6.1:
    /usr/local/lib/perl/5.6.1
    /usr/local/share/perl/5.6.1
    /usr/lib/perl5
    /usr/share/perl5
    /usr/lib/perl/5.6.1
    /usr/share/perl/5.6.1
    /usr/local/lib/site_perl
    /usr/lib/perl5/5.6
    /usr/lib/perl5/5.005/i386-linux
    /usr/lib/perl5/5.005
    .

---
Environment for perl v5.6.1:
    HOME=/home/btherl
    LANG=en_US
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=~/bin:/usr/local/bin:/usr/bin:/bin:/usr/bin/X11:/usr/games
    PERL_BADLANG (unset)
    SHELL=/bin/bash




nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About