#!perl
#***************************************************************
#
# ACTINIC.pm	- module for common functions among the Actinic scripts
#
# Written by George Menyhert
#
# Copyright (c) Actinic Software Ltd 1998
#
#***************************************************************

package ACTINIC;
require 5.002;

push (@INC, "cgi-bin");
<Actinic:Variable Name="IncludePathAdjustment"/>

require <Actinic:Variable Name="ActinicSafer"/>;
require <Actinic:Variable Name="ActinicDiffie"/>;
require <Actinic:Variable Name="ActinicEncrypt"/>;
require <Actinic:Variable Name="ActinicConstantsPackage"/>;

use Socket;
use strict;

umask (0177);												# update the process umask

#
# define some ACTINIC package constants
#

$ACTINIC::prog_name = 'ACTINIC.pm';					# Program Name
$ACTINIC::prog_name = $ACTINIC::prog_name;		# remove compiler warning
$ACTINIC::prog_ver = '$Revision: 21446 $ ';				# program version
$ACTINIC::prog_ver = substr($ACTINIC::prog_ver, 11); # strip the revision information
$ACTINIC::prog_ver =~ s/ \$//;						# and the trailers

$ACTINIC::BILLCONTACT 	= "INVOICE";
$ACTINIC::SHIPCONTACT 	= "DELIVERY";
$ACTINIC::SHIPINFO 		= "SHIPPING";
$ACTINIC::TAXINFO 		= "TAX";
$ACTINIC::GENERALINFO 	= "GENERAL";
$ACTINIC::PAYMENTINFO 	= "PAYMENT";
$ACTINIC::LOCATIONINFO 	= "LOCATION";

$ACTINIC::FILE				= 0;
$ACTINIC::SDTOUT			= 1;
$ACTINIC::MEMORY			= 2;

$ACTINIC::s_bTraceSocket = $::FALSE;
$ACTINIC::s_bTraceSockFirstPass = $::TRUE;
$ACTINIC::s_bTraceFileFirstPass = $::TRUE;

$ACTINIC::ORDER_BLOB_MAGIC = hex('10');
$ACTINIC::ORDER_DETAIL_BLOB_MAGIC = hex("11");

$ACTINIC::FORM_URL_ENCODED 			= 0;			# standard application/x-www-form-urlencoded (%xx) encoding	- This value is referenced in the PSP plug-ins - any changes need to be reflected there
$ACTINIC::MODIFIED_FORM_URL_ENCODED	= 1;			# Actinic format - identical to eParameter except an
																# underscore is used instead of a percent sign and the string is
																# prepended with an "a"
$ACTINIC::HTML_ENCODED					= 2;			# standard HTML encoding (&dd;)

$ACTINIC::B2B = new ACTINIC_B2B();					# Create B2B object to keep B2B parameters
$ACTINIC::USESAFE = $::TRUE;							# If true we attempt to use Safe.pm
$ACTINIC::USESAFEONLY = $::FALSE;					# If true, eval is only allowed in Safe.pm

$ACTINIC::MAX_RETRY_COUNT      = 10;
$ACTINIC::RETRY_SLEEP_DURATION = 1;
$ACTINIC::DOS_SLEEP_DURATION = 2;

$ACTINIC::AssertIsActive = $::FALSE;				# true if an assert is being reported
$ACTINIC::AssertIsLooping = $::FALSE;				# true if the assert function appears to be stuck in a loop
#
# Host mode indicator
#
$ACTINIC::ActinicHostMode = <Actinic:Variable Name="ActinicHostMode"/>;

################################################################
#
# GetStoreFolderName - returns the Store Folder's name, 
# which was always 'acatalog' in the previous versions  
#
# Returns: 	the Store Folder Name
#
################################################################

sub GetStoreFolderName
   {
   my $sStoreFolderName = $$::g_pSetupBlob{'CATALOG_URL'};
   #
   # match last folder name, both \ and / are allowed for separating folder names
   # trailing separator is also allowed
   #  
   if ($sStoreFolderName =~ /([^\/\\]+)([\/\\]?)$/)
      {
      return $1;
      }
   else
      {
#? ACTINIC::ASSERT($::FALSE, "Store Folder name was not found in Catalog URL ($#_)", __LINE__, __FILE__);
      }
   return "";
   }

################################################################
#
# GetActinicDate - Get the current date in Actinic
#	format (GMT server time)
#
# Returns: 	the date in YYYY/MM/DD HH:MM format
#
################################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
################################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# PSP plug ins!!!
# 20 Feb 2002 gmenyhert
#
################################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
################################################################

sub GetActinicDate
	{
	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	#
	# Get the current date/time on the server
	#
	my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst, $sDate);
	($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = gmtime(time);	# platform independent time
	$mon++;													# make month 1 based
	$year += 1900;											# make year AD based
	$sDate = sprintf("%4.4d/%2.2d/%2.2d %2.2d:%2.2d", $year, $mon, $mday, $hour, $min);
	#
	# Misc info
	#
	return($sDate);										# the date
	}

################################################################
#
# FormatDate - Takes the date formatting prompt and returns the
#	passed in strings in this order
#	The default format is dd/mm/yy
#
# Input:		0 - day
#				1 - month
#				2 - year
#				3 - editable/static ($::TRUE - editable[default])
#
# Returns: 	the date formatted as specified on the UI
#
# Author:	Zoltan Magyar, 10:14 PM 4/2/2002
#
################################################################

sub FormatDate
	{
	my ($sDay, $sMonth, $sYear, $bEditable) = @_;
	if (!defined $bEditable )
		{
		$bEditable = $::TRUE;							# which prompt to use? Default 1912
		}
	#
	# Format Date as required
	#
	my $sDatePrompt = ACTINIC::GetPhrase(-1, $bEditable ? 2247 : 1912);

	if ($sDatePrompt !~ s/dd/$sDay/i)
		{
		ACTINIC::ReportError(ACTINIC::GetPhrase(-1, 1913), ACTINIC::GetPath());
		}
	if ($sDatePrompt !~ s/mm/$sMonth/i)
		{
		ACTINIC::ReportError(ACTINIC::GetPhrase(-1, 1913), ACTINIC::GetPath());
		}
	if ($sDatePrompt !~ s/yy/$sYear/i)
		{
		ACTINIC::ReportError(ACTINIC::GetPhrase(-1, 1913), ACTINIC::GetPath());
		}
	return ($sDatePrompt);
	}

################################################################
#
# InitMonthMap - initialize the month maps.  This
#	subroutine must be called after ReadPromptFile.
#
# Affects: 	%::g_MonthMap (hash table mapping month names
#					to their numbers
#				%::g_InverseMonthMap - hash table inversion
#					of %::g_MonthMap
#
################################################################

sub InitMonthMap
	{
	%::g_MonthMap = (GetPhrase(-1, 0), 1,			# hash to convert month to digit
						GetPhrase(-1, 1), 2,
						GetPhrase(-1, 2), 3,
						GetPhrase(-1, 3), 4,
						GetPhrase(-1, 4), 5,
						GetPhrase(-1, 5), 6,
						GetPhrase(-1, 6), 7,
						GetPhrase(-1, 7), 8,
						GetPhrase(-1, 8), 9,
						GetPhrase(-1, 9), 10,
						GetPhrase(-1, 10), 11,
						GetPhrase(-1, 11), 12);
	my ($key, $value);
	while ( ($key, $value) = each %::g_MonthMap)	# build a revers map
		{
		$::g_InverseMonthMap{$value} = $key;
		}
	@::gMonthList = sort {$::g_MonthMap{$a} <=> $::g_MonthMap{$b}} keys %::g_MonthMap;
	}

################################################################
#
# GenerateComboHTML - generate HTML code for the given
#	range of selection
#
# Arguments:	0 - the control name
#					1 - default value
#					2 - format string ('%d' used if not specified)
#					3 - HTML style attribute
#					4 - array of items
#
# Return:		0 - the HTML string
#
# Zoltan Magyar - 11:54 PM 1/28/2002
#
################################################################

sub GenerateComboHTML
	{
	my ($sName, $nDefault, $sFormat, $sStyle, @aItems) = @_;
	if (!$sFormat)
		{
		$sFormat = "%d";
		}
	my $sItem;
	my $sHTML = "<SELECT NAME='$sName' SIZE='1' $sStyle>\n";
	foreach $sItem (@aItems)
		{
		if ($sItem eq $nDefault)						# use the default value
			{
			$sHTML .= '<OPTION SELECTED>' . sprintf($sFormat, $sItem) . "\n";
			}
		else													# just a standard non-selected value
			{
			$sHTML .= '<OPTION>' . sprintf($sFormat, $sItem) . "\n";
			}
		}
	$sHTML .= "</SELECT>";
	return ($sHTML);
	}

#######################################################
#
# GetCountryName - map the country code to country name
#
# Params:	0 - country code
#
# Returns:	0 - country name or undef on error
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# shipping plug in!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub GetCountryName
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in CountryName ($#_)", __LINE__, __FILE__);
#? ACTINIC::ASSERT(defined $::g_pLocationList, "Location list undefined", __LINE__, __FILE__);
	my $sCode = $_[0];
	return ($$::g_pLocationList{$sCode}{'NAME'});
	}

################################################################
#
#  IsValidIP - check if the given IP address is valid according
#				to the passed in rules.
#				The rule can be a comma separated list of the valid IP
#				addresses where '*' wildcard and '-' range specifier
#				(e.g. "10.1.1.10-20") can be used for any octet.
#
#  Input:		$sToCheck - the IP address to be checked
#					$sRules	 - the rules checked against
#
#  Output: 		$::TRUE - if the IP is valid
#
#  Author:  	Zoltan Magyar, 5/13/2003
#
#  Copyright (c) Actinic Software Ltd 2003
#
################################################################

sub IsValidIP
	{
#? ACTINIC::ASSERT($#_ == 1, "Invalid argument count in IsValidIP ($#_)", __LINE__, __FILE__);
	my $sToCheck 	= shift;								# IP address to be checked
	my $sRules		= shift;								# the list of rules
	my @aOctetsToCheck = split /\./, $sToCheck;	# get octets
	my $sError;												# rule format error if there is any
	#
	# Do some sanity check on the passed in IP
	#
	if (scalar @aOctetsToCheck != 4)					# if it doesn't look like an IP
		{														# report the error
		$sError = $sToCheck . " Invalid IP - the passed in IP does not have 4 octets.\r\n";
		SendMail($::g_sSmtpServer,
					$::g_pSetupBlob->{'EMAIL'},
					"Invalid IP Address Rule",
					$sError);								# send the message to the merchant
		RecordErrors($sError, GetPath());
		return $::FALSE;
		}
	#
	# Get list of IP rules
	#
	$sRules =~ s/\s//;									# get rid of white space first
	my @aRules = split /,/, $sRules;
	#
	# Check each IP rule
	#
	my $sIP;
	foreach $sIP (@aRules)
		{
		#
		# The checking is done on octet base rather than the full IP
		# so get the octets first.
		#
		my @aOctets = split /\./, $sIP;
		if (scalar @aOctets != 4)						# looks like an invalid octet?
			{													# log the problem
			$sError .= join('.',@aOctets) . " IP address rule seems to be invalid - not 4 octets\r\n";
			next;												# and take next
			}
		#
		# Now check octet by octet
		#
		my $nIndex;
		my $bValid = $::TRUE;
		for ($nIndex = 0; $nIndex < 4; $nIndex++)
			{
			#
			# Check for "*" wildcard character. If it matches then no
			# further validation is required for this octet
			#
			if ($aOctets[$nIndex] eq "*")				# "*" wildcard used -> anything allowed
				{
				next;
				}
			#
			# Check for a single numeric value. If the rule looks like this
			# then compare the appropriate octets.
			#
			elsif ($aOctets[$nIndex] =~ /^\d+$/)	# fix number for this octet
				{												# check if the numbers are identical
				if ($aOctets[$nIndex] == $aOctetsToCheck[$nIndex])
					{
					next;
					}
				}
			#
			# Check fo "x-y" type ranges. If this form is used then check if
			# the current octet fits in the range
			#
			elsif ($aOctets[$nIndex] =~ /^(\d+)\-(\d+)$/)	# x-y (range) used
				{												# check if we are in the range
				if ($aOctetsToCheck[$nIndex] >= $1 &&
					 $aOctetsToCheck[$nIndex] <= $2)
					{
					next;
					}
				}
			#
			# None of the rules can be applied so the form must be invalid
			# So log this problem but continue then (not a critical error)
			#
			else
				{
				$sError .= join('.',@aOctets) . " IP address rule seems to be invalid - none of the octet rules can be applied\r\n";
				last;
				}
			#
			# If we are here in case of any octet then the validation failed
			# for this rule. So indicate this a do not bother further validation.
			#
			$bValid = $::FALSE;
			last;
			}
		#
		# Checked all octets - now see if we find something
		#
		if ($bValid)
			{
			if (length $sError > 0)						# notify merchant about errors
				{
				RecordErrors($sError, GetPath());	# write it to the error.err
				SendMail($::g_sSmtpServer,
							$::g_pSetupBlob->{'EMAIL'},
							"Invalid IP Address Rule",
							$sError);						# send the message to the merchant
				}
			return $::TRUE;
			}
		}
	#
	# If we are here the IP address validation is failed
	#
	if (length $sError > 0)								# notify merchant about errors
		{
		RecordErrors($sError, GetPath());			# write it to the error.err
		SendMail($::g_sSmtpServer,
					$::g_pSetupBlob->{'EMAIL'},
					"Invalid IP Address Rule",
					$sError);								# send the message to the merchant
		}
	return $::FALSE;
	}

#######################################################
#
# GetHostname - attempt to retrieve the hostname
#
#	Returns:	0 - hostname or IP address or ''
#
#######################################################

sub GetHostname
	{
	my $sLocalhost = $ENV{SERVER_NAME};				# try the environment
	$sLocalhost =~ s/[^-a-zA-Z0-9.]//g;				# strip any bad characters

	if (!$sLocalhost)										# if still no hostname is found
		{
		$sLocalhost = $ENV{HOST};						# try a different environment variable
		$sLocalhost =~ s/[^-a-zA-Z0-9.]//g;			# strip any bad characters
		}
	if (!$sLocalhost)										# if still no hostname is found
		{
		$sLocalhost = $ENV{HTTP_HOST};				# try a different environment variable
		$sLocalhost =~ s/[^-a-zA-Z0-9.]//g;			# strip any bad characters
		}
	if (!$sLocalhost)										# if still no hostname is found
		{
		$sLocalhost = $ENV{LOCALDOMAIN};				# try a different environment variable
		$sLocalhost =~ s/[^-a-zA-Z0-9.]//g;			# strip any bad characters
		}
	if (!$sLocalhost)										# if still no hostname is found
		{
		$sLocalhost = `hostname`;						# try the command line
		$sLocalhost =~ s/[^-a-zA-Z0-9.]//g;			# strip any bad characters
		}
	if (!$sLocalhost &&									# if still no hostname and
		 $^O eq 'MSWin32')								# NT
		{
		my $sHost = `ipconfig`;							# run ipconfig and gather the collection of addresses
		$sHost =~ /IP Address\D*([0-9.]*)/;			# get the first address in the list
		$sLocalhost = $1;
		$sLocalhost =~ s/[^-a-zA-Z0-9.]//g;			# strip any bad characters
		}

	return ($sLocalhost);
	}

#######################################################
#
# HTTP_SendAndReceive - send some data to the server
#		and see the response
#
# Params:	0 - the remote server ip address
#			1 - the addressed port
#			2 - the path on the server
#			3 - the message to be sent - optional
#			4 - the method to be used (POST, GET) - optional
#					 the default option is GET
#
# Returns:	0 - status
#			1 - server message (e.g. HTTP/1.1 200 OK)
#					 or error message if connection failed
#			2 - the response
#
# Author: Zoltan Magyar - 04 Apr 2001
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# shipping plug in!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub HTTP_SendAndReceive
	{
#? ACTINIC::ASSERT($#_ >= 2, "Invalid argument count in HTTP_SendAndReceive ($#_)", __LINE__, __FILE__);
	#
	# Grab parameters
	#
	my ($sServer, $sPort, $sPath, $sContent, $sMethod) = @_;
	#
	# Set GET as default method
	#
	if (!defined $sMethod)
		{
		$sMethod = "GET";
		}
	#
	# Get protocol
	#
	my $proto = getprotobyname('tcp');
	my $ServerIP = inet_aton($sServer);
	if (!defined $ServerIP)
		{
		return($::FAILURE, GetPhrase(-1, 13, "$sServer: $!"), ''); # Record resolver error
		}

	my $sin = sockaddr_in($sPort, $ServerIP);
	if (!defined $sin)
		{
		return($::FAILURE, GetPhrase(-1, 14, $!), ''); # Record internal error
		}

	unless (socket(MYSOCKET, PF_INET, SOCK_STREAM, $proto))
		{
		return($::FAILURE, GetPhrase(-1, 1935, $!), ''); # Record internal error
		}

	unless (connect(MYSOCKET, $sin))
		{
		my $sError = GetPhrase(-1, 1934, $!);
		close(MYSOCKET);
		return($::FAILURE, $sError, ''); # Record internal error
		}
	#
	# Change file handle to disable buffer
	#
	my $old_fh = select(MYSOCKET);
	$| = 1; 		        # don't buffer output
	select($old_fh);
	#
	# POST the content to the specified path
	#
	binmode MYSOCKET;
	print MYSOCKET "$sMethod $sPath HTTP/1.0\r\n";
	print MYSOCKET "Content-Type: application/x-www-form-urlencoded\r\n";
	print MYSOCKET "Content-Length: " . (length $sContent) ."\r\n";
	print MYSOCKET "Accept: */*\r\n";
	print MYSOCKET "User-Agent: ActinicEcommerce\r\n";
	print MYSOCKET "\r\n";
	print MYSOCKET $sContent;
	#
	# Get the HTTP response line
	#
	my $sMessage = <MYSOCKET>;
	chomp($sMessage);
	if ($sMessage =~ /^HTTP.+\s([45].*)/)
		{
		close(MYSOCKET);
		return($::FAILURE, GetPhrase(-1, 1936, $1), ''); # Record internal error
		}
	#
	# Collect the whole response
	#
	my $sResponse;
	{
	local $/;
	$sResponse = <MYSOCKET>;								# read the entire file
	}
	#
	# Close the network connection
	#
	close(MYSOCKET);
	return($::SUCCESS, $sMessage, $sResponse);
	}

#######################################################
#
# HTTPS_SendAndReceive - send some data to the server
#		throgh the SSL socket and return the response
#
# Params:		0 - the remote server ip address
#				1 - the addressed port
#				2 - the path on the server
#				3 - the message to be sent - optional
#				4 - the method to be used (POST, GET) - optional
#					 the default option is GET
#				5 - true if we should close the connection after communication - optional (default: $::TRUE)
#				6 - reference to an opened ssl socket - optional
#
# Returns:		0 - status
#				1 - server message (e.g. HTTP/1.1 200 OK)
#					 or error message if connection failed
#				2 - the response
#				3 - the opened ssl socket - optional
#
# Author: Tibor Vajda
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# shipping plug in!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub HTTPS_SendAndReceive
	{
# ACTINIC::ASSERT($#_ >= 2, "Invalid argument count in HTTP_SendAndReceive ($#_)", __LINE__, __FILE__);
	#
	# Grab parameters
	#
	my ($sServer, $sPort, $sPath, $sContent, $sMethod, $bCloseConnection, $ssl_socket, $sHeader) = @_;
	#
	# Set GET as default method
	#
	if (!defined $sMethod)
		{
		$sMethod = "GET";
		}
	#
	# Set $::TRUE as default bCloseConnection value
	#
	if (!defined $bCloseConnection)
		{
		$bCloseConnection = $::TRUE;
		}
	#
	# Set up default header if it is not defined
	#
	if (!defined $sHeader)
		{
		$sHeader .= "Content-Type: application/x-www-form-urlencoded\r\n";
		$sHeader .= "Accept: */*\r\n";
		$sHeader .= "User-Agent: ActinicEcommerce\r\n";
		}
	my $sData = "$sMethod $sPath HTTP/1.0\r\n";
	$sData .= "Content-Length: " . (length $sContent) ."\r\n";
	$sData .= $sHeader;
	$sData .= "\r\n";
	$sData .= $sContent;

	my $sResponse;
	my $nResult = $::SUCCESS;
	my $sMessage = '';
	#
	# Open the communication socket	if necessary
	#
	if (!defined $ssl_socket)
		{
		#
		# First attempt: Net::SSL (OpenSSL-based) connection
		#
		eval
			{
			require Net::SSL;					# Try loading the SSL library
			#
			# Connect to the server
			#
			$ssl_socket = new Net::SSL(PeerAddr => $sServer, PeerPort => $sPort);
			if (!$ssl_socket)
				{
				$nResult = $::FAILURE;
				$sMessage = GetPhrase(-1, 1934, $!);
				}
			};
		#
		# Second attempt: ActinicSSL connection
		#
		if ($@)									# Error occured - the SSL library is probably not available
			{
			require <Actinic:Variable Name="ActinicSSL"/>;
			($nResult, $sMessage, $ssl_socket) = new ActinicSSL($sServer, $sPort);
			}
		}
	#
	# Check if any error occured
	#
	if ($nResult != $::SUCCESS)
		{
		return ($nResult, $sMessage, '');
		}
	#
	# Do the communication
	#
	if ($ssl_socket->isa('Net::SSL'))
		{
		#
		# Send the request info to the server
		#
		$ssl_socket->print($sData);
		#
		# Read the response from the server
		#
		my $buf ='';
		while ($ssl_socket->read($buf, 1024))
			{
			$sResponse .= $buf;
			}
		$nResult = $::SUCCESS;
		$sMessage = '';
		#
		# TV: I don't know ATM how Net::SSL can resume a connection, so always close the connection until further investigation
		#
		$bCloseConnection = $::TRUE;
		}
	elsif ($ssl_socket->isa('ActinicSSL'))
		{
		#
		# Send the request info to the server
		#
		($nResult, $sMessage) = $ssl_socket->send($sData);
		#
		# Read the response from the server
		#
		my $sResponseLine;
		while ($nResult == $::SUCCESS)
			{
			($nResult, $sMessage, $sResponseLine) = $ssl_socket->recv();
			$sResponse .= $sResponseLine;
			}
		#
		# EOF result is part of the normal behaviour
		#
		if ($nResult == $::EOF)
			{
			$nResult = $::SUCCESS;
			}
		#
		# TV: Resuming ActinicSSL connection needs further coding, we can't use it until that time
		#
		$bCloseConnection = $::TRUE;
		}
	else
		{
#? ACTINIC::ASSERT($::FALSE, "Unhandled SSL class provided ($#_)", __LINE__, __FILE__);
		}
	#
	# Close the connection if necessary
	#
	if ($bCloseConnection)
		{
		$ssl_socket->close();
		undef $ssl_socket;
		}

	return($nResult, $sMessage, $sResponse, $ssl_socket);
	}

#######################################################
#
# HTTP_SplitHeaderAndContent - Split the HTTP header and
#		content and parse the header
#
# Params:	0 - HTTP response
#
# Returns:	0 - status $::TRUE if OK
#				1 - error string
#				2 - header as a string
#				3 - content as a string
#				4 - ref to hash of type/value pairs for header
#
# Author: Mike Purnell - 01 May 2001
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# shipping plug in!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub HTTP_SplitHeaderAndContent
	{
	my ($sHTTPResponse) = @_;
	#
	# Find the blank line after the HTTP header
	#
	my $nHeaderEnd = index($sHTTPResponse, "\r\n\r\n");
	if($nHeaderEnd == -1)
		{
		return($::FALSE, 'Malformed HTTP response:' . $sHTTPResponse);
		}
	#
	# Split the response into header and content
	#
	my $sHeader = substr($sHTTPResponse, 0, $nHeaderEnd + 2);
	my $sContent = substr($sHTTPResponse, $nHeaderEnd + 4);
	#
	# Now parse the header into key value pairs
	#
	my @arrHeader = split(/\r\n/, $sHeader);		# split into an array of lines
	my ($sHeaderLine, $sHeaderType, $sHeaderValue);
	my %hashHeader;
	foreach $sHeaderLine(@arrHeader)					# for each header line
		{
		if($sHeaderLine ne '')							# if there is something there
			{
			($sHeaderType, $sHeaderValue) = split(/: */, $sHeaderLine); # split at the colon
			if($sHeaderValue)								# if there's a value
				{
				$hashHeader{$sHeaderType} =
					$sHeaderValue;							# set in the header hash
				}
			}
		}
	return($::TRUE, '', $sHeader, $sContent, \%hashHeader);
	}

