view release on metacpan or  search on metacpan

lib/DemoUsage.pm  view on Meta::CPAN

	$dcm_file->write_all_records();
	$dcm_file->unlock_and_close();

	my $ra_mail_prefs = $rh_prefs->{$PKEY_MAILING};
	ref( $ra_mail_prefs ) eq 'ARRAY' or $ra_mail_prefs = [$ra_mail_prefs];

	foreach my $rh_mail_pref (@{$ra_mail_prefs}) {
		ref( $rh_mail_pref ) eq 'HASH' or next;

		my $ra_filenames = $rh_mail_pref->{$MKEY_FILENAMES} || [];
		ref( $ra_filenames ) eq 'ARRAY' or $ra_filenames = [$ra_filenames];
		my $erase_files = $rh_mail_pref->{$MKEY_ERASE_FILES};

		my @mail_body = ();

		foreach my $filename (@{$ra_filenames}) {
			$filename or next;
			my $count_file = 
				DemoUsage::CountFile->new( $globals, $filename );
			$count_file->open_and_lock( 1 ) or do {
				push( @mail_body, "\n\n".$globals->get_error()."\n" );
				next;
			};
			$count_file->read_all_records();
			push( @mail_body, "\n\ncontent of '$filename':\n\n" );
			push( @mail_body, $count_file->get_sorted_file_content() );
			if( $erase_files ) {
				$count_file->delete_all_keys();
			} else {
				$count_file->set_all_day_counts_to_zero();
			}
			$count_file->write_all_records();
			$count_file->unlock_and_close();
		}

		my ($today_str) = ($self->today_date_utc() =~ m/^(\S+)/ );
		my $subject_unique = $rh_mail_pref->{$MKEY_SUBJECT_UNIQUE};
		defined( $subject_unique) or $subject_unique = ' -- usage to ';

		my $err_msg = $self->send_email_message(
			$globals->default_maintainer_name(),
			$globals->default_maintainer_email_address(),
			$globals->default_maintainer_name(),
			$globals->default_maintainer_email_address(),
			$globals->default_application_title().$subject_unique.$today_str,
			join( '', @mail_body ),
			<<__endquote,
This is a daily copy of the site usage count logs.
The first visitor activity on $today_str has just occurred.
__endquote
		);

		if( $err_msg ) {
			$globals->add_error( "can't e-mail usage counts: $err_msg" );
		}
	}
}

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

sub update_env_counts {
	my $self = shift( @_ );
	my $globals = $self->{$KEY_SITE_GLOBALS};
	my $rh_prefs = $globals->get_prefs_ref();
	
	my $rh_log_prefs = $rh_prefs->{$PKEY_LOG_ENV};
	ref( $rh_log_prefs ) eq 'HASH' or return( 0 );
	
	my $filename = $rh_log_prefs->{$LKEY_FILENAME} or return( 0 );
	my $ra_var_list = $rh_log_prefs->{$EKEY_VAR_LIST};
	ref( $ra_var_list ) eq 'ARRAY' or $ra_var_list = [$ra_var_list];
	
	# save miscellaneous low-distribution environment vars
	$self->update_one_count_file( $filename, 
		(map { "\$ENV{$_} = \"$ENV{$_}\"" } @{$ra_var_list}) );
}

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

sub update_site_vrp_counts {
	my $self = shift( @_ );
	my $globals = $self->{$KEY_SITE_GLOBALS};
	my $rh_prefs = $globals->get_prefs_ref();
	
	my $rh_log_prefs = $rh_prefs->{$PKEY_LOG_SITE};
	ref( $rh_log_prefs ) eq 'HASH' or return( 0 );
	
	my $filename = $rh_log_prefs->{$LKEY_FILENAME} or return( 0 );
	my $t_rd = $rh_log_prefs->{$SKEY_TOKEN_REDIRECT} || '__external_url__';
	
	# save which page within this site was hit
	$self->update_one_count_file( $filename, 
		$globals->user_path_string(), 
		$globals->http_redirect_url() ? $t_rd : () );
}

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

sub update_redirect_counts {
	my $self = shift( @_ );
	my $globals = $self->{$KEY_SITE_GLOBALS};
	my $rh_prefs = $globals->get_prefs_ref();
	
	my $rh_log_prefs = $rh_prefs->{$PKEY_LOG_REDIRECT};
	ref( $rh_log_prefs ) eq 'HASH' or return( 0 );
	
	my $filename = $rh_log_prefs->{$LKEY_FILENAME} or return( 0 );
	
	# save which url this site referred the visitor to, if any
	$self->update_one_count_file( $filename, $globals->http_redirect_url() );
}

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

