perl/ARSConfig.pm                                                                                   0100755 0000000 0000000 00000002374 07442556667 012666  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ;# $Id: ARSConfig.pm,v 1.2 2002/03/10 04:04:21 jay Exp $
package ARSConfig;

require 5.005;
use strict;
use vars qw($VERSION @ISA %EXPORT_TAGS);

$VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker

@ISA = qw(Exporter);

# System includes
use Exporter;

# Local includes
#(none)


##############################################################################
#
#  Globals
#
##############################################################################

use vars qw($GC);	# Ref to global configuration hash


##############################################################################
#
#  Initialization
#
##############################################################################

sub _load_config 
{
	my $config = $ENV{ARS_CONFIG} or die "No ARS_CONFIG in environment";
	
	my $hr;
	unless ($hr = do $config) {
		die "Couldn't parse config file $config: $@" if $@;
		die "Couldn't do config file: $!" unless defined $hr;
		die "$config didn't return a hashref" unless ref($hr) eq 'HASH';
	}

	$hr;
}

$GC = _load_config();

# XXX Verify GC here

%EXPORT_TAGS = ( default => [qw($GC)] );
Exporter::export_tags   (keys %EXPORT_TAGS);
Exporter::export_ok_tags(keys %EXPORT_TAGS);

1;
__END__


                                                                                                                                                                                                                                                                    perl/ARSHandler/                                                                                    0040755 0000000 0000000 00000000000 07614044210 012443  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   perl/ARSHandler/Admin.pm                                                                            0100644 0000000 0000000 00000024115 07614044210 014031  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ;# $Id: Admin.pm,v 1.14 2003/01/23 19:54:22 jay Exp $
;#
;# ARSHandler::Admin - Request handler plug-in that handles admin-only functions
;#
use strict;

#
# All of these admin functions are run thru the following admin check
# 
sub is_admin 
{
	my $state=shift;
	my %state=%$state;
	if ($state->{user_type} eq "admin" 		||
		$state->{user_type} eq "staff"		|| 
		$state->{user_type} eq "moderator"	) {
		return 1;
	} else {
		return 0;
	}
}


#
# admin_only handler builder - make handler accessible admin users only
#
sub admin_only($)
{
	my $handler = shift;

	# Build a handler that requires admin privs
	sub {
		my $state = shift;

		unless(is_admin($state)) {
			my $template = "$Template_Dir/generic.html";
			return output_template($template, $state, 
				uf_content => "Must be admin; sorry. :(");
		}
	
		$handler->($state);
	};
}


###########################################################
#
# Admin-only URL handlers
#
###########################################################


sub emit_new_article_form 
{
	my $state=shift;
	my $template="$Template_Dir/articles.html";
	my $currtime=time;
	
	my $buttons= '<BR><input type="submit" name="submit_type" value = "Preview">';

	# handle SUBMIT/PREVIEW actions in forms
	# we always show a preview button first. 
	# is this a reply?
	my $uf_content;	
	if ( $state->{submit_type} eq "Preview" ) {
		# Add a submit if the user pressed preview
		$buttons.= '<input type="submit" name="submit_type" value = "Submit">';
		$uf_content.=preview_new_article($state);
	} 
	$uf_content .=<<EOF;
<BR>
<TABLE WIDTH="100%" BORDER="0" cellspacing="0" cellpadding="2" >
<TR>
<TD valign="top" colspan=3 align=center>
<form method="post" action="http://ars.userfriendly.org/$state->{path}/post_article.cgi">
</td>
</tr>
<TR>
<TD valign="top" colspan=3>
<b>Post New Article</b></font> 
</td></tr>
<tr> 
<td valign="top">Headline</td>
<td><input type="text" name="headline" value="$state->{headline}" size=80 maxlength="120">
</td>
</tr>
<tr> 
<td valign="top">Comments</td>
<td><textarea name="message" cols="80" rows="8" wrap="virtual">$state->{message}</textarea>
<BR>
$buttons
</table>
<BR>
EOF
	return output_template($template, $state,  uf_content => $uf_content ) ;
}

###
#
# Preview article, just escape all encoding. 
#
##

sub preview_new_article 
{
	my $state=shift;
	my $headline=$state->{headline};
	my $message=$state->{message};
	$headline=~s/</\&lt;/g;
	$headline=~s/>/\&gt;/g;
	$message=~s/</\&lt;/g;
	$message=~s/>/\&gt;/g;
	<<EOF;
<B>Preview</b><P>
<TABLE>
<TR><TD bgcolor=#ffffcc><B>$headline</b></td></tr>
<tr><TD>$message</td></tr>
</TABLE>
EOF
}


sub post_new_article_form
{
	my $state=shift;

	my $template="$Template_Dir/articles.html";

	return emit_new_article_form($state) if $state->{submit_type} eq "Preview";

	my @errors=();
	push @errors , "Headline is empty" unless $state->{headline};
	push @errors , "Message is empty"  unless $state->{message};
	push @errors , "Posting area not defined" unless $state->{article_table};
	if (@errors) {
		my $Buttons= '<input type="submit" name="submit_type" value = "Preview">';
		my $errors="Posting <B> Not Successful </b> because of following errors:<BR>";
		
		$errors .= "$_<BR>" for @errors;
		
		return output_template($template, $state, article => $errors , buttons => $Buttons);
	}

	$state->{expire} ||= time + (30 * 24 * 60 * 60 );
	
	#FIXME: need expire put into state

	insert_article($state);

	# FIXME: expire hard coded to 30 days from insertion
	$template="$Template_Dir/articles.html";
	return output_template($template, $state, uf_content => "Thanks" );
}

# list all the active and inactive posts
#
# Form commands:  For each row, you get a post/query var named "acmd_XX" (where XX is numeric row id)
# that contains one of the following commands:
#    (empty string)    do nothing
#    add_XX            add XX days to expiry date
#    activate_XX       set STATUS=active and set expirty date to XX days from now
#    deactivate        set STATUS=inactive
#    delete            Remove row from db table

sub post_approve_form
{
	my $state   = shift;
	my $q       = $state->{q};
	my @actions = ();
	
	# Look for commands and process them as we find them
	my @qvars = ();
	foreach my $qvar ( keys %$q ) {
		next unless $q->{$qvar};
		next unless $qvar =~ /^acmd_(\d+)$/;
		push @qvars, [ $qvar, int($1) ];
	}
	
	my @cmds =	map  { $_->[1] => $q->{ $_->[0] } }
				sort { $a->[1] <=> $b->[1] }
				@qvars;

	while( my($id, $acmd) = splice @cmds, 0, 2 ) {
		my ($cmd, $arg) = $acmd =~ /^(.+?)(?:_(\d+))?$/;
		if ($cmd eq 'add') {
			update_article( $state, $id, add_expiry => 86400*$arg );
			push @actions, "Added $arg days to article #$id";
		} elsif ($cmd eq 'activate') {
			update_article( $state, $id, set_active => 1, set_expiry => time + 86400*$arg );
			push @actions, "Activated article #$id for $arg days";
		} elsif ($cmd eq 'deactivate') {
			update_article( $state, $id, set_active => 0 );
			push @actions, "Deactivated article #$id";
		} elsif ($cmd eq 'delete') {
			delete_article( $state, $id );
			push @actions, "Deleted article #$id";
		}
	}
	
	my $whatidid = join "<br>", @actions;
	
	my $template = "$Template_Dir/articles.html";

	return output_template($template, $state, uf_content => $whatidid);
}


sub emit_approve_form
{
	my $state=shift;
	my $now=time;
	my $template="$Template_Dir/articles.html";		
	my $uf_content =<<EOF;
<BR>
<TABLE WIDTH="100%" BORDER="0" cellspacing="0" cellpadding="2" >
<TR>
<TD valign="top" colspan=3 align=center>
<form method="get" action="http://ars.userfriendly.org/$state->{path}/approve.cgi">
</td>
</tr>
<TR>
<TD valign="top" colspan=3>
<HR>
<b>Approve Articles</b> Note: Articles that expired more than 7 days ago are not displayed.<br>&nbsp;<br>
</td></tr><tr><td>
EOF
		$uf_content.= article_list($state);
		$uf_content.=<<EOF;
</td></tr><tr><td><br><input type=submit name=Approve value="Approve Articles">
</form>
</td></tr></table>
<BR>
EOF
	return output_template($template,$state, uf_content=> $uf_content) 
}


#
# Emit a simple moderation form
# FIXME: for now, don't bother remembering previous moderation state
# should likely add that
sub emit_moderate_form
{
	my $state=shift;
	my $uf_content = build_link_back_to_index($state) . get_single_comment($state);
	my $threads=<<EOF;
<FORM action="http://ars.userfriendly.org/$state->{path}/mchange.cgi" method="post">
<input type="hidden" name="id" value="$state->{id}">
<input type="hidden" name="tid" value="$state->{tid}">
<input type="radio" name="status" value="active" checked> Active <input type="radio" name="status" value="inactive"> Moderated 
<input type="submit" name="submit" value="Moderate">
</form>
EOF
	my $template="$Template_Dir/comment.html";		
	return output_template($template, $state, 
		threads => $threads, uf_content => $uf_content, comment_mode_bar => "") ;
}


sub post_moderate_form
{
	my $state=shift;
	my $template="$Template_Dir/articles.html";		
	return output_template($template, $state, 
		uf_content => "Error in Moderation Form Data", ) unless  $state->{tid} && $state->{id};

	moderate_comment($state);
	my $url = add_state_to_url($state, "/$state->{path}/read.cgi", qw(id tid));
	return redirect_to_cachebusted_url( $state, $url);
}



# 
# handles admin disabling a user, 
# granting geekpoints
# changing users password
# 
sub user_admin_handler
{
	my $state = shift;
	my $q     = $state->{q};
	my $target_user = $q->{username};
	my $action = $q->{action};
	my $template = "$Template_Dir/generic.html";

	my $fail = sub {
		my $why = shift || "Unable to process request";
		return output_template($template, $state, errors => $why);
	};
	
	my @errors = ();
	$state->{ipe} ||= UFIPE->new;
	my $ipe = $state->{ipe};
	$ipe->clear;
	eval { $ipe->load( USERNAME => $target_user ) };
	return $fail->("Unable to load user $target_user") if $@;

	my $result = '';

	if ($action eq 'Disable') {
		$ipe->DISABLED( time );
		$ipe->ADMIN_COMMENT( $q->{ADMIN_COMMENT} );
		eval { $ipe->save };
		if($@) {
			push @errors, "Unable to save newly-disabled user: $@";
		} else {
			$result = "User disabled successfully";
			audit_log("Admin user $state->{login_user} has disabled user $target_user for: $q->{ADMIN_COMMENT}\n");
		}
	} elsif($action eq 'Enable') {
		$ipe->DISABLED( '' );
		eval { $ipe->save };
		if($@) {
			push @errors, "Unable to save newly-enabled user: $@";
		} else {
			$result = "User enabled successfully";
			audit_log("Admin user $state->{login_user} has reenabled user $target_user");
		}
	} elsif(!$action) {
		push @errors, "What do you wish to do with/to this user?" unless @errors;
	} else {
		push @errors, 'Invalid action specified';
	}

	my $enable_str = qq{<input type=submit name=action value="Enable">};
	my $disable_str= qq{
		<p>&nbsp;<br>Reason for disabling:<input type=text name=ADMIN_COMMENT size=40>
		<input type=submit name=action value="Disable">
	};
	my $status = '';
	my $ADMIN_COMMENT = $ipe->ADMIN_COMMENT;
	if($ipe->DISABLED) {
		$disable_str = '';
		my $date = int($ipe->DISABLED)>86401 ? (join" ",(split(" ",scalar localtime($ipe->DISABLED)))[1,2,4]) : "(unknown date)";
		$status = "<b>Disabled</b> on $date for: " . ($ADMIN_COMMENT || "No reason given");
	} else {
		$enable_str = '';
		$status = 'Enabled';
	}

	$result = "<h2>$result</h2>" if $result;
	my $form = join "", $result, map { "<h2>$_</h2>\n" } @errors;
	$form .= <<"EOF";
<table border=0 width="80%"><tr><td>&nbsp;</td></tr><tr><td align=left>
<form method=post>
<input type=hidden name=username value="$target_user">
Hapless user: $target_user<br>
Status: $status<br>
$enable_str $disable_str<br>
</form>
</td></tr></table>
EOF

	return output_template($template, $state, uf_content => $form);

}

##############################################################################

# Admin new top-level content
register 'create_article.cgi' => admin_only \&emit_new_article_form;
register 'post_article.cgi'   => admin_only cachebust \&post_new_article_form;
register 'list_articles.cgi'  => admin_only cachebust \&emit_approve_form;
register 'approve.cgi'        => admin_only cachebust \&post_approve_form;

# Admin existing comment conten
register 'moderate.cgi'       => admin_only cachebust \&emit_moderate_form;
register 'mchange.cgi'        => admin_only cachebust \&post_moderate_form;

# Admin user
register 'user.cgi'           => admin_only cachebust \&user_admin_handler;

1;
__END__

                                                                                                                                                                                                                                                                                                                                                                                                                                                   perl/ARSHandler/Comment.pm                                                                          0100644 0000000 0000000 00000017660 07466335257 014435  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ;# $Id: Comment.pm,v 1.21 2002/05/08 23:54:23 cvsars Exp $
;#
;# ARSHandler::Comment - Request handler plug-in that handles comment view/post
;#
use strict;


#########################################################################
#
# URL handlers
# 
#########################################################################

# 
# Handles /foo/?baz=blech and /foo/read.cgi?baz=blech, which
# comprise over 90% of the activity on the site
# this handles viewing the archives, and viewing the comments 
# attached to postings and cartoons
# 
sub read_handler 
{
	my $state=shift;

	# if cartoons, supply a default id of today
	$state->{id} ||= date_numeric_string(time) if $state->{path} eq 'cartoons';

	my $comment_mode_bar = "";
	my $article = get_article($state);
	my $threads ="";

	if ($state->{id} && ($state->{tid} || $state->{is_valid_article})) {
		if($state->{tid}) {
			$threads .= build_link_back_to_index($state);
			$threads .= get_single_comment($state);
		} else {
			$comment_mode_bar = comment_mode_bar($state);
			$threads .= get_comments($state);
		}
	}
		
	my $template="$Template_Dir/comment.html";
	return output_template($template, $state, 
		uf_content => $article, threads => $threads, 
		comment_mode_bar => $comment_mode_bar ) ;
}


sub emit_comment_form 
{
	my $state=shift;

	# Suppress reply buttons -- we're already replying
	$state->{noreply} = 1;
	
	my $template ="$Template_Dir/post.html";

	my $article = "";

	# are we replying to a thread?
	if ( $state->{tid} ){
		# yes, show parent article
		$state->{suppress_ancestors}=1;
		$state->{suppress_children}=1;
		my ($output, $username, $subject) = get_single_comment($state);
		$article .= build_link_back_to_index($state);
		$article .= "<p><b>$username wrote:</b><br>";
		$article .= $output;
		#FIXME: we may need to copy content of parent article into 
		# $state->{message} with '>' line prefix. 
		# We can live without that, short term. This is not usenet
	} else {
		# no, show uf content

		# Prevent posting new top-levels as necessary
		return error_nopost($state) if $state->{nopost};

		$article .= get_article($state);
		$article .= build_link_back_to_index($state);
	}

	my $buttons= '<input type="submit" name="submit_type" value = "Preview">';

	# handle SUBMIT/PREVIEW actions in forms
	# we always show a preview button first. 
	# is this a reply?
	if ( _was_preview_request($state) ) {
		# Add a submit if the user pressed preview
		$buttons .= '<input type="submit" name="submit_type" value = "Submit">';
		$article .= preview_new_comment($state);
	}

	$HTML_Fixer ||= ARS_FixHTML->new;
	my $instructions = "<font size=-1 color=#888888>Permitted HTML: " . $HTML_Fixer->allowed_tags_as_html . "</font>";

	# XXX This is a horrible, horrible hack.  Immediately before outputting form,
	# so it won't interfere with other uses of the subject, we're going to escape
	# quotes in the subject.
	$state->{subject} =~ s/\"/\&quot\;/g;

	return output_template($template, $state, 
		article => $article, buttons => $buttons, instructions => $instructions );
}


sub error_permissions
{
	my $state=shift;
	return report_error($state, qq|
		Your Posting has been denied, please see our terms and conditions. .<p>
		<a href="t_c.html">Here</a>
	|);
}


sub error_nopost
{
	my $state=shift;
	return report_error($state, qq|
		You don't have permission to post new top-level comments 
		to this location.<p>
		You can always post to
		<a href="users/diary151f.html?id=$state->{login_user}">
		your own diary</a> instead.<p>
	|);
}


#
# Add (n/t) to a subject that doesn't already have it
#
sub notextify
{
	local $_ = shift;
	return $_ if m#\bn[-/]?t\b#i;
	$_ = substr($_, 0, 74) if length($_) > 75;
	$_ .= " (n/t)";
	return $_;
}


#
# If body empty, add (n/t) to subject and body.
#
sub maybe_notextify
{
	my $state = shift;
	return $state if $state->{subject} =~ /^\s*$/;

	local $_ = $state->{message};
	if( /^\s*$/ || /^\s*\(?n[\-\/]t\)?\s*$/i ) {
		$state->{subject} = notextify($state->{subject});
		$state->{message} = "(n/t)";
	}

	$state;
}


#
# preview new comment - formats potential user comment
# using standard api tool bypassing db query 
#
sub preview_new_comment
{
	my $state   = shift;
	my $id      = $state->{id};
	my $tid     = $state->{tid};
	my $level   = get_comment_parent_level($state)+1;
	my $path    = $state->{path};
	my $src_ip  = $ENV{REMOTE_HOST};
	maybe_notextify($state);
	
	$HTML_Fixer ||= ARS_FixHTML->new;
	$HTML_Fixer->warn_closetags(0);
	my $message = $HTML_Fixer->convert_html( $state->{message} );
	my $subject = $HTML_Fixer->defang( $state->{subject} );

	my $output= "Note: Source IP Logged $src_ip" . $state->{tid} 
		? "<P><B>...to which you are thinking of replying:</B><p>\n"
		: "<P><B>Preview New Comment</B><P>";

	# Undef the tid for here
	$output .= display_comment(0,$id,undef,$level,
		$subject,$message,"",$state->{login_user},"Very Soon...","",$path,1);
}


sub _was_preview_request
{
	my $state = shift;
	my $r     = $state->{r} || Apache->request;
	my $method= $r->method;
	my $st    = $state->{submit_type};
	return if $method eq 'GET';
	return 0 if $st eq 'Submit';
	return 1;
}


#
# post comment form. Sanity checks then inserts 
# new comment into appropriate table
# 
sub post_comment_form 
{
	my $state=shift;

	# Prevent posting new top-levels as necessary
	return error_nopost($state) if $state->{nopost} && !$state->{tid};
	return error_permissions($state) if  $state->{ipe}->DISABLED;
	# Switch to preview if necessary
	return emit_comment_form($state) if _was_preview_request($state);

	maybe_notextify($state);

	$state->{subject} = $HTML_Fixer->defang( $state->{subject} );
	$HTML_Fixer ||= ARS_FixHTML->new;
	$HTML_Fixer->warn_closetags(0);
	$state->{message} = $HTML_Fixer->convert_html( $state->{message} );

	my @errors=();
	push @errors , "Subject is too short" unless length $state->{subject} > 1;
	push @errors , "Subject is empty"    if $state->{subject} =~ /^\s*$/;
	push @errors , "Message is empty"    if $state->{message} =~ /^\s*$/;
	push @errors , "Subject is too long" if length $state->{subject} > 80;
	push @errors , "Message is too long" if length $state->{message} > 7900;
	
	# Do we have a valid cartoon or article?
	if ( $state->{path} eq "cartoons" ) {
		push @errors, "Cartoon for $state->{id} does not exist" 
			unless valid_cartoon($state->{id}) ;
	} elsif ( ! article_exists( $state->{id}, $state->{article_table} ) ) {
		push @errors, "Article " . $state->{id} . " does not exist";
	}
	
	# puke if errors
	if( @errors ) {
		my $errors="<P>Comment Post <B>Not Successful</b> because of following errors:<BR>";
		
		foreach (@errors) { $errors .= "$_<BR>\n"; }

		$state->{errors}=$errors;
		return emit_comment_form($state);
	}

	# insert this reply, returning its new thread id
	$state->{tid} = insert_comment($state);

	my $url = add_state_to_url($state, "/$state->{'path'}/", qw(id tid));
	return redirect_to_cachebusted_url($state, $url);
}


# emit email form. Email this to a friend. form handler is
# a cgi on another machine, currently
# 
sub emit_email_form 
{
	my $state=shift;

	my $template ="$Template_Dir/email.html";

	my $article = get_article($state);

	return output_template($template, $state, 
		uf_content => $article ) ;

}

##############################################################################
#
# Add to the dispatch table
#
##############################################################################
# syntax is register 'URI' => attrib_routines \&subroutine name
# note that attrib_routines set up or check various items in $state

register 'emailstrip.cgi' => cachebust \&emit_email_form;
register 'postn.cgi' => require_login cachebust \&post_comment_form;
register 'postr.cgi' => require_login cachebust \&post_comment_form;
register 'post.cgi'  => require_login cachebust \&emit_comment_form;
register 'reply.cgi' => require_login cachebust \&emit_comment_form;
register 'read.cgi'  => require_login_for_path "newsletter", \&read_handler;

# We'll also take over as the default handler.
register DEFAULT     => require_login_for_path "newsletter", \&read_handler;

1;
__END__

                                                                                perl/ARSHandler/User.pm                                                                             0100644 0000000 0000000 00000063045 07553333347 013742  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ;# $Id: User.pm,v 1.23 2002/10/16 18:58:47 cvsars Exp $
;#
;# ARSHandler::User - Request handler plug-in that handles user login etc.
;#

use strict;

# System includes
use Digest::MD5;


##################################################################
#
# User Admin URL handlers
#
##################################################################


#
# User administration request
#
# Cases:
#    - Not logged in? Redirect to login page.
#    - Empty request? Display form filled out with user rec.
#      - Assume request is empty if submit button name not present
#    - Request with partial or invalid data? Display form with corrections in red
#      - If data validation fails, do this
#    - Complete and valid submission?  Store to DB and display thankspage
#      - If data validation succeeds, do this
#
sub handle_user_account
{
	my $state = shift;
	my $q     = $state->{q};

	my $template = "$Template_Dir/generic.html";
	
	my $ipe = $state->{ipe} ||= UFIPE->new;
	eval { $ipe->load(USERNAME => $state->{login_user}) };
	
	# Is he even logged in?
	if($@ || !$state->{login_user}) {
		return output_template($template, $state, uf_content => q{
			You must be <a href="login.html">logged in</a> to edit your settings.<p>
		});
	}

	$state->{refer} = $q->{refer} if $q->{refer};

	# See if we need to save this record
	my $saveable = $q->{Submit} ? 1 : 0;

	# Stash a copy of the current diary content, so we can check later
	# whether they've changed it
	my $old_diarycontent = $ipe->DIARYCONTENT;

	my %errors = ();
	if($saveable) {
		# Copy posted data into IPE obj

		# Simple Fields
		foreach my $field (qw(LISTMAIL SECMAIL DIARYCONTENT WANTAD MEMBADDR MEMBNAME MEMBCITY MEMBPROV MEMBCODE MEMBCTRY)) {
			my $meth = $ipe->can($field) or next;
			eval { $ipe->$meth( $q->{$field} ) };
			if($@) {
				$errors{$field} = $ipe->splain($@) . "<br>";
				# XXX FIXME: This is _FUGLY_ but we need to break encapsulation 
				# until we fix the misuse of the IPE object to stash the form contents
				$ipe->{$field} = $q->{$field};
			}
		}

		# Mailing lists
		foreach my $listname ($ipe->mailing_lists) {
			$ipe->list_subscription( $listname, $q->{"list_$listname"} );
		}

		# Binary preferences
		$ipe->preference( $_, $q->{"pref_$_"} ) for $ipe->prefs;

		%errors = validate_user_data($ipe) unless %errors;
		$saveable=0 if %errors;
	}
	
	if($saveable && !%errors) {
		$ipe->save;

		# Install the diary content, if it has changed
		if($ipe->DIARYCONTENT ne $old_diarycontent) {
			$state->{id}       = $ipe->ID;
			$state->{headline} = "Diary of ";
			$state->{headline} .= $ipe->MTYPE . " " if ($ipe->MTYPE ne "User");
			$state->{headline} .= $ipe->USERNAME;
			$state->{message}  = $HTML_Fixer->convert_html( $ipe->DIARYCONTENT );
			$state->{expire}   = time + 86400*600;
			$state->{article_status} = 'active';
			set_article($state); 
		}
		
		# Copy prefs from IPE into state
		$state->{$_} = $ipe->preference($_) for $ipe->prefs;
		set_pref_cookie($state);
		return redirect_to_cachebusted_url($state, $state->{refer}) if $state->{refer};
		return output_template($template, $state, uf_content => q{
			Thank you!  Your settings have been saved successfully.<p>
		});
	}
	
	my $form_html = user_form_html($state, \%errors);

	$form_html .= "<p><br></p>" . build_change_password_form($state);

	return output_template($template, $state, uf_content => $form_html);
}


sub build_change_password_form
{
	my $state = shift;
	my $q     = $state->{q};
	my $cur   = $q->{current_password};
	my $new   = $q->{new_password};
	my $vfy   = $q->{verify_new_password};

	<<"EOF";
<p><br></p>
<p align=left><b>Change Your Password</b></p>
<form method=post action="http://ars.userfriendly.org/users/changepass.cgi">
<table border=0 cellspacing=0 cellpadding=2>
<tr><td>Current password:</td><td><input type=password name=current_password size=15 maxlength=15 value="$cur"></td></tr>
<tr><td colspan=2>&nbsp;</td></tr>
<tr><td>New password:</td><td><input type=password name=new_password size=15 maxlength=15 value="$new"></td></tr>
<tr><td>Verify new password:</td><td><input type=password name=verify_new_password size=15 maxlength=15 value="$vfy"></td></tr>
<tr><td colspan=2><input type=submit name=changepass value="Change Password"></td></tr>
</table>

EOF
}


sub post_change_password
{
	my $state    = shift;
	my $q        = $state->{q};
	my $template = "$Template_Dir/generic.html";
	
	my $current_password    = $q->{current_password};
	my $new_password        = $q->{new_password};
	my $verify_new_password = $q->{verify_new_password};

	my $fail = sub {
		my $why = shift || "Unable to change your password for some reason.";
		my $nobuild = shift;
		$why = "<h2>$why</h2>\n";
		my $uf_content = $nobuild ? "" : build_change_password_form($state);
		return output_template($template, $state, errors => $why, uf_content => $uf_content);
	};

	return $fail->("You must be logged in to change your password.",1) 
		unless $state->{login_user};

	my $ipe = $state->{ipe} or die "assertion failed: login_user but no ipe";

	return $fail->("Your current password was incorrect.") 
		unless $ipe->PASSWORD_check($current_password);
	
	return $fail->("You did not specify a new password.")
		unless $new_password;

	return $fail->("Your old password is the same as your new password.")
		if $new_password eq $current_password;

	return $fail->("The two copies of your new password were not the same.")
		unless $new_password eq $verify_new_password;

	$ipe->PASSWORD($new_password);
	eval { $ipe->save };
	return $fail->("Database problem saving your new password") if $@;
	
	$state->{login_pass} = $new_password;
	set_auth_cookie($state);
	
	return output_template($template, $state, 
		uf_content => "Your password was changed successfully.");
}


sub user_form_html
{
	my $state = shift;
	my $err   = shift;
	my %err   = %$err;
	my $ipe   = $state->{ipe};

	my @viewstyles = ( 
		classic   => "Classic View (No Comments)",
		indexed   => "Threads with full text of top level",
		thread    => "All comments as subject only", 
		nonthread => "All comments as full text",
	);

	$HTML_Fixer ||= ARS_FixHTML->new;

	my @form = (
		mem        =>{ type=>'label',label=>'User Status:' },
		refer      =>{ type=>'hidden', val=>$state->{refer} },
		MEMBER     =>{ type=>'ro'	,label=>'Member/Sponsor:'},
		MTYPE      =>{ type=>'ro'	,label=>'Type:'},
		WANTAD     =>{ type=>'bin'  ,label=>"Show Me Ads (even though I\'m a $ipe->{MTYPE})",
			memberonly => 'yes'  },
		spacer01   =>{ type=>'label',label=>'&nbsp;' },
		spacer02   =>{ type=>'label',label=>'Shipping Address',		memberonly => 'yes' ,},
		MEMBNAME   =>{ type=>'text' ,label=>'Member Billing Name',	memberonly => 'yes' ,},
		MEMBADDR   =>{ type=>'text' ,label=>'Address',			 	memberonly => 'yes' ,},
		MEMBCITY   =>{ type=>'text' ,label=>'City',					memberonly => 'yes' ,},
		MEMBPROV   =>{ type=>'text' ,label=>'Province or State', 	memberonly => 'yes' ,},
		MEMBCODE   =>{ type=>'text' ,label=>'Postal Code', 			memberonly => 'yes' ,},
		MEMBCTRY   =>{ type=>'text' ,label=>'Country', 				memberonly => 'yes' ,},
		EXPIRE     =>{ type=>'ro'   ,label=>'Sponsorship Expiry Date',memberonly => 'yes' ,
			val=> " " .  scalar( localtime ($ipe->{EXPIRE})) . ( ( $ipe->{EXPIRE} < time ) ? " <B>Expired</b>": "") ,},
		spacer0    =>{ type=>'label',label=>'&nbsp;', 				memberonly => 'yes' ,},
		emails     =>{ type=>'label',label=>'Email Addresses:' },
		SECMAIL    =>{ type=>'text' ,label=>'Real Email Address (never displayed):' },
		LISTMAIL   =>{ type=>'text' ,label=>'Mailing List Email Address (if different):' },
		spacer1    =>{ type=>'label',label=>'&nbsp;' },
		lists      =>{ type=>'label',label=>'Mailing List Subscriptions:' },
		lists_go_here => {},
		spacer2    =>{ type=>'label',label=>'&nbsp;' },
		preferences=>{ type=>'label',label=>'User-written Comments:' },
		prefs_go_here => {},
		spacer3    =>{ type=>'label',label=>'&nbsp;' },
		diary      =>{ type=>'label',label=>'Your User Diary' },
		DIARYCONTENT =>{type=>'bigtext'
									,label=>'Diary Top-Level Permanent Content:', rows=>7 },
		allowed    =>{ type=>'ro'	,label=>'&nbsp;', 
			val => "<font size=-1 color=#888888>Permitted HTML: " . 
					$HTML_Fixer->allowed_tags_as_html . "</font>" },
		spacer4    =>{ type=>'label',label=>'&nbsp;' },
		UPDATED    =>{ type=>'ro'  	,label=>'Last Update Date:' },
	);
	# Splice in mailing lists
	{
		my $i=0;
		my $idx=undef;
		my @maillists = ();
		foreach my $listname ($ipe->mailing_lists) {
			my $info = $ipe->mailing_list_info($listname);
			my $desc = $info->{DESCRIPTION};
			my $freq = $info->{FREQUENCY};
			$freq = " ($freq)" if $freq;
			my $ctl = { type=>'bin', label=>"$desc$freq" };
			push @maillists, "list_$listname";
			push @maillists, $ctl;
		}
		
		for($i=0; $i<@form; $i+=2) {
			($idx=$i, last) if $form[$i] eq 'lists_go_here';
		}

		splice @form, $idx, 2, @maillists if defined $idx;
	}

	# Splice in preferences
	{
		my $i=0;
		my $idx=undef;
		my @prefctls = ();
		foreach my $prefname ($ipe->prefs) {
			my $info = $ipe->pref_info($prefname);
			my $desc = $info->{desc};
			my $ctlname = "pref_$prefname";
			my $ctl = { type=>'bin', label=>$desc };
			push @prefctls, $ctlname;
			push @prefctls, $ctl;
		}

		for($i=0; $i<@form; $i+=2) {
			($idx=$i, last) if $form[$i] eq 'prefs_go_here';
		}

		splice @form, $idx, 2, @prefctls if defined $idx;
	}

	# Build a hash, and get a list of the key order
	my %form = @form;
	{ my $i; @form = grep { ++$i % 2 } @form; }

	my $out="<form method=post action=http://ars.userfriendly.org/"/users/acct.cgi/">";
	$out .= "<input type=hidden name=refer value=\"$state->{refer}\">";
	$out .= "<table>";
	foreach my $field (@form) {
		my $f     = $form{$field};
		if ($ipe->{MEMBER} eq 'no' && $f->{memberonly} eq 'yes' ) {
			next;
		}
		my $type  = $f->{type};
		my $label = $f->{label};
		my $err   = $err{$field};
		$label =~ s/ /&nbsp;/g;
		my $val = $f->{val} || '';
	
		# See if this is a mailing list
		if($field =~ /^list_(.*)$/) {
			$val = $ipe->list_subscription($1);
		} elsif($field =~ /^pref_(.*)$/) {
			$val = $ipe->preference($1);
		} else {
			# See if this is an IPE field
			my $meth = $ipe->can($field); 
			$val  ||= $meth ? $ipe->$meth() : '';
		}
		
		$out .= "<TR>";
		my $ltd = "<TD ALIGN=\"LEFT\" VALIGN=\"TOP\" WIDTH=\"1%\">";
		if($type eq "text") {
			$out .= qq{$ltd$label</TD><TD ALIGN="LEFT"><INPUT TYPE="TEXT" SIZE="35" MAXLENGTH="140" NAME="$field" VALUE="$val">};
		} elsif($type eq "hidden") {
			$out .= qq{<INPUT TYPE="HIDDEN" NAME="$field" VALUE="$val">};
		} elsif($type eq "bigtext") {
			my $rows = $f->{rows};
			$out .= qq{$ltd$label</TD><TD ALIGN="LEFT"><TEXTAREA COLS="55" ROWS="$rows" NAME="$field">$val</TEXTAREA>};
		} elsif($type eq "label") {
			$out .= qq{<TD ALIGN="LEFT" COLSPAN="2"><B>$label</B></TD>};
		} elsif($type eq "bin") {
			my $checked = ($val && $val ne "no") ? "checked" : "";
			$out .= qq{<TD ALIGN="LEFT" COLSPAN="2"><INPUT TYPE="CHECKBOX" NAME="$field" $checked> $label</TD>};
		} elsif($type eq "radio") {
			my $r="";
			my @opts = @{ $f->{list} };
			while(@opts) {
				my $oval   = shift @opts;
				my $olabel = shift @opts;
				my $selected = $val eq $oval ? ' CHECKED' : '';
				$r.= qq{<INPUT NAME="$field" TYPE="RADIO" VALUE="$oval" $selected>$olabel}
			}
			$out .= qq{$ltd$label</TD><TD ALIGN="LEFT">$r</TD>};	
		} elsif($type eq "list") {
			my $select = "<SELECT NAME=\"$field\">";
			my @opts = @{ $f->{list} };
			while(@opts) {
				my $oval   = shift @opts;
				my $olabel = shift @opts;
				my $selected = $val eq $oval ? ' SELECTED' : '';
				$select .= qq{<OPTION VALUE="$oval" $selected> $olabel}
			}
			$select .= "</SELECT>";
			$out .= qq{$ltd$label</TD><TD ALIGN="LEFT">$select</TD>};	
		} elsif($type eq 'ro') {
			$val ||= $f->{val};
			$out .= qq{$ltd$label</TD><TD ALIGN="LEFT">$val</TD>};
		}
		$err = "<FONT COLOR=\"RED\">$err</FONT>" if $err;
		$out .= "<TD ALIGN=\"LEFT\">$err</TD></TR>\n";
	}

	$out .= qq{<TR><TD ALIGN="LEFT" COLSPAN="2"><INPUT TYPE="SUBMIT" NAME="Submit" VALUE="Save User Settings"></TD></TR>};
	$out .= "</TABLE></FORM>";
	$out .= "<FORM></FORM>"; # whut?
	$out;
}

#
# validate_user_data
# 
# Usage: %errors = validate_user_data $ipe;
#
# Return values: List of (field1 => "Error message for field1", field2 => "Error..").
# This list will be empty if there were no errors.
#
sub validate_user_data
{
	my $ipe = shift;
	my $ok  = 1;
	my %f;
	my %errs=();
	tie %f, 'UFIPE::Tie', $ipe;

	# Validate email addresses
	my $is_valid_email = sub { $_[0] =~ /^(.*?)\@(.*)\.(.*)$/ };
	my @listsubs       = $ipe->LISTBITMAP;
	$errs{SECMAIL} .='Please enter a valid address.' unless $is_valid_email->($f{SECMAIL});
	%errs;
}


#
# Usage: $cookie = newpass_cookie($state, $userid, $newpass);
#
# Creates (or verifies) a cookie authorizing a password
# change of user ID 
#
sub newpass_cookie
{
	my $state   = shift;
	my $userid  = shift;
	my $newpass = shift;
	local $state->{login_user} = $userid;
	local $state->{login_pass} = $newpass;
	my $astr = build_auth_string($state, "127.57.23.92", $userid);
	join '_', $userid, substr(Digest::MD5::md5_hex($astr), 0, 8);
}


sub handle_forgot_password_email_link
{
	my $state    = shift;
	my $c        = $state->{q}{c};
	my $userid   = int($c);
	my $now      = time;
	my $template = "$Template_Dir/generic.html";

	return emit_user_login_form($state) unless $userid;

	my $fail = sub {
		my $why = shift;
		my $template = "$Template_Dir/generic.html";
		return output_template($template, $state, errors => $why);		
	};
	
	my $ipe = ($state->{ipe} ||= UFIPE->new);
	eval { $ipe->load( ID => $userid ) };
	return $fail->("Unable to find user ID $userid") if $@;

	my $newpass = $ipe->NEWPASS;
	return $fail->("We have no record of this password change.") unless $newpass;

	return $fail->("This password change is invalid, has expired, or has been superceded.")
		unless $c eq newpass_cookie($state, $userid, $newpass);

	if($now - $ipe->NEWPASS_DATE > 86400) {
		$ipe->NEWPASS('');
		$ipe->NEWPASS_DATE(0);
		$ipe->save;
		return $fail->("This password change request has expired.");
	}

	# All tests passed.  Assume this is a valid password change.
	$ipe->PASSWORD($newpass);
	$ipe->NEWPASS('');
	$ipe->NEWPASS_DATE(0);
	$ipe->save;

	my $username = $ipe->USERNAME;

	my $content = qq{
		Ok, the password for <b>$username</b> has been changed to the one
		given in the confirmation email.<p>
		You can use the login form below to see for yourself that it works.<p>
	} . build_user_login_form($state);
	
	return output_template($template, $state, uf_content => $content); 
}


sub mail_password
{
	my $state    = shift;
	my $username = $state->{q}{username};
	my $template = "$Template_Dir/generic.html";
	my $now      = time;
	
	my $fail = sub {
		my $why = (shift || "Unable to mail you a new password for whatever reason.");
		my $template = "$Template_Dir/generic.html";
		return output_template($template, $state, errors => $why);
	};
	
	my $ipe = ($state->{ipe} ||= UFIPE->new);
	eval { $ipe->load(USERNAME => $username) };
	return $fail->("Unable to find user: $username") if $@;
	
	my $addr = $ipe->SECMAIL;
	return $fail->("$username has no Real Email Address on file") unless $addr;

	if( $ipe->NEWPASS ) {
		if ($now - $ipe->NEWPASS_DATE > 86400) {
			$ipe->NEWPASS('');
			$ipe->NEWPASS_DATE(0);
		} else {
			my $date = localtime($ipe->NEWPASS_DATE);
			return $fail->(qq{
				<b>$username</b> already has a pending password change, requested on $date.<p>
				Check your email for
				the instructions; or, wait 24 hours and try again; or, email $Admin_Email
				for assistance.<p>
			});
		}
	}

	# Build a new password, and a secure cookie 
	my $b64 = Digest::MD5::md5_base64( rand_bytes() );
	$b64 =~ tr/a-zA-Z0-9_//cd;
	my $newpass = substr( $b64, 0, 10 );
	my $cookie = newpass_cookie($state, $ipe->ID, $newpass);
	my $url    = "$Domain/users/newpass.cgi?c=$cookie";
	my $date   = localtime(time);

	# Send the email
	send_email( 
		to => $addr, 
		subject => "Confirm UserFriendly ARS Password Request",
		body => <<"EOF",
Someone (hopefully you) has requested that the password for the 
UserFriendly ARS account "$username" be reset.  We've 
responded with this email to <$addr>, which 
is the "$username" account's registered Real Email Address.


   The password for the account: $username
   
              can be changed to: $newpass


To cause this change to occur, go to the following URL within 24 hours
of the date of this email:

  $url

To leave this account unchanged, ignore this email -- this password
change request will expire in 24 hours.


-----------------------------------------------------------------------
Technical information about the originator of this request:

       IP address: $ENV{REMOTE_ADDR}
      Web browser: $ENV{HTTP_USER_AGENT}
    Date and time: $date
-----------------------------------------------------------------------

EOF
	);

	$ipe->NEWPASS($newpass);
	$ipe->NEWPASS_DATE($now);
	$ipe->save;
	
	return output_template($template, $state,
		uf_content => "Ok, we've emailed instructions to <b>$username</b>.");
}


sub handle_forgot_password_form
{
	my $state = shift;
	my $q     = $state->{q};
	my $template = "$Template_Dir/generic.html";

	# Have we a complete request?
	return mail_password($state) if $q->{username};

	# Emit the form
	my $output = <<"EOF";
<table border=0><tr><td>
<form method=post>
If you have entered a valid Real Email Address, you can 
use the form below to cause a new password to be emailed
to you.<p>

Username: <input type=text name=username size=15 maxlength=15><p>
<input type=submit value="Mail me a new password">
</form>
</td></tr></table>
EOF

	return output_template($template, $state, uf_content => $output);
}

sub build_user_login_form 
{
	my $state=shift;
	my $t=_user_login_form($state);
	my $blurb = read_file("$Template_Dir/registration_blurb.html");
	my $full=<<EOF;
$t
<table border=0 width="100%"><tr><td align=left>
$blurb
</td></tr></table>
EOF
	return $full;

}

sub _user_login_form {
	my $state = shift;
	return <<"EOF";
<table border=0 width="100%">
<TD width="5%">&nbsp;</TD>

<TD align=left valign=top>
<table border=1 cellspacing=0 cellpadding=3 width=100%>
<tr><td bgcolor=#ffffcc><font size="+1"><b>Need an account?  Sign up here.</b></font></td></tr>
<tr><td bgcolor=#ffffee align=right>
<form method=post action="http://ars.userfriendly.org/users/register.cgi">
<input type=hidden name=refer value="$state->{refer}">
Desired&nbsp;Username:&nbsp;<input type=text name=login size=17 maxlength=15><br>
Desired&nbsp;Password:&nbsp;<input type=password name=password size=17 maxlength=15><br>
Verify&nbsp;Password:&nbsp;<input type=password name=verify_password size=17 maxlength=15><br>
<input type=submit value="Sign Up">
</form>
</td></tr>
</table>

<TD width="5%">&nbsp;</TD>

<TD align=left valign=top>
<table border=1 cellspacing=0 cellpadding=3 width="100%">
<tr border=1><td bgcolor=#ffffcc><font size="+1"><b>Already have an account?  Log in here.</b></font></td></tr>
<tr><td bgcolor=#ffffee align=right>
<form method=post action="http://ars.userfriendly.org/users/login.cgi">
<input type=hidden name=refer value="$state->{refer}">
Username:&nbsp;<input type=text name=user size=15 maxlength=15><br>
Password:&nbsp;<input type=password name=pass size=15 maxlength=15><br>
<input type=submit value="Log In">
</form>
</td></tr>
</table><br><font size=-1><div align=center>
<a href="users/forgot.html">
Help! I've forgotten my password!</a>
</div></font>
</TD>
</table>
EOF
}


sub emit_user_login_form
{
	my $state    = shift;
	$state->{auth_status} = '';
	my $template = "$Template_Dir/generic.html";
	my $form = build_user_login_form($state);
	return output_template($template, $state, uf_content => $form);
}


#
# Accept login requests.
#
# Before returning, we need to have replaced any 
# existing ars_user cookie with either a valid one
# or an empty one, depending on the success of the 
# credential verification here.
#
sub post_user_login_form
{
	my $state    = shift;
	my $q        = $state->{q};
	my $user     = $q->{user};
	my $pass     = $q->{pass};
	my $template = "$Template_Dir/generic.html";
	
	$state->{refer} = $q->{grab_refer} ? $ENV{HTTP_REFERER} : $q->{refer};
	
	my $fail = sub { 
		my $othermess = shift;
		$othermess = "your login name or password was incorrect." unless defined $othermess;
		$othermess = qq{<h2><font color=red>Login failed</font>: $othermess.</h2>} if $othermess;
		my $template = "$Template_Dir/generic.html";
		$state->{auth_status} = '';
		$state->{cookie_out} = build_logout_cookie($state);
		my $form = build_user_login_form($state);
		return output_template($template, $state, 
			uf_content => $form,
			errors => $othermess,
		) ;
	};
	
	# Innocent until proven guilty
	return $fail->('') unless $user && $pass;
	my $ipe = $state->{ipe} ||= UFIPE->new;
	eval { $ipe->load( USERNAME => $user ) };
	return &$fail if $@;
	return &$fail("Your password was incorrect.") unless $ipe->PASSWORD_check($pass);
	if($ipe->DISABLED) {
		my $date = int($ipe->DISABLED) > 86401 ? localtime($ipe->DISABLED) : '';
		$date = " on " . join " ", (split " ", $date)[1,2,4] if $date;
		my $reason = $ipe->ADMIN_COMMENT ? (" for: " . $ipe->ADMIN_COMMENT) : '.';
		my $tense = $date ? "was" : "has been";
		return &$fail("Your account $tense disabled$date$reason");
	}

	# Innocent.
	$state->{login_user} = $q->{user};
	$state->{login_pass} = $q->{pass};
	$state->{auth_status}= "Logged in as: <b>$user</b><br>" . login_links($state);
	set_auth_cookie($state);

	return redirect_to_cachebusted_url( $state, $state->{refer} ) if $state->{refer};
	return output_template($template, $state, uf_content => qq{
		<h2>You are now logged in as $user.</h2>
	});
}


sub logout_handler
{
	my $state    = shift;
	my $template = "$Template_Dir/generic.html";
	my $q= $state->{q};
	$state->{login_user} = '';
	$state->{login_pass} = '';
	$state->{auth_status} = '';
	$state->{cookie_out} = build_logout_cookie($state);
	$state->{refer} = $q->{refer} || $ENV{HTTP_REFERER};
 	return redirect_to_cachebusted_url( $state, $state->{refer} ) if $state->{refer};
	return output_template($template, $state, 
		errors => qq{<p>You are now logged out.</p>},
		uf_content => build_user_login_form($state),
	); 
}


sub handle_user_register
{
	my $state    = shift;
	my $q        = $state->{q};
	my $template = "$Template_Dir/generic.html";

	$state->{refer} = $q->{refer} if $q->{refer};

	my ($login, $static, $password, $verify_password) = @$q{qw(
	     login   static   password   verify_password
	)};

	my $fail = sub {
		my @errors= @_;
		my $errors = "<h2>Registration <b><font color=red>not</font></b> successful because of the following errors:</h2>";
		$errors .= "<h2><b>$_</b><h2>\n" for @errors;
		$state->{errors} = $errors;
		return emit_user_login_form($state);
	};
	
	my @errors=();
	push @errors, "Username must be 3-15 alphanumeric characters in length"
		if $login !~ m/^[a-zA-Z][a-zA-Z0-9\_\-\. ]{2,14}$/;
	push @errors, "Your password must be at least 3 characters long."
		if length($password) < 3;
	push @errors, "You seem to have mistyped one of your passwords."
		if $password ne $verify_password;
	return $fail->(@errors) if @errors;

	my $ipe = $state->{ipe} ||= UFIPE->new;
	$ipe->clear;
	eval { $ipe->load( USERNAME => $login ) };
	return $fail->('The username you have chosen is unavailable.') unless $@;
	return $fail->('The username you have chosen is unavailable.') if $ipe->ID;

	$ipe->clear;
	$ipe->USERNAME( $login );
	$ipe->PASSWORD( $password );
	$ipe->GEEKPTS( $Geekpoints_Starting );
	eval { $ipe->save };

	if ($@) {
		warn "register_handler(): $@\n";
		return $fail->(qq{
			Unable to create your account due to a database error.<br>
			If this persists, contact <a href="mailto:$Admin_Email">$Admin_Email</a>
			for assistance.<br> Sorry about this. :(
		});
	};

	$state->{login_user} = $login;
	$state->{login_pass} = $password;
	set_auth_cookie($state);
	return redirect_to_cachebusted_url($state, "/users/acct.cgi?refer=" . UFCGI::escape($state->{refer}) );
}


sub emit_user_search_form
{
	my $state = shift;
	my $msg   = shift;

	return report_error( $state, $msg . user_search_form($state) );
}


sub handle_user_diary
{
	my $state    = shift;
	my $username = $state->{q}{id};
	
	return emit_user_search_form($state) unless $username;

	# Look up this user
	my @loadargs = ($username =~ /^\d+$/) ? (ID => $username) : (USERNAME => $username);
	my $hisipe = UFIPE->new;
	eval { $hisipe->load( @loadargs ) };
	return emit_user_search_form($state, "<b>User \"$username\" is unknown.</b><br>\n") if $@;
	$state->{id} = $hisipe->ID;
	
	# XXX Undo grotesque hack from inner_handler, rather than fix the root of the evil :)
	$state->{nopost}=0 if $state->{login_user} eq $username;

	$state->{title} = "UF - User Diary for ";
	$state->{title} .= " $hisipe->{MTYPE} " if ($hisipe->{MTYPE} ne 'User');
	$state->{title} .=  $username ;
	$state->{title} .= " (Moderator)" if ($hisipe->{TYPE} ne 'user');

	return read_handler($state);
}

################################################################
#
# Register URLS
#
################################################################

register '/users/acct.cgi'       
	=> cachebust retitle "UF - User Account Settings", 
	\&handle_user_account;
	
register '/users/changepass.cgi'
	=> cachebust retitle "UF - Change Password",
	\&post_change_password;

register '/users/register.cgi'
	=> cachebust retitle "UF - User Registration",
	\&handle_user_register;
	
register '/users/logout.cgi'
	=> cachebust retitle "UF - User Logout",
	\&logout_handler;

register '/users/forgot.cgi'
	=> cachebust retitle "UF - Password Change",
	\&handle_forgot_password_form;
	
register '/users/newpass.cgi'
	=> cachebust retitle "UF - Password Change",
	\&handle_forgot_password_email_link;

register '/users/login_form.cgi'
	=> cachebust retitle "UF - User Login",
	\&emit_user_login_form;

register 'login.html'
	=> cachebust retitle "UF - User Login",
	\&emit_user_login_form;

register 'register.html'
	=> cachebust retitle "UF - User Login",
	\&emit_user_login_form;

register '/users/login.cgi'
	=> cachebust retitle "UF - User Login",
	\&post_user_login_form;

register '/users/diary.cgi'
	=> \&handle_user_diary;

1;
__END__
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                           perl/ARSHandler/Member.pm                                                                           0100644 0000000 0000000 00000073516 07600021351 014215  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ;# $Id: Member.pm,v 1.6 2002/12/18 07:24:10 cvsars Exp $
;#
;# ARSHandler::Member - membership/sponsorship code
;#

use strict;

############################################################
#
#  Url handlers
#
############################################################

sub save_address_data
{
	my $state    = shift;
	my $q        = $state->{q};
	my $template = "$Template_Dir/generic.html";
	$state->{refer} = $q->{refer} if $q->{refer};
	if ($q->{no} ) {
		return redirect_to_cachebusted_url($state,"/")
	}
	##################
	#
	# Save membership request items in IPE, then build the paypal request form
	#
	##################
		
	my $ipe = $state->{ipe} ||= UFIPE->new;

	eval { $ipe->load(USERNAME => $state->{login_user}) };
	
	# Save Survey data
	my %rechash=();
	foreach my $field (qw(gender age job_title income other )) {
		$rechash{$field}=$q->{$field};
	}
	# bah. "other" 

	if ($rechash{"other"}) {
		$rechash{"job_title"}=$rechash{"other"};
	}
	delete $rechash{"other"};
	my $id_of_surveydata = insert_survey("survey", \%rechash);

	# note for privacy seekers. rechash contains only the above listed fields
	# and we throw away its id. No way to recover relationship. 
	# 

	my %errors = ();

	# Copy posted data into IPE obj
	# Simple Fields

	foreach my $field (qw(MEMBNAME MEMBADDR MEMBCITY MEMBPROV MEMBCODE MEMBCTRY TSHIRT MEMBPHON MEMBEMAI)) {
			my $meth = $ipe->can($field) or next;
			eval { $ipe->$meth( $q->{$field} ) };
			if($@) {
				$errors{$field} = $ipe->splain($@) . "<br>";
				# XXX FIXME: This is _FUGLY_ but we need to break encapsulation 
				# until we fix the misuse of the IPE object to stash the form contents
				$ipe->{$field} = $q->{$field};
			}
		}

	%errors = validate_memb_data($ipe,$q->{sponsorlevel}) unless %errors;

	my $Errorlist;
	foreach ( keys (%errors)  ) {
		$Errorlist.="<BR>$_ : $errors{$_}\n"
	}

	open (LOGFILE,">>/tmp/sponsorattempts.log");
	print LOGFILE "$state->{login_user} attempted signup   Date:";
	print LOGFILE scalar localtime() . "\n";	
	close LOGFILE;

	print STDERR "$Errorlist";

	if( ! $Errorlist ) {
		$ipe->save;
		my $form_html = purchase_html($state);
		return output_template($template, $state, uf_content => $form_html);
	}
	my $form_html = sponsor_form($state, \%errors);
	return output_template($template, $state, uf_content => $form_html);
}

sub purchase_form
{
	my $state    = shift;
	my $q        = $state->{q};
	my $template = "$Template_Dir/generic.html";
	my $form_html = purchase_html($state);
	return output_template($template, $state, uf_content => $form_html);
}


sub purchase_html
{
	my $state = shift;
	my $q=$state->{q};
	my $sponsorlevel=$q->{sponsorlevel};
	my $upgrade=$q->{upgrade};
	my %spiff=%{$Spiff{$sponsorlevel}};
	my $spiff=$spiff{text};
	my $code=$spiff{code};
	my $ccost=$spiff{ccost};
	my $ucost=$spiff{ucost};
	my $term=$spiff{term};
	my $Address=address_display($state);
	my $mtype=$state->{ipe}->{MTYPE};
	my $upgtxt="";
	if ($mtype ne $sponsorlevel ) {
		$upgtxt="Changing existing account from $mtype to $sponsorlevel"; 
	} else {
		$upgtxt="Extending existing account"; 
	}
	if ($mtype ne "User" && $upgrade eq "Y") {
		$ccost-=58;
		$ucost-=36;
		$upgtxt=<<EOF;
Apply my membership towards an Upgrade. <BR>
DISCOUNT: Take \$36.00 USD/ \$58.00 CAD off price, ship me the goodies.<P>

EOF
	}
	#modify prices for upgrade.
	#
	# gaaaaah multiple prices
	my $c= ($state->{ipe}->{MEMBCTRY} eq "CA" or  $state->{ipe}->{MEMBCTRY} eq "US") ? 
			$state->{ipe}->{MEMBCTRY} : "DF";
	my $CShipping=0; 
	my $UShipping=0;
	if ($sponsorlevel ne "Member") {
		$CShipping= $Shipping{"CAD"}->{$c};
		$UShipping= $Shipping{"USD"}->{$c};
		$ucost+=$UShipping;
		$ccost+=$CShipping;
	}
	$CShipping=sprintf ("%10.2f",$CShipping);
	$UShipping=sprintf ("%10.2f",$UShipping);
	$ccost=sprintf ("%10.2f",$ccost);
	$ucost=sprintf ("%10.2f",$ucost);
	my $time = scalar localtime();
	my $t=time() ;
	#FIXME: Order number is constant + ID.
	my $order=$state->{ipe}->{ID} + 9000000;
	my $monthly = ($sponsorlevel eq "Member") ? monthly($state,$t) : "";
	return <<"EOF";
<table border=0 width="100%">
<TD width="5%">&nbsp;</TD>
<TD align=left valign=top>
<table border=1 cellspacing=0 cellpadding=3>
<tr><td bgcolor=#ffffcc><font size="+1"><b>UF Sponsorship Payment</b></font></td></tr>
<tr><td bgcolor=#ffffee>
<TABLE width="99%">
<TR><TD width="33%" valign="top">
$upgtxt
<B>Username:</b> $state->{login_user}<BR>
<B>Userid: </b> $state->{ipe}->{ID}<BR>
<B>Shipping Address</B><BR>
$Address
</TD>
<TD width="33%" colspan=3 valign="top">
<B>$sponsorlevel Sponsorship Features</B><BR>
$spiff

<P>
Your Shipping is:<BR>
(USD) $UShipping / (CAD) $CShipping 

<P>Your total UF Sponsorship:

<H4>(USD) \$ $ucost / (CAD) \$ $ccost</H4>


</TD>
<TR>
<TD colspan=5 align=left>
<B>To complete your UF Sponsorship please choose one of the following payment options: 
</B></td>
</TR>
<TR>
<TD width="32%" valign="top">
<H3>Paypal</H3>

If you do not have a PayPal account, PayPal will guide you through a first-time PayPal account set up. 
<P>Paypal is US funds only.<BR>
<P>
<form action="https://www.paypal.com/cgi-bin/webscr" method="post">
<input type="hidden" name="cmd" value="_xclick-subscriptions">
<input type="hidden" name="business" value="member\@userfriendly.org">
<input type="hidden" name="item_name" value="UF $sponsorlevel Sponsorship">
<input type="hidden" name="item_number" value="$code#/$state->{ipe}->{ID}#$upgrade">
<input type="hidden" name="no_shipping" value="1">
<input type="hidden" name="return" value="users/paypal0ef2.html?accept=yes\&amp;code=$code&amp;t=$t">
<input type="hidden" name="cancel_return" value="users/paypalc320.html?accept=no">
<input type="hidden" name="no_note" value="1">
<input type="hidden" name="a3" value="$ucost">
<input type="hidden" name="p3" value="1">
<input type="hidden" name="t3" value="$term">
<input type="hidden" name="sra" value="1">
<input type="image" src="http://images.paypal.com/images/x-click-but20.gif" border="0" name="submit" alt="Make payments with PayPal">
</form>
<B>Note: Allow 24-48 hours for account activation. You will receive
your bonus merchandise in 4 to 6 weeks.</B>
<P>
</TD>
		<TD width="1%"VALIGN="top">
&nbsp;
		</TD>
<TD width="32%" valign="top">
<H3>Cheque or Money Order</H3>

<P><B>Print 2 copies of this page</B><BR>
Keep one copy for your records and send one copy with your payment.

<PRE>
UF Sponsorship for user "$state->{login_user}" 
Userid:  $state->{ipe}->{ID}
Sign Up Date: $time

Make cheques or money orders payable to:
UF Media Inc
c/o 2105 Scarboro Avenue
Vancouver, BC V5P 2L2
Canada
</PRE>
<P>Cheques and Money Orders can be made in either US or CAD funds.
<BR><B>Note: Your account will be activated when we receive payment. You will
receive your bonus merchandise in 8 to 10 weeks.</B>
</TD>
		<TD width="1%"VALIGN="top">
&nbsp;
		</TD>

<TD width="32%" valign="top">
<H3>Credit Card</H3>

We use <a href="http://www.beanstream.com/">Beanstream</a> as our Credit Card payment processor. 
<P>Credit Card payments are billed in CAD funds only.
<P>

<form method=post action="https://www.beanstream.com:443/scripts/payment/payment.asp">
<input type=hidden name=merchant_id value="110090000">
<input type=hidden name=trnOrderNumber value="$order">
<input type=hidden name=trnAmount value="$ccost">
<input type=hidden name=ordName value="$state->{ipe}->{MEMBNAME}">
<input type=hidden name=ordAddress1 value="$state->{ipe}->{MEMBADDR}">
<input type=hidden name=ordProvince value="$state->{ipe}->{MEMBPROV}">
<input type=hidden name=ordCity value="$state->{ipe}->{MEMBCITY}">
<input type=hidden name=ordPostalCode value="$state->{ipe}->{MEMBCODE}">
<input type=hidden name=ordCountry value="$state->{ipe}->{MEMBCTRY}">
<input type=hidden name=ordEmailAddress value="$state->{ipe}->{SECMAIL}">
<input type=hidden name=ref1  value="$code#$state->{ipe}->{ID}#$upgrade">
<input type=hidden name=ref2  value="$t">
<input type=image name=creditcards.gif src="../www.userfriendly.org/images/siteart/creditcards.gif">
</form>
<B>Note: Allow 24-48 hours for account activation. You will receive
your bonus merchandise in 4 to 6 weeks.</B>

</TD>
</TR>
$monthly
</td></tr>
</table>
</table>
EOF

}


sub back_from_creditcard
{
	my $state    = shift;
	my $q        = $state->{q};
	my $template = "$Template_Dir/generic.html";

	my $ipe = $state->{ipe} ||= UFIPE->new;
	my $logmessage;
	my $thankyou;
	if ($q->{"accept"} eq "no" ) {
		$logmessage = "User $state->{login_user} refused creditcard";
		$thankyou="Thanks for taking the time. Hopefully in the future you will sign up";
		$ipe->MEMBDATE( "Refused Credit Card");
	} elsif ($q->{"accept"} eq "yes" ) {
		$logmessage = "User $state->{login_user} accepted creditcard";
		$thankyou="Thanks for taking the time and giving us your support. Your sponsorship will be activated soon";
	}

	open (LOGFILE,">>/tmp/membership.log");
	print LOGFILE $logmessage . "  Date: ";
	print LOGFILE scalar localtime() . "\n\n";
	close LOGFILE;
	return output_template($template, $state, uf_content => $thankyou);
}


sub back_from_paypal
{
	my $state    = shift;
	my $q        = $state->{q};
	my $template = "$Template_Dir/generic.html";

	my $ipe = $state->{ipe} ||= UFIPE->new;
	my $logmessage;
	my $thankyou;
	eval { $ipe->load(USERNAME => $state->{login_user}) };
	foreach my $field (qw(MEMBDATE)) {
			my $meth = $ipe->can($field) or next;
			eval { $ipe->$meth( $q->{$field} ) };
			if($@) {
				$ipe->{$field} = $q->{$field};
			}
		}

	if ($q->{"accept"} eq "no" ) {
		$logmessage = "User $state->{login_user} refused paypal";
		$thankyou="Thanks for taking the time. Hopefully in the future you will sign up";
		$ipe->{MEMBDATE} = "Refused Paypal";
		$ipe->save;
	} elsif ($q->{"accept"} eq "yes" ) {
		$logmessage = "User $state->{login_user} accepted paypal";
		$thankyou="Thanks for taking the time and giving us your support. Your membership will be activated soon";
		$ipe->{MEMBDATE} = time() . " Date: " . localtime();
		$ipe->save;
	} else {
		$logmessage = "User $state->{login_user} has an error in paypal";
		$thankyou="Problem registering account. If you reached this page please contact us at membership\@userfriendly.org";
	}

	open (LOGFILE,">>/tmp/membership.log");
	print LOGFILE $logmessage . "  Date: ";
	print LOGFILE scalar localtime() . "\n\n";
	close LOGFILE;
	return output_template($template, $state, uf_content => $thankyou);
}


sub emit_choice
{
	my $state    = shift;
	my $q        = $state->{q};
	my $template = "$Template_Dir/generic.html";

	unless( $state->{login_user} ) {
			# No.. send them to the login form first.
			$state->{refer} =  $ENV{REQUEST_URI};
			my $form_source= "$Template_Dir/sponsorshiphelp.html";
			# give them some help
			my $content=read_file($form_source);
			$content .= _user_login_form($state);
			# tack on the login form
			return output_template($template, $state, uf_content => $content);
	}

	# FIXME: if not logged in, jump off to get a login or a membership, then come back here
	#
	my $form_source= "$Template_Dir/choice.html";
	my $content=read_file($form_source);
	return output_template($template, $state, uf_content => $content);
}

sub emit_sponsor_form
{
	my $state    = shift;
	my $q        = $state->{q};
	#
	# FIXME: if not logged in, jump off to get a login or a membership, then come back here
	#
	my $template = "$Template_Dir/generic.html";
	$state->{refer} = $q->{refer} if $q->{refer};
	my $form_html = sponsor_form($state);
	return output_template($template, $state, uf_content => $form_html);
}
sub sponsor_form
{
	my $state = shift;
	my $errors= shift;
	my $Errorlist= "";
	my $sponsorlevel=$state->{q}->{sponsorlevel};
	foreach ( keys (%$errors)  ) {
		$Errorlist.="<BR>$_ : $errors->{$_}\n"
	}
	my $Spiff=spiff_text($sponsorlevel);
	#grab member data from db if exists;
	# 
	my %q=existing_address($state);
	my $upgrade="";
	my $mtype=$state->{ipe}->{MTYPE};
	if ($mtype ne "User") {
		# help! how do I detect a full yearly membership?
		if ($mtype eq "Member" && $mtype ne $sponsorlevel ) {
			$upgrade=<<EOF;
Changing existing account from $mtype to $sponsorlevel<BR>
Upgrade my account?<P>
<INPUT TYPE="RADIO" NAME="upgrade" VALUE="Y" CHECKED><B>Yes,</B><BR> Upgrade my current Membership to a Sponsorship, (deducts 36.00 USD/ 58.00 CAD off Sponsorship price), I'll get the Sponsorship merchandise but no extra time extension.<P>
<INPUT TYPE="RADIO" NAME="upgrade" VALUE="N"><B>No,</B><BR>Upgrade <B>and</B> Extend my current Membership by a year, (pay full Sponsorship price) and receive the new merchandise.
EOF
		}
		elsif ($mtype ne $sponsorlevel ) {
			$upgrade="Changing existing account from $mtype to $sponsorlevel"; 
		} else {
			$upgrade="Extending existing account"; 
		}
	}
	# add in existing
	foreach my $field (keys %{$state->{q}}) {
		$q{$field}=$state->{q}->{$field};
	}
	my $prov=make_select("MEMBPROV", \&province, $q{MEMBPROV} );
	my $ctry=make_select("MEMBCTRY", \&country,  $q{MEMBCTRY} );
	
	my $size="";
	my $email="";
	if ($sponsorlevel ne "Member" ) {
		$size="Size of TShirt: " . make_select("TSHIRT",\&size,$q{TSHIRT});
		$email=<<EOF;
<TR BGCOLOR=#FFFFEE>
<TD>E-mail<B>*</B>:</TD><TD> <INPUT TYPE="TEXT" NAME="MEMBEMAI" SIZE=70 MAXLENGTH=120 VALUE="$q{MEMBEMAI}"> </TD></TR>
<TR BGCOLOR=#FFFFEE>
<TD>Phone<B>*</B>:</TD><TD> <INPUT TYPE="TEXT" NAME="MEMBPHON" SIZE=70 MAXLENGTH=120 VALUE="$q{MEMBPHON}"> </TD></TR>
<TR BGCOLOR=#FFFFEE>
		<TD COLSPAN="2">
<B>*</B> In the event there is a problem with your order.
		</TD>
	</TR>
EOF
	}
	# FIXME: errors need to be added to this form
	my $form_source= "$Template_Dir/sponsor.html";
	my $content=read_file($form_source);
	return <<"EOF";	
<form method="post" action="http://ars.userfriendly.org/users/save_address_data.cgi">
$Errorlist
$upgrade
<H5>Details of your selected sponsorship:</h5> 
$Spiff
<BR>
$size
<BR>

<TABLE CELLSPACING=2 CELLPADDING=2 BGCOLOR="#FFFFFF">
<TR BGCOLOR="#EEEEEE">
<TD COLSPAN=2><B>Set up $sponsorlevel sponsorship for user $state->{login_user}</B></TD></TR>
<TR BGCOLOR="#FFFFEE">
<TD>Name:</TD>
<TD><INPUT TYPE="TEXT" NAME="MEMBNAME" SIZE=70 MAXLENGTH=120 VALUE="$q{MEMBNAME}"></TD>
<TR BGCOLOR="#FFFFEE">
<TD>Address:</TD>
<TD><INPUT TYPE="TEXT" NAME="MEMBADDR" SIZE=70 MAXLENGTH=120 VALUE="$q{MEMBADDR}"></TD>
<TR BGCOLOR="#FFFFEE">
<TD>City</TD>
<TD><INPUT TYPE="TEXT" NAME="MEMBCITY" SIZE=70 MAXLENGTH=120 VALUE="$q{MEMBCITY}"></TD>
<TR BGCOLOR="#FFFFEE">
<TD>State or Prov:</TD>
<TD>$prov
Postal/ Zip Code: <INPUT TYPE="TEXT" NAME="MEMBCODE" SIZE=15 MAXLENGTH=15 VALUE="$q{MEMBCODE}">
</TD></TR>
<TR BGCOLOR=#FFFFEE>
<TD>Country:</TD><TD> $ctry </TD></TR>
$email
<TD colspan=2>
<B>The next fields are <U>optional</U></B>, but it would really help us out if you would take a few more seconds to fill them in.<BR>
Be assured we will <b>never, ever, ever</b> sell your personal information. At most, we'll use the data in <b>aggregate</b>. We store the optional data in a separate non-personally identifiable database. (Source available from link at bottom of this page).
<BR>Thanks!
</TD></TR>
<TR BGCOLOR=#FFFFEE>
<TD>Sex:</TD>
<TD><SELECT NAME="gender">
<OPTION VALUE="">--</OPTION>
<OPTION VALUE="Female">Female</OPTION>
<OPTION VALUE="Male">Male</OPTION>
</SELECT>
</TD></TR>
<TR BGCOLOR=#FFFFEE>
<TD>Age:</TD>
<TD><SELECT NAME="age">
<OPTION VALUE="">--</OPTION>
<OPTION VALUE="< 18">Under 18</OPTION>
<OPTION VALUE="18 - 24">18 to 24</OPTION>
<OPTION VALUE="25 - 34">25 to 34</OPTION>
<OPTION VALUE="35 - 44">35 to 44</OPTION>
<OPTION VALUE="45 - 55">45 to 55</OPTION>
<OPTION VALUE="> 55">over 55</OPTION>
</SELECT>
</TD></TR>
<TR BGCOLOR=#FFFFEE>
<TD>Occupation:</TD>
<TD><SELECT NAME="job_title">
<OPTION VALUE="">--</OPTION>
<OPTION VALUE="Senior IT">Senior IT Management (e.g. CTO, CIO, VP, Director of Technology)</OPTION>
<OPTION VALUE="IT Mgmt">IT Management (e.g. IT manager, project manager)</OPTION>
<OPTION VALUE="Sys Admin">Systems Administrator (e.g. databases, web, systems administration)</OPTION>
<OPTION VALUE="Programmer">Programmer/Developer</OPTION>
<OPTION VALUE="Net Specialist">Network Specialist</OPTION> 
<OPTION VALUE="Tech Support">Technical Support</OPTION>
<OPTION VALUE="Consultant">Analyst/Consultant</OPTION>
<OPTION VALUE="Web Design">Web Designer/Master/Support</OPTION>
<OPTION VALUE="Sr Mgmt">Senior Management (e.g. CEO, President, VP, General manager)</OPTION>
<OPTION VALUE="Mktg">Marketing & Sales</OPTION>
<OPTION VALUE="Biz Dev">Business Development</OPTION>
<OPTION VALUE="Mfg Dev">Manufacturing/Product Development</OPTION>
<OPTION VALUE="Finance">Finance/Accounting</OPTION>
<OPTION VALUE="HR">Human Resources</OPTION>
<OPTION VALUE="Student Comp Sci">Student - Computer Science</OPTION>	
<OPTION VALUE="Student Eng">Student - Engineering</OPTION>	
<OPTION VALUE="Student New Media">Student - New Media/Web Design/Administration</OPTION>
<OPTION VALUE="Student Technologist">Student - Technician/Technologist</OPTION>	
<OPTION VALUE="Student Comp Prog">Student - Computer Programming</OPTION>	
<OPTION VALUE="Other">Other</OPTION>
</SELECT>
<BR>
If Other please tell us: <INPUT TYPE="text" NAME="other" SIZE="40" MAXLENGTH="75">
</TD></TR>
<TR BGCOLOR=#FFFFEE>
<TD>Annual Household Income (USD):</TD>
<TD><SELECT NAME="income">
<OPTION VALUE="">--</OPTION>
<OPTION VALUE="< \$30k">under \$30,000</OPTION>
<OPTION VALUE="\$30 - \$40k">\$30,000 to \$44,000</OPTION>
<OPTION VALUE="\$45 - \$64k">\$45,000 to \$64,000</OPTION>
<OPTION VALUE="\$65 - \$99k">\$65,000 to \$99,000</OPTION>
<OPTION VALUE="\$100 - \$150k">\$100,000 to \$150,000</OPTION>
<OPTION VALUE="> \$150k">over \$150,000</OPTION>
</SELECT>
</TD></TR>
<TR><TD ALIGN=LEFT BGCOLOR="#FFFFFF" COLSPAN=2>
$content
</TD>
</TR>
<TR><td COLSPAN=2 ALIGN=CENTER>
<INPUT NAME="YES" TYPE=SUBMIT VALUE="I Agree. Sign Me Up"> || <INPUT NAME="NO" TYPE=SUBMIT VALUE="Nope. Cancel"></P>
</TABLE>
</FORM>

EOF

}

########################################
#
# Helper routines
#
########################################

sub spiff_text 
{
	my $sponsorlevel=shift;
	my %spiff=%{$Spiff{$sponsorlevel}};
	return <<EOF
$spiff{text}
<input type=hidden name="sponsorlevel" value="$sponsorlevel">
EOF
}

sub monthly 
{
	my $state=shift;
	my $t=shift;
	return <<EOF;
<TR><TD>
<H3> Monthly </H3>
<HR>
Paypal is our only option for monthly memberships, as transaction charges on a \$3.95 billing are too much to use cheques or credit cards:<BR>
If you do not have a PayPal account, PayPal will guide you through a first-time PayPal account set up. <P>
<!-- Begin PayPal Logo -->
<form action="https://www.paypal.com/cgi-bin/webscr" method="post">
<input type="hidden" name="cmd" value="_xclick-subscriptions">
<input type="hidden" name="business" value="member\@userfriendly.org">
<input type="hidden" name="item_name" value="UF Monthly Membership">
<input type="hidden" name="item_number" value="MMEM::$t/$state->{login_user}">
<input type="hidden" name="no_shipping" value="1">
<input type="hidden" name="return" value="users/paypal3c66.html?accept=yes\&amp;monthly=$t">
<input type="hidden" name="cancel_return" value="users/paypalc320.html?accept=no">
<input type="hidden" name="no_note" value="1">
<input type="hidden" name="a3" value="3.95">
<input type="hidden" name="p3" value="1">
<input type="hidden" name="t3" value="M">
<input type="hidden" name="src" value="1">
<input type="hidden" name="sra" value="1">
<input type="hidden" name="srt" value="12">
<input type="image" src="http://images.paypal.com/images/x-click-but20.gif" border="0" name="submit" alt="Make payments with PayPal">
</form>
EOF
}

sub validate_memb_data 
{	
	my $ipe = shift;
	my $mlevel=shift;
	my $ok  = 1;
	my %f;
	my %errs=();
	tie %f, 'UFIPE::Tie', $ipe;
	# Validate addresses
	# FIXME: Validate Something here.....
	#
	$errs{MEMBNAME} .='We need a name for our records.' unless ($f{MEMBNAME});
	$errs{MEMBADDR} .='We need a valid address for our records.' unless ($f{MEMBADDR});
	$errs{MEMBCITY} .='We need a valid city for our records.' unless ($f{MEMBCITY});
	$errs{MEMBPROV} .='We need a valid State or Province for our records. Enter ".." if this does not apply to your country.' unless ($f{MEMBPROV});
	$errs{MEMBCTRY} .='We need a valid country for our records.' unless ($f{MEMBCTRY});
	$errs{MEMBCODE} .='We need a valid postal/zip code for our records.' unless ($f{MEMBCODE});
	if ($mlevel ne "Member") {
		$errs{TSHIRT}   .='We need a Tshirt size.' unless ($f{TSHIRT});
		$errs{MEMBEMAI} .='We need a valid email address for contacting you about problems with your order' unless ($f{MEMBEMAI});
		$errs{MEMBPHON} .='We need a valid telephone for contacting you about problems with your order' unless ($f{MEMBPHON});
	}
	%errs;
}

sub existing_address 
{
	my $state    = shift;
	my %q=();	
	my $ipe = $state->{ipe} ||= UFIPE->new;
	eval { $ipe->load(USERNAME => $state->{login_user}) };
	my $meth;
	my $field;
	foreach $field (qw(MEMBNAME MEMBADDR MEMBCITY MEMBPROV MEMBCODE MEMBCTRY)) {
			$meth = $ipe->can($field);
			$q{$field} = $ipe->$meth() ;
		}
	return %q;
}

sub address_display 
{
	my $state    = shift;
	my $t="<TABLE>";	
	my $ipe = $state->{ipe} ||= UFIPE->new;
	eval { $ipe->load(USERNAME => $state->{login_user}) };
	my $meth;
	my $field;
	foreach $field (qw(MEMBNAME MEMBADDR MEMBCITY MEMBPROV MEMBCODE MEMBCTRY )) {
			$meth = $ipe->can($field);
			$t .= "<TR><TD>". $ipe->$meth() ."</TD></TR>" ;
			
		}
	$t.="</TABLE>";
	return $t;
}


sub make_select 
{
	my $field=shift;
	my $subref=shift;
	my $current_selection=shift;
	my $r=qq{<SELECT NAME="$field">\n};
	
	my @opts= &$subref;
	while (@opts) {
		my $oval   = shift @opts;
		my $olabel = shift @opts;
		my $selected = $current_selection eq $oval ? ' SELECTED' : '';
		$r.= qq{<OPTION VALUE="$oval" $selected>$olabel\n};
	}
	$r.="</SELECT>";
	return $r;
}

sub size
{
	return (
	''  => '-',
	'M'  => 'Medium',
	'L'  => 'Large',
	'XL' => 'Extra Large',
	'XXL'=> '2X Large',
	'3XL'=> '3X Large'
	);
}

sub province 
{
	return (
	'AB' => 'Alberta',
	'AK' => 'Alaska',
	'AL' => 'Alabama',
	'AR' => 'Arkansas',
	'AS' => 'American Samoa',
	'AZ' => 'Arizona',
	'BC' => 'British Columbia',
	'CA' => 'California',
	'CO' => 'Colorado',
	'CT' => 'Connecticut',
	'DC' => 'District of Columbia',
	'DE' => 'Delaware',
	'FL' => 'Florida',
	'FM' => 'Micronesia',
	'GA' => 'Georgia',
	'GU' => 'Guam',
	'HI' => 'Hawaii',
	'IA' => 'Iowa',
	'ID' => 'Idaho',
	'IL' => 'Illinois',
	'IN' => 'Indiana',
	'KS' => 'Kansas',
	'KY' => 'Kentucky',
	'LA' => 'Louisiana',
	'MA' => 'Massachusetts',
	'MB' => 'Manitoba',
	'MD' => 'Maryland',
	'ME' => 'Maine',
	'MI' => 'Michigan',
	'MN' => 'Minnesota',
	'MO' => 'Missouri',
	'MP' => 'Northern Marianas',
	'MS' => 'Mississippi',
	'MT' => 'Montana',
	'NB' => 'New Brunswick',
	'NC' => 'North Carolina',
	'ND' => 'North Dakota',
	'NE' => 'Nebraska',
	'NF' => 'Newfoundland',
	'NH' => 'New Hampshire',
	'NJ' => 'New Jersey',
	'NM' => 'New Mexico',
	'NS' => 'Nova Scotia',
	'NT' => 'Northwest Territories',
	'NU' => 'Nunavut',
	'NV' => 'Nevada',
	'NY' => 'New York',
	'OH' => 'Ohio',
	'OK' => 'Oklahoma',
	'ON' => 'Ontario',
	'OR' => 'Oregon',
	'PA' => 'Pennsylvania',
	'PE' => 'Prince Edward Island',
	'PR' => 'Puerto Rico',
	'QC' => 'Quebec',
	'RI' => 'Rhode Island',
	'SC' => 'South Carolina',
	'SD' => 'South Dakota',
	'SK' => 'Saskatchewan',
	'TN' => 'Tennessee',
	'TX' => 'Texas',
	'UT' => 'Utah',
	'VA' => 'Virginia',
	'VI' => 'Virgin Islands',
	'VT' => 'Vermont',
	'WA' => 'Washington',
	'WI' => 'Wisconsin',
	'WV' => 'West Virginia',
	'WY' => 'Wyoming',
	'YT' => 'Yukon',
	'--' => 'Outside U.S and Canada',
    );
}

sub country 
{
	return ( 
	'AL' => 'Albania',
	'DZ' => 'Algeria',
	'AS' => 'American Samoa',
	'AD' => 'Andorra',
	'AO' => 'Angola',
	'AI' => 'Anguilla',
	'AQ' => 'Antarctica',
	'AG' => 'Antigua and Barbuda',
	'AR' => 'Argentina',
	'AM' => 'Armenia',
	'AW' => 'Aruba',
	'AU' => 'Australia',
	'AT' => 'Austria',
	'AZ' => 'Azerbaijan',
	'BS' => 'Bahamas',
	'BH' => 'Bahrain',
	'BD' => 'Bangladesh',
	'BB' => 'Barbados',
	'BY' => 'Belarus',
	'BE' => 'Belgium',
	'BZ' => 'Belize',
	'BJ' => 'Benin',
	'BM' => 'Bermuda',
	'BT' => 'Bhutan',
	'BO' => 'Bolivia',
	'BA' => 'Bosnia and Herzegovina',
	'BW' => 'Botswana',
	'BV' => 'Bouvet Island',
	'BR' => 'Brazil',
	'IO' => 'British Indian Ocean Territory',
	'BN' => 'Brunei Darussalam',
	'BG' => 'Bulgaria',
	'BF' => 'Burkina Faso',
	'BI' => 'Burundi',
	'KH' => 'Cambodia',
	'CM' => 'Cameroon',
	'CA' => 'Canada',
	'CV' => 'Cape Verde',
	'KY' => 'Cayman Islands',
	'CF' => 'Central African Republic',
	'TD' => 'Chad',
	'CL' => 'Chile',
	'CN' => 'China',
	'CX' => 'Christmas Island',
	'CC' => 'Cocos (Keeling) Islands',
	'CO' => 'Colombia',
	'KM' => 'Comoros',
	'CG' => 'Congo',
	'CD' => 'Congo, The Democratic Republic of the',
	'CK' => 'Cook Islands',
	'CR' => 'Costa Rica',
	'CI' => 'Cote D\'ivoire',
	'HR' => 'Croatia',
	'CU' => 'Cuba',
	'CY' => 'Cyprus',
	'CZ' => 'Czech Republic',
	'DK' => 'Denmark',
	'DJ' => 'Djibouti',
	'DM' => 'Dominica',
	'DO' => 'Dominican Republic',
	'TP' => 'East Timor',
	'EC' => 'Ecuador',
	'EG' => 'Egypt',
	'SV' => 'El Salvador',
	'GQ' => 'Equatorial Guinea',
	'ER' => 'Eritrea',
	'EE' => 'Estonia',
	'ET' => 'Ethiopia',
	'FK' => 'Falkland Islands (Malvinas)',
	'FO' => 'Faroe Islands',
	'FJ' => 'Fiji',
	'FI' => 'Finland',
	'FR' => 'France',
	'GF' => 'French Guiana',
	'PF' => 'French Polynesia',
	'TF' => 'French Southern Territories',
	'GA' => 'Gabon',
	'GM' => 'Gambia',
	'GE' => 'Georgia',
	'DE' => 'Germany',
	'GH' => 'Ghana',
	'GI' => 'Gibraltar',
	'GR' => 'Greece',
	'GL' => 'Greenland',
	'GD' => 'Grenada',
	'GP' => 'Guadeloupe',
	'GU' => 'Guam',
	'GT' => 'Guatemala',
	'GN' => 'Guinea',
	'GW' => 'Guinea-Bissau',
	'GY' => 'Guyana',
	'HT' => 'Haiti',
	'HM' => 'Heard and McDonald Islands',
	'HN' => 'Honduras',
	'HK' => 'Hong Kong',
	'HU' => 'Hungary',
	'IS' => 'Iceland',
	'IN' => 'India',
	'ID' => 'Indonesia',
	'IR' => 'Iran, Islamic Republic of',
	'IQ' => 'Iraq',
	'IE' => 'Ireland',
	'IL' => 'Israel',
	'IT' => 'Italy',
	'JM' => 'Jamaica',
	'JP' => 'Japan',
	'JO' => 'Jordan',
	'KZ' => 'Kazakstan',
	'KE' => 'Kenya',
	'KI' => 'Kiribati',
	'KP' => 'Korea, Democratic People\'s Republic of',
	'KR' => 'Korea, Republic of',
	'KW' => 'Kuwait',
	'KG' => 'Kyrgyzstan',
	'LA' => 'Lao People\'s Democratic Republic',
	'LV' => 'Latvia',
	'LB' => 'Lebanon',
	'LS' => 'Lesotho',
	'LR' => 'Liberia',
	'LY' => 'Libyan Arab Jamahiriya',
	'LI' => 'Liechtenstein',
	'LT' => 'Lithuania',
	'LU' => 'Luxembourg',
	'MO' => 'Macau',
	'MK' => 'Macedonia, The Former Yugoslav Republic of',
	'MG' => 'Madagascar',
	'MW' => 'Malawi',
	'MY' => 'Malaysia',
	'MV' => 'Maldives',
	'ML' => 'Mali',
	'MT' => 'Malta',
	'MH' => 'Marshall Islands',
	'MQ' => 'Martinique',
	'MR' => 'Mauritania',
	'MU' => 'Mauritius',
	'YT' => 'Mayotte',
	'MX' => 'Mexico',
	'FM' => 'Micronesia, Federated States of',
	'MD' => 'Moldova, Republic of',
	'MC' => 'Monaco',
	'MN' => 'Mongolia',
	'MS' => 'Montserrat',
	'MA' => 'Morocco',
	'MZ' => 'Mozambique',
	'MM' => 'Myanmar',
	'NA' => 'Namibia',
	'NR' => 'Nauru',
	'NP' => 'Nepal',
	'NL' => 'Netherlands',
	'AN' => 'Netherlands Antilles',
	'NC' => 'New Caledonia',
	'NZ' => 'New Zealand',
	'NI' => 'Nicaragua',
	'NE' => 'Niger',
	'NG' => 'Nigeria',
	'NU' => 'Niue',
	'NF' => 'Norfolk Island',
	'MP' => 'Northern Mariana Islands',
	'NO' => 'Norway',
	'OM' => 'Oman',
	'PK' => 'Pakistan',
	'PW' => 'Palau',
	'PS' => 'Palestinian Territory, Occupied',
	'PA' => 'Panama',
	'PG' => 'Papua New Guinea',
	'PY' => 'Paraguay',
	'PE' => 'Peru',
	'PH' => 'Philippines',
	'PN' => 'Pitcairn',
	'PL' => 'Poland',
	'PT' => 'Portugal',
	'PR' => 'Puerto Rico',
	'QA' => 'Qatar',
	'RE' => 'Reunion',
	'RO' => 'Romania',
	'RU' => 'Russian Federation',
	'RW' => 'Rwanda',
	'KN' => 'Saint Kitts and Nevis',
	'LC' => 'Saint Lucia',
	'VC' => 'Saint Vincent and The Grenadines',
	'WS' => 'Samoa',
	'SM' => 'San Marino',
	'ST' => 'Sao Tome and Principe',
	'SA' => 'Saudi Arabia',
	'SN' => 'Senegal',
	'SC' => 'Seychelles',
	'SL' => 'Sierra Leone',
	'SG' => 'Singapore',
	'SK' => 'Slovakia',
	'SI' => 'Slovenia',
	'SB' => 'Solomon Islands',
	'SO' => 'Somalia',
	'ZA' => 'South Africa',
	'GS' => 'South Georgia South Sandwich Islands',
	'ES' => 'Spain',
	'LK' => 'Sri Lanka',
	'SH' => 'St. Helena',
	'PM' => 'St. Pierre and Miquelon',
	'SD' => 'Sudan',
	'SR' => 'Suriname',
	'SJ' => 'Svalbard and Jan Mayen',
	'SZ' => 'Swaziland',
	'SE' => 'Sweden',
	'CH' => 'Switzerland',
	'SY' => 'Syrian Arab Republic',
	'TW' => 'Taiwan, Province of china',
	'TJ' => 'Tajikistan',
	'TZ' => 'Tanzania, United Republic of',
	'TH' => 'Thailand',
	'TG' => 'Togo',
	'TK' => 'Tokelau',
	'TO' => 'Tonga',
	'TT' => 'Trinidad and Tobago',
	'TN' => 'Tunisia',
	'TR' => 'Turkey',
	'TM' => 'Turkmenistan',
	'TC' => 'Turks and Caicos Islands',
	'TV' => 'Tuvalu',
	'UG' => 'Uganda',
	'UA' => 'Ukraine',
	'AE' => 'United Arab Emirates',
	'GB' => 'United Kingdom',
	'US' => 'United States',
	'UM' => 'United States Minor Outlying Islands',
	'UY' => 'Uruguay',
	'UZ' => 'Uzbekistan',
	'VU' => 'Vanuatu',
	'VA' => 'Vatican city state',
	'VE' => 'Venezuela',
	'VN' => 'Viet Nam',
	'VG' => 'Virgin Islands (British)',
	'VI' => 'Virgin Islands (US)',
	'WF' => 'Wallis and Futuna',
	'EH' => 'Western Sahara',
	'YE' => 'Yemen',
	'YU' => 'Yugoslavia',
	'ZM' => 'Zambia',
	'ZW' => 'Zimbabwe',
	);
}




##############################################################################
#
# Register URLS
#
##############################################################################


# shows "get a sponsorship/upgrade sponsorship"

register '/users/newmem.html'
	=> cachebust retitle "UF - Become a Sponsor",
	\&emit_choice;

register '/users/choosesponsorlevel.cgi'
	=> cachebust retitle "UF - Become a Sponsor",
	\&emit_choice;

register '/users/sponsor.cgi'    
	=> require_login cachebust retitle "UF - Become a Sponsor",
	\&emit_sponsor_form;

# Address form shows address form, uses db contents, 
# shows requested sponsorship level

register '/users/save_address_data.cgi'    
	=> require_login cachebust retitle "UF - Mailing Address",
	\&save_address_data;

# show address uses db contents, 
# shows requested sponsorship level and costs
# and builds buttons to pay

register '/users/purchase_form.cgi'    
	=> require_login cachebust retitle "UF - Sponsorship Confirmation",
	\&purchase_form;

register '/users/paypal.cgi'     
	=> require_login cachebust retitle "UF - Become a Member",
	\&back_from_paypal;

register '/users/creditcard.cgi'     
	=> require_login cachebust retitle "UF - Become a Member",
	\&back_from_creditcard;

1;

                                                                                                                                                                                  perl/ARSHandler/Mgmt.pm                                                                             0100644 0000000 0000000 00000020364 07600021351 013703  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ;# $Id: Mgmt.pm,v 1.5 2002/10/08 19:40:08 jay Exp $
;#
;# ARSHandler::Mgmt - Request handler plug-in that handles staff-only functions
;#
use strict;
use UFDataLogger qw(:all);

#
# All of these admin functions are run thru the following staff check
# 
sub is_staff
{
	my $state=shift;
	my %state=%$state;
	if ( $state->{user_type} eq  "admin" ||  $state->{user_type} eq "staff") {
		return 1;
	} else {
		return 0;
	}
}


#
# admin_only handler builder - make handler accessible admin users only
#
sub staff_only($)
{
	my $handler = shift;

	# Build a handler that requires admin privs
	sub {
		my $state = shift;

		unless(is_staff($state)) {
			my $template = "$Template_Dir/generic.html";
			return output_template($template, $state, 
				uf_content => "Must be staff; sorry. :(");
		}
	
		$handler->($state);
	};
}


###########################################################
#
# Staff Only URL handlers
#
###########################################################
sub view_staff_search_form
{
	my $state = shift;
	my $template = "$Template_Dir/generic.html";
	my $form_html = staff_search_form($state) ;
	$state->{title}="UF Admin: Find User";
	return output_template($template, $state, uf_content => $form_html);
}


sub view_user_handler
{
	my $state = shift;
	my $template = "$Template_Dir/generic.html";
	my $form_html = staff_user_view($state);
	$state->{title}="UF Admin: View/Update User Status";
	return output_template($template, $state, uf_content => $form_html);
}

sub staff_search_form 
{
	return <<EOF;
<form method=post action=http://ars.userfriendly.org/"/users/view_user.cgi/">
Display Status of Username or UserID: 
<INPUT TYPE="TEXT" SIZE="20" NAME="OID" VALUE="">
<INPUT TYPE="SUBMIT" NAME="Submit" VALUE="Display">
</FORM>
EOF
}


sub staff_user_view 
{
	my $state = shift;
	my $err   = shift;

	# Look up this user
	my $username=$state->{q}->{OID};
	return staff_search_form($state) unless $username;

	my @loadargs = ($username =~ /^\d+$/) ? (ID => $username) : (USERNAME => $username);
	my $hisipe = UFIPE->new;
	eval { $hisipe->load( @loadargs ) };
	return staff_search_form($state, error=>"<b>User \"$username\" is unknown.</b><br>\n") if $@;
	$state->{OID} = $hisipe->ID;
	
	$HTML_Fixer ||= ARS_FixHTML->new;

	my @form = (
		spacer00   =>{ type=>'label',label=>'User Status:' },
		ID         =>{ type=>'ro'	,label=>'Member ID:' },
		USERNAME   =>{ type=>'ro'	,label=>'Username:' },
		MEMBER     =>{ type=>'ro'	,label=>'Member/Sponsor:' },
		MTYPE      =>{ type=>'list'	,label=>'Type:',
			'list' => [
			'User'  		=> 'No Membership',
			'Member'		=> 'Standard Membership', 
			'Minion' 		=> 'Sponsor:1 Minion',
			'Evil Genius In Training' => 'Sponsor:2 Evil Genuis in Training',
			'Evil Genius'	=> 'Sponsor:3 Evil Genius',
			'Dark Regent'	=> 'Sponsor:4 Dark Regent',
			'The'	=> 'Cack',
			], },
		spacer02   =>{ type=>'label',label=>'Shipping Address'},
		MEMBNAME   =>{ type=>'ro'   ,label=>'Member Billing Name'},
		MEMBADDR   =>{ type=>'ro'   ,label=>'Address',		},
		MEMBCITY   =>{ type=>'ro'   ,label=>'City',			},
		MEMBPROV   =>{ type=>'ro'   ,label=>'Province or State',},
		MEMBCODE   =>{ type=>'ro'   ,label=>'Postal Code', 	},
		MEMBCTRY   =>{ type=>'ro'   ,label=>'Country', 		},
		CMEMDATE   =>{ type=>'ro'   ,label=>'Charter Member Signup Date',},
		MEMBDATE   =>{ type=>'ro'   ,label=>'Sponsorship Creation',},
		MEMBEXPDATE=>{ type=>'ro'   ,label=>'Original Expiry Date',},
		EXPIRE     =>{ type=>'ro'   ,label=>'Sponsorship Expiry Date',
            val=> " " .  scalar( localtime ($hisipe->{EXPIRE})) . ( ( $hisipe->{EXPIRE} < time ) ? " <B>Expired</b>": "") ,},
		SECMAIL    =>{ type=>'ro'   ,label=>'Email Address' },
		LISTMAIL   =>{ type=>'ro'   ,label=>'Mailing List Address' },

		spacer01   =>{ type=>'label',label=>'Spiff Data:' },
		TSHIRT     =>{ type=>'ro'   ,label=>'TShirt Size' },
		MEMBEMAI   =>{ type=>'ro'   ,label=>'Shipping Trouble Email Address' },
		MEMBPHON   =>{ type=>'ro'   ,label=>'Shipping Trouble Telephone' },

		STAFFNOTE  =>{ type=>'bigtext',label=>'Notes' },
		UPDATED    =>{ type=>'ro'  	,label=>'Last Update Date:' },
		PAYTYPE    =>{ val=>'',
                       type=>'list',
                       label=>'New Payment: Method:',
                       list => [
                       'NULL' => '',
                       'QW'   => 'Paid By Cheque',
                       'FR'   => 'Promotional',
                       'CW'   => 'Other Credit Card Method',
                       'PW'   => 'PayPal indirect',
                       ], },
		PAYDETAIL  =>{ type=>'text',label=>'Payment Detail' },
		spacer     =>{ type=>'ro',label=>'&nbsp', val => "&nbsp;" },
		tlist      =>{ type=>'ro'   ,label=>'Transaction List',
            val=> transactionlist($hisipe->{ID}), },
			);
	
	# Build a hash, and get a list of the key order
	my %form = @form;
	{ my $i; @form = grep { ++$i % 2 } @form; }

	my $out=staff_search_form();
	$out .="<TR><TD COLSPAN=\"3\"><form method=post action=http://ars.userfriendly.org/"/users/change_status.cgi/">";
	$out .= "<input type=hidden name=refer value=\"$state->{refer}\">";
	$out .= "<INPUT TYPE=\"HIDDEN\" NAME=\"OID\" VALUE=\"$state->{OID}\">";
	$out .= "<table>";

	foreach my $field (@form) {
		my $f     = $form{$field};
		my $type  = $f->{type};
		my $label = $f->{label};
		$label =~ s/ /&nbsp;/g;
		my $meth = $hisipe->can($field); 
		my $val = $f->{val} ||= $meth ? $hisipe->$meth() : '';
		if ($field =~/CMEMDATE|MEMBDATE|MEMBEXPDATE|EXPIRE/ && $val > 1000) {$val=scalar localtime($val); }
		$out .= "<TR>\n";
		my $ltd = "<TD ALIGN=\"LEFT\" VALIGN=\"TOP\" WIDTH=\"1%\">\n";
		if($type eq "label") {
			$out .= qq{<TD ALIGN="LEFT" COLSPAN="2"><B>$label</B></TD>\n};
		} elsif($type eq "text") {
			$out .= qq{$ltd$label</TD><TD ALIGN="LEFT"><INPUT TYPE="TEXT" NAME="$field" SIZE="70" VALUE="$val"></TD>\n};
		} elsif($type eq "bigtext") {
			my $rows = $f->{rows};
			$out .= qq{$ltd$label</TD><TD ALIGN="LEFT"><TEXTAREA COLS="55" ROWS="$rows" NAME="$field">$val</TEXTAREA></TD>\n};
		} elsif($type eq "list") {
			my $select = "<SELECT NAME=\"$field\">";
			my @opts = @{ $f->{list} };
			while(@opts) {
				my $oval   = shift @opts;
				my $olabel = shift @opts;
				my $selected = $val eq $oval ? ' SELECTED' : '';
				$select .= qq{<OPTION VALUE="$oval" $selected> $olabel\n}
			}
			$select .= "</SELECT>\n";
			$out .= qq{$ltd$label</TD><TD ALIGN="LEFT">$select</TD>\n};	
		} elsif($type eq 'ro') {
			#$val ||= $f->{val};
			$out .= qq{$ltd$label</TD><TD ALIGN="LEFT">$val</TD>\n};
		}
		$out .= qq{</TR>\n};	
	}

	$out .= qq{<TR><TD ALIGN="LEFT" COLSPAN="2"><INPUT TYPE="SUBMIT" NAME="Submit" VALUE="Update User Account Status"></TD></TR>};
	$out .= "</TABLE></FORM>";
	$out;
}
sub update_member_status {
	my $state    = shift;
	my $q        = $state->{q};

	return "" unless $q->{OID};

	my $hisipe = UFIPE->new;
	eval { $hisipe->load( ID => $q->{OID} ) };
	
	return ("Failed to find Userid: $q->{OID}") if $@;
	
	# is now a member
	if ($q->{PAYTYPE} ne 'NULL') {
		# expiring in a year.
		my $code=$q->{PAYTYPE}; 
		# FIXME: need a real transaction type
		my $detail=$q->{PAYDETAIL};
		if ( transactioninsert($hisipe->{ID},$code,$detail) ) {
			my $now=time;
			my $year=366*24*60*60;
			my $prev_time=$hisipe->{EXPIRE};
			$hisipe->EXPIRE( (( $prev_time > $now) ?	$prev_time + $year : $now + $year) );
			transactioninsert($hisipe->{ID},"ST","Manual Change from web by: $state->{login_user} ". scalar localtime );
			#yay, success
		} 
		else {
			return "Failure: Transaction Exists";
		}
	}
	if ( $q->{MTYPE} ) {
		# of this type
		if ($q->{MTYPE} eq "User") {
			$hisipe->MEMBER('no');
		} else {
			$hisipe->MEMBER('yes');
		}
		$hisipe->MTYPE($q->{MTYPE});
	}
	$hisipe->STAFFNOTE($q->{STAFFNOTE});
	#
	# FIXME: expire dates from userproperties db need to migrate into
	# user db. Needs code as table data is not in right format
	# 
	$hisipe->save;
	return "Success";		
}

sub post_status_form 
{
	my $state    = shift;
	my $template = "$Template_Dir/generic.html";
	my $success=update_member_status($state);
	my $form_html = staff_user_view($state);
	$state->{title}="UF Admin: Update User Status: $success";
	return output_template($template, $state, uf_content => $form_html);

}
# Staff toolset
register 'search_user.cgi'   => admin_only cachebust \&view_user_handler;
register 'view_user.cgi'     => admin_only cachebust \&view_user_handler;
register 'change_status.cgi' => admin_only cachebust \&post_status_form;


1;
__END__

                                                                                                                                                                                                                                                                            perl/ARS_FixHTML.pm                                                                                 0100755 0000000 0000000 00000020306 07607112715 013007  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   #!/usr/bin/perl

package ARS_FixHTML;
require 5.005;
use strict;

# System includes
use HTML::Parser ();

my %tags = (
	# Permitted tags
	a      => { allow_attrs => {href=>sub{local $_=shift;m#^https://#||m#^http://#||m#^mailto:#?$_:''} } },
	b      => {},
	em     => {},
	u      => {},
	br     => { noclose=>1 },
	p      => { nonest=>1, allow_attrs => {align=>1} },
	ul     => {},
	li     => {},
	ol     => {},
	pre    => {},
	code   => {},
	'sub'  => {},
	sup    => {},
	strong => {},
	i      => {},
	strike => {},
	blockquote=> { nonest=>1 },

	# Modified tags
	h1     => { subopen => '<font size="+1"><b>', subclose => '</b></font><br>' },
	h2     => { subopen => '<b>', subclose => '</b><br>' },
	h3     => { subopen => '<b><i>', subclose => '</i></b><br>' },
	h4     => { subopen => '', subclose => '<br>' },
	h5     => { subopen => '', subclose => '<br>' },
	h6     => { subopen => '', subclose => '<br>' },
	h7     => { subopen => '', subclose => '<br>' },
	h8     => { subopen => '', subclose => '<br>' },
	h9     => { subopen => '', subclose => '<br>' },
	center => { subopen => '<div align="center">', subclose => '</div>' },
	img    => { subopen => "<font color=red size=-1><b><i>(Image)</i></b></font>", subclose=>'' },
	hr     => { subopen => "<br>", subclose => '' },

	# Stripped tags
	table  => { subopen => '', subclose => '' },
	tr     => { subopen => '', subclose => '' },
	th     => { subopen => '', subclose => '' },
	td     => { subopen => '', subclose => '' },
	font   => { subopen => '', subclose => '' },

	# Ignored tags
	#(anything else that gets tried will be defanged)
);


#
# Utility function defang - Escape all HTML metacharacters (but NOT entities)
#
# Usage:  $defanged = defang($raw)
#
sub defang 
{
	shift if $_[0] eq __PACKAGE__ || ref($_[0]) eq __PACKAGE__;
	local $_ = shift;
	s#\<#&lt;#g;
	s#\>#&gt;#g;
	$_;
}


sub wouldsub($)
{
	my $tag = shift;
	$tag = $tags{$tag} unless ref $tag;
	defined($tag->{subopen}) || defined($tag->{subclose});
}


sub subopen($)
{
	my $tagname = shift;
	my $t = $tags{$tagname};
	return defang qq|<$tagname>| unless $t;
	return $t->{subopen} if defined $t->{subopen};
	qq|<$tagname>|;
}


sub subclose($)
{
	my $tagname = shift;
	my $t = $tags{$tagname};
	return defang qq|<$tagname>| unless $t;
	return $t->{subclose} if defined $t->{subclose};
	qq|</$tagname>|;
}


#
# Returns a human-readable description of the allowable HTML tags.
#
sub allowed_tags_as_string
{
	my $out = '';
	foreach my $tag (keys %tags) {
		next if wouldsub $tag;
		my $attrs = $tags{$tag}->{allow_attrs};
		$out .= qq|<$tag|;
		foreach my $attr (keys %$attrs) {
			$out .= qq| $attr=""|;
		}
		$out .= qq|>, |;
	}

	$out =~ s/\, $//;
	$out =~ s/, ([^,]+)$/ and $1/;
	$out .= ".";

	$out;
}


sub allowed_tags_as_html
{
	my $h = defang allowed_tags_as_string();
	$h =~ s/([^,<>])[ ]+/${1}&nbsp;/g;
	$h;
}


sub new
{
	my $class = shift;
	my $self = {};

	$self->{parser_args} = [
		api_version => 3,
		start_h =>[sub { $self->handle_start(@_) }, "tagname, attr, text"],
		end_h   =>[sub { $self->handle_end(@_)   }, "tagname, text"      ],
		text_h  =>[sub { $self->handle_text(@_)  }, "text"               ],
		marked_sections => 1,
	];

	bless $self, $class;

	$self->init;

	$self->{anal_closetags} = 0;
	$self->{warn_closetags} = 0;

	$self;
}


#
# Prepare to convert some HTML
#
sub init
{
	my $self = shift;
	
	if($self->{parser}) {
		$self->{parser}->init( @{ $self->{parser_args} } );
	} else {
		$self->{parser} = HTML::Parser->new( @{ $self->{parser_args} } );
	}

	#$self->{parser}->unbroken_text(1);
	$self->{out}            = '';
	$self->{defang_all}     = 0;
	$self->{errors}         = 0;
	$self->{sawtags}        = 0;
	$self->{openstack}      = [];
	$self->{ready}          = 1;

	return $self;
}


sub anal_closetags { my $self=shift; @_ ? $self->{anal_closetags}=shift : $self->{anal_closetags} }

sub warn_closetags { my $self=shift; @_ ? $self->{warn_closetags}=shift : $self->{warn_closetags} }

#
# Convert some HTML.  Return the converted text.
#
sub convert_html
{
	my $self = shift;
	my $what = shift;

	# Strip unprintables right off the bat
	$what =~ tr/\040-\377\015\012//cd;

	$self->init unless $self->{ready};

	$self->{parser}->parse($what);
	$self->{parser}->eof;
	$self->handle_eof;

	# If there was no valid HTML at all, treat as ASCII.
	unless($self->{sawtags}) {
		$self->{out} = $what;
		#$self->{out} =~ s/\s+$//;
		$self->{out} =~ s/(\S{70})(\S)/$1\n$2/g;
		$self->{out} =~ s#\&#&amp;#g;
		$self->{out} = defang $self->{out};
		$self->{out} =~ s#\012#\012<br>#g;
	}

	return wantarray ? ($self->{out}, $self->{errors}, $self->{sawtags}) : $self->{out};
}


#
# method _validate_attr - ensure attr is acceptable.
#
# Usage: $newvalue = $self->_validate_attr('img', 'src', 'http://blah/foo.gif');
#
# Verifies that an attribute has the proper format.  
# Returns an anonymous array containing [ 'src' => 'http://blah/foo.gif' ] on success,
# or an empty list on failure.
#
sub _validate_attr
{
	my $self    = shift;
	my $tagname = shift;
	my $attr    = shift;
	my $value   = shift;

	my $t = $tags{$tagname} or return;
	my $c = $t->{allow_attrs}{$attr} or return;
	return [ $attr, $value ] unless ref($c) eq 'CODE';
	my $nv = $c->($value) or return;
	[ $attr, $nv ];
}


#
# method handle_start - called by HTML::Parser as each start tag is found
#
sub handle_start
{
	my $self = shift;
	my ($tagname, $attr, $text) = @_;

	my $t = $tags{$tagname};
	if ($self->{defang_all} || !$t) {
		$self->{out} .= defang $text;
		return;
	}

	$self->{openstack} = [ grep { $_ ne $tagname } @{ $self->{openstack} } ] if $t->{nonest};
	push @{ $self->{openstack} }, $tagname unless $t->{noclose};

	if(wouldsub $tagname) {
		$self->{out} .= subopen $tagname;
		$self->{sawtags} = 1;
		return;
	}
	
	my @approved_attrs = map { 
		$self->_validate_attr($tagname, $_, $attr->{$_}) 
	} keys %$attr;

	$self->{out} .= qq|<$tagname|;
	$self->{out} .= qq| $_->[0]="$_->[1]"| foreach @approved_attrs;
	$self->{out} .= qq|>|;
	$self->{sawtags} = 1;
	
	return;
}


sub handle_text
{
	my $self = shift;
	my $text = shift;

	$text =~ s/(\S{70})(\S)/$1\n$2/g;
	$text = defang $text;
	$self->{out} .= $text;
}


#
# method handle_end - called by HTML::Parser as each end tag is found
#
sub handle_end
{
	my $self = shift;
	my($tagname, $text) = @_;

	my $t = $tags{$tagname};
	if (!$t || $self->{defang_all} || $t->{noclose}) {
		# Unrecognized tag
		$self->{out} .= defang $text;
		return;
	}

	if ($self->{openstack}[-1] eq $tagname) {
		# Fast path: corresponding open tag is at top of stack.
		pop @{ $self->{openstack} };
		$self->{out} .= subclose $tagname;
		$self->{sawtags} = 1;
		return;
	}

	if($t->{nonest}) {
		# These aren't allowed to nest (<p>, say).
		# Ignore it unless we've seen an open tag for it.
		$self->{sawtags} = 1;
		return unless grep { $_ eq $tagname } @{ $self->{openstack} };
		$self->{openstack} = [ grep { $_ ne $tagname } @{ $self->{openstack} } ];
		$self->{out} .= subclose $tagname;
		return;
	}

	if($self->{anal_closetags}) {
		# As requested, overreact hysterically to unexpected close tag
		my $df_text = defang $text;
		$self->{out} .= qq|<br><table border=0><tr><td bgcolor="#ffff00">(Unexpected <b>$df_text</b> close|;
		$self->{out} .= qq| tag. HTML below this line has not been processed.)</td></tr></table><br>\n|;
		$self->{out} .= $df_text;
		$self->{defang_all} = 1;
		$self->{errors} = 1;
		$self->{sawtags} = 1;
		return;
	} elsif ($self->{warn_closetags}) {
		# Emit a warning and continue
		my $df_text = defang $text;
		$self->{out} .= qq|<br><table border=0><tr><td bgcolor="#ffff00">(Unexpected <b>$df_text</b> close tag)</td></tr></table>|;
		$self->{errors} = 1;
		$self->{sawtags} = 1;
	}

	# Have we seen a corresponding open tag at all?
	if ( grep { $_ eq $tagname } @{ $self->{openstack} } ) {
		# Yes, it's in there somewhere.. pop-n-close until we find it.
		while(($t = pop @{ $self->{openstack} }) ne $tagname) {
			$self->{out} .= subclose $t;
		}
		$self->{out} .= subclose $tagname;
		$self->{sawtags} = 1;
		return;
	}

	# Never saw an open tag for this close tag, so we'll just ignore it.
	return;
}


#
# method eof - called by convert_html when all data has been fed through the parser
#
sub handle_eof
{
	my $self = shift;

	while(my $tag = pop @{ $self->{openstack} }) {
		$self->{out} .= subclose $tag;
	}

	$self->{ready} = 0;
	return;
}


1;
__END__

                                                                                                                                                                                                                                                                                                                          perl/MemberHandler.pm                                                                               0100755 0000000 0000000 00000016524 07550150457 013605  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   #!/usr/bin/perl -w
# $Id: MemberHandler.pm,v 2.3 2002/10/06 23:54:34 cvsars Exp $

package MemberHandler;
require 5.005;
use integer;
use strict;
# cribbed ENTIRELY from Requesthandler.

# System includes
use Crypt::Blowfish;
use MIME::Base64;

# Local includes
use ARSConfig; # Brings in $GC = \%global_config_hash
use UserFriendly 3.01 qw(:comments :articles :html :util);
use UFCGI;
use UFIPE;
use Apache::Constants qw(:common);


#############################################################################
#
#  Constants
#
#############################################################################

use constant DEBUG => 0;				# Turn debug log msgs on or off

use constant BIT_SHOWCOMMENTS   => 0x01;
use constant BIT_SHOWSUBJONLY   => 0x02;
use constant BIT_SORTORDER      => 0x04;
use constant BIT_SEEMOD         => 0x08;
use constant BIT_SHOWEVERYTHING => 0x10;

use constant HTTP_HEADER => "Content-type: text/html\n\n";
#############################################################################
#
#  Global Variables
#
#############################################################################

use vars qw($Doc_Root);
use vars qw($Domain);
use vars qw($Cookie_Domain);
use vars qw($Geekpoints_Starting);
use vars qw($Admin_Email);
use vars qw($Auth_Key_File);
use vars qw($Template_Dir);
use vars qw(@Handlers);
use vars qw(%Config);
use vars qw($HTML_Fixer);	# shared ARS_FixHTML instance


#############################################################################
#
#  Global Init
#
#############################################################################

my %Dispatch = ();

$Doc_Root            =    $GC->{doc_root};
$Domain              =    $GC->{domain};
$Template_Dir        =    $GC->{template_dir};
$Cookie_Domain       =    $GC->{cookie_domain};
$Geekpoints_Starting =    $GC->{geekpoints_starting};
$Admin_Email         =    $GC->{admin_email};
$Auth_Key_File       =    $GC->{auth_key_file};
@Handlers            = @{ $GC->{handlers}  };
%Config              = %{ $GC->{db_layout} };
#############################################################################
#
#  Functions
#
#############################################################################

sub dwarn(@) { warn @_ if DEBUG }


my $cipher;
{
	my $source=read_file( $Auth_Key_File );
	my $key = pack("a56", $source); 

	# key length is 56 bytes == 448 bits
	# instantiate blowfish with this pretty secure key.
	# hmm, French users beware! this is bigger than your legal limit.

	$cipher = new Crypt::Blowfish $key;
	dwarn "Cipher Length is : " , length($key) , " bytes";
}




#
# Main request handler - called by mod_perl core during
# content phase of every request
#
sub handler 
{
	my $r = shift;
	my $result = undef;

	eval { $result = inner_handler($r) };
	return $result unless $@;

	warn "memberhandler: uncaught exception: $@";

	return SERVER_ERROR;
}


# Warn feature
package OUCH;
sub TIESCALAR { return {} }
sub FETCH { die "Hey!! This doesn't exist here" }
sub STORE { die "Nice try!" }
package MemberHandler;


#
# inner_handler - called by handler in an eval{} context.
#
sub inner_handler 
{
	# Apache request object
	my $r = shift;
	
	# %q raw query object. args = get method, content=postmethod
	# note: post content OVERRIDES get content
	
	my %q = ($r->args, $r->content);
	my %state = (r => $r, q => \%q );
	my $fullpath= $ENV{'REQUEST_URI'};

	return DECLINED if $fullpath =~ /\.[(?:gif)|(?:jpg)|(?:png)|(?:swf)|(?:zip)]/i;

	validate_auth_cookie(\%state);
	# Figure out who this is
	my($action, $function, $args,$path, $template);
	# 
	if($fullpath =~ m#^/(.*)\/([^/]*)$#) {
		$path = $1;
		$action = $2;
		($function,$args) = split /\?/, $action, 2;
	} else {
		($function,$args) = split /\?/, $fullpath, 2;
	}

	$template  = "$Doc_Root"; 
	$template .= "/$path" if $path;
	$template .= "/$function" if $function;
	if ( -d $template ) {
		if (-f "$template/index.shtml") {
			$template .= "index.shtml";
		} elsif ( -f "$template/index.html") {
			$template .= "/index.html";
		} else {
			$template= "$Doc_Root/index.html";
		}
	}
	dwarn "DR: $Doc_Root P: $path A: $action T: $template";
	return output_template($template, \%state);
}


sub get_auth_cookie
{
        my $state=shift;
        my $cookie = UFCGI->parse_cookie($ENV{HTTP_COOKIE})->{ars_user};
        my($login, $ip, $password, $time) = parse_auth_string($state, $cookie);
        ($login, $ip, $password, $time);
}

sub parse_auth_string
{
        my $state  = shift;
        my $cookie = shift;

        return unless $cookie;
        return if $cookie =~ /logged_out/;

        my $unenc= decode_base64($cookie);
        my $unblown;

        # start at 8, take 8 bytes at a time
        # $unenc should be exactly a multiple of 8 bytes.

        my $pos;
        for ( $pos = 0; $pos<length($unenc); $pos += 8) {
                $unblown .= $cipher->decrypt(substr($unenc, $pos, 8));
        }
        my ($login, $ip, $password, $time)=split ( /::/, $unblown, 4);
}


sub set_logout_cookie
{
	my $state = shift;
	$state->{cookie_out} = build_logout_cookie($state);
}

sub validate_auth_cookie
{
        my $state = shift;
        my ($login, $ip, $pass, $time) = get_auth_cookie($state);
        return unless $login && $pass;
        $state->{ipe} ||= UFIPE->new;
        my $ipe = $state->{ipe};
        eval { $ipe->load( USERNAME => $login, '-require_password' => $pass ) };
        (set_logout_cookie($state), return) if $@ =~ /not found/;
        return if $@;
        return if $ipe->DISABLED;

        # Credentials look good.  Load into state
        $state->{user_type}  = $ipe->TYPE;
        # yay, this is all it takes to get member specific includes
        $state->{member}     = $ipe->MEMBER;
        #
        $state->{login_user} = $login;
        $state->{login_pass} = $pass;
        $state->{auth_status}="Logged in as: <b>$login</b><br>" . login_links($state);
        return 1;
}

sub output_template
{
        my $template_path=shift;
        my $state=shift;
        my $r=$state->{r};

        $r->content_type('text/html');
        $r->status(200);

        # Add headers as needed

        if ($state->{cachebuster}) {
                my $ut = time + 1;
                my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($ut);
                my($wday_str, $mon_str) = split " ", scalar(gmtime($ut));
                $year += 1900;
                my $expiry = sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
                        $wday_str, $mday, $mon_str, $year, $hour, $min, $sec;

                $r->header_out( 'Cache-Control', 'no-cache' );
                $r->header_out( 'Pragma', 'no-cache' );
                $r->header_out( 'Expires', $expiry );
        } else {
                $r->header_out( 'Cache-Control', 'private' );
        }

        # add cookie if state has one for us;
        # FIXME: only does 1 cookie at a time.
        # header_out _may_ take a list

        $r->header_out( 'Set-Cookie' => $state->{cookie_out} ) if $state->{cookie_out};

        $r->send_http_header;
        print param_replace( ssi_replace( read_file($template_path), $state), { %$state, @_ });

        return OK;
}
sub login_links
{
        my $state = shift;
        my $username = $state->{login_user};

        return <<"EOF";
<a href="users/acct.html">My Settings</a><br>
<a href="users/diarya954.html?id=$username">My Diary</a><br>
<a href="users/logout.html">Log out</a><br>
EOF
}




1;
                                                                                                                                                                            perl/RequestHandler.pm                                                                              0100755 0000000 0000000 00000054166 07550144262 014027  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   #!/usr/bin/perl -w
# $Id: RequestHandler.pm,v 1.30 2002/10/06 18:18:31 jay Exp $

package RequestHandler;
require 5.005;
use integer;
use strict;


# System includes
use Crypt::Blowfish;
use MIME::Base64;

# Local includes
use ARSConfig; # Brings in $GC = \%global_config_hash
use UserFriendly 3.01 qw(:comments :articles :html :util);
use UFCGI;
use UFIPE;
use Apache::Constants qw(:common);
use ARS_FixHTML;


#############################################################################
#
#  Constants
#
#############################################################################

use constant DEBUG => 0;				# Turn debug log msgs on or off

use constant BIT_SHOWCOMMENTS   => 0x01;
use constant BIT_SHOWSUBJONLY   => 0x02;
use constant BIT_SORTORDER      => 0x04;
use constant BIT_SEEMOD         => 0x08;
use constant BIT_SHOWEVERYTHING => 0x10;

use constant HTTP_HEADER => "Content-type: text/html\n\n";


#############################################################################
#
#  Function Prototypes
#
#############################################################################

sub register($$);

sub cachebust($);

sub retitle($$);

sub require_login_for_path($$);

sub require_login($);


#############################################################################
#
#  Global Variables
#
#############################################################################

use vars qw($Doc_Root);
use vars qw($Domain);
use vars qw($Cookie_Domain);
use vars qw($Geekpoints_Starting);
use vars qw($Admin_Email);
use vars qw($Auth_Key_File);
use vars qw($Template_Dir);
use vars qw(@Handlers);
use vars qw(%Config);
use vars qw(%Spiff);
use vars qw(%Shipping);
use vars qw($HTML_Fixer);	# shared ARS_FixHTML instance


#############################################################################
#
#  Global Init
#
#############################################################################

my %Dispatch = ();

$Doc_Root            =    $GC->{doc_root};
$Domain              =    $GC->{domain};
$Template_Dir        =    $GC->{template_dir};
$Cookie_Domain       =    $GC->{cookie_domain};
$Geekpoints_Starting =    $GC->{geekpoints_starting};
$Admin_Email         =    $GC->{admin_email};
$Auth_Key_File       =    $GC->{auth_key_file};
@Handlers            = @{ $GC->{handlers}  };
%Config              = %{ $GC->{db_layout} };
%Spiff               = %{ $GC->{spiff} };
%Shipping            = %{ $GC->{shipping} };

my $cipher;
{
	my $source=read_file( $Auth_Key_File );
	my $key = pack("a56", $source); 

	# key length is 56 bytes == 448 bits
	# instantiate blowfish with this pretty secure key.
	# hmm, French users beware! this is bigger than your legal limit.

	$cipher = new Crypt::Blowfish $key;
	warn "Cipher Length is : " , length($key) , " bytes" if DEBUG;
}

$HTML_Fixer = ARS_FixHTML->new();


#############################################################################
#
#  Load handler libraries
#
#############################################################################


foreach my $h (@Handlers) {
	my $module = "ARSHandler::$h";
	eval qq{ require $module };
	die $@ if $@;
}


#############################################################################
#
#  Functions
#
#############################################################################

sub dwarn(@) { warn @_ if DEBUG }


sub register($$)
{
	shift if $_[0] eq 'RequestHandler';
	my ($pattern, $coderef) = @_;

	die "Duplicate request handler: $pattern already assigned" if $Dispatch{$pattern};

	$Dispatch{$pattern} = $coderef;
}


#
# Main request handler - called by mod_perl core during
# content phase of every request
#
sub handler 
{
	my $r = shift;
	my $result = undef;

	eval { $result = inner_handler($r) };
	return $result unless $@;

	warn "RequestHandler: uncaught exception: $@";

	return SERVER_ERROR;
}


# Warn feature
package OUCH;
sub TIESCALAR { return {} }
sub FETCH { die "Hey!! This doesn't exist here" }
sub STORE { die "Nice try!" }
package RequestHandler;


#
# inner_handler - called by handler in an eval{} context.
#
sub inner_handler 
{
	# Apache request object
	my $r = shift;
	
	# %q raw query object. args = get method, content=postmethod
	# note: post content OVERRIDES get content
	
	my %q = ($r->args, $r->content);
	my %state = (r => $r, q => \%q );
	my $fullpath= $ENV{'REQUEST_URI'};


	# Return if graphic file.
	# FIXME: audit this code path, since we don't want to be
	# sending html instead of jpeg

	return DECLINED if $fullpath =~ /\.[(?:gif)|(?:jpg)|(?:png)|(?:swf)]\b/i;

	my($action, $function, $args) = ($fullpath, '', '');
	if($fullpath =~ m#^/([^/]+)/?(.*)$#) {
		$state{path} = lc $1;
		$action = $2;
	}

	($function,$args) = split /\?/, $action, 2;
	$state{function }= lc $function;


	# data untainting all numerical input
	$state{id}  = int($q{id});
	$state{tid} = int($q{tid}) || int($q{thread});
	
	# FIXME: untaint text to be posted, limit size to 8000 chars or less
	# Fixup html in subject, message. also in headline (for postings)	
	$state{subject}     = $q{subject}; 
	$state{headline}    = $q{headline}; 
	$state{message}     = $q{message};
	$state{submit_type} = $q{Submit} ||= $q{submit_type};
	
	# We guarantee that all templates can safely use these vars.
	$state{uf_content}="";
	$state{errors}="";
	$state{refer}="";
	$state{title}="User Friendly";
	$state{login_user} = '';
	$state{login_pass} = '';
	$state{auth_status} = password_boxes(\%state);

	# Figure out who this is
	validate_auth_cookie(\%state);
	
	# we know who it is.  Check the preferences.
	get_pref_cookie(\%state);
	
	if($q{mode}) {
		@state{qw(
			showcomments 
			showsubjonly 
			sortorder 
			showeverything
		)} = translate_old_mode($q{mode});
	}
	
	if($q{new_comment_prefs}) {
		if($state{login_user}) {
			# Assertion: if login_user, $state{ipe} exists and is loaded
			$state{ipe}->STYLE( build_pref_string(\%state) ); 
			eval { $state{ipe}->save() };
		}
		set_pref_cookie(\%state);
	}


	# if the path is empty then
	# we let them view just index.shtml in the top level
	# with our ssi, param substitution and login data
	
	#FIXME: top level index.shtml file needs new vars
 
	if ($state{path} eq '') {
		if($state{function} =~ /^\/?$/ || $state{function} =~ /^\/?index\.s?html\b/i) {
			# top level index file
			$state{function} = "index.shtml";
			my $template = "$Doc_Root/$state{function}";
			return output_template($template, \%state);
		}
		# Who knows, let apache handle it 
		#		return DECLINED;
	}

	# If inside /users, turn off posting unless this is our own user page
	# XXX Need to find a cleaner way to do this
	if ($state{path} eq 'users') {
		$state{nopost}=1 unless $state{login_user} && $state{ipe} && $state{ipe}->ID eq $q{id};
	}

	# Look up handler for this URL
	my $func = $Dispatch{$state{function}};
	
	my $conf=$Config{$state{path}};

	if($conf) {
		# pretty printing vars
		$state{article_table}=$conf->{"Articles"};
		$state{comment_table}=$conf->{"Comments"};
		$state{title}=$conf->{"Title"};
	} elsif ($func ||= $Dispatch{$state{path}}) {
		tie $state{article_table}, 'OUCH';
		tie $state{comment_table}, 'OUCH';
	} elsif ( -e "$Doc_Root/$fullpath" ) {
			my $template = "$Doc_Root/$fullpath";
			return output_template($template, \%state);
	} else {
		# Not allowed to use default handler unless there's a DB table for this URL
		return DECLINED unless $func; 
	}
	$func ||= $Dispatch{"/$state{path}/$state{function}"};
	$func ||= $Dispatch{DEFAULT};
	return DECLINED unless $func;
	return $func->(\%state);
}


#########################################################
#
#  Preference cookie management
#
#########################################################

# backwards compatibility
#
sub translate_old_mode 
{
	my $mode = shift;
	my ($sc, $ss, $so, $se) = (1, 1, 0, 0);
	if($mode eq 'flat') {
		$sc=1; $ss=1; $se=1;
	} elsif($mode eq 'thread') {
		$sc=1; $ss=1; $se=0;
	} elsif($mode eq 'indexed') {
		$sc=1; $ss=0; $se=0;
	} else { #classic
		$sc=0; $ss=0; $se=0;
	}
	($sc,$ss,$so,$se);
}


sub translate_new_mode 
{
	my ($sc, $ss, $so, $se) = @_;

	return 'classic' unless $sc;
	return 'flat'    if $se;
	return 'thread'  if $ss;
	return 'indexed';
}


sub parse_pref_string
{
	my $state = shift;
	my $pstr  = shift;
	if ($pstr =~/^0x([0-9a-fA-F]+)$/ ) {
		# new format
		my $num = hex($1);
		$state->{showcomments}   = ($num & BIT_SHOWCOMMENTS) ? 1 : 0;
		$state->{showsubjonly}   = ($num & BIT_SHOWSUBJONLY) ? 1 : 0;
		$state->{sortorder}      = ($num & BIT_SORTORDER) ? 1 : 0;
		$state->{seemod}         = ($num & BIT_SEEMOD) ? 1 : 0;
		$state->{showeverything} = ($num & BIT_SHOWEVERYTHING) ? 1 : 0;
		return;
	}

	if ($pstr) {
		#old format
		my @c = split /::/, $pstr, 2;
		my @st = translate_old_mode($c[0]);
		$state->{showcomments}  = $st[0];
		$state->{showsubjonly}  = $st[1];
		$state->{sortorder}     = $st[2];
		$state->{showeverything}= $st[3];
		$state->{seemod}        =( $c[1] ne 'no') ;
		return "wasold";
	}

	# Set up defaults
	$state->{showcomments} = 1;
	$state->{showsubjonly} = 1;
	$state->{sortorder} = 1;
	$state->{seemod} = 0;
	$state->{showeverything} = 0;
	return;
}


sub build_pref_string
{
	my $state = shift;

	my $num = 0;
	$num |= BIT_SHOWCOMMENTS   if $state->{showcomments};
	$num |= BIT_SHOWSUBJONLY   if $state->{showsubjonly};
	$num |= BIT_SORTORDER      if $state->{sortorder};
	$num |= BIT_SEEMOD         if $state->{seemod};
	$num |= BIT_SHOWEVERYTHING if $state->{showeverything};
	sprintf "0x%x", $num;
}


sub get_pref_cookie 
{
	my $state=shift;
	my $cookie = UFCGI->parse_cookie($ENV{HTTP_COOKIE})->{ars_pref};
	$state->{had_pref_cookie} = $cookie ? 1 : 0;
	parse_pref_string($state, $cookie) and set_pref_cookie($state);
}


sub set_pref_cookie
{
	my $state = shift;

	my $val = build_pref_string($state);
	my $c = UFCGI->build_cookie( 
		name    => 'ars_pref',
		value   => $val,
		expires => time + 86400*365*2,
		domain  => $Cookie_Domain,
		path    => '/',
	);
	$state->{cookie_out} = $c;
}


#########################################################
#
#  Authentication cookie management
#
#########################################################

sub build_auth_string
{
	my $state = shift;
	my $ip    = shift || $ENV{REMOTE_ADDR};
	my $time  = shift || time;

	my $login    = $state->{login_user};
	my $password = $state->{login_pass};
	my $val = join "::", $login, $ip, $password, $time;

	# Iterate thru by 8 byte hunks.  
	# with the added 8 spaces, do not do the last hunk.
	# which will be all spaces
	my $blown;		
	my $pos;
	for ( $pos = 0;  (($pos + 8) < length($val) ) ; $pos+=8 ) {
		$blown .= $cipher->encrypt(substr($val, $pos, 8));
		# encrypt this without temp vars 
	}

	my $enc	 = encode_base64($blown,"");

	$enc;
}


sub parse_auth_string
{
	my $state  = shift;
	my $cookie = shift;

	return unless $cookie;
	return if $cookie =~ /logged_out/;

	my $unenc= decode_base64($cookie);
	my $unblown;		

	# start at 8, take 8 bytes at a time
	# $unenc should be exactly a multiple of 8 bytes.

	my $pos;
	for ( $pos = 0; $pos<length($unenc); $pos += 8) {
		$unblown .= $cipher->decrypt(substr($unenc, $pos, 8));
	}
	my ($login, $ip, $password, $time)=split ( /::/, $unblown, 4);
}


sub get_auth_cookie
{
	my $state=shift;
	my $cookie = UFCGI->parse_cookie($ENV{HTTP_COOKIE})->{ars_user};
	my($login, $ip, $password, $time) = parse_auth_string($state, $cookie);
	($login, $ip, $password, $time);
}


sub set_auth_cookie
{
	my $state = shift;

	my $val = build_auth_string($state);
	my $c = UFCGI->build_cookie( 
		name    => 'ars_user',
		value   => $val,
		expires => time + 86400*30*7,
		domain  => $Cookie_Domain,
		path    => '/',
	);
	$state->{cookie_out} = $c;
}


sub build_logout_cookie
{
	UFCGI->build_cookie(
		name   => 'ars_user',
		value  => "logged_out", 
		expires=> time - 86400,
		domain => $Cookie_Domain,
		path   => '/'
	);
}


sub set_logout_cookie
{
	my $state = shift;
	$state->{cookie_out} = build_logout_cookie($state);
}
		

#
# Loads auth_user cookie and views it with a skeptical eye.
#
# Returns 1     if credentials looked good; $state->{login_user} etc. are set
# Returns undef if credentials didn't smell right for whatever reason.
#
# In either case, we guarantee that if $state->{ipe} exists, it has been
# loaded with the user's data record.
#
sub validate_auth_cookie
{
	my $state = shift;
	my ($login, $ip, $pass, $time) = get_auth_cookie($state);
	return unless $login && $pass;
	$state->{ipe} ||= UFIPE->new;
	my $ipe = $state->{ipe};
	eval { $ipe->load( USERNAME => $login, '-require_password' => $pass ) };
	(set_logout_cookie($state), return) if $@ =~ /not found/;
	return if $@;
	# return if $ipe->DISABLED;
	
	# Credentials look good.  Load into state
	$state->{user_type}  = $ipe->TYPE; 
	# yay, this is all it takes to get member specific includes
	$state->{member}     = ($ipe->{MEMBER} eq 'yes' && $ipe->{EXPIRE} > time ) ? 'yes' : 'no' ;
	$state->{login_user} = $login;
	$state->{login_pass} = $pass;
	$state->{auth_status}="Logged in as: <b>$login</b><br>" . login_links($state);
	return 1;	
}


######################################################
#
#  Utility functions
#
######################################################


sub password_boxes
{
	my $state = shift;

	return <<"EOF";
<form method=post action="http://ars.userfriendly.org/users/login.cgi">
Username<BR><input type="text" name="user" size=15 maxlength="15" value=""><BR>
Password<BR><input type="password" name="pass" size="15" maxlength="15"><BR>
<input type=hidden name=grab_refer value=yes>
<input type=submit name="Submit" value="Login">
</form>
<br><a href="users/login.html">Create a New Account</a>
EOF
}


sub login_links
{
	my $state = shift;
	my $username = $state->{login_user};

	return <<"EOF";
<a href="users/diarya954.html?id=$username">My Diary</a><br>
<a href="users/acct.html">My Settings</a><br>
<BR>&nbsp;
<BR>
<B><a href="users/logout.html">Log out</a></B><br>
EOF
}


sub article_not_here_yet_message_intable
{
	my $state = shift;
	my $path  = $state->{path};

	return "The requested article does not exist at this time." unless $path eq 'users';

	return "This user has not yet created a diary." 
		unless $state->{login_user} && $state->{ipe} && $state->{ipe}->ID == $state->{id};

	# This is the user's own diary, but it's empty.
	$state->{nopost} = 1;
	return <<"EOF";
	This is your diary page -- but you haven't put anything here yet.<p>
	
	To claim this spot on the web as your own, go into
	<a href="users/acct.html">your account settings</a> and type something
	interesting into the box labeled <b>Diary Top-Level Permanent Content</b>.<p>
EOF
}


sub article_not_here_yet_message
{
	my $state = shift;
	
	my $article = qq{<table width=100% cellpadding=2 cellspacing=2 border=0><tr><td>\n};
	$article .= article_not_here_yet_message_intable($state);
	$article .= qq{</td></tr></table>};
	
	$article;
}


#
# get_article_generic - get article HTML, or an appropriate "not here yet" msg
#
sub get_article_generic
{
	my $state = shift;
	my $path  = $state->{path};

	$state->{is_valid_article}=1;
	my $article = get_article_as_html( @$state{qw(id article_table user_type path)} );
	return $article if $article;

	# No content - whip up a placeholder of some sort.
	delete $state->{is_valid_article};
	return article_not_here_yet_message($state);
}


#
# dispatch for top level articles
# cartoons, or news/animation/lotd
#
sub get_article
{
	my $state=shift;
	my $id=$state->{id};
	my $table=$state->{article_table};
	my $priv=$state->{user_type};
	my $path=$state->{path};
	my $view_mode=$state->{showcomments};
	# my ($id,$table,$priv,$path,$view_mode) = @_;
	
	return "" if $state->{tid};
	return user_search_form($state) if $path eq 'users' && !$id; 
	return get_article_generic($state) unless $path eq "cartoons";

	$state->{is_valid_article}=1;
	my $article = get_cartoon_html($id,$table,$priv,$path,$view_mode,$state->{sortorder},$state->{showsubjonly});
	return $article if $article;

	delete $state->{is_valid_article};
	return article_not_here_yet_message($state);
}


# user search form.
# 15000 users is a bit much to pick from a single list. 
sub user_search_form
{
	return <<'EOF'
<b>Search for a user</b><BR>
<form method=get action="http://ars.userfriendly.org/users/diary.cgi">
<table border=0 cellspacing=0 cellpadding=2>
<tr><td><input type=text name=id size=15 maxlength=15 value=""></td></tr>
<tr><td colspan=2>&nbsp;</td></tr>
<tr><td colspan=2><input type=submit value=" Search "></td></tr>
</table>
</form><BR>
EOF

}


sub report_error 
{
	my $state=shift;
	my $message=shift;
	my $template="$Template_Dir/generic.html";
	return output_template($template,$state,errors=> $message);
}


sub build_link_back_to_index
{
	my $state = shift;
	"<a href=%24state-.html>{path}/?id=$state->{id}><h3>Back to $state->{title} Index</h3></a>\n";
}


sub redirect_to_url
{
	my $state = shift;
	my $url = shift;
	my $template = "$Template_Dir/redirect.html";
	return output_template($template, $state,  url => $url );
}


sub cachebust_url($)
{
	my $url = shift;
	$url .= ($url =~ tr/?/?/) ? '&' : '?';
	$url .= "cbst=" . (1000000 + int rand 1000000);
	$url;
}


sub redirect_to_cachebusted_url
{
	my $state = shift;
	my $url = shift;
	return redirect_to_url($state, cachebust_url $url);
}


sub add_state_to_url
{
	my $state = shift;
	my $url   = shift;
	my @add   = @_;

	$url .= ($url =~ tr/?/?/) ? '&' : '?';
	
	$state->{$_} and $url .= "$_=$state->{$_}&" for @add;
	
	$url =~ s/[?&]$//;
	$url;
}


sub pref_dependency_javascript
{
	my $state    = shift;
	my $formname = shift;
	my $sc_name  = shift;
	my $ss_name  = shift;
	# XXX finish this my $
}


sub comment_mode_bar
{
	my $state = shift;

	my $f = "document.forms['prefset']";

	# Adjust these element numbers if the mode_bar form is altered
	my $show_comments = "$f.elements[0]";
	my $subject_only  = "$f.elements[1]";
	my $show_everything="$f.elements[2]";

	my $top_path = $state->{path};
	my $id = $state->{id};

	my %checked = map { $_ => '' } qw(classic indexed thread flat);
	my $mode = translate_new_mode(@$state{qw(showcomments showsubjonly sortorder showeverything)});
	$checked{$mode} = ' checked';
	
	my $postlink = $state->{nopost} 
		? "" 
		: qq{ <font size="+1"><b><a href="%24top_path/post307e.html?id=$id">Post&nbsp;new&nbsp;comment</a></b></font>};

	return <<"EOF";
<form method=post name=prefset>
<table border=0 cellspacing=0 cellpadding=0 width="100%" bgcolor="#ffffcc">
<tr>
  <td rowspan=2 width="2%">&nbsp;</td>
  <td rowspan=2 width="1%">$postlink</td>
  <td rowspan=2 width="2%">&nbsp;</td>
  <td><input type=radio name=mode value=classic$checked{classic}>Hide&nbsp;User&nbsp;Comments&nbsp;</td>
  <td><input type=radio name=mode value=indexed$checked{indexed}>Expand&nbsp;Top-Level&nbsp;</td>
  <td rowspan=2>
    <input type=hidden name=new_comment_prefs value=1>
    <input type=hidden name=id value="$id">
    <input type=submit value="Set View">
  </td>
</tr>
<tr>
  <td><input type=radio name=mode value=thread$checked{thread}>Show&nbsp;Subjects&nbsp;Only&nbsp;</td>
  <td><input type=radio name=mode value=flat$checked{flat}>Expand&nbsp;All&nbsp;</td>
</tr>
</table>
</form>
EOF
}


sub output_template 
{
	my $template_path=shift;
	my $state=shift;
	my $r=$state->{r};

	$r->content_type('text/html');
	$r->status(200);

	# Add headers as needed

	if ($state->{cachebuster}) {
		my $ut = time + 1;
		my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($ut);
		my($wday_str, $mon_str) = split " ", scalar(gmtime($ut));
		$year += 1900;
		my $expiry = sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
			$wday_str, $mday, $mon_str, $year, $hour, $min, $sec;

		$r->header_out( 'Cache-Control', 'no-cache' );
		$r->header_out( 'Pragma', 'no-cache' );
		$r->header_out( 'Expires', $expiry );
	} else {
		$r->header_out( 'Cache-Control', 'private' );
	}

	# add cookie if state has one for us;
	# FIXME: only does 1 cookie at a time.
	# header_out _may_ take a list
	
	$r->header_out( 'Set-Cookie' => $state->{cookie_out} ) if $state->{cookie_out};

	$r->send_http_header;

	print param_replace( ssi_replace( read_file($template_path), $state), { %$state, @_ });

	return OK;
}


##############################################################################
#
#  Handler utilities - use to add capabilities/restrictions to handlers
#
##############################################################################

#
# cachebust handler builder - make handler's output uncacheable
#
sub cachebust($)
{
	my $handler = shift;

	sub {
		my $state = shift;
		$state->{cachebuster} = 1;
		$handler->($state);
	}
}


sub require_login($)
{
	my $handler = shift;

	sub {
		my $state = shift;

		# are we logged in?
		unless( $state->{login_user} ) {
			# No.. send them to the login form first.
			$state->{refer} = $ENV{REQUEST_URI};
			return emit_user_login_form($state); 
			# XXX Pathological dependency on a subroutine from another plug-in
		}

		$handler->($state);
	}
}

sub require_login_for_path($$)
{
	my $path    = shift;
	my $handler = shift;

	my $require_login = require_login $handler;

	sub {
		my $state = shift;

		($state->{path} eq $path ? $require_login : $handler)->($state);
	}
}


sub retitle($$)
{
	my $title   = shift;
	my $handler = shift;

	sub {
		my $state = shift;
		$state->{title} = $title;
		$handler->($state);
	}
}



1;

__END__

=pod

=head1 NAME

RequestHandler - Universal request handler

=head1 SYNOPSIS

  <Location />
      SetHandler perl-handler
      PerlHandler RequestHandler
  </Location>

=head1 DESCRIPTION

 Main entry routine of UF's ARS comment system.
 All content below a given Location is processed by
 this handler, so its likely a good idea to have graphics
 handled by a different server. The system works fine 
 without it, but using a heavyweight mod_perl process 
 for graphics is probably a poor use of resources.

 Handles url's in the form:

 /$Config{pathname}/[read.cgi|post.cgi|postn.cgi|postr.cgi|reply.cgi]

 where $Config{pathname} is a key into a data structure 
 in the ars.conf file that defines the tables, titles, and names.

=head2 Config Data

 $Config{pathname}  containing the posting and message db names
 $Doc_Root/$path/post.html comment.html 
 path => from URI
 function => from URI

=head2 Params

 id => Top level article id
       cartoon date, 
       news article id, 
       or other article id
 tid => "thread id" or key of item within comment table
 level => depth of comment 1 -> n
 subject of message
 message content
 submit button text (for preview)
 user - username in db if not logged in
 pass - pass in db  ""  " " " 
 cookie for prefs (ars_prefs)
 cookie for login (ars_user)

=head1 BUGS

 Probably. 

=head1 AUTHORS

 Jay Thorne <jay@userfriendly.org>
 Mike Lyons <lyonsm@userfriendly.org>

=cut


                                                                                                                                                                                                                                                                                                                                                                                                          perl/UFCGI.pm                                                                                       0100755 0000000 0000000 00000005332 07277030757 011736  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ;# UFCGI - lightweight and sensible CGI utilities

require 5.005;
package UFCGI;
use strict;
use integer;


#
# unescape - simple URI unescape
#
sub unescape {
	shift if ref($_[0]) || $_[0] eq __PACKAGE__; # work as a method
	my $todecode = shift; 
	return undef unless defined($todecode);
	$todecode =~ tr/+/ /;
	$todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
	return $todecode;
}


#
# escape - simple URI escape
#
sub escape {
	shift if ref($_[0]) || $_[0] eq __PACKAGE__; # work as a method
	my $toencode = shift;
	return undef unless defined($toencode);
	$toencode=~s/([^a-z A-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
	$toencode=~s/ /+/g;
	return $toencode;
}


#
# parse_cookie - simple cookie parser
#
sub parse_cookie {
	shift if ref($_[0]) || $_[0] eq __PACKAGE__; # work as a method
	my $raw_cookie = shift;
	my %results;

	my(@pairs) = split("; ",$raw_cookie);
	foreach (@pairs) {
		my($key,$value) = split("=");
		#my(@values) = map unescape($_),split('&',$value);
		$key = unescape($key);
		$results{$key} = unescape($value);
	}

	return \%results unless wantarray;
	return %results;
}


sub _fix_exp {
	my $ut = shift;

	die "Unsupported time format: $ut\n" unless $ut =~ /^\d+$/;

    my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($ut);
	my($wday_str, $mon_str) = split " ", scalar(gmtime($ut));
    $year += 1900;
    return sprintf("%s, %02d-%s-%04d %02d:%02d:%02d GMT",
		$wday_str,$mday,$mon_str,$year,$hour,$min,$sec);
}


sub build_cookie {
	shift if ref($_[0]) || $_[0] eq __PACKAGE__; # work as a method
	my $self = { @_ };
	my(@constant_values,$domain,$path,$expires,$secure);
	push(@constant_values,"domain=$domain") if $domain = $self->{domain};
	push(@constant_values,"path=$path") if $path = $self->{path};
	push(@constant_values,"expires=$expires") if $expires = _fix_exp($self->{expires});
	push(@constant_values,'secure') if $secure = $self->{secure};

	my($key) = escape($self->{name});
	my($cookie) = join("=",$key,join("&",map escape($_),$self->{value}));
	return join("; ",$cookie,@constant_values);
}


1;

=head1 NAME

UFCGI - lightweight, sensible CGI utilities

=head1 SYNOPSIS

  use UFCGI;

  $escaped   = UFCGI::escape("string with %5e URI escapes");
  $unescaped = UFCGI::unescape($escaped);
  %cookies   = UFCGI::parse_cookie('THIS=that');

=head1 DESCRIPTION

This module provides small and fast replacements for some common tasks
that would otherwise require including the largeish CGI.pm.

=head1 BUGS

=over 4

=item *

Netscape supposedly has a bug whereby multiple cookies with the same
name appear, requring a cookie parser to remember and use the first
one seen.  This parser makes no effort to retain such state.

=item *

Unlike CGI.pm, our decode() function makes no effort to support EBCDIC.

=back

=cut

                                                                                                                                                                                                                                                                                                      perl/UFDataLogger.pm                                                                                0100755 0000000 0000000 00000007056 07550100725 013335  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ;# $Id: UFDataLogger.pm,v 2.1 2002/10/06 18:32:53 jay Exp $
package UFDataLogger;

# single purpose, data logging and retrieval library

require 5.005;
use strict;

BEGIN {
	use Exporter ();
	use vars     qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
	$VERSION     = 4.00;
	@ISA         = qw(Exporter);
	%EXPORT_TAGS = (
		all => [qw(transactionlist transactioninsert)],
	);
	#Exporter::export_tags(keys %EXPORT_TAGS);
	Exporter::export_ok_tags(keys %EXPORT_TAGS);
}


$VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker

# System includes

# Local includes
use UFSQL;
use ARSConfig;
UFSQL->set_database(@$GC{qw(dbi_dsn dbi_user dbi_pass)});

##############################################################################
#
#  Globals
#
##############################################################################

use vars qw($Sql);          # singleton UFSQL object
use vars qw($Table);		# table name,from config
use vars qw(%TypeTable);	# hardcoded transaction types
use vars qw(@fieldlist);	# db fields
use vars qw(%fieldlist);	# little list of formatter functions

$Sql ||= UFSQL->new;

my %TypeTable= (
		'CP' => "Credit Card Payment",
		'CW' => "Credit Card Payment Via Web",
		'CR' => "Credit Card Return",
		'PP' => "Paypal Payment",
		'PR' => "Paypal Return",
		'PW' => "Paypal Payment Via Web",
		'QP' => "Cheque Payment",
		'QR' => "Cheque Return",
		'QW' => "Cheque Payment Via Web",
		'FR' => "Promotional",
		'ST' => "Membership Status Change",
		'CA' => "Cancelled Membership",
	);

my $Table= $GC->{logging_table} or die "conf file not updated";

my @fieldlist=(
	userid 	=> { format=> sub { return shift }, name => "User Number",},
	etype	=> { format=> sub { my $t=shift; return $TypeTable{$t}; }, name=> "Type", },
	tdate	=> { format=> sub { return scalar localtime shift }, name=> "Date" ,},
	detail	=> { format=> sub { return shift}, name=> "Detail" ,},
	);

my %fieldlist=@fieldlist;
{ my $i; @fieldlist= grep { ++$i % 2 } @fieldlist; }


# routines

sub _transactionquery ($) 
{
	my $userid=shift;
	# select all records
	my @list=();
	my $flist=join "," , @fieldlist;
	my $sth =   $Sql->select_many($flist,$Table,"userid=$userid ", "order by tdate");
	my $hr;
	while ($hr = $sth->fetchrow_hashref) {
		push @list, $hr; 
	}
	$sth->finish;
	return \@list;
	# ref to list of hashes of records.
}

sub transactionlist ($)
{
	my $userid=shift;
	my $list=_transactionquery($userid);
	# now we have a nice list. 
	# we reformat prettily
	my $out="<TABLE CELLPADDING=3 CELLSPACING=1 BGCOLOR=\"#000000\"><TR>\n";
	foreach my $field (@fieldlist) {
		next if $field eq "userid";
		$out.="<TD BGCOLOR=\"#EEEEEE\"><B>$fieldlist{$field}->{name}</B> </TD>\n";
	}
	$out.="</TR>\n";
	foreach my $line (@{$list}) {
		$out .="<TR>\n";
		foreach my $field (@fieldlist) {
			next if $field eq "userid";
			$out.="<TD BGCOLOR=\"#FFFFFF\">\n";
			$out.= $fieldlist{$field}->{format}( $line->{$field} );
			$out.="</TD>\n";
		}
		$out .="</TR>\n";
	}
	$out.="</TABLE>\n";
	return $out;
}

sub transactioninsert ($$$)
{
	my $userid =shift;
	my $etype=shift;
	my $tdate=time;
	my $detail=shift;
	my $sth =   $Sql->select_many("userid", $Table,"userid=$userid and etype='$etype' and detail='$detail' ", "");
	if($sth->rows > 0 ) {
		$sth->finish;
		# whoops, this one already exists
		return 0;
	} 
	$sth->finish;
	my %rec=( 
		"userid" => $userid,
		"etype"  => $etype,
		"tdate"  => $tdate,
		"detail" => $detail,
		);
	my $id=0;	
	eval { $id = $Sql->insert_id($Table, \%rec) };
	die "Insert Transaction fatal DB error: $@\n" if $@ ;
	return $id;
}

                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  perl/UFIPE.pm                                                                                       0100755 0000000 0000000 00000066717 07442556670 011770  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ;# $Id: UFIPE.pm,v 1.19 2002/03/10 04:04:21 jay Exp $
package UFIPE;

require 5.005;
use strict;
use vars qw($VERSION);

$VERSION = do { my @r = (q$Revision: 1.19 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker

# System includes

# Local includes
use UFSQL;
use ARSConfig;
UFSQL->set_database(@$GC{qw(dbi_dsn dbi_user dbi_pass)});


##############################################################################
#
#  Globals
#
##############################################################################

use vars qw($Init);         # TRUE if _class_init() has been called
use vars qw($Sql);          # singleton UFSQL object
use vars qw(%Props);		# name => { ID NAME HOISTED IDX }
use vars qw(@Props);        # NAMEs of all Props
use vars qw(@HoistedProps);	# NAMEs of Props where HOISTED is true
use vars qw($HoistedProps); # @HoistedProps as comma-delimited string
use vars qw(@CommonProps);  # NAMEs of Props where HOISTED is false
use vars qw(@MailingLists); # Holds names of all mailing lists
use vars qw(%MailingLists); # name => { ID NAME DESCRIPTION FREQUENCY OLDFIELDNAME IDX }
use vars qw(@Prefs);        # List of preference names, in useful order
use vars qw(%Prefs);        # preference name => { bit desc }
use vars qw(%OldStyle);     # old STYLE cookie => corresponding bitmap string


##############################################################################
#
#  Global Variable Initialization
#
##############################################################################


@Prefs = qw(showcomments showsubjonly seemod showeverything);
%Prefs = (
	showcomments => { bit=>0x01, desc=>"Show comments" },
	showsubjonly => { bit=>0x02, desc=>"Show comment subjects only" },
	showeverything=>{ bit=>0x10, desc=>"Show expanded view of ALL comments" },
	#sortorder    => { bit=>0x04, desc=>"Order comments by thread instead of date" },
	seemod       => { bit=>0x08, desc=>"Show comments that have been moderated" },
);

%OldStyle = (
	'thread::on'  => '0x9',
	'indexed::on' => '0xA', 
	'classic::on' => '0x8',
	'flat::on'    => '0x1A',
	'thread::off' => '0x1',
	'indexed::off'=> '0x3', 
	'classic::off'=> '0x0',
	'flat::off'   => '0x13',
);


##############################################################################
#
#  Subroutines
#
##############################################################################


#
# printablechar - operator that guarantees a string is printable
#
# Normally returns it's argument unmodified.  Throws exception
# if it's argument contains unprintable characters.
#
sub printablechar($)
{
	my $arg = shift;

	my $tval = $arg;
	$tval =~ tr/\040-\377\015\012//cd;
	die "<S>field contains invalid characters</S>" 
		unless $arg eq $tval;

	$arg;
}


#
# reallyprintablechar - operator that guarantees a string is printable
#                       and contains no high ascii
#
# Normally returns it's argument unmodified.  Throws exception
# if it's argument contains unprintable characters.
#
sub reallyprintablechar($)
{
	my $arg = shift;

	my $tval = $arg;
	$tval =~ tr/\040-\177\015\012//cd;
	die "<S>field contains invalid characters</S>" 
		unless $arg eq $tval;

	$arg;
}


#
# maxlen - operator that guarantees a string is shorter than maxlen
#
# Usage:  my $blah = maxlen 255, $foo;
#
# Normally returns it's second argument unmodified. Throws an exception
# if the second argument is longer than the first in characters.
#
#
sub maxlen($$)
{
	my ($len, $arg) = @_;
	die "<S>field too long</S>" if length($arg) > $len;
	$arg;
}


##############################################################################
#
#  Methods
#
##############################################################################


# _class_init - load property list and build any needed accessor methods
#
# May be called as either instance or static method.
#
sub _class_init
{
	return if $Init;

	$Sql ||= UFSQL->new;

	my $that = shift;
	$that->_load_property_list;
	$that->_load_mailing_lists;
	$that->_build_methods;
	
	$Init=1;
}


#
# _load_property_list - load global property list from database.
#
# May be called as either instance or static method.
#
# Returns nothing useful.  Dies on DB error.
#
sub _load_property_list
{
	my $that = shift;

	return if %Props;
	%Props = @Props = @HoistedProps = @CommonProps = ();

	my $sth = $Sql->select_many('ID,NAME,HOISTED', 'PROPERTIES')
		or die "_load_property_list: SQL error loading properties list";

	while (my $row = $sth->fetchrow_hashref) {
		my $ID      = int( $row->{ID}      );
		my $NAME    =      $row->{NAME};
		my $HOISTED = int( $row->{HOISTED} );
		
		if ($HOISTED) {
			push @HoistedProps, $NAME;
		} else {
			push @CommonProps, $NAME;
		}
		
		push @Props, $NAME;

		$Props{$NAME} = {
			ID      => $ID, 
			NAME    => $NAME, 
			HOISTED => $HOISTED,
			IDX     => $#Props,
		};
	}

	$HoistedProps = join(",", @HoistedProps);

	die "_load_property_list: hoisted ID and USERNAME properties must exist" 
		unless	$Props{ID}       && $Props{ID}->{HOISTED} && 
				$Props{USERNAME} && $Props{USERNAME}->{HOISTED};

	$sth->finish;
}


#
# _load_mailing_lists - load mailing list configuration
#
# May be called as either instance or static method.
#
# Returns nothing useful.  Dies on DB error.
#
sub _load_mailing_lists
{
	my $that = shift;

	return if %MailingLists;
	%MailingLists = @MailingLists = ();

	my $sth = $Sql->select_many('ID,NAME,DESCRIPTION,FREQUENCY,OLDFIELDNAME', 'MAILINGLISTS')
		or die "_load_mailing_lists: SQL error loading mailing lists";

	while (my $row = $sth->fetchrow_hashref) {
		my $ID          = int $row->{ID};
		my $NAME        = $row->{NAME};
		my $DESCRIPTION = $row->{DESCRIPTION};
		my $FREQUENCY   = $row->{FREQUENCY};
		my $OLDFIELDNAME= $row->{OLDFIELDNAME};

		push @MailingLists, $NAME;
		$MailingLists{$NAME} = {
			ID           => $ID,
			NAME         => $NAME,
			DESCRIPTION  => $DESCRIPTION,
			FREQUENCY    => $FREQUENCY,
			OLDFIELDNAME => $OLDFIELDNAME,
			IDX          => $#MailingLists,
		};
	}

	$sth->finish; 
}


#
# _build_methods - construct accessor methods that don't already exist
#
# May be called as either instance or static method.
#
sub _build_methods
{
	my $that  = shift;
	my $class = ref($that) || $that;

	$that->_load_property_list unless %Props;

	# Construct all the default accessor/mutator methods.
	# We'll build methods for each prop that we don't already handle.
	# Saves us from having to use the AUTOLOAD hack.
	foreach (@Props) {
		my $method = $_;
		
		next if $that->can($method); # Ooh, already got one!
		
		my $subref = sub {
			my $self = shift;

			if (@_) {
				my $newval = printablechar maxlen(255, scalar(shift || ''));
				$self->_dirty($method, 1); # note that field has been changed
				return $self->{$method} = $newval;
			}

			$self->_maybe_load_prop($method);
			$self->{$method};
		};

		no strict 'refs';
		*{"${class}::${method}"} = $subref;
	}
}


sub splain
{
	my $self = shift;
	my $exception = shift;

	$exception =~ m#<s>(.*?)</s>#i ? $1 : "Internal error";
}


sub dbh 
{ 
	my $self = shift;
	return $self->{_dbh}=shift if @_;
	$self->{_dbh} 
}


#
# new - create new UFIPE interface.
#
# Static method.
#
sub new
{
	my $class= shift;
	my $self = {};
	bless $self, $class;
	$self->init(@_);
}


#
# init - initialize a UFIPE object.
#
# Returns $self.  May die on DB error.
#
sub init
{
	my $self = shift;
	my %args = @_;

	die "UFIPE::init: can't set ID in init; just use load()" if $args{ID};

	$self->_class_init unless $Init;

	# Start with the blankest of slates
	%$self = ();

	$self->dbh( $Sql->dbh );

	$self->_clean_all;
	$self->_defer_enable(1);
	
	foreach my $prop (keys %args) {
		next if $prop =~ /^\-/; # skip switches
		die "UFIPE::init: illegal property name $prop" unless $Props{$prop};
		my $method = $self->can($prop) or die "Missing method: $prop";
		$self->$method( $args{$prop} );
	}

	$self;
}


#
# clear - wipe a UFIPE object, preparing it for reuse
#
sub clear { $_[0]->init }


#
# _dirty - set or clear dirty flag for a property
#
# Usage:  $self->_dirty('SECMAIL', 1);  # SECMAIL changed since last save/load
#         &foo if $self->_dirty('LISTMAIL');
#
# Semantics of dirty flag: When save() is called, only those properties
# marked as dirty are written back to the database.  All dirty flags are
# cleared after every new(), init(), or clear(), and after completion of
# any successful load() or save().  Mutators set the dirty flag whenever
# a property is changed.
#
# Implementation: $self->{_dirty} is a string $#Props chars long.  A '0' in
# position N means that the property whose $Props{PROPNAME}->{IDX} is N is 
# clean, while a '1' in this position means 'dirty'.  Remember that a property
# IDX is a small nonnegative integer corresponding to it's index in @Props.
# This will almost certainly be different from the property ID (which come
# from the database, and may be large and discontiguous).
#
sub _dirty
{
	my $self = shift;
	my $prop = shift;
	my $fnum = $Props{$prop}->{IDX};
	return int( substr( $self->{_dirty}, $fnum, 1 ) ) unless @_;
	substr( $self->{_dirty}, $fnum, 1 ) = int(shift);
}


#
# _clean_all - clear dirty flag for all properties
#
sub _clean_all { $_[0]->{_dirty} = '0' x @Props }


#
# _defer_enable - set or clear defer enable flag
#
# Usage:  $self->_defer_enable(1);  # Load undef props from DB on 1st access
#
# Semantics of defer enable flag: off by default.  Turned on by load()
# if any properties were deferred.  If this is on, accessor methods will
# call _load_prop() on demand to fill in properties that are undef.  Once
# a property has been loaded from the DB, it is guaranteed to be defined
# (it might be an empty string, however).
#
sub _defer_enable { 
	my $self=shift; 
	@_ ? $self->{_defer_enable} = shift : $self->{_defer_enable};
}


#
# load - load a user record from the database
#
# Usages:   $self->load( $user_id );
#           $self->load( ID => $user_id );
#           $self->load( USERNAME => $user_name );
#
sub load
{
	my $self = shift;
	unshift @_, 'ID' if (@_ == 1);
	my %args = @_;

	# Figure out just what we're loading.
	my @loadprops = grep { $Props{$_} } @{ $args{'-load'} || [] };
	my @loadcommon= grep { !$Props{$_}->{HOISTED} } @loadprops;
	@loadprops   = (@loadprops, @HoistedProps); 
	# always load all hoisted

	#$self->_defer_enable( $args{-nodefer} ? 0 : 1 );

	# First, load the primary record and all hoisted props therein
	my $key = $args{ID} ? 'ID' : 'USERNAME';
	my $val = $args{$key};
	die "load: must specify ID or USERNAME" unless $val;

	my $where;
	if ($key eq 'ID') {
		die "load: ID must be an integer" unless $val eq int($val);
		$where = "$key=$val";
	} else {
		$where = "$key=" . $Sql->quote($val);
	}
	
	my $needpass = $args{'-require_password'};
	$where .= " and PASSWORD=PASSWORD(" . $Sql->quote($needpass) . ")" if $needpass;

	my $rec;
	$Sql->cache_next_query;
	eval { $rec = $Sql->select_hashref($HoistedProps, 'USERS', $where) };
	die "load: SQL error loading main user record: $@" if $@;
	die "load: user not found" unless $rec;

	$self->{$_} = $rec->{$_} || '' foreach @HoistedProps;

	# Prepare to load requested common properties.
	$self->{$_} = undef foreach @CommonProps;

	my @loadcommon_ids = map { $Props{$_}->{ID} } @loadcommon;
	if( @loadcommon_ids ) {
		$Sql->cache_next_query;
		
		my $sth = $Sql->select_where_in(
			SELECT => 'NAME,VALUE', FROM => 'USERPROPERTIES',
			WHERE => "USERID=$self->{ID} AND PROPID", '-IN' => \@loadcommon_ids,
		);

		while(my $hr = $sth->fetchrow_hashref) {
			$self->{ $hr->{NAME} } = $hr->{VALUE} || '';
		}

		$sth->finish;
	}

	# Nothing has changed since last save.
	$self->_clean_all;

	# All done.
	$self;
}


#
# _load_prop - load one deferred-load property from the database.
#
# Usage:  $self->_load_prop('LISTMAIL');
#
# Returns nothing useful.  Dies on error.  Note that it is _much_
# faster to let load() load all the pertinent properties at once
# than to fault them in one-at-a-time with _load_prop().
#
sub _load_prop
{
	my $self = shift;
	my $prop = shift;
	my $propid = $Props{$prop}->{ID} or die "fatal: _load_prop: unknown property $prop";

	die "fatal: _load_prop: deferred load with no ID" unless $self->{ID};

	my $row = $Sql->select_hashref(
		'VALUE,PROPID,USERID',
		'USERPROPERTIES',
		"PROPID=$propid and USERID=" . $self->{ID}
	);

	$self->_dirty($prop, 0);
	$self->{$prop} = $row->{VALUE} || '';
}


#
# _maybe_load_prop - do a deferred-load of a prop if necessary
#
sub _maybe_load_prop
{
	my $self = shift;
	my $prop = shift;

	return if defined($self->{$prop});
	return unless $self->_defer_enable;
	$self->_load_prop($prop);
}

					
#
# save - save a possibly-new record back to the database.
#
# Returns the user ID assigned to the possibly-new record.
#
sub save
{
	my $self = shift;
	my $dbh = $self->dbh;

	my $id = $self->{ID};
	$self->_dirty('ID') and die "Assertion failed: who changed ID?!";

	$self->{UPDATED}=time;
	$self->_dirty('UPDATED', 1);

	my @hoisted = grep { $self->_dirty($_) } @HoistedProps;
	my @common  = grep { $self->_dirty($_) } @CommonProps;
	$self->_clean_all;
	
	# Try to insert each common property.  If it fails, try an update.
	# If both fail, log the anomoly and give up.
	foreach my $prop (@common) {
		my $userid = $self->{ID};
		my $propid = $Props{$prop}->{ID};
		my $value  = $self->{$prop};

		if ($value) {
			# Value is true.  Try the insert first; if this fails,
			# switch to update.
			my $result;
			my $rec = { USERID => $userid, PROPID => $propid, VALUE => $value };
			eval { 
				local $dbh->{RaiseError} = 1;
				local $dbh->{PrintError};
				$result = $dbh->do( $Sql->insert_sql('USERPROPERTIES', $rec) ) 
			};
			die "Insert fatal DB error: $@\n" if $@ && $@ !~ /Duplicate entry/; # XXX mysql dep
			$Sql->update('USERPROPERTIES', $rec, "USERID=$userid and PROPID=$propid")
				if $@ || !$result;
		} else {
			# Value is undefined.  Delete the row(s), if any.
			$Sql->delete('USERPROPERTIES', "USERID=$userid and PROPID=$propid");
		}
	}

	# If no hoisted props are dirty, we're already done.
	return $id unless @hoisted;

	# Update or insert main USERS record, as appropriate
	my %rec = map { $_, $self->{$_} } @hoisted;
	return $self->{ID} = $Sql->insert_id('USERS', \%rec) unless $id;
	$Sql->update('USERS', \%rec, "ID=$id");
	$id;
}


#
# list_properties - list of supported property names
#
sub list_properties
{
	return @Props;
}


#
# _list_setup - prepare to fetch/alter global list subscriptions
#
# Usage:  ($mailid, $bmapid) = UFIPE->_list_setup;
#
# Static method.  croaks unless both LISTBITMAP and LISTMAP props exist.
#
sub _list_setup
{
	my $class = shift;

	$class->_class_init unless $Init;

	my $bmapid = $Props{LISTBITMAP}->{ID}
		or die "fatal: no LISTBITMAP property in PROPERTIES tbl";

	my $mailid = $Props{LISTMAIL}->{ID}
		or die "fatal: no LISTMAIL property in PROPERTIES tbl";

	$Props{LISTBITMAP}->{HOISTED}
		and die "fatal: wasn't expecting LISTBITMAP prop to be hoisted";

	$Props{LISTMAIL}->{HOISTED}
		and die "fatal: wasn't expecting LISTMAIL prop to be hoisted";

	wantarray ? ($mailid, $bmapid) : $mailid;
}


#
# build_maillist - return list of email addresses for a given list number.
#
# Static method.  Returns a list of email addresses.  Croaks on error.
sub build_maillist
{
	my $class = shift;
	my $listnum = shift;

	die "fatal: no list number specified" unless defined $listnum;
	
	$listnum++; # silly SQL uses base-1 string indices :(

	my ($mailid, $bmapid) = $class->_list_setup;

	my $sth = $Sql->select_many('USERID', 'USERPROPERTIES', 
		"PROPID=$bmapid and substring(VALUE, $listnum, 1)='1'")
			or die "DB failure fetching user ID list: $DBI::errstr";

	my @uids = ();
	while(my $row = $sth->fetchrow_arrayref) {
		push @uids, int($row->[0]) if int($row->[0]);
	}
	
	$sth->finish;

	# If no subscribers, we're done
	return unless @uids;

	# Now fill in the email addresses and return them.
	map { $_->[0] || () } $Sql->select_where_in(
		SELECT => 'VALUE', FROM => 'USERPROPERTIES',
		WHERE => "PROPID=$mailid AND USERID", '-IN' => \@uids,
	);
}


#
# unsubscribe_addresses - remove a list of addresses from all mailing lists
#
# Static method.  Returns the number of users unsubscribed. Croaks on error.
#
sub unsubscribe_addresses
{
	my $class = shift;
	my @addrs = ();

	my ($mailid, $bmapid) = $class->_list_setup;

	for (@_) {
		my ($local, $host) = split /\@/;
		my $addr = join '@', $local, lc($host);
		push @addrs, $addr;
	}

	# Which users are affected?
	my @uids = map { $_->[0] || () } $Sql->select_where_in(
		SELECT => 'USERID', FROM => 'USERPROPERTIES',
		WHERE => "PROPID=$mailid AND VALUE", IN => \@addrs,
	);

	# Unsub these users.
	$Sql->update_where_in(UPDATE => 'USERPROPERTIES', SET => { VALUE => '' },
	                      WHERE => "PROPID=$bmapid AND USERID", '-IN' => \@uids);
}


#
# Nonstandard accessor method for ID field (it can't get dirty).
#
sub ID 
{
	my $self = shift;
	die "UFIPE: ID is a read-only field" if @_;
	$self->{ID};
}


#
# Nonstandard mutator method for mailing list field (lowercase the hostname)
#
# Usage:  $value = $self->_email_getset('FIELDNAME');
#         $self->_email_getset('FIELDNAME', $new_value);
#
sub _email_getset
{
	my $self  = shift;
	my $field = shift;

	# Handle read request
	unless(@_) {
		$self->_maybe_load_prop($field);
		return $self->{$field};
	}

	my $addr = shift || '';
	
	if ($addr) { 
		my $copy;
		eval { $copy = reallyprintablechar maxlen(300, $addr) };
		die "_email_getset $field: $@" if $@;
		$copy =~ tr/\!-\~//cd;
		die "_email_getset $field: <s>email address contains characters we're unable to store</s>: $addr\n" 
			unless $copy eq $addr;

		die "_email_getset $field: <s>email address contains too many @ signs</s>: $addr\n"
			if ($addr =~ tr/@/@/) > 1;

		my ($local, $host) = split /\@/, $addr;
		die "_email_getset $field: <s>email address has invalid domain name</s>: $addr\n" unless $host =~ /.+\..+/;
		$addr = join '@', $local, lc($host);
	}

	$self->_dirty($field, 1);
	$self->{$field} = $addr;
}


#
# Nonstandard accessor/mutator methods for email addresses (validation, and host part to lowercase)
#
sub LISTMAIL { my $self=shift; $self->_email_getset('LISTMAIL', @_) }
sub SECMAIL  { my $self=shift; $self->_email_getset('SECMAIL', @_) }


#
# Nonstandard accessor for UPDATED (format nicely, and it's read-only)
#
sub UPDATED
{
	my $self = shift;
	die "UFIPE: UPDATED is a read-only field" if @_;
	my $date = $self->{UPDATED};
	return unless $date;
	scalar localtime($date);
}


#
# _hash_password - Find the hashed version of a plaintext password
# 
# Usage:  $hashed = $self->_hash_password($plaintext):
#
# Uses the database to do the password hashing.
#
sub _hash_password
{
	my $self  = shift;
	my $plain = shift;

	# Force it to a string value and quote it
	$plain = $Sql->quote("".$plain);
	my $hr = $Sql->select_hashref("PASSWORD($plain) as CP");

	$hr->{CP};
}


#
# Nonstandard mutator
#
# Passwords are write-only: read attempts throw an exception. 
# To validate a password, use the PASSWORD_check() method.
#
sub PASSWORD
{
	my $self  = shift;
	die "PASSWORD is write-only; use PASSWORD_check() to validate" unless @_;
	my $plain = shift;
	my $hashed= $self->_hash_password($plain);
	$self->_dirty('PASSWORD', 1);
	$self->{PASSWORD} = $hashed;
}


#
# PASSWORD_check - check whether a candidate password matches the
# one in the database.
#
# Usage:  die "Phooey on you" unless $user->PASSWORD_check('secret');
#
sub PASSWORD_check
{
	my $self = shift;
	my $plain= shift;

	$self->{PASSWORD} eq $self->_hash_password($plain);
}


#
# Nonstandard accessor for DIARYCONTENT (allow it to be super long)
#
sub DIARYCONTENT
{
	my $self = shift;
	
	if(@_) {
		my $newcontent = printablechar maxlen(7900, scalar(shift||''));
		$self->_dirty('DIARYCONTENT',1);
		return $self->{DIARYCONTENT} = $newcontent;
	}

	$self->_maybe_load_prop('DIARYCONTENT');
	$self->{DIARYCONTENT};
}


#
# Nonstandard mutator method for LISTBITMAP field (cleaner interface)
#
# Usage:  if ( $user->LISTBITMAP(1) ) { # user is subscribed to list #1 }
#         $user->LISTBITMAP(2, 1); # Subscribe user to list #2
#         $user->LISTBITMAP(5, 0); # Unsubscribe user from list #5
#
# In array context, returns the list of listnums subscribed:
#         @lists = $user->LISTBITMAP;
#
sub LISTBITMAP
{
	my $self = shift;
	my $lnum = shift;
	$self->_maybe_load_prop('LISTBITMAP');
	my $lb   = $self->{LISTBITMAP};

	# Handle read request
	unless (@_) {
		return int( substr($self->{LISTBITMAP}, $lnum, 1) ) if $lnum;

		return $lb unless wantarray;

		# Array context; build a list of subscribed lists.
		my @bits = split //, $self->{LISTBITMAP};
		return map { $bits[$_] ? ($MailingLists[$_-1]) : () } (1..$#bits);
	}

	# Write request
	my $bit = shift; $bit = $bit ? '1' : '0';
	$lb .= '0' while length($lb)+1 <= $lnum;
	substr($lb, $lnum, 1) = $bit;
	$lb =~ s/0+$//;

	return $bit if $lb eq $self->{LISTBITMAP};  # no change

	$self->{LISTBITMAP} = $lb || '';
	$self->_dirty('LISTBITMAP', 1);
	
	$bit;
}


#
# mailing_lists - return list of mailing list names.
#
# May be called as a static method.
#
sub mailing_lists
{
	my $that = shift;
	$that->_class_init unless $Init;
	die "mailing_lists is read-only" if @_;
	@MailingLists;
}


#
# mailing_list_info - retrieve record of mailing list given it's name
#
# Usage: $rec = $ipe->mailing_list_info('bloo');
#        print $rec->{ID}, $rec->{NAME}, $rec->{FREQUENCY};
#
sub mailing_list_info
{
	my $that     = shift;
	my $listname = shift;
	$that->_class_init unless $Init;
	$MailingLists{$listname} or die "mailing_list_info: unknown list name $listname";
}
	

#
# Migrate records that are pre-LISTBITMAP.
#
# If the LISTBITMAP is undef, we'll import the 
# legacy list subscription fields into LISTBITMAP
# and then set the first char of LISTBITMAP to 1.
#
sub _prepare_listbitmap
{
	my $self = shift;

	$self->_maybe_load_prop('LISTBITMAP');

	# Do nothing if this record has already been migrated
	return if substr( $self->{LISTBITMAP}, 0, 1 );

	# Pull data out of all old fields, and or into LISTBITMAP
	for my $listname (@MailingLists) {
		my $list   = $MailingLists{$listname};
		my $ofname = $list->{OLDFIELDNAME};
		next unless $ofname;
		my $method = $self->can($ofname);
		next unless $method;
		$self->LISTBITMAP( $list->{ID}, $self->$method() eq 'yes' ? 1 : 0 );
	}

	substr( $self->{LISTBITMAP}, 0, 1 ) = '1';
}


#
# list_subscription - high-level mutator/accessor for mailing list subscriptions.
#
# Usage:
#   Check if subscribed 'blah':   &foo if $ipe->list_subscription('blah');
#   Subscribe to 'bletch':        $ipe->list_subscription('bletch', 1);
#   Unsubscribe from 'barf':      $ipe->list_subscription('barf', 0);
#
sub list_subscription
{
	my $self = shift;
	my $name = shift;

	my $id = $MailingLists{$name}->{ID} 
		or die "list_subscriptions: Unknown list name $name";

	# See if we need to migrate old-style record
	$self->_prepare_listbitmap;

	# Handle read requests
	return $self->LISTBITMAP($id) unless (@_);

	my $newval = shift;

	$self->LISTBITMAP($id, $newval);
}


#
# translate_old_style - given an old style string, fetch corresponding bitmap
#
sub translate_old_style { $OldStyle{$_[1]} }


#
# Nonstandard accessor for STYLE (on-the-fly migration of old STYLE fields)
#
sub STYLE
{
	my $self = shift;

	if(@_) {
		# Handle write request
		my $style = shift;
		die "STYLE: must be new-style bitmap string, ie 0x007f" 
			unless $style =~ /^0x[0-9a-fA-F]{0,4}$/;
		$self->_dirty('STYLE', 1);
		return $self->{STYLE} = $style;
	}

	# Read request.  See if we need to convert old style.
	$self->_maybe_load_prop('STYLE');
	my $style = $self->{STYLE};
	return $OldStyle{$style} ? $OldStyle{$style} : 
		(($style =~ /^0x/) ? $style : '0x0');
}


#
# Nonstandard accessor for DISABLED (lagacy value of 'no' is equiv. to empty string)
#
sub DISABLED
{
	my $self = shift;

	if(@_) {
		# Handle write request
		my $val = shift;
		$val=86401 if $val && !int($val);
		$self->_dirty('DISABLED', 1);
		return $self->{DISABLED} = int($val / 86400);
	}

	# Read request.  Load the current value.
	$self->_maybe_load_prop('DISABLED');
	local $_ = $self->{DISABLED};

	# Fix legacy value of 'no'
	if (/^\s*no\s*$/i) {
		$_ = $self->{DISABLED} = '';
		$self->_dirty('DISABLED', 1);
		return $_;
	}

	# Handle false value
	return '' unless $_;
	
	# Fix legacy value of 'yes' (or anything other than
	# a unixtime) into unixdate of 1
	if($_ && !int($_)) {
		$self->{DISABLED} = 1;
		$self->_dirty('DISABLED', 1);
		return 1;
	}

	# Handle modern value (date disabled, stored as five-digit 
	# count of days since the epoch)
	return (int($_) * 86400);
}


#
# prefs - get names of supported binary preferences
#
sub prefs { @Prefs }


#
# pref_info - retrieve info record for a given pref name
#
sub pref_info { $Prefs{$_[1]} }


#
# preference - turn binary preference on or off
#
# Usage:
#   read a preference     &foo if $ipe->preference('seemod');
#   set a preference      $ipe->preference('showsubjonly', 1);
#
sub preference
{
	my $self     = shift;
	my $prefname = shift;

	my $rec = $Prefs{$prefname} or die "preference: unknown preference $prefname";
	my $style = $self->STYLE;

	$style =~/^0x([0-9a-fA-F]+)$/ or die "preference: internal error: bad style $style";
	my $num = int hex($1);

	# Handle read request
	return ($num & $rec->{bit}) ? 1 : 0 unless @_;

	# Write request: or in new setting
	my $newset = shift;
	$num &= ~($rec->{bit});
	$num |= $rec->{bit} if $newset;

	$self->STYLE( sprintf "0x%x", $num );
	$newset ? 1 : 0;
}


#
# as_string - convert a record to a string, presumeably for debuggin
#
sub as_string
{
	my $self = shift;

	join "\n", map { 
		join("=", $_, ($self->{$_}||"") . ($self->_dirty($_) ? ' (dirty)' : '') ) 
	} grep !/^_/, keys %$self;
}

#
# as_html - returns a string containing an HTML snippet for debugging
#
sub as_html
{
	my $self = shift;

	my $o = '<table border=1><tr><td align="right">';
	$o .= join qq{</td></tr>\n<tr><td align="right">}, 
	      map { 
		  	join( ':</td><td>&nbsp;', $_, 
	      		$self->{$_} . ($self->_dirty($_) ? ' (dirty)' : '') ) 
	      }
		  grep !/^_/, keys %$self;
	$o .= "</td></tr></table>";

	$o;
}

sub DESTROY {}


package UFIPE::Tie;

sub TIEHASH
{
	my $class = shift;
	my $ipe   = shift;
	bless { ipe => $ipe }, $class;
}

sub ipe
{
	my $self = shift;
	$self->{ipe};
}

sub FETCH
{
	my $self = shift;
	my $field= shift;
	my $ipe  = $self->{ipe};
	my $meth = $ipe->can($field) or return;
	$ipe->$meth();
}

sub STORE
{
	my $self = shift;
	my $field= shift;
	my $value= shift;
	my $ipe  = $self->{ipe};
	my $meth = $ipe->can($field) or die "Tied IPE can't store field $field";
	$ipe->$meth($value);
}

sub DELETE
{
	my $self = shift;
	my $field= shift;
	$self->STORE($field, undef);
}

sub CLEAR
{
	my $self = shift;
	my $ipe  = $self->{ipe};
	$ipe->clear;
	return;
}

sub EXISTS
{
	my $self = shift;
	my $field= shift;
	my $ipe  = $self->{ipe};
	return $ipe->can($field) ? 1 : 0;
}

sub FIRSTKEY
{
	my $self = shift;
	my $ipe  = $self->{ipe};
	$self->{keylist} = [ $ipe->list_properties ];
}

sub NEXTKEY
{
	my $self = shift;
	return unless $self->{keylist};
	shift @{ $self->{keylist} };
}

sub DESTROY {}


##############################################################################

1;
__END__

=pod

=head1 NAME UFIPE

UFIPE - UserFriendly Idependant Property Engine

=head1 SYNOPSIS

  use UFIPE;

  # Create a new user
  my $user = new UFIPE;
  $user->USERNAME('saucepan');
  $user->PASSWORD('zorch123');
  $user->EMAIL('saucepan at yahoo dot com');
  $user->SECMAIL('lyonsm@userfriendly.org');
  my $id = $user->save;

  # You can reuse a UFIPE object
  $user->clear;

  # Load an existing user, edit him, and save him back
  $user->load($id);  
  $user->load( USERNAME => 'saucepan' );
  $user->EMAIL('saucepan at hotmail dot com');
  $user->save;

  print $user->as_string, "\n";

=head1 DESCRIPTION

B<UFIPE> provides an object oriented interface to the User Friendly user
database.  Methods are provided to create, edit, load and save user 
records; see the SYNOPSIS section for more information.

=head1 SEE ALSO

L<perl(1)>, L<UserFriendly>

=cut

                                                 perl/UFSQL.pm                                                                                       0100755 0000000 0000000 00000021567 07442556670 012004  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   #!/usr/bin/perl -w

package UFSQL;
use strict;
require 5.005;

# Local includes
use DBI;
use ARSConfig;
use vars qw($VERSION);

$VERSION = do { my @r = (q$Revision: 1.6 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
# FIXME: Should we version this interface?
# with a $VERSION?
# 
# Globals
my $Dbh;
my $Dsn;
my $Username;
my $Password;
my $Debug;
# Load config info
UFSQL->set_database(@$GC{qw(dbi_dsn dbi_user dbi_pass)});


sub _verify_connection 
{
	$Dsn or die "No default DSN specified; call set_database() first";
	defined $Username or die "No default username; call set_database() first";
	defined $Password or die "No default password; call set_database() first";
	$Dbh ||= DBI->connect($Dsn, $Username, $Password)
		or die "pid $$ couldn't get DB connection: " . DBI->errstr;
}

#######################################################################
#
# Methods: Convention: foo_sql GENERATES sql to do operation foo
#
#######################################################################

#
# set_database - static (class) method that sets params for default DB connection
#
# Must be called before ->new() or &_verify_connection()
#
sub set_database
{
	my $class = shift;
	my($dsn, $user, $pass) = @_;
	$Dsn = $dsn;
	$Username = $user;
	$Password = $pass;
}


#
# set_debug - static (class) method that turns on SQL debugging (to STDERR)
#
sub set_debug
{
	shift if $_[0] eq __PACKAGE__;
	my $bug = shift;
	$Debug = $bug;
}


sub new
{
	my $class = shift;
	my $self = { @_ };
	bless $self, $class;
	_verify_connection();
	$self->{dbh} ||= $Dbh;
	$self;
}

sub my_warn
{
	warn @_ if $Debug;
}


sub prepare
{
	my $self = shift;
	my $dbh  = $self->{dbh};

	if( $self->{do_cache} ) {
		$self->{do_cache} = 0;
		return $dbh->prepare_cached(@_);
	}

	return $dbh->prepare(@_);
}

sub cache_next_query { $_[0]->{do_cache} = 1 }

#
# dbh - get the database handle.  Call as class or instance method.
#
# When called as class method, returns singleton DB connection (connecting if necessary)
#
sub dbh 
{ 
	my $self = shift;
	die "dbh is read-only" if @_;
	return $self->{dbh} if ref $self;
	_verify_connection();
	$Dbh;
}


sub quote
{
	my $self = shift;
	my $what = shift;
	return $self->{dbh}->quote($what);
}


sub select_hashref 
{
	my $self = shift;
	my $dbh  = $self->{dbh};
	my ($select, $from, $where, $other) = @_;
	
	my $sql="SELECT $select ";
	$sql.="FROM $from " if $from;
	$sql.="WHERE $where " if $where;
	$sql.="$other" if $other;

	# connect , or reuse $dbh, prepare and execute
	my $sth = $self->prepare($sql);
	my_warn $sql;
	
	$sth->execute					or die "execute failed: $DBI::errstr";
	
	my $hr = $sth->fetchrow_hashref();
	$sth->finish();
	
	$hr;
}


sub select_many
{
	my $self = shift;
	my $dbh  = $self->{dbh};
	my($select,$from,$where,$other) = @_;
	
	my $sql="SELECT $select ";
	$sql .= "FROM $from "   if $from;
	$sql .= "WHERE $where " if $where;
	$sql .= $other          if $other;

	# connect , or reuse $dbh, prepare and execute
	my_warn $sql;
	my $sth = $self->prepare($sql);

	$sth->execute			or die "execute failed: $DBI::errstr";
	
	$sth;
}


sub delete
{
	my $self = shift;
	my $dbh  = $self->{dbh};
	my($from, $where) = @_;

	die "Need where clause!" unless $where;

	my $sql = "DELETE FROM $from WHERE $where";
	my_warn $sql;
	$dbh->do($sql) or die "execute failed: $DBI::errstr";
	return;
}


sub action_where_in_sql 
{
	my $self = shift;
	my $dbh  = $self->{dbh};
	my %arg = @_;

	# Make sure no silly mistake causes a disaster
	die "Need WHERE clause" unless $arg{WHERE};

	my $ink = $arg{-IN} ? '-IN' : 'IN';
	my $q   = $ink ne '-IN'; # $q is TRUE if IN list should be quoted
	my $in  = $arg{$ink};
	die "missing IN array" unless ( $in && ref($in) eq 'ARRAY' && @$in );

	my $sql = '';
	$sql .= "SELECT $arg{SELECT} " if $arg{SELECT};
	$sql .= "DELETE              " if $arg{DELETE};
	$sql .= "UPDATE $arg{UPDATE} " if $arg{UPDATE};
	$sql .= "FROM   $arg{FROM}   " if $arg{FROM};

	if ( $arg{SET} ) {
		$sql .= "SET ";
		while (my($key, $val) = each %{ $arg{SET} }) {
			if ($key =~ /^-/) {
				$key =~ s/^-//;
				$sql .= "$key=$val,";
			} else {
				$sql .= "$key=" . $dbh->quote($val) . ",";
			}
		}
		$sql =~ s/\,$//;
	}

	$sql .= " WHERE  $arg{WHERE}  ";
	
	$sql .= "IN (" . join(',', $q ? map { $dbh->quote($_) } @$in : @$in) . ")";
	
	$sql .= $arg{OTHER} if $arg{OTHER};

	$sql;
}


#
# sqlActionWhereIn - call coderef for chunks of IN or -IN array
#
# Usage:  sqlActionWhereIn( \&code, %args );
#
# %args is expected to be named arguments as might be passed 
# to (for example) sqlActionWhereIn_sql().  %args are not validated,
# but must contain an IN (or -IN) argument which should be a reference
# to a non-empty array.
#
# &code will be called once for every 2048 bytes or so worth of 
# elements from @{ $args{IN} }, which prevents queries from getting
# too big even for very large lists of $args.
#
# This chunking means it is probably pointless to specify
# a sort order in $args{OTHER}.  :)
#
sub action_where_in 
{
	my $self = shift;
	my $dbh  = $self->{dbh};
	my $coderef = shift;
	my %arg = @_;
	my $inkey = $arg{-IN} ? '-IN' : 'IN';
	my $in = $arg{$inkey};
	return unless $in && ref($in) eq 'ARRAY' && @$in;
	
	my @inlist     = ();
	my $inbytes    = 0;
	my %inner_arg  = %arg;
	foreach my $item (@$in) {
		push @inlist, $item;
		$inbytes += length($item);
		if ($inbytes > 2048) {
			$inner_arg{$inkey} = \@inlist;
			$coderef->(%inner_arg);
			$inbytes = 0;
			@inlist  = ();
		}
	}
	
	if (@inlist) {
		$inner_arg{$inkey} = \@inlist;
		$coderef->(%inner_arg);
	}

	1;
}

sub select_where_in_raw 
{
	my $self = shift;
	my $dbh  = $self->{dbh};
	my $sql  = $self->action_where_in_sql(@_);

	my_warn $sql;
	my $sth = $self->prepare($sql);

	$sth->execute or die "execute failed: $DBI::errstr";

	$sth;
}


sub select_where_in_list 
{
	my $self = shift;
	my $dbh  = $self->{dbh};
	my $sth = $self->select_where_in_raw(@_) or return;
	my @rows = @{ $sth->fetchall_arrayref };
	$sth->finish;
	wantarray ? @rows : \@rows;
}				


#
# sqlSelectWhereIn - SELECT WHERE $foo IN (@bar) query for very large @bar
#
# Example Usage: 
#   @rows = sqlSelectWhereIn(SELECT => 'name,age', FROM   => 'employees',
#                            WHERE  => 'age > 18 AND id', '-IN' => @id_list);
#
# Splits up the query into chunks, so that each "IN (blah, blah)" list
# takes no more than about 2kb.  Returns a list of array refs, each
# referring to one row of the result set.
#
sub select_where_in 
{
	my $self = shift;
	my @rows = ();
	$self->action_where_in( sub { push @rows, $self->select_where_in_list(@_) }, @_ );
	wantarray ? @rows : \@rows;
}

sub update_where_in
{
	my $self = shift;
	my $dbh = $self->{dbh};
	my $rv = 0;
	$self->action_where_in( sub { $rv += $dbh->do($self->action_where_in_sql(@_)) }, @_ );
	$rv;
}


sub delete_where_in { &update_where_in }


#
# function &_mangle_data - edit in-place a record hash.
#
# Usage:  _mangle_data( \%record );
#
# Cannot be called as a method.
#
sub _mangle_data 
{
	my $hr = shift;
	die "someone tried to mangle stuff";
	
	foreach (keys %$hr) {
		$hr->{$_} =~ s/(\r\n)+/\r\n/g;
		$hr->{$_} =~ s/\n+/\n/g;
		$hr->{$_} =~ tr/\t//d;
		$hr->{$_} =~ s/(\w{50})+/$1\n/g;
		$hr->{$_} =  substr $hr->{$_}, 0, 7900;
		$hr->{$_} =~ s/[\s\n]*$//g;
	}

}


sub update 
{
	my $self = shift;
	my $dbh = $self->{dbh};
	my($table,$data,$where) = @_;
	# $data is ref to hash where key is fieldname and value is new data value
	# connect , or reuse $dbh, prepare and execute

	my $sql="UPDATE $table SET ";
	foreach (keys %$data) {
		if (/^-/) {
			my $key = $_;
			$key =~ s/^-//;
			$sql.=" $key = $$data{-$key},";
		} else {
			# quote the data if the name does not start with '-'
			$sql.=" $_ = ".$dbh->quote($$data{$_}).",";
		}
	}
	$sql =~ s/\,$//;
	$sql.=" WHERE $where\n";
	my_warn $sql;

	# all html entities are escaped. No html code AT ALL
	# FIXME: make it allow certain entities, not all 
	$dbh->do($sql) or die "execute failed: $DBI::errstr";
}


sub insert_sql 
{
	my $self = shift;
	my $dbh = $self->{dbh};
	my($table,$data) = @_;

	my($names,$values);
	foreach (keys %$data) {
		if (/^-/) {
			$values.="\n  ".$$data{$_}.",";
			s/^-//; # FIXME: this modifies caller's data :(
		}
		else {
			# quote the data if the name does not start with '-'
			$values.="\n  ".$dbh->quote($$data{$_}).",";
		}
		$names.="$_,";
	}
	chop($names);
	chop($values);

	my $sql="INSERT INTO $table ($names) VALUES($values)\n";

	my_warn $sql;

	# all html entities are escaped. No html code AT ALL
	$sql;
}


sub insert_id
{
	my $self = shift;
	my $dbh = $self->{dbh};
	my($table,$data) = @_;
	my($names,$values);

	my $sql = $self->insert_sql($table, $data);

	# connect , or reuse $dbh, prepare and execute
	my_warn $sql;

	# all html entities are escaped. No html code AT ALL
	# except in the NEWS posting table. since thats the data from the texpress system
	my $sth = $dbh->prepare($sql);

	$sth->execute or die "execute failed: $DBI::errstr";

	# FIXME: db dependent
	my $sid = $sth->{mysql_insertid};

	$sth->finish();
	$sid;
}


1;
__END__

                                                                                                                                         perl/UserFriendly.pm                                                                                0100755 0000000 0000000 00000110426 07614044174 013506  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   #!/usr/bin/perl -w
# 
# $Id: UserFriendly.pm,v 2.39 2003/01/23 19:54:16 jay Exp $
# 
# ' .... soon the booth was filling with flies, and Studebaker Hawk put his head
# between his knees and said in a deep, impressive, Ron Hubbard-type voice: "New York!" ....
# and the booth and everything ... lifed up ... out of the parking lot ... and into the sky!'
#
# Frank Zappa, Billy The Mountain, Just Another Band From LA
#
# Appropriate here, since Billy the Mountain started off as just a simple mountain
# until the royalty cheques for all those tourist postcards came in, and he wanted a vacation...
# 
# A warning to All Ye Who Enter Here: Abandon Hope! For some the legacy
# bits in code below will make as much sense as the quote above.
# 
# Copying: GPL V2.
# 
# (C) UserFriendly Media Inc. 2000 2001 2002
# Authors: Lots. Whoever coded the original slashcode
# Brendan McAdams, Paul Sullivan
# Jay Thorne, Mike Nugent, Mike Lyons
# 
# History:
# V 0.1  BM, PS ".lib" files, hacked from slashcode
# V 0.5  JT      Re-write of thread view, navigation
# V 1.0  JT      Collected into a .pm
# V 1.1  JT      Templating code with ssi
# V 1.5  JT MN   Crude security auditing
# V 2.0  JT      BEGIN and Exporter interface
#                More cleanup. Add in early generic client Comments/*.pm
# V 2.01 ML      Abstraction of the user data storage 
#                and abstracted the config interface
# V 2.5  ML      MAJOR clean up of comment navigation
#                Lots of new documentation, start of cruft-ectomy 
# -----------------
# At this point almost none of the original code remains, 
# Except in the SQL section
# -----------------
# V 3.0  ML      object orientation, a cleaned up module list 
#                CGI-ectomy! Nearly complete. Still needs CGI::Cookie
# V 3.01 ML JT   Abstract away SQL interface
# V 3.02 ML JT   Turn clients of this into single UniversalHandler
# V 3.03 ML JT   CGI-ectomy complete 
# V 4.00 ML JT   Great rename of interface. 
#                Cartoons and news items --> Articles
#                Comments/postings about articles -> Comments
#                Version Rename. 2.0
package UserFriendly;
use strict;
require 5.005;

BEGIN {
	use Exporter ();
	use vars     qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
	$VERSION     = 4.00;
	@ISA         = qw(Exporter);
	%EXPORT_TAGS = (
		comments => [qw(get_comments display_comment moderate_comment
						get_single_comment get_comment_parent_level insert_comment)],
		articles => [qw(get_article_as_html get_cartoon_html
						article_exists article_list insert_article 
						update_article delete_article set_article)],
		html     => [qw(ssi_replace param_replace)],
		util     => [qw(read_file get_cartoon get_cartoon_nav date_numeric_string
						valid_cartoon rand_bytes send_email audit_log insert_survey)],
	);
	#Exporter::export_tags(keys %EXPORT_TAGS);
	Exporter::export_ok_tags(keys %EXPORT_TAGS);
}


# System includes
#use DBI;
use IO::Socket;
use Apache::SIG ();
Apache::SIG->set;
use Time::Local qw(timelocal);
use FileHandle;
use POSIX qw(_exit);

# External includes
use UFMEDIA::CacheOneFile;

# Local includes
use UFCGI;
use UFSQL;
use ARSConfig;


####################################################################
#
#  Globals
#
####################################################################

my $doc_root =    $GC->{doc_root};
my $domain   =    $GC->{domain};
my $gdomain  =    $GC->{gdomain};
my $debug    =    $GC->{debug};
my %Config   = %{ $GC->{db_layout} };

my $Admin_Email   = $GC->{admin_email};
my $Cookie_Domain = $GC->{cookie_domain};
my $Sendmail_Path = $GC->{sendmail_path};
my $Nav_HTML      = $GC->{nav_html};
my $Cache_Root    = $GC->{cache_root};
my $Cache_Timeout = $GC->{cache_timeout};

use vars qw ($Sql);
my %FileCache;


####################################################################
#
#  Global init
#
####################################################################

# Propagate SQL config through to UFSQL
UFSQL->set_database(@$GC{qw(dbi_dsn dbi_user dbi_pass)});
UFSQL->set_debug($debug);

# urlcache stores the cartoons, but is duplicated
# by each mod_perl child process.
my %urlcache;

warn "Starting UserFriendly.pm $VERSION" if $debug;


####################################################################
#
#  Subroutines
#
####################################################################


#
# rand_bytes - read 16 bytes from /dev/urandom
#
# Usage: $rand = rand_bytes();
#
# Returns a scalar containing 16 bytes of arbitrary, binary data
# read from /dev/urandom.  Throws an exception on IO errors.
#
sub rand_bytes
{
	my $fh     = new FileHandle;
	my $device = '/dev/urandom';
	my $rand   = '';
	
	open $fh, "<$device"     or die "unable to open $device: $!";
	read($fh, $rand, 16)==16 or die "unable to read $device: $!";
	close $fh;

	$rand;
}


#
# send_email - transmit an email message.
#
# Usage: send_email( to=>"larry@aol.com", from=>$me, subject=>"foo", body=>"Hi there" );
#
# The "to" and "body" arguments are mandatory.
#
# Returns nothing useful.  Throws an exception if the outgoing
# message could not be queued.
#
sub send_email
{
	my %m    = @_;
	my $to   = $m{to};
	my $from = $m{from} || $Admin_Email;
	my $subj = $m{subject} || "UserFriendly ARS Email";
	my $body = $m{body};
	my $fh   = new FileHandle;
	
	local $SIG{PIPE} = 'IGNORE';
	
	my $pid  = open $fh, "|-";
	die "unable to fork: $!" unless defined $pid;
	unless($pid) {
		exec $Sendmail_Path, '--', $to;
		warn "Unable to exec $Sendmail_Path: $!";
		while(<STDIN>) { };
		_exit(199);
	}

	print $fh 
		"To: ", $to, 
		"\nFrom: ", $from, 
		"\nSubject: ", $subj, 
		"\n\n", $body
	or die "Error writing to pipe to sendmail: $! $?";

	close $fh or die "Error writing to pipe to sendmail: $! $?";
}

# _add_days
# math on dates for cartoon nav
#
sub _add_days 
{
	my ($days, $startday)= @_; 
	my ($yearstart)= int( ( $startday/10000 ) % 1900) ;
	my ($monstart)= int ( ($startday % 10000)/100 );
	$monstart--;
	my ($daystart)= int ( ($startday % 10000)  %100 );
	my $dayseconds;
	if ( ($daystart < 32) && ($daystart > 0) && ($monstart< 12) && ($monstart>= 0) && (( $yearstart > 96 ) || ($yearstart < 30))) {
		$dayseconds=timelocal(12,15,1,$daystart,$monstart,$yearstart);
		$dayseconds=$dayseconds+($days*(24*60*60));
	}
	else { $dayseconds =  time; }
	return date_numeric_string($dayseconds);
}

#
# get_cartoon_nav
# previous and next buttons for archive viewing
#
sub get_cartoon_nav 
{
	my ($date,$table,$priv,$path,$sc,$so,$sb) = @_;
	my $yesterday = _add_days(-1, $date);
	my $tomorrow = _add_days(1, $date);
	#FIXME: D has new nav items.
	# do we have comments turned on? 
	my $daytype = $date <= 19971117 ? 'firstday' : ( $date < date_numeric_string(time) ? 'all' : 'lastday' );
	my $html = $Nav_HTML->{ $sc ? 'comments' : 'no_comments' }->{$daytype};

	$html =~ s/\$yesterday/$yesterday/g;
	$html =~ s/\$tomorrow/$tomorrow/g;
	$html =~ s/\$date/$date/g;

	$html;
}


#
# we use 8 character numeric strings for ID in the cartoons table
#
sub date_numeric_string 
{
	my $date =shift; 
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) 
		= localtime($date);
	$year += 1900;
	$mon++;
	return $year * 10000 + $mon * 100 + $mday ;  
	# yyyymmdd
}

#
# date_pretty. return short text date
#
sub date_pretty 
{
	my($i) = @_;
	my($year)=substr($i,0,4);
	my($month)=substr($i,4,2);
	my($day)=substr($i,6,2);
	my(@months)=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
	return $months[$month-1]." $day, $year";
}

#
# get_single_comment
# formats a single comment
# with its parents and children
#
sub get_single_comment
{
	my $state=shift;
	my %state=%$state;
	$Sql ||= UFSQL->new;
	$Sql->cache_next_query;
	my $sth = $Sql->select_many(
		"ID,USERNAME,SUBJECT,MESSAGE,TIMESTAMP,STATUS,SUB_PARENT,LEVEL,PARENT,REMOTE_HOST",
		$state{comment_table},"ITEM='$state{id}' && ID = '$state{tid}'",""
	);
	my $hr;
	if (!($hr = $sth->fetchrow_hashref )) {
		return "comment id:$state{tid} Not Found";
	}
	my $tid       	= $hr->{'ID'};
	my $username  	= $hr->{'USERNAME'};
	my $subject	    = $hr->{'SUBJECT'};
	if ($subject eq "") {
		$subject    = "&lt;No Subject&gt;";
	}
	my $message   	= $hr->{'MESSAGE'}; 
	my $timestamp 	= $hr->{'TIMESTAMP'};
	my $status 	= $hr->{'STATUS'};
	my $subparent   = $hr->{'SUB_PARENT'};
	my $parent      = $hr->{'PARENT'};
	my $level     	= $hr->{'LEVEL'};
	my $srcIP	= $hr->{'REMOTE_HOST'};
	my $email=""; 

	$sth->finish;
	my $modmode=$state{seemod};	

	_maybe_moderate( \($status,$modmode,$subject,$message,$username) );

	my $output = "";
	$output = qq{<table border=0 cellspacing=0 width="100%">\n};
	
	$output .= _comment_ancestors(
		$state{id}, 
		$tid, 
		$subparent, 
		$state{path}, 
		$state{seemod}, 
		$state{comment_table}
	) unless $state{suppress_ancestors};

	my $cut_comment_length=0;
	
	$output .= display_comment($cut_comment_length,$state{id},$tid,$level,
		$subject,$message, $email,$username,$timestamp,$state{user_type},$state{path},$state{noreply},$srcIP);
		
	$output .= _comment_children(
		$state{id}, 
		$tid, 
		$parent, 
		$state{path}, 
		$state{seemod}, 
		$state{comment_table}
	) unless $state{suppress_children};
		
	$output .= qq{</font> </td> </tr> </table>\n};
	return wantarray ? ($output, $username, $subject) : $output;
}


# find_ancestors - find all ancestors of a given comment 
#
# Does as many recursive queries as needed to locate all immediate ancestors of 
# comment ID $thread.  Returns a list of records, each of which is a ref
# to an anon array of [id, sub_parent, username, subject, status, level]
# The first element of the list is the eldest ancestor, and the last
# element of the list is the parent of comment $thread.  If $thread
# is a top-level comment, the empty list is returned.
#
sub find_ancestors 
{
	my ($id, $sub_parent, $table) = @_;

	# If we are at the top, we are done
	return if $id eq $sub_parent;

	# Find the parent of this parent
	$Sql ||= UFSQL->new;

	my $hr = $Sql->select_hashref(
		'ID,SUB_PARENT,USERNAME,SUBJECT,STATUS,LEVEL, TIMESTAMP',
		$table,"ID='$sub_parent'",
	);
	
	return (
		find_ancestors($hr->{ID}, $hr->{SUB_PARENT}, $table), 
		[@$hr{qw(ID SUB_PARENT USERNAME SUBJECT STATUS LEVEL TIMESTAMP)}],
	);
}


# comment_ancestors - build HTML for navigation to comment ancestors
#
sub _comment_ancestors 
{
	# Returns HTML snippet corresponding to parent, grandparent, 
	# great-n-grandparent links for a comment.
	my ($item, $thread, $parent, $path, $modmode, $table) = @_;
	
	my $output;

	# Look up parent, grandparent, etc.
	my @ancestors = find_ancestors($thread, $parent, $table);
	foreach my $ancestor (@ancestors) {
		my ($tid, $sub_parent, $username, $subject, $status, $level, $timestamp) = @$ancestor;
		_maybe_moderate( \($status, $modmode, $subject, '', $username) );
		$output .= _display_thread(0,$item,$tid,$level,$subject,'','',$username,$timestamp,'',$path,0);
	}

	$output;
}


# comment_children_recurse - return HTML for reply subtree
#
sub _comment_children_recurse 
{
	my($pid, $co, $path, $item, $modmode) = @_;
	# FIXME: layout is borked. top level of thread is not delineated well
	my $output = '';
	my $kids = $co->{$pid} || [];
	my @sorted = sort { $a->{ID} <=> $b->{ID} } @$kids;
	foreach my $kid (@sorted) {
		my($tid,$sub_parent,$username,$subject,$status,$level,$timestamp)=
			@$kid{qw(ID SUB_PARENT USERNAME SUBJECT STATUS LEVEL TIMESTAMP)};
		_maybe_moderate( \($status, $modmode, $subject, '', $username) );
		$output .= _display_thread(0,$item,$tid,$level,$subject,'','',$username,$timestamp,'',$path,0);
		$output .= _comment_children_recurse($tid, $co, $path, $item, $modmode);
	}
	
	$output;
}


# comment_children - build HTML for navigation to comment followups
#
sub _comment_children 
{
	my ($item, $thread, $parent, $path, $modmode, $table) = @_;

	my $output = '';

	# Build list of all followups to this comment.
	# We'll brute force this by loading all comments in this thread
	# that might be followups to this one, and then process them in-core.
	$Sql ||= UFSQL->new;
	my $sth = $Sql->select_many('ID,SUB_PARENT,USERNAME,SUBJECT,STATUS,LEVEL,TIMESTAMP', $table, 
	 		"PARENT='$parent' && STATUS != 'dead' && ID > $thread && SUB_PARENT >= $thread",
			'order by ID desc');

	# Build a tree out of the comments
	my $hr;
	my %children_of = ();
	push @{$children_of{$hr->{SUB_PARENT}}}, {%$hr} while $hr = $sth->fetchrow_hashref;
	$sth->finish;

	$output .= _comment_children_recurse($thread, \%children_of, $path, $item, $modmode);

	$output;		
}


sub get_comments
{
	my $state=shift;
	unless( $state->{showcomments}) {
		my $content = <<EOF;
<TABLE width="100%" border=0>
<TR>
<TD align=left>
<!--#include virtual="/arch_news.html"-->
<P>
<!--#include virtual="/arch_news_foot.html"-->
</TD>
<TD align=right valign=top>
<!--#include virtual="/adcnet.html"-->
</TD>
</TR>
</TABLE>
EOF
		return ssi_replace($content,$state);
	}

	# Bypass cache if it's turned off
	return _get_comments_uncached($state) unless $Cache_Timeout;

	# Bypass cache for moderators
	my $ut = $state->{user_type};
	return _get_comments_uncached($state) if $ut eq 'admin' || $ut eq 'moderator';

	# Bypass cache for noreply mode
	return _get_comments_uncached($state) if $state->{noreply};

	# Build cache identifier
	my $table   = $state->{comment_table} || 'notable';
	my $id      = int( $state->{id} );
	my $path    = UFCGI::escape( $state->{path} ) || 'nopath';
	my $modmode = $state->{seemod}         ? 'M' : 'm';
	my $ss      = $state->{showsubjonly}   ? 'S' : 's';
	my $sc      = $state->{showcomments}   ? 'C' : 'c';
	my $se      = $state->{showeverything} ? 'E' : '';
	my $so      = UFCGI::escape( $state->{sortorder} ) || 'noso';

	my $subdir = $table;
	my $file   = join("_", $path, $id, $modmode, $ss . $se, $sc, $so) . ".html";
	my $cacheid= "$subdir/$file";


	# Prepare a cache object
	unless ($FileCache{$cacheid}) {
		mkdir("$Cache_Root/$subdir", 0777);
		
		my %smallstate;
		@smallstate{qw(comment_table path id seemod showsubjonly showcomments sortorder showeverything)} =
		    @$state{qw(comment_table path id seemod showsubjonly showcomments sortorder showeverything)};
	
		$FileCache{$cacheid} = UFMEDIA::CacheOneFile->new(
			cache_file => "$Cache_Root/$subdir/$file",
			max_age    => $Cache_Timeout,
			refill_sub => sub { _get_comments_uncached(\%smallstate) },				
		);
	}

	return $FileCache{$cacheid}->get_value;
}


#
# _get_comments_uncached
# main code section for comment display
# the heaviest wall clock time function
# The algorithm is simple, but has a speed issue.
# 1. select all comments from the db
# 2. store the comment contents in  %text, keyed by ID
# 3. Put the id of the parent comment of a given comment in %parent, keyed by ID
# By nature of the way comments are entered, 
# we know that a given reply to a comment will always 
# have a larger ID than its parent,
# 4. read %parent in reverse order
# 	take the current comment and append it to the parent
#	since we're in reverse order, parent will always exist. and the 
#	text will appear after the parent, with the newest replies first on the page
#	if parent is this post, leave alone -> is a top level post
# 	reply comments are thus added to the top level post
# 5. read %text in reverse order as well
# 	append the text to the output data
#	this will give a reverse order thread, but with the rather
#	cool side effect of putting the latest thread at the top.
#	so the latest discussion comes first on the page.
#	so less scrolling for most posters.
#
sub _get_comments_uncached
{
	my $state=shift;
	return unless $state->{showcomments};
	my $table   = $state->{comment_table};
	my $id      = $state->{id};
	my $path    = $state->{path};
	my $modmode = $state->{seemod};
	my $type    = $state->{user_type};
	my $noreply = $state->{noreply};
	my ($sc, $so, $ss, $se) = @$state{qw(showcomments sortorder showsubjonly showeverything)};
	my $full    = $se || ($ss ? 0 : 1) ;

    return "Error: No comment Id" unless $state->{id}; 
	
	my ($output,$comment,$thread, $indent, $sort, $hr);

	$output = qq{<table border=0 cellspacing=0 width="100%">};
	
	$indent = $se ? 0 : 1;
	$full = 1 if $se;
	# select all appropriate comment items from the table
	# Step 1
	$Sql ||= UFSQL->new;
	$Sql->cache_next_query;
	my ($sth) = $Sql->select_many("ID,USERNAME,SUBJECT,MESSAGE,TIMESTAMP,STATUS,PARENT,SUB_PARENT,LEVEL",
		$table,
		"ITEM=$id AND STATUS != 'dead' ",
		"order by ID");
	# 
	my %parent;
	my %text;
	# Did we get any rows?
	# Step 2
	if($sth->rows >= 1) {
		while($hr=$sth->fetchrow_hashref) {
			my $tid		= $hr->{'ID'};
			my $username= $hr->{'USERNAME'};
			my $subject	= $hr->{'SUBJECT'};
			my $message	= $hr->{'MESSAGE'};
			my $timestamp= $hr->{'TIMESTAMP'};
			my $status 	= $hr->{'STATUS'};
			my $parent	= $hr->{'PARENT'};
			my $sub_parent	= $hr->{'SUB_PARENT'};
			my $level	= $hr->{'LEVEL'};
			my $email	= "";
			# no more emails
			# Step 3
			# parent is hash containing the parent of this comment
			$parent{$tid}=$sub_parent;
			#FIXME: deleted posts should not be clickable
			# add to text hash the formatted html from this post
			_maybe_moderate( \($status,$modmode,$subject,$message,$username) );

			# display the correct amount of detail based on the
			# comment depth ($level)
			# and whether to display full text ($full)
			# and whether to indent ($indent)
			# dispcomment shows the text, no indenting
			# dispthread only shows the title and adds indents
			my $cut=1;
			my @stuff=($cut,$id,$tid,$level,$subject,$message, $email,$username,$timestamp,$type,$path,$noreply);
			# $indent,$full,$level,1,
			my $comment;	
			if($level == 1) {
				if( $full) {
					$comment = display_comment(@stuff);
				} 
				else {
					$comment = _display_thread(@stuff);
				}
			} else {
				if($indent) {
					$comment= _display_thread(@stuff);
				} 
				else {
					$comment= display_comment(@stuff);
				}
			}

			$text{$tid}=$comment; 
		}
		# Step 4
		# for every comment numbered $node
		# start at the last comment
		# and go backwards
		foreach my $node (sort { $b <=> $a } keys %text ) {
			# is this is parented by itself?
			if ( $node == $parent{$node}) {
				# leave it alone, because its a top level comment
			} else {
				# attach this text to its parent's text
				# delete it from the text hash
				# so that we can just run thru the hash to display
				# the entire comment contents
				$text{$parent{$node}}.=$text{$node};
				$text{$node}="";
			}
		}
		# Step 5
		# finally , add all the output reverse sequentially
		foreach my $node ( sort { $b <=> $a } keys %text ) {
			$output.=$text{$node};
		}
	} else {
		# query failed
		$output .= qq|<TR><TD><b>No comments posted yet.</b></td></tr>|;
	}
	$sth->finish;
	$output .= qq|</table>|;
	return($output);
}


sub _maybe_moderate 
{
	my ($status,$modmode,$subject,$message,$username)=@_;

	if($$status ne "active" ) {
		if ($$modmode ) {
			eval { $$subject .= "   &lt;MODERATED&gt;" };
		} else  {
			eval {
				$$username = "&lt;Deleted&gt;";
				$$subject  = "&lt;Deleted&gt;";
				$$message  = "This message has been moderated down, score -1 :)";
			};
		}
	}
}



sub diary_link
{
	my $author = shift;
	$author && $author ne "\&lt;Deleted\&gt;"
		? qq{ by <a href="users/diary05dd.html?id=}%20.%20UFCGI::escape($author)%20.%20qq{">$author</a>}
		: $author;
}


# display_comment
# format a comment based on 
# length, if top level, and cut content length requested
# admin status
# emits only one or more table rows
sub display_comment 
{
	my	($cut,$id,$tid,$level,$subject,$message,$email,$author,$timestamp,$type,$path,$noreply,$srcip) = @_;
	return "Bad Comment Id" if ! $id ;

	$subject = "(No subject given)" if $subject =~ /^\s*$/;
	$subject = $tid
		? qq{<a href="%24domain/%24path/read9d9d.html?id=$id&amp;tid=$tid">$subject</a>}
		: qq{<b>$subject</b>};

	$subject = _build_indent_string($level) . $subject;

	$timestamp=_pretty_print_yyyymmdd($timestamp);
	my $alink = diary_link($author);
	my $comment = qq{<tr bgcolor="#FFFFCC">\n<td><b>$subject</b></td>\n};
	$comment .=   qq{<td>$alink</td>\n<td align=right nowrap>$timestamp</td></tr>\n};

	$message ='' if $message =~ /^\s*$/ || $message =~ /^\s*\(?\s*n\s*[\-\/]?\s*t\s*\)?\s*$/;

	if ($level==1 && $cut && ( length ($message)  > 300)  )	{
		$message = substr($message,0,280) .
	 qq{<!-- cutoff --><a href="%24domain/%24path/reada55f.html?id=$id\&amp;tid=$tid"> .....cont'd</a>};
	}
	$comment .= qq{<tr><td bgcolor="#FFFFEE" colspan=3>$message</td></tr>\n} if $message;
	$comment .= qq{<tr><td bgcolor="#FFFFEE" colspan=3 align=right>\n};

	unless ($noreply) {
		if ( $type eq "admin" || $type eq "moderator" ) {
			$comment .= "[ <a href=_%24domain/%24path/moderateb613.html?id=$id\&amp;tid=$tid\%22>Moderate</a> ]";
		 	$comment .= " Poster's Source IP: $srcip " if $srcip;
			$comment .= "[ <a href=_%24domain/admin/usera3cb.html?username=$author\%22>Admin User</a> ]";
		}
		$comment .= "[ <a href=_%24domain/%24path/replyb613.html?id=$id\&amp;tid=$tid\%22>Reply</a> ]"
			if $author ne "\&lt;Deleted\&gt;";
	}
	
	$comment .= qq{</td></tr>\n};
	return $comment;
}

#
# as display_comment, but only display subject line
# emits one or more table rows
sub _display_thread 
{
	my ($cut,$id,$tid,$level,$subject,$message,$email,$username,$timestamp,$type,$path,$noreply) = @_;

	return "Bad Thread ID" if ! $id;
	
	my ($bg,$thread,$push);
	$push = _build_indent_string($level);
	if ($level < 2 && $cut) {
		# enhance thread leader.
		$subject = qq{<b>$subject</b>};
		$bg = qq{bgcolor="#FFFFEE"};
	}	
	
	$timestamp=_pretty_print_yyyymmdd($timestamp);

	$thread .= qq{<tr $bg><td>};
	$thread .= "\n$push<a href=_%24domain/%24path/readb613.html?id=$id\&amp;tid=$tid\%22>";
	$thread .= "$subject</a></td>";
	$thread .= "<td align=left>" . diary_link($username) . "</td>";
	$thread .= "<td align=right nowrap>$timestamp</td>";
	$thread .= qq{</tr>\n};
	
	return($thread);
}


# _build_indent_string - builds string of &nbsp;s to indent to a given level
#
sub _build_indent_string
{
	my $level = shift;
 	$level= $level < 0 ? 0 : $level > 16 ? 16 : $level-1;
	my $spacer = '&nbsp; ' x $level;
	return $spacer;
}


# get_article_as_html - load article from DB table, and format as HTML
#
# Returns undef if no row with ID $id existed in table $table.
#
# displays the story or top level article associated with this "$id"
# from table $table. Cutting off after 500 chars if $shortform
# showing an edit link if $priv = admin
# and adding a comment on this link if no ID supplied
# Displays all STATUS='active' articles. 
# no auto aging of articles (yet)
# ID's are item numbers for replies
#
# $id -> article id
# $table -> table where data resides
# $shortform -> whether to truncate body
# $priv -> user is an admin
# $path -> top level of url
#
sub get_article_as_html
{
	my ($id,$table,$priv,$path) = @_;
	my $shortform=!$id;
	my $now=time;
	my $where;

	# all posted items not expired, and active
	# This is the Index View..
	$where = "STATUS = 'active' AND EXPIRETIME >$now" ;
	return "Error in Caller: No tablename" if ! $table;
	
	# ..unless an ID was specified on the uri
	if ( int($id) ) {
		# ..in which case we let them see it
		$where = "ID=$id";
	} elsif ($path eq 'news') {
		# ..except for news, where they get the last 7 days and LIKE IT
		my $daterange=$now - (7*24*60*60);
		$where = "ID > $daterange";
	}
	
	my ($hr,$data,$message,$headline,$username,$timestamp,$date,$item,$order);
	# sort order is different for newsletter articles.
	if ($table eq "NEWSLPOSTS" ) {
		$order = "ORDER BY ID ASC"
	}
	else {
		$order = "ORDER BY ID DESC"
	}
	# formats as table with multiple rows
	$data ="<table width=\"100%\" cellpadding=\"2\" cellspacing=\"2\" border=\"0\">\n";
	$Sql ||= UFSQL->new;
	$Sql->cache_next_query;
	my $sth = $Sql->select_many("ID,MESSAGE,HEADLINE,USERNAME,TIMESTAMP",
			"$table","$where","$order");
	my $rows;
	while ($hr=$sth->fetchrow_hashref) {
		$rows++;
		$message = $hr->{'MESSAGE'};
		$headline= $hr->{'HEADLINE'};
		$username = $hr->{'USERNAME'};
		$date= _pretty_print_yyyymmdd($hr->{'TIMESTAMP'});
		$item = $hr->{'ID'};
		if ( $path eq 'news' || $path eq 'newsletter' || $path eq 'animation' ) {
			# no poster's name for news, newsletter or animation
			$data .= qq|<TR><TD bgcolor="#FFFFCC"><B>$headline</B> Updated/Posted: $date</font></TD></TR>\n\n|;
		} else  {
			$data .= qq|<TR><TD bgcolor="#FFFFCC"><B>[$username] $headline</B> Updated/Posted: $date</font></TD></TR>\n\n|;
		}
		# if no id, make navigation items
		if ( $shortform  && (length($message) > 2000) ) {
			$message = substr($message,0,2000);
			$message.= " ...</b><br>\n<a href=_/%24path/index9ce4.html?id=$item\%22>Full text of this item</font></a>\n";
		}
		if (!$id) {
			$message .= qq|\n<br><a href="%24path/indexebae.html?id=$item"><IMG SRC="../graphics.userfriendly.org/images/usercomments.gif" width="60" height="18" ALT="User Comments" border="0"></a><BR>\n\n|;
		}
		if ($priv eq "admin") {
			$message .= qq|\n<a href="%24path/approveebae.html?id=$item">Edit This Article</a><BR>\n\n|;
		}
		$data .= "<TR><TD>$message</TD></TR>\n";
	}
	$sth->finish();
	$data .="</table>\n";
	return unless $rows;
	return $data;
}


# _pretty_print_yyyymmdd - Nicely format an article date
#
sub _pretty_print_yyyymmdd
{
	# Date special format
	my $date = shift;
	if ($date=~/^\d+$/) {
		my $year  = substr($date, 0,4);
		my $month = substr($date, 4,2);
		my $day   = substr($date, 6,2);
		my $hour  = substr($date, 8,2);
		my $min   = substr($date,10,2);
		my $sec   = substr($date,12,2);
		return("[$year/$month/$day $hour:$min]");
	}
	return $date;
}

sub _pretty_print_first_age
{
	# Date special format
	my $date = shift;
	if ($date=~/^\d+$/) {
		my $year  = substr($date, 0,4);
		my $month = substr($date, 4,2);
		my $day   = substr($date, 6,2);
		my $hour  = substr($date, 8,2);
		my $min   = substr($date,10,2);
		my $sec   = substr($date,12,2);
		my $t=timelocal($sec,$min,$hour,$day,($month-1),$year);
		my $f_a = sprintf("%x",($t-882345600));
		# Magic constant Nov 17, 1997	
		return("[FA:$f_a]");
	}
	return $date;
}

# read HTML data
# for file inclusion
#
sub read_file 
{
	my $file = shift;
	my $html="";
	if (!$file) {
		return "Readfile: Empty template filename";
	}
	elsif ( $doc_root && ( -e "$doc_root/$file") ) {
		$file ="$doc_root/$file";
	}
	#
	# bit o magic: filenames are always relative to doc_root
	#
	if (open(FILE, "<$file") ) {
		$html =join ("", <FILE>);
		close(FILE);
		return $html;
 	}
	else {
		warn "Readfile couldn't open $file $!" if $debug;
		return "Couldn't open template file $file: $!\n";
	}
}


# started Nov 17, 1997.
# Ended today.
# 
sub valid_cartoon 
{
	my $date=int shift;
	if ($date > date_numeric_string(time)){
		# if past today, then show an empty one
		return 0;
	}
	my ($year)=(int($date/10000)) - 1900;
	my ($mon)=int(($date%10000)/100);
	$mon--;  
	if ($mon < 0 || $mon > 11 ) {
		return 0;
	}
	my ($dayw)=int(($date % 10000)%100);
	# re-cast time they specifed in local time, and compare
	# to what was given us. if different then dates like 
	# 20011301 (13th month?) were entered
	my @foo=localtime (timelocal(12,20,15,$dayw,$mon,$year));
	my $new=sprintf("%04d%02d%02d",($foo[5]+1900),($foo[4]+1),$foo[3]);
	if ($date == $new && $date >= 19971117 ) {
		return 1;
	}
	else {
		return 0;
	}
}


# Caches cartoon in IPC::CAche.
# Fast, and shares well with others.
#
sub get_cartoon 
{
	
	my (@text,$connection,$t,$rdate,$url,$active);
	# this talks to the main server and gets the correct image
	# for this $date's strip
	my $date = int shift;
	return unless valid_cartoon($date);
	
	unless ( $url = $urlcache{$date} ) {
		# Need to look up this strip's URL.
		# First, see if we can find it in our local database.
		$Sql ||= UFSQL->new;
		my $hr = $Sql->select_hashref('URL', 'STRIPS', "ID=$date");

		unless($url = $hr->{URL}) {
			$connection = new IO::Socket::INET ( Proto => "tcp",
					PeerAddr => "www.userfriendly.org",
					PeerPort => "http(80)",
						   );
			$connection->autoflush(1);
			print $connection "GET /cgi-bin/get_current.cgi?date=$date HTTP/1.0\n\n";
			@text = <$connection>;
			close($connection);
			chomp(@text);
			foreach $t (@text) {
				if (($t =~ /\|/) && (!$active)) {
					($rdate, $url) = split(/\|/,$t,2);
					$active=1;
				}
			}

			$url =~ s/^ //;

			# Illiad, the skank, only started doing consistent graphic sizes Jan 29, 1999 for the weekly
			# and sometime in 1999 for the sunday
			if ($date > 19990129) {
	        		my ($year)=(int($date/10000)) - 1900;
	        		my ($mon)=int(($date%10000)/100);
	        		$mon--;
	        		my ($dayw)=int(($date % 10000)%100);
	        		my ($s)=timelocal(12,20,15,$dayw,$mon,$year);
	        		my ($sec,$min,$hour,$mday,$mond,$yeard,$wday,$yday,$isdst) = localtime($s);
	        		my $height = ( $wday == 0) ? 529 : 274;
				$url .="\" width=\"720\" height=\"$height\" ALT=\"Strip for " . date_pretty($date);
			}
			
			eval { $Sql->insert_id('STRIPS', { ID => $date, URL => $url }) };
		}
	
		# cache it in a local hash. Since this will grow to only 
		# 2000 entries in the forseeable future
		# so should not be a memory issue
		$urlcache{$date} = $url;
	};

	return ($url, date_pretty($date)) ;
}


# wrap a nav and cartoon call into one
# 
sub get_cartoon_html	
{
	# if no date, or zero, do today
	my ($url, $prettydate)=get_cartoon(@_);
	return unless $url;
	#
	#FIXME: Unconditional ad
	#
	my $other;
	# my $other = $state{member} eq 'yes' ? "<DIV style=\"background:ffffcc\">$ENV{AD_BANNER_4}</DIV><BR>": '';
	my $nav = get_cartoon_nav(@_);
	<<"EOF";
$nav<BR>
$other
<B>Cartoon for $prettydate</b><BR>
<a href="cartoons/indexc11c.html?id=$_[0]"><img border="0" src="%24url.html"></a>
EOF
}


# utility routine for a faked up server side include
# 
sub ssi_replace($$) {
	my $r = Apache->request;
	
	# small brain damaged version
	# only does file includes
	# and echo environment variables, for ad banner cachebusting
	# FIXME: does not do proper encoding, only "none" 
	

	# ssi is modified in an environment that includes
	# membership. Basically, for now, membership only changes the includes
	# filenames to $docroot/member/foo
	# this way, if we add special memberships with different functions later
	# we need only change the enumeration in the db, and add
	# some extra logic here.

	my $stuff = shift;
	my $state = shift;
	my $localroot=$doc_root;
	if ($state->{member} eq 'yes' && $state->{ipe}->{WANTAD} ne 'on' ) {
		$localroot.= "/member";
	}
	$stuff =~ s/<!--#include virtual="(.*?)" ?-->/read_file("$localroot$1")/eg;
	$stuff =~ s/<!--#include virtual="(.*?)" ?-->/read_file("$localroot$1")/eg;
	$stuff =~ s/<!--#include virtual="(.*?)" ?-->/read_file("$localroot$1")/eg;
	$stuff =~s/<!--#echo\s+(?:encoding="?none"?\s+)?var="?(.*?)"?\s*-->/$r->subprocess_env($1)/ieg;
	return $stuff;
}

sub _unmunge($) { return "uf" . ( join "", reverse shift =~ /(\d)/g ).".gif"; }


# param replace. acts like small brain damaged Template.pm
# FIXME: replace with real Template.pm?
#
sub param_replace($$)
{
	my ($text,$params)=@_;
	#
	# supports #var# format only.
	#
	foreach my $key (sort { length($b) <=> length($a) } keys %$params) {
		$text =~ s/#$key#/$$params{$key}/eg;
	}
	if ($$params{member} eq 'yes') {
		$text =~ s/(ufng\d+\.gif)/_unmunge($1)/eg;
	}
	return $text;
}

# article_exists
# you canna reply if its not in the fooking table or its inactive
#
sub article_exists 
{
	my ($id,$table)=@_;
	$Sql ||= UFSQL->new;
	my $sth = $Sql->select_many("HEADLINE,STATUS,ID","$table","ID = '$id'","");	
	my $hr = $sth->fetchrow_hashref;
	$sth->finish;	
	# does not 'exist' if headline is empty, not found or status is set to inactive
	if ($hr->{'HEADLINE'} eq "" || $hr->{'STATUS'} eq 'inactive' ) {
		return 0;
	}
	else {
		return 1;
	}
}


# list all the active and inactive posts
#
# Form commands:  For each row, you get a post/query var named "acmd_XX" (where XX is numeric row id)
# that contains one of the following commands:
#    (empty string)    do nothing
#    add_XX            add XX days to expiry date
#    activate_XX       set STATUS=active and set expirty date to XX days from now
#    deactivate        set STATUS=inactive
#    delete            Remove row from db table
#
sub article_list
{
	my $state    = shift;
	my $now      = time;
	my $basetime = $now - (86400*7);
	my $postlist = "<TABLE border=0 cellspacing=0>\n";
	my $chk;
	
	my $activeknob = qq|<select name="acmd_ID"><option value="">-| .
		join("" , map { qq|<option value="add_$_">Add $_ day(s)| } qw/1 2 3 5 7 14 30 60/) .
		qq|<option value="deactivate">Deactivate</select></td><td colspan=3>&nbsp;\n|;

	my $inactiveknob = qq|&nbsp;</td><td align=right colspan=3><select name="acmd_ID"><option value="">-| .
		join("", map { qq|<option value="activate_$_">Activate for $_ day(s)| } qw/1 3 7 14 30 60/) .
		qq|<option value="delete">Delete</select>\n|;
	
	$Sql ||= UFSQL->new;
	my $sth = $Sql->select_many("ID,EXPIRETIME,HEADLINE,MESSAGE,USERNAME,STATUS",$state->{article_table},
		"EXPIRETIME > $basetime","ORDER BY STATUS,ID");
	while (my $hr = $sth->fetchrow_hashref) {
		# now list all the reviews in the database....
		my $id = $hr->{'ID'};
		my $color=qq{"#FFFFCC"};
		my $active = $hr->{STATUS} eq 'active';
		(my $knob = $active ? $activeknob : $inactiveknob) =~ s/ID/$id/eg;
		$color=qq{"#aaffaa"} if $active;

		my $et = $hr->{EXPIRETIME};
		my $nicetime = ($et < $now) ? (int(($now-$et)/86400) . " day(s) ago") : (int(($et-$now)/86400) . " day(s) from now");
		$nicetime =~ s/ /&nbsp;/g;
		$postlist .= "<TR bgcolor=$color><TD><b>$hr->{HEADLINE}</b></td><td><b>$hr->{STATUS}</b></td><td>Poster:<B>$hr->{USERNAME}</b></td><td>Expires:$nicetime</TD></TR>\n";

		# Defang message, so form works
		# note, we allow html in articles, just not in comments
		#FIXME: need to call fancy message defanger
		$hr->{'MESSAGE'}=~ s/</&lt;/g;
		$hr->{'MESSAGE'}=~ s/>/&gt;/g;
		$postlist .= "<TR bgcolor=$color><TD colspan=4>$hr->{MESSAGE}</TD></tr>\n";
		#
		# pre-check and bold current status
		$postlist .= "<TR bgcolor=$color><TD>";
		
		# now the hard part. Approval ui Elements.
		$postlist .=  "$knob</TD></TR>\n";
		$postlist .= "<tr bgcolor=#ffffff><td><font size=0>&nbsp;</font></td></tr>\n";
	}
	$postlist .= "</table>";
	$sth->finish;
	return $postlist;
}


# queries db for level of parent comment.
# 
sub get_comment_parent_level 
{
	my $state = shift;
	my $table = $state->{comment_table};
	my $tid =   $state->{tid} or return (0,0);
	$Sql ||= UFSQL->new;
	my $sth =   $Sql->select_many("ID,ITEM,LEVEL,PARENT",$table,
		"ID='$tid' ", "");
	my $hr = $sth->fetchrow_hashref;
	return ($hr->{LEVEL},$hr->{PARENT});
}

sub insert_comment 
{
	my $state = shift;
	$Sql ||= UFSQL->new;
	my $subparent_id=$state->{tid} || 1;
	my ($level,$parent)=get_comment_parent_level($state);
	my $id_of_new_comment= $Sql->insert_id ( 
		$state->{comment_table}, {
			ITEM         => $state->{id},
			PARENT	     => $parent,
			SUB_PARENT   => $subparent_id,
			LEVEL        => $level+1,
			USERNAME     => $state->{login_user},
			SUBJECT      => $state->{subject},
			MESSAGE      => $state->{message},
			REMOTE_HOST  => $ENV{'REMOTE_ADDR'}
		}
	);
	# 
	# if we are not replying, ie ($state->{tid} is empty
	# 
	unless ( $state->{tid} ) {
		# re-parent a comment with itself
		# mark this as top level
		$Sql->update($state->{comment_table},{
			-SUB_PARENT => $id_of_new_comment , -PARENT => $id_of_new_comment },
			"ID=$id_of_new_comment");
	}
	return $id_of_new_comment;
}


sub update_article
{
	my $state = shift;
	my $id    = shift;
	my $table = $state->{article_table};
	my %c     = @_;

	my %what = ();

	$c{add_expiry} and $what{'-EXPIRETIME'} = "EXPIRETIME + $c{add_expiry}";
	$c{set_expiry} and $what{'-EXPIRETIME'} = "$c{set_expiry}";
	exists $c{set_active} and $what{STATUS} = $c{set_active} ? 'active' : 'inactive';

	$Sql ||= UFSQL->new;
	$Sql->update($table, \%what, "ID=$id");
}


sub delete_article
{
	my $state = shift;
	my $id    = shift;
	my $table = $state->{article_table};
	$Sql ||= UFSQL->new;
	$Sql->delete($table, "ID=$id");
}


sub insert_article { &set_article }


sub set_article
{
	my $state = shift;

	$Sql ||= UFSQL->new;
	my $table = $state->{article_table};
	my $rec = {
		HEADLINE      => $state->{headline},
		MESSAGE       => $state->{message},
		USERNAME      => $state->{login_user},
		'-EXPIRETIME' => $state->{expire},
	};

	$rec->{ID}     = $state->{id} if $state->{id};
	$rec->{STATUS} = $state->{article_status} if $state->{article_status};
	
	eval { $state->{id} = $Sql->insert_id($table, $rec) };
	die "Insert fatal DB error: $@\n" if $@ && $@ !~ /Duplicate entry/; # XXX mysql dep
	$Sql->update($table, $rec, "ID=$state->{id}") if $@;

	return $state->{id};
}

sub insert_survey {
	$Sql ||= UFSQL->new;
	my $table =shift;
	my $rec = shift;
	my $id=0;
	eval { $id = $Sql->insert_id($table, $rec) };
	die "Insert fatal DB error: $@\n" if $@ && $@ !~ /Duplicate entry/; # XXX mysql dep
	return $id;
}
sub moderate_comment
{
	my $state=shift;
	$Sql ||= UFSQL->new;
	$Sql->update( $state->{comment_table}, {
		STATUS => $state->{q}{status}, 
	}, "ID=$state->{tid}");
	audit_log("Moderation: $state->{login_user} set $state->{comment_table} ID=$state->{tid} to $state->{q}{status}");
	return 'success';
}


sub audit_log
{
	my $str = shift;
	warn "AUDITLOG: $str\n";
}


1;

                                                                                                                                                                                                                                          perl/ars.sample.conf                                                                                0100644 0000000 0000000 00000025406 07615710523 013450  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   #!/usr/bin/perl -w
;# $Id: ars.conf,v 2.7 2003/01/04 22:39:53 cvsars Exp $

+{
	# Set me!  Database DSN and credentials
	dbi_dsn => 'DBI:mysql:uf;host=localhost',
	dbi_user => '',
	dbi_pass => '',

	# Set me! This is the document root for the templates and index pages 
	doc_root    => '/home/ars/ARS',
	template_dir=> '/home/ars/perl/template',
	logging_table=>'translog',
	# Set me! This directory must exist and be writable by whatever
	# UID your mod_perl child processes run under.
	cache_root  => '/home/ars/perl/cache_root',

	# Set me! This is how many seconds to cache comment index pages.
	cache_timeout => 5,

	# Set me! This is the list of request handler modules.
	# The names listed here will be prefixed with the package
	# name 'ARSHandler::' and then loaded with require at 
	# RequestHandler.pm module startup (in mod_perl parent process).
	handlers => [qw( Member Admin  User  Comment Mgmt )],
	
	# Set me! Set this to the apache virtual domain.
	domain    => 'http://ars.userfriendly.org',

	# Set me! domain for graphics server, or set same as above
	gdomain    => 'http://graphics.userfriendly.org',

	# Set me! Domain to use when settings cookies (including leading dot)
	cookie_domain => '.userfriendly.org',

	# Set me! administrator role account
	admin_email => 'ars@userfriendly.org',

	# Set me! Number of geekpoints new users start with
	geekpoints_starting => 10,

	# Set me! for extra debug into the error log
	debug     => 0,

	# Set me!  File containing auth cookie blowfish key
	auth_key_file => '/etc/httpd/conf/host_key',

	# Set me!  Path to sendmail executable
	sendmail_path => '/usr/sbin/sendmail',
	shipping => {
		CAD => { US => 10.00, CA => 21.00, DF=> 30.00},
		USD => { US =>  6.00, CA => 14.00, DF=> 18.00},
	},
	spiff => {
		Member => { 
			text	=> 'Standard Membership, Cost:  (USD) $36.00 / (CAD) $58.00',
			spiff	=> "12 months of ad-free Userfriendly.org",
			ccost	=> 58.00,
			ucost	=> 36.00,
			code	=> "ME",
			term	=> "Y", # for paypal
			},
		Minion => {
			text	=> '<UL><LI><B>Tier 1 Sponsorship: Minion</B><BR><B>Cost: (USD) $45.00 / (CAD) $72.00</B><P> Entitles you to 12 months of ad-free Userfriendly.org and a "UserFriendly.org Minion 2002" T-shirt<BR>Shipping extra:
<DIR>
	<LI>in US - (USD) $6 USD/ (CAD) $10 
	<LI>to Canada - (USD) $14 / (CAD) $21
	<LI>International - (USD) $18 / (CAD) $30
</DIR>
',
			spiff	=> '"Userfriendly.org Minion 2002" T-shirt"<BR>',
			ccost	=> 72.00,
			ucost	=> 45.00,
			code	=> "MI",
			term	=> "Y",  # paypal
			},
		"Evil Genius in Training"=> {
			text  =>'<UL><LI><B>Tier 2 Sponsorship: Evil Genius-in-Training</B><BR><B>Cost: (USD) $99.00 / (CAD) $159.00</B><P> <DIR>
	<LI>12 months of ad-free Userfriendly.org
	<LI>a "UserFriendly.org Evil Genius-in-Training 2002" T-shirt
	<LI>a plush Dust Puppy doll
	<LI>an "Evil Genius-in-Training 2002" Coffee Mug
</DIR>Shipping extra:
<DIR>
	<LI>in US - (USD) $6 USD/ (CAD) $10 
	<LI>to Canada - (USD) $14 / (CAD) $21
	<LI>International - (USD) $18 / (CAD) $30
</DIR>
</UL>
',
			spiff	=> '"UserFriendly.org Evil Genius-in-Training 2002" T-shirt, a plush Dust Puppy doll and an "Evil Genius-in-Training 2002" Coffee Mug<BR>',
			ccost	=> 159.00,
			ucost	=> 99.00,
			code	=> "GI",
			term	=> "Y",
			},
		"Evil Genius"=> {
			
			text	=> '<UL><LI><B>Tier 3 Sponsorship: Evil Genius</B><BR><B>Cost: (USD) $250.00 / (CAD) $399</B><P>
			<DIR>
	<LI>12 months of ad-free Userfriendly.org
	<LI>a "UserFriendly.org Evil Genius 2002" T-shirt
	<LI>a plush Dust Puppy doll
	<LI>an "Evil Genius 2002" Coffee Mug
	<LI>an "Evil Genius 2002" Diploma suitable for framing
	<LI>a $25 UF Store Gift Certificate
</DIR>Shipping extra:
<DIR>
	<LI>in US - (USD) $6 USD/ (CAD) $10 
	<LI>to Canada - (USD) $14 / (CAD) $21
	<LI>International - (USD) $18 / (CAD) $30
</DIR>
</UL>
',
			spiff	=> '"UserFriendly.org Evil Genius 2002" T-shirt, a plush Dust Puppy doll, an "Evil Genius 2002" Coffee Mug, an "Evil Genius 2002" Diploma suitable for framing, a $20 UF Store Gift Certificate',
			ccost	=> 399.00,
			ucost	=> 250.00,
			code  	=> "EG",
			term	=> "Y",
			},
		"Dark Regent"=> {
			text	=> '<UL><LI><B>Tier 4 Sponsorship: Dark Regent</B><BR><B>Cost: (USD) $1000.00 / (CAD) $1599</B><P>
Entitles you to
<DIR>
	<LI>12 months of ad-free Userfriendly.org
	<LI>a "UserFriendly.org Dark Regent 2002" T-shirt
	<LI>a plush Dust Puppy doll
	<LI>a "Dark Regent 2002" Coffee Mug
	<LI>a "Dark Regent 2002" Diploma suitable for framing
	<LI>Set of 4 User Friendly books signed by Illiad
	<LI>a $50 UF Store Gift Certificate
	<LI>a signed Limited Edition Print
</DIR>Shipping extra:
<DIR>
	<LI>in US - (USD) $6 USD/ (CAD) $10 
	<LI>to Canada - (USD) $14 / (CAD) $21
	<LI>International - (USD) $18 / (CAD) $30
</DIR>
</UL>
',
			spiff	=> 'a "UserFriendly.org Dark Regent 2002" T-shirt, a plush Dust Puppy doll, a "Dark Regent 2002" Coffee Mug, a "Dark Regent 2002" Diploma suitable for framing, Set of 4 User Friendly books signed by Illiad, a $50 UF Store Gift Certificate, a signed Limited Edition Print',
			ccost	=> 1599.00,
			ucost	=> 1000.00,
			code	=> "DR",
			term	=> "Y",
			},
	} ,
	db_layout => {
		users      => {
			Title   => 'UF - User Diary',
			Articles=> 'DIARY',
			Comments=> 'DIARYCOMMENTS',
		} ,
		news       => { 
			Title    => 'UF - Daily Static News Comments' ,
			Articles => 'NEWS',
			Comments => 'COMMENTS' 
		} ,
		cartoons   => { 
			Title    => 'UserFriendly Strip Comments' ,
			Articles => '',
			Comments => 'CARTOONS' 
		} ,
		newsletter => { 
			Title    => 'UF - Static Cling Newsletter Comments' ,
			Articles => 'NEWSLPOSTS',
			Comments => 'NEWSLCOMMENTS' 
		} ,
		animation  => { 
			Title    => 'UF - Animation Comments' ,
			Articles => 'ANIMS',
			Comments => 'ANIMCOMMENTS' 
		} ,
		lotd	     => { 
			Title    => 'UF - Link Of The Day Comments' ,
			Articles => 'LOTD',
			Comments => 'LOTDCOMMENTS' 
		} ,
		ff	     => { 
			Title    => 'UF - FF' ,
			Articles => 'FF',
			Comments => 'FFCOMMENTS' 
		} ,	
		forum	     => { 
			Title    => 'UF - Friendly Forum Comments' ,
			Articles => 'FORUM',
			Comments => 'FORUMCOMMENTS' 
		} ,	
		video        => {
			Title   => 'UF - Videos',
			Articles=> 'VIDEO',
			Comments=> 'VIDEOCOMMENTS',
		} ,
	},


	nav_html => {
		comments => {
			# UF cartoon nav with comments 
			firstday=> <<'EOF',
<img src="../graphics.userfriendly.org/images/nav_first.gif" height="25" width="313" border="0" usemap="#ars">
<map name="ars">
<area shape="rect" href="cartoons/emailstripfdd3.html?id=$date" coords="32,0 100,25" alt="Email the strip to a friend">
<area shape="rect" href="../www.userfriendly.org/cartoons/archives/index-2.html" coords="110,0 160,25" alt="Cartoon Search">
<area shape="rect" href="cartoons/index43f6.html" coords="165,0 220,25" alt="Random Cartoon">
<area shape="rect" href="cartoons/indexc515.html?id=$tomorrow" coords="227,0 310,25" alt="Next Day's Cartoon">
</map>
EOF

			lastday=> <<'EOF',
<img src="../graphics.userfriendly.org/images/nav_last.gif" height="25" width="304" border="0" usemap="#ars">
<map name="ars">
<area shape="rect" href="cartoons/index6b1f.html?id=$yesterday" coords="32,0 88,25" alt="Previous Cartoon">
<area shape="rect" href="cartoons/emailstripfdd3.html?id=$date" coords="91,0 155,25" alt="Email the strip to a friend">
<area shape="rect" href="../www.userfriendly.org/cartoons/archives/index-2.html" coords="162,0 218,25" alt="Cartoon Search">
<area shape="rect" href="cartoons/index43f6.html" coords="221,0 277,25" alt="Random Cartoon">
</map>
EOF
			all=>  <<'EOF',
<img src="../graphics.userfriendly.org/images/nav_all.gif" height="25" width="369" border="0" usemap="#ars">
<map name="ars">
<area shape="rect" href="cartoons/index6b1f.html?id=$yesterday" coords="32,0 88,25" alt="Previous Cartoon">
<area shape="rect" href="cartoons/emailstripfdd3.html?id=$date" coords="91,0 155,25" alt="Email the strip to a friend">
<area shape="rect" href="../www.userfriendly.org/cartoons/archives/index-2.html" coords="162,0 218,25" alt="Cartoon Search">
<area shape="rect" href="cartoons/index43f6.html" coords="221,0 277,25" alt="Random Cartoon">
<area shape="rect" href="cartoons/indexc515.html?id=$tomorrow" coords="281,0 342,25" alt="Next Day's Cartoon">
</map>
EOF
		},
		no_comments => {
			# UF "Classic nav" with the big pencils
			firstday => <<'EOF',
<img src="../graphics.userfriendly.org/images/classic_first.gif" height="80" width="528" border="0" usemap="#ars">
<map name="ars">
<area shape="rect" href="../www.userfriendly.org/static/index.html" coords="33,0 121,80" alt="Daily Static">
<area shape="rect" href="cartoons/emailstripfdd3.html?id=$date" coords="122,0 200,80" alt="Email the strip to a friend">
<area shape="rect" href="../www.userfriendly.org/cartoons/archives/index.html" coords="201,0 256,80" alt="Up to Archive top">
<area shape="rect" href="cartoons/index9f44.html?id=$tomorrow&amp;mode=classic" coords="257,0 330,80" alt="">
<area shape="rect" href="../www.userfriendly.org/cartoons/archives/index-2.html" coords="331,0 407,80" alt="Cartoon Search">
<area shape="rect" href="cartoons/index43f6.html" coords="408,0 490,80" alt="Random Cartoon">
</map>
EOF

			lastday => <<'EOF',
<img src="../graphics.userfriendly.org/images/classic_last.gif" height="80" width="528" border="0" usemap="#ars">
<map name="ars">
<area shape="rect" href="../www.userfriendly.org/static/index.html" coords="33,0 121,80" alt="Daily Static">
<area shape="rect" href="cartoons/emailstripfdd3.html?id=$date" coords="122,0 200,80" alt="Email the strip to a friend">
<area shape="rect" href="cartoons/index176f.html?id=$yesterday&amp;mode=classic" coords="201,0 274,80" alt="Previous Cartoon">
<area shape="rect" href="../www.userfriendly.org/cartoons/archives/index.html" coords="275,0 327,80" alt="Up to Archive top">
<area shape="rect" href="../www.userfriendly.org/cartoons/archives/index-2.html" coords="328,0 410,80" alt="Cartoon Search">
<area shape="rect" href="cartoons/index43f6.html" coords="411,0 490,80" alt="Random Cartoon">
</map>
EOF
 
			all => <<'EOF',
<img src="../graphics.userfriendly.org/images/classic_all.gif" height="80" width="528" border="0" usemap="#ars">
<map name="ars">
<area shape="rect" href="../www.userfriendly.org/static/index.html" coords="0,0 84,80" alt="Daily Static">
<area shape="rect" href="cartoons/emailstripfdd3.html?id=$date" coords="85,0 160,80" alt="Email the strip to a friend">
<area shape="rect" href="cartoons/index176f.html?id=$yesterday&amp;mode=classic" coords="161,0 238,80" alt="Previous Cartoon">
<area shape="rect" href="../www.userfriendly.org/cartoons/archives/index.html" coords="239,0 293,80" alt="Up to Archive top">
<area shape="rect" href="cartoons/index9f44.html?id=$tomorrow&amp;mode=classic" coords="294,0 369,80" alt="">
<area shape="rect" href="../www.userfriendly.org/cartoons/archives/index-2.html" coords="370,0 446,80" alt="Cartoon Search">
<area shape="rect" href="cartoons/index43f6.html" coords="447,0 533,80" alt="Random Cartoon">
</map>
EOF
		},
	},	
};

__END__

                                                                                                                                                                                                                                                          perl/doc/                                                                                           0040755 0000000 0000000 00000000000 07501447131 011271  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   perl/doc/arsdb.sql                                                                                  0100644 0000000 0000000 00000033634 07501447127 013120  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   # MySQL dump 8.14
#
# Host: localhost    Database: uf
#--------------------------------------------------------
# Server version	3.23.38-Max-log

#
# Table structure for table 'ANIMCOMMENTS'
#

CREATE TABLE ANIMCOMMENTS (
  ID int(20) NOT NULL auto_increment,
  ITEM int(20) NOT NULL default '0',
  PARENT int(20) NOT NULL default '0',
  SUB_PARENT int(20) NOT NULL default '0',
  LEVEL int(1) default NULL,
  TIMESTAMP timestamp(14) NOT NULL,
  GEEKPTS int(20) default '0',
  USERNAME varchar(15) NOT NULL default '',
  SUBJECT varchar(150) NOT NULL default '',
  MESSAGE text,
  STATUS enum('active','inactive','dthread','kthread') NOT NULL default 'active',
  REMOTE_HOST varchar(75) default NULL,
  MOD_BY varchar(15) default NULL,
  MOD_DATE varchar(30) default NULL,
  PRIMARY KEY  (ID),
  KEY parent_idx (PARENT),
  KEY subparent_idx (SUB_PARENT),
  KEY item_idx (ITEM),
  KEY status_idx (STATUS)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'ANIMS'
#

CREATE TABLE ANIMS (
  ID int(20) NOT NULL auto_increment,
  TIMESTAMP timestamp(14) NOT NULL,
  EXPIRETIME int(14) NOT NULL default '0',
  USERNAME varchar(15) NOT NULL default '',
  HEADLINE varchar(150) default NULL,
  MESSAGE text,
  STATUS enum('active','inactive') NOT NULL default 'inactive',
  PRIMARY KEY  (ID),
  KEY status_idx (STATUS),
  KEY expire_idx (EXPIRETIME)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'CARTOONS'
#

CREATE TABLE CARTOONS (
  ID int(20) NOT NULL auto_increment,
  ITEM int(20) NOT NULL default '0',
  PARENT int(20) NOT NULL default '0',
  SUB_PARENT int(20) NOT NULL default '0',
  LEVEL int(1) default NULL,
  TIMESTAMP timestamp(14) NOT NULL,
  GEEKPTS int(20) default '0',
  USERNAME varchar(15) NOT NULL default '',
  SUBJECT varchar(150) NOT NULL default '',
  MESSAGE text,
  STATUS enum('active','inactive','dthread','kthread') NOT NULL default 'active',
  REMOTE_HOST varchar(75) default NULL,
  MOD_BY varchar(15) default NULL,
  MOD_DATE varchar(30) default NULL,
  PRIMARY KEY  (ID),
  KEY parent_idx (PARENT),
  KEY subparent_idx (SUB_PARENT),
  KEY item_idx (ITEM),
  KEY status_idx (STATUS),
  KEY parent (PARENT),
  KEY idx (ID),
  KEY useridx (USERNAME)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'COMMENTS'
#

CREATE TABLE COMMENTS (
  ID int(20) NOT NULL auto_increment,
  ITEM int(20) NOT NULL default '0',
  PARENT int(20) NOT NULL default '0',
  SUB_PARENT int(20) NOT NULL default '0',
  LEVEL int(1) default NULL,
  TIMESTAMP timestamp(14) NOT NULL,
  GEEKPTS int(20) default '0',
  USERNAME varchar(15) NOT NULL default '',
  SUBJECT varchar(150) NOT NULL default '',
  MESSAGE text,
  STATUS enum('active','inactive','dthread','kthread') NOT NULL default 'active',
  REMOTE_HOST varchar(75) default NULL,
  MOD_BY varchar(15) default NULL,
  MOD_DATE varchar(30) default NULL,
  PRIMARY KEY  (ID),
  KEY item_idx (ITEM),
  KEY parent_idx (PARENT),
  KEY subparent_idx (SUB_PARENT),
  KEY status_idx (STATUS),
  KEY idx (ID),
  KEY useridx (USERNAME),
  KEY user (USERNAME)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'DIARY'
#

CREATE TABLE DIARY (
  ID int(20) NOT NULL default '0',
  TIMESTAMP timestamp(14) NOT NULL,
  EXPIRETIME int(14) NOT NULL default '0',
  USERNAME varchar(15) NOT NULL default '',
  HEADLINE varchar(150) default NULL,
  MESSAGE text,
  STATUS enum('active','inactive') NOT NULL default 'inactive',
  PRIMARY KEY  (ID),
  KEY status_idx (STATUS),
  KEY expire_idx (EXPIRETIME)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'DIARYCOMMENTS'
#

CREATE TABLE DIARYCOMMENTS (
  ID int(20) NOT NULL auto_increment,
  ITEM int(20) NOT NULL default '0',
  PARENT int(20) NOT NULL default '0',
  SUB_PARENT int(20) NOT NULL default '0',
  LEVEL int(1) default NULL,
  TIMESTAMP timestamp(14) NOT NULL,
  GEEKPTS int(20) default '0',
  USERNAME varchar(15) NOT NULL default '',
  SUBJECT varchar(150) NOT NULL default '',
  MESSAGE text,
  STATUS enum('active','inactive','dthread','kthread') NOT NULL default 'active',
  REMOTE_HOST varchar(75) default NULL,
  MOD_BY varchar(15) default NULL,
  MOD_DATE varchar(30) default NULL,
  PRIMARY KEY  (ID),
  KEY parent_idx (PARENT),
  KEY subparent_idx (SUB_PARENT),
  KEY item_idx (ITEM),
  KEY status_idx (STATUS)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'FORUM'
#

CREATE TABLE FORUM (
  ID int(20) NOT NULL auto_increment,
  TIMESTAMP timestamp(14) NOT NULL,
  EXPIRETIME int(14) NOT NULL default '0',
  USERNAME varchar(15) NOT NULL default '',
  HEADLINE varchar(150) default NULL,
  MESSAGE text,
  STATUS enum('active','inactive') NOT NULL default 'inactive',
  PRIMARY KEY  (ID),
  KEY status_idx (STATUS),
  KEY expire_idx (EXPIRETIME)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'FORUMCOMMENTS'
#

CREATE TABLE FORUMCOMMENTS (
  ID int(20) NOT NULL auto_increment,
  ITEM int(20) NOT NULL default '0',
  PARENT int(20) NOT NULL default '0',
  SUB_PARENT int(20) NOT NULL default '0',
  LEVEL int(1) default NULL,
  TIMESTAMP timestamp(14) NOT NULL,
  GEEKPTS int(20) default '0',
  USERNAME varchar(15) NOT NULL default '',
  SUBJECT varchar(150) NOT NULL default '',
  MESSAGE text,
  STATUS enum('active','inactive','dthread','kthread') NOT NULL default 'active',
  REMOTE_HOST varchar(75) default NULL,
  MOD_BY varchar(15) default NULL,
  MOD_DATE varchar(30) default NULL,
  PRIMARY KEY  (ID),
  KEY parent_idx (PARENT),
  KEY subparent_idx (SUB_PARENT),
  KEY item_idx (ITEM),
  KEY status_idx (STATUS)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'GEEKCOMMENTS'
#

CREATE TABLE GEEKCOMMENTS (
  ID int(20) NOT NULL auto_increment,
  ITEM int(20) NOT NULL default '0',
  PARENT int(20) NOT NULL default '0',
  SUB_PARENT int(20) NOT NULL default '0',
  LEVEL int(1) default NULL,
  TIMESTAMP timestamp(14) NOT NULL,
  GEEKPTS int(20) default '0',
  USERNAME varchar(15) NOT NULL default '',
  SUBJECT varchar(150) NOT NULL default '',
  MESSAGE text,
  STATUS enum('active','inactive') NOT NULL default 'active',
  REMOTE_HOST varchar(75) default NULL,
  PRIMARY KEY  (ID),
  KEY parent_idx (PARENT),
  KEY subparent_idx (SUB_PARENT),
  KEY status_idx (STATUS),
  KEY item_idx (ITEM)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'GEEKSTUFF'
#

CREATE TABLE GEEKSTUFF (
  ID int(20) NOT NULL auto_increment,
  TIMESTAMP timestamp(14) NOT NULL,
  USERNAME varchar(15) NOT NULL default '',
  HEADLINE varchar(150) default NULL,
  PREVIEW text,
  MESSAGE text,
  IMAGE varchar(25) default 'erwin.gif',
  STATUS enum('active','inactive') NOT NULL default 'inactive',
  PRIMARY KEY  (ID),
  KEY status_idx (STATUS)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'LOTD'
#

CREATE TABLE LOTD (
  ID int(20) NOT NULL auto_increment,
  TIMESTAMP timestamp(14) NOT NULL,
  EXPIRETIME int(14) NOT NULL default '0',
  USERNAME varchar(15) NOT NULL default '',
  HEADLINE varchar(150) default NULL,
  MESSAGE text,
  STATUS enum('active','inactive') NOT NULL default 'inactive',
  PRIMARY KEY  (ID),
  KEY status_idx (STATUS),
  KEY expire_idx (EXPIRETIME)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'LOTDCOMMENTS'
#

CREATE TABLE LOTDCOMMENTS (
  ID int(20) NOT NULL auto_increment,
  ITEM int(20) NOT NULL default '0',
  PARENT int(20) NOT NULL default '0',
  SUB_PARENT int(20) NOT NULL default '0',
  LEVEL int(1) default NULL,
  TIMESTAMP timestamp(14) NOT NULL,
  GEEKPTS int(20) default '0',
  USERNAME varchar(15) NOT NULL default '',
  SUBJECT varchar(150) NOT NULL default '',
  MESSAGE text,
  STATUS enum('active','inactive','dthread','kthread') NOT NULL default 'active',
  REMOTE_HOST varchar(75) default NULL,
  MOD_BY varchar(15) default NULL,
  MOD_DATE varchar(30) default NULL,
  PRIMARY KEY  (ID),
  KEY parent_idx (PARENT),
  KEY subparent_idx (SUB_PARENT),
  KEY item_idx (ITEM),
  KEY status_idx (STATUS)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'MAILINGLISTS'
#

CREATE TABLE MAILINGLISTS (
  ID int(11) NOT NULL auto_increment,
  NAME varchar(30) NOT NULL default '',
  DESCRIPTION varchar(200) NOT NULL default '',
  FREQUENCY varchar(32) default NULL,
  OLDFIELDNAME varchar(32) default NULL,
  PRIMARY KEY  (ID)
) TYPE=InnoDB;

#
# Table structure for table 'NEWS'
#

CREATE TABLE NEWS (
  ID int(20) NOT NULL auto_increment,
  TIMESTAMP timestamp(14) NOT NULL,
  USERNAME varchar(15) NOT NULL default '',
  HEADLINE varchar(150) default NULL,
  PREVIEW text,
  MESSAGE text,
  IMAGE varchar(25) default 'erwin.gif',
  STATUS enum('active','inactive') default NULL,
  PRIMARY KEY  (ID),
  KEY idx (ID),
  KEY timeidx (TIMESTAMP)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'NEWSLCOMMENTS'
#

CREATE TABLE NEWSLCOMMENTS (
  ID int(20) NOT NULL auto_increment,
  ITEM int(20) NOT NULL default '0',
  PARENT int(20) NOT NULL default '0',
  SUB_PARENT int(20) NOT NULL default '0',
  LEVEL int(1) default NULL,
  TIMESTAMP timestamp(14) NOT NULL,
  GEEKPTS int(20) default '0',
  USERNAME varchar(15) NOT NULL default '',
  SUBJECT varchar(150) NOT NULL default '',
  MESSAGE text,
  STATUS enum('active','inactive','dthread','kthread') NOT NULL default 'active',
  REMOTE_HOST varchar(75) default NULL,
  MOD_BY varchar(15) default NULL,
  MOD_DATE varchar(30) default NULL,
  PRIMARY KEY  (ID),
  KEY parent_idx (PARENT),
  KEY subparent_idx (SUB_PARENT),
  KEY item_idx (ITEM),
  KEY status_idx (STATUS)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'NEWSLPOSTS'
#

CREATE TABLE NEWSLPOSTS (
  ID int(20) NOT NULL auto_increment,
  TIMESTAMP timestamp(14) NOT NULL,
  EXPIRETIME int(14) NOT NULL default '0',
  USERNAME varchar(15) NOT NULL default '',
  HEADLINE varchar(150) default NULL,
  MESSAGE text,
  STATUS enum('active','inactive') NOT NULL default 'inactive',
  PRIMARY KEY  (ID),
  KEY status_idx (STATUS),
  KEY expire_idx (EXPIRETIME)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'PROPERTIES'
#

CREATE TABLE PROPERTIES (
  ID int(10) unsigned NOT NULL auto_increment,
  NAME varchar(20) NOT NULL default '',
  HOISTED tinyint(4) NOT NULL default '0',
  PRIMARY KEY  (ID)
) TYPE=InnoDB;



INSERT INTO PROPERTIES VALUES (1,'ID',1);
INSERT INTO PROPERTIES VALUES (2,'USERNAME',1);
INSERT INTO PROPERTIES VALUES (3,'SECMAIL',1);
INSERT INTO PROPERTIES VALUES (4,'LISTMAIL',0);
INSERT INTO PROPERTIES VALUES (5,'LISTBITMAP',0);
INSERT INTO PROPERTIES VALUES (6,'PASSWORD',1);
INSERT INTO PROPERTIES VALUES (7,'EMAIL',1);
INSERT INTO PROPERTIES VALUES (8,'TYPE',1);
INSERT INTO PROPERTIES VALUES (9,'GEEKPTS',1);
INSERT INTO PROPERTIES VALUES (10,'RECSTATIC',1);
INSERT INTO PROPERTIES VALUES (11,'RECSURVEY',1);
INSERT INTO PROPERTIES VALUES (12,'DISABLED',1);
INSERT INTO PROPERTIES VALUES (13,'SIGNATURE',1);
INSERT INTO PROPERTIES VALUES (14,'RECINVESTOR',1);
INSERT INTO PROPERTIES VALUES (15,'RECSM',1);
INSERT INTO PROPERTIES VALUES (16,'RECPRESS',1);
INSERT INTO PROPERTIES VALUES (17,'SEEMOD',1);
INSERT INTO PROPERTIES VALUES (18,'STYLE',1);
INSERT INTO PROPERTIES VALUES (20,'UPDATED',1);
INSERT INTO PROPERTIES VALUES (21,'LISTSTATUS',0);
INSERT INTO PROPERTIES VALUES (22,'NEWPASS',0);
INSERT INTO PROPERTIES VALUES (23,'NEWPASS_DATE',0);
INSERT INTO PROPERTIES VALUES (24,'ADMIN_COMMENT',0);
INSERT INTO PROPERTIES VALUES (25,'DIARYCONTENT',0);
INSERT INTO PROPERTIES VALUES (26,'MEMBER',1);
INSERT INTO PROPERTIES VALUES (27,'MEMBNAME',0);
INSERT INTO PROPERTIES VALUES (28,'MEMBADDR',0);
INSERT INTO PROPERTIES VALUES (29,'MEMBCITY',0);
INSERT INTO PROPERTIES VALUES (30,'MEMBPROV',0);
INSERT INTO PROPERTIES VALUES (31,'MEMBCODE',0);
INSERT INTO PROPERTIES VALUES (32,'MEMBCTRY',0);
INSERT INTO PROPERTIES VALUES (33,'MEMBDATE',0);
INSERT INTO PROPERTIES VALUES (34,'MEMBEXPDATE',0);
#
# Table structure for table 'STRIPS'
#

CREATE TABLE STRIPS (
  ID int(15) unsigned NOT NULL default '0',
  URL varchar(255) NOT NULL default '',
  PRIMARY KEY  (ID)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'USERPROPERTIES'
#

CREATE TABLE USERPROPERTIES (
  USERID int(11) NOT NULL default '0',
  PROPID int(11) NOT NULL default '0',
  VALUE text NOT NULL,
  PRIMARY KEY  (USERID,PROPID)
) TYPE=InnoDB;

#
# Table structure for table 'USERS'
#

CREATE TABLE USERS (
  ID int(15) unsigned NOT NULL auto_increment,
  USERNAME varchar(15) NOT NULL default '',
  PASSWORD varchar(30) NOT NULL default '',
  EMAIL text NOT NULL,
  TYPE enum('user','admin','moderator') default 'user',
  GEEKPTS smallint(15) default '0',
  RECSTATIC varchar(6) default NULL,
  RECSURVEY varchar(6) default NULL,
  DISABLED varchar(6) default NULL,
  SIGNATURE text,
  RECINVESTOR varchar(6) default NULL,
  RECSM varchar(6) default NULL,
  RECPRESS varchar(6) default NULL,
  SEEMOD varchar(6) default NULL,
  STYLE varchar(15) NOT NULL default '',
  SECMAIL text,
  UPDATED int(15) default NULL,
  MEMBER enum('no','yes') default 'no',
  PRIMARY KEY  (ID),
  KEY AUTH (USERNAME,PASSWORD),
  KEY useridx (USERNAME),
  KEY passidx (PASSWORD)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'VIDEO'
#

CREATE TABLE VIDEO (
  ID int(20) NOT NULL auto_increment,
  TIMESTAMP timestamp(14) NOT NULL,
  EXPIRETIME int(14) NOT NULL default '0',
  USERNAME varchar(15) NOT NULL default '',
  HEADLINE varchar(150) default NULL,
  MESSAGE text,
  STATUS enum('active','inactive') NOT NULL default 'inactive',
  PRIMARY KEY  (ID),
  KEY status_idx (STATUS),
  KEY expire_idx (EXPIRETIME)
) TYPE=InnoDB PACK_KEYS=1;

#
# Table structure for table 'VIDEOCOMMENTS'
#

CREATE TABLE VIDEOCOMMENTS (
  ID int(20) NOT NULL auto_increment,
  ITEM int(20) NOT NULL default '0',
  PARENT int(20) NOT NULL default '0',
  SUB_PARENT int(20) NOT NULL default '0',
  LEVEL int(1) default NULL,
  TIMESTAMP timestamp(14) NOT NULL,
  GEEKPTS int(20) default '0',
  USERNAME varchar(15) NOT NULL default '',
  SUBJECT varchar(150) NOT NULL default '',
  MESSAGE text,
  STATUS enum('active','inactive','dthread','kthread') NOT NULL default 'active',
  REMOTE_HOST varchar(75) default NULL,
  MOD_BY varchar(15) default NULL,
  MOD_DATE varchar(30) default NULL,
  PRIMARY KEY  (ID),
  KEY parent_idx (PARENT),
  KEY subparent_idx (SUB_PARENT),
  KEY item_idx (ITEM),
  KEY status_idx (STATUS)
) TYPE=InnoDB PACK_KEYS=1;


                                                                                                    perl/doc/Installation_Instructions                                                                  0100644 0000000 0000000 00000002271 07501446542 016445  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   Installation instructions:

1. Unpack the tarball
	tar -xzvf ars.tar.gz

   This creates the directory perl
	You need a document root to stash include files and files not handled by ARS.
	
	
2.  Install the perl modules


UFMEDIA::CacheOneFile

included in the scripts directory.

Time::Local
Crypt::Blowfish;
use DBI ();
use DBD::mysql ();

3.  hack your apache httpd.conf to do the following:
	a. include the httpd.conf included with the tarball
	b. source the included startup.perl
	c. obvious path changes as needed

<VirtualHost xxx.yyyy.zzz.mmm:80>
	PerlRequire /home/ars/perl/startup.perl
	ServerName ars.userfriendly.org
	Include /home/ars/perl/httpd.conf
</VirtualHost>

4. Database:
as root...
mysqladmin create arsdb

modify ars.conf so that it matches the local machine.
Often you want the host to be localhost.

mysql_dsn => 'DBI:mysql:arsdb;host=localhost',
dbi_user => 'ars',
dbi_pass => 'arspass', 

arsdb is the db
ars   is the mysql user
arspass is the mysql password

Grant access to the db to that specific user

mysql ars
grant all privileges on arsdb.* to ars@'localhost' identified by 'arspass';

Then create the standard tables

mysql arsdb < arsdb.sql

Then the system should come up
                                                                                                                                                                                                                                                                                                                                       perl/doc/License                                                                                    0100644 0000000 0000000 00000013622 07442555505 012610  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   This Software is released under the Artistic License, which follows.

The "Artistic License"

Preamble
The intent of this document is to state the conditions under which a Package may be copied, such that the
Copyright Holder maintains some semblance of artistic control over the development of the package, while
giving the users of the package the right to use and distribute the Package in a more-or-less customary
fashion, plus the right to make reasonable modifications. 

Definitions
"Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that
collection of files created through textual modification. 

"Standard Version" refers to such a Package if it has not been modified, or has been modified in
accordance with the wishes of the Copyright Holder as specified below. 

"Copyright Holder" is whoever is named in the copyright or copyrights for the package. 

"You" is you, if you're thinking about copying or distributing this Package. 

"Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges,
time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but
only to the computing community at large as a market that must bear the fee.) 

"Freely Available" means that no fee is charged for the item itself, though there may be fees involved in
handling the item. It also means that recipients of the item may redistribute it under the same
conditions they received it. 


You may make and give away verbatim copies of the source form of the Standard Version of this Package
without restriction, provided that you duplicate all of the original copyright notices and associated
disclaimers. 


You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from
the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 


You may otherwise modify your copy of this Package in any way, provided that you insert a prominent
notice in each changed file stating how and when you changed that file, and provided that you do at least
ONE of the following: 


place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting
said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive
site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the
Standard Version of the Package. 
use the modified Package only within your corporation or organization. 
rename any non-standard executables so the names do not conflict with standard executables, which must
also be provided, and provide a separate manual page for each non-standard executable that clearly
documents how it differs from the Standard Version. 
make other distribution arrangements with the Copyright Holder. 


You may distribute the programs of this Package in object code or executable form, provided that you do
at least ONE of the following: 


distribute a Standard Version of the executables and library files, together with instructions (in the
manual page or equivalent) on where to get the Standard Version. 
accompany the distribution with the machine-readable source of the Package with your modifications. 
give non-standard executables non-standard names, and clearly document the differences in manual pages
(or equivalent), together with instructions on where to get the Standard Version. 
make other distribution arrangements with the Copyright Holder. 


You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you
choose for support of this Package. You may not charge a fee for this Package itself. However, you may
distribute this Package in aggregate with other (possibly commercial) programs as part of a larger
(possibly commercial) software distribution provided that you do not advertise this Package as a product
of your own. You may embed this Package's interpreter within an executable of yours (by linking); this
shall be construed as a mere form of aggregation, provided that the complete Standard Version of the
interpreter is so embedded. 


The scripts and library files supplied as input to or produced as output from the programs of this
Package do not automatically fall under the copyright of this Package, but belong to whomever generated
them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library
files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a
binary executable image, then distribution of such an image shall neither be construed as a distribution
of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not
represent such an executable image as a Standard Version of this Package. 


C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into
this Package in order to emulate subroutines and variables of the language defined by this Package shall
not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these
subroutines do not change the language in any way that would cause it to fail the regression tests for
the language. 


Aggregation of this Package with a commercial distribution is always permitted provided that the use of
this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces
visible to the end user of the commercial distribution. Such use shall not be construed as a distribution
of this Package. 


The name of the Copyright Holder may not be used to endorse or promote products derived from this
software without specific prior written permission. 


THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT
LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 

The End 

                                                                                                              perl/doc/README                                                                                     0100644 0000000 0000000 00000004725 07442555505 012167  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   $Id: README,v 1.1 2002/03/10 04:04:21 jay Exp $

Version 2.1

We call the software ARS, the UF Account Registration System

We built this to enable the fans to comment on the 
strip. We've since expanded it to include the news, the link of the day, 
the animations, the newletter, the various new content areas and, 
in a burst of energy, added a weblog for each registered user.

The license is Artistic or GPL, just like perl, since the 
software is heavily based on perl.

Feature List:

Heavy caching of comments.
	We cache the various views of the strip for 5 seconds. 
	On a really good day, we get nearly 1000 comments and 
	it can take up to 400 milliseconds of CPU on a pIII550 
	to regenerate this list, its a BIG win. Our hits per
	second goes from 1.5 to 30 with the addition of this
	very simple change. Moderators always get the uncached
	version. Just so they can keep on top of things.

SSI functionality
	Standard SSI tags are used, so you don't need a separate
	set for the comment board

Compact, design
	We have a clean separation of Admin, User and Comment
	code, with several helper modules for
	SQL(UFSQL), User Properties (UFIPE) HTML(ARS_HTML)
	and a central set of utility routines (UserFriendly.pm) and
	RequestHandler.pm. ARS 1.x had quite a few problems and
	quite a few bits of duplicated code. And was poorly documented.


Specific capabilites.

The Strip archive
  - ability to surf when not logged in
  - navigation of threads
  - posting new comments (requires login)
  - reply to existing comment (requires login)
  - preview of new comment and reply (requires login)

Persistent preferences:
  - real email
  - list email
  - show moderated content
  - mailing list subscriptions:
  - IR
  - Newsletter
  - Surveys
  - PR

Registration
  - Easy signup
  - Signup takes you to page to set your preferences
  - Posting comments restricted until mailback completed

Users can have forgotten password reset in a secure manner
  - Feature: without being able to irrate random people, _and_
  - without having to store plaintext passwords in the DB
    (except very briefly, while a password is being changed.)

Users can change their password at any time, as long as they
  are logged in and know their current password

Admin: 
User management
  - disable users, with optional reason why

Comment management
  - (un)moderate comments
  - Post new article content
  - Approve/delete/expire article content
  - Edit existing articles . In V2.2. V2.1 does not have this implemented yet.

                                           perl/doc/VersionHistory                                                                             0100644 0000000 0000000 00000007607 07442555505 014243  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   $Id: VersionHistory,v 1.1 2002/03/10 04:04:21 jay Exp $
ARS 2.1 May 9

Added caching for the strip/news comments index view. Its REALLY needed.
Gives 10x speed improvements. 
By default the cache expires in 6 seconds.. approximate single thread reading time.


ARS 2.0												Sat Apr 28 21:19:17 PDT 2001

We ended up doing a near complete rewrite stemming from needing to refactor the problem

Some terminology:

Top level news items and such are called "Articles"

Postings and replies about a given article are called "Comments"

There are 4 main components:

	a. The sql db driver. UFSQL. Provides a consistent interface to the db. 
	   Any port to a non-mysql system has ONE gotcha in there, for insertion with ID readback.
	   Object oriented, with a single connection per webserver process.
	   
	b. The intelligent properties engine. UFIPE. Wraps usernames, authentication, preferences, 
	   mailing list subscriptions in an object.

	c. RequestHandler and the plugins in ARSHandler/*.pm
	   Surprisingly enough handles the requests and hands them off to appropriate handler
	   subroutines.
	   Takes the request and does sanity checks and enforces security, then builds the
	   state object used by all the handlers and other routines.
	
	d. Userfriendly.pm library. Contains the Article display code, the Comments threading code
	   the comments display code and the high level routines used by the request handlers. 

Main reason for this arrangement is there is now only one code path for a read of
a comment. Whether its for the strip, or the 8 other comment areas we currently have.

In ARS 1.x there were 8 or more nearly indentical Index.pm and Read.pm files.

Similarly, there are now only 5 template files, instead of nearly 40 in the
1.x variation.

Yohimbe


09/26/2000
Begin changes for adding in link of the day discussion

06/09/2000
Brendan W. McAdams (rit)
Modifications to stop storing plain text passwords in our database, 
and subsequent password recovery methods related to this.
From now on, if you lose your password we generate a new one and 
email it to you. Kind of like Zend.com (only other place i've seen this so far actually).

Questions can be mailed to the dev team.

- brendan

05/19/2000
Jay Thorne (Yohimbe)
New mods include login status on the main page, and some 
diddling with the perl to make things better faster stronger.
We're continuing to remove old functions that are no longer in use.

We are putting the source code out under the artistic license.
A copy is included here for your perusal.
All images and characters are (c) Copyright User Friendly Media Inc, 1997-2000

5/03/2000 
Jay Thorne (Yohimbe)

This code assumes an external source of news and cartoons to comment on.
The functions in ARS/bin/getxxxx.pl are run as cron jobs to fill
the databases with new postings.  

Overview of operation:
all the code in the /perl subdirectory is meant to run as mod_perl

/perl/httpd.conf includes the relevant sections to add to your webserver config

Note that it assumes you have a running apache with mod_perl.

Code was developed with perl 5.005_03 and Apache/1.3.12 (Unix)  (Red Hat/Linux) mod_perl/1.21

Also assumes a working mysql on the default port. the user, as set in Userfriendly.pm file
needs read/write privs to the uf database. Database creation scripts are in /perl/dbscript.mysql

4/19/2000
Mike Nugent (Wildcard`)

The Requirements file tells you everything you should need
in order to make this puppy go.  We assume you know you need
perl, apache, etc.

In addition grep for # Set me! in the files for variables
that we feel that you should probably take a look at
before you try to make this go.

Add you name and date when you make critical changes to the
code or make any changes to this file.

03/15/2000 TONS of mods, mod_perling by Jay Thorne (Yohimbe)
single db handle mods, move all subs into single .pm file

01/15/2000 Original Code by Paul Sullivan (sad|st) and Brendan W. McAdams (rit)
                                                                                                                         perl/doc/_Requirements.txt                                                                          0100644 0000000 0000000 00000000543 07442555505 014664  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   Require 5.000;
use DBI;
use Date::Manip;
use Apache::SIG ();
use Compress::Zlib;
use MIME::Base64;
use Crypt::Blowfish;
use POSIX;

In addition, a 56 byte (456 bit) key is needed.  We suggest a
cryptographically secure system such as ssh as a generator, but
it will take the first 56 bytes of any file.  Yes, grabbing some
from /dev/random will work too.
                                                                                                                                                             perl/doc/featurelist.txt                                                                            0100644 0000000 0000000 00000002632 07442555505 014372  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   * strip archive
  * needs nav bar fixup with pencils or some shit
  * greg says he's nearly done the hash config for these HTML snippets
- ability to surf when not logged in
- navigation of threads
- posting new comments (requires login)
- reply to existing comment (requires login)
- preview of new comment and reply (requires login)
- persistent preferences:
  - No need for visible email
  - No need for signature
  - real email
  - list email
  - show moderated content
  - mailing list subscriptions:
    - IR
    - Static Cling
    - Surveys
    - Spam
    - PR
  - No need for geek points at this time
* Registration
  * Secure mailback verification
  - Easy signup (notwithstanding mailback)
  - Signup takes you to page to diddle yorn settings
  * Posting comments restricted until mailback completed
  * Static Cling defaults to on?
- Users can have forgotten password reset in a secure manner
  - Feature: without being able to irrate random people, _and_
  - without having to store plaintext passwords in the DB
    (except very briefly, while a password is being changed.)
- Users can change their password at any time, as long as they
  are logged in and know their current password
- Admin: user management
  - disable users, with optional reason why
- Admin: comment management
  - (un)moderate comments
- Admin: post new article content
- Admin: approve/delete/expire article content
* Admin: Edit existing articles
                                                                                                      perl/httpd.conf                                                                                     0100644 0000000 0000000 00000000440 07614077072 012521  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   # $Id: httpd.conf,v 1.34 2003/01/23 23:43:54 cvsars Exp $

PerlSetEnv ARS_CONFIG /home/ars/perl/ars.conf
PerlFreshRestart On
PerlModule UFSQL
PerlModule UFIPE
PerlModule UserFriendly
PerlModule RequestHandler

<Location />
	SetHandler perl-script
	PerlHandler RequestHandler
</Location>

                                                                                                                                                                                                                                perl/httpd_members.conf                                                                             0100644 0000000 0000000 00000000445 07442556670 014245  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   # $Id: httpd_members.conf,v 2.1 2002/03/10 04:04:21 jay Exp $

PerlSetEnv ARS_CONFIG /home/ars/perl/mem.conf
PerlModule Apache::DBI
PerlModule UFSQL
PerlModule UFIPE
PerlModule UserFriendly
PerlModule MemberHandler

<Location />
	SetHandler perl-script
	PerlHandler MemberHandler
</Location>

                                                                                                                                                                                                                           perl/memberstartup.perl                                                                             0100755 0000000 0000000 00000001410 07442556670 014313  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   #! /usr/bin/perl
use strict;

# load up necessary perl function modules to be able to call from Perl-SSI
# files.  These objects are reloaded upon server restart (SIGHUP or SIGUSR1)
# if PerlFreshRestart is "On" in httpd.conf (as of mod_perl 1.03).
# only library-type routines should go in this directory.

use lib "/home/ars/perl";

# make sure we are in a sane environment.
$ENV{GATEWAY_INTERFACE} =~ /^CGI-Perl/ or die "GATEWAY_INTERFACE not Perl!";

use Apache::Registry ();       # for things in the "/programs" URL

# pull in things we will use in most requests so it is read and compiled
# exactly once

BEGIN { $ENV{ARS_CONFIG} = '/home/ars/perl/mem.conf' }

use ARSConfig;
use DBI ();
use DBD::mysql ();
use UserFriendly;
use UFIPE;
use UFSQL;
use MemberHandler;
1;
                                                                                                                                                                                                                                                        perl/startup.perl                                                                                   0100755 0000000 0000000 00000001507 07550371102 013113  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   #! /usr/bin/perl
use strict;

# load up necessary perl function modules to be able to call from Perl-SSI
# files.  These objects are reloaded upon server restart (SIGHUP or SIGUSR1)
# if PerlFreshRestart is "On" in httpd.conf (as of mod_perl 1.03).
# only library-type routines should go in this directory.

use lib "/home/ars/perl";

# make sure we are in a sane environment.
$ENV{GATEWAY_INTERFACE} =~ /^CGI-Perl/ or die "GATEWAY_INTERFACE not Perl!";

use Apache::Registry ();       # for things in the "/programs" URL

# pull in things we will use in most requests so it is read and compiled
# exactly once

BEGIN { $ENV{ARS_CONFIG} = '/home/ars/perl/ars.conf' }

use ARSConfig;
use DBI ();
#use Apache;
#@use Apache::DBI;
use DBD::mysql ();
DBI->install_driver("mysql");
use UserFriendly;
use UFIPE;
use UFSQL;
use RequestHandler;
1;
                                                                                                                                                                                         perl/template/                                                                                      0040755 0000000 0000000 00000000000 07611316746 012350  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   perl/template/choice.html                                                                           0100644 0000000 0000000 00000002005 07611316746 014462  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <TABLE BORDER="0">
		<TR><TD colspan=2>
<B>Payment Options for Sponsorships are:</B>
<DIR>
	<LI>PayPal
	<LI>Credit Card (Visa or Mastercard)
	<LI>Cheque
	<LI>Money Order
</DIR>
		</TD>
	</TR>
		<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>

<TR><TD colspan=2 VALIGN="left">
<UL><LI><B>Monthly or Yearly Membership</B><BR>
Cost: (USD) $3.95/mo. OR (USD) $36.00/yr. / (CAD) $58.00/yr.<BR>
No frills, value-priced membership entitles you to
<DIR>
	<LI>12 months of ad-free Userfriendly.org
</DIR>

<P>Monthly payment option:
<DIR>
	<LI>PayPal only
</DIR>
<BR>

<P>Yearly payment options:
<DIR>
	<LI>PayPal
	<LI>Credit Card
	<LI>Cheque
	<LI>Money order
</DIR>
<P>
<A HREF="users/sponsor9b57.html?sponsorlevel=Member"><IMG HSPACE="5" SRC="../www.userfriendly.org/images/siteart/mbrship_self.gif" ALT="Give me the Membership!" WIDTH="230" HEIGHT="45" BORDER="0" ALIGN="middle"></A>

<BR CLEAR="all">

</TD></TR>
		<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>


</TABLE>

</TD></TR>
</TABLE>

                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                           perl/template/agreement.html                                                                        0100644 0000000 0000000 00000025470 07463702521 015205  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <P>
<B>User Friendly Membership Agreement<BR> 						
Last modified December 10, 2001</B>
</P>

<P> This page contains our full Membership Agreement, covering our Charter
Membership Subscriptions. You may wish to print or bookmark this page for
reference. </P>

<P> This agreement (the "Agreement") sets forth the terms and conditions of our
agreement with you in respect of your use of the User Friendly website and the
services and features available to you as one of our subscribers (the
"Subscribers"). Your use of this site and services constitutes your agreement to
these terms and conditions. This Agreement is made between ourselves, UF Media
Inc. ("UFMI"), a for-profit company organized and existing under the laws of
British Columbia, Canada based at 1400 Ð 1055 West Hastings, Vancouver, British
Columbia V6E 2E9 Canada, and you as a Subscriber. </P>

<P> 1.	Your Rights </P>

<P> UFMI grants you, the Subscriber, a non-exclusive, non-transferable, limited
right to access, use and display the Membership portions of the UFMI website and
the materials provided therein for your personal, non-commercial use, only.  This
grant of rights is subject to your full compliance with the terms and conditions
of this Agreement and this grant of rights remains in effect only so long as you
are in full compliance with the terms and conditions of this Agreement. </P>

<P> 2.	Membership Services </P>

<P> This agreement constitutes you purchase of a Membership Subscription.
In this regard, you: </P>

<P> (a)	Hereby agree to purchase a Membership
Subscription to access the Members Port.  You may cancel at any time during that
subscription in which case UFMI will refund the remainder of your subscription on
a pro-rata basis that will cover the unused months of your subscription (partial
months will not be refunded), minus a $10 processing fee. </P>


<P> (b)	Hereby agree to pay the monthly, quarterly or annual subscription
charges set forth on the Site, applicable taxes, and other charges incurred on
your account in order to access the Membership Port. UFMI reserves the right to
increase fees, surcharges, and site subscription fees, or to institute new fees
at any time, upon 10 days notice posted in advance on this Site. You acknowledge
and agree that UFMI's third-party subscription service will automatically charge
your account for renewal of your Site subscription at the determined period,
until you cancel prior to such renewal having happened. </P>

<P> (c)	Agree, for the purposes of identification and subscription tracking,
to provide UFMI with accurate, complete, and updated information required by the
Site registration to the Membership Port ("Registration Data"), including your
name, e-mail address, state or province of residence (for tax purposes) and
applicable payment data (e.g., transaction information through the third-party
payment processor). </P>

<P> 3.	No-Commercialization </P>

<P> You agree to use the Members portion of the Site in a non-commercial manner
only. Additionally, you specifically agree not to post, transmit or otherwise
distribute to the Site any material containing any solicitation of funds,
advertising or solicitation for goods or services. </P>

<P> 4.	Copyright and Trademarks </P>

<P> All content on the Site, including, without limitation, text, images,
software, audio and video clips, databases, and Membership Port (collectively,
the "Content") are owned or controlled by UFMI, which retains all right, title,
and interest in and to the Content. The Site and Content are protected by the
copyright and trademark laws of Canada, the United States and other countries,
international conventions, and other applicable laws. You may not display,
reproduce, create derivative works from, transmit, sell, distribute, or in any
way exploit the Site or the Content or any portion thereof for any public or
commercial use without the prior written permission of UFMI. </P>

<P> 5.	Public Communications </P>

<P> You acknowledge and agree that any public communications made to or by means
of any portion of the Site are public. You acknowledge that you have no
expectation of privacy in any public communication and that no confidential,
fiduciary, contractually implied or other relationship is created between you and
UFMI by reason of your transmitting a public communication to any area of the
Site. </P>

<P> 6.	Privacy Policy </P>

<P> The terms and conditions of UFMI's privacy policy are set out in the section
labeled "Privacy Policy" on the Home Page of the Site and (as they may be changed
by UFMI in its sole discretion from time to time) are incorporated herein and
included in this Agreement. </P>

<P> 7.	Links to Other Sites </P>

<P> The Site contains links and pointers to other sites on the Internet, which
may be maintained by third parties. Such links do not constitute an endorsement
by UFMI or its affiliates of any third-party site or any materials contained
therein. UFMI and its affiliates do not control, and are not responsible for, the
availability, accuracy, privacy policy, or currency of such third-party sites or
any information, content, products or services accessible from such third-party
sites. </P>

<P> 8.	Ability to comply </P>

<P> You represent and warrant to UFMI that you are of right and ability to enter
into this Agreement and to use the Site in accordance with the terms and
conditions of this Agreement. </P>

<P> 9.	Financial responsibility </P>

<P> You agree not to assign, transfer or sublicense your rights as a subscriber
to the Membership Port. You agree to be financially responsible for all
usage or activity on your Membership account. </P>

<P> 10.	Indemnification </P>

<P> You hereby agree to indemnify, defend and hold harmless UFMI and its
affiliates from and against any and all liability and costs of any kind
whatsoever incurred by UFMI or the affiliates in connection with any claim
arising out of any breach or alleged breach of any of your obligations set forth
herein. </P>

<P> 11.	DISCLAIMER OF WARRANTY </P>

<P> EXCEPT AS EXPRESSLY SET FORTH HEREIN, THE SITE (INCLUDING ALL CONTENT,
SOFTWARE, FUNCTIONS, MEMBERSHIP SERVICES, MATERIALS AND INFORMATION MADE
AVAILABLE THEREON OR ACCESSED BY MEANS THEREOF) ARE PROVIDED ON AN "AS IS" BASIS,
WITHOUT WARRANTIES OF ANY KIND WHATSOEVER, EITHER EXPRESS OR IMPLIED, INCLUDING,
BUT NOT LIMITED TO, WARRANTIES OF TITLE OR IMPLIED WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, TITLE, COMPATIBILITY, SECURITY, ACCURACY, OR
NON-INFRINGEMENT. TO THE FULLEST EXTENT PERMISSIBLE BY LAW, UFMI AND THE
AFFILIATES MAKE NO WARRANTIES AND SHALL NOT BE LIABLE FOR THE USE OF THE SITE
UNDER ANY CIRCUMSTANCES, INCLUDING BUT NOT LIMITED TO NEGLIGENCE BY UFMI. UFMI
DOES NOT WARRANT THAT THE FUNCTIONS CONTAINED IN THE SITE OR THE MEMBERSHIP
SERVICES WILL BE UNINTERRUPTED OR ERROR-FREE, THAT DEFECTS WILL BE CORRECTED,
THAT THE SITE OR MEMBERSHIP SERVICES WILL MEET ANY PARTICULAR CRITERIA OF
PERFORMANCE OR QUALITY, OR THAT THE SITE, INCLUDING FORUMS OR THE SERVER (S) ON
WHICH THE SITE IS OPERATED, ARE FREE OF VIRUSES OR OTHER HARMFUL COMPONENTS. </P>

<P> 12.	LIMITATION OF LIABILITY </P>

<P> USE OF THE SITE AND THE MEMBERSHIP SERVICES AT YOUR OWN RISK. YOU ASSUME FULL
RESPONSIBILITY AND RISK OF LOSS RESULTING FROM YOUR DOWNLOADING AND/OR USE OF
FILES, INFORMATION, COMMUNICATIONS, CONTENT, OR OTHER MATERIAL (INCLUDING WITHOUT
LIMITATION SOFTWARE) ACCESSED THROUGH OR OBTAINED BY MEANS OF THE SITE OR THE
MEMBERSHIP SERVICES. UNDER NO CIRCUMSTANCES SHALL UFMI OR ITS AFFILIATES, OR ANY
PROVIDER OF TELECOMMUNICATIONS OR NETWORK SERVICES FOR UFMI OR ITS AFFILIATES BE
LIABLE FOR ANY DIRECT, INDIRECT, PUNITIVE, SPECIAL OR CONSEQUENTIAL DAMAGES THAT
ARE DIRECTLY OR INDIRECTLY RELATED TO THE USE OF, OR THE INABILITY TO USE, THE
SITE OR MEMBERSHIP SERVICES, EVEN IF UFMI, ITS AFFILIATES OR THEIR PROVIDERS OF
TELECOMMUNICATIONS OR NETWORK SERVICES HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES. THE TOTAL LIABILITY OF UFMI AND ITS AFFILIATES HEREUNDER IS LIMITED
TO THE AMOUNT, IF ANY, ACTUALLY PAID BY YOU FOR ACCESS AND USE OF THE MEMBERSHIP
SERVICES. YOU HEREBY RELEASE UFMI AND ITS AFFILIATES FROM ANY AND ALL
OBLIGATIONS, LIABILITIES AND CLAIMS IN EXCESS OF THIS LIMITATION. SOME STATES DO
NOT ALLOW THE EXCLUSION OR LIMITATION OF INCIDENTAL OR CONSEQUENTIAL DAMAGES, SO
THE ABOVE LIMITATION OR EXCLUSION MAY NOT APPLY TO YOU. </P>

<P> 13.	Termination </P>

<P> In addition to any other rights of the parties set forth herein, either you
or UFMI may cancel or terminate this Agreement at any time and for any reason as
provided for herein.  UFMI also reserves the right to restrict, suspend or
terminate your access to the Membership Port in whole or in part, without notice,
with respect to any breach or threatened breach by you of any portion of this
Agreement. If UFMI terminates this Agreement based on a breach of any portion of
this Agreement, UFMI reserves the right to refuse to provide a subscription or
any Membership to you in the future. </P>

<P> 14.	Modifications </P>

<P> (a)	UFMI has the right to modify this Agreement and any policies affecting
the Site in its sole discretion. Any modification is effective immediately upon
posting to the Site. Your continued use of the Site following notice of any
modification to this Agreement shall be conclusively deemed an acceptance of all
such modification(s). </P>

<P> (b)	UFMI has the right to modify, suspend or discontinue the Site or any
portion thereof at any time, including the availability of any area of the Site,
including, without limitation, the Membership Port. UFMI may also impose limits
on certain features and services or restrict your access to parts or all of the
UFMI Site without notice or liability. </P>

<P> 15.	General </P>

<P> This Agreement constitutes the entire agreement between you and UFMI with
respect to the Site and the Membership Port and supersedes all prior agreements
between you and UFMI. Failure by UFMI to enforce any provision of this agreement
shall not be construed as a waiver of any provision or right. Interpretation and
enforcement of this Agreement shall be governed by the laws of the Province of
British Columbia, Canada, and you hereby agree to attorn to the jurisdictions of
the Courts of British Columbia for that purpose. In any such action, the
prevailing party shall be entitled to recover all legal expenses incurred in
connection with the action, including but not limited to its costs, both taxable
and non-taxable, and attorney's fees on a solicitor client basis. In the event
that any portion of this Agreement is held unenforceable, the unenforceable
portion shall be construed in accordance with applicable law as nearly as
possible to reflect the original intentions of the parties, and the remainder of
the provisions shall remain in full force and effect. </P>

<P> Subscribing to the UFMI Membership Subscriber service indicates your
agreement to the terms and conditions set forth above. </P>

<P> I Agree || Cancel </P>
                                                                                                                                                                                                        perl/template/articles.html                                                                         0100644 0000000 0000000 00000002303 07553126630 015033  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
        "http://www.w3.org/TR/1999/REC-html401-19991224/loose.dtd">


<!-- Mirrored from ars.userfriendly.org/ars.tar.gz by HTTrack Website Copier/3.x [XR&CO'2014], Tue, 01 Mar 2022 03:38:10 GMT -->
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; CHARSET=iso-8859-1">
<META NAME="description" CONTENT="User Friendly the Comic Strip">
<META NAME="keywords" CONTENT="dust puppy, cartoon, comics, Columbia, Internet, strip, techies, crud puppy, illiad">
<META NAME="Author" CONTENT="Illiad">
<TITLE>New Article for #title#</TITLE>
<STYLE TYPE="text/css">
<!--
BODY,DIV,P,TD,B
{
font-family: "Verdana", "Helvetica", "Sans-Serif";
font-size: 12px;
}
-->
</STYLE>
</HEAD>
<BODY BGCOLOR="#ffffff">
<!--#include virtual="/header_ccs.html"-->
<TABLE BGCOLOR="#ffffff" WIDTH="100%" CELLSPACING="2" CELLPADDING="2" BORDER="0">
<TR> 
<TD width="120" VALIGN="top" ALIGN="left" bgcolor="#ffffcc"> 
</TD>
<!--#include virtual="/nav.html"-->
<!--#include virtual="/adside.html"-->
<TD width="*" VALIGN="top" ALIGN="left"> 
<TABLE BGCOLOR="#ffffff" WIDTH="100%" CELLSPACING="1" CELLPADDING="2" BORDER="0">
<TR><TD>
#uf_content#
#errors#
<BR>
<!--#include virtual="/admin_nav.html"-->
</td>
</tr>
</table>
</td>
</tr>
</table>

<!--#include virtual="/footer.html"-->
</center>
</BODY>

<!-- Mirrored from ars.userfriendly.org/ars.tar.gz by HTTrack Website Copier/3.x [XR&CO'2014], Tue, 01 Mar 2022 03:38:10 GMT -->
</HTML>
                                                                                                                                                                                                                                                                                                                             perl/template/comment.html                                                                          0100644 0000000 0000000 00000002763 07553126652 014705  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
        "http://www.w3.org/TR/1999/REC-html401-19991224/loose.dtd">
<HTML>
<HEAD>
	<META HTTP-EQUIV="Content-Type" CONTENT="text/html; CHARSET=iso-8859-1">
	<META NAME="description" CONTENT="User Friendly the Comic Strip">
	<META NAME="keywords" CONTENT="dust puppy, cartoon, comics, Columbia, Internet, strip, techies, crud puppy, illiad">
	<META NAME="Author" CONTENT="Illiad">

	<TITLE>#title#</TITLE>
<STYLE TYPE="text/css">
<!--
BODY,DIV,P,TD,B
{
font-family: "Verdana", "Helvetica", sans-serif;
font-size: 12px;
table {table-layout: fixed}


}
-->
</STYLE>
</HEAD>
<BODY BGCOLOR="#ffffff">
<!--#include virtual="/header_ccs.html"-->
<TABLE BGCOLOR="#ffffff" WIDTH="100%" CELLSPACING="2" CELLPADDING="2" BORDER="0">
<TR> 
<TD width="120" VALIGN="top" ALIGN="left" bgcolor="#ffffcc"> 
<!--#include virtual="/nav.html"-->
<!--#include virtual="/adside.html"-->
</TD>
<TD width="*" VALIGN="top" ALIGN="left"> 
<TABLE BGCOLOR="#ffffff" WIDTH="100%" CELLSPACING="1" CELLPADDING="2" BORDER="0">
<TR><TD bgcolor="white" align=center>
#uf_content#
#comment_mode_bar#
</TD>
</TR>
</TABLE>
<TABLE WIDTH="100%" BORDER="0" cellspacing="0" cellpadding="2" >
<TR>
<TD bgcolor="#ffffff" valign="top">
&nbsp;
#threads#
</td>
</tr>
<TR>
<TD bgcolor="#ffffff" valign="top">
<P>&nbsp;<P>
<a href="cartoons/index.html">[Todays Cartoon Discussion]</a>
<a href="news/index.html">[News Index]</a>
</td>
</tr>
</table>

</td>
</tr>
</table>

<!--#include virtual="/footer.html"-->
</BODY>
</HTML>
             perl/template/email.html                                                                            0100644 0000000 0000000 00000004247 07553126670 014331  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
        "http://www.w3.org/TR/1999/REC-html401-19991224/loose.dtd">
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; CHARSET=iso-8859-15">
<META NAME="description" CONTENT="User Friendly the Comic Strip">
<META NAME="keywords" CONTENT="dust puppy, cartoon, comics, Columbia, Internet, strip, techies, crud puppy, illiad">
<META NAME="Author" CONTENT="Illiad">
<TITLE>#title#</TITLE>
<STYLE TYPE="text/css">
<!--
BODY,DIV,P,TD,B
{
font-family: "Verdana", "Helvetica", sans-serif;
font-size: 12px;
}
-->
</STYLE>
</HEAD>
<BODY BGCOLOR="#ffffff">
<!--#include virtual="/header_ccs.html"-->
<TABLE BGCOLOR="#ffffff" WIDTH="100%" CELLSPACING="2" CELLPADDING="2" BORDER="0">
<TR> 
<TD width="120" VALIGN="top" ALIGN="left" bgcolor="#ffffcc"> 
<!--#include virtual="/nav.html"-->
<!--#include virtual="/adside.html"-->
</td>
<TD width="*" VALIGN="top" ALIGN="left"> 
<TABLE BGCOLOR="#ffffff" WIDTH="100%" CELLSPACING="1" CELLPADDING="2" BORDER="0">
<TR><TD bgcolor="white" align="center">
#uf_content#
</TD></TR>
<TR><TD bgcolor="white" align="center">
<TABLE BORDER="0" cellspacing="1" cellpadding="2" >
<FORM ACTION="http://www.userfriendly.org/cgi-bin/emailstrip.cgi" METHOD="post">
<INPUT TYPE="hidden" NAME="location" VALUE="http://www.userfriendly.org/cartoons/thanks.html">
<INPUT TYPE="hidden" NAME="source" VALUE="#id#">
<TR>
	<TD valign="top" colspan=2> Email this cartoon URL to a friend (separate multiple recipients with commas)</td>
</TR>
<TR>
	<TD ALIGN="left" VALIGN="top">Email To:</TD>
	<TD ALIGN="left" VALIGN="top"><INPUT TYPE="text" NAME="rcpt" SIZE="30" MAXLENGTH="80"></TD>
</TR>
<TR>
	<TD ALIGN="left" VALIGN="top">Email From:</TD>
	<TD ALIGN="left" VALIGN="top"><INPUT TYPE="text" NAME="from" SIZE="30" MAXLENGTH="80"></TD>
</TR>
<TR>
	<TD ALIGN="left" VALIGN="top">Message:</TD>
	<TD ALIGN="left" VALIGN="top"><INPUT TYPE="text" NAME="msg" SIZE="30" MAXLENGTH="100">
</TR>
<TR>
	<TD ALIGN="center" colspan=2  VALIGN="top"><input type="Submit" name="Send" value="Send"><input type="Reset"></TD>
</TR>
</FORM>
</TABLE>

</TD>
</TR>
</TABLE>

</TD>
</TR>
</TABLE>
<!--#include virtual="/footer.html"-->
</BODY>
</HTML>
                                                                                                                                                                                                                                                                                                                                                         perl/template/generic.html                                                                          0100644 0000000 0000000 00000002227 07553126703 014647  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
        "http://www.w3.org/TR/1999/REC-html401-19991224/loose.dtd">
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; CHARSET=iso-8859-15">
<META NAME="description" CONTENT="User Friendly the Comic Strip">
<META NAME="keywords" CONTENT="dust puppy, cartoon, comics, Columbia, Internet, strip, techies, crud puppy, illiad">
<META NAME="Author" CONTENT="Illiad">
<TITLE>#title#</TITLE>
</HEAD>
<STYLE TYPE="text/css">
<!--
BODY,DIV,P,TD,B
{
font-family: "Verdana", "Helvetica", sans-serif;
font-size: 12px;
}
-->
</STYLE>
<BODY BGCOLOR="#ffffff">
<!--#include virtual="/header_ccs.html"-->
<TABLE BGCOLOR="#ffffff" WIDTH="100%" CELLSPACING="2" CELLPADDING="2" BORDER="0">
<TR> 
<TD width="120" VALIGN="top" ALIGN="left" bgcolor="#ffffcc"> 
<!--#include virtual="/nav.html"-->
<!--#include virtual="/adside.html"-->
</TD>
<TD width="*" VALIGN="top" ALIGN="left"> 
<TABLE BGCOLOR="#ffffff" WIDTH="100%" CELLSPACING="1" CELLPADDING="2" BORDER="0">
<TR><TD bgcolor="white">
#errors#
#uf_content#
</TD>
</TR>
</TABLE>
</td>
</tr>
</table>
</table>
<!--#include virtual="/footer.html"-->
</BODY>
</HTML>
                                                                                                                                                                                                                                                                                                                                                                         perl/template/newmem.html                                                                           0100644 0000000 0000000 00000025457 07442555646 014546  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <P><B>User Friendly Membership Agreement</B></P>
<P>Last modified February 20, 2002</P>

</P>
<P>This page contains our full Membership
Agreement, covering our Membership Subscriptions. You may wish to
print or bookmark this page for reference.</P>

</P>
<P>This agreement (the &quot;Agreement&quot;)
sets forth the terms and conditions of our agreement with you in
respect of your use of the User Friendly website and the services and
features available to you as one of our subscribers (the
&quot;Subscribers&quot;). Your use of this site and services
constitutes your agreement to these terms and conditions. This
Agreement is made between ourselves, UF Media Inc. (&quot;UFMI&quot;),
a for-profit company organized and existing under the laws of British
Columbia, Canada based at 1400 - 1055 West Hastings, Vancouver,
British Columbia V6E 2E9 Canada, and you as a Subscriber.</P>

</P>
<P><B>1.	Your Rights</B></P>

</P>
<P>UFMI grants you, the Subscriber, a
non-exclusive, non-transferable, limited right to access, use and
display the Membership portions of the UFMI website and the materials
provided therein for your personal, non-commercial use, only.  This
grant of rights is subject to your full compliance with the terms and
conditions of this Agreement and this grant of rights remains in
effect only so long as you are in full compliance with the terms and
conditions of this Agreement.  
</P>

</P>
<P><B>2.	Membership Services</B></P>

</P>
<P>This agreement constitutes you purchase
of a Membership Subscription. 
</P>
<P>In this regard, you:</P>

</P>
<OL>
	<LI>hereby agree to purchase a
	Membership Subscription to access the Members Port 
	<LI>hereby agree to pay the
	(non-refundable) monthly or annual subscription charges set forth on
	the Site and any applicable taxes, in order to access the Membership
	Port. UFMI reserves the right to increase fees, surcharges, and site
	subscription fees, or to institute new fees at any time, upon 10
	days notice posted in advance on this Site. You acknowledge and
	agree that UFMI's third-party subscription service will
	automatically charge your account for renewal of your Site
	subscription at the determined period, until you cancel prior to
	such renewal having happened. 
	<LI>hereby agree, for the purposes of identification and subscription
tracking, to provide UFMI with accurate, complete, and updated
information required by the Site registration to the Membership  Port
(&quot;Registration Data&quot;), including your name, e-mail address,
state or province of residence (for tax purposes) and applicable
payment data (e.g., transaction information through any third-party
payment processor).</P>
</OL>
</P>
<P><B>3.	No-Commercialization </B>
</P>

</P>
<P>You agree to use the Members portion of
the<U> </U>Site in a non-commercial manner only. Additionally, you
specifically agree not to post, transmit or otherwise distribute to
the Site any material containing any solicitation of funds,
advertising or solicitation for goods or services.</P>

</P>
<P><B>4.	Copyright and Trademarks</B></P>

</P>
<P>All content on the Site, including,
without limitation, text, images, software, audio and video clips,
databases, and Membership Port (collectively, the &quot;Content&quot;)
are owned or controlled by UFMI, which retains all right, title, and
interest in and to the Content. The Site and Content are protected by
the copyright and trademark laws of Canada, the United States and
other countries, international conventions, and other applicable
laws. You may not display, reproduce, create derivative works from,
transmit, sell, distribute, or in any way exploit the Site or the
Content or any portion thereof for any public or commercial use
without the prior written permission of UFMI.</P>

</P>
<P><B>5.	Public Communications</B></P>

</P>
<P>You acknowledge and agree that any
public communications made to or by means of any portion of the Site
are public. You acknowledge that you have no expectation of privacy
in any public communication and that no confidential, fiduciary,
contractually implied or other relationship is created between you
and UFMI by reason of your transmitting a public communication to any
area of the Site.</P>

</P>
<P><B>6.	Privacy Policy</B></P>

</P>
<P>The terms and conditions of UFMI's
privacy policy are set out in the section labeled &quot;Privacy
Policy&quot; on the Home Page of the Site and (as they may be changed
by UFMI in its sole discretion from time to time) are incorporated
herein and included in this Agreement.</P>

</P>
<P><B>7.	Links to Other Sites</B></P>

</P>
<P>The Site contains links and pointers to
other sites on the Internet, which may be maintained by third
parties. Such links do not constitute an endorsement by UFMI or its
affiliates of any third-party site or any materials contained
therein. UFMI and its affiliates do not control, and are not
responsible for, the availability, accuracy, privacy policy, or
currency of such third-party sites or any information, content,
products or services accessible from such third-party sites.</P>

</P>
<P><B>8.	Ability to comply</B></P>

</P>
<P>You represent and warrant to UFMI that
you are of right and ability to enter into this Agreement and to use
the Site in accordance with the terms and conditions of this
Agreement.</P>

</P>
<P><B>9.	Financial responsibility</B></P>

</P>
<P>You agree not to assign, transfer or
sublicense your rights as a subscriber to the Membership Port. You
agree to be financially responsible for all usage or activity on your
Membership account.</P>

</P>
<P><B>10.	Indemnification</B></P>

</P>
<P>You hereby agree to indemnify, defend
and hold harmless UFMI and its affiliates from and against any and
all liability and costs of any kind whatsoever incurred by UFMI or
the affiliates in connection with any claim arising out of any breach
or alleged breach of any of your obligations set forth herein.</P>

</P>
<P><B>11.	DISCLAIMER OF WARRANTY</B></P>

</P>
<P>EXCEPT AS EXPRESSLY SET FORTH HEREIN,
THE SITE (INCLUDING ALL CONTENT, SOFTWARE, FUNCTIONS, MEMBERSHIP
SERVICES, MATERIALS AND INFORMATION MADE AVAILABLE THEREON OR
ACCESSED BY MEANS THEREOF) ARE PROVIDED ON AN &quot;AS IS&quot;
BASIS, WITHOUT WARRANTIES OF ANY KIND WHATSOEVER, EITHER EXPRESS OR
IMPLIED, INCLUDING, BUT NOT LIMITED TO, WARRANTIES OF TITLE OR
IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
PURPOSE, TITLE, COMPATIBILITY, SECURITY, ACCURACY, OR
NON-INFRINGEMENT. TO THE FULLEST EXTENT PERMISSIBLE BY LAW, UFMI AND
THE AFFILIATES MAKE NO WARRANTIES AND SHALL NOT BE LIABLE FOR THE USE
OF THE SITE UNDER ANY CIRCUMSTANCES, INCLUDING BUT NOT LIMITED TO
NEGLIGENCE BY UFMI. UFMI DOES NOT WARRANT THAT THE FUNCTIONS
CONTAINED IN THE SITE OR THE MEMBERSHIP SERVICES WILL BE
UNINTERRUPTED OR ERROR-FREE, THAT DEFECTS WILL BE CORRECTED, THAT THE
SITE OR MEMBERSHIP SERVICES WILL MEET ANY PARTICULAR CRITERIA OF
PERFORMANCE OR QUALITY, OR THAT THE SITE, INCLUDING FORUMS OR THE
SERVER(S) ON WHICH THE SITE IS OPERATED, ARE FREE OF VIRUSES OR OTHER
HARMFUL COMPONENTS.</P>

</P>
<P><B>12.	LIMITATION OF LIABILITY</B></P>

</P>
<P>USE OF THE SITE AND THE MEMBERSHIP
SERVICES AT YOUR OWN RISK. YOU ASSUME FULL RESPONSIBILITY AND RISK OF
LOSS RESULTING FROM YOUR DOWNLOADING AND/OR USE OF FILES,
INFORMATION, COMMUNICATIONS, CONTENT, OR OTHER MATERIAL (INCLUDING
WITHOUT LIMITATION SOFTWARE) ACCESSED THROUGH OR OBTAINED BY MEANS OF
THE SITE OR THE MEMBERSHIP SERVICES. UNDER NO CIRCUMSTANCES SHALL
UFMI OR ITS AFFILIATES, OR ANY PROVIDER OF TELECOMMUNICATIONS OR
NETWORK SERVICES FOR UFMI OR ITS AFFILIATES BE LIABLE FOR ANY DIRECT,
INDIRECT, PUNITIVE, SPECIAL OR CONSEQUENTIAL DAMAGES THAT ARE
DIRECTLY OR INDIRECTLY RELATED TO THE USE OF, OR THE INABILITY TO
USE, THE SITE OR MEMBERSHIP SERVICES, EVEN IF UFMI, ITS AFFILIATES OR
THEIR PROVIDERS OF TELECOMMUNICATIONS OR NETWORK SERVICES HAS BEEN
ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. THE TOTAL LIABILITY OF
UFMI AND ITS AFFILIATES HEREUNDER IS LIMITED TO THE AMOUNT, IF ANY,
ACTUALLY PAID BY YOU FOR ACCESS AND USE OF THE MEMBERSHIP SERVICES.
YOU HEREBY RELEASE UFMI AND ITS AFFILIATES FROM ANY AND ALL
OBLIGATIONS, LIABILITIES AND CLAIMS IN EXCESS OF THIS LIMITATION.
SOME STATES DO NOT ALLOW THE EXCLUSION OR LIMITATION OF INCIDENTAL OR
CONSEQUENTIAL DAMAGES, SO THE ABOVE LIMITATION OR EXCLUSION MAY NOT
APPLY TO YOU.</P>

</P>
<P><B>13.	Termination</B></P>

</P>
<P>In addition to any other rights of the
parties set forth herein, either you or UFMI may cancel or terminate
this Agreement at any time and for any reason as provided for herein.
 UFMI also reserves the right to restrict, suspend or terminate your
access to the Membership Port in whole or in part, without notice,
with respect to any breach or threatened breach by you of any portion
of this Agreement. If UFMI terminates this Agreement based on a
breach of any portion of this Agreement, UFMI reserves the right to
refuse to provide a subscription or any Membership to you in the
future.</P>

</P>
<P><B>14.	Modifications</B></P>

</P>
<P>(a)	UFMI has the right to modify this
Agreement and any policies affecting the Site in its sole discretion.
Any modification is effective immediately upon posting to the Site.
Your continued use of the Site following notice of any modification
to this Agreement shall be conclusively deemed an acceptance of all
such modification(s).</P>

</P>
<P>(b)	UFMI has the right to modify,
suspend or discontinue the Site or any portion thereof at any time,
including the availability of any area of the Site, including,
without limitation, the Membership Port. UFMI may also impose limits
on certain features and services or restrict your access to parts or
all of the UFMI Site without notice or liability.</P>

</P>
<P><B>15.	General</B></P>

</P>
<P>This Agreement constitutes the entire
agreement between you and UFMI with respect to the Site and the
Membership Port and supersedes all prior agreements between you and
UFMI. Failure by UFMI to enforce any provision of this agreement
shall not be construed as a waiver of any provision or right.
Interpretation and enforcement of this Agreement shall be governed by
the laws of the Province of British Columbia, Canada, and you hereby
agree to attorn to the jurisdictions of the Courts of British
Columbia for that purpose. In any such action, the prevailing party
shall be entitled to recover all legal expenses incurred in
connection with the action, including but not limited to its costs,
both taxable and non-taxable, and attorney's fees on a solicitor
client basis. In the event that any portion of this Agreement is held
unenforceable, the unenforceable portion shall be construed in
accordance with applicable law as nearly as possible to reflect the
original intentions of the parties, and the remainder of the
provisions shall remain in full force and effect.</P>

</P>
<P>Subscribing to the UFMI Membership
Subscriber service indicates your agreement to the terms and
conditions set forth above.</P>
</BODY>
</HTML>
                                                                                                                                                                                                                 perl/template/post.html                                                                             0100644 0000000 0000000 00000003561 07553126721 014222  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
        "http://www.w3.org/TR/1999/REC-html401-19991224/loose.dtd">
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; CHARSET=iso-8859-15">
<META NAME="description" CONTENT="User Friendly the Comic Strip">
<META NAME="keywords" CONTENT="dust puppy, cartoon, comics, Columbia, Internet, strip, techies, crud puppy, illiad">
<META NAME="Author" CONTENT="Illiad">
<TITLE>New Comment:#title#</TITLE>
<STYLE TYPE="text/css">
<!--
BODY,DIV,P,TD,B
{
font-family: "Verdana", "Helvetica", sans-serif;
font-size: 12px;
}
-->
</STYLE>
</HEAD>
<BODY BGCOLOR="#ffffff">
<!--#include virtual="/header_ccs.html"-->
<TABLE BGCOLOR="#ffffff" WIDTH="100%" CELLSPACING="2" CELLPADDING="2" BORDER="0">
<TR> 
<TD width="120" VALIGN="top" ALIGN="left" bgcolor="#ffffcc"> 
<!--#include virtual="/nav.html"-->
<!--#include virtual="/adside.html"-->
</TD>
<TD width="*" VALIGN="top" ALIGN="left"> 
<TABLE BGCOLOR="#ffffff" WIDTH="100%" CELLSPACING="1" CELLPADDING="2" BORDER="0">
<TR><TD align="center">
</td>
</tr>
</TABLE>
<TABLE WIDTH="100%" BORDER="0" cellspacing="1" cellpadding="2" >
<TR>
<TD valign="top" colspan=3 align=left>
#article#
#errors#
</TD></TR></TABLE>
<TABLE><TR><TD>
<form method="post" action="http://ars.userfriendly.org/#path#/postn.cgi">
<input type="hidden" name="id" value="#id#">   
<input type="hidden" name="tid" value="#tid#">   
</td>
</tr>
<TR>
<TD valign="top" colspan=3>
<p><br></p>
<HR>
<b>Post New Comment</b></font> 
</td></tr>
<tr> 
<td valign="top">Subject</td>
<td><input type="text" name="subject" value="#subject#" size=30 maxlength="50">
</td>
</tr>
<tr> 
<td valign="top">Comments</td>
<td><textarea name="message" cols="65" rows="9" wrap="virtual">#message#</textarea>
<BR>
#buttons#
</td>
</tr>
<tr><td>&nbsp;</td><td>#instructions#</td></tr>
</table>
</td>
</tr>
</table>
<!--#include virtual="/footer.html"-->
</center>
</BODY>
</HTML>
                                                                                                                                               perl/template/redirect.html                                                                         0100644 0000000 0000000 00000000246 07463343765 015044  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <HTML>
<HEAD>

<META name="resource-type" content="document"> 

<META HTTP-EQUIV="refresh" CONTENT="0; URL=#url#">

<TITLE></TITLE>

</HEAD>

<BODY>

</BODY>
</HTML>
                                                                                                                                                                                                                                                                                                                                                          perl/template/registration_blurb.html                                                               0100644 0000000 0000000 00000004214 07550101567 017127  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <H3>New User Info</H3>









<H3>Membership Help</H3>
<B>If you are here because you want a <BIG>UF Membership</BIG> Subscription (ad-free UF, no merchandise), you need
to either Log In to your existing UF account or create a new UF
Comments system account in order to continue the subscription process. </B>

<H3>UF Comment System Info</H3>
<P>Thanks for joining the UF Comment System!  This is your chance to
get involved with the UF community and to interact with fellow UFies and UF
staffers by commenting (and replying to comments about) cartoons, news items, you
name it!  Here's some basic information.


<P><b>Why should I register?</b>  The UF Comments system is free! Ever wanted to
make your thoughts known about a new cartoon or UF News item?  That's what the
Comments system is for.  If you're not registered, you can't comment. Also, the
account is required for subscribers to the paid Membership service.</P>

<P><B>What happens after I register?</B> Upon registration you are immediately
logged in to our Comment system. We use a very secure cookie for authentication. It is
encrypted and tagged so that no one can re-use it to impersonate you. 
We <u><i>do</i></u> use a preferences cookie in order to store your 
choices, but this contains absolutely no personal information.</P>

<P><b>What information do I have to give you?</b> We need a valid email address, your
selected nickname and a password.  Choose your nick carefully! Not only does it
identify you to the Community at large, it is also used to:

<LI>identifies your postings in the Comments system (UFies stand and deliver, no anonymous coward posts allowed) 
<LI>Once you choose your nick, it cannot be changed so choose wisely!</P>

<P><B>Are you going to sell my information?</b> No.  We know how important
privacy is to geeks since we're geeks too!  Your info will be kept private and
not sold to anyone.  See our <a
href="../www.userfriendly.org/privacypolicy/index.html">privacy policy</a> for details.

<P><B>Who owns the copyright on this stuff anyway?</b> All posts are copyright
their owners.  Everything else is copyright User Friendly.  The posts are
<i>yours</i> and yours alone.

</FONT>

<p></P>
                                                                                                                                                                                                                                                                                                                                                                                    perl/template/sponsor.html                                                                          0100644 0000000 0000000 00000000332 07550440114 014721  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <P>
<B>Purchase of a UF Sponsorship indicates your agreement to the terms and conditions set forth in the <a href="../www.userfriendly.org/UFSponsorshipAgreement.pdf">UF Membership/Sponsorship Agreement</a>.
</B>

                                                                                                                                                                                                                                                                                                      perl/template/sponsorshiphelp.html                                                                  0100644 0000000 0000000 00000000474 07550101567 016473  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <H3>Sponsorship Help</H3>

Our system has detected that you are either not logged in or do not already have a UF account. 
<BR>
You MUST have an account and be logged in before you can continue the Sponsorship process.

<BR>
<B> You can start an account from here, or log in if you have an existing account</b>
<BR>
                                                                                                                                                                                                    perl/template/choiceold.html                                                                        0100644 0000000 0000000 00000012743 07560427356 015176  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <TABLE BORDER="0">
		<TR><TD colspan=2>
<B>Payment Options for Sponsorships are:</B>
<DIR>
	<LI>PayPal
	<LI>Credit Card (Visa or Mastercard)
	<LI>Cheque
	<LI>Money Order
</DIR>
		</TD>
	</TR>
		<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>

	<TR>
		<TD VALIGN=TOP>
<A HREF="../www.userfriendly.org/images/siteart/art_minion.jpg"><IMG ALIGN="TOP" SRC="../www.userfriendly.org/images/siteart/art_minion.gif" ALT="Minion" WIDTH="100" HEIGHT="100" BORDER="0" HSPACE="6"></A>
<BR CLEAR="all">click thumbnail to<BR>view large image		</TD>
		<TD valign="left">
<UL><LI><B>Tier 1 Sponsorship: Minion</B><BR>
Cost: (USD) $45.00 / (CAD) $72.00<BR>
Entitles you to
<DIR>
	<LI>12 months of ad-free Userfriendly.org
	<LI>a "UserFriendly.org Minion 2002" T-shirt 
</DIR>
Shipping extra:
<DIR>
	<LI>in US - (USD) $6 USD/ (CAD) $10 
	<LI>to Canada - (USD) $14 / (CAD) $21
	<LI>International - (USD) $18 / (CAD) $30
</DIR>
<P>
<A HREF="users/sponsor7dbe.html?sponsorlevel=Minion"><IMG HSPACE="5" SRC="../www.userfriendly.org/images/siteart/minion_self.gif" ALT="Make me a Minion!" WIDTH="230" HEIGHT="45" BORDER="0" ALIGN="middle"></A>

<BR CLEAR="all">
		</TD>
	</TR>
		<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>
	<TR>
		<TD VALIGN=TOP>
<A HREF="../www.userfriendly.org/images/siteart/art_egit.jpg"><IMG SRC="../www.userfriendly.org/images/siteart/art_egit.gif" ALT="Evil Genius in Training" HSPACE="6" WIDTH="100" HEIGHT="100" BORDER="0" ALIGN="TOP"></A>
<BR CLEAR="all">click thumbnail to<BR>view large image		</TD>
		<TD valign="left">
<UL><LI><B>Tier 2 Sponsorship: Evil Genius-in-Training</B><BR>
Cost: (USD) $99.00 / (CAD) $159.00<BR>
Entitles you to 
<DIR>
	<LI>12 months of ad-free Userfriendly.org
	<LI>a "UserFriendly.org Evil Genius-in-Training 2002" T-shirt
	<LI>a plush Dust Puppy doll
	<LI>an "Evil Genius-in-Training 2002" Coffee Mug
</DIR>
Shipping extra:
<DIR>
	<LI>in US - (USD) $6 USD/ (CAD) $10 
	<LI>to Canada - (USD) $14 / (CAD) $21
	<LI>International - (USD) $18 / (CAD) $30
</DIR>

<P>
<A HREF="users/sponsorda9f.html?sponsorlevel=Evil+Genius+in+Training"><IMG HSPACE="5" SRC="../www.userfriendly.org/images/siteart/egit_self.gif" ALT="Make me an Evil Genius-in-Training!" WIDTH="230" HEIGHT="45" BORDER="0" ALIGN="middle"></A>

<BR CLEAR="all">
		</TD>
	</TR>
		<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>
	
	<TR>
			<TD VALIGN=TOP>
<A HREF="../www.userfriendly.org/images/siteart/art_eg.jpg"><IMG SRC="../www.userfriendly.org/images/siteart/art_eg.gif" ALT="Evil Genius" HSPACE="6" WIDTH="100" HEIGHT="100" BORDER="0" ALIGN="top"></A>
<BR CLEAR="all">click thumbnail to<BR>view large image		</TD>
		<TD valign="left">
<UL><LI><B>Tier 3 Sponsorship: Evil Genius</B><BR>
Cost: (USD) $250.00 / (CAD) $399.00<BR>
Entitles you to
<DIR>
	<LI>12 months of ad-free Userfriendly.org
	<LI>a "UserFriendly.org Evil Genius 2002" T-shirt
	<LI>a plush Dust Puppy doll
	<LI>an "Evil Genius 2002" Coffee Mug
	<LI>an "Evil Genius 2002" Diploma, suitable for framing
	<LI>a $25 UF Store Gift Certificate
</DIR>
Shipping extra:
<DIR>
	<LI>in US - (USD) $6 USD/ (CAD) $10 
	<LI>to Canada - (USD) $14 / (CAD) $21
	<LI>International - (USD) $18 / (CAD) $30
</DIR>

<P>
<A HREF="users/sponsorc5dd.html?sponsorlevel=Evil+Genius"><IMG HSPACE="5" SRC="../www.userfriendly.org/images/siteart/evilgenius_self.gif" ALT="Make me an Evil Genius!" WIDTH="230" HEIGHT="45" BORDER="0" ALIGN="middle"></A>

<BR CLEAR="all">
		</TD>
	</TR>
			<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>
	<TR>
			<TD VALIGN=TOP>
<A HREF="../www.userfriendly.org/images/siteart/art_dr.jpg"><IMG SRC="../www.userfriendly.org/images/siteart/art_dr.gif" ALT="Dark Regent" HSPACE="6" WIDTH="100" HEIGHT="100" BORDER="0" ALIGN="top"></A>
<BR CLEAR="all">click thumbnail to<BR>view large image		</TD>
		<TD valign="left">
<UL><LI><B>Tier 4 Sponsorship: Dark Regent</B><BR>
Cost: (USD) $1000.00 / (CAD) $1599.00<BR>
Entitles you to
<DIR>
	<LI>12 months of ad-free Userfriendly.org
	<LI>a "UserFriendly.org Dark Regent 2002" T-shirt
	<LI>a plush Dust Puppy doll
	<LI>a "Dark Regent 2002" Coffee Mug
	<LI>a "Dark Regent 2002" Diploma, suitable for framing
	<LI>Set of 4 User Friendly books signed by Illiad
	<LI>a $50 UF Store Gift Certificate
	<LI>a signed Limited Edition Print
</DIR>
Shipping extra:
<DIR>
	<LI>in US - (USD) $6 USD/ (CAD) $10 
	<LI>to Canada - (USD) $14 / (CAD) $21
	<LI>International - (USD) $18 / (CAD) $30
</DIR>
<P>
<A HREF="users/sponsorbdc2.html?sponsorlevel=Dark+Regent"><IMG HSPACE="5" SRC="../www.userfriendly.org/images/siteart/darkregent_self.gif" ALT="Make me a Dark Regent!" WIDTH="230" HEIGHT="45" BORDER="0" ALIGN="middle"></A>

<BR CLEAR="all">
		</TD>
	</TR>
			<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>
<TR><TD colspan=2 VALIGN="left">
<UL><LI><B>Monthly or Yearly Membership</B><BR>
Cost: (USD) $3.95/mo. OR (USD) $36.00/yr. / (CAD) $58.00/yr.<BR>
No frills, value-priced membership entitles you to
<DIR>
	<LI>12 months of ad-free Userfriendly.org
</DIR>

<P>Monthly payment option:
<DIR>
	<LI>PayPal only
</DIR>
<BR>

<P>Yearly payment options:
<DIR>
	<LI>PayPal
	<LI>Credit Card
	<LI>Cheque
	<LI>Money order
</DIR>
<P>
<A HREF="users/sponsor9b57.html?sponsorlevel=Member"><IMG HSPACE="5" SRC="../www.userfriendly.org/images/siteart/mbrship_self.gif" ALT="Give me the Membership!" WIDTH="230" HEIGHT="45" BORDER="0" ALIGN="middle"></A>

<BR CLEAR="all">

</TD></TR>
		<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>


</TABLE>

</TD></TR>
</TABLE>

                             perl/template/choice.short.html                                                                     0100644 0000000 0000000 00000002005 07560427466 015625  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <TABLE BORDER="0">
		<TR><TD colspan=2>
<B>Payment Options for Sponsorships are:</B>
<DIR>
	<LI>PayPal
	<LI>Credit Card (Visa or Mastercard)
	<LI>Cheque
	<LI>Money Order
</DIR>
		</TD>
	</TR>
		<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>

<TR><TD colspan=2 VALIGN="left">
<UL><LI><B>Monthly or Yearly Membership</B><BR>
Cost: (USD) $3.95/mo. OR (USD) $36.00/yr. / (CAD) $58.00/yr.<BR>
No frills, value-priced membership entitles you to
<DIR>
	<LI>12 months of ad-free Userfriendly.org
</DIR>

<P>Monthly payment option:
<DIR>
	<LI>PayPal only
</DIR>
<BR>

<P>Yearly payment options:
<DIR>
	<LI>PayPal
	<LI>Credit Card
	<LI>Cheque
	<LI>Money order
</DIR>
<P>
<A HREF="users/sponsor9b57.html?sponsorlevel=Member"><IMG HSPACE="5" SRC="../www.userfriendly.org/images/siteart/mbrship_self.gif" ALT="Give me the Membership!" WIDTH="230" HEIGHT="45" BORDER="0" ALIGN="middle"></A>

<BR CLEAR="all">

</TD></TR>
		<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>


</TABLE>

</TD></TR>
</TABLE>

                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                           perl/template/choice.long.html                                                                      0100644 0000000 0000000 00000012743 07600017745 015425  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   <TABLE BORDER="0">
		<TR><TD colspan=2>
<B>Payment Options for Sponsorships are:</B>
<DIR>
	<LI>PayPal
	<LI>Credit Card (Visa or Mastercard)
	<LI>Cheque
	<LI>Money Order
</DIR>
		</TD>
	</TR>
		<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>

	<TR>
		<TD VALIGN=TOP>
<A HREF="../www.userfriendly.org/images/siteart/art_minion.jpg"><IMG ALIGN="TOP" SRC="../www.userfriendly.org/images/siteart/art_minion.gif" ALT="Minion" WIDTH="100" HEIGHT="100" BORDER="0" HSPACE="6"></A>
<BR CLEAR="all">click thumbnail to<BR>view large image		</TD>
		<TD valign="left">
<UL><LI><B>Tier 1 Sponsorship: Minion</B><BR>
Cost: (USD) $45.00 / (CAD) $72.00<BR>
Entitles you to
<DIR>
	<LI>12 months of ad-free Userfriendly.org
	<LI>a "UserFriendly.org Minion 2002" T-shirt 
</DIR>
Shipping extra:
<DIR>
	<LI>in US - (USD) $6 USD/ (CAD) $10 
	<LI>to Canada - (USD) $14 / (CAD) $21
	<LI>International - (USD) $18 / (CAD) $30
</DIR>
<P>
<A HREF="users/sponsor7dbe.html?sponsorlevel=Minion"><IMG HSPACE="5" SRC="../www.userfriendly.org/images/siteart/minion_self.gif" ALT="Make me a Minion!" WIDTH="230" HEIGHT="45" BORDER="0" ALIGN="middle"></A>

<BR CLEAR="all">
		</TD>
	</TR>
		<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>
	<TR>
		<TD VALIGN=TOP>
<A HREF="../www.userfriendly.org/images/siteart/art_egit.jpg"><IMG SRC="../www.userfriendly.org/images/siteart/art_egit.gif" ALT="Evil Genius in Training" HSPACE="6" WIDTH="100" HEIGHT="100" BORDER="0" ALIGN="TOP"></A>
<BR CLEAR="all">click thumbnail to<BR>view large image		</TD>
		<TD valign="left">
<UL><LI><B>Tier 2 Sponsorship: Evil Genius-in-Training</B><BR>
Cost: (USD) $99.00 / (CAD) $159.00<BR>
Entitles you to 
<DIR>
	<LI>12 months of ad-free Userfriendly.org
	<LI>a "UserFriendly.org Evil Genius-in-Training 2002" T-shirt
	<LI>a plush Dust Puppy doll
	<LI>an "Evil Genius-in-Training 2002" Coffee Mug
</DIR>
Shipping extra:
<DIR>
	<LI>in US - (USD) $6 USD/ (CAD) $10 
	<LI>to Canada - (USD) $14 / (CAD) $21
	<LI>International - (USD) $18 / (CAD) $30
</DIR>

<P>
<A HREF="users/sponsorda9f.html?sponsorlevel=Evil+Genius+in+Training"><IMG HSPACE="5" SRC="../www.userfriendly.org/images/siteart/egit_self.gif" ALT="Make me an Evil Genius-in-Training!" WIDTH="230" HEIGHT="45" BORDER="0" ALIGN="middle"></A>

<BR CLEAR="all">
		</TD>
	</TR>
		<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>
	
	<TR>
			<TD VALIGN=TOP>
<A HREF="../www.userfriendly.org/images/siteart/art_eg.jpg"><IMG SRC="../www.userfriendly.org/images/siteart/art_eg.gif" ALT="Evil Genius" HSPACE="6" WIDTH="100" HEIGHT="100" BORDER="0" ALIGN="top"></A>
<BR CLEAR="all">click thumbnail to<BR>view large image		</TD>
		<TD valign="left">
<UL><LI><B>Tier 3 Sponsorship: Evil Genius</B><BR>
Cost: (USD) $250.00 / (CAD) $399.00<BR>
Entitles you to
<DIR>
	<LI>12 months of ad-free Userfriendly.org
	<LI>a "UserFriendly.org Evil Genius 2002" T-shirt
	<LI>a plush Dust Puppy doll
	<LI>an "Evil Genius 2002" Coffee Mug
	<LI>an "Evil Genius 2002" Diploma, suitable for framing
	<LI>a $25 UF Store Gift Certificate
</DIR>
Shipping extra:
<DIR>
	<LI>in US - (USD) $6 USD/ (CAD) $10 
	<LI>to Canada - (USD) $14 / (CAD) $21
	<LI>International - (USD) $18 / (CAD) $30
</DIR>

<P>
<A HREF="users/sponsorc5dd.html?sponsorlevel=Evil+Genius"><IMG HSPACE="5" SRC="../www.userfriendly.org/images/siteart/evilgenius_self.gif" ALT="Make me an Evil Genius!" WIDTH="230" HEIGHT="45" BORDER="0" ALIGN="middle"></A>

<BR CLEAR="all">
		</TD>
	</TR>
			<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>
	<TR>
			<TD VALIGN=TOP>
<A HREF="../www.userfriendly.org/images/siteart/art_dr.jpg"><IMG SRC="../www.userfriendly.org/images/siteart/art_dr.gif" ALT="Dark Regent" HSPACE="6" WIDTH="100" HEIGHT="100" BORDER="0" ALIGN="top"></A>
<BR CLEAR="all">click thumbnail to<BR>view large image		</TD>
		<TD valign="left">
<UL><LI><B>Tier 4 Sponsorship: Dark Regent</B><BR>
Cost: (USD) $1000.00 / (CAD) $1599.00<BR>
Entitles you to
<DIR>
	<LI>12 months of ad-free Userfriendly.org
	<LI>a "UserFriendly.org Dark Regent 2002" T-shirt
	<LI>a plush Dust Puppy doll
	<LI>a "Dark Regent 2002" Coffee Mug
	<LI>a "Dark Regent 2002" Diploma, suitable for framing
	<LI>Set of 4 User Friendly books signed by Illiad
	<LI>a $50 UF Store Gift Certificate
	<LI>a signed Limited Edition Print
</DIR>
Shipping extra:
<DIR>
	<LI>in US - (USD) $6 USD/ (CAD) $10 
	<LI>to Canada - (USD) $14 / (CAD) $21
	<LI>International - (USD) $18 / (CAD) $30
</DIR>
<P>
<A HREF="users/sponsorbdc2.html?sponsorlevel=Dark+Regent"><IMG HSPACE="5" SRC="../www.userfriendly.org/images/siteart/darkregent_self.gif" ALT="Make me a Dark Regent!" WIDTH="230" HEIGHT="45" BORDER="0" ALIGN="middle"></A>

<BR CLEAR="all">
		</TD>
	</TR>
			<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>
<TR><TD colspan=2 VALIGN="left">
<UL><LI><B>Monthly or Yearly Membership</B><BR>
Cost: (USD) $3.95/mo. OR (USD) $36.00/yr. / (CAD) $58.00/yr.<BR>
No frills, value-priced membership entitles you to
<DIR>
	<LI>12 months of ad-free Userfriendly.org
</DIR>

<P>Monthly payment option:
<DIR>
	<LI>PayPal only
</DIR>
<BR>

<P>Yearly payment options:
<DIR>
	<LI>PayPal
	<LI>Credit Card
	<LI>Cheque
	<LI>Money order
</DIR>
<P>
<A HREF="users/sponsor9b57.html?sponsorlevel=Member"><IMG HSPACE="5" SRC="../www.userfriendly.org/images/siteart/mbrship_self.gif" ALT="Give me the Membership!" WIDTH="230" HEIGHT="45" BORDER="0" ALIGN="middle"></A>

<BR CLEAR="all">

</TD></TR>
		<TR>
		<TD colspan=2>
		<HR ALIGN="center" NOSHADE>
		</TD>
	</TR>


</TABLE>

</TD></TR>
</TABLE>

                             scripts/CacheOneFile/                                                                               0040755 0000000 0000000 00000000000 07442770510 013522  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/lib/                                                                           0040755 0000000 0000000 00000000000 07442770455 014300  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/lib/UFMEDIA/                                                                   0040755 0000000 0000000 00000000000 07571306752 015350  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/lib/UFMEDIA/CacheOneFile.pm                                                    0100755 0000000 0000000 00000007650 07216274676 020170  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ;# $Id: CacheOneFile.pm,v 1.1 2000/12/15 01:54:06 lyonsm Exp $

package UFMEDIA::CacheOneFile;
use strict;
use vars qw($VERSION);

$VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker

# System includes
use Carp;
use FileHandle;
use Fatal qw(close link unlink rename stat); # cuts down "or die" noise


#############################################################################
#
#  Methods
#
#############################################################################


# Usage: 
#    $cache = new UFMEDIA::CacheOneFile(
#        cache_file => '/var/cache/myapp/flurg.cache',
#        max_age    => 30,
#        refill_sub => sub { recalculate_flurges(31337, 'blue', 42) },
#    );
sub new
{
	my $that  = shift;
	my $class = ref($that) || $that;
	my $self  = {
		@_,
	};

	croak "must specify cache_file"   unless $self->{cache_file};
	croak "must specify max_age"      unless $self->{max_age} > 0;
	croak "must specify refill_sub"   unless ref($self->{refill_sub});

	bless $self, $class;
}


# Builds and installs an up-to-date cache file.  Returns new data.
#
sub _refill_file
{
	my $self    = shift;
	my $refill  = $self->{refill_sub};
	my $file    = $self->{cache_file};
	my $oldfile = "$file.old.$$";
	my $newfile = "$file.new.$$";
	my $newfh = new FileHandle(">$newfile")
			or croak "unable to write $newfile: $!";

	# Let's get some up-to-date data
	my $data = &$refill;

	$newfh->print($data) or die "writing $newfile: write: $!\n";
	$newfh->close;

	# install the new file
	link($file, $oldfile) if -e $file;
	rename($newfile, $file);
	unlink($oldfile)      if -e $oldfile;

	$data;
}


#
# Returns a value from the cache file, updating the cache if it's too old.
#
sub get_value
{
	my $self = shift;
	my $file    = $self->{cache_file};
	my $max_age = $self->{max_age};

	my $fh = new FileHandle("<$file") or return $self->_refill_file;

	my ($nlink, $mtime) = ($fh->stat)[3,9];
	my $age = time - $mtime;

	local $/;
	return scalar <$fh> unless $age > $max_age;

	# File exists and is out-of-date.  Obtain an update lock.
	flock($fh, 2);

	# If nlink went down while we were waiting for the lock, it means the
	# file was too old, but someone else fixed it while we were waiting
	my $new_nlink = ($fh->stat)[3];
	if(!$new_nlink || $new_nlink < $nlink) {
		# (XXX If someone else deleted the file, they violated the contract.
		#      But we'll be a good sport about it and just recreate the file.)
		$fh = new FileHandle("<$file") or return $self->_refill_file;
		return scalar <$fh>;
	}

	# We're holding the lock, and nobody else has fixed the out-of-date file
	# yet, so it must be our responsibility.  Do so now.
	$self->_refill_file;
}


#############################################################################

1;
__END__

=pod

=head1 NAME

UFMEDIA::CacheOneFile - cache a scalar value in a file on disk

=head1 SYNOPSIS

 use UFMEDIA::CacheOneFile;

 my $cache = new UFMEDIA::CacheOneFile(
     cache_file => '/var/cache/myapp/flurge.cache',
     max_age    => 30,
     refill_sub => sub { recalculate_flurges(31337, 'blue', 42) },
 );

 my $value = $cache->get_value;

=head1 DESCRIPTION

UFMEDIA::CacheOneFile enables you to cache a single scalar value in a file
on disk.  Given a filename under a writable directory, a maximum age, and
a reference to a refill subroutine, a cache object will cache the result
of the refill subroutine in the file the first time B<get_value()> is called,
and use the cached value for subsequent calls to B<get_value()> until B<max_age> the cache file is more than B<max_age> seconds old.

If multiple processes share a single cache file, the first process that 
reads the cache file after it has expired will take responsibility for
replacing it with an up-to-date copy.  Other processes needing up-to-date
information will wait for this to finish and will then use the new value.

=head1 AUTHOR

Mike Lyons <lyonsm@userfriendly.org>

=head1 SEE ALSO

perl(1).

=cut


                                                                                        scripts/CacheOneFile/t/                                                                             0040755 0000000 0000000 00000000000 07442770456 013776  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/t/10CacheOneFile.t                                                             0100755 0000000 0000000 00000005323 07216474016 016564  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ;# $Id: 10CacheOneFile.t,v 1.2 2000/12/15 19:59:10 lyonsm Exp $

require 5.005;
use strict;
use vars qw($numtest $curtest $loaded $failreason);
BEGIN { $^W=1 }

BEGIN {
	unless(grep {/blib/} @INC) {
		# Probably being run manually.  Help perl find the modules.
		unshift(@INC, '../lib');
		unshift(@INC, 'lib');
	}
}

package main;

# some useful subs
sub PLAN   { $numtest=shift; $|=1; print "1..$numtest\n"; $curtest = 1;}
sub SSTR   { local $_=shift; $_ ? (chomp,s/\n(?!#)/\n# /g,$_)[2] : '' }
sub DPRINT { print "# ", SSTR($_[0]), "\n" }
sub OK     { 
	my $comment = shift;
	$comment=$comment ? " # (".SSTR($comment).")" : '';
	print "ok $curtest$comment\n"; 
	$curtest++ 
}
sub NOT_OK { 
	my $why = shift;
	DPRINT("NOT OK $curtest: $why") if $why;
	print "not ok $curtest\n"; 
	$curtest++;
}
sub SKIP { 
	my $why=shift; 
	if ($why) {
		$why = SSTR($why);
		print "ok $curtest # Skipped: $why\n"; 
	} else {
		print "ok $curtest # Skip\n";
	}
	$curtest++;
}
sub BADSKIP {
	my $why=shift;
	if ($why) {
		$why = SSTR($why);
		print "not ok $curtest # Skipped: $why\n";
	} else {
		print "not ok $curtest # Skip\n";
	}
	$curtest++;
}
sub ABORT {
	my $whyabort = shift;
	my $whyskip  = shift;
	NOT_OK("FATAL: $whyabort") if $whyabort;
	BADSKIP($whyskip) until $curtest > $numtest;
	exit(0);
}


#1	Module loaded and compiled properly
BEGIN {
	$loaded=0;
	$failreason='';
	eval { require UFMEDIA::CacheOneFile; $loaded=1 };
	$failreason  =$@ if $@;
	eval { import  UFMEDIA::CacheOneFile };
	$failreason||=$@ if $@;
}
$loaded
	? OK
	: ABORT($failreason,"(module failed to compile)");


#2	Constructor
my $test_file = "./__testfile.${$}__";
my $test_data = "aaaaaaa";
my $orig_test_data = $test_data;
END { unlink $test_file }
unlink $test_file;
my $cache;
eval {
  $cache = new UFMEDIA::CacheOneFile(
	cache_file => $test_file,
	max_age    => 3,
	refill_sub => sub { $test_data++ },
  );
};
!$@ && $cache
	? OK
	: ABORT($@ || "constructor failed", "(couldn't instantiate test object)");


#3	Initial read works OK
$cache->get_value eq $orig_test_data
	? OK
	: NOT_OK("new value didn't match up");


#4	Second read fills from cache
$cache->get_value eq $orig_test_data
	? OK
	: NOT_OK("cache expired too soon");


#5	Cache expiry
sleep(4);
$cache->get_value eq ++$orig_test_data
	? OK
	: NOT_OK("cache failed to expire");


#	Concurrency tests: look for kill and fork
my $cankill = 0;
my $canfork = 0;
eval { kill 0,$$ };
unless($@) {
	$cankill=1;
	eval { fork ? die "parent\n" : die "child\n" };
	kill(9,$$) if $@ =~ /^child/;
	$canfork=1 if $@ =~ /^parent/;
}

#6	Concurrent update
if($canfork) {
	SKIP("XXX Write concurrency tests!");
} else {
	SKIP("(need to be able to fork)");
}


END { SKIP('(ran out of tests to run)') until $curtest > $numtest; }
BEGIN { PLAN 6 }

                                                                                                                                                                                                                                                                                                             scripts/CacheOneFile/MANIFEST                                                                       0100644 0000000 0000000 00000000115 07216274676 014660  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   MANIFEST
MANIFEST.SKIP
README
lib/UFMEDIA/CacheOneFile.pm
t/10CacheOneFile.t
                                                                                                                                                                                                                                                                                                                                                                                                                                                   scripts/CacheOneFile/MANIFEST.SKIP                                                                  0100644 0000000 0000000 00000000137 07216274676 015431  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   bak$
^blib
Makefile
^pm_to_blib$
import_.*
export_.*
.*\.sw[a-z]$
\.tar\.gz$
\bCVS/
CVS
\.swp$
                                                                                                                                                                                                                                                                                                                                                                                                                                 scripts/CacheOneFile/Makefile.PL                                                                    0100644 0000000 0000000 00000001127 07216274676 015505  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ;# $Id: Makefile.PL,v 1.1 2000/12/15 01:54:06 lyonsm Exp $

use ExtUtils::MakeMaker;

WriteMakefile(
	NAME => 'UFMEDIA::CacheOneFile',
	VERSION_FROM => 'lib/UFMEDIA/CacheOneFile.pm',
	ABSTRACT_FROM => 'lib/UFMEDIA/CacheOneFile.pm',
	AUTHOR => 'Mike Lyons <lyonsm@userfriendly.org>',
);

# Alter default libscan behaviour.  By default, _all_ files found under
# ./lib are installed.  I'm sick of it installing my vim .swp files,
# so here we provide a libscan that ignores them.
sub MY::libscan {
  package MY;
  my($self,$path) = @_;
  return '' if $path =~ m:\b(\.swp|RCS|CVS|SCCS)\b: ;
  $path;
}
                                                                                                                                                                                                                                                                                                                                                                                                                                         scripts/CacheOneFile/README                                                                         0100644 0000000 0000000 00000001264 07216274676 014415  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   $Id: README,v 1.1 2000/12/15 01:54:06 lyonsm Exp $

                       UFMEDIA::CacheOneFile perl module

What is it?
-----------
UFMEDIA::CacheOneFile enables you to cache a single scalar value in a file
on disk.  Given a filename under a writable directory, a maximum age, and
a reference to a (presumably expensive) subroutine which returns an
up-to-date value, this module will cache the result of the subroutine in
the given file until the file reaches the maximum age.  It is safe to
share the cache file among multiple processes.

Installation
------------
perl Makefile.PL && make test && make install

After installation, see the UFMEDIA::CacheOneFile man page for instructions.
                                                                                                                                                                                                                                                                                                                                            scripts/CacheOneFile/blib/                                                                          0040755 0000000 0000000 00000000000 07442770500 014431  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/lib/                                                                      0040755 0000000 0000000 00000000000 07442770500 015177  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/lib/UFMEDIA/                                                              0040755 0000000 0000000 00000000000 07442770501 016252  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/lib/UFMEDIA/.exists                                                       0100644 0000000 0000000 00000000000 07442762405 017561  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/lib/UFMEDIA/CacheOneFile.pm                                               0100555 0000000 0000000 00000007650 07216274676 021076  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ;# $Id: CacheOneFile.pm,v 1.1 2000/12/15 01:54:06 lyonsm Exp $

package UFMEDIA::CacheOneFile;
use strict;
use vars qw($VERSION);

$VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker

# System includes
use Carp;
use FileHandle;
use Fatal qw(close link unlink rename stat); # cuts down "or die" noise


#############################################################################
#
#  Methods
#
#############################################################################


# Usage: 
#    $cache = new UFMEDIA::CacheOneFile(
#        cache_file => '/var/cache/myapp/flurg.cache',
#        max_age    => 30,
#        refill_sub => sub { recalculate_flurges(31337, 'blue', 42) },
#    );
sub new
{
	my $that  = shift;
	my $class = ref($that) || $that;
	my $self  = {
		@_,
	};

	croak "must specify cache_file"   unless $self->{cache_file};
	croak "must specify max_age"      unless $self->{max_age} > 0;
	croak "must specify refill_sub"   unless ref($self->{refill_sub});

	bless $self, $class;
}


# Builds and installs an up-to-date cache file.  Returns new data.
#
sub _refill_file
{
	my $self    = shift;
	my $refill  = $self->{refill_sub};
	my $file    = $self->{cache_file};
	my $oldfile = "$file.old.$$";
	my $newfile = "$file.new.$$";
	my $newfh = new FileHandle(">$newfile")
			or croak "unable to write $newfile: $!";

	# Let's get some up-to-date data
	my $data = &$refill;

	$newfh->print($data) or die "writing $newfile: write: $!\n";
	$newfh->close;

	# install the new file
	link($file, $oldfile) if -e $file;
	rename($newfile, $file);
	unlink($oldfile)      if -e $oldfile;

	$data;
}


#
# Returns a value from the cache file, updating the cache if it's too old.
#
sub get_value
{
	my $self = shift;
	my $file    = $self->{cache_file};
	my $max_age = $self->{max_age};

	my $fh = new FileHandle("<$file") or return $self->_refill_file;

	my ($nlink, $mtime) = ($fh->stat)[3,9];
	my $age = time - $mtime;

	local $/;
	return scalar <$fh> unless $age > $max_age;

	# File exists and is out-of-date.  Obtain an update lock.
	flock($fh, 2);

	# If nlink went down while we were waiting for the lock, it means the
	# file was too old, but someone else fixed it while we were waiting
	my $new_nlink = ($fh->stat)[3];
	if(!$new_nlink || $new_nlink < $nlink) {
		# (XXX If someone else deleted the file, they violated the contract.
		#      But we'll be a good sport about it and just recreate the file.)
		$fh = new FileHandle("<$file") or return $self->_refill_file;
		return scalar <$fh>;
	}

	# We're holding the lock, and nobody else has fixed the out-of-date file
	# yet, so it must be our responsibility.  Do so now.
	$self->_refill_file;
}


#############################################################################

1;
__END__

=pod

=head1 NAME

UFMEDIA::CacheOneFile - cache a scalar value in a file on disk

=head1 SYNOPSIS

 use UFMEDIA::CacheOneFile;

 my $cache = new UFMEDIA::CacheOneFile(
     cache_file => '/var/cache/myapp/flurge.cache',
     max_age    => 30,
     refill_sub => sub { recalculate_flurges(31337, 'blue', 42) },
 );

 my $value = $cache->get_value;

=head1 DESCRIPTION

UFMEDIA::CacheOneFile enables you to cache a single scalar value in a file
on disk.  Given a filename under a writable directory, a maximum age, and
a reference to a refill subroutine, a cache object will cache the result
of the refill subroutine in the file the first time B<get_value()> is called,
and use the cached value for subsequent calls to B<get_value()> until B<max_age> the cache file is more than B<max_age> seconds old.

If multiple processes share a single cache file, the first process that 
reads the cache file after it has expired will take responsibility for
replacing it with an up-to-date copy.  Other processes needing up-to-date
information will wait for this to finish and will then use the new value.

=head1 AUTHOR

Mike Lyons <lyonsm@userfriendly.org>

=head1 SEE ALSO

perl(1).

=cut


                                                                                        scripts/CacheOneFile/blib/lib/auto/                                                                 0040755 0000000 0000000 00000000000 07442770500 016147  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/lib/auto/UFMEDIA/                                                         0040755 0000000 0000000 00000000000 07442770500 017221  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/lib/auto/UFMEDIA/CacheOneFile/                                            0040755 0000000 0000000 00000000000 07442770500 021466  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/lib/auto/UFMEDIA/CacheOneFile/.exists                                     0100644 0000000 0000000 00000000000 07442762405 022776  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/arch/                                                                     0040755 0000000 0000000 00000000000 07442770500 015346  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/arch/auto/                                                                0040755 0000000 0000000 00000000000 07442770500 016316  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/arch/auto/UFMEDIA/                                                        0040755 0000000 0000000 00000000000 07442770500 017370  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/arch/auto/UFMEDIA/CacheOneFile/                                           0040755 0000000 0000000 00000000000 07442770500 021635  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/arch/auto/UFMEDIA/CacheOneFile/.exists                                    0100644 0000000 0000000 00000000000 07442762405 023145  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/man3/                                                                     0040755 0000000 0000000 00000000000 07442770501 015270  5                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/man3/.exists                                                              0100644 0000000 0000000 00000000000 07442762405 016577  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   scripts/CacheOneFile/blib/man3/UFMEDIA::CacheOneFile.3pm                                            0100644 0000000 0000000 00000012167 07442770501 021341  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   .\" Automatically generated by Pod::Man version 1.15
.\" Sun Mar 10 15:50:25 2002
.\"
.\" Standard preamble:
.\" ======================================================================
.de Sh \" Subsection heading
.br
.if t .Sp
.ne 5
.PP
\fB\\$1\fR
.PP
..
.de Sp \" Vertical space (when we can't use .PP)
.if t .sp .5v
.if n .sp
..
.de Ip \" List item
.br
.ie \\n(.$>=3 .ne \\$3
.el .ne 3
.IP "\\$1" \\$2
..
.de Vb \" Begin verbatim text
.ft CW
.nf
.ne \\$1
..
.de Ve \" End verbatim text
.ft R

.fi
..
.\" Set up some character translations and predefined strings.  \*(-- will
.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left
.\" double quote, and \*(R" will give a right double quote.  | will give a
.\" real vertical bar.  \*(C+ will give a nicer C++.  Capital omega is used
.\" to do unbreakable dashes and therefore won't be available.  \*(C` and
.\" \*(C' expand to `' in nroff, nothing in troff, for use with C<>
.tr \(*W-|\(bv\*(Tr
.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
.ie n \{\
.    ds -- \(*W-
.    ds PI pi
.    if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
.    if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\"  diablo 12 pitch
.    ds L" ""
.    ds R" ""
.    ds C` ""
.    ds C' ""
'br\}
.el\{\
.    ds -- \|\(em\|
.    ds PI \(*p
.    ds L" ``
.    ds R" ''
'br\}
.\"
.\" If the F register is turned on, we'll generate index entries on stderr
.\" for titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and
.\" index entries marked with X<> in POD.  Of course, you'll have to process
.\" the output yourself in some meaningful fashion.
.if \nF \{\
.    de IX
.    tm Index:\\$1\t\\n%\t"\\$2"
..
.    nr % 0
.    rr F
.\}
.\"
.\" For nroff, turn off justification.  Always turn off hyphenation; it
.\" makes way too many mistakes in technical documents.
.hy 0
.if n .na
.\"
.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2).
.\" Fear.  Run.  Save yourself.  No user-serviceable parts.
.bd B 3
.    \" fudge factors for nroff and troff
.if n \{\
.    ds #H 0
.    ds #V .8m
.    ds #F .3m
.    ds #[ \f1
.    ds #] \fP
.\}
.if t \{\
.    ds #H ((1u-(\\\\n(.fu%2u))*.13m)
.    ds #V .6m
.    ds #F 0
.    ds #[ \&
.    ds #] \&
.\}
.    \" simple accents for nroff and troff
.if n \{\
.    ds ' \&
.    ds ` \&
.    ds ^ \&
.    ds , \&
.    ds ~ ~
.    ds /
.\}
.if t \{\
.    ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
.    ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
.    ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
.    ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
.    ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
.    ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
.\}
.    \" troff and (daisy-wheel) nroff accents
.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
.ds 8 \h'\*(#H'\(*b\h'-\*(#H'
.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
.ds ae a\h'-(\w'a'u*4/10)'e
.ds Ae A\h'-(\w'A'u*4/10)'E
.    \" corrections for vroff
.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
.    \" for low resolution devices (crt and lpr)
.if \n(.H>23 .if \n(.V>19 \
\{\
.    ds : e
.    ds 8 ss
.    ds o a
.    ds d- d\h'-1'\(ga
.    ds D- D\h'-1'\(hy
.    ds th \o'bp'
.    ds Th \o'LP'
.    ds ae ae
.    ds Ae AE
.\}
.rm #[ #] #H #V #F C
.\" ======================================================================
.\"
.IX Title "UFMEDIA::CacheOneFile 3"
.TH UFMEDIA::CacheOneFile 3 "perl v5.6.1" "2000-12-14" "User Contributed Perl Documentation"
.UC
.SH "NAME"
\&\s-1UFMEDIA:\s0:CacheOneFile \- cache a scalar value in a file on disk
.SH "SYNOPSIS"
.IX Header "SYNOPSIS"
.Vb 1
\& use UFMEDIA::CacheOneFile;
.Ve
.Vb 5
\& my $cache = new UFMEDIA::CacheOneFile(
\&     cache_file => '/var/cache/myapp/flurge.cache',
\&     max_age    => 30,
\&     refill_sub => sub { recalculate_flurges(31337, 'blue', 42) },
\& );
.Ve
.Vb 1
\& my $value = $cache->get_value;
.Ve
.SH "DESCRIPTION"
.IX Header "DESCRIPTION"
\&\s-1UFMEDIA:\s0:CacheOneFile enables you to cache a single scalar value in a file
on disk.  Given a filename under a writable directory, a maximum age, and
a reference to a refill subroutine, a cache object will cache the result
of the refill subroutine in the file the first time \fB\f(BIget_value()\fB\fR is called,
and use the cached value for subsequent calls to \fB\f(BIget_value()\fB\fR until \fBmax_age\fR the cache file is more than \fBmax_age\fR seconds old.
.PP
If multiple processes share a single cache file, the first process that 
reads the cache file after it has expired will take responsibility for
replacing it with an up-to-date copy.  Other processes needing up-to-date
information will wait for this to finish and will then use the new value.
.SH "AUTHOR"
.IX Header "AUTHOR"
Mike Lyons <lyonsm@userfriendly.org>
.SH "SEE ALSO"
.IX Header "SEE ALSO"
\&\fIperl\fR\|(1).
                                                                                                                                                                                                                                                                                                                                                                                                         scripts/CacheOneFile/Makefile                                                                       0100644 0000000 0000000 00000044061 07442770476 015177  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   # This Makefile is for the UFMEDIA::CacheOneFile extension to perl.
#
# It was generated automatically by MakeMaker version
# 5.45 (Revision: 1.222) from the contents of
# Makefile.PL. Don't edit this file, edit Makefile.PL instead.
#
#	ANY CHANGES MADE HERE WILL BE LOST!
#
#   MakeMaker ARGV: ()
#
#   MakeMaker Parameters:

#	ABSTRACT_FROM => q[lib/UFMEDIA/CacheOneFile.pm]
#	AUTHOR => q[Mike Lyons <lyonsm@userfriendly.org>]
#	NAME => q[UFMEDIA::CacheOneFile]
#	VERSION_FROM => q[lib/UFMEDIA/CacheOneFile.pm]

# --- MakeMaker post_initialize section:


# --- MakeMaker const_config section:

# These definitions are from config.sh (via /usr/lib/perl5/5.6.1/i586-linux/Config.pm)

# They may have been overridden via Makefile.PL or on the command line
AR = ar
CC = cc
CCCDLFLAGS = -fpic
CCDLFLAGS = -rdynamic
DLEXT = so
DLSRC = dl_dlopen.xs
LD = cc
LDDLFLAGS = -shared -L/usr/local/lib
LDFLAGS =  -L/usr/local/lib
LIBC = 
LIB_EXT = .a
OBJ_EXT = .o
OSNAME = linux
OSVERS = 2.2.16
RANLIB = :
SO = so
EXE_EXT = 
FULL_AR = /usr/bin/ar


# --- MakeMaker constants section:
AR_STATIC_ARGS = cr
NAME = UFMEDIA::CacheOneFile
DISTNAME = UFMEDIA-CacheOneFile
NAME_SYM = UFMEDIA_CacheOneFile
VERSION = 1.01
VERSION_SYM = 1_01
XS_VERSION = 1.01
INST_BIN = blib/bin
INST_EXE = blib/script
INST_LIB = blib/lib
INST_ARCHLIB = blib/arch
INST_SCRIPT = blib/script
PREFIX = /usr
INSTALLDIRS = site
INSTALLPRIVLIB = $(PREFIX)/lib/perl5/5.6.1
INSTALLARCHLIB = $(PREFIX)/lib/perl5/5.6.1/i586-linux
INSTALLSITELIB = $(PREFIX)/lib/perl5/site_perl/5.6.1
INSTALLSITEARCH = $(PREFIX)/lib/perl5/site_perl/5.6.1/i586-linux
INSTALLBIN = $(PREFIX)/bin
INSTALLSCRIPT = $(PREFIX)/bin
PERL_LIB = /usr/lib/perl5/5.6.1
PERL_ARCHLIB = /usr/lib/perl5/5.6.1/i586-linux
SITELIBEXP = /usr/lib/perl5/site_perl/5.6.1
SITEARCHEXP = /usr/lib/perl5/site_perl/5.6.1/i586-linux
LIBPERL_A = libperl.a
FIRST_MAKEFILE = Makefile
MAKE_APERL_FILE = Makefile.aperl
PERLMAINCC = $(CC)
PERL_INC = /usr/lib/perl5/5.6.1/i586-linux/CORE
PERL = /usr/bin/perl
FULLPERL = /usr/bin/perl
FULL_AR = /usr/bin/ar

VERSION_MACRO = VERSION
DEFINE_VERSION = -D$(VERSION_MACRO)=\"$(VERSION)\"
XS_VERSION_MACRO = XS_VERSION
XS_DEFINE_VERSION = -D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\"
PERL_MALLOC_DEF = -DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc -Dfree=Perl_mfree -Drealloc=Perl_realloc -Dcalloc=Perl_calloc

MAKEMAKER = /usr/lib/perl5/5.6.1/ExtUtils/MakeMaker.pm
MM_VERSION = 5.45

# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle).
# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle)
# ROOTEXT = Directory part of FULLEXT with leading slash (eg /DBD)  !!! Deprecated from MM 5.32  !!!
# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar)
# DLBASE  = Basename part of dynamic library. May be just equal BASEEXT.
FULLEXT = UFMEDIA/CacheOneFile
BASEEXT = CacheOneFile
PARENT_NAME = UFMEDIA
DLBASE = $(BASEEXT)
VERSION_FROM = lib/UFMEDIA/CacheOneFile.pm
OBJECT = 
LDFROM = $(OBJECT)
LINKTYPE = dynamic

# Handy lists of source code files:
XS_FILES= 
C_FILES = 
O_FILES = 
H_FILES = 
HTMLLIBPODS    = 
HTMLSCRIPTPODS = 
MAN1PODS = 
MAN3PODS = lib/UFMEDIA/CacheOneFile.pm
HTMLEXT = html
INST_MAN1DIR = blib/man1
INSTALLMAN1DIR = $(PREFIX)/share/man/man1
MAN1EXT = 1
INST_MAN3DIR = blib/man3
INSTALLMAN3DIR = $(PREFIX)/share/man/man3
MAN3EXT = 3pm
PERM_RW = 644
PERM_RWX = 755

# work around a famous dec-osf make(1) feature(?):
makemakerdflt: all

.SUFFIXES: .xs .c .C .cpp .cxx .cc $(OBJ_EXT)

# Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that
# some make implementations will delete the Makefile when we rebuild it. Because
# we call false(1) when we rebuild it. So make(1) is not completely wrong when it
# does so. Our milage may vary.
# .PRECIOUS: Makefile    # seems to be not necessary anymore

.PHONY: all config static dynamic test linkext manifest

# Where is the Config information that we are using/depend on
CONFIGDEP = $(PERL_ARCHLIB)/Config.pm $(PERL_INC)/config.h

# Where to put things:
INST_LIBDIR      = $(INST_LIB)/UFMEDIA
INST_ARCHLIBDIR  = $(INST_ARCHLIB)/UFMEDIA

INST_AUTODIR     = $(INST_LIB)/auto/$(FULLEXT)
INST_ARCHAUTODIR = $(INST_ARCHLIB)/auto/$(FULLEXT)

INST_STATIC  =
INST_DYNAMIC =
INST_BOOT    =

EXPORT_LIST = 

PERL_ARCHIVE = 

PERL_ARCHIVE_AFTER = 

TO_INST_PM = lib/UFMEDIA/CacheOneFile.pm

PM_TO_BLIB = lib/UFMEDIA/CacheOneFile.pm \
	$(INST_LIB)/UFMEDIA/CacheOneFile.pm


# --- MakeMaker tool_autosplit section:

# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
AUTOSPLITFILE = $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e 'use AutoSplit;autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1) ;'


# --- MakeMaker tool_xsubpp section:


# --- MakeMaker tools_other section:

SHELL = /bin/sh
CHMOD = chmod
CP = cp
LD = cc
MV = mv
NOOP = $(SHELL) -c true
RM_F = rm -f
RM_RF = rm -rf
TEST_F = test -f
TOUCH = touch
UMASK_NULL = umask 0
DEV_NULL = > /dev/null 2>&1

# The following is a portable way to say mkdir -p
# To see which directories are created, change the if 0 to if 1
MKPATH = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mkpath

# This helps us to minimize the effect of the .exists files A yet
# better solution would be to have a stable file in the perl
# distribution with a timestamp of zero. But this solution doesn't
# need any changes to the core distribution and works with older perls
EQUALIZE_TIMESTAMP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e eqtime

# Here we warn users that an old packlist file was found somewhere,
# and that they should call some uninstall routine
WARN_IF_OLD_PACKLIST = $(PERL) -we 'exit unless -f $$ARGV[0];' \
-e 'print "WARNING: I have found an old package in\n";' \
-e 'print "\t$$ARGV[0].\n";' \
-e 'print "Please make sure the two installations are not conflicting\n";'

UNINST=0
VERBINST=0

MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \
-e "install({@ARGV},'$(VERBINST)',0,'$(UNINST)');"

DOC_INSTALL = $(PERL) -e '$$\="\n\n";' \
-e 'print "=head2 ", scalar(localtime), ": C<", shift, ">", " L<", $$arg=shift, "|", $$arg, ">";' \
-e 'print "=over 4";' \
-e 'while (defined($$key = shift) and defined($$val = shift)){print "=item *";print "C<$$key: $$val>";}' \
-e 'print "=back";'

UNINSTALL =   $(PERL) -MExtUtils::Install \
-e 'uninstall($$ARGV[0],1,1); print "\nUninstall is deprecated. Please check the";' \
-e 'print " packlist above carefully.\n  There may be errors. Remove the";' \
-e 'print " appropriate files manually.\n  Sorry for the inconveniences.\n"'


# --- MakeMaker dist section:

DISTVNAME = $(DISTNAME)-$(VERSION)
TAR  = tar
TARFLAGS = cvf
ZIP  = zip
ZIPFLAGS = -r
COMPRESS = gzip --best
SUFFIX = .gz
SHAR = shar
PREOP = @$(NOOP)
POSTOP = @$(NOOP)
TO_UNIX = @$(NOOP)
CI = ci -u
RCS_LABEL = rcs -Nv$(VERSION_SYM): -q
DIST_CP = best
DIST_DEFAULT = tardist


# --- MakeMaker macro section:


# --- MakeMaker depend section:


# --- MakeMaker cflags section:


# --- MakeMaker const_loadlibs section:


# --- MakeMaker const_cccmd section:


# --- MakeMaker post_constants section:


# --- MakeMaker pasthru section:

PASTHRU = LIB="$(LIB)"\
	LIBPERL_A="$(LIBPERL_A)"\
	LINKTYPE="$(LINKTYPE)"\
	PREFIX="$(PREFIX)"\
	OPTIMIZE="$(OPTIMIZE)"


# --- MakeMaker c_o section:


# --- MakeMaker xs_c section:


# --- MakeMaker xs_o section:


# --- MakeMaker top_targets section:

#all ::	config $(INST_PM) subdirs linkext manifypods

all :: pure_all htmlifypods manifypods
	@$(NOOP)

pure_all :: config pm_to_blib subdirs linkext
	@$(NOOP)

subdirs :: $(MYEXTLIB)
	@$(NOOP)

config :: Makefile $(INST_LIBDIR)/.exists
	@$(NOOP)

config :: $(INST_ARCHAUTODIR)/.exists
	@$(NOOP)

config :: $(INST_AUTODIR)/.exists
	@$(NOOP)

$(INST_AUTODIR)/.exists :: /usr/lib/perl5/5.6.1/i586-linux/CORE/perl.h
	@$(MKPATH) $(INST_AUTODIR)
	@$(EQUALIZE_TIMESTAMP) /usr/lib/perl5/5.6.1/i586-linux/CORE/perl.h $(INST_AUTODIR)/.exists

	-@$(CHMOD) $(PERM_RWX) $(INST_AUTODIR)

$(INST_LIBDIR)/.exists :: /usr/lib/perl5/5.6.1/i586-linux/CORE/perl.h
	@$(MKPATH) $(INST_LIBDIR)
	@$(EQUALIZE_TIMESTAMP) /usr/lib/perl5/5.6.1/i586-linux/CORE/perl.h $(INST_LIBDIR)/.exists

	-@$(CHMOD) $(PERM_RWX) $(INST_LIBDIR)

$(INST_ARCHAUTODIR)/.exists :: /usr/lib/perl5/5.6.1/i586-linux/CORE/perl.h
	@$(MKPATH) $(INST_ARCHAUTODIR)
	@$(EQUALIZE_TIMESTAMP) /usr/lib/perl5/5.6.1/i586-linux/CORE/perl.h $(INST_ARCHAUTODIR)/.exists

	-@$(CHMOD) $(PERM_RWX) $(INST_ARCHAUTODIR)

config :: $(INST_MAN3DIR)/.exists
	@$(NOOP)


$(INST_MAN3DIR)/.exists :: /usr/lib/perl5/5.6.1/i586-linux/CORE/perl.h
	@$(MKPATH) $(INST_MAN3DIR)
	@$(EQUALIZE_TIMESTAMP) /usr/lib/perl5/5.6.1/i586-linux/CORE/perl.h $(INST_MAN3DIR)/.exists

	-@$(CHMOD) $(PERM_RWX) $(INST_MAN3DIR)

help:
	perldoc ExtUtils::MakeMaker

Version_check:
	@$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
		-MExtUtils::MakeMaker=Version_check \
		-e "Version_check('$(MM_VERSION)')"


# --- MakeMaker linkext section:

linkext :: $(LINKTYPE)
	@$(NOOP)


# --- MakeMaker dlsyms section:


# --- MakeMaker dynamic section:

## $(INST_PM) has been moved to the all: target.
## It remains here for awhile to allow for old usage: "make dynamic"
#dynamic :: Makefile $(INST_DYNAMIC) $(INST_BOOT) $(INST_PM)
dynamic :: Makefile $(INST_DYNAMIC) $(INST_BOOT)
	@$(NOOP)


# --- MakeMaker dynamic_bs section:

BOOTSTRAP =


# --- MakeMaker dynamic_lib section:


# --- MakeMaker static section:

## $(INST_PM) has been moved to the all: target.
## It remains here for awhile to allow for old usage: "make static"
#static :: Makefile $(INST_STATIC) $(INST_PM)
static :: Makefile $(INST_STATIC)
	@$(NOOP)


# --- MakeMaker static_lib section:


# --- MakeMaker htmlifypods section:

htmlifypods : pure_all
	@$(NOOP)


# --- MakeMaker manifypods section:
POD2MAN_EXE = /usr/bin/pod2man
POD2MAN = $(PERL) -we '%m=@ARGV;for (keys %m){' \
-e 'next if -e $$m{$$_} && -M $$m{$$_} < -M $$_ && -M $$m{$$_} < -M "Makefile";' \
-e 'print "Manifying $$m{$$_}\n";' \
-e 'system(qq[$$^X ].q["-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" $(POD2MAN_EXE) ].qq[$$_>$$m{$$_}])==0 or warn "Couldn\047t install $$m{$$_}\n";' \
-e 'chmod(oct($(PERM_RW))), $$m{$$_} or warn "chmod $(PERM_RW) $$m{$$_}: $$!\n";}'

manifypods : pure_all lib/UFMEDIA/CacheOneFile.pm
	@$(POD2MAN) \
	lib/UFMEDIA/CacheOneFile.pm \
	$(INST_MAN3DIR)/UFMEDIA::CacheOneFile.$(MAN3EXT)

# --- MakeMaker processPL section:


# --- MakeMaker installbin section:


# --- MakeMaker subdirs section:

# none

# --- MakeMaker clean section:

# Delete temporary files but do not touch installed files. We don't delete
# the Makefile here so a later make realclean still has a makefile to use.

clean ::
	-rm -rf ./blib $(MAKE_APERL_FILE) $(INST_ARCHAUTODIR)/extralibs.all perlmain.c mon.out core core.*perl.*.? *perl.core so_locations pm_to_blib *$(OBJ_EXT) *$(LIB_EXT) perl.exe $(BOOTSTRAP) $(BASEEXT).bso $(BASEEXT).def $(BASEEXT).exp
	-mv Makefile Makefile.old $(DEV_NULL)


# --- MakeMaker realclean section:

# Delete temporary files (via clean) and also delete installed files
realclean purge ::  clean
	rm -rf $(INST_AUTODIR) $(INST_ARCHAUTODIR)
	rm -f  $(INST_LIB)/UFMEDIA/CacheOneFile.pm
	rm -rf Makefile Makefile.old


# --- MakeMaker dist_basics section:

distclean :: realclean distcheck

distcheck :
	$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=fullcheck \
		-e fullcheck

skipcheck :
	$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=skipcheck \
		-e skipcheck

manifest :
	$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=mkmanifest \
		-e mkmanifest

veryclean : realclean
	$(RM_F) *~ *.orig */*~ */*.orig


# --- MakeMaker dist_core section:

dist : $(DIST_DEFAULT)
	@$(PERL) -le 'print "Warning: Makefile possibly out of date with $$vf" if ' \
	    -e '-e ($$vf="$(VERSION_FROM)") and -M $$vf < -M "Makefile";'

tardist : $(DISTVNAME).tar$(SUFFIX)

zipdist : $(DISTVNAME).zip

$(DISTVNAME).tar$(SUFFIX) : distdir
	$(PREOP)
	$(TO_UNIX)
	$(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME)
	$(RM_RF) $(DISTVNAME)
	$(COMPRESS) $(DISTVNAME).tar
	$(POSTOP)

$(DISTVNAME).zip : distdir
	$(PREOP)
	$(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME)
	$(RM_RF) $(DISTVNAME)
	$(POSTOP)

uutardist : $(DISTVNAME).tar$(SUFFIX)
	uuencode $(DISTVNAME).tar$(SUFFIX) \
		$(DISTVNAME).tar$(SUFFIX) > \
		$(DISTVNAME).tar$(SUFFIX)_uu

shdist : distdir
	$(PREOP)
	$(SHAR) $(DISTVNAME) > $(DISTVNAME).shar
	$(RM_RF) $(DISTVNAME)
	$(POSTOP)


# --- MakeMaker dist_dir section:

distdir :
	$(RM_RF) $(DISTVNAME)
	$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=manicopy,maniread \
		-e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');"


# --- MakeMaker dist_test section:

disttest : distdir
	cd $(DISTVNAME) && $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) Makefile.PL
	cd $(DISTVNAME) && $(MAKE)
	cd $(DISTVNAME) && $(MAKE) test


# --- MakeMaker dist_ci section:

ci :
	$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=maniread \
		-e "@all = keys %{ maniread() };" \
		-e 'print("Executing $(CI) @all\n"); system("$(CI) @all");' \
		-e 'print("Executing $(RCS_LABEL) ...\n"); system("$(RCS_LABEL) @all");'


# --- MakeMaker install section:

install :: all pure_install doc_install

install_perl :: all pure_perl_install doc_perl_install

install_site :: all pure_site_install doc_site_install

install_ :: install_site
	@echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site

pure_install :: pure_$(INSTALLDIRS)_install

doc_install :: doc_$(INSTALLDIRS)_install
	@echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod

pure__install : pure_site_install
	@echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site

doc__install : doc_site_install
	@echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site

pure_perl_install ::
	@$(MOD_INSTALL) \
		read $(PERL_ARCHLIB)/auto/$(FULLEXT)/.packlist \
		write $(INSTALLARCHLIB)/auto/$(FULLEXT)/.packlist \
		$(INST_LIB) $(INSTALLPRIVLIB) \
		$(INST_ARCHLIB) $(INSTALLARCHLIB) \
		$(INST_BIN) $(INSTALLBIN) \
		$(INST_SCRIPT) $(INSTALLSCRIPT) \
		$(INST_HTMLLIBDIR) $(INSTALLHTMLPRIVLIBDIR) \
		$(INST_HTMLSCRIPTDIR) $(INSTALLHTMLSCRIPTDIR) \
		$(INST_MAN1DIR) $(INSTALLMAN1DIR) \
		$(INST_MAN3DIR) $(INSTALLMAN3DIR)
	@$(WARN_IF_OLD_PACKLIST) \
		$(SITEARCHEXP)/auto/$(FULLEXT)


pure_site_install ::
	@$(MOD_INSTALL) \
		read $(SITEARCHEXP)/auto/$(FULLEXT)/.packlist \
		write $(INSTALLSITEARCH)/auto/$(FULLEXT)/.packlist \
		$(INST_LIB) $(INSTALLSITELIB) \
		$(INST_ARCHLIB) $(INSTALLSITEARCH) \
		$(INST_BIN) $(INSTALLBIN) \
		$(INST_SCRIPT) $(INSTALLSCRIPT) \
		$(INST_HTMLLIBDIR) $(INSTALLHTMLSITELIBDIR) \
		$(INST_HTMLSCRIPTDIR) $(INSTALLHTMLSCRIPTDIR) \
		$(INST_MAN1DIR) $(INSTALLMAN1DIR) \
		$(INST_MAN3DIR) $(INSTALLMAN3DIR)
	@$(WARN_IF_OLD_PACKLIST) \
		$(PERL_ARCHLIB)/auto/$(FULLEXT)

doc_perl_install ::
	-@$(MKPATH) $(INSTALLARCHLIB)
	-@$(DOC_INSTALL) \
		"Module" "$(NAME)" \
		"installed into" "$(INSTALLPRIVLIB)" \
		LINKTYPE "$(LINKTYPE)" \
		VERSION "$(VERSION)" \
		EXE_FILES "$(EXE_FILES)" \
		>> $(INSTALLARCHLIB)/perllocal.pod

doc_site_install ::
	-@$(MKPATH) $(INSTALLARCHLIB)
	-@$(DOC_INSTALL) \
		"Module" "$(NAME)" \
		"installed into" "$(INSTALLSITELIB)" \
		LINKTYPE "$(LINKTYPE)" \
		VERSION "$(VERSION)" \
		EXE_FILES "$(EXE_FILES)" \
		>> $(INSTALLARCHLIB)/perllocal.pod


uninstall :: uninstall_from_$(INSTALLDIRS)dirs

uninstall_from_perldirs ::
	@$(UNINSTALL) $(PERL_ARCHLIB)/auto/$(FULLEXT)/.packlist

uninstall_from_sitedirs ::
	@$(UNINSTALL) $(SITEARCHEXP)/auto/$(FULLEXT)/.packlist


# --- MakeMaker force section:
# Phony target to force checking subdirectories.
FORCE:
	@$(NOOP)


# --- MakeMaker perldepend section:


# --- MakeMaker makefile section:

# We take a very conservative approach here, but it\'s worth it.
# We move Makefile to Makefile.old here to avoid gnu make looping.
Makefile : Makefile.PL $(CONFIGDEP)
	@echo "Makefile out-of-date with respect to $?"
	@echo "Cleaning current config before rebuilding Makefile..."
	-@$(RM_F) Makefile.old
	-@$(MV) Makefile Makefile.old
	-$(MAKE) -f Makefile.old clean $(DEV_NULL) || $(NOOP)
	$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL 
	@echo "==> Your Makefile has been rebuilt. <=="
	@echo "==> Please rerun the make command.  <=="
	false

# To change behavior to :: would be nice, but would break Tk b9.02
# so you find such a warning below the dist target.
#Makefile :: $(VERSION_FROM)
#	@echo "Warning: Makefile possibly out of date with $(VERSION_FROM)"


# --- MakeMaker staticmake section:

# --- MakeMaker makeaperl section ---
MAP_TARGET    = perl
FULLPERL      = /usr/bin/perl

$(MAP_TARGET) :: static $(MAKE_APERL_FILE)
	$(MAKE) -f $(MAKE_APERL_FILE) $@

$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
	@echo Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET)
	@$(PERL) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
		Makefile.PL DIR= \
		MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
		MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=


# --- MakeMaker test section:

TEST_VERBOSE=0
TEST_TYPE=test_$(LINKTYPE)
TEST_FILE = test.pl
TEST_FILES = t/*.t
TESTDB_SW = -d

testdb :: testdb_$(LINKTYPE)

test :: $(TEST_TYPE)

test_dynamic :: pure_all
	PERL_DL_NONLAZY=1 $(FULLPERL) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;' $(TEST_FILES)

testdb_dynamic :: pure_all
	PERL_DL_NONLAZY=1 $(FULLPERL) $(TESTDB_SW) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(TEST_FILE)

test_ : test_dynamic

test_static :: test_dynamic
testdb_static :: testdb_dynamic


# --- MakeMaker ppd section:
# Creates a PPD (Perl Package Description) for a binary distribution.
ppd:
	@$(PERL) -e "print qq{<SOFTPKG NAME=\"UFMEDIA-CacheOneFile\" VERSION=\"1,01,0,0\">\n}. qq{\t<TITLE>UFMEDIA-CacheOneFile</TITLE>\n}. qq{\t<ABSTRACT>cache a scalar value in a file on disk</ABSTRACT>\n}. qq{\t<AUTHOR>Mike Lyons &lt;lyonsm\@userfriendly.org&gt;</AUTHOR>\n}. qq{\t<IMPLEMENTATION>\n}. qq{\t\t<OS NAME=\"$(OSNAME)\" />\n}. qq{\t\t<ARCHITECTURE NAME=\"i586-linux\" />\n}. qq{\t\t<CODEBASE HREF=_/_.html />\n}. qq{\t</IMPLEMENTATION>\n}. qq{</SOFTPKG>\n}" > UFMEDIA-CacheOneFile.ppd

# --- MakeMaker pm_to_blib section:

pm_to_blib: $(TO_INST_PM)
	@$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \
	"-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \
        -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'$(INST_LIB)/auto','$(PM_FILTER)')"
	@$(TOUCH) $@


# --- MakeMaker selfdocument section:


# --- MakeMaker postamble section:


# End.
                                                                                                                                                                                                                                                                                                                                                                                                                                                                               scripts/CacheOneFile/pm_to_blib                                                                     0100644 0000000 0000000 00000000000 07442770501 015536  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   ARS/header_ca.html                                                                                  0100644 0000765 0000144 00000002177 07510643326 013013  0                                                                                                    ustar   ars                             users                                                                                                                                                                                                                  <!-- Start UF title and Ad Banner -->
<TABLE BGCOLOR="#ffffff" WIDTH="100%" CELLSPACING="0" CELLPADDING="0" BORDER="0">
<TR>
<TD width="1%" rowspan=3 ALIGN="left" VALIGN="top"><IMG alt="Cartoon Archive" border=0 width=134 height=66 src="../graphics.userfriendly.org/images/title_uf_cartoons.gif"></TD>
<td width="100%" align=left valign=top bgcolor="#ff9900"><img src=../graphics.userfriendly.org/images/clear.gif width=100 height=3></td></tr>
<tr><td align=left valign=top bgcolor="#ffffff"><img src=../graphics.userfriendly.org/images/clear.gif width=100 height=3></td></tr>
<TR><TD align=center>
<!-- Begin Banner -->

<IFRAME src="../adsnew.userfriendly.org/cgi-bin/advertpro/bannersa207.pl?region=4&amp;keyword=NULL" height="60" width="468" marginwidth="0" marginheight="0" vspace="0" hspace="0" frameborder="0" align="middle" scrolling="no">
<A href="../adsnew.userfriendly.org/cgi-bin/advertpro/blinkcd0d.pl?region=4&amp;slot=1" target="_top">
<IMG src="../adsnew.userfriendly.org/cgi-bin/advertpro/bimg15a5.pl?region=4&amp;slot=1&amp;keyword=NULL" border="0" width="468" height="60" alt="UF Archives">
</a>
</iframe>
<!-- End Banner -->

</TABLE>
                                                                                                                                                                                                                                                                                                                                                                                                 ARS/header_ccs.html                                                                                 0100644 0000765 0000144 00000001517 07560431070 013171  0                                                                                                    ustar   ars                             users                                                                                                                                                                                                                  <TABLE BGCOLOR="#ffffff" WIDTH="100%" CELLSPACING="0" CELLPADDING="0" BORDER="0">
<TR>
<TD width="1%" rowspan=3 ALIGN="left" VALIGN="top"><a href="../www.userfriendly.org/static/index.html"><IMG alt="The Daily Static" border=0 width=125 height=60 src="../www.userfriendly.org/images/titles/title_uforg.gif"></a></TD>
<TR><TD align=center>

<IFRAME src="../adsnew.userfriendly.org/cgi-bin/advertpro/bannersa207.pl?region=4&amp;keyword=NULL" height="60" width="468" marginwidth="0" marginheight="0" vspace="0" hspace="0" frameborder="0" align="middle" scrolling="no">
<A href="../adsnew.userfriendly.org/cgi-bin/advertpro/blinkcd0d.pl?region=4&amp;slot=1" target="_top">
<IMG src="../adsnew.userfriendly.org/cgi-bin/advertpro/bimg15a5.pl?region=4&amp;slot=1&amp;keyword=NULL" border="0" width="468" height="60" alt="UF Archives">
</a>
</iframe>

</TD></TR>
</TABLE>

                                                                                                                                                                                 ARS/header_ncs.html                                                                                 0100644 0000765 0000144 00000001465 07510643371 013212  0                                                                                                    ustar   ars                             users                                                                                                                                                                                                                  <!-- Start UF title and Ad Banner -->
<TABLE BGCOLOR="#ffffff" WIDTH="95%" CELLSPACING="0" CELLPADDING="0" BORDER="0">
<TR>	
<TD ALIGN="left" VALIGN="top">
<IMG alt="NCS" border=0 width=160 height=60 src="../graphics.userfriendly.org/images/titles/title_uf_ncs.gif"> 
</TD>
<TD ALIGN="right" VALIGN="top">
</TD>

<IFRAME src="../adsnew.userfriendly.org/cgi-bin/advertpro/bannersa207.pl?region=4&amp;keyword=NULL" height="60" width="468" marginwidth="0" marginheight="0" vspace="0" hspace="0" frameborder="0" align="middle" scrolling="no">
<A href="../adsnew.userfriendly.org/cgi-bin/advertpro/blinkcd0d.pl?region=4&amp;slot=1" target="_top">
<IMG src="../adsnew.userfriendly.org/cgi-bin/advertpro/bimg15a5.pl?region=4&amp;slot=1&amp;keyword=NULL" border="0" width="468" height="60" alt="UF Archives">
</a>
</iframe>

</TR>
</TABLE>