view release on metacpan or  search on metacpan

lib/DemoUsage.pm  view on Meta::CPAN

}

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

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 {