sub update_referrer_counts {
	my $self = shift( @_ );
	my $globals = $self->{$KEY_SITE_GLOBALS};
	my $rh_prefs = $globals->get_prefs_ref();
	
	my $rh_log_prefs = $rh_prefs->{$PKEY_LOG_REFERRER};
	ref( $rh_log_prefs ) eq 'HASH' or return( 0 );
	
	my $fn_normal = $rh_log_prefs->{$LKEY_FILENAME};
	my $fn_search = $rh_log_prefs->{$RKEY_FN_SEARCH};
	my $fn_keywords = $rh_log_prefs->{$RKEY_FN_KEYWORDS};
	my $fn_discards = $rh_log_prefs->{$RKEY_FN_DISCARDS};
	
	my $t_rfs = $rh_log_prefs->{$RKEY_TOKEN_REF_SELF} || '__self_reference__';
	my $t_rfo = $rh_log_prefs->{$RKEY_TOKEN_REF_OTHER} || '__other_reference__';
	
	my $ra_discards = $rh_log_prefs->{$RKEY_DISCARDS} || [];
	ref( $ra_discards ) eq 'ARRAY' or $ra_discards = [$ra_discards];
	
	my $rh_engines = $rh_log_prefs->{$RKEY_SEARCH_ENGINES};
	ref( $rh_engines ) eq 'HASH' or $rh_engines = {};
	
	# save which url had referred visitors to this site
	my (@ref_norm, @ref_sear, @ref_keyw, @ref_disc);

	SWITCH: {
		my $referer = $globals->referer();
		my ($ref_filename, $query) = split( /\?/, $referer, 2 );
		$ref_filename =~ s|/$||;     # lose trailing "/"s
		$referer = ($query =~ /[a-zA-Z0-9]/) ? 
			"$ref_filename?$query" : $ref_filename;
		$ref_filename =~ m|^http://([^/]+)(.*)|;
		my ($domain, $path) = ($1, $2);
		
		# first check if visitor is moving within our own site
		my $site_url = $globals->url_base();
		if( $ref_filename =~ m|$site_url|i ) {
			push( @ref_norm, $t_rfs );
			push( @ref_sear, $t_rfs );
			push( @ref_keyw, $t_rfs );
			push( @ref_disc, $t_rfs );			
			last SWITCH;
		}

		# else check if visitor came from checking an e-mail online
		foreach my $ident (@{$ra_discards}) {
			if( $ref_filename =~ m|$ident|i ) {
				push( @ref_norm, $t_rfo );
				push( @ref_sear, $t_rfo );
				push( @ref_keyw, $t_rfo );
				push( @ref_disc, $referer );
				last SWITCH;
			}
		}
		
		# else check if the referring domain is a search engine
		foreach my $dom_frag (keys %{$rh_engines}) {
			if( ".$domain." =~ m|[/\.]$dom_frag\.|i ) { # CHANGED THIS LINE 0-43
				my $se_query = CGI::MultiValuedHash->new( 1, $query );
				my @se_keywords;
				
				my $kwpn = $rh_engines->{$dom_frag};
				my @kwpn = ref($kwpn) eq 'ARRAY' ? @{$kwpn} : $kwpn;
				foreach my $query_param (@kwpn) {
					push( @se_keywords, split( /\s+/, 
						$se_query->fetch_value( $query_param ) ) );
				}

				foreach my $kw (@se_keywords) {
					$kw =~ s/^[^a-zA-Z0-9]+//;  # remove framing junk
					$kw =~ s/[^a-zA-Z0-9]+$//;
					$kw = lc( $kw ); # ADDED THIS LINE 0-43
				}

				# save both the file name and the search words used
				push( @ref_norm, $t_rfo );
				push( @ref_sear, $ref_filename );
				push( @ref_keyw, @se_keywords );
				push( @ref_disc, $t_rfo );
				last SWITCH;
			}
		}

		# otherwise, referer is probably a normal web site
		push( @ref_norm, $referer );
		push( @ref_sear, $t_rfo );
		push( @ref_keyw, $t_rfo );
		push( @ref_disc, $t_rfo );
	}

	$fn_normal and $self->update_one_count_file( $fn_normal, @ref_norm );
	$fn_search and $self->update_one_count_file( $fn_search, @ref_sear );
	$fn_keywords and $self->update_one_count_file( $fn_keywords, @ref_keyw );
	$fn_discards and $self->update_one_count_file( $fn_discards, @ref_disc );
}

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

sub update_one_count_file {
	my ($self, $filename, @keys_to_inc) = @_;
	my $globals = $self->{$KEY_SITE_GLOBALS};
	my $rh_prefs = $globals->get_prefs_ref();

	push( @keys_to_inc, $rh_prefs->{$PKEY_TOKEN_TOTAL} );

	my $count_file = 
		DemoUsage::CountFile->new( $globals, $filename );
	$count_file->open_and_lock( 1 ) or return( undef );
	$count_file->read_all_records();

	foreach my $key (@keys_to_inc) {
		$key eq '' and $key = $rh_prefs->{$PKEY_TOKEN_NIL};
		$count_file->key_increment( $key );
	}

	$count_file->write_all_records();
	$count_file->unlock_and_close();
}

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

sub send_email_message {
	my ($self, $to_name, $to_email, $from_name, $from_email, 
		$subject, $body, $body_head_addition) = @_;
	my $globals = $self->{$KEY_SITE_GLOBALS};

	my $EMAIL_HEADER_STRIP_PATTERN = '[,<>()"\'\n]';  #for names and addys
	$to_name    =~ s/$EMAIL_HEADER_STRIP_PATTERN//g;
	$to_email   =~ s/$EMAIL_HEADER_STRIP_PATTERN//g;
	$from_name  =~ s/$EMAIL_HEADER_STRIP_PATTERN//g;
	$from_email =~ s/$EMAIL_HEADER_STRIP_PATTERN//g;
	$globals->is_debug() and $subject .= " -- debug";
	
	my $body_header = <<__endquote.
--------------------------------------------------
This e-mail was sent at @{[$self->today_date_utc()]} 
by the web site "@{[$globals->default_application_title()]}", 
which is located at "@{[$globals->url_base()]}".
__endquote
	$body_head_addition.
	($globals->is_debug() ? "Debugging is currently turned on.\n" : 
	'').<<__endquote;
--------------------------------------------------
__endquote

	my $body_footer = <<__endquote;


--------------------------------------------------
END OF MESSAGE
__endquote
	
	my $host = $globals->default_smtp_host();
	my $timeout = $globals->default_smtp_timeout();
	my $error_msg = '';

	TRY: {
		my $smtp;