view release on metacpan or  search on metacpan

lib/Apache2/ClickPath/Decode.pm  view on Meta::CPAN

package Apache2::ClickPath::Decode;

use strict;
use warnings;
no warnings qw{uninitialized};
use Apache2::ClickPath::_parse;
use MIME::Base64 ();
use Crypt::CBC ();
use Crypt::Blowfish ();
use Digest::MD5 ();
use Digest::CRC ();
use Class::Member qw{friendly_session
		     tag
		     server_map
		     secret
		     secret_iv
		     session
		     remote_session_host remote_session
		     server_id
		     server_name
		     creation_time
		     server_pid
		     seq_number
		     connection_id
		     debug};

our $VERSION='1.900';

sub new {
  my $class=shift;
  my $I={};
  my %o=@_;

  if( ref( $class ) ) {
    bless $I=>ref( $class );
    $I->friendly_session=$class->friendly_session;
    $I->tag=$class->tag;
    $I->server_map=$class->server_map;
  } else {
    bless $I=>$class;
  }

  foreach my $m (qw{friendly_session tag server_map session secret secret_iv}) {
    $I->$m=$o{$m} if( exists $o{$m} );
  }

  if( length $I->session ) {
    return $I->parse;
  }

  return $I;
}

sub parse {
  my $I=shift;
  $I->session=shift if( @_ );

  my $session=$I->session;

  if( length $I->tag ) {
    my $tag=$I->tag;
    return unless( $session=~m~\Q$tag\E([^/]+)~ );
    $I->session=$session=$1;
  }

  return unless( length $session );

  if( defined $I->friendly_session and ref($I->friendly_session) ne 'HASH' ) {

lib/Apache2/ClickPath/Decode.pm  view on Meta::CPAN

      defined $I->friendly_session and
      exists $I->friendly_session->{$l[1]} ) {
    my %h=('**'=>'*', '*!'=>'!', '*.'=>'=', '!'=>"\n");
    $l[2]=~s/(\*[*!.]|!)/$h{$1}/ge;

    $I->remote_session_host=$I->friendly_session->{$l[1]};
    $I->remote_session=$l[2];
  } else {
    undef $I->remote_session_host;
    undef $I->remote_session;
  }

  # extract session start time
  $l[0]=~tr[@\-][+/];
  @l=split /:/, $l[0], 2;	# $l[0]: IP Addr, $l[1]: session

  return unless( @l==2 );

  $I->server_name=$l[0];

  if( defined $I->server_map ) {
    if( length $I->server_map ) {
      unless( ref( $I->server_map ) eq 'HASH' ) {
	my $map=eval $I->server_map;
	if( ref( $map ) eq 'HASH' ) {
	  $I->server_map=$map;
	} else {
	  (undef, $I->server_map)=
	    Apache2::ClickPath::_parse::MachineTable( $I->server_map );
	}
      }

      $I->server_id=$I->server_map->{$l[0]}->[0]
	if( ref( $I->server_map ) eq 'HASH' and
	    exists $I->server_map->{$l[0]} );
    } else {
      $I->server_id=$l[0];
    }
  } else {
    my $len4=do {use integer; (length( $l[0] )+3)/4;};
    $len4*=4;
    $I->server_id=
      join
	( '.',
	  unpack("C*",
		 MIME::Base64::decode_base64($l[0].
					     ('='x($len4-length( $l[0] ))))) );
  }

  my $len4=do {use integer; (length( $l[1] )+3)/4;};
  $len4*=4;
  $l[1]=MIME::Base64::decode_base64( $l[1].('='x($len4-length( $l[1] ))) );
  if( $I->secret ) {
    my $secret=Apache2::ClickPath::_parse::Secret( $I->secret );
    my $iv;
    if( length $I->secret_iv ) {
      $iv=substr( Digest::MD5::md5( $I->secret_iv ), 0, 8 );
    } else {
      $iv="abcd1234";
    }
    my $crypt=Crypt::CBC->new(
			      -key=>$secret,
			      -keysize=>length($secret),
			      -cipher=>'Crypt::Blowfish',
			      -literal_key=>1,
			      -header=>'none',
			      -iv=>$iv,
			     );
    $l[1]=$crypt->decrypt( $l[1] );
  }

  my $crc;
  if( length( $l[1] ) ) {
    $crc=Digest::CRC::crc8( substr( $l[1], 1 ) );
  } else {
    $crc=-1;			# invalid value
  }

  @l=unpack( "CNNnN", $l[1] );

  die "Invalid session: CRC checksum failed" if( $crc!=$l[0] );

  (undef,
   $I->creation_time,
   $I->server_pid,
   $I->seq_number,
   $I->connection_id)=@l;

  return $I;
}

1;

__END__

=head1 NAME

Apache2::ClickPath::Decode - Decode Apache2::ClickPath session IDs

=head1 SYNOPSIS

 use Apache2::ClickPath::Decode;
 my $decoder=Apache2::ClickPath::Decode->new;
 $decoder->tag='-';
 my $time=$decoder
             ->parse( 'http://bla.com/-PtVOR9:dxAredNNqtcus9NNNOdM/' )
             ->creation_time;

=head1 DESCRIPTION

C<Apache2::ClickPath::Decode> provides an OO interface for decoding
C<Apache2::ClickPath> session identifiers.

=head2 Methods

This module uses L<Class::Member(3)> to implement member functions. Thus,
all member functions are lvalues, eg C<< $decoder->tag='-' >>.

=over 4

=item B<new>