Ticket-Simple-0.0.2000755001750001750 011355135015 14757 5ustar00ckuelkerckuelker000000000000Changes000444001750001750 124411355135015 16331 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2Revision history for Ticket-Simple 0.0.2 2010-04-01T17:01:21 - changes: * tighten licence specification to make META.yml happy * add descr. to POD NAME section to avoid lintian warning - contributers: Christian Kuelker Xavier Oswald Lintian warnings - original version createid by: Christian Kuelker 0.0.l 2009-11-29T10:08:22 - contributers: Christian Kuelker - original version createid by: Christian Kuelker MANIFEST000444001750001750 65711355135015 16156 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2Build.PL Changes lib/Ticket/Simple.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml README t/00.load.t t/10.init_tests.t t/20_now.t t/21_create_ticket.t t/22_store_ticket.t t/23_fetch_ticket.t t/24_is_ticket_equal_stored.t t/25_is_ticket_valid.t t/26_ttl.t t/27_wipe_ticket.t t/28_destroy_ticket.t t/29_is_ticket_valid_now.t t/leaktrace.t t/perlcritic_cpan.t t/perlcriticrc t/pod-coverage.t t/pod.t t/refcount.t MANIFEST.SKIP000444001750001750 143211355135015 16733 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2 #!start included /usr/local/share/perl/5.10.0/ExtUtils/MANIFEST.SKIP # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \B\.git\b \B\.gitignore\b \b_darcs\b # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ # Avoid Devel::Cover files. \bcover_db\b #!end included /usr/local/share/perl/5.10.0/ExtUtils/MANIFEST.SKIP # Avoid Module::Build generated and utility files. \bBuild$ \bBuild.bat$ \b_build \bBuild.COM$ \bBUILD.COM$ \bbuild.com$ # Avoid archives of this distribution \bTicket-Simple-[\d\.\_]+ META.yml000444001750001750 136111355135015 16307 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2--- name: Ticket-Simple version: v0.0.2 author: - 'Christian Kuelker ' abstract: A basic ticket system license: gpl2 resources: homepage: http://www.cipux.org license: http://opensource.org/licenses/gpl-2.0.php build_requires: Module::Build: 0 Test::More: 0 Test::Pod: 1.14 requires: Carp: 0 Class::Std: v0.0.9 Digest::MD5: 0 Log::Log4perl: 0 Readonly: 0 Time::HiRes: 0 version: 0 recommends: Test::Perl::Critic: 0 Test::Pod::Coverage: 1.04 configure_requires: Module::Build: 0.35 provides: Ticket::Simple: file: lib/Ticket/Simple.pm version: v0.0.2 generated_by: Module::Build version 0.35 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 README000444001750001750 74011355135015 15676 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2Ticket-Simple version 0.0.1 A basic ticket system INSTALLATION To install this module, preferably run the following commands: perl Build.PL ./Build ./Build test ./Build install DEPENDENCIES Carp; Class::Std Digest::MD5 Log::Log4perl Readonly Time::HiRes version COPYRIGHT AND LICENCE Copyright (C) 2009, Christian Kuelker This library is licensed under the GNU GPL - GNU General Public License version 2 or later. Makefile.PL000444001750001750 17111355135015 16766 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2use Module::Build::Compat; Module::Build::Compat->run_build_pl(args => \@ARGV); Module::Build::Compat->write_makefile(); Build.PL000444001750001750 232511355135015 16333 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2use strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'Ticket::Simple', license => 'gpl2', dist_author => 'Christian Kuelker ', dist_version => '0.0.2', dist_abstract => 'A basic ticket system', # create_makefile_pl => 'traditional', # create_readme => 1, # verbose => 1, installdirs => 'vendor', meta_merge => { resources => { homepage => q(http://www.cipux.org), }, }, recommends => { 'Test::Perl::Critic' => 0, 'Test::Pod::Coverage' => '1.04', }, build_requires => { 'Module::Build' => 0, 'Test::More' => 0, 'Test::Pod' => '1.14', }, requires => { 'Carp' => 0, 'Class::Std' => '0.0.9', #'Contextual::Return' => 0, #'Date::Manip' => 0, 'Digest::MD5' => 0, 'Log::Log4perl' => 0, 'Readonly' => 0, 'Time::HiRes' => 0, 'version' => 0, }, add_to_cleanup => ['Ticket-Simple-*'], ); # BUILD target #$builder->do_create_readme(); #$builder->do_create_makefile_pl(); $builder->create_build_script(); t000755001750001750 011355135015 15143 5ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.228_destroy_ticket.t000444001750001750 150111355135015 21027 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl -w use warnings; use strict; use Test::More tests => 8; BEGIN { use_ok('Ticket::Simple'); } my $ts = Ticket::Simple->new(); my ( $t1, $v1 ) = $ts->create_ticket( { login => 't' } ); ok( $ts->store_ticket( { login => 't', ticket => $t1, valid => $v1 } ), '- can store ticket' ); my ( $t2, $v2 ) = $ts->fetch_ticket( { login => 't' } ); ok( $t1 eq $t2, '- ticket are equal' ); ok( $v1 == $v2, '- valid until time is the same' ); ok( $ts->destroy_ticket( { login => 't' } ), '- wipe ticket call ok' ); my ( $t3, $v3 ) = $ts->fetch_ticket( { login => 't' } ); ok( ( not( defined $t3 ) ), '- ticket not defined' ); ok( ( not( defined $v3 ) ), '- valid not defined' ); ok( ( not $ts->is_ticket_valid( { login => 't', ticket => $t3, time => $v3 } ) ), '- is ticket NOT valid' ); perlcriticrc000444001750001750 101711355135015 17707 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t# CipUX Perl::Critic Configuration # # SEVERITY NAME ...is equivalent to... SEVERITY NUMBER # ---------------------------------------------------- # gentle 5 # stern 4 # harsh 3 # cruel 2 # brutal 1 severity = brutal verbose = 11 perlcritic_cpan.t000444001750001750 101011355135015 20616 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl # use strict; use warnings; use File::Spec; use Test::More; use English qw(-no_match_vars); if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::Perl::Critic; }; if ($EVAL_ERROR) { my $msg = 'Test::Perl::Critic required to criticise code'; plan( skip_all => $msg ); } my $rcfile = File::Spec->catfile( 't', 'perlcriticrc' ); Test::Perl::Critic->import( -profile => $rcfile ); all_critic_ok(); leaktrace.t000444001750001750 22511355135015 17377 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/tuse Test::More tests => 1; use Test::LeakTrace; no_leaks_ok { use Ticket::Simple; my $object = Ticket::Simple->new(); } 'no memory leaks'; 10.init_tests.t000444001750001750 72511355135015 20055 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl -w use warnings; use strict; use Test::More tests => 5; BEGIN { use_ok( 'Ticket::Simple' ); } # Test ts creation for Ticket::Simple my $ts = Ticket::Simple->new(); ok( $ts, '->new returns true' ); ok( ref $ts, '->new returns a reference' ); isa_ok( $ts, 'SCALAR' , '->new returns a hash reference' ); isa_ok( $ts, 'Ticket::Simple', '->new returns a Ticket::Simple object' ); #ok( scalar keys %$ts == 3, '->new returns an object with 3 attributes' ); 00.load.t000444001750001750 17711355135015 16607 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/tuse Test::More tests => 1; BEGIN { use_ok( 'Ticket::Simple' ); } diag( "Testing Ticket::Simple $Ticket::Simple::VERSION" ); 27_wipe_ticket.t000444001750001750 145311355135015 20307 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl -w use warnings; use strict; use Test::More tests => 8; BEGIN { use_ok('Ticket::Simple'); } my $ts = Ticket::Simple->new(); my ( $t1, $v1 ) = $ts->create_ticket( { login => 't' } ); ok( $ts->store_ticket( { login => 't', ticket => $t1, valid => $v1 } ), '- can store ticket' ); my ( $t2, $v2 ) = $ts->fetch_ticket( { login => 't' } ); ok( $t1 eq $t2, '- ticket are equal' ); ok( $v1 == $v2, '- valid until time is the same' ); ok( $ts->wipe_ticket( { login => 't' } ), '- wipe ticket call ok' ); my ( $t3, $v3 ) = $ts->fetch_ticket( { login => 't' } ); ok( $t3 eq "", '- ticket are equal' ); ok( $v3 == 0, '- valid until time is the same' ); ok( ( not $ts->is_ticket_valid( { login => 't', ticket => $t3, time => $v3 } ) ), '- is ticket NOT valid' ); 20_now.t000444001750001750 60211355135015 16547 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl -w use warnings; use strict; use Test::More tests => 4; use Time::HiRes qw(gettimeofday); BEGIN { use_ok('Ticket::Simple'); } my ( $s1, $ms1 ) = gettimeofday; my $ts = Ticket::Simple->new(); my $n = $ts->now(); my ( $s2, $ms2 ) = gettimeofday; ok( $n, '- now returns true' ); ok( $n > "$s1.$ms1", '- now > before' ); ok( $n < "$s2.$ms2", '- now < after' ); 21_create_ticket.t000444001750001750 222311355135015 20574 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl -w use warnings; use strict; use Test::More tests => 13; use Digest::MD5 qw(md5_hex); use Time::HiRes qw(gettimeofday); BEGIN { use_ok('Ticket::Simple'); } my ( $s1, $ms1 ) = gettimeofday; my $ts = Ticket::Simple->new(); my ( $t, $v ) = $ts->create_ticket( { login => 'test' } ); my ( $s2, $ms2 ) = gettimeofday; ok( $t, '- crate_ticket returns ticket' ); ok( $v, '- create_ticket returns valid until time' ); ok( $v > "$s1.$ms1", '- now > before' ); ok( $v > "$s2.$ms2", '- now > after, if not ttl wrong' ); #diag( "ticket [$t]"); ok( ( length $t ) == 32, '- lenght ok' ); my ( $t1, $v1 ) = $ts->create_ticket( { login => 'test', time => "$s1.$ms1" } ); ok( $t1, '- crate_ticket returns ticket' ); ok( $v1, '- create_ticket returns valid until time' ); ok( $v1 > "$s1.$ms1", '- now > before' ); ok( $v1 > "$s2.$ms2", '- now > after, if not ttl wrong' ); ok( ( length $t1 ) == 32, '- lenght ok' ); my ( $t2, $v2 ) = $ts->create_ticket( { login => 'test', time => "$s1.$ms1" } ); ok( $t1 eq $t2, '- recreated ticket is the same' ); ok( $v1 == $v2, '- recreated vaild until time is the same' ); pod-coverage.t000444001750001750 47111355135015 20022 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl -T use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } all_pod_coverage_ok(); 22_store_ticket.t000444001750001750 44411355135015 20451 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl -w use warnings; use strict; use Test::More tests => 2; BEGIN { use_ok('Ticket::Simple'); } my $ts = Ticket::Simple->new(); my ( $t, $v ) = $ts->create_ticket( { login => 't' } ); ok( $ts->store_ticket( { login => 't', ticket => $t, valid => $v } ), '- can store ticket' ) 23_fetch_ticket.t000444001750001750 75511355135015 20414 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl -w use warnings; use strict; use Test::More tests => 4; BEGIN { use_ok('Ticket::Simple'); } my $ts = Ticket::Simple->new(); my ( $t1, $v1 ) = $ts->create_ticket( { login => 't' } ); ok( $ts->store_ticket( { login => 't', ticket => $t1, valid => $v1 } ), '- can store ticket' ); my ( $t2, $v2 ) = $ts->fetch_ticket( { login => 't' } ); ok( $t1 eq $t2, '- ticket are equal' ); ok( $v1 == $v2, '- valid until time is the same' ); #diag("t1 [$t1] t2 [$t2] v1 [$v1] v2 [$v2]"); pod.t000444001750001750 21411355135015 16224 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); 24_is_ticket_equal_stored.t000444001750001750 61711355135015 22503 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl -w use warnings; use strict; use Test::More tests => 3; BEGIN { use_ok('Ticket::Simple'); } my $ts = Ticket::Simple->new(); my ( $t1, $v1 ) = $ts->create_ticket( { login => 't' } ); ok( $ts->store_ticket( { login => 't', ticket => $t1, valid => $v1 } ), '- can store ticket' ); ok( $ts->is_ticket_equal_stored( { login => 't', ticket => $t1 } ), '- is_ticket_equal_stored' ); 25_is_ticket_valid.t000444001750001750 127711355135015 21137 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl -w use warnings; use strict; use Test::More tests => 5; BEGIN { use_ok('Ticket::Simple'); } my $ts = Ticket::Simple->new(); my ( $t1, $v1 ) = $ts->create_ticket( { login => 't' } ); ok( $ts->store_ticket( { login => 't', ticket => $t1, valid => $v1 } ), '- can store ticket' ); ok( $ts->is_ticket_valid( { login => 't', ticket => $t1, time => $v1 } ), '- is_ticket_valid' ); my $n = $ts->now(); ok( $ts->is_ticket_valid( { login => 't', ticket => $t1, time => $n } ), '- is_ticket_valid even now' ); ok( ( not $ts->is_ticket_valid( { login => 't', ticket => $t1, time => ( $n + 3000000 ) } ) ), '- is_ticket_valid not in teh future' ); refcount.t000444001750001750 36511355135015 17276 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/tuse Test::More tests => 2; use Test::Refcount; use Ticket::Simple; my $object = Ticket::Simple->new(); is_oneref( $object, '$object has a refcount of 1' ); my $otherref = $object; is_refcount( $object, 2, '$object now has 2 references' ); 29_is_ticket_valid_now.t000444001750001750 57711355135015 22010 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl -w use warnings; use strict; use Test::More tests => 3; BEGIN { use_ok('Ticket::Simple'); } my $ts = Ticket::Simple->new(); my ( $t1, $v1 ) = $ts->create_ticket( { login => 't' } ); ok( $ts->store_ticket( { login => 't', ticket => $t1, valid => $v1 } ), '- can store ticket' ); ok( $ts->is_ticket_valid_now( { login => 't', ticket => $t1 }),'- is_ticket_valid' ); 26_ttl.t000444001750001750 55711355135015 16566 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/t#!perl -w use warnings; use strict; use Test::More tests => 4; BEGIN { use_ok('Ticket::Simple'); } my $ts = Ticket::Simple->new( { ttl => 2000 } ); ok( $ts, 'new with ttl param works' ); my $ttl = $ts->get_ttl; ok( $ttl == 2000, '- got ttl out of the sytsem' ); $ts->set_ttl(3000); my $ttl2 = $ts->get_ttl; ok( $ttl2 == 3000, '- got ttl out of the sytsem' ); lib000755001750001750 011355135015 15446 5ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2Ticket000755001750001750 011355135015 16671 5ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/libSimple.pm000444001750001750 2415411355135015 20643 0ustar00ckuelkerckuelker000000000000Ticket-Simple-0.0.2/lib/Ticket# +=========================================================================+ # || Ticket::Simple || # || A basic ticket system || # +=========================================================================+ # Id: $Id$ # Rev: $Revision$ # Source: $Source$ # Date: $Date$ # URL: $HeadURL$ package Ticket::Simple; use strict; use warnings; use Carp qw(confess); use Class::Std; use Digest::MD5 qw(md5_hex); use Log::Log4perl qw(get_logger :levels); use Readonly; use Time::HiRes qw(gettimeofday); { # begin insite out class # PRIVATE METHODS # - seed # PUBLIC METHODS # - create_ticket use version; our $VERSION = qv('v0.0.2'); use re 'taint'; # Keep data captured by parens tainted delete @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; # Make %ENV safe # CONST Readonly::Scalar my $EMPTY_STRING => q{}; Readonly::Scalar my $TICKET_LENGTH => 32; Readonly::Scalar my $SEED_LENGTH => 1282; Readonly::Array my @RND_SEED_CHARS => ( 'A' .. 'Z', 'a' .. 'z', 0 .. 9, qw(! @ $ % &) ); Readonly::Scalar my $SEED => seed(); Readonly::Scalar my $TTL => 600; # in sec # OBJ ## no critic my %ttl_of : ATTR( init_arg =>'ttl' :get :set :default(600)); # GLOBAL my %cred = (); # define a closure for log4perl my $ifdef = sub { my $v = shift; return sub { return $v if defined $v; return 'UNDEF'; }; }; sub now { my ( $self, $p_r ) = @_; my $l = get_logger(__PACKAGE__); my ( $seconds, $microseconds ) = gettimeofday; $l->debug("time now [$seconds] seconds"); $l->debug("time now [$microseconds] micro-seconds"); my $now = "$seconds.$microseconds"; $l->debug("time now [$now] time"); return $now; } sub create_ticket { my ( $self, $p_r ) = @_; my $msg = 'parameter [login] is missing in sub call [create_ticket]'; my $login = exists $p_r->{login} ? $p_r->{login} : confess $msg; my $time = exists $p_r->{time} ? $p_r->{time} : $self->now; my $l = get_logger(__PACKAGE__); # prepare $l->debug("input parameter login: [$login]"); $l->debug("global parameter SEED: [$SEED]"); my $ttl = ( exists $ttl_of{ ident $self} and defined > $ttl_of{ ident $self} and $ttl_of{ ident $self} > 0 ) ? $ttl_of{ ident $self} : $TTL; $l->debug( 'ttl: ', $ttl ); # main my ( $seconds, $microseconds ) = split m{\.}mx, $time; $l->debug("time [$seconds] seconds"); $l->debug("time [$seconds] micro-seconds"); my $valid = $seconds + $ttl . ".$microseconds"; $l->debug("valid until [$valid] seconds.micro-seconds"); my $ticket = md5_hex( join $EMPTY_STRING, $valid, $SEED, $login ); $l->info("new ticket [$ticket]"); return ( $ticket, $valid ); } sub wipe_ticket { my ( $self, $p_r ) = @_; my $msg = 'parameter [login] is missing in sub call [wipe_ticket]'; my $login = exists $p_r->{login} ? $p_r->{login} : confess $msg; $self->store_ticket( { login => $login, ticket => $EMPTY_STRING, valid => 0 } ); return 1; } sub destroy_ticket { my ( $self, $p_r ) = @_; my $msg = 'parameter [login] is missing in sub call [destroy_ticket]'; my $login = exists $p_r->{login} ? $p_r->{login} : confess $msg; $self->store_ticket( { login => $login, ticket => undef, valid => undef } ); return 1; } sub fetch_ticket { my ( $self, $p_r ) = @_; my $msg = 'parameter [login] is missing in sub call [fetch_ticket]'; my $login = exists $p_r->{login} ? $p_r->{login} : confess $msg; my $ticket = $cred{$login}->{ticket}; my $valid = $cred{$login}->{valid}; return ( $ticket, $valid ); } sub store_ticket { my ( $self, $p_r ) = @_; my $m = 'parameter [login] is missing in sub call [store_ticket]'; my $l = exists $p_r->{login} ? $p_r->{login} : confess $m; $m = 'parameter [ticket] is missing in sub call [store_ticket]'; my $t = exists $p_r->{ticket} ? $p_r->{ticket} : confess $m; $m = 'parameter [valid] is missing in sub call [store_ticket]'; my $v = exists $p_r->{valid} ? $p_r->{valid} : confess $m; my $go = get_logger(__PACKAGE__); # undef can be stored also (see destroy) $go->debug( 'login: ', { filter => $ifdef->($l) } ); $go->debug( 'ticket: ', { filter => $ifdef->($t) } ); $go->debug( 'value: ', { filter => $ifdef->($v) } ); $cred{$l} = { ticket => $t, valid => $v, }; return 1; } sub is_ticket_equal_stored { my ( $self, $p_r ) = @_; my $msg = 'parameter [login] is missing in sub call [store_ticket]'; my $login = exists $p_r->{login} ? $p_r->{login} : confess $msg; $msg = 'parameter [ticket] is missing in sub call [store_ticket]'; my $ticket = exists $p_r->{ticket} ? $p_r->{ticket} : confess $msg; my ( $stored_ticket, $valid ) = $self->fetch_ticket( { login => $login } ); if ( $stored_ticket eq $ticket ) { return 1; } else { return 0; } } sub is_ticket_valid_now { my ( $self, $p_r ) = @_; my $msg = 'parameter [login] is missing in sub call [store_ticket]'; my $login = exists $p_r->{login} ? $p_r->{login} : confess $msg; $msg = 'parameter [ticket] is missing in sub call [store_ticket]'; my $ticket = exists $p_r->{ticket} ? $p_r->{ticket} : confess $msg; my $r = $self->is_ticket_valid( { login => $login, ticket => $ticket, time => $self->now } ); return $r; } sub is_ticket_valid { my ( $self, $p_r ) = @_; my $m = 'param. [login] is missing in sub call [is_ticket_valid]'; my $l = exists $p_r->{login} ? $p_r->{login} : confess $m; $m = 'param. [ticket] is missing in sub call [is_ticket_valid]'; my $t = exists $p_r->{ticket} ? $p_r->{ticket} : confess $m; $m = 'param. [time] is missing in sub call [is_ticket_valid]'; my $j = exists $p_r->{time} ? $p_r->{time} : confess $m; my $go = get_logger(__PACKAGE__); my ( $s, $v ) = $self->fetch_ticket( { login => $l } ); if ( defined $s and defined $t and $s eq $t and length $t == $TICKET_LENGTH and defined $j and defined $v and $j <= $v and $j > 0 ) { return 1; # SUCCESS } else { $go->debug( 'login: ', { filter => sub { return $l if defined $l } } ); $go->debug( 'login: ', { filter => $ifdef->($l) } ); $go->debug( 'got ticket: ', { filter => $ifdef->($t) } ); $go->debug( 'stored ticket: ', { filter => $ifdef->($s) } ); $go->debug( 'got valid: ', { filter => $ifdef->($j) } ); $go->debug( 'stored valid: ', { filter => $ifdef->($v) } ); return 0; # FAILURE } return 0; # FAILURE } sub seed : PRIVATE { # sub will be executed in readonly section! Log::Log4perl::init_once( log_cfg() ); my $l = get_logger(__PACKAGE__); # Calculating secret random seed for this session # "S ISp&FtR0z$EU!We8DvpUzC26D0RE1pVW8vSXp9at5RUwXk # WesmQvJY!w!LrLHdo^wB7f6lr7U9PGPTYhxTI!PhKjXhMmZZK # ckIi^Qbl&g^$Qir!9S5LIoo!J1bX*OHVw" srand; my @chars = @RND_SEED_CHARS; my $seed = join q{}, @chars[ map { rand @chars } ( 1 .. $SEED_LENGTH ) ]; $l->debug("new seed [$seed]"); return $seed; } sub log_cfg { my $cfg = <<'EOF'; log4perl.category.Ticket::Simple = WARN, S log4perl.appender.S = Log::Log4perl::Appender::ScreenColoredLevels log4perl.appender.S.stderr = 0 log4perl.appender.S.layout = Log::Log4perl::Layout::PatternLayout log4perl.appender.S.layout.ConversionPattern = %d{yyyy-MM-dd+HH:mm:ss} %M <%L>: %m%n EOF return \$cfg; } } # end insite out class 1; __END__ =pod =for stopwords Christian Kuelker log_cfg =head1 NAME Ticket::Simple - A basic ticket system. =head1 VERSION version v0.0.2 =head1 SYNOPSIS my $ts=Ticket::Simple->new(); or my $ts=Ticket::Simple->new({ttl=>600}); =head1 DESCRIPTION Provides a simple ticket system for creating, storing, fetching, comparing user assigned tickets. =head1 SUBROUTINES/METHODS =head2 create_ticket =head2 wipe_ticket =head2 destroy_ticket =head2 fetch_ticket =head2 is_ticket_equal_stored =head2 is_ticket_valid =head2 is_ticket_valid_now Test if the ticket was issued =head2 now =head2 seed =head2 store_ticket =head2 log_cfg =head2 set_ttl =head2 get_ttl =head1 DIAGNOSTICS =head1 CONFIGURATION AND ENVIRONMENT No external configuration needed. =head1 DEPENDENCIES Carp; Class::Std Digest::MD5 Log::Log4perl Readonly Time::HiRes version =head1 INCOMPATIBILITIES Not known. =head1 BUGS AND LIMITATIONS Not known. =head1 AUTHOR Christian Kuelker Echristian.kuelker@cipworx.orgE =head1 LICENSE AND COPYRIGHT Copyright (C) 2009 by Christian Kuelker This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut