view release on metacpan or  search on metacpan

eg/demo.pl  view on Meta::CPAN

}

my $NOT_EXISTS = quotemeta 'Object does not exist in the data store';

run() if not caller; # if you require this, you'll need to call demo::run()

sub TEST_FONT_EXISTENCE {
   if ( not $config{use_magick} ) {
      if ( $config{font} =~ m{\s}xms ) {
         croak "The font path '$config{font}' has a space in it. GD hates spaces!";
      }
   }
   require IO::File;
   my $FONTFILE = IO::File->new;
   if ( $FONTFILE->open( $config{font} ) ) {
      $FONTFILE->close;
   }
   else {
      croak qq~I can not open/find the font file in '$config{font}': $!~;
   }
   return;
}

sub new {
   TEST_FONT_EXISTENCE();
   my $class = shift;
   my $self  = {
      ISDISPLAY => 0,
      SID       => undef,
      CPAN      => 'http://search.cpan.org/dist',
      IS_GD     => 0,
   };
   bless $self, $class;
   return $self;
}

sub config { return \%config }

sub run {
   local $SIG{__DIE__} = sub {
      print header . <<"ERROR" or croak "Can not print to STDOUT: $!";
         <h1 style="color:red;font-weight:bold"
            >FATAL ERROR</h1>
         @_
ERROR
      exit;
   };

   my $START = Time::HiRes::time();
   my $self  = shift || __PACKAGE__->new;

   GD::SecurityImage->import( use_magick => $config{use_magick} );

   $self->{IS_GD}   = $GD::SecurityImage::BACKEND eq 'GD';
   $self->{cgi}     = CGI->new;
   $self->{program} = $config{program};
   if ( ! $self->{program} ){
      # it is possible to get the url as "demo.pl??foo=bar"
      my $url = $self->{cgi}->can('self_url') ? $self->{cgi}->self_url
                                              : $self->{cgi}->url;
      ($self->{program}, my @jp) = split m{[?]}xms, $url;
   }

   my %options      = $self->all_options;
   my %styles       = $self->all_styles;
   my @optz         = keys %options;
   my @styz         = keys %styles;

   $self->{rnd_opt} = $options{ $optz[ int rand @optz ] };
   $self->{rnd_sty} = $styles{  $styz[ int rand @styz ] };

   # our database handle
   my $dbh = DBI->connect(
                "DBI:mysql:$config{database}",
                @config{ qw/ user pass / },
                {
                   RaiseError => 1,
                }
             );

   my %session;
   my $create_ses = sub { # fetch/create session
      my $sid = @_ ? undef : $self->{cgi}->cookie('GDSI_ID');
      tie %session, 'Apache::Session::MySQL', $sid, { ## no critic (Miscellanea::ProhibitTies)
         Handle     => $dbh,
         LockHandle => $dbh,
         TableName  => $config{table_name},
      };
   };

   my $eok = eval { $create_ses->(); 1; };

   # I'm doing a little trick to by-pass exceptions if the session id
   # coming from the user no longer exists in the database. 
   # Also, I'm not validating the session key here, you can also check
   # IP and browser string to validate the session. 
   # It is also possible to put a timeout value for security_code key.
   # But, all these and anything else are all beyond this demo...
   if ( $@ && $@ =~ m{ \A $NOT_EXISTS }xms ) {
      $create_ses->('new');
   }

   if ( ! $session{security_code} ) {
      $session{security_code} = $self->_random; # initialize random code
   }

   $self->{ISDISPLAY} = $self->{cgi}->param('display') || 0;
   $self->{SID}       = $session{_session_id};
   my $output         = q{}; # output buffer

   if ( $self->{ISDISPLAY} ) {
      $START = Time::HiRes::time();
      my($image, $mime, $random) = $self->create_image($session{security_code}, $START );
      $output  = $self->myheader(type => "image/$mime");
      $output .= $image;
      binmode STDOUT;
   }
   else {
      $output  = $self->myheader . $self->html_head;
      $output .= $self->{cgi}->param('process') ? $self->process( $session{security_code} )
               : $self->{cgi}->param('help')    ? $self->help