#######################################################
#
# SendMail - Send an email to the specified email
#	address if this service has been requested.
#
#	Params:	0 - the smtp server ip address
#				1 - the destination email address
#				2 - the subject
#				3 - the message
#           4 - optional return address
#
#	Returns:	0 - status
#				1 - message
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# shipping plug in!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub SendMail
	{
#? ACTINIC::ASSERT($#_ >= 3, "Invalid argument count in SendMail ($#_)", __LINE__, __FILE__);

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	if ($#_ < 3)
		{
		return($::FAILURE, GetPhrase(-1, 12, 'Actinic::SendMail'), 0, 0);
		}

	my ($sSmtpServer, $sEmailAddress, $sSubjectText, $sMessageText, $sReturnAddress) = @_;
	#
	# pass it on to the rich mail function
	#
	return(SendRichMail($sSmtpServer, $sEmailAddress, $sSubjectText, $sMessageText, "", $sReturnAddress));
	}

#######################################################
#
# CheckSMTPResponse	-	Checks if the SMTP server
#								response is an error message
#								checks also if there were
#								any response at all
#								See RFC 821 for details
#
# Params:	0	-	SMTP socket
#				1	-	$bDetail request for detailed response
#									for authentication
#
# Returns:	0	$::SUCCESS	-	if SMTP command accepted
#					$::FAILURE	-	if any error occured or
#										nothing was responded
#				1	-	response message from the server
#				2	-	if $bDetail is $::TRUE, then a list
#						with all line(s) of response in format:
#						"code,message"
#
#######################################################

sub CheckSMTPResponse
	{
	my ($pSocket, $bDetail) = @_;
	my ($sMessage, $sCode, $bMore, $nResult, @lDetails);

	$nResult = $::SUCCESS;
	do
		{
		my $sTemp;
		$sMessage = readline($pSocket);				# read a line from SMTP server
		$sMessage =~ s/^(\d\d\d)(.?)//;				# parse and remove response code and contiune flag
		$sCode = $1;										# get response code
		$bMore = $2 eq "-";								# check if there is another line of this response
		if ($bDetail)
			{
			$sTemp = $sCode . ',' . $sMessage;		# construct the detail line
			push @lDetails, $sTemp;						# add it to the list
			}
		if (length $sCode < 3)							# not a valid SMTP response
			{
			$nResult = $::FAILURE;						# bad response code
			}
		if ($sCode =~ /^[45]/)							# if it is an error message
			{
			$nResult = $::FAILURE;						# this is an error response
			}
		} while ($bMore);									# continue reading if further line is reported
	if ($bDetail)
		{
		return ($nResult, $sMessage, @lDetails);
		}
	else
		{
		return ($nResult, $sMessage);
		}
	}

#######################################################
#
# SMTPAuthentication	-	It does the SMTP authentication
#								before the normal S?TP process
#								See RFC 2554 for details
#
# Params:	0	-	SMTP socket
#				1	-	reported SMTP server name
#				2	-	@lDetail initial response string
#									of the SMTP server
#
# Returns:	0	$::SUCCESS	-	if SMTP command accepted
#					$::FAILURE	-	if any error occured or
#										nothing was responded
#				1	-	response message from the server
#
#######################################################

sub SMTPAuthentication
	{
	my ($pSocket, $sReportedServerName, @lDetails) = @_;
	my ($sOfferedMethods, @lsSupportedMethods, $sTemp, $sSelectedMethod, $sSelectedHandler, $sMessage, $nResult, $nCode, $sAnswer);

	require <Actinic:Variable Name="ActinicSmtpAuth"/>;
	$ActinicSMTPAuth::sServername = $sReportedServerName;	# set the servername for Digest-MD5 authentication

	#
	# check if the response includes the AUTH string
	# which identify the Auth extension
	#
	foreach $sTemp (@lDetails)
		{
		my ($sCode, $sMessage) = split(/,/, $sTemp);
		if ($sTemp =~ /AUTH[ |=](.*)$/i)
			{
			$sOfferedMethods = $1;
			last;
			}
		}
	if (length $sOfferedMethods == 0)				# SMTP Authentication is not supported by this server
		{
		return ($::FAILURE, "SMTP Authentication is not supported by this server!");
		}
	for( my $nI = 0; $nI <= $#ActinicSMTPAuth::lsProtocol; $nI++)	# try to select the highest security level of auth method
		{
		if ($sOfferedMethods =~ /$ActinicSMTPAuth::lsProtocol[$nI]/i)
			{
			$sSelectedMethod = $ActinicSMTPAuth::lsProtocol[$nI];	# the name of the protocol
			$sSelectedHandler = $ActinicSMTPAuth::lpHandler[$nI];	# the handler routine in ActinicSMTPAuth.pm
			if (length $sSelectedMethod == 0)		# We couldn't find matching methods in Supported and offered methods!"
				{
				return ($::FAILURE, "We couldn't find matching methods in Supported and Offered methods!");
				}
			#
			# initiate the authentication process with the AUTH "$method" string
			#
			my $sAuthTrailer;
			($nResult, $sAuthTrailer) = &$sSelectedHandler(0, $sAnswer);	# get the AUTH command trailer string
			if ($nResult != $::SUCCESS)				# check for failures
				{
				return($::FAILURE, $sMessage);
				}
			$sTemp = "AUTH " . $sSelectedMethod . ' ' . $sAuthTrailer . "\r\n";
			unless (print $pSocket $sTemp)
				{
				$sMessage = GetPhrase(-1, 18, 2, $!);	# Record internal error
				return($::FAILURE, $sMessage);
				}
			my $bNeedMore = $::TRUE;
			for (my $nII = 1; 1; $nII++)				# do the necessery sends and receives
				{
				($nResult, $sMessage, @lDetails) = CheckSMTPResponse($pSocket, $::TRUE);	# see what the SMTP server's response
				$lDetails[0] =~ /([^,]*),(.*)/;
				$nCode = $1;
				$sAnswer = $2;
				#
				# Check the response code here.
				# If if it is 235, then we are authenticated,
				# else the response code must be 334 or error code
				#
				if ($nCode == 235)						# user is successfully authenticated
					{
					return ($::SUCCESS, '');
					}
				if ($nCode != 334)						# if the answer was not accepted by the server
					{
					last;										# fall back to the next method
					}
				#
				# Call the selected handler routine
				#
				($nResult, $sTemp, $bNeedMore) = &$sSelectedHandler($nII, $sAnswer);
				if ($nResult != $::SUCCESS)
					{
					return($::FAILURE, $sTemp);		# return the error for displaying
					}
				unless (print $pSocket $sTemp)		# send the string to the server
					{
					$sMessage = GetPhrase(-1, 18, 2, $!);	# Record internal error
					return($::FAILURE, $sMessage);
					}
				}
			}
		}
		return($::FAILURE, $nCode . ' ' . $sAnswer);	# return the answer for displaying
	}



#######################################################
#
# SendRichMail - Send an email to the specified email
#	address if this service has been requested.
#
#	Params:	0 - the smtp server ip address
#				1 - the destination email address
#				2 - the subject
#				3 - the message as text
#				4 - the message as HTML
#           5 - optional return address
#
#	Returns:	0 - status
#				1 - message
#
#######################################################

sub SendRichMail
	{
#? ACTINIC::ASSERT($#_ >= 4, "Invalid argument count in SendRichMail ($#_)", __LINE__, __FILE__);

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	if ($#_ < 4)
		{
		return($::FAILURE, GetPhrase(-1, 12, 'Actinic::SendRichMail'), 0, 0);
		}

	my ($sSmtpServer, $sEmailAddress, $sLocalError, $sSubjectText, $sMessageText, $sMessageHTML, $sBoundary, $sReturnAddress);
	($sSmtpServer, $sEmailAddress, $sSubjectText, $sMessageText, $sMessageHTML, $sReturnAddress) = @_;
	my (@lDetails);
	#
	# Check if the SMTP server is specified. If not, then there is no need for e-mail
	#
	if ($sSmtpServer eq '')
		{
		return($::FAILURE, GetPhrase(-1, 2306), 0, 0); # Record internal error
		}
	#
	# Check message content for bare LFs and repair if there are some
	#

	$sMessageText =~ s/\r\n/\n/g;        			# CRLF -> LF
	$sMessageText =~ s/\r/\n/g;          			# remaining CR -> LF
	$sMessageText =~ s/\n/\r\n/g;        			# all LF -> CRLF
																# and check the HTML content as well
	$sMessageHTML =~ s/\r\n/\n/g;        			# CRLF -> LF
	$sMessageHTML =~ s/\r/\n/g;          			# remaining CR -> LF
	$sMessageHTML =~ s/\n/\r\n/g;        			# all LF -> CRLF
	#
	# Check the return address
	#
	if (!$sReturnAddress)								# if no return address defined
		{
		$sReturnAddress = $sEmailAddress;			# use the destination email address
		}
	#
	# Gather the SMTP host, server, and socket information
	#
	my ($nProto, $them, $nSmtpPort, $sLocalHost, $sMessage, $serverIP);

	my $sLocalhost = GetHostname();					# get the local machine name or ip address
	if ($sLocalhost eq '')
		{
		$sLocalhost = 'localhost';						# try localhost as a final possibility
																# GetHostname should not fail on most of the systems
		}

	$nProto = getprotobyname('tcp');
	$nSmtpPort = 25;										# Use default port

	$serverIP = inet_aton($sSmtpServer);			# due the dns lookup and get the ip address
	if (!defined $serverIP)
		{
		return($::FAILURE, GetPhrase(-1, 13, "$sSmtpServer: $!"), 0, 0); # Record resolver error
		}

	$them = sockaddr_in($nSmtpPort, $serverIP);	# create the sockaddr
	if (!defined $them)
		{
		return($::FAILURE, GetPhrase(-1, 14, $!), 0, 0); # Record internal error
		}

	unless (socket(MYSOCKET, PF_INET, SOCK_STREAM, $nProto))	# create the socked
		{
		return($::FAILURE, GetPhrase(-1, 15, $!), 0, 0); # Record internal error
		}

	unless (connect(MYSOCKET, $them))				# connect to the remote host
		{
		$sLocalError = GetPhrase(-1, 16, $!);		# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	binmode MYSOCKET;										# just incase

	my($oldfh) = select(MYSOCKET);					# make MYSOCKET the current file handle
	$| = 1;													# make each command send a flush
	select($oldfh);										# return to the default file handle
	my $SMTPSocket = *MYSOCKET;
	my $nResult;											# $::SUCCESS if the response was OK
	($nResult, $sMessage) = CheckSMTPResponse($SMTPSocket);	# see what the SMTP server has to say
	$sMessage =~ /([^ ]*)/;								# parse the server name reported by the SMTP server itself
	my $sReportedServerName = $1;
	if ($nResult != $::SUCCESS)						# check for failures
		{
		$sLocalError = GetPhrase(-1, 17, 1, $sMessage);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}
	my $sHelloMsg = ($::bSTMPAuth == $::TRUE ? 'EHLO ' : 'HELO ') . "$sLocalhost\r\n";
	unless (print MYSOCKET $sHelloMsg)				# start the conversation with the SMTP server
		{
		$sLocalError = GetPhrase(-1, 18, 1, $!);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	($nResult, $sMessage, @lDetails) = CheckSMTPResponse($SMTPSocket, $::TRUE);	# see what the SMTP server has to say
	if ($nResult != $::SUCCESS)						# check for failures
		{
		$sLocalError = GetPhrase(-1, 17, 2, $sMessage);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}
	if ($::bSTMPAuth == $::TRUE)						# check if Authentication is requested
		{
		($nResult, $sMessage) = SMTPAuthentication($SMTPSocket, $sReportedServerName, @lDetails);	# call Authentication routine
		if ($nResult != $::SUCCESS)					# check for failures
			{
			$sLocalError = GetPhrase(-1, 17, 1, $sMessage);	# Record internal error
			close MYSOCKET;
			return($::FAILURE, $sLocalError, 0, 0);
			}
		}

	unless (print MYSOCKET "MAIL FROM:<" . $sReturnAddress . ">\r\n") # specify the origin
		{
		$sLocalError = GetPhrase(-1, 18, 2, $!);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	($nResult, $sMessage) = CheckSMTPResponse($SMTPSocket);	# see what the SMTP server has to say
	if ($nResult != $::SUCCESS)						# check for failures
		{
		$sLocalError = GetPhrase(-1, 17, 3, $sMessage);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	unless (print MYSOCKET "RCPT TO:<",$sEmailAddress,">\r\n") # reciepient is always the supplier
		{
		$sLocalError = GetPhrase(-1, 18, 3, $!);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	($nResult, $sMessage) = CheckSMTPResponse($SMTPSocket);	# see what the SMTP server has to say
	if ($nResult != $::SUCCESS)						# check for failures
		{
		$sLocalError = GetPhrase(-1, 17, 4, $sMessage);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	unless (print MYSOCKET "DATA\r\n")				# the rest of the is the message body until the <CRLF>.<CRLF>
		{
		$sLocalError = GetPhrase(-1, 18, 4, $!);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	($nResult, $sMessage) = CheckSMTPResponse($SMTPSocket);	# see what the SMTP server has to say
	if ($nResult != $::SUCCESS)						# check for failures
		{
		$sLocalError = GetPhrase(-1, 17, 5, $sMessage);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	if ($sMessageText ne '' && $sMessageHTML ne '')	# if both messages are specified
		{
		#
		# make up our multi-part boundary from the order number
		#
		$sBoundary = "------------" . $::g_InputHash{ORDERNUMBER};
		#
		# let server know we are sending MIME
		#
		unless (print MYSOCKET "MIME-Version: 1.0\r\n") # MIME version
			{
			$sLocalError = GetPhrase(-1, 18, 11, $!);	# Record internal error
			close MYSOCKET;
			return($::FAILURE, $sLocalError, 0, 0);
			}
		}
	else														# this isn't a multi-part message
		{
		$sBoundary = "";									# clear the boundary
		}
	#
	# Print date header
	#
	my ($month, $now, @now, $sNow);
	my (@months) = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');

	$now = time;
	@now = gmtime($now);
	$month = $months[$now[4]];
	$sNow = sprintf("%02d %s %04d %02d:%02d:%02d GMT", $now[3], $month, $now[5]+1900, $now[2], $now[1], $now[0]);

	unless (print MYSOCKET "Date: $sNow\r\n") 	# Date
		{
		$sLocalError = GetPhrase(-1, 18, 5, $!);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	unless (print MYSOCKET "From: $sReturnAddress\r\n") # subject
		{
		$sLocalError = GetPhrase(-1, 18, 5, $!);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	unless (print MYSOCKET "Subject: $sSubjectText\r\n") # subject
		{
		$sLocalError = GetPhrase(-1, 18, 6, $!);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	unless (print MYSOCKET "To: $sEmailAddress\r\n") # subject
		{
		$sLocalError = GetPhrase(-1, 18, 7, $!);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	unless (print MYSOCKET "Reply-To: $sReturnAddress\r\n") # subject
		{
		$sLocalError = GetPhrase(-1, 18, 8, $!);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	if ($sBoundary ne '')								# if both message types are specified
		{
		my $sContentMultipart = "Content-Type: multipart/alternative; ";
		$sContentMultipart .= "boundary=\"" . $sBoundary . "\"\r\n\r\n";

		unless (print MYSOCKET $sContentMultipart) # content-type
			{
			$sLocalError = GetPhrase(-1, 18, 12, $!);	# Record internal error
			close MYSOCKET;
			return($::FAILURE, $sLocalError, 0, 0);
			}
		}
	else														# add Content-Type headers anyway
		{
		my $sContentType = "Content-Type: text/plain; charset=ISO-8859-1\r\n";
		$sContentType .= "Content-Transfer-Encoding: 8bit\r\n";
		unless (print MYSOCKET $sContentType) # content-type
			{
			$sLocalError = GetPhrase(-1, 18, 12, $!);	# Record internal error
			close MYSOCKET;
			return($::FAILURE, $sLocalError, 0, 0);
			}
		}

	unless (print MYSOCKET "\r\n")					# blank line
		{
		$sLocalError = GetPhrase(-1, 18, 8, $!);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	if ($sBoundary ne '')								# if both message types are specified
		{
		#
		# send the text multipart
		#
		my $sTextMultipart = "--" . $sBoundary . "\r\n";
		$sTextMultipart .= "Content-Type: text/plain; charset=us-ascii\r\n";
		$sTextMultipart .= "Content-Transfer-Encoding: 7bit\r\n\r\n" . $sMessageText . "\r\n\r\n";

		unless (print MYSOCKET $sTextMultipart)	# text content
			{
			$sLocalError = GetPhrase(-1, 18, 13, $!);	# Record internal error
			close MYSOCKET;
			return($::FAILURE, $sLocalError, 0, 0);
			}

		#
		# send the HTML multipart
		#
		my $sHTMLMultipart = "--" . $sBoundary . "\r\n";
		$sHTMLMultipart .= "Content-Type: text/html; charset=us-ascii\r\n";
		$sHTMLMultipart .= "Content-Transfer-Encoding: 7bit\r\n\r\n" . $sMessageHTML . "\r\n\r\n";

		unless (print MYSOCKET $sHTMLMultipart)	# HTML content
			{
			$sLocalError = GetPhrase(-1, 18, 14, $!);	# Record internal error
			close MYSOCKET;
			return($::FAILURE, $sLocalError, 0, 0);
			}

		#
		# send the final boundary
		#
		my $sEndMultipart = "--" . $sBoundary . "--\r\n";
		unless (print MYSOCKET $sEndMultipart)		# multipart terminator
			{
			$sLocalError = GetPhrase(-1, 18, 15, $!);	# Record internal error
			close MYSOCKET;
			return($::FAILURE, $sLocalError, 0, 0);
			}
		}
	else
		{
		unless (print MYSOCKET "$sMessageText\r\n")	# just spacing
			{
			$sLocalError = GetPhrase(-1, 17, 6, $sMessage); # Record internal error
			close MYSOCKET;
			return($::FAILURE, $sLocalError, 0, 0);
			}
		}
	unless (print MYSOCKET "\r\n.\r\n")				# finish the message
		{
		$sLocalError = GetPhrase(-1, 18, 9, $!);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	($nResult, $sMessage) = CheckSMTPResponse($SMTPSocket);	# see what the SMTP server has to say
	if ($nResult != $::SUCCESS)						# check for failures
		{
		$sLocalError = GetPhrase(-1, 17, 7, $sMessage);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	unless (print MYSOCKET "QUIT\r\n")				# end the conversation
		{
		$sLocalError = GetPhrase(-1, 18, 10, $!);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	($nResult, $sMessage) = CheckSMTPResponse($SMTPSocket);	# see what the SMTP server has to say
	if ($nResult != $::SUCCESS)						# check for failures
		{
		$sLocalError = GetPhrase(-1, 17, 8, $sMessage);	# Record internal error
		close MYSOCKET;
		return($::FAILURE, $sLocalError, 0, 0);
		}

	shutdown MYSOCKET, 1;								# shutdown sends
	close MYSOCKET;										# done

	return($::SUCCESS, '', 0, 0);
	}

#######################################################
#
# GetScriptUrl - retrieve an url to the specified script
#
# Input 	: $sScriptID - ID of the script
#
# Returns:	0 - URL of the script
#
#######################################################

sub GetScriptUrl
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in GetScriptUrl ($#_)", __LINE__, __FILE__);
	my $sScriptID = shift;
	#
	# Compose the script url
	#
	my $sCgiUrl = $$::g_pSetupBlob{CGI_URL};		# Full HTTP path to cgi-bin
	#
	# Make CGI URL relative (by stripping server part) when
	# the 'Use Relative CGI URLs' option is selected
	#
	if ($$::g_pSetupBlob{'USE_RELATIVE_CGI_URLS'})
		{
		$sCgiUrl =~ s/http(s?):\/\/[^\/]*\//\//;	# strip server part
		}
	$sCgiUrl .= "%s" . sprintf("%6.6d%s",$$::g_pSetupBlob{CGI_ID},$$::g_pSetupBlob{CGI_EXT});
	#
	# Determine the final script call form
	#
	$sCgiUrl = sprintf($sCgiUrl, $sScriptID);
	return $sCgiUrl;
	}

#######################################################
#
# GetCookies - retrieve the actinic cookies
#
# Returns:	0 - cart ID (undef if undefined)
#				1 - checkout details (undef if undefined)
#
#######################################################

sub GetCookies
	{
	my ($sCookie, $sCookies);
	$sCookies = $::ENV{'HTTP_COOKIE'};				# try to retrieve the cookie
	my (@CookieList) = split(/;/, $sCookies);		# separate the various cookie variables in the list
	my ($sLabel);
	my ($sCartID, $sContactDetails);
	foreach $sCookie (@CookieList)
		{
		$sCookie =~ s/^\s*//;							# strip leading white space
		if ($sCookie =~ /^ACTINIC_CART/)				# found the cart ID
			{
			($sLabel, $sCartID) = split (/=/, $sCookie);	# retrieve the value
			#
			# Make the cart ID secure by locking out any shell type characters
			#
			$sCartID =~ /([a-zA-Z0-9]+)/;				# cart ID's are just characters
			$sCartID = $1;
			}
		elsif ($sCookie =~ /^ACTINIC_CONTACT/)		# found the contact details
			{
			($sLabel, $sContactDetails) = split (/=/, $sCookie);	# retrieve the value
			#
			# strip any trailing or leading quotes and spaces
			#
			$sContactDetails =~ s/^\s*"?//;        # " # here for emacs formatting
			$sContactDetails =~ s/"?\s*$//;        # " # here for emacs formatting
			}
		elsif ($sCookie =~ /^ACTINIC_REFERRER=(.*)/)	# found the referrer cookie
			{
			#
			# Limited implementation, only for non-framed sites
			#
		 	my ($bDefined, $sAlternatePath) = IsCustomVarDefined('ACT_REFERRERCOOKIE_OFF');
		 	if (!$bDefined &&								# if referrer cookie is not disabled
		 		 !IsCatalogFramed() &&					# and catalog is not framed
				 !$$::g_pSetupBlob{CLEAR_ALL_FRAMES})	# and custom frames not used
		 		{
				$::g_sReferrer = DecodeText($1, $ACTINIC::FORM_URL_ENCODED);	# decode the URL
				}
			}
		}
	if ($::g_sReferrer eq "")							# if the cookie ACTINIC_REFERRER was missing
		{
		$::g_sReferrer = $::ENV{"HTTP_REFERER"};	# save environment referrer URL
		}
	#
	# Make sure that the referrer is set and correctly formatted
	#
	ParseReferrer();

	my ($sDigest,$sBaseFile) = ACTINIC::CaccGetCookies();
	if ($sDigest ||										# if registered buyer
		$::g_InputHash{HASH})							# or buyer is logging in
		{
		$sContactDetails = "";							# we don't need the contact details
		}
	return ($sCartID, $sContactDetails);
	}

################################################################
#
# ParseReferrer - parse the referrer URL
#
################################################################

sub ParseReferrer
	{
	my ($sURL);
	$::g_bRealReferrer = $::TRUE;					# flag to indicate source of URL
	$sURL = $::g_sReferrer;						# get local copy of globally stored referrer
	if ((defined %::g_InputHash) &&				# override the real referrer with the passed value
	    (defined $::g_InputHash{ACTINIC_REFERRER}))
		 {
		 $sURL = $::g_InputHash{ACTINIC_REFERRER};
		 }
	$sURL =~ s/(.*)([\?|\&]ACTINIC_REFERRER=.*?)(\&.*|$)/$1$3/i;	# remove ACTINIC_REFERRER from incoming URL

	if ((defined %::g_InputHash) &&					# if we have input parameters
	    (defined $::g_InputHash{ACTINIC_REFERRER}))	# and ACTINIC_REFERER is present
		{
		$::g_InputHash{ACTINIC_REFERRER} = $sURL;	# then replace it with the URL without the ACTINIC_REFERRER parameter
		}

	if (($sURL !~ /\/$/) &&								# Make sure that if URL is a directory it ends with '/'
		($sURL ne ""))
		{
		my @lFields = split('/',$sURL);				# Split it into fields
		my $sFnam = pop @lFields;						# Get last field
		#
		# Check if it looks like a file name
		#
		if ($sFnam !~ /\./) 								# it doesn't seem to be a filename
			{
			if ($sFnam =~ /\?/ || 						# however it could be a file ref if it inlcudes cgi parameters
				 $sFnam =~ /&/)
				{
				$sURL = '';									# this is not a valuable URL for us - could be misleading, so delete it
				}
			else
				{
				$sURL .= '/';								# looks like a directory without trailing '/', add it
				}
			}
		else													# it could be a file
			{
			pop @lFields;
			my $sPrev = pop @lFields;					# Get the previous entry
			if ($sPrev=~ /^http(s?):/)					# Is it http/https?
				{												# If so then the referrer is a server only
				$sURL .= '/';								# so add trailing '/'
				}
			}
		}
	#
	# There are four possibilities here
	# We have a URL from HTTP_REFERER
	# We have a URL from ACTINIC_REFERRER cookie
	# We have a URL from ACTINIC_REFERRER input field
	# We don't have a URL, in this case we shall invent one
	#
	if ($sURL eq '')										# empty URL (blocked HTTP_REFERER and referrer cookie not set)
		{
		if (ACTINIC::IsCatalogFramed())				# framed Catalog
			{
			$sURL = $$::g_pSetupBlob{CATALOG_URL} . $$::g_pSetupBlob{FRAMESET_PAGE};	# URL of frameset
			}
		else													# not framed
			{
			$sURL = $$::g_pSetupBlob{CATALOG_URL} . $$::g_pSetupBlob{CATALOG_PAGE};		# URL of Catalog
			}
		$::g_bRealReferrer = $::FALSE;				# generated referrer URL
		}
	#
	# SSL bounce passes the cookie content as CGI parameter. It could be a long string
	# which leads to hanging pages on java/javascript redirects because IE6 security
	# changes (cix:act_dev/enquire_within:1335)
	# So just strip this parameter when the referrer is requested.
	#
	$sURL =~ s/COOKIE\=[^\&]*\&//;

	if ((defined $::g_InputHash{challenge}) &&			# and it was the business login page
	    (!defined $::g_InputHash{ACTINIC_REFERRER}))	# and ACTINIC_REFERRER is not defined
	   {
	   $::g_InputHash{ACTINIC_REFERRER} = $sURL;			# store the base page
	   }
	$::g_sReferrer = $sURL;										# store the modified URL
	}

#######################################################
#
# GetReferrer - retrieve the referrer URL
#
# Returns:	0 - referring URL
#
#######################################################

sub GetReferrer
	{
	return ($::g_sReferrer);
	}

#######################################################
#
# TrimHashEntries - trim leading and trailing white
#	space from every value in the hash table
#
# Params:	0 - in/out - pointer to the hash
#
#######################################################

sub TrimHashEntries
	{
#? ACTINIC::ASSERT(0 == $#_, "Invalid parameter count in TrimHashEntries, $#_", __LINE__, __FILE__);
	my $pHash = $_[0];
	#
	# process each entry in the hash
	#
	my ($key, $value);
	while ( ($key, $value) = each %$pHash)
		{
		$$pHash{$key} =~ s/^\s*(.*?)\s*$/$1/gs;
		}
	}

#######################################################
#
# UUEncode - Returns a base 64 encoded string
#
# Params:	[0] - $sInputString
#
# Returns:	($sOutput) - Encoded string
#
#######################################################

sub UUEncode
	{
	my ($sInput) = @_;
	my $sOutput = "";
	my ($i, $cByte, $nByteNo, $nLeftOver);
	my @arrInput = unpack("C*", $sInput);
	use integer;
	#
	# Lookup table for output characters
	#
	my $sLookup = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";

	$nByteNo = 0;
	foreach $cByte (@arrInput)
		{
		if($nByteNo == 0)
			{
			#
			# The first input byte just takes the top 6 bits
			# and then passes on the lower 2 bits to be the
			# top 2 bits of the next byte
			#
			$sOutput .= substr($sLookup, ($cByte >> 2) & 63, 1);
			$nLeftOver = ($cByte << 4) & 48;			# Leave 2 bits
			$nByteNo++;
			}
		elsif($nByteNo == 1)
			{
			#
			# The second input byte takes the top 4 bits
			# and makes them the lower 4 bits, combined with
			# the two bits from the first byte
			#
			$sOutput .= substr($sLookup, $nLeftOver | (($cByte >> 4) & 15), 1);
			$nLeftOver = ($cByte << 2) & 60;			# Keep lower 4 bits (shifted up)
			$nByteNo++;
			}
		elsif($nByteNo == 2)
			{
			#
			# Finally we take the left over 4 bits as the
			# upper 4 bits, together with 2 bits from
			# the top of the new byte. The last 6
			# bits can be used as-is
			#
			$sOutput .= substr($sLookup, $nLeftOver | (($cByte >> 6) & 3), 1);
			$sOutput .= substr($sLookup, $cByte & 63, 1);		# Take last 6 bits
			$nByteNo = 0;
			}
		}
	if($nByteNo == 1)
		{
		$sOutput .= substr($sLookup, $nLeftOver, 1);
		$sOutput .= '==';
		}
	elsif($nByteNo == 2)
		{
		$sOutput .= substr($sLookup, $nLeftOver, 1);
		$sOutput .= '=';
		}
	return($sOutput);
	}

#######################################################
#
# SplitString - Splits a string into a number of lines
#
# Input:	[0] - $sText - the text to split
#			[1] - $nWidth - how wide the lines should be
#			[2] - $sDelimiter - delimiter for lines
#
# Returns:	($sOutput) - Split string
#
#######################################################

sub SplitString
	{
	my ($sText, $nWidth, $sDelimiter) = @_;
	my ($sOutput, $sTemp, $nStart, $nIndex);

	$nStart = 0;
	while($sText ne '')
		{
		$sTemp = substr($sText, 0, $nWidth + 1);
		if($sTemp =~ / $/)
			{
			$sTemp =~ s/ $//;
			$nStart = $nWidth + 1;
			}
		else
			{
			if(length($sTemp) <= $nWidth)
				{
				$sOutput .= $sTemp;
				last;
				}
			$nIndex = rindex($sTemp, ' ');
			if($nIndex == -1)
				{
				$sOutput .= $sTemp;
				last;
				}
			$sTemp = substr($sTemp, 0, $nIndex);
			$nStart = $nIndex + 1;
			}
		$sText = substr($sText, $nStart);
		$sOutput .= $sTemp . $sDelimiter;
		}
	return($sOutput);
	}

##################################################################################
#																											#
# HTML manipulation functions - begin															#
#																											#
##################################################################################

#######################################################
#
# ProcessEscapableText - encode the text from the
#	specified string leaving escaped regions raw.
#
# Params:	0 - the string to convert
#
# Returns:	0 - status
#				1 - modified string or error message (if any)
#				2 - 0
#				3 - 0
#
#######################################################

sub ProcessEscapableText
	{
 #? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ProcessEscapableText ($#_)", __LINE__, __FILE__);

    my ($sString) = @_;
    #
	# First see if there is any escaped text
    #
    my (@Response);
    if ($sString !~ /!!</)                              # no escaped text
       {
       return (EncodeText($sString));                   # encode it
       }
    #
	# Pick apart the string
    #
    my $sNewString = '';
	while ( $sString =~	m/(.*?)!!<(.*?)>!!(.*)/s )	# pick out embedded HTML
       {
       @Response = EncodeText($1);                     # encode preceding text
       if ($Response[0] != $::SUCCESS)
          {
          return (@Response);
          }
       $sNewString .= $Response[1] . $2;               # encode text + raw HTML
       $sString = $3;                                  # now look for more
       }
    @Response = EncodeText($sString);                  # encode final part
    if ($Response[0] != $::SUCCESS)
       {
       return (@Response);
       }
    $sNewString .= $Response[1];                       # add in final part
    return ($::SUCCESS, $sNewString, 0, 0);
	}

#######################################################
#
# EncodeText2 - convert then non-alphanumeric characters in
#	the supplied string to &#xx; where xx is the
#	equivalent decimal code for the character.  This is
#	needed for the HTML printout
#
# Params:	0 - the string to convert
#				1 - (optional) if TRUE, do HTML encoding (&#d;)
#					if FALSE, do CGI encodeing (%x).  Default - TRUE
#				2 - (optional) if TRUE make spaces &nbsp;,
#					default - FALSE.  Only makes sense in
#					the context of 1 = TRUE
#
# Returns:	0 - modified string
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# PSP plug ins!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub EncodeText2
	{
	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	my @Response = EncodeText(@_);
#? ACTINIC::ASSERT($Response[0] == $::SUCCESS, "It looks like EncodeText can return an error.", __LINE__, __FILE__);
	return ($Response[1]);
	}

#######################################################
#
# EncodeText - convert then non-alphanumeric characters in
#	the supplied string to &#xx; where xx is the
#	equivalent decimal code for the character.  This is
#	needed for the HTML printout
#
# Params:	0 - the string to convert
#				1 - (optional) if TRUE, do HTML encoding (&#d;)
#					if FALSE, do CGI encodeing (%x).  Default - TRUE
#				2 - (optional) if TRUE make spaces &nbsp;,
#					default - FALSE.  Only makes sense in
#					the context of 1 = TRUE
#
# Returns:	0 - status
#				1 - modified string or error message (if any)
#				2 - 0
#				3 - 0
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# PSP plug ins!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub EncodeText
	{
#? ACTINIC::ASSERT($#_ >= 0, "Invalid argument count in EncodeText ($#_)", __LINE__, __FILE__);

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	my ($sString, $bHtmlEncoding, $bNBSP) = @_;
	if (!defined $bHtmlEncoding)						# default encoding is HTML
		{
		$bHtmlEncoding = $::TRUE;
		}
	if (!defined $bNBSP)									# default NBSP is FALSE
		{
		$bNBSP = $::FALSE;
		}
	#
	# Do the substitution.
	#
	if ($bHtmlEncoding)									# HTML encoding
		{
		$sString =~ s/(\W)/sprintf('&#%d;', ord($1))/eg;	# regular space substitution
		}
	else														# CGI encoding
		{
		$sString =~ s/(\W)/sprintf('%%%2.2x', ord($1))/eg;	# regular space substitution
		}

	if ($bNBSP)												# if we want non-breaking spaces
		{
		$sString =~ s/&#32;/&nbsp;/g;					# replace the normal spaces with the non-breaking versions
		}														# NOTE: this does nothing if ! $bHtmlEncoding

	return ($::SUCCESS, $sString, 0, 0);
	}

#######################################################
#
# DecodeText - this function is similar
#	to EncodeText with two exceptions: 1) it deals with
#	characters stored as %xx and 2) it works in reverse
#	restoring the character for the % value
#
# Params:	0 - the string to convert
#				1 - decode method flag $ACTINIC::HTML_ENCODED or $ACTINIC::FORM_URL_ENCODED or $ACTINIC::MODIFIED_FORM_URL_ENCODED
#					$ACTINIC::HTML_ENCODED = standard html encoding (&)
#					$ACTINIC::FORM_URL_ENCODED = decode using application/x-www-form-urlencoded (%xx)
#					$ACTINIC::MODIFIED_FORM_URL_ENCODED = Actinic format - identical to $::FORM_URL_ENCODED except an
#						underscore is used instead of a percent sign and the string is
#						prepended with an "a".  This encoding is used to map arbitrary
#						strings into HTML "ID and NAME" data types.
#						NAME tokens must begin with a letter ([A-Za-z]) and may be
#						followed by any number of letters, digits ([0-9]), hyphens ("-"),
#						underscores ("_"), colons (":"), and periods (".")
#
# Returns:	($sString) - the converted string
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# PSP plug ins!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub DecodeText
	{
#? ACTINIC::ASSERT($#_ == 1, "Invalid argument count in DecodeText ($#_)", __LINE__, __FILE__);

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	my ($sString, $eEncoding) = @_;

	if ($eEncoding == $ACTINIC::MODIFIED_FORM_URL_ENCODED)
		{
		$sString =~ s/^a//;								# string the leading a
		$sString =~ s/_([A-Fa-f0-9]{2})/pack('c',hex($1))/ge;	# Convert _XX from hex numbers to character equivalent
		}
	elsif ($eEncoding == $ACTINIC::FORM_URL_ENCODED)
		{
		$sString =~ s/\+/ /g;							# replace + signs with the spaces they represent
		$sString =~ s/%([A-Fa-f0-9]{2})/pack('c',hex($1))/ge;	# Convert %XX from hex numbers to character equivalent
		}
	elsif ($eEncoding == $ACTINIC::HTML_ENCODED)
		{
#		$sString =~ s/(\W)/sprintf('&#%d;', ord($1))/eg;	# regular space substitution
		$sString =~ s/&#([0-9]+);/chr($1)/eg;
		}
	else
		{
#? ACTINIC::ASSERT($::FALSE, 'Invalid encodgin argument to DecodeText' . " ($eEncoding)", __LINE__, __FILE__);
		}

	return ($sString);
	}

#######################################################
#
# DecodeXOREncryption - xor the chars of some text
#
# Input:	0	- string for the original text
#			1	- password to use for encryption
#
# Return:	0	- the modified string
#
#######################################################

sub DecodeXOREncryption
	{
	my ($sOriginal, $sPassword) = @_;

	my $sDest;
	my $cOrigChar;
	my $cChar;
	my $nPwLen = length($sPassword);
	my $nCount = 0;
	my @aASCII = split(/ /, $sOriginal);
	my $nASCII;
	foreach $nASCII (@aASCII)
		{
		my $nIdx = ($nCount % $nPwLen);
		$cChar = substr($sPassword, $nIdx, 1);
		$cOrigChar = chr($nASCII);
		$sDest .= chr(ord($cOrigChar) ^ ord($cChar));
		$nCount++;
		}
	return($sDest);
	}


#######################################################
#
# TemplateFile - replace the vars in the template file
#	with the values stored in the variable table
#
# Params:	0 - template filename
#				1 - a reference to the variable table
#				2 - binmode indicator
#
# Returns:  0 - $::SUCCESS or $::FAILURE on error
#				1 - error message
#				2 - modified HTML
#				3 - 0
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# PSP plug ins!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub TemplateFile
	{
#? ACTINIC::ASSERT($#_ >= 0, "Invalid argument count in TemplateFile ($#_)", __LINE__, __FILE__);

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	my ($sFilename, $pVariableTable, $bBinmode);
	($sFilename, $pVariableTable, $bBinmode) = @_;

	unless (open (TFFILE, "<$sFilename"))
		{
		return($::FAILURE, GetPhrase(-1, 21, $sFilename, $!), '', 0);
		}
	#
	# The file input may be getting confused on Win32 for binary files
	# so the file mode set to binary within certain conditions
	#
	if (defined $bBinmode &&
		 $bBinmode == $::TRUE)
		{
   	binmode TFFILE;
   	}
	my ($sOutput);
	{
	local $/;
	$sOutput = <TFFILE>;								# read the entire file
	}
	close (TFFILE);

	return (TemplateString($sOutput, $pVariableTable));
	}

#######################################################
#
# TemplateString - replace the vars in the template
#	string with their values
#
# Params:	0 - template string
#				1 - a reference to the variable table
#
# Returns:  0 - $::SUCCESS or $::FAILURE on error
#				1 - error message
#				2 - modified HTML
#				3 - 0
#
#######################################################

sub TemplateString
	{
#? ACTINIC::ASSERT($#_ == 1, "Invalid argument count in TemplateString ($#_)", __LINE__, __FILE__);

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	my ($sString, $pVariableTable);
	($sString, $pVariableTable) = @_;

	my ($key, $value);
	my @aSortedKeys = sort {length $b <=> length $a} keys %$pVariableTable;	# sort the variable names in descending 'length of name' order
	foreach $key (@aSortedKeys) 						# for every key in the table
		{
		$value = $pVariableTable->{$key};			# determine the value to be substituted
		if ($key ne '')									# at least the key shouldn't be empty
			{
			$sString =~ s/$key/$value/isg;			# replace the variable with its value
			}
		}

	return ($::SUCCESS, '', $sString, 0);
	}

#######################################################
#
# ReturnToLastPage - bounce the browser to the previous
#	page
#
# Params:	0 - bounce delay (if less than 0, don't
#					automatically bounce)
#				1 - string to add to display
#				2 - optional page title.  If the page
#						title exists (ne ''), the page is formatted
#						using the bounce template
#				3 - the refering site URL
#				4 - content site URL
#				5 - pointer to the setup blob
#				6+ - InputHash table
#
# Returns:	0 - status
#				1 - error message
#				2 - HTML for the bounce page
#
#######################################################

sub ReturnToLastPage
	{
#? ACTINIC::ASSERT($#_ > 6, "Invalid argument count in ReturnToLastPage ($#_)", __LINE__, __FILE__);

	if ($_[1] ne '')										# if the page title is defined, format the page prettily
		{
		return (ReturnToLastPageEnhanced(@_));
		}
	else														# otherwise, use a plain page
		{
		return (ReturnToLastPagePlain(@_));
		}
	}

#######################################################
#
# GroomError - make the error look nice for the HTML
#
# Params:	0 - Error string
#
# Returns:	0 - pretty string
#
#######################################################

sub GroomError
	{
	if ($#_ != 0)
		{
		return (GroomError(ACTINIC::GetPhrase(-1, 12, 'GroomError')));
		}
	my ($sError) = @_;
	my $sMessage;
	if ($sError eq "")
		{
		return ($sError);
		}

	$sMessage = ACTINIC::GetPhrase(-1,1971, $::g_sErrorColor) . $sError . ACTINIC::GetPhrase(-1,1970);
	$sError = ACTINIC::GetPhrase(-1,2178, $$::g_pSetupBlob{FORM_BACKGROUND_COLOR}, $sMessage);	# construct the HTML error message header
	$sError .= ACTINIC::GetPhrase(-1,2180);

	return ($sError);
	}

#######################################################
#
# GroomHTML - Display HTML in catalog style
#	NOTE: this is a wrapper for the ACTINIC
#	package version.  It prevents a bunch of duplicate
#	work
#
# Params:	[0] - string to add to display
#				[1] - optional page title.  If the page
#						title exists, the page is formatted
#						using the bounce template
#				2 - the refering site URL
#				3 - content site URL
#				4 - pointer to the setup blob
#				5 - InputHash table
#
# Expects:	%::g_InputHash should be defined
#
# Returns:	($ReturnCode, $Error, $sHTML, 0)
#				if $ReturnCode = $::FAILURE, the operation failed
#					for the reason specified in $Error
#				Otherwise everything is OK
#				$sHTML - the HTML of the page
#
#######################################################

sub GroomHTML
	{
#? ACTINIC::ASSERT($#_ > 4, "Invalid argument count in GroomHTMLEnhanced ($#_)", __LINE__, __FILE__);
	my ($sHTML, $sMessage, $sScriptName);
	my ($pInputHash, $temp, $sTitle, $pSetupBlob, $sWebSiteUrl, $sContentUrl);
	($sMessage, $sTitle, $sWebSiteUrl, $sContentUrl, $pSetupBlob, $pInputHash) = @_;

	my ($sPath, @Response, $Status, $Message);
	$sPath = GetPath();									# get the path to the web site dir

	my (%VariableTable);
	$VariableTable{$::VARPREFIX."BOUNCETITLE"} = $sTitle; # add the title to the var list
	$VariableTable{$::VARPREFIX."BOUNCEMESSAGE"} = $sMessage; # add the message to the var list

	@Response = TemplateFile($sPath."bounce.html", \%VariableTable); # make the substitutions
	($Status, $Message, $sHTML) = @Response;
	if ($Status != $::SUCCESS)
		{
		return (@Response);
		}

	#######
	# make the file references point to the correct directory
	#######
	if( !$ACTINIC::B2B->Get('UserDigest') )
		{
		@Response = ACTINIC::MakeLinksAbsolute($sHTML, $::g_sWebSiteUrl, $::g_sContentUrl);
		}
	else
		{
		my $sBaseFile = $ACTINIC::B2B->Get('BaseFile');
		my $smPath = ($sBaseFile) ? $sBaseFile : $::g_sContentUrl;
		my $sCgiUrl = $::g_sAccountScript;
		$sCgiUrl   .= ($::g_InputHash{SHOP} ? '?SHOP=' . ACTINIC::EncodeText2($::g_InputHash{SHOP}, $::FALSE) . '&': '?');
		$sCgiUrl   .= 'PRODUCTPAGE=';
		@Response = ACTINIC::MakeLinksAbsolute($sHTML, $sCgiUrl, $smPath);
		}

	($Status, $Message, $sHTML) = @Response;
	if ($Status != $::SUCCESS)
		{
		return (@Response);
		}

	return ($::SUCCESS, '', $sHTML, 0);
	}

#######################################################
#
# ReturnToLastPagePlain - bounce the browser to the
#	previous page using a plain white page
#
# Params:	0 - bounce delay (if less than 0, don't
#					automatically bounce)
#				1 - string to add to display
#				2 - optional page title.  If the page
#						title exists (ne ''), the page is formatted
#						using the bounce template
#				3 - the refering site URL
#				4 - content site URL
#				5 - pointer to the setup blob
#				6+ - InputHash table
#
# Returns:	0 - status
#				1 - error message
#				2 - HTML for the bounce page
#
#######################################################

sub ReturnToLastPagePlain
	{
#? ACTINIC::ASSERT($#_ > 6, "Invalid argument count in ReturnToLastPagePlain ($#_)", __LINE__, __FILE__);
	my ($sHTML, $nDelay, $sMessage, $sRefPage, $sScriptName, %InputHash, $temp, $sWebSiteUrl, $sContentUrl, $pSetupBlob);
	($nDelay, $sMessage, $temp, $sWebSiteUrl, $sContentUrl, $pSetupBlob, %InputHash) = @_;

		#
	# note this is only a wrapper function due to so many references
	# PageList was eliminated
		#
	$sRefPage = $::Session->GetLastShopPage();


	return (BounceToPagePlain($nDelay, $sMessage, $temp,
		$sWebSiteUrl, $sContentUrl, $pSetupBlob, $sRefPage, \%InputHash));
	}

#######################################################
#
# BounceToPagePlain - bounce the browser to the
#	specified page using a simple page
#
# Params:	0 - bounce delay (if less than 0, don't
#					automatically bounce)
#				1 - string to add to display
#				2 - optional page title.  If the page
#						title exists (ne ''), the page is formatted
#						using the bounce template
#				3 - the refering site URL
#				4 - content site URL
#				5 - pointer to the setup blob
#				6 - URL to go to
#				7 - InputHash table
#				8 - clear frames flag - if $::TRUE,
#				   clear any existing
#					frames when bouncing.   Default: $::FALSE
#
# Returns:	0 - status
#				1 - error message
#				2 - HTML for the bounce page
#
#######################################################

sub BounceToPagePlain
	{
#? ACTINIC::ASSERT($#_ > 6, "Wrong number of arguments in BounceToPagePlain ($#_)", __LINE__, __FILE__);

	my ($sHTML, $nDelay, $sMessage, $sRefPage, $sScriptName, $pInputHash);
	my ($temp, $sWebSiteUrl, $sContentUrl, $pSetupBlob, $bClearFrames);
	my $sReferrer;
	($nDelay, $sMessage, $temp, $sWebSiteUrl, $sContentUrl, $pSetupBlob, $sRefPage, $pInputHash, $bClearFrames) = @_;

	my ($sDigest,$sBaseFile) = ACTINIC::CaccGetCookies();
	if( !$sDigest )
		{
		$sWebSiteUrl = $sContentUrl;
		}
	else
		{
		$sWebSiteUrl = $sBaseFile;
		$sWebSiteUrl =~ s#/[^/]*$#/#;
		}
	#
	# Check website url when separate SSL server is used
	#
	if ($$::g_pSetupBlob{'SSL_USEAGE'} == "1" &&	# if SSL is only used for some pages
		 defined $ENV{HTTPS} &&
		 $ENV{HTTPS} =~ /on/i)
		{
		$sWebSiteUrl = $$::g_pSetupBlob{'SSL_CATALOG_URL'};
		}
	if ($sRefPage eq '')									# if no referring page, ask the user to manually return
		{
		$sHTML = "<HTML>\n";								# open page
		$sHTML .= "<BODY";								# body definition

		my ($bBgIsImage, $sBgImageFileName, $sBgColor) = GetPageBackgroundInfo();
		if ($bBgIsImage &&
         length $sBgImageFileName > 0)
			{
			$sHTML .= " BACKGROUND=\"" . $sWebSiteUrl . $sBgImageFileName . "\"";
			}
		elsif (length $sBgColor > 0)
			{
			$sHTML .= " BGCOLOR=\"" . $sBgColor . "\"";
			}
		if (length $$pSetupBlob{'FOREGROUND_COLOR'} > 0)
			{
			$sHTML .= " TEXT=\"" . $$pSetupBlob{'FOREGROUND_COLOR'} . "\""
			}
		if (length $$pSetupBlob{'LINK_COLOR'} > 0)
			{
			$sHTML .= " LINK=\"" . $$pSetupBlob{'LINK_COLOR'} . "\""
			}
		if (length $$pSetupBlob{'ALINK_COLOR'} > 0)
			{
			$sHTML .= " ALINK=\"" . $$pSetupBlob{'ALINK_COLOR'} . "\""
			}
		if (length $$pSetupBlob{'VLINK_COLOR'} > 0)
			{
			$sHTML .= " VLINK=\"" . $$pSetupBlob{'VLINK_COLOR'} . "\""
			}
		$sHTML .= "><BLOCKQUOTE>\n";
		$sHTML .= $sMessage."<P>\n";					# add the call specific message (if any)
		$sHTML .= GetPhrase(-1, 22) . "<BR></BLOCKQUOTE>\n";
		}
	else														# bounce to the referring page
		{
		$sHTML = "<HTML><HEAD>\n";								# open page
		if( $sRefPage =~ /\?/ )
			{
			my $sBefore = "$`\?";
			my $sAfter = "\&$'";
			if (($nDelay >= 0) &&						# if auto bounce
				 (!IsStaticPage($sAfter)) &&			# and not static page
				 ($sAfter !~ /ACTINIC_REFERRER/))	# and referrer not already present
				{
				$sReferrer = "&ACTINIC_REFERRER=" . ACTINIC::EncodeText2(GetReferrer(),$::FALSE);
				}
			if( ACTINIC::IsCatalogFramed() &&
				$sBefore =~ /$::g_sAccountScriptName/) # Catalog is framed and the business script is called, so we have to care about the framenavbar
				{
				my ($sProductPage, $sAnchor);
			################################################################################################
			# we have to detect, wchich URL is the appropriate here
			# if the previous URL was somthing like this:
			# 		http://server/cgi-bin/bb000002.pl?MAINFRAMEURL=Stationery.html&PRODUCTPAGE=Frameset.html
			# in this case the name of product page is in the MAINFRAMEURL variable
			# if the previous URL was somthing like this:
			#		http://server/cgi-bin/bb000002.pl?PRODUCTPAGE=Stationery.html
			# then the name of the product page is in the PRODUCTPAGE variable
			# if the previous URL was somthing like this:
			#		http://server/cgi-bin/bb000002.pl?REFPAGE=Stationery.html
			# then the name of the product page is in the REFPAGE variable
			# Note: The product page may be encoded and may include the anchor twice if comming from search
			################################################################################################
			if ($sAfter =~ /(\?|\&)REFPAGE=\"?(.*?)(\#[a-zA-Z0-9\-_]+)?(\"|&|$)/)
					{
					$sAnchor = $3;
					$sProductPage = $2;
					$sAfter =~ s/(\?|\&)REFPAGE=\"?$sProductPage$sAnchor\"?//;
					}
				if ($sAfter =~ /(\?|\&)PRODUCTPAGE=\"?(.*?)(\#[a-zA-Z0-9\-_]+)?(\"|&|$)/)
					{
					$sAnchor = $3;
					$sProductPage = $2;
					$sAfter =~ s/(\?|\&)PRODUCTPAGE=\"?$sProductPage$sAnchor\"?//;
					}
				if ($sAfter =~ /(\?|\&)MAINFRAMEURL=\"?(.*?)(\#[a-zA-Z0-9\-_]+)?(\"|&|$)/)
					{
					$sAnchor = $3;
					$sProductPage = $2;
					$sAfter =~ s/(\?|\&)MAINFRAMEURL=\"?$sProductPage$sAnchor\"?//;
					}
				$sAfter =~ s/^\?/&/;						# in case first parameter then change ? to &
				my $sOtherParams = $sAfter . $sReferrer . $sAnchor;	# but in this case we need the other parameters from the query
				if (!$$pSetupBlob{'UNFRAMED_CHECKOUT'} == 1)	# Checkout is framed, so we don't want double framenavbar
																			# if we done a 'MAINFRAMURL' URL, then the framenavbar would be doubled
					{
					$sRefPage = $sBefore . 'PRODUCTPAGE=' . $sProductPage . $sOtherParams;
					}
				else													# the checkout is unframed, so we have to recreate the framenavbar
					{
					$sRefPage = $sBefore . 'MAINFRAMEURL=' . $sProductPage . "&PRODUCTPAGE=" . $$::g_pSetupBlob{'FRAMESET_PAGE'} . $sOtherParams;
					}
				}
			if( ACTINIC::IsCatalogFramed() &&
				$$::g_pSetupBlob{UNFRAMED_CHECKOUT} &&
				$sBefore !~ /$::g_sAccountScriptName/)				# if the site is framed but the checkout is not, then add the websiteurl to clear frame
				{
				$bClearFrames = 1;
				}
			if( $$pInputHash{MAINFRAMEURL} )	# For parsed frameset we may change main frame URL
				{
				$sRefPage = $sBefore . 'MAINFRAMEURL=' . $$pInputHash{MAINFRAMEURL} . $sAfter . $sReferrer;
				}
			elsif( $$pInputHash{BASE}  )			# Someone is passing catalog directory, pass it on
				{
				$sRefPage = $sBefore . 'BASE=' . $$pInputHash{BASE} . $sAfter . $sReferrer;
				}
			}
		if ($nDelay >= 0)									# only try to auto bounce if the delay is a positive number
			{
			my $sMetaTag;
			my $sReferrer = ACTINIC::GetReferrer();
			if (!IsStaticPage($sRefPage) &&
					$sRefPage !~ /ACTINIC_REFERRER/)	# we don't want to add one more referrer if one already exists
				{
				$sRefPage .= "&ACTINIC_REFERRER=" . ACTINIC::EncodeText2($sReferrer,$::FALSE);
				}
			if ($bClearFrames)							# use JavaScript to clear frames on the auto-bounce
				{
				my $sTarget = $$::g_pSetupBlob{CLEAR_ALL_FRAMES} ? "top" : "parent";
				$sMetaTag =
					"<SCRIPT LANGUAGE=\"JAVASCRIPT\">\n" .
					"<!-- hide from older browsers\n" .
					"setTimeout(\"ForwardPage()\", " . 1000 * $nDelay . ");\n" .
					"function ForwardPage()\n" .
					"	{\n" .
					"	var sURL = '$sRefPage';\n" .
					"	$sTarget.location.replace(sURL);\n" .
					"	}\n" .
					"// -->\n" .
					"</SCRIPT>\n";
				}
			else												# no need for the JavaScript, so use the more commonly supported Meta tag
				{
				$sMetaTag = "<META HTTP-EQUIV=\"refresh\" "; # refresh message
				$sMetaTag .= "CONTENT=\"$nDelay; URL=".$sRefPage."\">\n";
				$sMetaTag .=
					"<SCRIPT LANGUAGE=\"JAVASCRIPT\">\n" .
					"<!-- hide from older browsers\n" .
					"setTimeout(\"ForwardPage()\", " . 1000 * ($nDelay+1) . ");\n" .
					"function ForwardPage()\n" .
					"	{\n" .
					"	var sURL = '$sRefPage';\n" .
					"	location.replace(sURL);\n" .
					"	}\n" .
					"// -->\n" .
					"</SCRIPT>\n";
				}
			$sHTML .= $sMetaTag;
			}

		$sHTML .= "</HEAD><BODY";								# body definition

		my ($bBgIsImage, $sBgImageFileName, $sBgColor) = GetPageBackgroundInfo();
		if ($bBgIsImage &&
          length $sBgImageFileName > 0)
			{
			$sHTML .= " BACKGROUND=\"" . $sWebSiteUrl . $sBgImageFileName . "\"";
			}
		elsif (length $sBgColor > 0)
			{
			$sHTML .= " BGCOLOR=\"" . $sBgColor . "\"";
			}
		if (length $$pSetupBlob{'FOREGROUND_COLOR'} > 0)
			{
			$sHTML .= " TEXT=\"" . $$pSetupBlob{'FOREGROUND_COLOR'} . "\""
			}
		if (length $$pSetupBlob{'LINK_COLOR'} > 0)
			{
			$sHTML .= " LINK=\"" . $$pSetupBlob{'LINK_COLOR'} . "\""
			}
		if (length $$pSetupBlob{'ALINK_COLOR'} > 0)
			{
			$sHTML .= " ALINK=\"" . $$pSetupBlob{'ALINK_COLOR'} . "\""
			}
		if (length $$pSetupBlob{'VLINK_COLOR'} > 0)
			{
			$sHTML .= " VLINK=\"" . $$pSetupBlob{'VLINK_COLOR'} . "\""
			}
		$sHTML .= "><BLOCKQUOTE>\n";
		$sHTML .= $sMessage."<P>\n";					# add the call specific message (if any)
		my $sBounceSentence;
		if ($nDelay >= 0)									# if the delay is a positive number
			{
			$sBounceSentence = GetPhrase(-1, 23, $sRefPage) . "\n"; # try to automatically bounce or here
			}
		else													# negative delay means no auto bounce
			{
			$sBounceSentence = GetPhrase(-1, 161, $sRefPage) . "\n"; # click here to continue
			}
		#
		# if we are to clear the frames in the jump, add the target to this URL
		#
		if ($bClearFrames)
			{
			$sBounceSentence =~ s/(HREF=)/TARGET="_parent" $1/i;
			}
		#
		# add the message to the page
		#
		$sHTML .= "<NOSCRIPT>" . $sBounceSentence . "</NOSCRIPT><BLOCKQUOTE>";
		}
	$sHTML .= "</BODY>\n</HTML>\n";

	return ($::SUCCESS, '', $sHTML, 0);
	}

#######################################################
#
# GetPageBackgroundInfo - 	determines if we use background image or background color for HTML pages, 
#									and also returns the appropriate image file name or color
#
# Returns:	0 - $::TRUE if we use background image, $::FALSE otherwise
#				1 - background image file name 
#				2 - background color code in the format #ffff
#
#######################################################

sub GetPageBackgroundInfo
	{
#? ACTINIC::ASSERT($#_ == -1, "Invalid argument count in GetPageBackgroundInfo ($#_)", __LINE__, __FILE__);
	#
	# Page background info is inserted into the setup BLOB by Catalog as custom info
	#
   my ($bIsBgColorFlagDefined, $bIsBgColorUsed) = ACTINIC::IsCustomVarDefined( 'IsBackgroundColor' );
   my ($bIsBgImageDefined, $sBgImageFileName) = ACTINIC::IsCustomVarDefined( 'BackgroundImageFileName' );
	#
	# Determine if we use image or color
	#
   my $bBgIsImage = (($bIsBgImageDefined && (length $sBgImageFileName > 0)) &&
						   ($bIsBgColorFlagDefined && !$bIsBgColorUsed));

	return ($bBgIsImage, $sBgImageFileName, $$::g_pSetupBlob{'BACKGROUND_COLOR'});
	}

#######################################################
#
# ReturnToLastPageEnhanced - bounce the browser to the
#	previous page, but format the page contents using
#	the bounce.html template
#
# Params:	0 - bounce delay (if less than 0, don't
#					automatically bounce)
#				1 - string to add to display
#				2 - optional page title.  If the page
#						title exists (ne ''), the page is formatted
#						using the bounce template
#				3 - the refering site URL
#				4 - content site URL
#				5 - pointer to the setup blob
#				6+ - InputHash table
#
# Returns:	0 - status
#				1 - error message
#				2 - HTML for the bounce page
#
#######################################################

sub ReturnToLastPageEnhanced
	{
#? ACTINIC::ASSERT($#_ > 6, "Invalid argument count in ReturnToLastPageEnhanced ($#_)", __LINE__, __FILE__);
	my (%InputHash, $sTitle, $sMessage, $pSetupBlob, $sContentUrl, $sWebSiteUrl, $sRefPage, $nDelay);
	($nDelay, $sMessage, $sTitle, $sWebSiteUrl, $sContentUrl, $pSetupBlob, %InputHash) = @_;
	#
	# note this is only a wrapper function due to so many references
	# PageList was eliminated
	#
	$sRefPage = $::Session->GetLastShopPage();

	return (BounceToPageEnhanced($nDelay, $sMessage, $sTitle,
		$sWebSiteUrl, $sContentUrl, $pSetupBlob, $sRefPage, \%InputHash));
	}

#######################################################
#
# RestoreFrameURL -	adjust the URL to restore frames
#							if required
#
# Params:	0 - target URL
#
# Returns:	0 - modifed target URL
#
#######################################################

sub RestoreFrameURL
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in RestoreFrameURL ($#_)", __LINE__, __FILE__);
	my ($sUrl) = @_;
	if (IsPartOfFrameset())								# the current page is framed
		{
		return ($sUrl);									# no need to restore frames
		}
	#
	# If using custom frames then all we can do is use the Unframed Checkout URL
	#
	if ($$::g_pSetupBlob{CLEAR_ALL_FRAMES} &&		# customer frame is used
		 $$::g_pSetupBlob{UNFRAMED_CHECKOUT_URL})	# and there is a checkout URL
		{
		return ($$::g_pSetupBlob{UNFRAMED_CHECKOUT_URL});
		}
	if (!IsCatalogFramed())								# catalog is not framed
		{
		return ($sUrl);									# no need to restore frames
		}
	#
	# The catalog frameset needs to be restored
	#
	# If target is to a static page which is not the frameset or login page then
	# we need to construct a URL like http://site/frameset.html?localpage&frame
	# otherwise just return the URL
	#
	if (IsStaticPage($sUrl))
		{
		if (($sUrl =~ /\/$$::g_pSetupBlob{'FRAMESET_PAGE'}/) ||
			 ($sUrl =~ /\/$$::g_pSetupBlob{'B2B_LOGONPAGE'}/))
			{
			return ($sUrl);
			}
		else
			{
			$sUrl =~ s/.*\/([^\/\=]+$)/$1/;			# get the filename, may include anchor
			if ($sUrl eq $$::g_pSetupBlob{CATALOG_PAGE})	# target is default page
				{
				$sUrl = $::Session->GetBaseUrl() . $$::g_pSetupBlob{FRAMESET_PAGE};	# so don't need page name
				}
			else												# otherwise add the target page name
				{
				$sUrl = $::Session->GetBaseUrl() . $$::g_pSetupBlob{FRAMESET_PAGE} . "?" . $sUrl . "&CatalogBody";
				}
			return ($sUrl);
			}
		}
	#
	# The target must be to a script
	#
	my ($sBefore, $sAfter) = split(/\?/, $sUrl);	# split into script name and parameters
	if ($sBefore !~ /$::g_sAccountScriptName/)	# Not a call to the Business script
		{
		return ($sUrl);									# so just return the url
		}
	if ($sAfter eq "")									# No parameters supplied to the business script
		{
		my ($sBodyPage, $sProductPage) = ACTINIC::CAccCatalogBody();
		return("MAINFRAMEURL=$sBodyPage" . "&PRODUCTPAGE=$sProductPage");	# so return the catalog page
		}
	#
	# Finally, we have a call to the accounts script with parameters
	#
	$sAfter = "&" . $sAfter;							# prefix with & note that split removed the ?
	# If MAINFRAME is already defined then nothing more to do
	if ($sAfter =~ /&MAINFRAMEURL=/)
		{
		return ($sUrl);									# so just return the url
		}
	#
	# Construct the B2B call to load the frameset
	#
	my ($sProductPage, $sAnchor);
	################################################################################################
	# we have to detect, wchich URL is the appropriate here
	# if the previous URL was somthing like this:
	# 		http://server/cgi-bin/bb000002.pl?MAINFRAMEURL=Stationery.html&PRODUCTPAGE=Frameset.html
	# in this case the name of product page is in the MAINFRAMEURL variable
	# if the previous URL was somthing like this:
	#		http://server/cgi-bin/bb000002.pl?PRODUCTPAGE=Stationery.html
	# then the name of the product page is in the PRODUCTPAGE variable
	# if the previous URL was somthing like this:
	#		http://server/cgi-bin/bb000002.pl?REFPAGE=Stationery.html
	# then the name of the product page is in the REFPAGE variable
	# Note: The product page may be encoded and may include the anchor twice if comming from search
	################################################################################################
	if ($sAfter =~ s/&REFPAGE=\"?(.*?)(\#[a-zA-Z0-9\-_]+)?(\".*|&.*|$)/$3/)
		{
		$sAnchor = $2;
		$sProductPage = $1;
		}
	if ($sAfter =~ s/&PRODUCTPAGE=\"?(.*?)(\#[a-zA-Z0-9\-_]+)?(\".*|&.*|$)/$3/)
		{
		$sAnchor = $2;
		$sProductPage = $1;
		}
	#
	# Add the referrer if not already specified
	#
	if ($sAfter !~ /&ACTINIC_REFERRER=/)
		{
		$sAfter .= "&ACTINIC_REFERRER=" . ACTINIC::EncodeText2(ACTINIC::GetReferrer(),$::FALSE);
		}
	$sUrl = $sBefore . '?MAINFRAMEURL=' . $sProductPage . "&PRODUCTPAGE=" . $$::g_pSetupBlob{'FRAMESET_PAGE'} . $sAfter . $sAnchor;
	return ($sUrl);
	}

#######################################################
#
# BounceToPageEnhanced - bounce the browser to the
#	specified page, but format the page contents using
#	the bounce.html template
#
# Params:	0 - bounce delay (if less than 0, don't
#					automatically bounce)
#				1 - string to add to display
#				2 - optional page title.  If the page
#						title exists (ne ''), the page is formatted
#						using the bounce template
#				4 - the refering site URL
#				5 - content site URL
#				6 - pointer to the setup blob
#				7 - the page to go to
#				8 - pointer to InputHash table
#				9 - clear frames flag - if $::TRUE,
#					clear any existing
#					frames when bouncing.   Default: $::FALSE
#
# Returns:	0 - status
#				1 - error message
#				2 - HTML for the bounce page
#
#######################################################

sub BounceToPageEnhanced
	{
#? ACTINIC::ASSERT($#_ >= 7, "Wrong number of arguments in BounceToPageEnhanced ($#_)", __LINE__, __FILE__);
	my ($sHTML, $nDelay, $sMessage, $sScriptName);
	my ($pInputHash, $temp, $sTitle, $sMetaTag, $pSetupBlob, $sWebSiteUrl, $sContentUrl, $sRefPage, $bClearFrames);
	($nDelay, $sMessage, $sTitle, $sWebSiteUrl, $sContentUrl, $pSetupBlob, , $sRefPage, $pInputHash, $bClearFrames) = @_;

	if( !IsPartOfFrameset() )
		{
		$bClearFrames = $::FALSE;
		}

	if ($sRefPage eq '')									# if no referring page, ask the user to manually return
		{
		$sMessage .= "<P>\n";							# add the bouncy message
		$sMessage .= GetPhrase(-1, 22) . "<BR>\n";
		$sMetaTag = '';									# no bounce command
		}
	else														# bounce to the referring page
		{
		if( $sRefPage =~ /\?/ )
			{
			my $sBefore = "$`\?";
			my $sAfter = "\&$'";
			if( ACTINIC::IsCatalogFramed() and 					# Catalog framed
				 !$$::g_pSetupBlob{UNFRAMED_CHECKOUT} ) 		# framed checkout
				{
				$sRefPage =~ s/(PRODUCTPAGE\=\"?)$$::g_pSetupBlob{FRAMESET_PAGE}(\"?)/$1$$::g_pSetupBlob{'CATALOG_PAGE'}$2/;
				}
			$sBefore = "$`\?";
			$sAfter = "\&$'";
			if( $$pInputHash{MAINFRAMEURL} )	# For parsed frameset we may change main frame URL
				{
				$sRefPage = $sBefore . 'MAINFRAMEURL=' . $$pInputHash{MAINFRAMEURL} . $sAfter;
				}
			elsif( $$pInputHash{BASE}  )			# Someone is passing catalog directory, pass it on
				{
				$sRefPage = $sBefore . 'BASE=' . $$pInputHash{BASE} . $sAfter;
				}
			}
		if ($nDelay >= 0)									# only try to auto bounce if the delay is a positive number
			{
			if ($bClearFrames)							# use JavaScript to clear frames on the auto-bounce
				{
				my $sTarget = $$::g_pSetupBlob{CLEAR_ALL_FRAMES} ? "top" : "parent";
				$sMetaTag =
					"<SCRIPT LANGUAGE=\"JAVASCRIPT\">\n" .
					"<!-- hide from older browsers\n" .
					"setTimeout(\"ForwardPage()\", " . 1000 * $nDelay . ");\n" .
					"function ForwardPage()\n" .
					"	{\n" .
					"	$sTarget.location.replace('$sRefPage');\n" .
					"	}\n" .
					"// -->\n" .
					"</SCRIPT>\n";
				}
			else												# no need for the JavaScript, so use the more commonly supported Meta tag
				{
				$sMetaTag = "<META HTTP-EQUIV=\"refresh\" "; # refresh message
				$sMetaTag .= "CONTENT=\"$nDelay; URL=".$sRefPage."\">\n";
				}
			}

		$sMessage .= "<P>\n";							# add the bouncy message
		my $sBounceSentence;
		if ($nDelay >= 0)									# if the delay is a positive number
			{
			$sBounceSentence = GetPhrase(-1, 23, $sRefPage) . "\n"; # try to automatically bounce or here
			}
		else													# negative delay means no auto bounce
			{
			$sBounceSentence = GetPhrase(-1, 161, $sRefPage) . "\n"; # click here to continue
			}
		#
		# if we are to clear the frames in the jump, add the target to this URL
		#
		if ($bClearFrames)
			{
			my $sTarget = $$::g_pSetupBlob{CLEAR_ALL_FRAMES} ? "_top" : "_parent";
			$sBounceSentence =~ s/(HREF=)/TARGET="$sTarget" $1/i;
			}

		$sMessage .= $sBounceSentence;				# add the bounce line to the text
		}

	my ($sPath, @Response, $Status, $Message);
	$sPath = GetPath();									# get the path to the web site dir

	my (%VariableTable);
	$VariableTable{$::VARPREFIX."BOUNCETITLE"} = $sTitle; # add the title to the var list
	$VariableTable{$::VARPREFIX."BOUNCEMESSAGE"} = $sMessage; # add the message to the var list

	@Response = TemplateFile($sPath."bounce.html", \%VariableTable); # make the substitutions
	($Status, $Message, $sHTML) = @Response;
	if ($Status != $::SUCCESS)
		{
		return (@Response);
		}

	#######
	# make the file references point to the correct directory
	#######
	my $smPath = $sContentUrl;
	my $sCgiUrl = $sWebSiteUrl;
	my ($sDigest,$sBaseFile) = ACTINIC::CaccGetCookies();
	if( $sDigest )
		{
		$smPath = ($sBaseFile) ? $sBaseFile : $sContentUrl;
		$sCgiUrl = $::g_sAccountScript;
		$sCgiUrl   .= $::g_InputHash{SHOP} ? '?SHOP=' . ACTINIC::EncodeText2($::g_InputHash{SHOP}, $::FALSE) . '&' : '?';
		$sCgiUrl   .= 'PRODUCTPAGE=';
		}
	@Response = MakeLinksAbsolute($sHTML, $sCgiUrl, $smPath);
	($Status, $Message, $sHTML) = @Response;
	if ($Status != $::SUCCESS)
		{
		return (@Response);
		}

	my ($sSearchTag, $sReplaceTag);
	$sSearchTag = '</TITLE>';							# the bounce meta tag comes immediately after the title
	$sReplaceTag = $sSearchTag . "\n" . $sMetaTag;

	$sHTML =~ s/$sSearchTag/$sReplaceTag/ig;		# insert the bounce meta tag

	return ($::SUCCESS, '', $sHTML, 0);
	}

#######################################################
#
# UpdateDisplay - Print the HTML to the browser after
#	modifying it to keep the page refs in order
#
# Params:	0 - HTML
#				1 - the original CGI input string
#				2 - Cookie (optional)
#				3 - cache flag (optional - default no-cache)
#				4 - contact details cookie (optional)
#				5 - cart cookie if any (optional)
#
#######################################################

sub UpdateDisplay
	{
#? ACTINIC::ASSERT($#_ >= 1, "Invalid argument count in UpdateDisplay ($#_)", __LINE__, __FILE__);
	my ($sHTML, $OriginalInputData, $sCookie, $bNoCacheFlag, $sContactDetailsCookie, $sCartCookie) = @_;
	if (!defined $sCookie)								# if the optional cookie was not supplied
		{
		$sCookie = '';										# set the cookie to empty
		}
	if (!defined $bNoCacheFlag)						# default the cache flag to no cache
		{
		$bNoCacheFlag = $::TRUE;
		}

	###
	# eliminate PrepareRefPageData
	###
	my ($sSearch, $sReplace, $sPageHistory);
	$sSearch = $::VARPREFIX."REFPAGE";
	$sPageHistory = $::Session->GetLastShopPage() ;
	$sReplace = "<INPUT TYPE=HIDDEN NAME=REFPAGE VALUE=\"$sPageHistory\">\n" ;
	$sHTML =~ s/$sSearch/$sReplace/;					# insert the page list
	#
	# Update the checkout link to pass along the website URL
	#
	# - For flexi navbars
	#
	my ($sTemp, $sEncodedRef) = ACTINIC::EncodeText($sPageHistory, $::FALSE);	# do CGI encoding first
	if (($$::g_pSetupBlob{SSL_USEAGE} == 1) &&	# if SSL used only for checkout pages
		 ($sPageHistory !~ /(\?|&)ACTINIC_REFERRER=/))	# we don't want to add one more referrer if one already exists
		{														# then also add referer because HTTP_REFERRER might be undefined
		$sEncodedRef .= "&ACTINIC_REFERRER=" . EncodeText2(GetReferrer(), $::FALSE);
		}
	$sHTML =~ s/(\?ACTION=[^'"]+)/$1&REFPAGE=$sEncodedRef/gi;	#"'
	#
	# - For quick search
	#
	$sHTML =~ s/(<FORM\sNAME\s*=\s*simplesearch[^>]*>)/$1$sReplace/gi;
	#
	# Check section jump referrers
	#
	my $sURL = ACTINIC::EncodeText2($::Session->GetLastShopPage(), $::FALSE);
	$sHTML =~ s/(['"]\&ACTINIC_REFERRER\=["']\s*\+)\s*escape\(location\.href\)/$1\'$sURL\'/;
	#
	# add a random hidden parameter value to guarantee requeries
	#
	srand();
	my ($Random) = rand();
	$sHTML =~ s/<Actinic:Variable Name="Random"/>/$Random/g;

	SaveSessionAndPrintPage($sHTML, $sCookie, $bNoCacheFlag, $sContactDetailsCookie, $::FALSE, $sCartCookie);
	}

#######################################################
#
# PrintNonParsedHeader - print the non-parsed headers
#  Note that this function is separate from PrintHeader
#  because I didn't want to break access to PrintHeader
#  at such a late date.  This function should be called
#  when dynamic feedback is required.  Note that NT does
#  not respect nonparsed headers for dynamic update (even
#  under Apache).
#
#	Input: 	0 - content type
#
#######################################################

sub PrintNonParsedHeader
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in PrintNonParsedHeader ($#_)", __LINE__, __FILE__);
	#
   # Dump the HTTP headers so we can do proper non parsed header processing (for dynamic feedback)
   #
	$|=1;
	print "Content-type: " . $_[0] . "\n";
	print $::ENV{SERVER_PROTOCOL} . " 200 OK\n";
	print "Server: " . $::ENV{SERVER_SOFTWARE} . "\n";
   #
   # Build a date for the expiry
   #
	my ($day, $month, $now, $later, $expiry, @now, $sNow);
	my (@days) = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
	my (@months) = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');

	$now = time;
	@now = gmtime($now);
	$day = $days[$now[6]];
	$month = $months[$now[4]];
	$sNow = sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", $day, $now[3],
						 $month, $now[5]+1900, $now[2], $now[1], $now[0]);

	print "Date: $sNow\n\n";							# print the date to allow the browser to compensate between server and client differences
	}

#######################################################
#
# PrintHeader - print the HTTP header
#
#	Params: 	0 - content type
#				1 - content length
#				2 - cookie if any (or undef)
#				3 - no-cache flag - if $::TRUE,
#					include no-cache flag.
#				4 - contact details cookie (optional)
#				5 - cart cookie if any (optional)
#
# 3/11/99 - content type, length, date and nocache moved to the top
#		date made unconditional.	R. Zybert
# 23/03/2001 - cart cookie added - Z. Magyar
#
#######################################################

sub PrintHeader
	{
#? ACTINIC::ASSERT($#_ >= 3, "Invalid argument count in PrintHeader ($#_)", __LINE__, __FILE__);
	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#
	my ($sType, $nLength, $sCookie, $bNoCache, $sContactDetailsCookie, $sCartCookie) = @_;
	#
	# Build dates for the expiries
	#
	my $sNow = GenerateCookieDate();					# generate today's formatted date string
	my $sExpiry = GenerateCookieDate(2 * 365 * 24);	# generate formatted date string of two years after	
	my $nCartExpiryOffset = 28;						# the default offset time for cart expiry
	if ($$::g_pSetupBlob{'CART_EXPIRY'})			# modify the default to the one defined in the setup blob if available
		{
		$nCartExpiryOffset = $$::g_pSetupBlob{'CART_EXPIRY'};
		};
	my $sCartExpiry = GenerateCookieDate($nCartExpiryOffset);	# generate default expiry date for cart cookies
	#
	# Determination of the session ID cookie expiry
	#
	my $sSessionIdExpiry = $sCartExpiry;			# default session ID expiry to cart expiry
	#
	# Only override the default expiry of the session cookie if there is
	# a saved cart for this customer and this customer is unregistered
	#
	if (!$ACTINIC::B2B->Get('UserDigest') &&					# unregistered customer
		 ($$::g_pSetupBlob{'UNREG_SHOPPING_LIST'} == 1) &&	# saved carts are enabled for unregistered customers
		  $::Session->{_NEWESTSAVEDCARTTIME})					# we have the date of a saved cart
		{
		#
		# We need to consider the following time line:=
		# ---------F-------N-------------C---S---------
		# F is the time the most recently saved files was created	$::Session->{_NEWESTSAVEDCARTTIME}
		# N is the current time													time
		# C is N + the cart expiry												$sCartExpiry
		# S is F + the saved cart expiry										$$::g_pSetupBlob{'UNREG_SHOPPING_LIST_EXPIRY'}
		# S can be before or after C
		# To calculate the expiry time we need to know the number of hours between N and the later of C and S
		#
		my $nF = $::Session->{_NEWESTSAVEDCARTTIME} / (60 * 60);						# F as hours
		my $nN = time / (60 * 60);																# N as hours
		my $nS = ($nF + ($$::g_pSetupBlob{'UNREG_SHOPPING_LIST_EXPIRY'} * 24));	# S as hours

		if (($nS - $nN) > $sCartExpiry)				# if the offset S - N is greater than C - N
			{
			$sSessionIdExpiry = GenerateCookieDate($nS - $nN);	# generate expiry date for cart cookies
			}
		}
	#
	# set the cookie if it needs to be set
	#
	my $bCookieIsSent = $::FALSE;						# determines whether any cookie is appended to the response
	my ($sCurrentCookie);
	if ((!$ACTINIC::AssertIsActive) &&					# if assert is not active
		(defined $::Session))						# and there is a session object (happens with MergeDiff.pl)
		{
		$sCurrentCookie = $::Session->{_OLDSESSIONID};	# retrieve the old session ID
		}
	my $bCookie = (length $sCookie > 0);			# if a cookie is to be saved
	#
	# now print the header
	#
	if($ENV{'PerlXS'} eq 'PerlIS')					# Windows IIS6 may be using PerIS.dll insteasd of perl.exe
		{
		print "HTTP/1.0 200 OK\n";						# so we must insert the protocol and return status
		}

	print "Content-type: $sType\r\n";
	print "Content-length: $nLength\r\n";
	print "Date: $sNow\r\n";							# print the date to allow the browser to compensate between server and client differences

	if ($bNoCache)
		{
		print "Cache-Control: no-cache\r\n";		# HTTP/1.1
		print "Pragma: no-cache\r\n";					# HTTP/1.0
		}
	#
	# If the COOKIE parameter is defined then we came from the SSL redirect page
	# so we should force the retrieved cookie value to be saved
	#
	if (defined $::g_InputHash{'COOKIE'})
		{
		$bCookie = $::TRUE;
		$sCookie = $sCurrentCookie;
		}
	if ($bCookie)											# if we are to save the cookie
		{
		print "Set-Cookie: ACTINIC_CART=" .			# set the cookie
		   $sCookie . "; EXPIRES=" .
			$sSessionIdExpiry . "; PATH=/;\r\n";
		$bCookieIsSent = $::TRUE;						# a cookie is appended to the response
		}

	if (!$ACTINIC::AssertIsActive)
		{
		my $sBusinessCookie = ACTINIC::CAccBusinessCookie();			# If B2B user logged in - save the digest
		if ($sBusinessCookie eq "-" and $sContactDetailsCookie)		# if we are to save the contact details cookie
			{
			print "Set-Cookie: " . $sContactDetailsCookie . # set the cookie
				"; EXPIRES=" . $sExpiry . "; PATH=/;\r\n";
			$bCookieIsSent = $::TRUE;					# a cookie is appended to the response
			}
		else
			{
			print "Set-Cookie: ACTINIC_BUSINESS=" . $sBusinessCookie . 		# set the cookie - this session only
				"; PATH=/;\r\n";
			$bCookieIsSent = $::TRUE;					# a cookie is appended to the response
			}
		if ($::ACT_ADB)									# If there is an address book
			{
			print $::ACT_ADB->Header();				# Ouput address book cookies
			$bCookieIsSent = $::TRUE;					# a cookie is appended to the response
			}
		}
	#
	# Print cart cookies
	#
	if ($sCartCookie ne '')
		{
		print "Set-Cookie: " . $sCartCookie . 		# set the cookie
				"; EXPIRES=" . $sCartExpiry .
				"; PATH=/;\r\n";
		$bCookieIsSent = $::TRUE;						# a cookie is appended to the response
		}

	#
	# Print compact P3P policy
	#
	if ($bCookieIsSent &&								# if any cookie is sent and
		$$::g_pSetupBlob{P3P_COMPACT_POLICY})		# the policy is defined
		{
		print "P3P: CP=\"" . $$::g_pSetupBlob{P3P_COMPACT_POLICY} . "\"\r\n"; # print the policy
		}

	print "\r\n";
	}

#######################################################
#
# GenerateCookieDate
#
#	Generates a formatted date string for cookie definition
#	(for expiry and date tags)
#
#	Input: 	0 - offset: generated date deflection from NOW - hours
#					(optional. Default: 0)
#
#	Output:	0 - formatted cookie date
#
#######################################################

sub GenerateCookieDate
	{
	my $offset = shift;									# generated date deflection from NOW - optional
	#
	# Optional offset adjusted to 0 if not defined
	#
	if (!$offset)
		{
		$offset = 0;
		}
	#
	# Initialization
	#
	my (@date, $day, $month, $now, $later, $sDate);
	my (@days) = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
	my (@months) = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
	#
	# Compose the sought date
	#
	$now = time;											# today's date value
	$later = $now + $offset *3600;					# deflected time
	@date = gmtime($later);								# grab time components
	$day = $days[$date[6]];								# day's abreviated name
	$month = $months[$date[4]];						# month's abreviated name
	$sDate = sprintf("%s, %02d-%s-%04d %02d:%02d:%02d GMT", $day, $date[3],
							$month, $date[5]+1900, $date[2], $date[1], $date[0]);	# format the generated date
	return $sDate;
	}

#######################################################
#
# SaveSessionAndPrintPage - wrapper for PrintPage which
#		does the session closing
#
#	Params: 	0 - HTML to print
#				1 - cookie if any (or undef)
#				2 - no-cache flag - if $::TRUE,
#					include no-cache flag.
#					Default - $::TRUE
#				3 - contact details cookie (optional)
#           4 - if true, skip XML parsing (default - false)
#				5 - cart cookie if any (optional)
#
#######################################################

sub SaveSessionAndPrintPage
	{
#? ACTINIC::ASSERT($#_ >= 0, "Invalid argument count in PrintPage ($#_)", __LINE__, __FILE__);

	my ($sHTML, $sCookie, $bNoCacheFlag, $sContactDetailsCookie, $bSkipXMLParsing, $sCartCookie) = @_;

	$::Session->SaveSession();

	PrintPage($sHTML, $::Session->GetSessionID(), $bNoCacheFlag, $sContactDetailsCookie, $bSkipXMLParsing, $sCartCookie);
	}

#######################################################
#
# PrintPage - print the HTML page
#
#	Params: 	0 - HTML to print
#				1 - cookie if any (or undef)
#					 this parameter is redundent
#				2 - no-cache flag - if $::TRUE,
#					include no-cache flag.
#					Default - $::TRUE
#				3 - contact details cookie (optional)
#           4 - if true, skip XML parsing (default - false)
#				5 - cart cookie if any (optional)
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# PSP plug ins!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub PrintPage
	{
#? ACTINIC::ASSERT($#_ >= 1, "Invalid argument count in PrintPage ($#_)", __LINE__, __FILE__);
   if ($::s_nErrorRecursionCounter > 10)
		{
		$ACTINIC::AssertIsActive = $::TRUE;
#?      ACTINIC::TRACE('Callstack:\n%s', CallStack());
		}
   $::s_nErrorRecursionCounter++;

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	my $nLength;
	my ($sHTML, $sNotUsed, $bNoCacheFlag, $sContactDetailsCookie, $bSkipXMLParsing, $sCartCookie) = @_;
	my $sCookie = "";
	if (defined $::Session)
		{
		$sCookie = $::Session->GetSessionID();
		}

   if (!$ACTINIC::AssertIsActive &&					# skip the XML parsing if we are reporting an assert as this can cause infinite looping if the problem is in the customer account code
		 !$bSkipXMLParsing)
		{
		$sHTML = ACTINIC::ParseXML($sHTML);			# the body
		}
	$nLength = length $sHTML;

	if (!defined $bNoCacheFlag)						# default the no cache flag to on
		{
		$bNoCacheFlag = $::TRUE;
		}

	binmode STDOUT;										# dump in binary mode since Netscape likes it

	PrintHeader('text/html', $nLength, $sCookie, $bNoCacheFlag, $sContactDetailsCookie, $sCartCookie);

	print $sHTML;							# the body
	}

#######################################################
#
# PrintText - print the text page
#
#	Params: 	0 - text to print
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# PSP plug ins!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub PrintText
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in PrintText ($#_)", __LINE__, __FILE__);

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	my $sText = $_[0];

	my $nLength = length $sText;

	binmode STDOUT;										# dump in binary mode since Netscape likes it

	PrintHeader('text/plain', $nLength, undef, $::FALSE);

	print $sText;											# the body
	}

#######################################################
#
# ReportError - report the specified error to the
#	browser and error file
#
# Params:	0 - error message
#				1 - the file path
#
#######################################################

sub ReportError
	{
#? ACTINIC::ASSERT($#_ == 1, "Invalid argument count in ReportError ($#_)", __LINE__, __FILE__);

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	my ($sMessage, $sPath);
	($sMessage, $sPath) = @_;

	RecordErrors(@_);										# record the error to the error file

	TerminalError($_[0]);								# display the error
	}

#######################################################
#
# RecordErrors - Record the specified error to the
#	error file
#
# Params:	0 - error message
#				1 - file path
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# shipping and PSP plug ins!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub RecordErrors
	{
#? ACTINIC::ASSERT($#_ == 1, "Invalid argument count in RecordErrors ($#_)", __LINE__, __FILE__);

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	my ($sMessage, $sPath);
	($sMessage, $sPath) = @_;

	#########
	# Write the error to the file
	#########
	my ($sPad, $sFile);
	$sPad = " "x100;
	$sFile = $sPath."error.err";

	SecurePath($sFile);									# make sure only valid filename characters exist in $file to prevent hanky panky

	open(NQFILE, ">>".$sFile);							# Open the error file

	print NQFILE ("Program = ");						# Begin to write error file details
	print NQFILE (substr($::prog_name.$sPad,0,8)); # Write error file details

	print NQFILE (", Program version = ");			# Write error file details
	print NQFILE (substr($::prog_ver.$sPad,0,6)); # Write error file details

	print NQFILE (", HTTP Server = ");				# Write error file details
	print NQFILE (substr($::ENV{'SERVER_SOFTWARE'}.$sPad,0,30)); # Write error file details

	print NQFILE (", Return code = ");				# Write error file details
	print NQFILE (substr("999".$sPad,0,20));		# Write error file details

	print NQFILE (", Date and Time = ");			# Write error file details
	print NQFILE ACTINIC::GetActinicDate();		# Write error file details

	print NQFILE (", Internal Errors = ");			# Write error file details
	print NQFILE ($sMessage);							# Write error file details

	print NQFILE "\n";
	close NQFILE;

	ChangeAccess("rw", $sFile);						# make the file accessible
	}

#######################################################
#
# TerminalError - generate the error html
#
#	Params: 	0 - the error
#
#######################################################

sub TerminalError
	{
# No assert here because the assert function calls this function - recursion loop
	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	my ($sError, $sHTML);
	($sError) = @_;										# get the error message

	$sHTML  = "<HTML><TITLE>Actinic</TITLE><BODY>";
	if (defined $::g_pPromptList)
		{
		$sHTML .= "<H1>" . GetPhrase(-1, 24) . "</H1>";
		$sHTML .= "<HR>" . GetPhrase(-1, 25) . ": $sError<HR>";
		$sHTML .= GetPhrase(-1, 26);
		}
	else														# if the localized text file has not been read - assume english
		{
		$sHTML .= "<H1>" . "A General Script Error Occurred" . "</H1>";
		$sHTML .= "<HR>" . "Error" . ": $sError<HR>";
		$sHTML .= "Press the Browser back button and try again or contact the site owner.";
		}
	$sHTML .= "</BODY></HTML>";

	$ACTINIC::AssertIsActive = $::TRUE;
	PrintPage($sHTML, undef, $::TRUE);

	exit;
	}

#######################################################
#
# LogData - (currently) wrapper for ACTINIC::RecordErrors
#           writes if $::DEBUG_CLASS_FILTER 'includes' the specified
#				debug class
#
# Input:		0 - string to write
#
# Author: Bill Birthisel
#
#######################################################

sub LogData
	{
#? ACTINIC::ASSERT($#_ == 1, "Incorrect parameter count LogData", __LINE__, __FILE__);
	my $sLogData = shift;
	my $nDebugClass = shift;
	if ($::DEBUG_CLASS_FILTER &						# determine the filtering by bitwise check
		$nDebugClass)
		{
		ACTINIC::RecordErrors($sLogData, ACTINIC::GetPath());
		}
	}

#######################################################
#
# MakeLinksAbsolute - make all file references
#	absolute (to the web site dir)
#
# Params:	0 - current HTML
#				1 - referring site url
#				2 - content url
#
# Returns:	0 - status
#				1 - error message
#				2 - modified text
#
# 03/11/99 - modified to accept single quotes - R. Zybert
# 20/01/01 - modified to accept ftp: links - Z. Magyar
# 17/05/01 - modified to deal with javascript section links - Z.Magyar
#          - it has been removed because the modified
#				 section link handling - 25/06/01 - zmagyar
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# PSP plug ins!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub MakeLinksAbsolute
	{
#? ACTINIC::ASSERT($#_ == 2, "Invalid argument count in MakeLinksAbsolute ($#_)", __LINE__, __FILE__);

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#
	my ($sHTML, $sWebSiteUrl, $sContentUrl, $Status, $Message, @Response);
	($sHTML, $sWebSiteUrl, $sContentUrl) = @_;

	#######
	# make the file references point to the correct directory
	# Absolute addresses (starting from /) are unchanged (rz)
	#######
  	$sHTML =~ s/<A([^>]*?)HREF=(['"])?(?!http(s?):|mailto:|ftp:|#|\/|javascript:)([^'"\s]+)(['"\s])/<A$1HREF=$2$sWebSiteUrl$3$4$5/gi;	# " <quote helps emacs format> # replace hyperlink references
 	$sHTML =~ s/<FRAME([^>]*?)SRC=(['"])?(?!http(s?):|mailto:|ftp:|#)([^'"\/][^'"\s]+)(["\s])/<FRAME$1SRC=$2$sWebSiteUrl$3$4$5/gi;	# " <quote helps emacs format> # replace hyperlink references
	#
	# Make sure that popup URLs are correct (Extended Product Info and T&C pages)
	#
	$sHTML = MakeExtendedInfoLinksAbsolute($sHTML, $sWebSiteUrl);
	return ($::SUCCESS, '', $sHTML);					# do the replacement
	}

################################################################
#
# MakeExtendedInfoLinksAbsolute - Make sure that Extended Product
# Info pages are correct. We change the relative links given in
# the javascript references to absolute
#
# Params:	0 - current HTML
#				1 - referring site url
#
# Returns:	0 - modified text
#
################################################################

sub MakeExtendedInfoLinksAbsolute
	{
#?	ACTINIC::ASSERT($#_ == 1, "Invalid argument count in MakeExtendedInfoLinksAbsolute ($#_)", __LINE__, __FILE__);
	my ($sSearch, $sHTML, $sWebSiteUrl);
	($sHTML, $sWebSiteUrl) = @_;
	$sSearch = ACTINIC::GetPhrase(-1, 2175);
	$sSearch =~ s/(.*\().*$/$1/;						# strip at (
	$sSearch = quotemeta $sSearch;
	$sHTML =~ s/=(["']$sSearch['"])([^'"\s]+)/=$1$sWebSiteUrl$2$3/gi;		# "
	return ($sHTML);
	}

##################################################################################
#																											#
# HTML manipulation functions - end																#
#																											#
##################################################################################

##################################################################################
#																											#
# Generic Utilities - begin        																#
#																											#
##################################################################################

#######################################################
#
# GetScriptNameRegexp
#
# Returns: 	0 - a regexp that will match any of the
#					standard Catalog scriptnames
#
#######################################################

sub GetScriptNameRegexp
	{
	my (@ScriptPathParts) = split /(\\|\/)/, $::ENV{"SCRIPT_NAME"};
	my ($sScriptBase);
	$sScriptBase = substr($ScriptPathParts[$#ScriptPathParts], 2);
	return ("(ca|os|nq|ts|cp|ss|sh|bb|md|cm|ms|se|rs)$sScriptBase");
	}

################################################################
#
# GetStaticPageRegexp
#
# Returns: 	0 - a regexp that will match any of the
#					accepted static page file types
#
#	Matches:-	.html	.htm	.shtml
#					.js
#					.php	.php3
#					.css
#					.vrml
#					.asp
#					.cfm
#					the above can only be followed by # or ?
#					if the expression being tested ends in / then we
#					assume it refers to the default static page
################################################################

sub GetStaticPageRegexp
	{
	return ("(\.((s?)html|htm|js|php(3?)|css|vrml|asp|cfm))\$|(\/\$)");
	}

############################################################
#
#  IsStaticPage
#  Test URL to guess if it represents a static page
#
#   Params	0	: URL
#   Result  1	: $::TRUE for static page
#  			   $::FALSE if not (or don't know)
#
#  Ryszard Zybert  Jul 24 20:32:07 BST 2000
#
#  Copyright (c) Actinic Software Ltd (2000)
#
############################################################

sub IsStaticPage
	{
	my ($sURL) = @_;
	if ($sURL =~ /(\?|\#)/)
		{
		$sURL = $`;
		}
	if ($sURL =~ /\%[0-9A-Fa-f]{2}/)					# Looks like it is encoded
		{
		$sURL = DecodeText($sURL, $ACTINIC::FORM_URL_ENCODED);	# decode the URL
		}
	my $sRegExp = GetScriptNameRegexp();			# Get the script regular expression
	my $sPageRegExp = GetStaticPageRegexp();		# Get the static page regular expression
	if( $sURL =~ /$sPageRegExp/i and $sURL !~ /$sRegExp/ )
		{
		return ($::TRUE);
		}
	return ($::FALSE);
	}

################################################################
#
#  IsFramePage
#  Test URL to guess if it represents a frame page
#
#   Params	0	: Page name without path
#   Result  1	: $::TRUE for frame page
#  			 	  $::FALSE if not (or don't know)
#
#  Gordon Camley  Oct 18 16:15 GMT 2003
#
#  Copyright (c) Actinic Software Ltd (2003)
#
################################################################

sub IsFramePage
	{
	my ($sPageName) = @_;
	if ($sPageName =~ /\%[0-9A-Fa-f]{2}/)			# Looks like it is encoded
		{
		$sPageName = DecodeText($sPageName, $ACTINIC::FORM_URL_ENCODED);	# decode the page name
		}
	my ($sRegExp);
	#
	# Custom Variable (ACT_CUSTOM_FRAME_PAGES) can be used to identify the customer's own
	# frame pages. Frame names should be filename.extension, may be a comma separated list
	#
 	my ($bCusFrame, $sCusFramePages) = ACTINIC::IsCustomVarDefined('ACT_CUSTOM_FRAME_PAGES');
	#
	# If Catalog is framed, then include the navigation bar and frameset pages
	#
	if (IsCatalogFramed())
		{
	 	$sRegExp = "framenavbar.html|" . $$::g_pSetupBlob{FRAMESET_PAGE};
 		}
	#
	# If customer frame list is defined, then include the customer page list
	#
	if ($bCusFrame)
		{
		$sCusFramePages = join("|", split(",", $sCusFramePages));
		$sRegExp .= "|" . $sCusFramePages;
		}
	if( $sPageName =~ /$sRegExp/i)					# see if page name matches list of frame pages
		{
		return ($::TRUE);									# true if matched
		}
	return ($::FALSE);									# false if not matched
	}

#######################################################
#
# Modulus - use this division function in place of
#	the % operator in cases where performance is not an
#	issue *or* when it is likely that the number is
#	greater than 2^31.  This is required because Perl
#	5.003 on FreeBSD crashes with a floating point exception
#	in those cases.
#
# Params:	0 - a
#				1 - b
#		where c = a % b
#
# Returns: 	0 - c
#
#######################################################

sub Modulus
	{
#? ACTINIC::ASSERT($#_ == 1, "Wrong number of arguments in Modulus ($#_)", __LINE__, __FILE__);
	my ($nA, $nB) = @_;
	#
	# a % b = int(a - b * int(a/b) )
	#
	my $nC = $nA - $nB * int($nA / $nB);
#?	if ($^O ne 'freebsd')
#?		{
#?		my $nD = $nA % $nB;
#? ACTINIC::ASSERT($nD == $nC, "Modulus emulation error $nC != $nD", __LINE__, __FILE__);
#?		}
	return($nC);
	}

###############################################################
#
# JoinHashes - do a boolean join on the two supplied hashes
#   and store the results in a third hash.
#
# Input:	   0 - reference to hash1
#           1 - reference to hash2
#			   2 - join operation
# Output:   3 - reference to output hash
#
###############################################################

sub JoinHashes
	{
#? ACTINIC::ASSERT($#_ == 3, "Incorrect parameter count JoinHashes(" . join(', ', @_) . ").", __LINE__, __FILE__);
	my ($rhash1, $rhash2, $bOperation, $rhashOutput) = @_;

	undef %$rhashOutput;									 # clear the output hash
	#
	# Now do the appropriate join operation on the hashes.  (See Perl Cookbook p 147 (first edition))
	#
	if ($bOperation == $::INTERSECT)					 # AND join (INTERSECTION)
		{
		foreach (keys %$rhash1)							 # check each key in hash1
			{
			$$rhashOutput{$_} = 0 if exists $$rhash2{$_}; # add this key to the output hash if it exists in hash 2
			}
		}
	else														 # OR join (UNION)
		{
		%$rhashOutput = %$rhash1;						 # copy all of the keys from hash1 to output
		foreach (keys %$rhash2)
			{
			$$rhashOutput{$_} = 0;						 # copy the keys from hash2 to output
			}
		}
	}

#######################################################
#
# ReadTheDir
#     Open a directory and read its contents - this
#     is a hack-around for a bug in PerlIS for NT.
#
# Params: 	0 - the directory path to read
#
# Returns: 	0 - status code
#				1 - error message if any
#				2+ - file list (or 0, 0)
#
#######################################################

sub ReadTheDir
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ReadTheDir ($#_)", __LINE__, __FILE__);

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	my ($sPath, @FileList);
	($sPath) = @_;											# get the path

	SecurePath($sPath);									# make sure only valid filename characters exist in $file to prevent hanky panky
	if( opendir (NQDIR, "$sPath") )					# open the directory to get a file listing
		{														# if successful,
		@FileList = readdir (NQDIR);					# read the directory
		closedir (NQDIR);									# close the directory
		return ($::SUCCESS, '', @FileList);			# return the directory contents
		}

	if ($^O ne "MSWin32")
		{
		return($::FAILURE, GetPhrase(-1, 31, $sPath, $!), 0, 0);
		}
	#
	# if we are here, the open failed.  This is probably NT with the PerliS 303 bug
	#	try to read the directory using dos commands
	#
	my ($sDosPath, $sCommand);
	$sDosPath = $sPath;									# get the path of the directory to read
	$sDosPath =~ s/\//\\/g;								# convert the forward slashes to dos backslashes

	$sCommand = "dir /B \"$sDosPath\"";

	unless (open (PIPE, $sCommand . " |"))
		{
		return($::FAILURE, GetPhrase(-1, 32, $sPath, $!), 0, 0);
		}

	@FileList = <PIPE>;									# read the contents of the directory
	chomp @FileList;										# remove the trailing newlines
	close (PIPE);											# close the file

	if ($#FileList == 0 &&								# if the command returned file not found
		 $FileList[0] =~ m/File Not Found/i)
		{
		my ($sMessage);
		$sMessage = $FileList[0];
		return($::FAILURE, GetPhrase(-1, 32, $sPath, $sMessage), 0, 0);
		}

	return ($::SUCCESS, '', @FileList);				# return the directory contents
	}

#######################################################
#
# IsCatalogFramed - Is Catalog running in framed mode
#
# Returns:	($ReturnCode)
#				$::TRUE if running in a Frame
#				$::FALSE if not
#
#######################################################

sub IsCatalogFramed
	{
	#
	# use the existence of navigation page
	#
	return($$::g_pSetupBlob{USE_FRAMES});
	}

#######################################################
#
# IsBrochureFramed - Is Brochure running in framed mode
#
# Returns:	($ReturnCode)
#				$::TRUE if running in a Frame
#				$::FALSE if not
#
#######################################################

sub IsBrochureFramed
	{
	#
	# use the existence of navigation page
	#
	return($$::g_pSetupBlob{BROCHURE_USE_FRAMES});
	}

#######################################################
#
# CheckFileExists - returns whether the given file
#				exists and is readable
#
# Params:	[0] - File name
#				[1] - Path
#
# Returns:	($ReturnCode)
#				$::TRUE if file exists and is readable
#				$::FALSE if not
#
#######################################################

sub CheckFileExists
	{
#? ACTINIC::ASSERT($#_ == 1, "Wrong number of arguments in CheckFileExists", __LINE__, __FILE__);

	my ($sFileName, $sPath);
	($sFileName, $sPath) = @_;
	#
	# build the file name
	#
	my $sFile = $sPath . $sFileName;
	return (-e $sFile && -r $sFile);					# does the file exist and is readable
	}

#######################################################
#
# GetCatalogBasePageName - gets the file name of the
#		enclosing frame
#
# Params:	[0] - Path
#
# Returns:	($ReturnCode, $sError, $sPageName)
#				$::TRUE if file exists and is readable, $::FALSE if not
#				$sError if present or ""
#				$sBasePageName - base page name
#
#######################################################

sub GetCatalogBasePageName
	{
#? ACTINIC::ASSERT($#_ == 0, "Wrong number of arguments in GetCatalogBasePageName", __LINE__, __FILE__);

	my ($sPath, $sBasePageName);
	($sPath) = @_;
	$sBasePageName = $$::g_pSetupBlob{CATALOG_PAGE};
#? ACTINIC::ASSERT((length $sBasePageName) > 0, "Base page name not found", __LINE__, __FILE__);
	return ($::SUCCESS, "", $sBasePageName);		# return our base page name
	}

##################################################################################
#																											#
# Generic Utilities - end        																#
#																											#
##################################################################################

##############################################################################################################
#
# CGI Input Processing (should use CGI.pm but forbidden)- Begin
#
##############################################################################################################

#######################################################
#
# ReadAndParseInput - read the input and parse it
#
# Expects:	$::ENV to be defined
#
# Returns:	0 - status
#				1 - error message
#				2 - the input string
#				3 - spacer to keep output even
#				4+ - input hash table
#
#######################################################

sub ReadAndParseInput
	{
	my ($InputData, $nInputLength);

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	if ( (length $::ENV{'QUERY_STRING'}) > 0)		# if there is query string data (GET)
		{
		$InputData = $::ENV{'QUERY_STRING'};		# read it
		$nInputLength = length $InputData;
		}
	else														# otherwise, there must be a POST
		{
		my ($nStep, $InputBuffer);
		$nInputLength = 0;
		$nStep = 0;
		while ($nInputLength != $ENV{'CONTENT_LENGTH'})	# read until you have the entire chunk of data
			{
			#
			# read the input
			#
			binmode STDIN;
			$nStep = read(STDIN, $InputBuffer, $ENV{'CONTENT_LENGTH'});  # Set $::g_InputData equal to user input
			$nInputLength += $nStep;					# keep track of the total data length
			$InputData .= $InputBuffer;				# append the latest chunk to the total data buffer
			if (0 == $nStep)								# EOF
				{
				last;											# stop read
				}
			}

		if ($nInputLength != $ENV{'CONTENT_LENGTH'})
			{
			return ($::FAILURE, "Bad input.  The data length actually read ($nInputLength) does not match the length specified " . $ENV{'CONTENT_LENGTH'} . "\n", '', '', 0, 0);
			}
		}
	$InputData =~ s/&$//;								# loose any bogus trailing &'s
	$InputData =~ s/=$/= /;								# make sure trailing ='s have a value
	my ($OriginalInputData);
	$OriginalInputData = $InputData;					# copy the input string for use later

	if ($nInputLength == 0)								# error if there was no input
		{
		return ($::FAILURE, "The input is NULL", '', '', 0, 0);
		}
	#
	# parse and decode the input
	#
	my (@CheckData, %DecodedInput);
	@CheckData = split (/[&=]/, $InputData);		# check the input line
	if ($#CheckData % 2 != 1)
		{
		return ($::FAILURE, "Bad input string \"" . $InputData . "\".  Argument count " . $#CheckData . ".\n", '', '', 0, 0);
		}
	my %EncodedInput = split(/[&=]/, $InputData);	# parse the input hash
	my ($key, $value);
	while (($key, $value) = each %EncodedInput)
		{
		if ($key !~ /BLOB/i)								# do not censor the order BLOB
			{
			if (($value =~ /[\(\)]/) ||				# reject ( and ) before decoding
			  ($value =~ /[<>]/))						# reject < and > before decoding
				{
				return ($::FAILURE, "Input contains invalid characters.", undef, undef, undef, undef);
				}
			}
		$key = DecodeText($key, $ACTINIC::FORM_URL_ENCODED);	# decode the hash entry
		$value = DecodeText($value, $ACTINIC::FORM_URL_ENCODED);
		if ($key =~ /\0/)									# check for poison NULLs in key
			{
			return ($::FAILURE, "Input contains invalid characters.", undef, undef, undef, undef);
			}
		if ($key !~ /BLOB/i)								# do not censor the order BLOB value
			{
			if ($value =~ /\0/)							# check for poison NULLs in value
				{
				return ($::FAILURE, "Input contains invalid characters.", undef, undef, undef, undef);
				}
			#
			# Restrict the length of data between <> brackets
			#
			if ($key !~ /TEXTDATA/i)
				{
				if (($value =~ /.*?\<(.*)\>/s) &&	# if there is text between the outer bracket pair
					 ($::eABDataLimit < length $1))	# and the length of the text is greater than the allowed length
					{
					while($value =~ s/(\<)(.*?)(\>)/\[$2\]/gs) {}
					}
				}
			}
		$DecodedInput{$key} = $value;
		}
	#
	# Now process the path to the catalog directory.  In stand alone mode, the path is hard coded in the script.
	# In Actinic Host mode, the path is derived from the SHOPID and the shop data file.
	#
	my ($status, $sError) = ProcessPath($DecodedInput{SHOP}, \%DecodedInput);
	if ($status != $::SUCCESS)
		{
		return ($status, $sError);
		}

	return ($::SUCCESS, '', $OriginalInputData, '', %DecodedInput);
	}

#######################################################
#
# ProcessPath - process the input to derive a path
#   to the catalog directory
#
# Params:	0 - shop ID if in Actinic Host Mode
#               or undef if stand alone
#
# Returns:	0 - status
#				1 - error message
#
#######################################################

sub ProcessPath
	{
#? ACTINIC::ASSERT($#_ >= 0, "Invalid argument count in ProcessPath ($#_)", __LINE__, __FILE__);
	my ($sShopID, $rhInput) = @_;
	my ($status, $sError);
	#
	# Now process the path to the catalog directory.  In stand alone mode, the path is hard coded in the script.
	# In Actinic Host mode, the path is derived from the SHOPID and the shop data file.
	#
	my $sInitialPath = '<Actinic:Variable Name="PathFromCGIToWeb"/>';
	if (!<Actinic:Variable Name="ActinicHostMode"/>)				# stand alone mode
		{
		$ACTINIC::s_sPath = $sInitialPath;
		}
	else
		{
		#
		# Check if the shop ID has nothing in it
		#
		if ($sShopID eq '' &&
			($$rhInput{ACTION} =~ /^AUTHORIZE/ || $$rhInput{ACTION} eq 'OCC_VALIDATE'))
			{
			if(defined $$rhInput{PATH} && $$rhInput{PATH} ne '')
				{
				$ACTINIC::s_sPath = $$rhInput{PATH};
				return ($::SUCCESS, undef);
				}
			}
		#
		# Load the module for access to the configuration files
		#
		eval
			{
			require AHDClient;
			};
		if ($@)												# the interface module does not exist
			{
			return ($::FAILURE, 'An error occurred loading the AHDClient module.  ' . $@);
			}
		my ($nStatus, $pClient);
		($nStatus, $sError, $pClient) = new_readonly AHDClient($sInitialPath);
		if ($nStatus!= $::SUCCESS)
			{
			return($nStatus, $sError);
			}
		#
		# Retrieve the appropriate record
		#
		($status, $sError, my $pShop) = $pClient->GetShopDetails($sShopID);
		if ($status != $::SUCCESS)		 				# error during the query
			{
			return ($status, $sError);
			}
		if (!defined($pShop))							# no shop with this ID
			{
			return ($::BADDATA, $sError);
			}
		#
		# Retrieve the specific path
		#
		$ACTINIC::s_sPath = $pShop->{Path};
		}

	return ($::SUCCESS, undef);
	}

#######################################################
#
# CheckSafeFilePath - checks if file path navigates 
#						 outside of current and parent folders
#
# Input:    0 - file path to be checked
#
#######################################################

sub CheckSafeFilePath
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in CheckSafeFilePath ($#_)", __LINE__, __FILE__);
	#
	# Don't let the hackers get any file from the server
	# So check the file name and only allow files from current
	# and parent directories
	#
	my ($sFilePath) = @_;
	if ($sFilePath ne $$::g_pSetupBlob{'HOMEPAGEURL'})
		{
		if (($sFilePath =~ /\//) ||					# if file path contains any '/'
			 ($sFilePath =~ /\\/))						#  or '\' characters
			{
			ReportError(ACTINIC::GetPhrase(-1,2248, $sFilePath), GetPath());
		}
	}
	}

##############################################################################################################
#
# CGI Input Processing (should use CGI.pm but forbidden)- End
#
##############################################################################################################

##############################################################################################################
#
# File Read Calls - Begin
#
##############################################################################################################

#######################################################
#
# GetSectionBlobName - make the blob name from the ID
#
# Input:    0 - section ID
#
# Returns:	0 - return code ($::SUCCESS or $::FAILURE)
#           1 - error message (if any)
#				2 - blob name
#
#######################################################

sub GetSectionBlobName
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in GetSectionBlobName ($#_)", __LINE__, __FILE__);
	#
	# Validate the input ID - make sure it contains only digits
	#
	if ($_[0] !~ /^(\d+)$/)								# if the section ID does not contain only digits
		{
		return ($::FAILURE, GetPhrase(-1, 306));		# bad input
		}
	my $nID = $1;											# retrieve the ID

	return ($::SUCCESS, undef, sprintf('A000%d.cat', $nID));	# format and return the filename
	}

#######################################################
#
# GetHierarchicalCustomVar - Get a hierchical customvar
#
# Input:	$pProduct			- pointer to product info
#			$sCustomVar			- customvar to get
#			$sSectionBlobName - customvar to get
#
# Returns:	CUSTOMVAR or '??????'
#
#######################################################

sub GetHierarchicalCustomVar
	{
	my ($pProduct, $sCustomVar, $sSectionBlobName) = @_;
	#
	# If defined at product level, return it
	#
	if (defined $pProduct->{'CUSTOMVARS'}{$sCustomVar})
		{
		return ($pProduct->{'CUSTOMVARS'}{$sCustomVar});
		}
	#
	# If defined at section level, return it
	#
	my ($nStatus, $sMessage, $rhashSection);
	($nStatus, $sMessage, $rhashSection) = GetSectionHash($sSectionBlobName);
	if ($nStatus == $::FAILURE)
		{
		ACTINIC::ReportError($sMessage, GetPath());
		}
	if (defined ${$rhashSection->{'CUSTOMVARS'}}{$sCustomVar})
		{
		return ($rhashSection->{'CUSTOMVARS'}{$sCustomVar});
		}
	#
	# If defined at parent section level, return it
	#
	my $nSectionID;
	foreach $nSectionID (@{$rhashSection->{'PARENT_SECTIONS'}})
		{
		($nStatus, $sMessage, $sSectionBlobName) = ACTINIC::GetSectionBlobName($nSectionID); # retrieve the blob name
		if ($nStatus == $::FAILURE)
			{
			ACTINIC::ReportError($sMessage, GetPath());
			}
		($nStatus, $sMessage, $rhashSection) = GetSectionHash($sSectionBlobName);
		if ($nStatus == $::FAILURE)
			{
			ACTINIC::ReportError($sMessage, GetPath());
			}
		if (defined $rhashSection->{'CUSTOMVARS'}{$sCustomVar})
			{
			return ($rhashSection->{'CUSTOMVARS'}{$sCustomVar});
			}
		}
	#
	# If defined at site level, return it
	#
	my $sValue;
	($nStatus, $sValue) = IsCustomVarDefined($sCustomVar);
	if ($nStatus)
		{
		return ($sValue);
		}
	return ('??????');
	}

#######################################################
#
# ParseOnlinePriceTemplate - Parse the online price template for a product
#
# Input:	$sPriceTemplate - price XML template
#
# Returns:	0	- $::SUCCESS or $::FAILURE
#				1	- error message if $::FAILURE
#				2	- ref to <Actinic:OnlinePrices> element
#				3	- ref to <Actinic:RetailPrices> element
#				4	- ref to <Actinic:CustomerPrices> element
#
#######################################################

sub ParseOnlinePriceTemplate
	{
	my ($sPriceTemplate) = @_;
	#
	# Decode the template
	#
	$sPriceTemplate =~ s/%0d\s*//g;
	$sPriceTemplate = ACTINIC::DecodeText($sPriceTemplate, $ACTINIC::FORM_URL_ENCODED);
	my ($nDummy, $ptreePriceTemplate) = ACTINIC::PreProcessXMLTemplateString($sPriceTemplate);
	#
	# Parse the template
	#
	my $elemAll = $ptreePriceTemplate->[0];
	my $elemOnlinePrices = ($elemAll->GetTag() eq 'OnlinePrices') ?
		$elemAll :	$elemAll->FindNode('OnlinePrices');
	if (!defined $elemOnlinePrices)
		{
		return ($::FAILURE, GetPhrase(-1, 2451, 'OnlinePrices'));
		}

	my $elemRetailPrices = $elemOnlinePrices->FindNode('RetailPrices');
	if (!defined $elemRetailPrices)
		{
		return ($::FAILURE, GetPhrase(-1, 2451, 'RetailPrices'));
		}
	
	my $elemCustomerPrices = $elemOnlinePrices->FindNode('CustomerPrices');
	if (!defined $elemCustomerPrices)
		{
		return ($::FAILURE, GetPhrase(-1, 2451, 'CustomerPrices'));
		}
	return ($::SUCCESS, '', $elemOnlinePrices, $elemRetailPrices, $elemCustomerPrices);
	}
		
#######################################################
#
# GetSectionHash - Get a reference to the section hash
#
# Input:	$sSectionBlobFileName - section blob file name
#
# Returns:	0 - status (SUCCESS, FAILURE, NOTFOUND)
#				1 - error message
#				2 - a reference to the section hash
#
#######################################################

sub GetSectionHash
	{
	my ($sSectionBlobFileName) = @_;
	
	if (!defined $::g_pSectionList{$sSectionBlobFileName})
		{
		my @Response = ReadSectionFile(GetPath().$sSectionBlobFileName);
		if ($Response[0] != $::SUCCESS)
			{
			return ($::NOTFOUND, GetPhrase(-1, 2452, $sSectionBlobFileName));
			}
		if (${$::g_pSectionList{$sSectionBlobFileName}}{VERSION} != $::g_nSectionBlobVersion)		# not the correct blob version number
			{
			return ($::FAILURE, sprintf($::g_sCompabilityError, ${$::g_pSectionList{$sSectionBlobFileName}}{VERSION}, "Section blob",  $::g_nSectionBlobVersion));
			}
		}
	return ($::SUCCESS, '', $::g_pSectionList{$sSectionBlobFileName});
	}
	
#######################################################
#
# GetProduct - locate a product object given its
#	product reference.  if the queried product has
#	been removed from the catalog, GetProduct will
#	return NOTFOUND.
#
# Params:	0 - the product reference
#				1 - the section blob filename
#				2 - file path
#
# Returns:	0 - status (SUCCESS, FAILURE, NOTFOUND)
#				1 - error message
#				2 - a reference to the product
#
#######################################################

sub GetProduct
	{
#? ACTINIC::ASSERT($#_ == 2, "Invalid argument count in GetProduct ($#_)", __LINE__, __FILE__);

	my ($ProductRef, $sSectionBlobFilename, $sPath);
	($ProductRef, $sSectionBlobFilename, $sPath) = @_;
	if (length $ProductRef == 0)
		{
		return ($::FAILURE, GetPhrase(-1, 37), 0, 0);
		}
	#
	# Strip out the duplicate product reference tags
	#
	my $sOrigProdRef = $ProductRef;
	$sOrigProdRef =~ s/^\d+\!//g;						# if there is a duplicate product code then remove it
	#
	# see if the section is already in memory
	#
	my ($bInMemory);
	$bInMemory = defined $::g_pSectionList{$sSectionBlobFilename};

	#
	# If the item is not in memory, read the section blob
	#
	my (@Response, $Status, $Message);
	if (!$bInMemory)
		{
		@Response = ReadSectionFile($sPath.$sSectionBlobFilename);
		($Status, $Message) = @Response;
		if ($Status != $::SUCCESS)
			{
			return ($::NOTFOUND, GetPhrase(-1, 173, $ProductRef), \%::g_DeletedProduct);
			}
		if (${$::g_pSectionList{$sSectionBlobFilename}}{VERSION} != $::g_nSectionBlobVersion)		# not the correct blob version number
			{
			return ($::FAILURE, sprintf($::g_sCompabilityError, ${$::g_pSectionList{$sSectionBlobFilename}}{VERSION}, "Section blob",  $::g_nSectionBlobVersion));
			}
		}
	#
	# see if the product was found in the file.  If not, the supplier must have removed the item from the
	# catalog after we added the item to the cart.
	#

	if (!defined ${$::g_pSectionList{$sSectionBlobFilename}}{$sOrigProdRef})
		{
		#
		# If the product is not in the given section then check if it is
		# there in any other section
		#
		my $sSID;
		my $sSectionBlobName;
		($Status, $sSID) = LookUpSectionID($sPath, $sOrigProdRef);	# look it up
		if ($Status == $::SUCCESS)					# we find a section ID
			{
			#
			# Is this section ID the same as the already checked one?
			#
			($Status, $Message, $sSectionBlobName) = GetSectionBlobName($sSID); # retrieve the blob name
			if ($Status == $::FAILURE) 			# couldn't find the section blob
				{
				return ($Status, $Message, \%::g_DeletedProduct);	#nothing to do here
				}
			#
			# Is this section ID the same as the already checked one?
			#
			if (($sSectionBlobName eq $sSectionBlobFilename) ||	# it is the same as the checked one
			   ((defined $::g_pSectionList{$sSectionBlobName}) && # or this section blob is already loaded 
				(!defined ${$::g_pSectionList{$sSectionBlobName}}{$sOrigProdRef}))) # but this product is not in it
				{
				return ($::NOTFOUND, GetPhrase(-1, 173, $ProductRef), \%::g_DeletedProduct);
				}
			#
			# We found a new section blob where the product is possibly in
			# Lets try that one
			#
			return (GetProduct($sOrigProdRef, $sSectionBlobName, $sPath));
			}
		return ($::NOTFOUND, GetPhrase(-1, 173, $ProductRef), \%::g_DeletedProduct);
		}

	return ($::SUCCESS, '', ${$::g_pSectionList{$sSectionBlobFilename}}{$sOrigProdRef});
	}

################################################################
#
# LookUpSectionID - look up the section ID for a given product
#   reference 
#
# Input:	   0 - path
#				1 - product reference to look for
#
# Output:  	0 - status
#				1 - section ID
#
# Author: Zoltan Magyar
#
################################################################

sub LookUpSectionID
	{
	my ($sPath, $sProdRef) = @_;						# get parameters
	
	my %Product;
	my $rFile = \*PRODUCTINDEX;
	my $sFilename = $sPath . "oldprod.fil";
	my ($status, $sError) = ACTINIC::InitIndex($sFilename, $rFile, $::g_nSearchIndexVersion);
	if ($status != $::SUCCESS)
		{
		ACTINIC::TerminalError($sError);
		}
	#
	# Do the product lookup
	#
	($status, $sError) = ACTINIC::ProductSearch($sProdRef, $rFile, $sFilename, \%Product);
	if ($status != $::SUCCESS)							# search engine error
		{
		ACTINIC::CleanupIndex($rFile);
		return ($::FAILURE, 0);							# report it
		}
	return ($::SUCCESS, $Product{SID});
	}
	
#######################################################
#
# GetProductReferenceFromVariant - translate the
#	specified product variant code into a product
#	reference.
#
# Params:	0 - the variant code
#				1 - the section blob filename
#				2 - file path
#
# Returns:	0 - status (SUCCESS, FAILURE, NOTFOUND)
#				1 - error message
#				2 - the product reference
#
#######################################################

sub GetProductReferenceFromVariant
	{
#? ACTINIC::ASSERT($#_ == 2, "Invalid argument count in GetProductReferenceFromVariant ($#_)", __LINE__, __FILE__);
	my ($sInvalidProductReference) = "'";
	my ($sVariantCode, $sSectionBlobFilename, $sPath);
	($sVariantCode, $sSectionBlobFilename, $sPath) = @_;
#? ACTINIC::ASSERT(length $sVariantCode > 0, "Invalid product variant code (empty).", __LINE__, __FILE__);
	#
	# see if the section is already in memory
	#
	my ($bInMemory);
	$bInMemory = defined $::g_pVariantList{$sSectionBlobFilename};
	#
	# If the item is not in memory, read the section blob
	#
	my (@Response, $Status, $Message);
	if (!$bInMemory)
		{
		@Response = ReadSectionFile($sPath.$sSectionBlobFilename);
		($Status, $Message) = @Response;
		if ($Status != $::SUCCESS)
			{
			return (@Response);
			}
		my $nVersion = 0;
		if (${$::g_pVariantList{$sSectionBlobFilename}}{VERSION} != $nVersion)	# not the correct blob version number
			{
			return ($::FAILURE, sprintf($::g_sCompabilityError, ${$::g_pVariantList{$sSectionBlobFilename}}{VERSION} ,"Variant blob", $nVersion ));
			}
		}
	#
	# see if the product was found in the file.  If not, the supplier must have removed the item from the
	# catalog after we added the item to the cart.
	#
	if (!defined ${$::g_pVariantList{$sSectionBlobFilename}}{$sVariantCode})
		{
		return ($::FAILURE, GetPhrase(-1, 190, $sVariantCode), $sInvalidProductReference);
		}

	return ($::SUCCESS, undef, ${$::g_pVariantList{$sSectionBlobFilename}}{$sVariantCode});
	}

#######################################################
#
# ReadSetupFile - read the setup blob file
#
# Params:	0 - path
#
# Returns:	0 - status
#				1 - error message
#
# Affects:	$::g_pSetupBlob - points to the global
#					setup hash
#
#######################################################

sub ReadSetupFile
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ReadSetupFile ($#_)", __LINE__, __FILE__);

	my @Response = ReadConfigurationFile($_[0]."nqset00.fil",'$g_pSetupBlob');	# load the catalog
	if ($Response[0] != $::SUCCESS)
		{
		return (@Response);
		}

	if ($$::g_pSetupBlob{VERSION} != $::g_nSetupBlobVersion) # not the correct blob version number
		{
		return ($::FAILURE, sprintf($::g_sCompabilityError, $$::g_pSetupBlob{VERSION}, "Setup blob", $::g_nSetupBlobVersion ));
		}

	my $nMinorVersion = 1;
	if ($$::g_pSetupBlob{MINOR_VERSION} < $nMinorVersion) # not the correct blob version number
		{
		return ($::FAILURE, "Setup blob minor version number is " . $$::g_pSetupBlob{MINOR_VERSION} .
			", but minor version $nMinorVersion is required.", 0, 0);
		}
#? if ($$::g_pSetupBlob{MINOR_VERSION} > $nMinorVersion)
#?		{
#?		TRACE('Setup blob minor version number does not match the script minor version number.');
#?		TRACE("\tThe setup blob minor version number is " . '%d.', $$::g_pSetupBlob{MINOR_VERSION});
#?		TRACE("\tThe script expects minor version number " . '%d.', $nMinorVersion);
#?		}

	$::g_sRequiredColor	= $$::g_pSetupBlob{REQUIRED_COLOR}; # store the global required field color
	$::g_sErrorColor		= $$::g_pSetupBlob{ERRORHIGHLIGHTCOLOR};	# the error highlight field color

	#
	# At this point the content URL was converted to https if SSL was in used - no longer required
	#
	my $sCgiUrl = $$::g_pSetupBlob{CGI_URL};							# Full HTTP path to cgi-bin
	my $sSSLCgiUrl = "";
	if ($$::g_pSetupBlob{USE_SSL})
		{
		$sSSLCgiUrl = $$::g_pSetupBlob{SSL_CGI_URL};		# Full HTTPS path to cgi-bin
		}
	#
	# Make CGI URL relative (by stripping server part) when
	# the 'Use Relative CGI URLs' option is selected
	#
	if ($$::g_pSetupBlob{'USE_RELATIVE_CGI_URLS'})
		{
		$sCgiUrl =~ s/http(s?):\/\/[^\/]*\//\//;						# strip server part
		$sSSLCgiUrl =~ s/http(s?):\/\/[^\/]*\//\//;	# strip server part
		}
	my $sCgiName = "%s" . sprintf("%6.6d%s",$$::g_pSetupBlob{CGI_ID},$$::g_pSetupBlob{CGI_EXT});
	$sCgiUrl .= $sCgiName;
	$sSSLCgiUrl .= $sCgiName;
	#
	# Define global script variables
	#
	$::g_sAccountScript 	= sprintf($sCgiUrl, "bb");
	$::g_sAccountScriptName = sprintf($sCgiName, "bb");
	$::g_sOrderScript 	= sprintf($sCgiUrl, "os");
	$::g_sSearchScript  	= sprintf($sCgiUrl, "ss");
	$::g_sCartScript  	= sprintf($sCgiUrl, "ca");
	$::g_sSearchHighLightScript = sprintf($sCgiUrl, "sh");
	$::g_sSSLSearchScript= sprintf($sSSLCgiUrl, "ss");
	#
	# At this point the account script  was converted to https if SSL was in used - no longer required
	#
	# PRESNET
	# Presnet: set flags by uncommenting these changes
	#
#	$$::g_pSetupBlob{'EMAIL_ORDER'}	= $::TRUE;
#	$$::g_pSetupBlob{'REVERSE_ADDRESS_CHECK'}	= $::TRUE;
#	$$::g_pSetupBlob{'SUPPRESS_CART_WITH_CONFIRM'}	= $::TRUE;
#	$$::g_pSetupBlob{'DISPLAY_CART_AFTER_CONFIRM'}	= $::TRUE;
#	$$::g_pSetupBlob{'PROCEED_CHECKOUT'} = 'pwc.gif';
#	$$::g_pSetupBlob{'CONTINUE_SHOP'} = 'cs.gif';
#	$$::g_pSetupBlob{'EDIT_CART'} = 'ec.gif';
#	$$::g_pSetupBlob{'CONFIRM_IMG'} = 'cnfm.gif';
#	$$::g_pSetupBlob{'CANCEL_IMG'} = 'can.gif';
#	$$::g_pSetupBlob{'REMOVE_IMG'} = 'rem.gif';
#	$$::g_pSetupBlob{'EDIT_IMG'} = 'edit.gif';
	# PRESNET

	return ($::SUCCESS, "", 0, 0);					# we are done
	}

#######################################################
#
# ReadCatalogFile - read the catalog blob file.
#
# Params:	0 - path
#
# Returns:	0 - status
#				1 - error message
#
# Affects:	$::g_pCatalogBlob - points to the global
#					catalog hash
#
#######################################################

sub ReadCatalogFile
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ReadCatalogFile ($#_)", __LINE__, __FILE__);

	my @Response = ReadConfigurationFile($_[0]."A000.cat",'$g_pCatalogBlob');	# load the catalog
	if ($Response[0] != $::SUCCESS)
		{
		return (@Response);
		}

	if ($$::g_pCatalogBlob{VERSION} != $::g_nCatalogBlobVersion)	# not the correct blob version number
		{
		return ($::FAILURE, sprintf($::g_sCompabilityError, $$::g_pCatalogBlob{VERSION}, "Catalog blob", $::g_nCatalogBlobVersion ));
		}

	return ($::SUCCESS, "", 0, 0);					# we are done
	}

#######################################################
#
# ReadDiscountBlob - read the discount setup file.
#
# Params:	0 - path
#
# Returns:	0 - status
#				1 - error message
#
# Affects:	$::g_pDiscountBlob - points to the global
#					discounts hash
#
#######################################################

sub ReadDiscountBlob
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ReadCatalogFile ($#_)", __LINE__, __FILE__);

	my @Response = ReadConfigurationFile($_[0]."discounts.fil",'$g_pDiscountBlob');	# load the catalog
	if ($Response[0] != $::SUCCESS)
		{
		return (@Response);
		}

	if ($$::g_pDiscountBlob{VERSION} != $::g_nDiscountBlobVersion)	# not the correct blob version number
		{
		return ($::FAILURE, sprintf($::g_sCompabilityError, $$::g_pDiscountBlob{VERSION}, "Discount blob", $::g_nDiscountBlobVersion ));
		}

	return ($::SUCCESS, "", 0, 0);					# we are done
	}

#######################################################
#
# IsCustomVarDefined - Check if the given CUSTOMVAR is
#		defined at Catalog level and return its value if so
#
# Params:	0 - name of the CUSTOMVAR
#
# Returns:	0 - $::TRUE if the CV is defined
#				1 - the value of the CV if defined (otherwise '')
#
# Affects:	$::g_pCatalogBlob - loads the catalog blob
#					if it isn't loaded
#
#######################################################

sub IsCustomVarDefined
	{
	my $sVarname = $_[0];
	#
	# See if Catalog BLOB is already loaded
	#
	if (!defined $::g_pCatalogBlob)					# if it isn't there
		{
		my ($nStatus, $sMessage) = ReadCatalogFile(GetPath());	# then load it now
		if ($nStatus != $::SUCCESS)
			{
			TerminalError($sMessage);
			}
		}
	if (!defined $::g_pCatalogBlob->{CUSTOMVARS}{$sVarname})
		{
		return($::FALSE, "");
		}
	else
		{
		return($::TRUE, $::g_pCatalogBlob->{CUSTOMVARS}{$sVarname});
		}
	}

#######################################################
#
# ReadPaymentFile - read the location blob file.
#
# Params:	0 - path
#
# Returns:	0 - status
#				1 - error message
#
# Affects:	$::g_pPaymentList - points to the global
#					payment hash
#
#######################################################

sub ReadPaymentFile
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ReadPaymentFile ($#_)", __LINE__, __FILE__);

	my @Response = ReadConfigurationFile($_[0]."payment.fil",'$g_pPaymentList');	# load the blob
	if ($Response[0] != $::SUCCESS)
		{
		return (@Response);
		}

	if ($$::g_pPaymentList{VERSION} != $::g_nPaymentBlobVersion)	# not the correct blob version number
		{
		return ($::FAILURE, sprintf($::g_sCompabilityError, $$::g_pPaymentList{VERSION}, "Location blob", $::g_nPaymentBlobVersion ));
		}

	return ($::SUCCESS, "", 0, 0);					# we are done
	}

#######################################################
#
# ReadLocationsFile - read the location blob file.
#
# Params:	0 - path
#
# Returns:	0 - status
#				1 - error message
#
# Affects:	$::g_pLocationList - points to the global
#					location hash
#
#######################################################

sub ReadLocationsFile
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ReadLocationsFile ($#_)", __LINE__, __FILE__);

	my @Response = ReadConfigurationFile($_[0]."locations.fil",'$g_pLocationList');	# load the catalog
	if ($Response[0] != $::SUCCESS)
		{
		return (@Response);
		}

	if ($$::g_pLocationList{VERSION} != $::g_nLocationBlobVersion)	# not the correct blob version number
		{
		return ($::FAILURE, sprintf($::g_sCompabilityError, $$::g_pLocationList{VERSION}, "Location blob", $::g_nLocationBlobVersion));
		}

	return ($::SUCCESS, "", 0, 0);					# we are done
	}

#######################################################
#
# ReadSearchSetupFile - read the search setup blob file
#
# Params:	0 - path
#
# Returns:	0 - status
#				1 - error message
#
# Affects:	$::g_pSearchSetup - points to the global
#					search setup hash
#
#######################################################

sub ReadSearchSetupFile
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ReadSearchSetupFile ($#_)", __LINE__, __FILE__);

	my @Response = ReadConfigurationFile($_[0]."search.fil",'$g_pSearchSetup');	# load the catalog
	if ($Response[0] != $::SUCCESS)
		{
		return (@Response);
		}

	if ($$::g_pSearchSetup{VERSION} != $::g_nSearchSetupBlobVersion) # not the correct blob version number
		{
		return ($::FAILURE, sprintf($::g_sCompabilityError, $$::g_pSearchSetup{VERSION}, "Search setup blob", $::g_nSearchSetupBlobVersion));
		}

	return ($::SUCCESS, "", 0, 0);					# we are done
	}

#######################################################
#
# ReadTaxSetupFile - read the tax blob file.
#
# Params:	0 - path
#
# Returns:	0 - status
#				1 - error message
#
# Affects:	$::g_pLocationList - points to the global
#					location hash
#
#######################################################

sub ReadTaxSetupFile
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ReadTaxSetupFile ($#_)", __LINE__, __FILE__);

	my @Response = ReadConfigurationFile($_[0]."taxsetup.fil",'$g_pTaxSetupBlob','$g_pTaxesBlob','$g_pTaxZonesBlob','$g_pTaxZoneMembersTable');	# load the file
	if ($Response[0] != $::SUCCESS)
		{
		return (@Response);
		}

	if ($$::g_pTaxSetupBlob{VERSION} != $::g_nTaxSetupBlobVersion)	# not the correct blob version number
		{
		return ($::FAILURE, sprintf($::g_sCompabilityError, $$::g_pTaxSetupBlob{VERSION}, "Tax setup blob", $::g_nTaxSetupBlobVersion));
		}

	return ($::SUCCESS, "", 0, 0);					# we are done
	}

#######################################################
#
# ReadSSPSetupFile - read the SSP setup blob file.
#
# Params:	0 - path
#
# Returns:	0 - status
#				1 - error message
#
# Affects:	$::g_pSSPSetupBlob - points to the global
#					SSP setup hash
#
# Author:	Mike Purnell
#
#######################################################

sub ReadSSPSetupFile
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ReadSSPSetupFile ($#_)", __LINE__, __FILE__);

	my @Response = ReadConfigurationFile($_[0]."sspsetup.fil",'$g_pSSPSetupBlob');	# load the file
	if ($Response[0] != $::SUCCESS)
		{
		return (@Response);
		}

	if ($$::g_pSSPSetupBlob{VERSION} != $::g_nSSPSetupBlobVersion)	# not the correct blob version number
		{
		return ($::FAILURE, sprintf($::g_sCompabilityError, $$::g_pSSPSetupBlob{VERSION}, "SSP setup blob", $::g_nSSPSetupBlobVersion ));
		}

	return ($::SUCCESS, "", 0, 0);					# we are done
	}

#######################################################
#
# ReadSectionFile - read the specified section blob
#	file
#
# Params:	0 - blob filename
#
# Returns:	0 - status
#				1 - error message
#
# Affects:	$::g_pSectionList - points to the global
#					section hash
#
#######################################################

sub ReadSectionFile
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ReadSectionFile ($#_)", __LINE__, __FILE__);

	my @Response = ReadConfigurationFile(@_,'%g_pSectionList');		# load the configuration
	if ($Response[0] != $::SUCCESS)
		{
		$Response[0] = $::NOTFOUND;					# translate the failure into a product not found error
		return (@Response);
		}

	return ($::SUCCESS, "", 0, 0);					# we are done
	}


#######################################################
#
# ReadPhaseFile - read phase list
#
# Params:	0 - path
#
# Returns:	0 - status
#				1 - error message
#
# Affects:	$::g_pPhaseList - points to the global
#					phase hash
#
#######################################################

sub ReadPhaseFile
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ReadPhaseFile ($#_)", __LINE__, __FILE__);

	my @Response = ReadConfigurationFile($_[0]."phase.fil",'$g_pPhaseList');	# load the catalog
	if ($Response[0] != $::SUCCESS)
		{
		return (@Response);
		}

	if ($$::g_pPhaseList{VERSION} != 0)				# not the correct blob version number
		{
		return ($::FAILURE, sprintf($::g_sCompabilityError, $$::g_pPhaseList{VERSION}, "Phase blob", 0));
		}

	return ($::SUCCESS, "", 0, 0);					# we are done
	}

#######################################################
#
# ReadPromptFile - read the prompt blob
#
# Params:	0 - path
#
# Returns:	0 - status
#				1 - error message
#
# Affects:	$::g_pPromptList - points to the global
#					prompt hash
#
#######################################################

sub ReadPromptFile
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ReadPromptFile ($#_)", __LINE__, __FILE__);

	my @Response = ReadConfigurationFile($_[0]."prompt.fil",'$g_pPromptList');	# load the catalog
	if ($Response[0] != $::SUCCESS)
		{
		return (@Response);
		}

	if ($$::g_pPromptList{VERSION} != 0)				# not the correct blob version number
		{
		return ($::FAILURE, sprintf($::g_sCompabilityError, $$::g_pPromptList{VERSION}, "Prompt blob", 0));
		}
	#
	# load some common values into globals
	#
	$::g_sCancelButtonLabel 	= GetPhrase(-1, 505);
	$::g_sConfirmButtonLabel 	= GetPhrase(-1, 153);
	$::g_sAddToButtonLabel 		= GetPhrase(-1, 154);
	$::g_sEditButtonLabel 		= GetPhrase(-1, 155);
	$::g_sRemoveButtonLabel 	= GetPhrase(-1, 156);
	$::g_sSearchButtonLabel 	= GetPhrase(-1, 157);
	$::g_sSaveShoppingListLabel 	= GetPhrase(-1, 2164);
	$::g_sGetShoppingListLabel 	= GetPhrase(-1, 2165);
	$::g_sUpdateCartLabel			= GetPhrase(-1, 2166);
	$::g_sCheckoutNowLabel			= GetPhrase(-1, 184);
	$::g_sContinueShoppingLabel	= GetPhrase(-1, 47);
	$::g_sSendCouponLabel			= GetPhrase(-1, 2356);
	$::g_sSendMailLabel				= GetPhrase(-1, 2374);

	$::g_sCompabilityError		= GetPhrase(-1, 2219);
	#
	# the substitute product for products that have been deleted
	#
	%::g_DeletedProduct =
		(
		'REFERENCE' => ' ',
		'NAME' => ACTINIC::GetPhrase(-1, 174),
		'PRICE' => 0,
		'MIN' => 1,
		'MAX' => 0,
		'TAX_TREATMENT' => $ActinicOrder::ZERO
		);
	#
	# build some index tables to speed generic searches later
	#
	my @keys = keys %{$::g_pPromptList};
	my $list = join(' ', @keys);
	my @scratch = ($list =~ m/([-0-9]+),(\d+) /g);
	while ($#scratch != -1)
		{
		my $nPhraseID = pop @scratch;					# find the next phrase ID
		push (@{$::g_PhraseIndex{pop @scratch}}, $nPhraseID); # add it to the stack for this phase
		}
	return ($::SUCCESS, "", 0, 0);					# we are done
	}

#######################################################
#
# ReadConfigurationFile - read the specified blob
#	file
#
# Params:	0 - blob filename
#           1... optional - global variables to be shared with
#                the script
#                Format:  '$foo','$bar',... would share $::foo and $::bar
#                This triggers an attempt to load Safe.pm and eval the
#                script in a Safe compartment. If Safe.pm cannot be loaded
#                eval is used and these arguments are ignored.
#                (See EvalInSafe())
#
# Returns:	0 - status
#				1 - error message
#
# Affects:	the appropriate blob
#
#######################################################

sub ReadConfigurationFile
	{
#? ACTINIC::ASSERT($#_ >= 0, "Invalid argument count in ReadConfigurationFile ($#_)", __LINE__, __FILE__);

	my $sFilename = shift;
	my $pShared   = \@_;					# Optional list of shared variables

	my @Response = ReadAndVerifyFile($sFilename);
	if ($Response[0] != $::SUCCESS)
		{
		return(@Response);
		}
	#
	# execute the script (parse the blob)
	#

	if( !$ACTINIC::USESAFE or $#$pShared < 0 )					# No shared variables - use eval
		{
		if (eval($Response[2]) != $::SUCCESS)
			{
			return ($::FAILURE, "Error loading configuration file $sFilename. $@", 0, 0);
			}
		}
	else
		{
		@Response = EvalInSafe($Response[2],$ACTINIC::USESAFEONLY,$pShared);	# Try to use Safe.pm
		if( $Response[0] != $::SUCCESS)
			{
			return ($::FAILURE, "Error loading configuration file $sFilename. $Response[1]", 0, 0);
			}
		}

	return ($::SUCCESS, "", 0, 0);					# we are done
	}

#######################################################
#
# ReadAndVerifyFile - read the specified script and
#	verify its signature
#
# Params:	0 - filename
#
# Returns:	0 - status
#				1 - error message
#				2 - script
#
#######################################################

sub ReadAndVerifyFile
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in ReadAndVerifyFile ($#_)", __LINE__, __FILE__);

	my ($sFilename);
	($sFilename) = @_;									# set the blob filename

	unless (open (SCRIPTFILE, "<$sFilename"))		# open the file
		{
		return ($::FAILURE, "Error opening configuration file $sFilename. $!", 0, 0);
		}

	my $nCheckSum = <SCRIPTFILE>;						# read the checksum
	chomp $nCheckSum;										# strip any trailing CRLF
	$nCheckSum =~ s/;$//;								# strip the trailing ;

	my $sScript;
	{
	local $/;
	$sScript = <SCRIPTFILE>;							# read the entire file
	}
	close (SCRIPTFILE);									# close the file
	#
	# calculate the script checksum
	#
	my $uTotal;
		{
		use integer;
		$uTotal = unpack('%32C*', $sScript);
		}
	#
	# verify the script
	#
	if ($nCheckSum != $uTotal)
		{
		return ($::FAILURE, "$sFilename is corrupt.  The signature is invalid.", 0, 0);
		}

	$sScript =~ s/\r//g;									# remove the dos <CR>

	return ($::SUCCESS, "", $sScript, 0);
	}

################################################################
#
# GetBuyerAndAccount - retrieve the buyer and account given the digest
#
# Input:	   0 - digest
#           1 - path
#
# Returns:	0 - status
#           1 - error message if any
#           2 - a reference to the buyer hash
#           3 - a reference to the account hash
#
################################################################

sub GetBuyerAndAccount
	{
	my ($sDigest) = @_;
	if($sDigest eq '')
		{
		return($::NOTFOUND);
		}
	#
	# Get the buyer
	#
	my ($Status, $sMessage, $pBuyer) = ACTINIC::GetBuyer($sDigest, ACTINIC::GetPath());
	if ($Status != $::SUCCESS)
		{
		return ($Status, $sMessage);
		}
	#
	# Get the account
	#
	my $pAccount;
	($Status, $sMessage, $pAccount) = ACTINIC::GetCustomerAccount($$pBuyer{AccountID}, ACTINIC::GetPath());
	if ($Status != $::SUCCESS)
		{
		return ($Status, $sMessage);
		}
	return($::SUCCESS, '', $pBuyer, $pAccount);
	}

#######################################################
#
# GetCustomerAddressLists - get a hash of lists of valid
#				customer addresses
#
# Params:	0 - reference to the buyer object
#				1 - reference to the account
#				2 - whether to skip location info check (optional)
#
# Returns:	0 - status
#				1 - error message
#				2 - reference to a list of valid invoice addresses
#				3 - reference to a list of valid delivery addresses
#				4 - id of a single valid invoice address or -1
#				5 - id of a single valid delivery address or -1
#
#######################################################

sub GetCustomerAddressLists
	{
	my($pBuyer, $pAccount, $bSkipLocationCheck) = @_;

	my ($Status, $sMessage, $pAddress, @listValidInvoiceAddresses, @listValidDeliveryAddresses);
	#
	# Get the address list
	#
	my @listAddressIDs = split(/,/, $$pAccount{AddressList});
	my $nAddressID;
	#
	# Sort out where we have a single invoice or delivery address
	#
	my $nSingleInvoiceID = -1;
	if( $pAccount->{InvoiceAddressRule} == 1)										# The Customer rule overrides buyer rule
		{
		$nSingleInvoiceID = $pAccount->{InvoiceAddress};
		}
	elsif($pBuyer->{InvoiceAddressRule} == 0)
		{
		$nSingleInvoiceID = $pBuyer->{InvoiceAddressID};
		}
	my $nSingleDeliveryID = $pBuyer->{DeliveryAddressRule} == 0 ?
		$pBuyer->{DeliveryAddressID} : -1;
	#
	# Go thru the address list
	#
	foreach $nAddressID (@listAddressIDs)
		{
		($Status, $sMessage, $pAddress) = ACTINIC::GetCustomerAddress($$pBuyer{AccountID}, $nAddressID, ACTINIC::GetPath());
		if ($Status != $::SUCCESS)
			{
			ACTINIC::CloseCustomerAddressIndex(); # The customer index is left open for multiple access, so clean it up here
			return ($::FAILURE, "The format of the address information stored on the server (oldaddress.fil) is invalid. The reported error was: " . $sMessage, "");
			}
		#
		# Check if this is a valid invoice address
		#
		if($pAddress->{ValidAsInvoiceAddress})
			{
			my $bValidAddress = $::FALSE;
			if($::g_pLocationList->{EXPECT_INVOICE})
				{
				if($bSkipLocationCheck)
					{
					$bValidAddress = $::TRUE;
					}
				elsif($::g_LocationInfo{INVOICE_COUNTRY_CODE} eq '' ||
					$::g_LocationInfo{INVOICE_COUNTRY_CODE} eq $ActinicOrder::REGION_NOT_SUPPLIED ||
					($pAddress->{CountryCode} eq $::g_LocationInfo{INVOICE_COUNTRY_CODE} &&
					($::g_LocationInfo{INVOICE_REGION_CODE} eq $ActinicOrder::UNDEFINED_REGION ||
					$pAddress->{StateCode} eq $::g_LocationInfo{INVOICE_REGION_CODE})))
					{
					$bValidAddress = $::TRUE;
					}
				}
			else
				{
				$bValidAddress = $::TRUE;
				}

			if(($nSingleInvoiceID == -1 && $bValidAddress) ||
				$nSingleInvoiceID == $pAddress->{ID})
				{
				push @listValidInvoiceAddresses, $pAddress;
				}
			}
		#
		# Check if this is a valid delivery address
		#
		if($pAddress->{ValidAsDeliveryAddress})
			{
			my $bValidAddress = $::FALSE;
			if($::g_pLocationList->{EXPECT_DELIVERY})
				{
				if($bSkipLocationCheck)
					{
					$bValidAddress = $::TRUE;
					}
				elsif($::g_LocationInfo{DELIVERY_COUNTRY_CODE} eq '' ||
					($::g_LocationInfo{DELIVERY_COUNTRY_CODE} eq $ActinicOrder::REGION_NOT_SUPPLIED ||
					$pAddress->{CountryCode} eq $::g_LocationInfo{DELIVERY_COUNTRY_CODE}) &&
					($::g_LocationInfo{DELIVERY_REGION_CODE} eq $ActinicOrder::UNDEFINED_REGION ||
					$pAddress->{StateCode} eq $::g_LocationInfo{DELIVERY_REGION_CODE}))
					{
					$bValidAddress = $::TRUE;
					}
				}
			else
				{
				$bValidAddress = $::TRUE;
				}

			if(($nSingleDeliveryID == -1 && $bValidAddress) ||
				$nSingleDeliveryID == $pAddress->{ID})
				{
				push @listValidDeliveryAddresses, $pAddress;
				}
			}
		}

	return($::SUCCESS, '', \@listValidInvoiceAddresses, \@listValidDeliveryAddresses,
		$nSingleInvoiceID, $nSingleDeliveryID);
	}

################################################################
#
# GetBuyer - retrieve the buyer given the digest
#
# Input:	   0 - digest
#           1 - path
#
# Returns:	0 - status
#           1 - error message if any
#           2 - a reference to the buyer hash
#
################################################################

sub GetBuyer
	{
#? ACTINIC::ASSERT($#_ == 1, 'Incorrect parameter count ACTINIC::GetBuyer(' . join(', ', @_) . ").", __LINE__, __FILE__);
	#
	# Since we typically only retrieve one buyer per execution, it is OK to open the file,
	# do the lookup and close the file.  It is easier to maintain this way.
	#
	my ($sDigest, $sPath) = @_;
	if ($sDigest eq $ACTINIC::BuyerDigest)
		{
		return ($::SUCCESS, undef, \%ACTINIC::Buyer);
		}
	undef %ACTINIC::Buyer;
	undef $ACTINIC::BuyerDigest;
	#
	# Open and prepare the index
	#
	my $rFile = \*BUYERINDEX;
	my $sFilename = $sPath . "oldbuyer.fil";
	my ($status, $sMessage) = InitIndex($sFilename, $rFile, $::g_nBuyerBlobVersion);
	if ($status != $::SUCCESS)
		{
		return ($status, $sMessage);
		}
 	eval
		{
		require Digest::MD5;								# Try loading MD5
		import Digest::MD5 'md5_hex';
		};
	if ($@)
		{
		require <Actinic:Variable Name="DigestPerlMD5"/>;
		import Digest::Perl::MD5 'md5_hex';			# Use Perl version if not found
		}
	#
	# Find the buyer
	#
	my $sUserName = $ACTINIC::B2B->Get('UserName');
	my $sUserHash = md5_hex($sUserName . $sDigest);
	my $sUserKey = $ACTINIC::B2B->Get('UserKey');
	my $sValue;
	($status, $sMessage, $sValue) = IndexSearch($sUserHash, 2, $rFile, $sFilename);
	if ($status != $::SUCCESS)
		{
		if ($status == $::NOTFOUND)					# if not found
			{													# use context specific message
			$sMessage = ACTINIC::GetPhrase(-1, 2268);
			}
		CleanupIndex($rFile);
		return ($status, $sMessage);
		}
	CleanupIndex($rFile);
	#
	# Decrypt the index value if $sUserKey is present.
	#
	if ($sUserKey)
		{
		$sUserKey =~ s/([A-Fa-f0-9]{2})/pack("C",hex($1))/ge;
		my @PrivateKey = unpack('C*',$sUserKey);
		my ($sLength, $sDetails) = split(/ /, $sValue);
		$sDetails =~ s/([A-Fa-f0-9]{2})/pack("C",hex($1))/ge;

		ActinicEncrypt::InitEncrypt(@{$$::g_pSetupBlob{PUBLIC_KEY_128BIT}});
		$sDetails = ActinicEncrypt::DecryptSafer($sDetails, @PrivateKey);
		$sValue = substr($sDetails,0,$sLength);	# restore it's size to the original length
		}
	#
	# Parse the index value into a hash.  See CCustomerBuyerItem::operator CString for packing details.
	#
   $sValue =~ s/([^ ])$/$1 /;							# if there is no trailing space add one
   $sValue .= 'a';                              # this is used to prevent the split from stripping trailing empty fields
	my @Details = split(/ /, $sValue);
   pop @Details;											# clear the trailing bogus "a"
	my @Labels = qw (ID AccountID Status InvoiceAddressRule InvoiceAddressID DeliveryAddressRule
						  DeliveryAddressID MaximumOrderValue EmailOnOrder LimitOrderValue HideRetailPrices
						  EmailAddress Name FirstName LastName Salutation Title TelephoneNumber MobileNumber FaxNumber);
	if( $sUserKey )
		{
		push @Labels,'AccountKey';
		}
	#
	# See if the challenge key is corrupt
	#
	if ($#Details != $#Labels)
		{
		return($::BADDATA, ACTINIC::GetPhrase(-1, 2073), undef);
		}
	my $nIndex;
	#
	# Load the hash.  Note that Labels and Details are sorted in the same order
	#
	foreach ($nIndex = 0; $nIndex <= $#Details; $nIndex++)
		{
		$ACTINIC::Buyer{$Labels[$nIndex]} = DecodeText($Details[$nIndex], $ACTINIC::FORM_URL_ENCODED);
		}
	if( $sUserKey )
		{
		$ACTINIC::B2B->Set('AccountKey',$ACTINIC::Buyer{AccountKey});
		}

	$ACTINIC::BuyerDigest = $sDigest;				# remember the digest for automated access later

	return ($::SUCCESS, undef, \%ACTINIC::Buyer);
	}

################################################################
#
# GetCustomerAccount - retrieve the customer given the ID
#
# Input:	   0 - ID
#           1 - path
#
# Returns:	0 - status
#           1 - error message if any
#           2 - a reference to the account hash
#
################################################################

sub GetCustomerAccount
	{
#? ACTINIC::ASSERT($#_ == 1, 'Incorrect parameter count ACTINIC::GetCustomerAccount(' . join(', ', @_) . ").", __LINE__, __FILE__);
	#
	# Since we typically only retrieve one account per execution, it is OK to open the file,
	# do the lookup and close the file.  It is easier to maintain this way.
	#
	my ($nID, $sPath) = @_;
	if ($nID == $ACTINIC::AccountID)
		{
		return ($::SUCCESS, undef, \%ACTINIC::Account);
		}
	undef %ACTINIC::Account;
	undef $ACTINIC::AccountID;
	#
	# Open and prepare the index
	#
	my $rFile = \*ACCOUNTINDEX;
	my $sFilename = $sPath . "oldaccount.fil";
	my ($status, $sMessage) = InitIndex($sFilename, $rFile, $::g_nCustomerAccountBlobVersion);
	if ($status != $::SUCCESS)
		{
		return ($status, $sMessage);
		}
	#
	# Find the account
	#
	my $sValue;
	($status, $sMessage, $sValue) = IndexSearch($nID, 2, $rFile, $sFilename);
	if ($status != $::SUCCESS)
		{
		if ($status == $::NOTFOUND)					# if not found
			{													# use context specific message
			$sMessage = ACTINIC::GetPhrase(-1, 2269);
			}
		CleanupIndex($rFile);
		return ($status, $sMessage);
		}
	CleanupIndex($rFile);
	#
	# If customer accounts are encrypted do the decryption here
	#
	my $sAccountKey = $ACTINIC::B2B->Get('AccountKey');
	if( $sAccountKey )
		{
		$sAccountKey =~ s/([A-Fa-f0-9]{2})/pack("C",hex($1))/ge;
		my @PrivateKey = unpack('C*',$sAccountKey);
		my ($sLength, $sDetails) = split(/ /, $sValue);
		$sDetails =~ s/([A-Fa-f0-9]{2})/pack("C",hex($1))/ge;

		ActinicEncrypt::InitEncrypt(@{$$::g_pSetupBlob{PUBLIC_KEY_128BIT}});
		$sDetails = ActinicEncrypt::DecryptSafer($sDetails, @PrivateKey);
		$sValue = substr($sDetails,0,$sLength);	# restore it's size to the original length
		}
	#
	# Parse the index value into a hash.  See CCustomerItem::operator CString and CIndexValueCustomerAccount::operator CString for packing details.
	#
   $sValue =~ s/([^ ])$/$1 /;							# if there is no trailing space add one
   $sValue .= 'a';                              # this is used to prevent the split from stripping trailing empty fields
	my @Details = split(/ /, $sValue);
   pop @Details;											# clear the trailing bogus "a"
	my @Labels = qw (EmailOnOrder InvoiceAddressRule Status InvoiceAddress PriceSchedule DefaultPaymentMethod
						  AccountName CompanyName EmailAddress TelephoneNumber MobileNumber FaxNumber Name FirstName LastName Salutation Title AddressList);
#? ACTINIC::ASSERT($#Details == $#Labels, 'Corrupt index ACTINIC::GetAccount(' . "$#Details != $#Labels).", __LINE__, __FILE__);
	my $nIndex;
	#
	# Load the hash.  Note that Labels and Details are sorted in the same order
	#
	foreach ($nIndex = 0; $nIndex <= $#Details; $nIndex++)
		{
		$ACTINIC::Account{$Labels[$nIndex]} = DecodeText($Details[$nIndex], $ACTINIC::FORM_URL_ENCODED);
		}
	#
	# Be sure we dont load this again
	#
	$ACTINIC::AccountID = $nID;
	return ($::SUCCESS, undef, \%ACTINIC::Account);
	}

################################################################
#
# GetCustomerAddress - get the customer account address
#
# Input:	   0 - account ID
#           1 - address ID
#           2 - path
#
# Returns:	0 - status
#           1 - error message if any
#           2 - reference address hash
#
################################################################

sub GetCustomerAddress
	{
#? ACTINIC::ASSERT($#_ == 2, 'Incorrect parameter count ACTINIC::GetCustomerAddress(' . join(', ', @_) . ").", __LINE__, __FILE__);
	#
	# Since we occasionally retrieve multiple addresses per execution, we only open the file if it is not open
	# and leave it open until explicitly closed.
	#
	my ($nAccountID, $nAddressID, $sPath) = @_;
	my $sIdentifier = $nAccountID . ":" . $nAddressID;
	if (defined $ACTINIC::Addresses{$sIdentifier})
		{
		return ($::SUCCESS, undef, $ACTINIC::Addresses{$sIdentifier});
		}
	#
	# If the file is not open, open and prepare the index
	#
	my $sFilename = $sPath . "oldaddress.fil";
	if (!defined $ACTINIC::rAddressFileHandle)
		{
		$ACTINIC::rAddressFileHandle = \*ADDRESSINDEX;
		my ($status, $sMessage) = InitIndex($sFilename, $ACTINIC::rAddressFileHandle, $::g_nAddressBlobVersion);
		if ($status != $::SUCCESS)
			{
			return ($status, $sMessage);
			}
		}
	#
	# Find the address
	#
	my ($status, $sMessage, $sValue) = IndexSearch($sIdentifier, 2, $ACTINIC::rAddressFileHandle, $sFilename);
	if ($status != $::SUCCESS)
		{
		if ($status == $::NOTFOUND)					# if not found
			{													# use context specific message
			$sMessage = ACTINIC::GetPhrase(-1, 2270);
			}
		CleanupIndex($ACTINIC::rAddressFileHandle);
		undef $ACTINIC::rAddressFileHandle;
		return ($status, $sMessage);
		}
	#
	# If customer addresses are encrypted do the decryption here
	#
	my $sAccountKey = $ACTINIC::B2B->Get('AccountKey');
	if( $sAccountKey )
		{
		$sAccountKey =~ s/([A-Fa-f0-9]{2})/pack("C",hex($1))/ge;
		my @PrivateKey = unpack('C*',$sAccountKey);
		my ($sLength, $sDetails) = split(/ /, $sValue);
		$sDetails =~ s/([A-Fa-f0-9]{2})/pack("C",hex($1))/ge;

		ActinicEncrypt::InitEncrypt(@{$$::g_pSetupBlob{PUBLIC_KEY_128BIT}});
		$sDetails = ActinicEncrypt::DecryptSafer($sDetails, @PrivateKey);
		$sValue = substr($sDetails,0,$sLength);	# restore it's size to the original length
		}
	#
	# Parse the index value into a hash.  See CCustomerAddressItem::operator CString for packing details.
	#
   $sValue =~ s/([^ ])$/$1 /;							# if there is no trailing space add one
   $sValue .= 'a';                              # this is used to prevent the split from stripping trailing empty fields
	my @Details = split(/ /, $sValue);
   pop @Details;											# clear the trailing bogus "a"
	my @Labels = qw (ValidAsInvoiceAddress ValidAsDeliveryAddress ExemptTax1 ExemptTax2 CountryCode StateCode Name
						  Line1 Line2 Line3 Line4 PostCode Tax1ExemptData Tax2ExemptData Tax1ID Tax2ID nResidential);
#? ACTINIC::ASSERT($#Details == $#Labels, 'Corrupt index ACTINIC::GetCustomerAddress(' . "$#Details != $#Labels).", __LINE__, __FILE__);
	my $nIndex;
	#
	# Load the hash.  Note that Labels and Details are sorted in the same order
	#
	foreach ($nIndex = 0; $nIndex <= $#Details; $nIndex++)
		{
		$ACTINIC::Addresses{$sIdentifier}{$Labels[$nIndex]} = DecodeText($Details[$nIndex], $ACTINIC::FORM_URL_ENCODED);
		}
	#
	# Add the address ID to the hash
	#
	$ACTINIC::Addresses{$sIdentifier}{ID} = $nAddressID;

	return ($::SUCCESS, undef, $ACTINIC::Addresses{$sIdentifier});
	}

################################################################
#
# CloseCustomerAddressIndex - cleanup up the file
#
################################################################

sub CloseCustomerAddressIndex
	{
	if (defined $ACTINIC::rAddressFileHandle)
		{
		CleanupIndex($ACTINIC::rAddressFileHandle);
		undef $ACTINIC::rAddressFileHandle;
		}
	}

################################################################
#
# InitIndex - initialize the specified index file tables
#
# Input:	   0 - the path to the data file
#           1 - a reference to the desired file handle
#           2 - expected file version
#
# Returns:	0 - status
#           1 - error message if any
#
################################################################

sub InitIndex
	{
#? ACTINIC::ASSERT($#_ == 2, 'Incorrect parameter count ACTINIC::InitIndex(' . join(', ', @_) . ").", __LINE__, __FILE__);
	my ($sPath, $rFileHandle, $nExpectedVersion) = @_;
	#
	# Open the index.  Retry a couple of times on failure just incase an update is in progress.
	#
	my ($status, $sError);
	my $nRetryCount = $ACTINIC::MAX_RETRY_COUNT;
	$status = $::SUCCESS;
	while ($nRetryCount--)
		{
		unless (open ($rFileHandle, "<$sPath"))
			{
			$sError = $!;
			sleep $ACTINIC::RETRY_SLEEP_DURATION;	# pause a moment
			$status = $::FAILURE;
			$sError = ACTINIC::GetPhrase(-1, 282, $sPath, $sError);
			next;
			}
		binmode $rFileHandle;
	   #
	   # Check the file version number
	   #
		my $sBuffer;
		unless (read($rFileHandle, $sBuffer, 4) == 4) # read the blob version number (a short)
			{
			$sError = $!;
			close ($rFileHandle);
			return ($::FAILURE, ACTINIC::GetPhrase(-1, 283, $sPath, $sError));
			}

		my ($nVersion) = unpack("n", $sBuffer);	# convert to a number
		if ($nVersion != $nExpectedVersion)
			{
			close($rFileHandle);
			sleep $ACTINIC::RETRY_SLEEP_DURATION;	# pause a moment
			$status = $::FAILURE;
			$sError = ACTINIC::GetPhrase(-1, 284, $sPath, $nExpectedVersion, $nVersion);
			next;
			}

		last;
		}

	return($status, $sError);
	}

################################################################
#
# CleanupIndex - do the cleanup work
#
# Input:	   0 - reference to the index file handle
#
################################################################

sub CleanupIndex
	{
	close ($_[0]);
	}

###############################################################
#
# IndexSearch - search an index for the key.  The result of
#   this recursive function is the index value.  This function
#   assumes that each key has exactly one value.  It can
#   be used for product and account indices.  Search indices
#   where multiple results are possible should use another
#   form of this function.
#
# Input:	   0 - search key (or remaining fragment on
#               recursive call)
#           1 - point to start in the file
#           2 - file handle
#           3 - file path (for identification in errors)
#				4 - exact match required? (optional, default - $::FALSE)
#
# Returns:  0 - status
#           1 - error message
#           2 - value
#
###############################################################

sub IndexSearch
	{
#? ACTINIC::ASSERT(($#_ == 3 || $#_ == 4), 'Incorrect parameter count IndexSearch(' . join(', ', @_) . ").", __LINE__, __FILE__);
	my ($sKey, $nLocation, $rFile, $sFileName, $bExactMatch) = @_;
	#
	# Default exact match flat to false
	#
	if ($#_ < 4)
		{
		$bExactMatch = $::FALSE;
		}

	my ($nDependencies, $nCount, $nRefs, $sRefs, $sBuff, $sFragment, $sValue);
	my ($nIndex, $sSeek, $nHere, $nLength, $sNext, $nRead);
	#
   # At the start of the file, we have an (empty) value list
   # followed by a list of dependency records
	#
	unless (seek($rFile, $nLocation, 0))			# Seek to node
		{
		return ($::FAILURE, ACTINIC::GetPhrase(-1, 285, $sFileName, $!));
		}
	#
   # Read the value (if any).
	#
	unless (read($rFile, $sBuff, 2) == 2)			# Read the count
		{
		return ($::FAILURE, ACTINIC::GetPhrase(-1, 285, $sFileName, $!));
		}

	($nCount) = unpack("n", $sBuff);					# Turn into an integer

	for ($nIndex = 0; $nIndex < $nCount; $nIndex++)
		{
		unless (read($rFile, $sBuff, 2) == 2)		# Get value length
			{
			return ($::FAILURE, ACTINIC::GetPhrase(-1, 285, $sFileName, $!));
			}

		($nLength) = unpack("n", $sBuff);			# unpack the value length

		unless (read ($rFile, $sValue, $nLength) == $nLength) # read the value
			{
			return ($::FAILURE, ACTINIC::GetPhrase(-1, 285, $sFileName, $!));
			}

		unless (read($rFile, $sBuff, 1) == 1)		# read the reference count
			{
			return ($::FAILURE, ACTINIC::GetPhrase(-1, 285, $sFileName, $!));
			}
		($nRefs) = unpack("C", $sBuff);				# Unpack it

		$sRefs = "";										# Kill left-over references
		if ($nRefs > 0)
			{
			unless (read($rFile, $sRefs, $nRefs) == $nRefs)	# Read and ignore the actual refs
				{
				return ($::FAILURE, ACTINIC::GetPhrase(-1, 285, $sFileName, $!));
				}
			}

		if ($sKey eq "")					# If this is an exact match
			{
#? ACTINIC::ASSERT(1 == $nCount, "Index match not unique.", __LINE__, __FILE__);
			return ($::SUCCESS, undef, $sValue);
			}
		}
	#
   # Now search the dependencies
   #
	unless (read($rFile, $sBuff, 2) == 2)			# Read count
		{
		return ($::FAILURE, ACTINIC::GetPhrase(-1, 285, $sFileName, $!));
		}
	$nDependencies = unpack("n", $sBuff);			# Count of dependencies (network short)

	for ($nIndex = 0; $nIndex < $nDependencies; $nIndex++)
		{
		unless (read($rFile, $sBuff, 1) == 1)		# Read fragment length
			{
			return ($::FAILURE, ACTINIC::GetPhrase(-1, 285, $sFileName, $!));
			}
		$nLength = unpack("C", $sBuff);				# Unpack it

		unless (read($rFile, $sFragment, $nLength) == $nLength) # Read the string fragment
			{
			return ($::FAILURE, ACTINIC::GetPhrase(-1, 285, $sFileName, $!));
			}
		unless (read($rFile, $sSeek, 4) == 4)		# Read the link (convert later, if we need it)
			{
			return ($::FAILURE, ACTINIC::GetPhrase(-1, 285, $sFileName, $!));
			}
		#
		# We only care about the fragment length as far as
		# the length of the word we're looking for
		# But only if not exact match is required
		#
		if (!$bExactMatch)
			{
			$sFragment = substr($sFragment, 0, length($sKey)); # Reduce fragment to useful length
			}
		#
		# Allow special regex characters in $sFragment
		#
		my $sQuotedFragment = quotemeta($sFragment);
		#
		# If the fragment partially matches our word then we
		# continue down the tree. It only needs to match as much
		# of the word as we have - it's perfectly possible for
		# the fragment to be longer than the word
		#
		if ($sKey =~ m/^$sQuotedFragment/) # Does it match?
			{
			$sNext = $';									# Get part after match
			$nHere = tell($rFile);						# Save where we are

			my ($status, $sError, $sValue) = IndexSearch($sNext, unpack("N", $sSeek), $rFile, $sFileName, $bExactMatch); # Look down tree
			if ($status == $::FAILURE ||				# if the lookup errored or
				 $status == $::SUCCESS)					# if it was completed,
				{
				return ($status, $sError, $sValue);	# return the state
				}
			#
			# If we are here, $::NOTFOUND was returned, try the next one
			#
			unless (seek($rFile, $nHere, 0))			# Back to where we were
				{
				return ($::FAILURE, ACTINIC::GetPhrase(-1, 285, $sFileName, $!));
				}
			}

		if ($sFragment gt $sKey)						# If we've passed the point in the list
			{
			last;												# Don't look further
			}
		}

	return ($::NOTFOUND, 'Item not found in index');
	}

###############################################################
#
# ProductSearch - search an index for a product.  The result of
#   this recursive function is a hash containing the product
#   definition.
#
# Input:	   0 - product reference (or remaining fragment on
#               recursive call)
#           1 - file handle
#           2 - file name
# Output:   3 - reference to product hash table
#
# Returns:  0 - status
#           1 - error message
#
###############################################################

sub ProductSearch
	{
#? ACTINIC::ASSERT($#_ == 3, "Incorrect parameter count ProductSearch(" . join(', ', @_) . ").", __LINE__, __FILE__);
	my ($sProductReference, $rFile, $sFilename, $rhashProduct) = @_;

	undef %$rhashProduct;								# clear the existing product hash

	my ($Status, $sMessage, $sValue) = ACTINIC::IndexSearch($sProductReference, 2, $rFile, $sFilename, $::TRUE);
	if ($Status != $::SUCCESS)
		{
		if ($Status == $::NOTFOUND)					# if not found
			{													# use context specific message
			$sMessage = ACTINIC::GetPhrase(-1, 2267);
			}
		return ($Status, $sMessage);
		}
	#
	# Now parse the product definition string.  The string is in the following format:
	#
	# CUR DIGITS PRICE ANCHOR NAME_LENGTH NAME DESCRIPTION_LENGTH DESCRIPTION SECTION_NAME_LENGTH SECTION_NAME
	# PROPERTY1_LENGTH PROPERTY1 PROPERTY2_LENGTH PROPERTY2 ... PROPERTYN_LENGTH PROPERTYN
	#
	# CUR                - 3 character ISO currency code or equivalent
	# DIGITS             - number of digits in the fractional part of the price
	# PRICE              - product unit price in Actinic internal format
	# ANCHOR             - HTML anchor of product.  Anchor includes filename.
	# NAME_LENGTH        - product name length
	# NAME               - product name (may contain spaces)
	# DESCRIPTION_LENGTH - product description length
	# DESCRIPTION        - product description (may contain spaces)
	# SID						- the section ID
	# SECTION_LENGTH     - section name length
	# SECTION            - section name (may contain spaces)
	# PRODUCT_IMAGE_LENGTH	- the length of the product image
	# PRODUCT_IMAGE		- the product image
	# PROPERTY_LENGTH    - property length
	# PROPERTY           - property packed as <property name><property type>!<value>
	#
	unless ($sValue =~ /^(\S+) (\d+) (\d+) (\S+) (\d+) (.+)/s)
		{
		return ($::FAILURE, ACTINIC::GetPhrase(-1, 255, $sValue));
		}
	$$rhashProduct{CURRENCY} = $1;					# record the currency
	$$rhashProduct{DECIMALS} = $2;					# record the currency decimal count
	$$rhashProduct{PRICE}    = $3;					# record the price
	$$rhashProduct{ANCHOR}   = $4;					# record the HTML anchor

	my $nLength = $5;										# get the name length
	my $sBuffer = $6;										# the remainder of the string
	#
	# Now extract the name
	#
	$$rhashProduct{NAME} = substr($sBuffer, 0, $nLength);

	substr($sBuffer, 0, $nLength + 1) = '';		# strip the used part
	#
	# Now extract the description
	#
	unless ($sBuffer =~ /^(\d+) (.+)/s)
		{
		return ($::FAILURE, ACTINIC::GetPhrase(-1, 255, $sValue));
		}
	$nLength = $1;
	$sBuffer = $2;
	$$rhashProduct{DESCRIPTION} = substr($sBuffer, 0, $nLength);
	substr($sBuffer, 0, $nLength + 1) = '';		# strip the used part
	#
	# Now extract the section ID
	#
	unless ($sBuffer =~ /^(\d+) (.+)/s)
		{
		return ($::FAILURE, ACTINIC::GetPhrase(-1, 255, $sValue));
		}
	$$rhashProduct{SID} = $1;
	$sBuffer = $2;
	#
	# Now extract the section name
	#
	unless ($sBuffer =~ /^(\d+) (.+)/s)
		{
		return ($::FAILURE, ACTINIC::GetPhrase(-1, 255, $sValue));
		}
	$nLength = $1;
	$sBuffer = $2;
	$$rhashProduct{SECTION} = substr($sBuffer, 0, $nLength);

	substr($sBuffer, 0, $nLength + 1) = '';		# strip the used part
	#
	# Now extract the product image
	#
	unless ($sBuffer =~ /^(\d+) (.*)/s)
		{
		return ($::FAILURE, ACTINIC::GetPhrase(-1, 255, $sValue));
		}
	$nLength = $1;
	$sBuffer = $2;
	$$rhashProduct{IMAGE} = substr($sBuffer, 0, $nLength);

	substr($sBuffer, 0, $nLength + 1) = '';		# strip the used part
	#
	# The rest is property information
	#
	my $rhashProperties = {};							# allocate a buffer for the hash properties
	my $sProperty;
	until ($sBuffer !~ /^(\d+) (.+)/s)				# while properties still exist
		{
		$nLength = $1;
		$sBuffer = $2;
		$sProperty = substr($sBuffer, 0, $nLength); # get the next property from the list
		unless ($sProperty =~ /([^!]+)!(.*)/)		# parse the property
			{
			return ($::FAILURE, ACTINIC::GetPhrase(-1, 255, $sValue));
			}
		$$rhashProperties{$1} .= $2 . "!";			# <name><type> = <value1>!<value2>!...<valueN>!

		substr($sBuffer, 0, $nLength + 1) = '';	# strip the used part
		}

	$$rhashProduct{PROPERTIES} = $rhashProperties; # store the properties as a hash reference in the product hash

	return ($::SUCCESS);
	}

###############################################################
#
# GetCurrentScheduleID
#
#	Returns the schedule ID of the current user
#
# Returns:  0 - status
#				1 - error message
#				2 - schedule ID of the current user
#
# Author: Tibor Vajda
#
###############################################################

sub GetCurrentScheduleID
	{
	#
	# Find the schedule Id of the actual user
	#
	my $nScheduleID;										# current user's schedule id
	my ($Status, $sMessage, $pBuyer, $pAccount);	# helpers
	my $sDigest = $ACTINIC::B2B->Get('UserDigest');	# get the user identifying digest
	if ($sDigest)											# if there is logged in user
		{
		my ($Status, $sMessage, $pBuyer) = ACTINIC::GetBuyer($sDigest, ACTINIC::GetPath()); # look up the buyer
		if ($Status != $::SUCCESS)						# we found the buyer info associated to this user
			{
			return ($Status, $sMessage);
			}
		($Status, $sMessage, $pAccount) = ACTINIC::GetCustomerAccount($pBuyer->{AccountID}, ACTINIC::GetPath()); # find the account information
		if ($Status != $::SUCCESS)
			{
			return ($Status, $sMessage);
			}
		$nScheduleID = $pAccount->{PriceSchedule};
		}
	else														# no logged in user -> retail user
		{
		$nScheduleID = $ActinicOrder::RETAILID;
		}

	return ($::SUCCESS, '', $nScheduleID);
	}

###############################################################
#
# IsProductVisible
#
#	Checks the visibility of the specified product
#	for the current user
#
# Input:	   0 - path
#				1 - product ref
#				2 - (optional) price schedule ID - default:current user's id
#
# Returns:  0 -	true, if the product is visible
#						false, otherwise
#
# Author: Tibor Vajda
#
###############################################################

sub IsProductVisible
	{
	my $sProdRef		= shift;
	my $nScheduleID	= shift;							# optional

	my ($nStatus, $sMessage);
	#
	# ScheduleID is provided as an optional parameter
	# otherwise initialized by the current user's scheduleID
	#
	if (!$nScheduleID)
		{
		($nStatus, $sMessage, $nScheduleID) = GetCurrentScheduleID();	# determine the user's schedule id
		if ($nStatus != $::SUCCESS)
			{
			TerminalError($sMessage);
			}
		}
	#
	# If price schedule is not constrained, then no additional check required
	#
	if (!IsPriceScheduleConstrained($nScheduleID))
		{
		return $::TRUE;
		}
	#
	# Requires search module to be imported
	#
	require <Actinic:Variable Name="SearchPackage"/>;
	#
	# Determine the hash of all products which are visible for
	# this price schedule
	#
	my $sPath = GetSecurePath();
	my $rPriceScheduleHits = {};
	($nStatus, $sMessage) = Search::SearchPriceSchedule($sPath, $nScheduleID, $rPriceScheduleHits);
	if ($nStatus != $::SUCCESS)
		{
		TerminalError($sMessage);
		}
	#
	# return true if the product is visible for the price schedule
	#
	return (exists $rPriceScheduleHits->{$sProdRef});	# product visibility
	}

###############################################################
#
# IsPriceScheduleConstrained
#
#	Determines whether there is any hidden product for
#	the specified schedule ID
#
# Input:		0 - schedule ID
#
# Returns:  0 -	true, if all product is visible for the schedule id
#						false, otherwise
#
# Author: Tibor Vajda
#
###############################################################

sub IsPriceScheduleConstrained
	{
	my $nScheduleID = shift;
   #
   # search setup blob is required
	# load it if not available
   #
	if (!$::g_pSearchSetup)
		{
		my $sPath = GetSecurePath();
		my ($Status, $sError) = ReadSearchSetupFile($sPath);	# read the search setup
		if ($Status != $::SUCCESS)
			{
			ReportError($sError, $sPath);
			}
		}
	#
	# Look for the price schedule definitions
	#
	my $phashPriceScheduleHides = $::g_pSearchSetup->{PRICE_SCH_HIDES}; # helper hash is stored in the search setup blob
	return $phashPriceScheduleHides->{$nScheduleID};
	}

#######################################################
#
# GetPhrase  - Get the specified phrase and format it.
#
# Params:	0 - phase number
#				1 - prompt number
#				2+ - optional list of arguments supplied
#					to complete string formatting
#
# Returns:	0 - prompt string
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# shipping and PSP plug ins!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub GetPhrase
	{
#? ACTINIC::ASSERT($#_ >= 1, "Invalid argument count in GetPhrase ($#_)", __LINE__, __FILE__);

	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#

	no strict 'refs';										# this class routine symbolic references
	my ($nPhase, $nPrompt, @args);
	if ($#_ < 1)											# incorrect number of arguments
		{
		$nPhase = -1;										# return parameters not set
		$nPrompt = 12;
		@args = ('GetPhrase');
		}
	else
		{
		($nPhase, $nPrompt, @args) = @_;
		}

	my ($sPhrase);
	if (defined $::g_pPromptList)						# if the phrase list is defined and
		{
		$sPhrase = $$::g_pPromptList{"$nPhase,$nPrompt"}{PROMPT};
		}
	elsif (defined $::g_InputHash{"PHRASE$nPhase,$nPrompt"}) # the phrases are in hidden parameters
		{
		$sPhrase = $::g_InputHash{"PHRASE$nPhase,$nPrompt"};
		}
	else
		{
		return ("Phrases not read yet ($nPhase,$nPrompt) {" . join(', ', @args) . "}.");			# report so
		}
	#
	# process any substitution
	#
	if (defined $sPhrase &&								# if the phrase was found and
		 $#args > -1)										# there are values to substitute
		{
		$sPhrase = sprintf($sPhrase, @args);		# perform the substitution
		}

	if (defined $sPhrase)								# if the phrase was defined
		{
		return ($sPhrase); 								# return the phrase
		}

	return ("Phrase not found ($nPhase,$nPrompt) {" . join(', ', @args) . "}!!");
	}

#######################################################
#
# GetRequireMessage - retrieve the "this field is required"
#	message for the specified phase and prompt
#
# Params:	0 - phase number
#				1 - prompt number
#
# Returns:	0 - message
#
#######################################################

sub GetRequiredMessage
	{
#? ACTINIC::ASSERT($#_ == 1, "Invalid argument count in GetRequireMessage ($#_)", __LINE__, __FILE__);
	return
			(
			GetPhrase(-1, 55, "\"<B>" .  ACTINIC::GetPhrase(-1, 1971,  $::g_sRequiredColor) .
			GetPhrase($_[0], $_[1]) . ACTINIC::GetPhrase(-1, 1970) . "</B>\"") . "<BR>\n"
			);
	}

#######################################################
#
# GetLengthFailureMessage - retrieve the "this field is too long"
#	message for the specified phase and prompt
#
# Params:	0 - phase number
#				1 - prompt number
#
# Returns:	0 - message
#
#######################################################

sub GetLengthFailureMessage
	{
#? ACTINIC::ASSERT($#_ == 2, "Invalid argument count in GetLengthFailureMessage ($#_)", __LINE__, __FILE__);
	return
			(
			GetPhrase(-1, 2299, "\"<B>" .  ACTINIC::GetPhrase(-1, 1971,  $::g_sRequiredColor) .
			GetPhrase($_[0], $_[1]) . ACTINIC::GetPhrase(-1, 1970) . "</B>\"", $_[2]) . "<BR>\n"
			);
	}

#######################################################
#
# IsPromptRequired - is the specified prompt required.
#	For simplicity, all errors return $::FALSE.
#
# Params:	0 - phase number
#				1 - prompt number
#
# Returns:	0 - $::TRUE if required
#
#######################################################

sub IsPromptRequired
	{
#? ACTINIC::ASSERT($#_ == 1, "Invalid argument count in IsPromptRequired ($#_)", __LINE__, __FILE__);

	no strict 'refs';										# this class routine symbolic references
	if ($#_ != 1)											# incorrect number of arguments
		{
		return ($::FALSE);
		}

	my ($nPhase, $nPrompt) = @_;
	#
	# locate the prompt and return its status
	#
	return ($$::g_pPromptList{"$nPhase,$nPrompt"}{STATUS} == $::REQUIRED ? $::TRUE : $::FALSE); # return it's required status
	}

#######################################################
#
# IsPromptHidden - is the specified prompt hidden.
#	For simplicity, all errors return $::FALSE.
#
# Params:	0 - phase number
#				1 - prompt number
#
# Returns:	0 - $::TRUE if hidden
#
#######################################################

sub IsPromptHidden
	{
#? ACTINIC::ASSERT($#_ == 1, "Invalid argument count in IsPromptHidden ($#_)", __LINE__, __FILE__);
	no strict 'refs';										# this class routine symbolic references
	if ($#_ != 1)											# incorrect number of arguments
		{
		return ($::FALSE);
		}

	my ($nPhase, $nPrompt) = @_;
	#
	# locate the prompt and return its status
	#
	return ($$::g_pPromptList{"$nPhase,$nPrompt"}{STATUS} == $::HIDDEN ? $::TRUE : $::FALSE); # return it's hidden status
	}

#######################################################
# ChangeAccess
#     Change the access permissions using the various
#     platform specific calls.
#
# Params:	0 - the new mode of the file.  supported
#					modes are '' - no permissions,
#					"r" - read only, "rw" - read/write
#         	1 - the file to modify
#
# Returns:	number of files changed
#
#######################################################

sub ChangeAccess
	{
# No assert here because ASSERT calls TRACE which calls ChangeAccess - recursion loop
	#
	# !!!!!! This is a function commonly used by many utilities.  Any changes to its interface will
	# !!!!!! need to be verified with the various utility scripts.
	#
	my $OldMask = umask(0);								# give full access
	my ($mode, $file, $nCount);
	($mode, $file) = @_;

	SecurePath($file);									# make sure only valid filename characters exist in $file to prevent hanky panky
	if ($mode eq '')										# no permissions
		{
		$nCount = chmod 0200, $file;					# process chmod on unix
		}
	elsif ($mode eq "rw")
		{
		$nCount = chmod 0666, $file;					# process chmod on unix
		}
	elsif ($mode eq "r")
		{
		$nCount = chmod 0644, $file;					# process chmod on unix
		}
	umask($OldMask);
	return ($nCount);
	}

#######################################################
#
# CleanFileName - Clean iffy characters from file name
#	only letters, digits, '.','_','-' allowed
#	each is changed into '_'
#
#	CAUTION: '/' is not allowed!
#
# Params:	file name
# Returns:	modified name
#
# (rz)
#######################################################

sub CleanFileName
	{
	my $nam = shift;
	$nam =~ tr/a-zA-Z0-9\.\_\-/_/c;
	return $nam;
	}

#######################################################
#
# SecurePath2 - Return an error if the specified path contains
#	any shell characters
#
# Input:	   0 - path
#
# Returns:  0 - error or undef
#
#######################################################

sub SecurePath2
	{
	my ($sPath) = $_[0];
	if ($^O =~ /win/i)									# NT
		{
		if ($sPath =~ m|[!&<>\|*?()^;\${}\[\]\`\'\"\n\r]| ||		# the secure path characters (allow backslashes)
			 $sPath =~ m|\0|)
			{
			return("\"$sPath\" contains invalid characters.");
			}
		}
	else
		{
		if ($sPath =~ m|[!&<>\|*?()^;\${}\[\]\`\'\"\\~\n\r]| ||		# the secure path characters (no backslashes)
			 $sPath =~ m|\0|)
			{
			return("\"$sPath\" contains invalid characters.");
			}
		}
	return (undef);
	}

#######################################################
#
# SecurePath - Error out if the specified path contains
#	any shell characters
#
# Params:	0 - path
#
#######################################################

sub SecurePath
	{
	my $sError = SecurePath2(@_);
	if ($sError)
		{
		TerminalError($sError);
		}
	}

#######################################################
#
# CheckForShellCharacters - this is not as safe as
#  only tolerating specific characters, but for this
#  release, this is all we have time for.
#
# Input:	   0 - value to check
#
# Returns:  0 - error message if any, undef if OK
#
#######################################################

sub CheckForShellCharacters
	{
	my ($sValue) = $_[0];
	if ($sValue =~ m|[!&<>\|*?()^;\${}\[\]\`\'\"\\~\n\r]| ||		# the secure path characters (no backslashes)
		 $sValue =~ m|\0|)
		{
		return ("\"$sValue\" contains invalid characters.");
		}
	return (undef);
	}

#######################################################
#
# GetPath - retrieve the path to the catalog directory
#
# Returns:  0 - path
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################
#
# Any modification of this function's interface or
# basic functionality have to be reflected in the
# shipping and PSP plug ins!!!
# 20 Feb 2002 gmenyhert
#
#######################################################
#   WARNING WARNING WARNING WARNING WARNING WARNING
#######################################################

sub GetPath
	{
	return ($ACTINIC::s_sPath);
	}

#######################################################
#
# GetSecurePath
#
# retrieves the path to the catalog directory
# but checks it before
#
# Returns: 0 - path
#
#######################################################

sub GetSecurePath
	{
	my $sPath = GetPath();								# retrieve the path
	SecurePath($sPath);									# make sure there is nothing funny going on
	if (!$sPath)											# if the path is empty or undefined
		{
		TerminalError("Path not found.");
		}
	if (!-e $sPath ||										# the path does not exist or
		 !-d $sPath)										# the path is not a directory
		{
		TerminalError("Invalid path.");
		}
	return $sPath;
	}

#######################################################
#
# AuthenticateUser - verify the username and password
#  Exits on error.
#
# Input:	   0 - user
#				1 - password
#
# Returns:  0 - status
#           1 - message
#
#######################################################

sub AuthenticateUser
	{
	my ($sUsername, $sPassword) = @_;
	my ($sCorrectUsername, $sCorrectPassword) = ('<Actinic:Variable Name="UserName"/>', '<Actinic:Variable Name="Password"/>');
	#
	# The username and password must be defined.
	#
	if (!$sUsername ||
		 !$sPassword)
		{
		sleep $ACTINIC::DOS_SLEEP_DURATION;			# Discourage DOS attacks
		return ($::FAILURE, ACTINIC::GetPhrase(-1, 2033));
		}
	#
	# Try to load MD5
	#
 	eval
		{
		require Digest::MD5;								# Try loading MD5
		import Digest::MD5 'md5_hex';
		};
	if ($@)
		{
		require <Actinic:Variable Name="DigestPerlMD5"/>;
		import Digest::Perl::MD5 'md5_hex';			# Use Perl version if not found
		}
	#
	# Verify the account
	#
	if (!<Actinic:Variable Name="ActinicHostMode"/>)				# stand alone mode
		{
		if ($sCorrectUsername ne md5_hex($sUsername) ||		# either the username or password does not match
			 $sCorrectPassword ne md5_hex($sPassword))
			{
			sleep $ACTINIC::DOS_SLEEP_DURATION;		# Discourage DOS attacks
			return ($::FAILURE, ACTINIC::GetPhrase(-1, 2034));
			}
		}
	else														# Actinic Host mode
		{
		#
		# Load the module for access to the configuration files
		#
		eval 'require AHDClient;';
		if ($@)												# the interface module does not exist
			{
			return ($::FAILURE, ACTINIC::GetPhrase(-1, 2033) . '  ' . $@);
			}
		my ($nStatus, $sError, $pClient);
		($nStatus, $sError, $pClient) = new_readonly AHDClient('<Actinic:Variable Name="PathFromCGIToWeb"/>');
		if ($nStatus!= $::SUCCESS)
			{
			return($nStatus, $sError);
			}
		#
		# Retrieve the appropriate record
		#
		($nStatus, $sError, my $pShop)= $pClient->GetShopDetailsFromUsernameAndPassword($sUsername, $sPassword);
		if (!defined($pShop))							# shop not found by user credentials
			{
			sleep $ACTINIC::DOS_SLEEP_DURATION;		# Discourage DOS attacks
			return ($::BADDATA, $sError);
			}
		elsif ($nStatus != $::SUCCESS)				# some other error has occured
			{
			return ($nStatus, $sError);
			}
		}

	return ($::SUCCESS, undef);
	}


##############################################################################################################
#
# File Read Calls - End
#
##############################################################################################################

##############################################################################################################
#
# Blob Write Library - Begin
#
##############################################################################################################

#######################################################
#
# OpenWriteBlob - open the blob for write access
#	If the specified filename is empty, use STDOUT.
#	Note that STDOUT mode buffers the message and
#  writes on Close using HTTP header
#
# Params:	0 - filename - if filename == '',
#					then use standard out
#
# Returns:	0 - status
#				1 - error message
#
# Affects:	WBFILE - file handle
#				$s_WBBuffer - file buffer
#				$ACTINIC::s_WBStyle - the blob style
#					= $ACTINIC::FILE - file
#					= $ACTINIC::STDOUT - STDOUT
#					= $ACTINIC::MEMORY - memory
#
#######################################################

sub OpenWriteBlob
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in OpenWriteBlob ($#_)", __LINE__, __FILE__);

	my ($sFilename) = @_;

	if (length $sFilename > 0 &&						# if we are writting to a file, open it
		 $sFilename ne "memory")
		{
#? 	ACTINIC::ASSERT(undef, "This path is potentially not secure - can we remove it?", __LINE__, __FILE__);
		SecurePath($sFilename);							# make sure only valid filename characters exist in $file to prevent hanky panky
		unless (open (WBFILE, ">$sFilename"))		# open the file
			{
			return ($::FAILURE, "Unable to open $sFilename for writing: $!\n", 0, 0);
			}

		binmode WBFILE;									# make sure the file is written in binary mode

		$ACTINIC::s_WBStyle = $ACTINIC::FILE;								# writing to file
		}
	elsif ($sFilename eq "memory")
		{
		$ACTINIC::s_WBBuffer = '';									# clear the buffer
		$ACTINIC::s_WBStyle = $ACTINIC::MEMORY;							# writing to memory
		}

	return ($::SUCCESS, '', 0, 0);
	}

#######################################################
#
# WriteBlob - write the blob
#
# Params:	0 - \@FieldList - reference to an array
#					of field values to store
#				1 - \@FieldType - ref to an array of field
#					types (in the same order as FieldList
# Returns:	0 - status
#				1 - error message
#
# Expects:	WBFILE - file handle
#
#######################################################

sub WriteBlob
	{
#? ACTINIC::ASSERT($#_ == 1, "Invalid argument count in WriteBlob ($#_)", __LINE__, __FILE__);

	my ($FieldList, $FieldType) = @_;

	my ($Field, $Type, @Response, $i, $nTotal);
	for($i = 0; $i <= $#{$FieldList}; $i++)		# loop over the fields in the table
		{
		$Type = $$FieldType[$i];						# the field data type
		$Field = $$FieldList[$i];						# the field value

		if ($Type == $::RBBYTE)							# this field is a byte
			{
			@Response = WriteByte($Field);			# Write the byte
			}
		elsif ($Type == $::RBWORD)						# this field is a Word
			{
			@Response = WriteWord($Field);			# Write the Word
			}
		elsif ($Type == $::RBDWORD)					# this field is a double word
			{
			@Response = WriteDoubleWord($Field);	# Write the double word
			}
		elsif ($Type == $::RBQWORD)					# this field is a Java long (64 bits)
			{
			@Response = WriteQuadWord($Field);		# Write the QuadWord
			}
		elsif ($Type == $::RBSTRING)					# this field is a string
			{
			@Response = WriteString($Field);			# Write the string
			}
		else													# unknown field type
			{
			return ($::FAILURE, "Unknown field type $Type\n", 0, 0); # return error
			}

		my ($Status, $Message, $nLength);
		($Status, $Message, $nLength) = @Response;				# extract the results
		$nTotal += $nLength;
		if ($Status != $::SUCCESS)						# if the Write failed,
			{
			return ($Status, $Message, 0, 0);		# bail
			}
		}

	return ($::SUCCESS, '', 0, 0);
	}

#######################################################
#
# CloseWriteBlob - close the blob
#
# Returns:	0 - status
#				1 - error message
#				2 - file buffer
#
# Expects: 	WBFILE - file handle
#				$ACTINIC::s_WBStyle - flag indicating status of WBFILE
#				$ACTINIC::s_WBBuffer - the databuffer (if $ACTINIC::s_WBStyle != $ACTINIC::FILE)
#
#######################################################

sub CloseWriteBlob
	{
	if ($ACTINIC::s_WBStyle == $ACTINIC::FILE)							# file
		{
		close (WBFILE);
		}
	else														# memory
		{
		return ($::SUCCESS, '', $ACTINIC::s_WBBuffer, 0);
		}

	return ($::SUCCESS, '', 0);
	}

##############################################################################################################
#
# Blob Write Library - End
#
##############################################################################################################

##############################################################################################################
#
# Low Level Write Library - Begin
#
##############################################################################################################

#######################################################
#
# WriteByte - write a byte
#
# Params:	0 - byte to write
#
# Returns:	0 - status
#				1 - error message
#				2 - data length
#
# Expects:	$ACTINIC::s_WBStyle - indicating file status
#				WBFILE - if $ACTINIC::s_WBStyle == $ACTINIC::FILE
#				$ACTINIC::s_WBBuffer - if $ACTINIC::s_WBStyle != $ACTINIC::FILE
#
#######################################################

sub WriteByte
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in WriteByte ($#_)", __LINE__, __FILE__);

	my ($SIZE, $Byte, $Data);
	$SIZE = 1;												# declare some variables
	($Byte) = @_;
	$Data = 0;

	$Data = pack ("C", $Byte);

	if ($ACTINIC::s_WBStyle == $ACTINIC::FILE)							# if we are writing to a file
		{
		unless (print WBFILE $Data)					# write the number
			{
			return ($::FAILURE, "Error writing a byte to the file: $!\n", 0);
			}
		}
	else														# if we are dumping to HTTP
		{
		$ACTINIC::s_WBBuffer .= $Data;							# append the data to the buffer
		}

	return ($::SUCCESS, '', length $Data);
	}

#######################################################
#
# WriteWord - write a Word in network byte order from
#	the the file
#
# Params:	0 - word to write
#
# Returns:	0 - status
#				1 - error message
#				2 - data length
#
# Expects:	$ACTINIC::s_WBStyle - indicating file status
#				WBFILE - if $ACTINIC::s_WBStyle == $ACTINIC::FILE
#				$ACTINIC::s_WBBuffer - if $ACTINIC::s_WBStyle != $ACTINIC::FILE
#
#######################################################

sub WriteWord
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in WriteWord ($#_)", __LINE__, __FILE__);

	my ($SIZE, $Word, $Data);
	$SIZE = 2;												# declare some variables
	($Word) = @_;
	$Data = 0;

	$Data = pack ("n", $Word);

	if ($ACTINIC::s_WBStyle == $ACTINIC::FILE)							# if we are dumping to a file
		{
		unless (print WBFILE $Data)					# write the number
			{
			return ($::FAILURE, "Error writing a word to the file: $!\n", 0);
			}
		}
	else														# we are dumping to HTTP
		{
		$ACTINIC::s_WBBuffer .= $Data;							# append to the data buffer
		}

	return ($::SUCCESS, '', length $Data);
	}

#######################################################
#
# WriteDoubleWord - write a dword in network byte order
#	from the the file
#
# Params:	0 - double word to write
#
# Returns:	0 - status
#				1 - error message
#				2 - data length
#
# Expects:	$ACTINIC::s_WBStyle - indicating file status
#				WBFILE - if $ACTINIC::s_WBStyle == $ACTINIC::FILE
#				$ACTINIC::s_WBBuffer - if $ACTINIC::s_WBStyle != $ACTINIC::FILE
#
#######################################################

sub WriteDoubleWord
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in WriteDoubleWord ($#_)", __LINE__, __FILE__);

	my ($SIZE, $DWord, $Data);
	$SIZE = 4;												# declare some variables
	($DWord) = @_;
	$Data = 0;

	$Data = pack ("N", $DWord);

	if ($ACTINIC::s_WBStyle == $ACTINIC::FILE)							# if we are dumping to a file
		{
		unless (print WBFILE $Data)					# write the number
			{
			return ($::FAILURE, "Error writing a double word to the file: $!\n", 0);
			}
		}
	else														# we are dumping to HTTP
		{
		$ACTINIC::s_WBBuffer .= $Data;							# append to the data buffer
		}

	return ($::SUCCESS, '', length $Data);
	}

#######################################################
#
# WriteQuadWord - write a Java long (64 bits) in network
#	byte order from the the file
#
# Params:	0 - quad word to write
#
# Returns:	0 - status
#				1 - error message
#				2 - data length
#
# Expects:	$ACTINIC::s_WBStyle - indicating file status
#				WBFILE - if $ACTINIC::s_WBStyle == $ACTINIC::FILE
#				$ACTINIC::s_WBBuffer - if $ACTINIC::s_WBStyle != $ACTINIC::FILE
#
#######################################################

sub WriteQuadWord
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in WriteQuadWord ($#_)", __LINE__, __FILE__);

	my ($SIZE, $QuadWord, $Data);
	$SIZE = 8;												# declare some variables
	($QuadWord) = @_;
	$Data = 0;

	my $nPadding = ($QuadWord < 0) ? 255 : 0;		# pad the top 32 bits to sign extend
	my (@Bytes);
	$Bytes[0] = $nPadding;								# 64 bit longs are not really supported
	$Bytes[1] = $nPadding;
	$Bytes[2] = $nPadding;
	$Bytes[3] = $nPadding;
	$Bytes[4] = ($QuadWord & hex("ff000000"))				>> 24;
	$Bytes[5] = ($QuadWord & hex("ff0000"))				>> 16;
	$Bytes[6] = ($QuadWord & hex("ff00"))					>>  8;
	$Bytes[7] = ($QuadWord & hex("ff"));

	$Data = pack ("C8", @Bytes);

	if ($ACTINIC::s_WBStyle == $ACTINIC::FILE)							# if we are dumping to a file
		{
		unless (print WBFILE $Data)					# write the number
			{
			return ($::FAILURE, "Error writing a 8 byte word to the file: $!\n", 0);
			}
		}
	else														# if we are dumping to HTTP
		{
		$ACTINIC::s_WBBuffer .= $Data;							# append to the data buffer
		}

	return ($::SUCCESS, '', length $Data);
	}

#######################################################
#
# WriteString - write a string from the file
#
# Params:	0 - string to write
#
# Returns:	0 - status
#				1 - error message
#				2 - data length
#
# Expects:	$ACTINIC::s_WBStyle - indicating file status
#				WBFILE - if $ACTINIC::s_WBStyle == $ACTINIC::FILE
#				$ACTINIC::s_WBBuffer - if $ACTINIC::s_WBStyle != $ACTINIC::FILE
#
#######################################################

sub WriteString
	{
#? ACTINIC::ASSERT($#_ == 0, "Invalid argument count in WriteString ($#_)", __LINE__, __FILE__);

	my ($String, $Data, $nLength);
	($String) = @_;
	$Data = 0;
	$nLength = length $String;

	my (@Response);
	@Response = WriteWord($nLength);					# write the string length
	if (!$Response[0])
		{
		return (@Response);								# if there was an error, bail
		}

	my ($nByteLength);
	$nByteLength = 2 * $nLength;						# unicode so each char is 2 bytes

	if ($nByteLength > 0)								# if there is any string data
		{
		my ($Pack, @Characters);

		$Pack = "a".($nByteLength / 2);				# pack the string
		$Data = pack ($Pack, $String);

		$Pack = "C".$nByteLength;						# unpack the individual characters
		@Characters = unpack ($Pack, $Data);

		$Pack = "xC" x ($nByteLength / 2);			# create the pack string xCxCxC... that writes the unicode string
		$Data = pack ($Pack, @Characters);			# pack the unicode string

		if ($ACTINIC::s_WBStyle == $ACTINIC::FILE)			# dumping to file
			{
			unless (print WBFILE $Data)				# write the raw string
				{
				return ($::FAILURE, "Error writing a string to the file: $!\n", 0);
				}

			if ($nByteLength > 4096)					# there seems to be a limit on how long of a string we can write
				{
				return ($::FAILURE, "Error writing a string from the file: string is ".
						  "\n\tlonger than 4K - probably bad format or bad version\n", 0);
				}
			}
		else													# dumping to HTTP
			{
			$ACTINIC::s_WBBuffer .= $Data;						# append to the buffer
			}
		}

	return ($::SUCCESS, '', length $Data);
	}

##############################################################################################################
#
# Low Level Write Library - End
#
##############################################################################################################

#######################################################
#
# GetPlugInScript - read and return the Plug-in	script
#
# Params:	$sScriptName - the script name
#
# Returns:	0 - status
#				1 - error message (if any)
#				2 - script
#
#######################################################

sub GetPlugInScript
	{
	my ($sScriptName) = @_;

	my ($sFilename) = ACTINIC::GetPath() . $sScriptName;
	my @Response = ACTINIC::ReadAndVerifyFile($sFilename);
	return (@Response);
	}

############################################################
#  EvalInSafe - Eval script Safely
#  This function attempts to load Safe.pm module.
#  If succesful it will execute supplied script in a Safe
#  container (no system calls are allowed and only specified
#  variables are shared).
#  Otherwise 'force' switch (second argument) is checked.
#  If true - nothing is done and $::FAILURE is returned
#  If false - eval is used to evaluate script.
#
#  Arguments
#    0 - script to eval
#    1 - force switch
#    2 - reference to a list of variables to be shared with
#           the script.
#    (format: ('$foo','$bla') will allow sharing $::foo and $::bla)
#    ($::SUCCESS and $::FAILURE are shared automatically)
#  Returns
#    0 - status
#    1 - error message string
#
#  If eval is executed (either in Safe or using eval) then
#  status and error message are passed from eval.
#  (If error message exists then status is always $::FAILURE)
#  If 'force' flag is on and Safe.pm is not found then status
#  if $::FAILURE.
#  If Safe.pm detects a violation status is $::FAILURE
#
#  Example:
#  If $scr contains following script:
#  $::gtext = "This is my text";
#  $::gtext1 = "This is my text1";
#  return $::SUCCESS;
#
#  then
#  my ($Result, $Msg ) = EvalInSafe($scr,$::FALSE,'$gtext');
#
#  will return $::SUCCESS
#    If Safe.pm exists then $::gtext is set but $::gtext1 is not set
#    If Safe.pm does not exist then both are set
#
#  my ($Result, $Msg ) = EvalInSafe($scr,$::FALSE,'$gtext','$gtext1');
#
#  returns $::SUCCESS and sets $::gtext and $::gtext1
#
#  my ($Result, $Msg ) = EvalInSafe($scr,$::TRUE,'$gtext');
#
#  returns $::SUCCESS and sets $::gtext if Safe.pm exists
#  returns $::FAILURE and sets nothing otherwise
#
#  Ryszard Zybert  Mar 24 18:09:02 GMT 2000
#
#  Copyright (c) Actinic Software Ltd (2000)
############################################################

sub EvalInSafe
	{
	return ::EvalInSafe(@_);
	}

#------------------------------------------- Start of main ---------

package main;

############################################################
#  EvalInSafe
#    See comments in ACTINIC::EvalInSafe
#  This is here only in order to make it global in order to work
#  with Safe.pm version 1 (using share() instead of share_from())
#
#  Ryszard Zybert  Aug 12 10:48:31 BST 2000
#
#  Copyright (c) Actinic Software Ltd (2000)
############################################################

sub EvalInSafe
	{
	my $sScript = shift;			# Script to eval
	my $bForce  = shift;			# If true do it only with Safe
	my $pShare  = shift;			# Reference to a list of shared variables
	my $Result;

	eval 'require Safe';			# Try to load Safe.pm
	if( $@ )							# Cannot find it
		{
		if( $bForce )				# If unsafe eval is forbidden
			{
			return ($::FAILURE, "Cannot load Safe.pm");	# return failure
			}
		$Result = eval($sScript);	# otherwise just use eval
		}
	else								# Safe found
		{
		my $pCnt = new Safe();											# Safe container
		$pCnt->share('$SUCCESS','$FAILURE');						# Always share these two
		$pCnt->share(@$pShare);											# Share variables specified
		$Result = $pCnt->reval($sScript);							# Eval the script
		}
	if( $@ )							# If there is an error message it is a failure
		{
		$Result = $::FAILURE;
		}
	return ($Result,$@);			# done
	}

package ACTINIC;

#------------------------------------------- End of main ---------

#######################################################
#
# TRACE - debug trace function.  Works either with
#	server on port 9876 or a file
#
# Params:	sprintf ready list containing message.
#					a newline is automatically appended
#
#######################################################

#?sub TRACE
#?	{
#? $| = 1;
#?	my $sMessage = sprintf(shift, @_);

#?	while ($ACTINIC::s_bTraceSockFirstPass)
#?		{
#?		$ACTINIC::s_bTraceSockFirstPass = $::FALSE;

#?		my ($remote,$port, $iaddr, $paddr, $proto, $line);

#?		$remote  = 'localhost';
#?		$port    = 9876;
#?		if ($port =~ /\D/)
#?			{
#?			$port = getservbyname($port, 'tcp')
#?			}
#?		if (!$port)
#?			{
#?			last;
#?			}
#?		if (!($iaddr = inet_aton($remote)))
#?			{
#?			last;
#?			}
#?		$paddr   = sockaddr_in($port, $iaddr);

#?		$proto   = getprotobyname('tcp');
#?		no strict 'subs';
#?		if (!socket(DBOUT, PF_INET, SOCK_STREAM, $proto))
#?			{
#?			last;
#?			}
#?		if (!connect(DBOUT, $paddr))
#?			{
#?			last;
#?			}

#?		$ACTINIC::s_bTraceSocket = $::TRUE;

#?		print DBOUT "\n\n";
#?		}

#?	while (!$ACTINIC::s_bTraceSocket &&
#?			  $ACTINIC::s_bTraceFileFirstPass)
#?		{
#?		$ACTINIC::s_bTraceFileFirstPass = $::FALSE;
#?		my $sFilename = GetPath() . 'output.txt';
#?		ChangeAccess('rw', $sFilename);
#?		SecurePath($sFilename);								# make sure only valid filename characters exist in $file to prevent hanky panky
#?		open (DBOUT, ">$sFilename");
#?		}

#?	print DBOUT $sMessage . "\n";
#?	}

#######################################################
#
# ASSERT - debug ASSERT function.
#
# Params:	0 - condition - if false, throw an assertion
#				1 - message associated with the assertion
#				2 - line number where assertion is
#				3 - file containing assertion
#
#######################################################

#?  sub ASSERT
#?  	{
#?  	my ($bTest, $sMessage, $nLine, $sFile) = @_;
#?  	if (!$bTest)
#?  		{
#?  		$ACTINIC::AssertIsActive = $::TRUE;
#?  		my $sText = 'Assertion failed: ' . $sMessage . ' (' . $sFile . ', line: ' . $nLine . ')';

#?  		if ($ACTINIC::AssertIsLooping)
#?  			{
#?  			my $sCallStack;
#?  			$sCallStack = CallStack();
#?  			TRACE($sText . $sCallStack);
#?  			exit;
#?  			}
#?  		$ACTINIC::AssertIsLooping = $::TRUE;

#?  		TRACE($sText);
#?  		my $sCallStack;
#?  		$sCallStack = CallStackHTML();
#?  		TerminalError($sText . $sCallStack);
#?  		}
#?  	}

#######################################################
#
# CallStack - produce a call stack
#
# Returns: string call stack formatted as follows:
#
#	main, line number
#  function, line number
#  next function, line number
#	...
#	current function, line number
#
#######################################################

#?sub CallStack
#?	{
#?	my @call = caller(1);
#?	my $line = $call[2];
#?	my $cnt = 2;

#?	my @stack;

#?	while (defined($call[0]))
#?		{
#?		my $caller = $call[0];
#?		@call = caller($cnt);
#?		$call[3] = $caller if (!defined($call[3]));
#?		unshift(@stack, $call[3] . ", " . $line);
#?		$line = $call[2];
#?		$cnt++;
#?		}
#?	return(join("\r\n", @stack));
#?	}

#######################################################
#
# CallStackHTML - produce a call stack in HTML ready format
#
# Returns: string call stack formatted in HTML as follows:
#
#	Call Stack:
#
#		*main*, line number
#  	*function*, line number
#  	*next function*, line number
#		...
#		*current function*, line number
#
#	The actual stack is indented with block quote and the
#	function names are emboldened.
#
#######################################################

#?sub CallStackHTML
#?	{
#?	my $sCallStack = "<BR><BR>Call Stack:<BLOCKQUOTE><B>" . CallStack() . "</BLOCKQUOTE>";
#?	$sCallStack =~ s/\r\n/<BR>\r\n<B>/g;
#?	$sCallStack =~ s/,/\<\/B\>,/g;
#?	return($sCallStack);
#?	}

#######################################################
#
# Search highlighting function
#
#######################################################

###############################################################
#
# HighlightWords - highlight the specified words in the HTML
#   page using the supplied markup.
#
# Input:	   0 - space separated list of words to highlight
#           1 - highlight start markup
#           2 - highlight end markup
#In/Output: 3 - reference to the HTML to be modified.  The
#               modification is done in place.
#
####### WARNING WARNING WARNING WARNING WARNING ###############
#
# The following code does not follow normal Actinic coding standards.
# This is code for Perl experts at 11AM after a strong pot of coffee!
# It is a special case self-modifying code with run-time generation.
#
# It is strongly recommended that you review pages 72-73 of the Blue
# Camel. This uses "s'PATTERN'CODE_TO_CREATE_REPLACEMENT'gesi" and
# exploits the special properties of a "single quote" as a delimiter.
#
####### WARNING WARNING WARNING WARNING WARNING ###############
#
###############################################################

sub HighlightWords
   {
#? ACTINIC::ASSERT($#_ == 3, "Incorrect parameter count HighlightWords(" . join(', ', @_) . ").", __LINE__, __FILE__);
   my ($sWords, $sStart, $sEnd, $rsHTML) = @_;
   #
   # Now, Highlighting words...
   #
   my @Patterns = ();
   #
   # All strings should be preprocessed to single-space delimiters
   # But split on whitespace in case the processing is imperfect
   #
   my @Words = split /\s+?/,$sWords;
   for (@Words)
      {
      # Match at beginning of words. This should handle single character
      # words without problems - but it won't work for all hyphenated words
      # or those containing an apostrophe because those are not in "\b".
      #
      # But the real problem is that $sWords is not entity-escaped like the
		# HTML and hence: "O'Reilly" ne "O&#39;Reilly". Note those are XML/SGML
      # entities, not older HTML "%xx" ones. Ben is already relying on "$_".
      #
      s/\'/\&#39;/g;          # apostrophe in match pattern: O'Reilly
      s/-/\&#45;/g;				# hyphen in match pattern: Diffie-Hellman
      s/\./\&#46;/g;				# period in match pattern: www.actinic.com
      s/_/ /g;						# convert '_' to space in pattern: Big_A_Auto
      #
      # 31 Jan 2001 - zmagyar:
      # We should handle international charater sets sometimes.
      # If so then chars above xC0h should be encoded as the sepcial
      # characters above.
      # So lets encode this character range:
      # But be careful  here because the lowercases and capitals should be
		# handled here as the /i switch won't do it - zmagyar - 01 Feb 20001
		#
      s/([\xc0-\xff])/sprintf('(&#%d;|&#%d;)', ord($1), ord($1) + (ord($1) < 224 ? 32 : -32))/eg;
      #
      # Conversions we don't want to consider: !&;:$%*
      #
		# > If an integer, avoid highlight breaking an XML character entity
		# > like "&#123;". This is not yet perfect - a ";" following the
		# > integer prevents highlighting it even if not XML. The best fix
		# > requires unrolling the global replace and explicitly checking
		# > if each match is part of an entity. But this should cover most
		# > of the practical cases.
		#
		# > Highlight extends to word boundaries in all cases.
		#
		if ($_ =~ m/^\d+$/)
			{
			#
			# Make sure word boundary is not ";" after Integer
			#
			push @Patterns, "\\b$_\[^;\]*?\\b(?!;)";
			}
		elsif ($_ ne '')
			{
			#
			# The encoded charaters break the word boundaries so new condition
			# should be used instead of \b
			#
	      push @Patterns, '([^\w;]' . $_ . '|^' . $_ . ')[\w\#\&\;]*';

	      # -------------- Original comment and code retained -----------------
			# 31 Jan 2001 - zmagyar:
			#
			# The code below doesn't work with international charsets so it was
			# commented out, but retained.
			#
	      #	push @Patterns, "\\b$_.*?\\b";
	      # -------------- End of retained comment and code  -----------------
	      }
      }
   #
   # The patterns from above, i.e. words beginning with the match string.
   # The regex "\b$_.*?\b" is really more like "\b\w+?" in the case of
   # words for which we have not explicitly fixed the escaped characters.
   #

   #
   # There are a few fragemts such as the page title or javascript
   # code what we do not want to alter. So do some protective code here.
   # zmagyar - 5/13/2003
   #
   my $nFragmentCount = 0;

   $$rsHTML =~ s'\<title\>.+?\<\/title\>|\<script.+?\<\/script\>'
   	#
   	# We try to be clever here and protect the fragments by
   	# replacing then with an XML tag. All fragments are replaced
   	# to an <Actinic:ProtectFragment_x> XML tag ther x is the
   	# index of the fragment. The original fragment is saved to
   	# the B2B object so the protective XML
   	# tag will not be restored here, this task is left with
   	# the XML parser.
   	#
   	# Save the original fragment first
   	#
   	$nFragmentCount++;								# we need unique XML tag names
   	$ACTINIC::B2B->SetXML("ProtectFragment_$nFragmentCount", $&);
   	#
   	# Now replace the fragment to the protective XML tag
   	#
   	"<Actinic:ProtectFragment_$nFragmentCount/>";
   	'gesi;
	#
	# Now everything is prepared so do the highlight itself
	#
   my $sPattern;

   foreach $sPattern (@Patterns)
      {
      $$rsHTML =~ s'\>(.*?)\<'
         #
         # see WARNING above...this is the start of code generation
         # the indentation is correct - single quote is a delimiter like "{"
         #
         # Extract the text between adjacent markup tags into $1.
         # Many end up ($1 eq "") or ($1 =~ /\s/), but Perl should
         # quickly search-mismatch on those anyway via length checking.
         # Since this is a global replace, it will essentially reread
         # the HTML for each pattern - ok for $#Patterns of 1 or 2, if
         # we allow many more than that, the loop should be reconsidered.
         # For highlighting, more than 3 or 4 may be unworkable anyway.
         # But an advanced search with one match out of a much larger
         # group of patterns could occur.
         #
         my $t = $1;
         $t =~ s/($sPattern)/$sStart$1$sEnd/gsi;
         #
         # Re-insert the text, now surrounded by highlight on/off, between
			# the original markup tags with markup delimiters since the original
			# used them to search
         #
         ">$t<";
         #
         # see WARNING above...next line is the finish
      'gesi;                                    # ' # This single quote eliminates formatting problems with emacs
      }
   }

###############################################################
#
# DeterminePricesToShow - Work out which prices to show
#
# Returns:	($bShowRetailPrices, $bShowCustomerPrices, $nAccountSchedule)
#				$::TRUE or $::FALSE for bShowXXX
#				if $bShowCustomerPrices, then $nAccountSchedule contains schedule ID
#
###############################################################

sub DeterminePricesToShow
	{
	#
	# Need to work out which prices to show
	#
	my $nAccountSchedule = -1;
	my $bShowCustomerPrices = $::FALSE;
	my $bShowRetailPrices = $::TRUE;
	#
	# See if this is a customer account
	#
	my $sDigest = $ACTINIC::B2B->Get('UserDigest');
	if($sDigest ne '')
		{
		#
		# Get the buyer
		#
		my ($Status, $Message, $pBuyer) = ACTINIC::GetBuyer($sDigest, ACTINIC::GetPath()); # look up the buyer
		if ($Status == $::SUCCESS)
			{
			#
			# Got the buyer so get the account
			#
			my $pAccount;
			($Status, $Message, $pAccount) = ACTINIC::GetCustomerAccount($$pBuyer{AccountID}, ACTINIC::GetPath());
			if ($Status == $::SUCCESS)
				{
				#
				# Got the account so get the schedule and whether retail prices are shown
				#
				if( $pAccount->{PriceSchedule} != $ActinicOrder::RETAILID ) # If retail  is not default
					{
					$nAccountSchedule = $pAccount->{PriceSchedule};		# save the schedule
					$bShowRetailPrices = !$pBuyer->{HideRetailPrices};	# save whether we show retail prices
					$bShowCustomerPrices = $::TRUE;							# we show customer prices
					}
				}
			}
		}
	return($bShowRetailPrices, $bShowCustomerPrices, $nAccountSchedule);
	}

###############################################################
#
# GetVariantList - Get the variant list and product ref HTML for component
#
# Input:		[0] - the product reference
#
# Returns:	($VariantList, $sLine)
#				$VariantList - reference to a list of variants
#				$sLine	- HTML for product ref
#
###############################################################

sub GetVariantList
	{
	my ($sProductRef) = @_;
	my ($VariantList, $sLine, $k, $i);
	foreach $k (keys %::g_InputHash)
		{
		if( $k =~ /^(vb?_?)\Q$sProductRef\E\_/ )
			{
			my $sVariantSpec = $';
			my $cnt = $sVariantSpec =~ tr/_/_/; 			# Count underscores
			if( $cnt == 0 )										# Nothing - we take VALUE
				{
				$VariantList->[$sVariantSpec] = $::g_InputHash{$k};
				$sLine .= "<INPUT TYPE=HIDDEN NAME=\"v_$sProductRef" . "_" . "$sVariantSpec\" VALUE=\"$::g_InputHash{$k}\">";
				}
			elsif( $cnt == 1 )									# Just one - a simple case
				{
				my ($sAttribute,$sValue) = split('_',$sVariantSpec);
				$VariantList->[$sAttribute] = $sValue;
				$sLine .= "<INPUT TYPE=HIDDEN NAME=\"v_$sProductRef" . "_" . "$sAttribute\" VALUE=\"$sValue\">";
				}
			else														# More than one - several attributes in one widget
				{
				my @sVarSpecItems = split('_',$sVariantSpec);
				for( $i=0; $i<=$#sVarSpecItems; $i+=2)
					{
					$VariantList->[$sVarSpecItems[$i]] = $sVarSpecItems[$i+1];
					$sLine .= "<INPUT TYPE=HIDDEN NAME=\"v_$sProductRef" . "_" . "$sVarSpecItems[$i]\" VALUE=\"$sVarSpecItems[$i+1]\">";
					}
				}
			}
		}
	return($VariantList, $sLine);
	}

#######################################################
#
# Customer accounts common functions
#
#######################################################

#######################################################
#
# CaccGetCookies - get busines  cookies
#
# Returns  0 - account cookie value
#          1 - base file cookie value
#
# Other fields are stored in the B2B object with B2B->Set()
#######################################################

sub CaccGetCookies
	{
	my ($sCookie, $sCookies);

	my $sReferer = ACTINIC::GetReferrer();
	$sReferer =~ s/\?.*//;							# We need here just the file name information

	if( $::g_InputHash{USER} and $::g_InputHash{HASH} and !$::g_InputHash{ORDERHASH})	# LOGIN page - emulate cookies
		{
		return ($ACTINIC::B2B->Get('UserIDCookie'),$ACTINIC::B2B->Get('BaseFile'));
		}
	#
	# When the referrer is a static page the it shouldn't be business so clear
	# the business cookie and return.
	# However bounce page can provide '/' as referrer even in Business which
	# is interpreted a static page an the business session is accidentaly closed.
	# It means that we should detect the failed referrer determination and leave
	# the cookie as it is.
	#
	if( ACTINIC::IsStaticPage($sReferer) && 		# If this came from another static page - this is not B2B
		 $sReferer != "/")								# but check the for failed referrer befor clear the cookie
		{
		$ACTINIC::B2B->Clear('BaseFile');
		$ACTINIC::B2B->Clear('UserIDCookie');
		$ACTINIC::B2B->Clear('UserName');
		$ACTINIC::B2B->Set('ClearIDCookie','CLEAR');	# Clear User Cookie next time
		$ACTINIC::B2B->Set('ClearUserCookie','CLEAR');	# Clear User Name Cookie next time
		return ('','');
		}
	$sCookies = $::ENV{'HTTP_COOKIE'};				# try to retrieve the cookie
	my (@CookieList) = split(/;/, $sCookies);		# separate the various cookie variables in the list
	my ($sDigest,$sBaseFile);

	foreach $sCookie (@CookieList)
		{
		$sCookie =~ s/^\s*//;										# strip leading white space
		if( $sCookie =~ /^ACTINIC_BUSINESS/ )					# found the account cookie
			{
			my ($sLabel, $sCookieValue) = split (/=/, $sCookie);		# retrieve the value
			#
			# strip any trailing or leading quotes and spaces
			#
			$sCookieValue =~ s/^\s*\"?//;
			$sCookieValue =~ s/\"?\s*$//;
			my $sCookieText = ACTINIC::DecodeText($sCookieValue, $ACTINIC::FORM_URL_ENCODED);
			#
			# There is one field per line: name TAB value
			#
			my (@Fields) = split("\n",$sCookieText);			# Get all fields
			my $sField;
			foreach $sField (@Fields)								# Extract name and value from each field
				{
				my ($sName,$sData) = split("\t",$sField);		# Split into name and value
				#
				# strip any trailing or leading quotes and spaces
				#
				$sData =~ s/^\s*\"?//;
				$sData =~ s/\"?\s*$//;
				if( $sData eq "" )
					{
					next;
					}
				for ($sName)
					{
					/^ACCOUNT/ and do									# found the account cookie
						{
						$sDigest = $sData;
						last;
						};
					/^BASEFILE/ and do								# found the base file
						{
						$sBaseFile = $sData;
						last;
						};
					/^USERNAME/ and do								# found user name
						{
						$ACTINIC::B2B->Set('UserName',$sData);
						last;
						};
					/^PRODUCTPAGE/ and do							# found the last page shown
						{
						$ACTINIC::B2B->Set('ProductPage',$sData);
						last;
						};
					/^CHALLENGE/ and do							# found the last page shown
						{
						$ACTINIC::B2B->Set('UserKey',$sData);
						last;
						};
					last;
					}
				}
			last;															# Found what we were looking for
			}
		}
	if( !$sDigest )											 		# If there is no Digest clear all other user variables
		{
		$ACTINIC::B2B->Clear('UserIDCookie');
		$ACTINIC::B2B->Clear('UserName');
		$ACTINIC::B2B->Clear('UserDigest');
		$ACTINIC::B2B->Clear('ProductPage');
		return ('',$sBaseFile);
		}
	return ($sDigest,$sBaseFile);
	}

#######################################################
#
# IsPartOfFrameset - $::TRUE if current page is a frame
# in a Catalog frameset, $::FALSE otherwise.
#
# No arguments
#
#######################################################

sub IsPartOfFrameset
	{
	my $sOrderScript = sprintf("os%6.6d%s",$$::g_pSetupBlob{CGI_ID},$$::g_pSetupBlob{CGI_EXT});

	if( ($::g_InputHash{USER} and $::g_InputHash{HASH}) or          # This is the login page
		 (!IsCatalogFramed() && !$$::g_pSetupBlob{CLEAR_ALL_FRAMES}) or# There are no frames
		 ($::prog_name =~ /^ORDERSCR/ and			# orderscript is running
		 $$::g_pSetupBlob{UNFRAMED_CHECKOUT} ) )                     # and checkout is unframed
		{
		return $::FALSE;                                             # No frame handlin
		}
	return $::TRUE;                                                 # Frames have to be handled
	}

############################################################
#  CAccBusinessCookie - create Business cookie
#  Uses data stored in B2B object to construct business cookie.
#  Returns encoded cookie value ready for transmission.
#
#  Ryszard Zybert  Aug 31 12:39:42 BST 2000
#
#  Copyright (c) Actinic Software Ltd (2000)
############################################################

sub CAccBusinessCookie
	{
	my $sCookie = "";
	$sCookie .= "BASEFILE\t" . $ACTINIC::B2B->Get('BaseFile') .	"\n";							# Basefile
	if ( $ACTINIC::B2B->Get('ClearIDCookie') )							# Request to clear
		{
		return (ACTINIC::EncodeText2($sCookie,0));
		}
	my $sDigest = $ACTINIC::B2B->Get('UserDigest');						# User Digest
	if ( $sDigest )
		{
		if ( $sDigest eq "." )													# '.' is like '' but is TRUE
			{
			$sDigest = "";
			}
		if( $sDigest eq "" )
			{
			return (ACTINIC::EncodeText2($sCookie,0));
			}
		$sCookie .= "ACCOUNT\t$sDigest\n";									# Store Digest
		}
	else
		{
		return ("-");	  															# No user - don't bother with cookies
		}
	if ( $ACTINIC::B2B->Get('ClearUserCookie') )
		{
		$sCookie .= "USERNAME\t\n";									 		# Clear username  cookie
		}
	else
		{
		$sCookie .= "USERNAME\t" . $ACTINIC::B2B->Get('UserName') . "\n";						# User name
		}
	$sCookie .= "PRODUCTPAGE\t" . $ACTINIC::B2B->Get('ProductPage') .	"\n";					# Productpage
	$sCookie .= "CHALLENGE\t" . $ACTINIC::B2B->Get('UserKey') . "\n";							# Challenge
	return (ACTINIC::EncodeText2($sCookie,0));
	}

#######################################################
# CAccLogin - User login
# No arguments
# Requires: $::g_InputHash needs to be set before
#           $::ENV{HTTP_REFERER}
#           Phrases blob read in
#
# In this case $::g_sB2BUserIDCookie and $::g_sBaseFile are set.
# Otherwise check ACCOUNT cookie against user list.
# Returns only on success.
#######################################################

sub CAccLogin
	{
#? ACTINIC::ASSERT($::g_InputHash{ACTINIC_REFERRER} =~ /\.[gif|jpg|jpeg|png|swf]$/i, "ACTINIC_REFERRER is an image ($::g_InputHash{ACTINIC_REFERRER})", __LINE__, __FILE__);
	my ($sDigest,$sBaseFile,$Md5, $bLoggingIn);

	$ACTINIC::B2B->Clear('UserIDCookie');

	if( $::g_InputHash{USER} and $::g_InputHash{HASH} )	# If this came from LOGIN page
		{
		#
		# Determine and set basefile
		#
		$sBaseFile = ACTINIC::GetReferrer();

		$sDigest = $::g_InputHash{HASH};
		$ACTINIC::B2B->Set('UserIDCookie',$sDigest);
		$ACTINIC::B2B->Set('UserName',$::g_InputHash{USER});
		$ACTINIC::B2B->Set('BaseFile', $sBaseFile);
		if( $::g_InputHash{challengeout} )						# Try new and old version for compatibility
			{
			$ACTINIC::B2B->Set('UserKey',$::g_InputHash{challengeout});
			}
		else
			{
			$ACTINIC::B2B->Set('UserKey',$::g_InputHash{challenge});
			}
		#
		# We're logging in
		#
		$bLoggingIn = $::TRUE;
		$::g_bJustAfterLogin = $::TRUE;
		}
	else
		{
		#
		# We're not logging in
		#
		$bLoggingIn = $::FALSE;

		my $sReferer = ACTINIC::GetReferrer();
		$sReferer =~ s/\?.*//;							# We need here just the file name information

		if( ACTINIC::IsStaticPage($sReferer) && 	# If this came from another static page - this is not B2B
			 $sReferer != "/")							# but check the for failed referrer befor clear the cookie
			{
			$sDigest = "";									# Clear everything
			$ACTINIC::B2B->Clear('BaseFile');
			$ACTINIC::B2B->Clear('UserIDCookie');
			$ACTINIC::B2B->Set('ClearIDCookie','CLEAR');	# Clear User Cookie next time
			$ACTINIC::B2B->Set('ClearUserCookie','CLEAR');	# Clear User Name Cookie next time
			}
		else
			{
			($sDigest,$sBaseFile) = ACTINIC::CaccGetCookies();		# See if the user logged in already
			$ACTINIC::B2B->Set('BaseFile',$sBaseFile);
			}
		}

	my ($Status, $sMessage, $pBuyer) = ACTINIC::GetBuyer($sDigest, ACTINIC::GetPath()); # look up the buyer
	#
	# Check if the challenge is corrupt
	#
	if ($Status == $::BADDATA)
		{
		my ($Status, $sMessage, $sHTML) = ACTINIC::BounceToPageEnhanced(7, ACTINIC::GetPhrase(-1, 1962) . $sMessage . ACTINIC::GetPhrase(-1, 1970) . ACTINIC::GetPhrase(-1, 2055),
																										'',
																									  $::g_sWebSiteUrl,
																									  $::g_sContentUrl, $::g_pSetupBlob,
																									  $::g_sWebSiteUrl.$$::g_pSetupBlob{B2B_LOGONPAGE},
																						  			  \%::g_InputHash);
		if ($Status != $::SUCCESS)
			{
			ACTINIC::ReportError($sMessage, ACTINIC::GetPath());
			}

		ACTINIC::UpdateDisplay($sHTML, $::g_OriginalInputData, $::Session->GetSessionID());
		exit;
		}

	if ($Status != $::SUCCESS &&
		 $Status != $::NOTFOUND)
		{
		my ($Status, $sMessage, $sHTML) = ACTINIC::ReturnToLastPage(7, ACTINIC::GetPhrase(-1, 1962) . $sMessage . ACTINIC::GetPhrase(-1, 1970) . ACTINIC::GetPhrase(-1, 2055), ACTINIC::GetPhrase(-1, 141),
																						$::g_sWebSiteUrl,
																						$::g_sContentUrl, $::g_pSetupBlob, \%::g_InputHash);
		if ($Status != $::SUCCESS)
			{
			ACTINIC::ReportError($sMessage, ACTINIC::GetPath());
			}

		ACTINIC::UpdateDisplay($sHTML, $::g_OriginalInputData, $::Session->GetSessionID());
		exit;
		}

	if( $sDigest &&
		 $Status != $::NOTFOUND)						# Find the user
		{
		my $pAccount;
		($Status, $sMessage, $pAccount) = ACTINIC::GetCustomerAccount($$pBuyer{AccountID}, ACTINIC::GetPath());
		if ($Status != $::SUCCESS)
			{
			my ($Status, $sMessage, $sHTML) = ACTINIC::ReturnToLastPage(7, ACTINIC::GetPhrase(-1, 1962) . $sMessage . ACTINIC::GetPhrase(-1, 1970) . ACTINIC::GetPhrase(-1, 2055), ACTINIC::GetPhrase(-1, 141),
																						 $::g_sWebSiteUrl,
																						 $::g_sContentUrl, $::g_pSetupBlob, \%::g_InputHash);
			if ($Status != $::SUCCESS)
				{
				ACTINIC::ReportError($sMessage, ACTINIC::GetPath());
				}

			ACTINIC::UpdateDisplay($sHTML, $::g_OriginalInputData, $::Session->GetSessionID());
			exit;
			}
		#
		# Check for suspended customer account or buyer
		# and bounce to the login page
		#
		if( $$pAccount{Status} != 0 )					# Customer account suspended
			{
			my ($Status, $sError, $sHTML) = ACTINIC::BounceToPageEnhanced(7, ACTINIC::GetPhrase(-1, 1962) . ACTINIC::GetPhrase(-1, 214, $$pAccount{AccountName}) . ACTINIC::GetPhrase(-1, 1970) . ACTINIC::GetPhrase(-1, 2055),
																										'',
																									  $::g_sWebSiteUrl,
																									  $::g_sContentUrl, $::g_pSetupBlob,
																									  $::g_sWebSiteUrl.$$::g_pSetupBlob{B2B_LOGONPAGE},
																						  			  \%::g_InputHash);
			ACTINIC::PrintPage($sHTML, $::Session->GetSessionID(), $::FALSE);
			exit;
			}
		elsif ( $$pBuyer{Status} != 0 )				# Buyer account suspended
			{
			my ($Status, $sError, $sHTML) = ACTINIC::BounceToPageEnhanced(7, ACTINIC::GetPhrase(-1, 1962) . ACTINIC::GetPhrase(-1, 215, $$pBuyer{Name},$$pAccount{AccountName}) . ACTINIC::GetPhrase(-1, 1970) . ACTINIC::GetPhrase(-1, 2055),
																							'',
																						  $::g_sWebSiteUrl,
																						  $::g_sContentUrl, $::g_pSetupBlob,
																						  $::g_sWebSiteUrl.$$::g_pSetupBlob{B2B_LOGONPAGE},
																						  \%::g_InputHash);
			ACTINIC::PrintPage($sHTML, $::Session->GetSessionID(), $::FALSE);
			exit;
			}
		#
		# OK so far so save the digest and set the checkout fields if we can
		#
		$ACTINIC::B2B->Set('UserDigest',$sDigest);
		#
		# If we're logging in, set the checkout fields from the account
		#
		if($bLoggingIn)
			{
			($Status, $sMessage) = CaccSetCheckoutFields($pBuyer, $pAccount);
			if($Status != $::SUCCESS)
				{
				ACTINIC::ReportError($sMessage, ACTINIC::GetPath());
				}
			$::Session->SetDigest($sDigest);
			}
		ACTINIC::CloseCustomerAddressIndex(); # The customer index is left open for multiple access, so clean it up here
		}
	else														# Not found
		{
		my $sMessage;
		#
		# See if the digest defined (invalid user or pass)
		# or not (cookies disabled).
		#
		if ($sDigest)										# Digest is there
			{													# wrong password or username
			$sMessage = ACTINIC::GetPhrase(-1, 216);
			}
		else													# digest is undefined
			{													# the cookies are disabled
			$sMessage = ACTINIC::GetPhrase(-1, 52);
			}
		RecordErrors($sMessage, ACTINIC::GetPath()); # record the error to the error file

		$::g_sContentUrl = $::Session->GetBaseUrl();
		if ($::g_sContentUrl =~ /\/$/)				# if it is a plain url
			{													# then stick the login page
			$::g_sContentUrl .= $$::g_pSetupBlob{B2B_LOGONPAGE};
			}

		my ($Status, $sError, $sHTML) = ACTINIC::BounceToPageEnhanced(7, ACTINIC::GetPhrase(-1, 1962) . $sMessage . ACTINIC::GetPhrase(-1, 1970) . ACTINIC::GetPhrase(-1, 2055), ACTINIC::GetPhrase(-1, 208),
																						  $::g_sWebSiteUrl,
																						  $::g_sContentUrl, $::g_pSetupBlob,
																						  $::g_sContentUrl,
																						  \%::g_InputHash,$::TRUE);
		if ($Status != $::SUCCESS)
			{
			ACTINIC::ReportError($sError, ACTINIC::GetPath());
			}
		#
		# Set $::g_bLoginPage before PrintPage (XML parsing) to make sure that
		# the correct message will be displayed.
		# See comments of UnregTagHandler for more info.
		#
		$::g_bLoginPage = $::TRUE;
		PrintPage($sHTML, $::Session->GetSessionID(), $::TRUE);
		exit;
		}
	}

#######################################################
#
# CAccCatalogBody - returns name of main catalog page
#
# Params - none
# Returns 0 - html file name - no path
#         1 - the same file if there are no frames and a frameset file if there are
#
#######################################################

sub CAccCatalogBody
	{
	my $sProductPage = $$::g_pSetupBlob{'CATALOG_PAGE'};		# default template
	#
	# See if there is a template request
	#
	if( $::g_InputHash{PRODUCTPAGE} =~ /\S/ )
		{
		$sProductPage = $::g_InputHash{PRODUCTPAGE};
		}

	my $sFramePage = $sProductPage;
	if( ACTINIC::IsCatalogFramed() )
		{
		$sFramePage = $$::g_pSetupBlob{FRAMESET_PAGE};			# default template with frames
		}
	return ($sProductPage,$sFramePage);
	}

#######################################################
#
# CaccSetCheckoutFields - Set the details for this buyer
#			to the checkout fields
#
# Input  0 - ref to buyer
#        1 - ref to account
#
# Returns:	0 - Status
#				1 - error message
#
#######################################################

sub CaccSetCheckoutFields
	{
	my ($pBuyer, $pAccount) = @_;
	my ($Status, $sMessage, $pInvoiceAddress, $pDeliveryAddress, $nInvoiceAddressID, $nDeliveryAddressID);
	my (%hashBillAddress, %hashShipAddress, %hashShipInfo, %hashTaxInfo,
		%hashGeneralInfo, %hashPaymentInfo, %hashLocationInfo);
	#
	# Set the address IDs to undefined
	#
	$nInvoiceAddressID = -1;
	$nDeliveryAddressID = -1;
	#
	# Parse the tax information
	#
	ActinicOrder::ParseAdvancedTax();
	#
	# Set the Compnay fields to the account name
	#
	$hashBillAddress{'REMEMBERME'} = $::FALSE;
	#
	# Set the Company fields to the account name
	#
	if ($pAccount->{CompanyName} ne '')
		{
		$hashBillAddress{'COMPANY'} = $pAccount->{CompanyName};
		}
	else
		{
		$hashBillAddress{'COMPANY'} = $pAccount->{AccountName};
		}
	#
	# Set the preferred payment method after getting the string
	# representation for use in the payment hash
	#
	$hashPaymentInfo{'METHOD'} 		= ActinicOrder::EnumToPaymentString($pAccount->{DefaultPaymentMethod});
	$hashPaymentInfo{'SCHEDULE'} 	= $pAccount->{PriceSchedule};		# get the scedule ID
	#
	# Check if the account only allows one invoice address
	#
	if($pAccount->{InvoiceAddressRule} == 1)
		{
		$nInvoiceAddressID = $pAccount->{InvoiceAddress};

		$hashBillAddress{'NAME'}		= $pAccount->{Name};
		$hashBillAddress{'SALUTATION'}= $pAccount->{Salutation};
		$hashBillAddress{'JOBTITLE'}	= $pAccount->{Title};
		$hashBillAddress{'PHONE'}		= $pAccount->{TelephoneNumber};
		$hashBillAddress{'FAX'}			= $pAccount->{FaxNumber};
		$hashBillAddress{'EMAIL'}		= $pAccount->{EmailAddress};
		}
	else
		{
		if($pBuyer->{InvoiceAddressRule} == 0)
			{
			$nInvoiceAddressID = $pBuyer->{InvoiceAddressID};
			}

		$hashBillAddress{'NAME'}		= $pBuyer->{Name};
		$hashBillAddress{'SALUTATION'}= $pBuyer->{Salutation};
		$hashBillAddress{'JOBTITLE'}	= $pBuyer->{Title};
		$hashBillAddress{'PHONE'}		= $pBuyer->{TelephoneNumber};
		$hashBillAddress{'FAX'}			= $pBuyer->{FaxNumber};
		$hashBillAddress{'EMAIL'}		= $pBuyer->{EmailAddress};
		}
	#
	# If we know the invoice address populate the hashes with the address
	# details
	#
	if($nInvoiceAddressID != -1)
		{
		($Status, $sMessage, $pInvoiceAddress) =
			ACTINIC::GetCustomerAddress($pBuyer->{AccountID}, $nInvoiceAddressID, ACTINIC::GetPath());
		if ($Status != $::SUCCESS)
			{
			return($Status, $sMessage);
			}
		$hashBillAddress{'ADDRESS1'}				= $pInvoiceAddress->{Line1};
		$hashBillAddress{'ADDRESS2'}				= $pInvoiceAddress->{Line2};
		$hashBillAddress{'ADDRESS3'}				= $pInvoiceAddress->{Line3};
		$hashBillAddress{'ADDRESS4'}				= $pInvoiceAddress->{Line4};
		$hashBillAddress{'COUNTRY'}				= ACTINIC::GetCountryName($pInvoiceAddress->{CountryCode});
		$hashBillAddress{'POSTALCODE'}			= $pInvoiceAddress->{PostCode};
		$hashLocationInfo{'INVOICEADDRESS4'}	= $pInvoiceAddress->{Line4};
		$hashLocationInfo{'INVOICEPOSTALCODE'}	= $pInvoiceAddress->{PostCode};
		$hashLocationInfo{'INVOICERESIDENTIAL'}	= $pInvoiceAddress->{nResidential};
		#
		# Now set the invoice location information
		#
		$hashLocationInfo{INVOICE_COUNTRY_CODE}	= $pInvoiceAddress->{CountryCode};
		$hashLocationInfo{INVOICE_REGION_CODE}  = $pInvoiceAddress->{StateCode} eq '' ?
		      $ActinicOrder::UNDEFINED_REGION :
				$pInvoiceAddress->{StateCode};
		#
		# Now set any tax exemption data
		#
		if($::g_pTaxSetupBlob{TAX_BY} != $::eTaxByDelivery)
			{
			$hashTaxInfo{'EXEMPT1'} 	= $pInvoiceAddress->{ExemptTax1} == 0 ? $::FALSE : $::TRUE;
			$hashTaxInfo{'EXEMPT2'} 	= $pInvoiceAddress->{ExemptTax2} == 0 ? $::FALSE : $::TRUE;
			if($hashTaxInfo{'EXEMPT1'})
				{
				$hashTaxInfo{'EXEMPT1DATA'} 	= $pInvoiceAddress->{Tax1ExemptData};
				}
			if($hashTaxInfo{'EXEMPT2'})
				{
				$hashTaxInfo{'EXEMPT2DATA'} 	= $pInvoiceAddress->{Tax2ExemptData};
				}
			}
		}

	if($pBuyer->{DeliveryAddressRule} == 0)
		{
		$nDeliveryAddressID = $pBuyer->{DeliveryAddressID};
		($Status, $sMessage, $pDeliveryAddress) =
			ACTINIC::GetCustomerAddress($pBuyer->{AccountID}, $nDeliveryAddressID, ACTINIC::GetPath());
		if ($Status != $::SUCCESS)
			{
			return($Status, $sMessage);
			}

		$hashShipAddress{'NAME'}		= $pBuyer->{Name};
		$hashShipAddress{'SALUTATION'}= $pBuyer->{Salutation};
		$hashShipAddress{'JOBTITLE'}	= $pBuyer->{Title};
		$hashShipAddress{'PHONE'}		= $pBuyer->{TelephoneNumber};
		$hashShipAddress{'FAX'}			= $pBuyer->{FaxNumber};
		$hashShipAddress{'EMAIL'}		= $pBuyer->{EmailAddress};

		$hashShipAddress{'ADDRESS1'}				= $pDeliveryAddress->{Line1};
		$hashShipAddress{'ADDRESS2'}				= $pDeliveryAddress->{Line2};
		$hashShipAddress{'ADDRESS3'}				= $pDeliveryAddress->{Line3};
		$hashLocationInfo{'DELIVERADDRESS3'}	= $pDeliveryAddress->{Line3};
		$hashShipAddress{'ADDRESS4'}				= $pDeliveryAddress->{Line4};
		$hashLocationInfo{'DELIVERADDRESS4'}	= $pDeliveryAddress->{Line4};
		$hashShipAddress{'COUNTRY'}				= ACTINIC::GetCountryName($pDeliveryAddress->{CountryCode});
		$hashShipAddress{'POSTALCODE'}			= $pDeliveryAddress->{PostCode};
		$hashLocationInfo{'DELIVERPOSTALCODE'}		= $pDeliveryAddress->{PostCode};
		#
		# Now set the delivery location information
		#
		$hashLocationInfo{DELIVERY_COUNTRY_CODE}	= $pDeliveryAddress->{CountryCode};
		$hashLocationInfo{DELIVERY_REGION_CODE} = $pDeliveryAddress->{StateCode} eq '' ?
		        $ActinicOrder::UNDEFINED_REGION :
		        $pDeliveryAddress->{StateCode};
		#
		# if we know the invoice address as well, mark separate ship appropriately
		#
		if($nInvoiceAddressID != -1)
			{
			if($nInvoiceAddressID == $nDeliveryAddressID)		# same address?
				{
				$hashLocationInfo{'SEPARATESHIP'}	= $::FALSE;
				$hashShipAddress{'SEPARATESHIP'}		= $::FALSE;
				}
			else																# different address
				{
				$hashLocationInfo{'SEPARATESHIP'}	= $::TRUE;
				$hashShipAddress{'SEPARATESHIP'}		= $::TRUE;
				}
			}
		#
		# Now set any tax exemption data if we're taxing by delivery address
		#
		if($::g_pTaxSetupBlob{TAX_BY} == $::eTaxByDelivery)
			{
			$hashTaxInfo{'EXEMPT1'} 	= $pDeliveryAddress->{ExemptTax1} == 0 ? $::FALSE : $::TRUE;
			$hashTaxInfo{'EXEMPT2'} 	= $pDeliveryAddress->{ExemptTax2} == 0 ? $::FALSE : $::TRUE;
			if($hashTaxInfo{'EXEMPT1'})
				{
				$hashTaxInfo{'EXEMPT1DATA'} 	= $pDeliveryAddress->{Tax1ExemptData};
				}
			if($hashTaxInfo{'EXEMPT2'})
				{
				$hashTaxInfo{'EXEMPT2DATA'} 	= $pDeliveryAddress->{Tax2ExemptData};
				}
			}
		}
	#
	# save the modified data
	#
	my @Response = $::Session->UpdateCheckoutInfo(
		\%hashBillAddress, \%hashShipAddress, \%hashShipInfo, \%hashTaxInfo,
		\%hashGeneralInfo, \%hashPaymentInfo, \%hashLocationInfo);
	if ($Response[0] != $::SUCCESS)
		{
		return (@Response);
		}
	no strict 'refs';
	%::g_BillContact	= %hashBillAddress;					# copy the hashes to global tables
	%::g_ShipContact	= %hashShipAddress;
	%::g_ShipInfo		= %hashShipInfo;
	%::g_TaxInfo		= %hashTaxInfo;
	%::g_GeneralInfo	= %hashGeneralInfo;
	%::g_PaymentInfo	= %hashPaymentInfo;
	%::g_LocationInfo = %hashLocationInfo;

	return($::SUCCESS, '');
	}

#######################################################
#
# CAccFindUser - find logged in user using cookie
#
# No arguments
#
# Returns User Digest or "" if not found or suspended
#
#######################################################

sub CAccFindUser
	{
	my ($sDigest,$sBaseFile) = ACTINIC::CaccGetCookies();	# See if the user logged in already
	if (!$sDigest)
		{
		return ("");
		}

	my ($Status, $sMessage, $pBuyer) = ACTINIC::GetBuyer($sDigest, ACTINIC::GetPath()); # look up the buyer
	if ($Status != $::SUCCESS)
		 {
		 return ("");
		 }

	my $pAccount;
	($Status, $sMessage, $pAccount) = ACTINIC::GetCustomerAccount($$pBuyer{AccountID}, ACTINIC::GetPath());
	if ($Status != $::SUCCESS)
		{
		return ("");
		}

	if( $$pAccount{Status} == 0 &&
		 $$pBuyer{Status} == 0 )						# Check if account is active
		{
		$ACTINIC::B2B->Set('BaseFile',$sBaseFile);
		return ($sDigest);								# Found - return digest
		}

	return ("");
	}

#######################################################
#
# ParseXML - PXML wrapper
# Prepares basic variables and parses text using ACTINIC_PXML
#
# Argument: 0 - text to parse
#
# Returns: 	0 - Parsed text
#
#######################################################

sub ParseXML
	{
	my $sHTML = shift;
	my $sDigest = $ACTINIC::B2B->Get('UserDigest');

	if( !$sDigest )	# No user
		{
		$sDigest = $ACTINIC::B2B->Set('UserDigest',ACTINIC::CAccFindUser());	# See if there is a user cookie after all
		}

	if( $sDigest )		# User found - do some basic XML variables
		{
		my ($Status, $sMessage, $pBuyer) = ACTINIC::GetBuyer($sDigest, ACTINIC::GetPath()); # look up the buyer
		if ($Status != $::SUCCESS)
			{
			ACTINIC::ReportError($sMessage, ACTINIC::GetPath());
			}

		my $pAccount;
		($Status, $sMessage, $pAccount) = ACTINIC::GetCustomerAccount($$pBuyer{AccountID}, ACTINIC::GetPath());
		if ($Status != $::SUCCESS)
			{
			ACTINIC::ReportError($sMessage, ACTINIC::GetPath());
			}

		my $sBuyer = $$pBuyer{Name};
		my $sAccount = $$pAccount{AccountName};
		$ACTINIC::B2B->SetXML('BUYER',      $sBuyer);
		$ACTINIC::B2B->SetXML('ACCOUNT',    $sAccount);
		$ACTINIC::B2B->SetXML('NOWSERVING', ACTINIC::GetPhrase(-1, 212, ACTINIC::GetPhrase(-1, 1968, $$::g_pSetupBlob{FOREGROUND_COLOR}), $sBuyer, ACTINIC::GetPhrase(-1, 1970)));
		$ACTINIC::B2B->SetXML('CURRACCOUNT',ACTINIC::GetPhrase(-1, 213, ACTINIC::GetPhrase(-1, 1968, $$::g_pSetupBlob{FOREGROUND_COLOR}), $sAccount, ACTINIC::GetPhrase(-1, 1970)));
		$ACTINIC::B2B->SetXML('WELCOME',    ACTINIC::GetPhrase(-1, 210, $$::g_pSetupBlob{FORM_BACKGROUND_COLOR}, ACTINIC::GetPhrase(-1, 1969, $$::g_pSetupBlob{FOREGROUND_COLOR}), $sBuyer, ACTINIC::GetPhrase(-1, 1970)));

		my $sShop = $::g_InputHash{SHOP} ? '&SHOP=' . ACTINIC::EncodeText2($::g_InputHash{SHOP}, $::FALSE) : '';
		my $sTarget = '_self';
		my $sOrderScript = sprintf("os%6.6d%s",$$::g_pSetupBlob{CGI_ID},$$::g_pSetupBlob{CGI_EXT});
		if( ACTINIC::IsCatalogFramed() and					# Catalog framed
			 !(($::ENV{SCRIPT_NAME} =~ /\/$sOrderScript$/ and             # A checkout page
				 $$::g_pSetupBlob{UNFRAMED_CHECKOUT} )) )                     # and checkout is unframed
			{
			$sTarget = '_parent';								# Always logout to parent frame
			}
		#
		# Check if we have logout link specified (home page)
		#
		$ACTINIC::B2B->SetXML('LOGOUT', ACTINIC::GetPhrase(-1, 2283, $::g_sAccountScript, $sShop, $sTarget,
									ACTINIC::GetPhrase(-1, 217, ACTINIC::GetPhrase(-1, 1968, $$::g_pSetupBlob{LINK_COLOR}),
									ACTINIC::GetPhrase(-1, 1970))));
		$ACTINIC::B2B->SetXML('LOGOUT_SIMPLE',
									 "&nbsp;<A HREF=\"$::g_sAccountScript\?ACTION=LOGOUT" .
									 $sShop
									 . '" TARGET="' . $sTarget . '">'
									 . ACTINIC::GetPhrase(-1, 217, ACTINIC::GetPhrase(-1, 1968, $$::g_pSetupBlob{LINK_COLOR}), ACTINIC::GetPhrase(-1, 1970))
									 . "</A>");
		#
		# Handle the Brochure pages logout here, because the framed status can be different from the catalog pages
		#
		$sTarget = '_self';
		if( ACTINIC::IsBrochureFramed())				# if brochure is framed
			{
			$sTarget = '_parent';								# Always logout to parent frame
			}
		$ACTINIC::B2B->SetXML('BROCHURE_LOGOUT', ACTINIC::GetPhrase(-1, 2283, $::g_sAccountScript, $sShop, $sTarget,
									ACTINIC::GetPhrase(-1, 217, ACTINIC::GetPhrase(-1, 1968, $$::g_pSetupBlob{LINK_COLOR}),
									ACTINIC::GetPhrase(-1, 1970))));
		$ACTINIC::B2B->SetXML('BROCHURE_LOGOUT_SIMPLE',
									 "&nbsp;<A HREF=\"$::g_sAccountScript\?ACTION=LOGOUT" .
									 $sShop
									 . '" TARGET="' . $sTarget . '">'
									 . ACTINIC::GetPhrase(-1, 217, ACTINIC::GetPhrase(-1, 1968, $$::g_pSetupBlob{LINK_COLOR}), ACTINIC::GetPhrase(-1, 1970))
									 . "</A>");
		}
	return (ParseXMLCore($sHTML));
	}

#######################################################
#
# ParseXMLCore - PXML wrapper
# Loads parser module and does the parse
#
# Argument: 0 - text to parse
#
# Returns: 	0 - Parsed text
#
#######################################################

sub ParseXMLCore
	{
	my $sStringToParse = shift;
	#
	# Load XML parser
	#
	eval
		{
		require <Actinic:Variable Name="ActinicPXMLPackage"/>;	# load parser library
		};
	if ($@)													# library load failed?
		{
		ReportError($@, GetPath());					# if so then record the error
		}

	my $pXML = new ACTINIC_PXML();					# Create XML object
	my ($sParsedHTML, $pTree) = $pXML->Parse($sStringToParse);		# Parse text
	#
	# At this point the parsed HTML was converted to https if SSL was in used - no longer required
	#
	return ($sParsedHTML);		# Return parsed text
	}

################################################################
#
# PreProcessXMLTemplateString
#
# Get the XML entity tree of a given string
#
# Input: 	0 - string to process
#
# Returns: 	0 - the parsed text
#				2 - XML entity tree
#
# Author:	Zoltan Magyar, 8:33 PM 3/13/2002
#
################################################################

sub PreProcessXMLTemplateString
	{
	my $sStringToParse = shift;
	#
	# Load XML parser
	#
	eval
		{
		require <Actinic:Variable Name="ActinicPXMLPackage"/>;	# load parser library
		};
	if ($@)													# library load failed?
		{
		ReportError($@, GetPath());					# if so then record the error
		}

	my $pXML = new PXML();								# Create XML object
	my @Response = $pXML->Parse($sStringToParse, "Actinic:");		# Parse text
	return (@Response);									# Return the full result
	}

################################################################
#
# PreProcessXMLTemplate
#
# Get the XML entity tree of a given file
#
# Input: 	0 - file name to process
#
# Returns: 	0 - status (success/failure)
#				1 - the parsed text
#				2 - XML entity tree
#
# Author:	Zoltan Magyar, 8:33 PM 3/13/2002
#
################################################################

sub PreProcessXMLTemplate
	{
	my $sFilename = shift;
	#
	# Load XML parser
	#
	eval
		{
		require <Actinic:Variable Name="ActinicPXMLPackage"/>;	# load parser library
		};
	if ($@)													# library load failed?
		{
		return ($::FAILURE, $@);						# if so then return the error message
		}

	my $pXML = new PXML();								# Create XML object
	my @Response = $pXML->ParseFile($sFilename, "Actinic:");		# Parse text

	return (@Response);									# Return the full result
	}

################################################################
#
# ReplaceActinicVars	- Replace an 'Actinic:XXX' variable
#
# Input: 	$sText - text to process
#
# Returns: 	0 - status (success/failure)
#				1 - error message
#				2 - substituted string
#
# Author:	Mike Purnell
#
################################################################

sub ReplaceActinicVars
	{
	my ($sText, $rhValues) = @_;
	
	my $sVarPrefix = 'Actinic:';
	my $sSubstituted = '';
	while ($sText =~ m|(<\s*$sVarPrefix)(\w+)|)
		{
		$sSubstituted .= $`;
		if (defined $rhValues->{$2})
			{
			my $sVarName = $2;
			$sSubstituted .= $rhValues->{$2};
			$sText = substr($sText, (length $`) + length($1) + length($2));
			if ($sText =~ m|(^[^>]*?/>)|)
				{
				$sText = substr($sText, length($1));
				}
			elsif ($sText =~ m|(<\s*/$sVarPrefix$sVarName\s*>)|)
				{
				$sText = substr($sText, (length $`) + length($1));
				}
			}
		else
			{
			$sSubstituted .= $1 . $2;
			$sText = substr($sText, (length $`) + length($1) + length($2));
			if ($sText =~ m|(^[^>]*?>)|)
				{
				$sSubstituted .= $1;
				$sText = substr($sText, length($1));
				}
			}
		}
	$sSubstituted .= $sText;
	return ($::SUCCESS, '', $sSubstituted);
	}
	
#---------------------------------------------------------------
#
# Digital Download related functions
#
#---------------------------------------------------------------
################################################################
#
# GetDigitalContent
#	calls the download plugin and receives the list of downloadable
#	files for the passed in products
#
# Input: 	0 - the cart list
#				1 - $::TRUE if the content should be shown without
#					 checking the conditions (optional
#
# Returns: 	0 - status (success/failure)
#				1 - the parsed text
#				2 - hash of files (prodref => array of files)
#
# Author:	Zoltan Magyar, 9:52 AM 7/4/2002
#
################################################################

sub GetDigitalContent
	{
	my ($pCartList) = shift;							#$_[0];
	my ($bAlways) = shift;
	my $pOrderDetail;
	my @Response;
	my $nExpiry;

	if (!defined $bAlways ||							# if the parameter was not provided, then initalise it.
		length $bAlways == 0)
		{
		$bAlways = $::FALSE;
		}

	#
	# Check if DD is enabled
	#
	$nExpiry = $$::g_pSetupBlob{'DD_EXPIRY_TIME'};
	if (($nExpiry <= 0) ||								# if the link has expired
		(!$::Session->IsPaymentMade() &&				# or the order has not been payed yet
		($bAlways != $::TRUE))	||						# and the content is not requested regardless of the payment status
		$::Session->IsIPCheckFailed())				# or the IP check has failed
		{
		return($::SUCCESS, "", {}, 0);				# we don't allow digital download
		}
	#
	# Get product references
	#
	my @ProdRefs;
	foreach $pOrderDetail (@$pCartList)				# review all of the items in the cart
		{
		push @ProdRefs, $$pOrderDetail{'PRODUCT_REFERENCE'};	# add it to the list of references
		my %CurrentItem = %$pOrderDetail;
		#
		# Locate the section blob
		#
		my ($Status, $Message, $sSectionBlobName) = ACTINIC::GetSectionBlobName($CurrentItem{SID}); # retrieve the blob name
		if ($Status == $::FAILURE)
			{
			return ($Status, $Message);
			}
		#
		# locate this product's object.
		#
		@Response = ACTINIC::GetProduct($CurrentItem{"PRODUCT_REFERENCE"}, $sSectionBlobName,
												  ACTINIC::GetPath());	# get this product object
		my $pProduct;
		($Status, $Message, $pProduct) = @Response;
		if ($Status == $::FAILURE)
			{
			return (@Response);
			}
		#
		# Check if component has product ref (associated product)
		#
		if( $pProduct->{COMPONENTS} )
			{
			my $VariantList = ActinicOrder::GetCartVariantList(\%CurrentItem);
			my %Component;
			my $pComponent;
			my $nIndex = 1;

			foreach $pComponent (@{$pProduct->{COMPONENTS}})
				{
				@Response = ActinicOrder::FindComponent($pComponent, $VariantList);
				($Status, %Component) = @Response;
				if ($Status != $::SUCCESS)
					{
					return ($Status, $Component{text}, {}, 0);
					}
				push @ProdRefs, $Component{code};
				}
			}
		}
	#
	# Load Download module
	#
 	eval "require <Actinic:Variable Name="DownloadModule"/>;";			# Try loading download module
	if ($@)
		{
		return ($::FAILURE, "Error loading digital download module. $@", {}, 0);
		}
	#
	# Get list of download URLs
	#
	@Response = DigitalDownload::GetContentList($nExpiry, \@ProdRefs);
	return(@Response);
	}


#---------------------------------------------------------------
#
# END - Digital Download related functions - END
#
#---------------------------------------------------------------

############################################################
#
#  package ACTINIC_B2B - keeps B2B variables
#  This object keeps B2B variables providing Set, Clear and Get
#  functions.
#  SetXML, AppendXML, GetXML and ClearXML are used to store and
#  retrieve XML tag variables used by ACTINIC_PXML class.
#
#  Ryszard Zybert  Mar 17 12:11:17 GMT 2000
#
#  Copyright (c) Actinic Software Ltd (2000)
#
############################################################
package ACTINIC_B2B;
use strict;
############################################################
#  sub new - create B2B object
#
#  Ryszard Zybert  Mar 17 12:11:50 GMT 2000
#
#  Copyright (c) Actinic Software Ltd (2000)
############################################################

sub new
	{
	my $Proto = shift;
	my $Class = ref($Proto) || $Proto;
	my $Self  = {};
	bless ($Self, $Class);
	$Self->{XML} = {};

	return $Self;
	}
############################################################
#  B2B->Set - set B2B variable
#  Arguments
#		0 - class
#		1 - variable name
#		2 - variable value
#  Returns
#		0 - variable value
#
#  Ryszard Zybert  Mar 17 12:14:43 GMT 2000
#
#  Copyright (c) Actinic Software Ltd (2000)
############################################################

sub Set
	{
	my $Self = shift;
	my $sName = shift;
	my $sValue = shift;

	$Self->{$sName} = $sValue;
	return $sValue;
	}
############################################################
#  B2B->Clear - unset B2B variable
#  Arguments
#  		0 - class
#  		1 - variable name
#
#  Ryszard Zybert  Mar 17 12:19:09 GMT 2000
#
#  Copyright (c) Actinic Software Ltd (2000)
############################################################

sub Clear
	{
	my $Self = shift;
	my $sName = shift;

	$Self->{$sName} = undef;
	}
############################################################
#  B2B->Get - get B2B variable
#  Arguments
#    		0 - class
#    		1 - variable name
#  Returns
#    		0 - variable value
#
#  Ryszard Zybert  Mar 17 12:20:48 GMT 2000
#
#  Copyright (c) Actinic Software Ltd (2000)
############################################################

sub Get
	{
	my $Self = shift;
	my $sName = shift;
	return $Self->{$sName};
	}
############################################################
#  B2B->SetXML - set B2B XML variable
#  Arguments
#		0 - class
#		1 - variable name
#		2 - variable value
#  Returns
#		0 - variable value
#
#  If variable is already defined does nothing and returns an empty
#  string.
#  Update should be used to modify existing variables
#
#  Ryszard Zybert  Mar 17 12:14:43 GMT 2000
#
#  Copyright (c) Actinic Software Ltd (2000)
############################################################

sub SetXML
	{
	my $Self = shift;
	my $sName = shift;
	my $sValue = shift;

	$Self->{XML}->{$sName} = $sValue;
	return $sValue;
	}
############################################################
#  B2B->AppendXML - append string to B2B XML variable
#  Arguments
#  		0 - class
#  		1 - variable name
#  		2 - string to append
#  Returns
#  		0 - new variable value
#
#  Ryszard Zybert  Mar 17 12:19:09 GMT 2000
#
#  Copyright (c) Actinic Software Ltd (2000)
############################################################

sub AppendXML
	{
	my $Self = shift;
	my $sName = shift;
	my $sValue = shift;

	$Self->{XML}->{$sName} .= $sValue;
	return $Self->{XML}->{$sName};
	}
############################################################
#  B2B->GetXML - get B2B XML variable
#  Arguments
#    		0 - class
#    		1 - variable name
#  Returns
#    		0 - variable value
#
#  Ryszard Zybert  Mar 17 12:20:48 GMT 2000
#
#  Copyright (c) Actinic Software Ltd (2000)
############################################################

sub GetXML
	{
	my $Self = shift;
	my $sName = shift;
	return $Self->{XML}->{$sName};
	}
############################################################
#  B2B->ClearXML - clear all B2B XML variables
#
#  Ryszard Zybert  Mar 17 12:23:28 GMT 2000
#
#  Copyright (c) Actinic Software Ltd (2000)
############################################################

sub ClearXML
	{
	my $Self = shift;
	$Self->{XML} = undef;
	}

##################################################################################################
#
#  package SSLConnection - SSL connection class
#  
#  Class sending requests on an SSL socket and receiving rsponses
#
#  Zoltan Magyar  Jan 10 2007
#
#  Copyright (c) Actinic Software Ltd (2007)
#
##################################################################################################

package SSLConnection;
use strict;

############################################################
#
#  sub new - create a new SSL connection object
#
#  Input:	[0] - server to connect to
#				[1] - server's port
#				[2] - path to request
#
#  Zoltan Magyar
#
#  Copyright (c) Actinic Software Ltd (2007)
#
############################################################

sub new
	{
	my $Proto = shift;
	my $Class = ref($Proto) || $Proto;
	my $Self  = {};
	bless ($Self, $Class);
	$Self->{_SERVER} = shift;
	$Self->{_PORT} = shift;
	$Self->{_PATH} = shift;
	#
	# Init some members
	#
	$Self->{_HEADER} = {};								# list of header parameters
	$Self->{_METHOD} = "GET";
	$Self->{_CONNECT_STATUS} = $::FALSE;
	$Self->{_CONNECT_ERROR_MESSAGE} = "SSLConnection::SendRequest() must be called first.";
	# 
	# Set up default header values
	#
	$Self->{_HEADER}->{"Content-Type"} = "application/x-www-form-urlencoded";
	$Self->{_HEADER}->{"Accept"} = "*/*";
	$Self->{_HEADER}->{"User-Agent"} = "ActinicEcommerce";
	$Self->{_HEADER}->{"Connection"} = "close";
	$Self->{_HEADER}->{"Pragma"} = "no-cache";
	
	return $Self;
	}
	
############################################################
#
#  SetHeaderValue - set parameters to be included in the header
#
#  Input:	[0] - parameter name
#				[1] - parameter value
#
#  Author: Zoltan Magyar
#
#  Copyright (c) Actinic Software Ltd (2007)
#
############################################################

sub SetHeaderValue
	{
	my $Self = shift @_;
	my $sParam = shift @_;
	my $sValue = shift @_;
	$Self->{_HEADER}->{$sParam} = $sValue;
	}	
	
############################################################
#
#  SetRequestMethod - set HTTP request method
#
#  Input:	[0] - new request method
#
#  Author: Zoltan Magyar
#
#  Copyright (c) Actinic Software Ltd (2007)
#
############################################################

sub SetRequestMethod
	{
	my $Self = shift @_;
	my $sMethod = shift @_;
	$Self->{_METHOD} = $sMethod;
	}	
	
############################################################
#
#  GetConnectStatus - get the status of the connection
#
#  Return:	[0] - the status ($::TRUE in case of success)
#
#  Author: Zoltan Magyar
#
#  Copyright (c) Actinic Software Ltd (2007)
#
############################################################

sub GetConnectStatus
	{
	my $Self = shift @_;
	return($Self->{_CONNECT_STATUS});
	}	
	
############################################################
#
#  GetResponseHeader - get the header of the http response
#
#  Return:	[0] - the header
#
#  Author: Zoltan Magyar
#
#  Copyright (c) Actinic Software Ltd (2007)
#
############################################################

sub GetResponseHeader
	{
	my $Self = shift @_;
	return($Self->{_RESPONSE_HEADER_STRING});
	}	
	
############################################################
#
#  GetResponseContent - get the content of the http response
#
#  Return:	[0] - the content
#
#  Author: Zoltan Magyar
#
#  Copyright (c) Actinic Software Ltd (2007)
#
############################################################

sub GetResponseContent
	{
	my $Self = shift @_;
	return($Self->{_RESPONSE_CONTENT_STRING});
	}	
	
############################################################
#
#  GetHeaderHash - get the header of the http response as
#		a perl hash of key value pairs
#
#  Return:	[0] - the content
#
#  Author: Zoltan Magyar
#
#  Copyright (c) Actinic Software Ltd (2007)
#
############################################################

sub GetHeaderHash
	{
	my $Self = shift @_;
	return($Self->{_RESPONSE_HEADER_HASH});
	}		
	
############################################################
#
#  GetHeaderString - get the header parameter list as a 
#		single string in the format of HTTP header
#
#  Return:	[0] - the concatenated string parameter list
#
#  Author: Zoltan Magyar
#
#  Copyright (c) Actinic Software Ltd (2007)
#
############################################################

sub GetHeaderString
	{
	my $Self = shift @_;
	my $sHeader;
	my $sParam;
	#
	# Concatenate the params
	#
	foreach $sParam (keys %{$Self->{_HEADER}})
		{
		$sHeader .= sprintf("%s: %s\r\n", $sParam, $Self->{_HEADER}->{$sParam});
		}

	return($sHeader);
	}
	
############################################################
#
#  SendRequest - send the request itself
#
#  Input:	[0] - content to be sent
#
#  Zoltan Magyar
#
#  Copyright (c) Actinic Software Ltd (2007)
#
############################################################

sub SendRequest
	{
	my $Self = shift @_;
	my $sContent = shift @_;
	#
	# Send the request
	#
	my ($nResult, $sMessage, $sResponse, $ssl_socket); 
	($nResult, $sMessage, $sResponse, $ssl_socket) = ACTINIC::HTTPS_SendAndReceive(
		$Self->{_SERVER}, 
		$Self->{_PORT}, 
		$Self->{_PATH}, 
		$sContent,
		$Self->{_METHOD},
		$::TRUE,
		$ssl_socket,
		$Self->GetHeaderString());
	#
	# Check if the request was received correctly and we got a response
	#
	if ($nResult != $::SUCCESS)
		{
		$Self->{_CONNECT_STATUS} = $::FALSE;
		$Self->{_CONNECT_ERROR_MESSAGE} = $sMessage;
		return;
		}
	#
	# Process the response
	#
	(	$Self->{_CONNECT_STATUS}, 
		$Self->{_CONNECT_ERROR_MESSAGE}, 
		$Self->{_RESPONSE_HEADER_STRING}, 
		$Self->{_RESPONSE_CONTENT_STRING}, 
		$Self->{_RESPONSE_HEADER_HASH}) = ACTINIC::HTTP_SplitHeaderAndContent($sResponse);
		
	return ($sMessage, $sResponse);
	}


1;
