usertracker.pm

嵌入式ＷＥＢ

#!/usr/bin/perl -wT

#/----------------------------------------------------------------
# UserTracker Package
# 
# Inherits from HTML::Parser
# 
# 

package UserTracker;

push @ISA, "HTML::Parser";

use strict;
use URI;
use HTML::Parser;

my $GLOBAL_COUNT = 0;

1;


#/----------------------------------------------------------------
# Public methods
# 

sub new {
    my( $class, $path ) = @_;
    my $id;
    
    my $self = $class->SUPER::new();
    
    $self->base_path( $path ) if defined $path;
    
    return $self;
}

sub base_path {
    my( $self, $path ) = @_;
    my $id;
    
    if ( defined $path ) {
        $self->{base_path} = $path;
        if ( $ENV{PATH_INFO} ) {
            if ( $ENV{PATH_INFO} =~ s|^/$self->{base_path}/\.([a-zA-Z0-9_.-]*)/|/| ) {
                $id = $1;
            }
        }
        $id ||= $self->unique_id;
        $self->user_id( $id );
    }
    return defined( $self->{base_path} ) ? $self->{base_path} : "";
}

sub user_id {
    my( $self, $user_id ) = @_;
    $self->{user_id} = $user_id if defined $user_id;
    $self->{user_id} ||= $self->unique_id;
    
    return $self->{user_id};
}


#/----------------------------------------------------------------
# Internal (protected) methods
# 

sub unique_id {
    my $self = shift;
    # Use Apache's mod_unique_id if available
    return $ENV{UNIQUE_ID} || eval {
        require Digest::MD5;
        my $md5 = new Digest::MD5;
        my $semi_unique = defined( $$ ) ?
            $$ : $ENV{REMOTE_ADDR} . $ENV{REMOTE_PORT};
        my $id = $md5->md5_base64( time, $semi_unique, $GLOBAL_COUNT++ );
        $id =~ tr|+/=|-_.|;
        $id;
    } || die "Unable to generate unique identifier for cookie\n";
}

sub encode {
    my( $self, $url ) = @_;
    my $uri  = new URI( $url, "http" );
    my $id   = $self->user_id();
    my $base = $self->base_path;
    my $path = $uri->path;
    
    $path =~ s|^$base|$base/.$id|;
    $uri->path( $path );
    
    return $uri->as_string;
}


#/----------------------------------------------------------------
# Subs to implement HTML::Parser callbacks
# 

sub start {
    my( $self, $tag, $attr, $attrseq, $origtext ) = @_;
    my $new_text = $origtext;
    
    my %relevant_pairs = (
        frameset    => "src",
        a           => "href",
        area        => "href",
        form        => "action",
# Uncomment these lines if you want to track images too
#        img         => "src",
#        body        => "background",
    );
    
    while ( my( $rel_tag, $rel_attr ) = each %relevant_pairs ) {
        if ( $tag eq $rel_tag and $attr->{$rel_attr} ) {
            $attr->{$rel_attr} = $self->encode( $attr->{$rel_attr} );
            my @attribs = map { "$_=\"$attr->{$_}\"" } @$attrseq;
            $new_text = "<$tag @attribs>";
        }
    }
    
    # Meta refresh tags have a different format, handled separately
    if ( $tag eq "meta" and $attr->{"http-equiv"} eq "refresh" ) {
        my( $delay, $url ) = split ";URL=", $attr->{content}, 2;
        $attr->{content} = "$delay;URL=" . $self->encode( $url );
        my @attribs = map { "$_=\"$attr->{$_}\"" } @$attrseq;
        $new_text = "<$tag @attribs>";
    }
    
    print $new_text;
}

sub declaration {
    my( $self, $decl ) = @_;
    print $decl;
}

sub text {
    my( $self, $text ) = @_;
    print $text;
}

sub end {
    my( $self, $tag ) = @_;
    print "</$tag>";
}

sub comment {
    my( $self, $comment ) = @_;
    print "<!--$comment-->";
}