package ClockPerl;
use constant NL => qq[\012];
use vars qw/ $VERSION /;
$VERSION = 1.00;

=pod

   AUTHOR
      Tommy Butler <cpan@atrixnet.com>
      phone: (817)-468-7716
      6711 Forest Park Dr
      Arlington, TX
           76001-8403

   COPYRIGHT   Copyright (C) Tommy Butler  2002
   LISCENCE
         This software is free, and you may use
         and distribute it under the same terms
         as Perl itself.

=cut

# --------------------------------------------------------
# Constructor
# --------------------------------------------------------
sub new {

   my($class)  = shift;
   my($main)   = shift;
   my($this)   = {};
   my($name)   = __PACKAGE__;

   # -------------------------------------------
   # bless object ref into the class' namespace
   # -------------------------------------------
   bless($this, $class);


   # -------------------------------------------
   # begin setting up class attributes
   # -------------------------------------------
   $this->{'name'}   = $name;
   $this->{'main'}   = $main;


   # -------------------------------------------
   # finish by verifying class attributes
   # -------------------------------------------
   $this->verify_attributes();

   # return object reference
   return($this);
}


# --------------------------------------------------------
# ClockPerl::verify_attributes()
# --------------------------------------------------------
sub verify_attributes {

   my($this) = shift;
   my($name) = $this->{'name'};
   my($main) = $this->{'main'};

   $this->quit(qq[$name needs a reference to the caller's namespace.])
      if not $main;

   return(1);
}


# --------------------------------------------------------
# ClockPerl::benchsub()
# --------------------------------------------------------
sub benchsub {

   no strict 'refs';

   my($this)   = shift;
   my($sub)    = shift;
   my(@args)   = (@_,'');
   my($pak)    = $this->{'main'}{'PACKAGE'};

   $pak ||= ''; $sub ||= '';

   my($start) = 0; my($end) = 0;

   open(TRASH, '>tmp.txt'); select TRASH;

   $start = $this->startsub($sub);

   eval($pak->$sub(@args));

   $end = $this->endsub($sub);

   truncate(TRASH,0); close(TRASH); select STDOUT;

   $this->format_results($sub,$start,$end)
}


# --------------------------------------------------------
# ClockPerl::startsub()
# --------------------------------------------------------
sub startsub {

   my($this) = shift;
   my($sub)  = @_;

   $this->{'STARTSUB'}{ $sub } = (times)[0];

   push( @{ $this->{'list'} }, $sub );

   return( $this->{'STARTSUB'}{ $sub } );
}



# --------------------------------------------------------
# ClockPerl::endsub()
# --------------------------------------------------------
sub endsub {

   my($this) = shift;
   my($sub)  = @_;

   $this->{'ENDSUB'}{ $sub } = (times)[0];

   push( @{ $this->{'list'} }, $sub );

   return( $this->{'ENDSUB'}{ $sub } );
}


# --------------------------------------------------------
# ClockPerl::startmark()
# --------------------------------------------------------
sub startmark {

   my($this,$markid) = @_;

   ++$this->{'current_set'};

   $markid ||= $this->{'current_set'};

   $this->{'STARTMARK'}{ $markid } = (times)[0];

   return( $this->{'STARTMARK'}{ $markid } );
}



# --------------------------------------------------------
# ClockPerl::endmark()
# --------------------------------------------------------
sub endmark {

   my($this,$markid) = @_;

   $markid ||= $this->{'current_set'};

   $this->{'ENDMARK'}{ $markid } = (times)[0];

   return( $this->{'ENDMARK'}{$markid} );
}



# --------------------------------------------------------
# ClockPerl::timediff()
# --------------------------------------------------------
sub timediff {

   my($this,$markid) = @_;

   $markid ||= $this->{'current_set'};

   $this->format_results(
      qq[start mark #$i to finish mark #$i],
      $this->{'STARTMARK'}{ $markid },
      $this->{'ENDMARK'}{ $markid } )
}



# --------------------------------------------------------
# ClockPerl::format_results()
# --------------------------------------------------------
sub format_results {

   my($this,$sub,$start,$end) = @_;

   $sub ||= '(unnamed subroutine)'; $start ||= 0; $end ||= 0;

   sprintf qq[execution time for $sub: %.5f secs] . NL x 2, $end - $start
}


# --------------------------------------------------------
# ClockPerl::quit()
# --------------------------------------------------------
sub quit {

   my($this) = shift;

   print( qq[Content-Type: text/html] . NL x 2 )
      if (scalar(@{ $this->{'main'}{'ARGV'} }) == 0);

   print( qq[process terminated due to errors...] ) and die $this->trace(@_)
}


# --------------------------------------------------------
# ClockPerl::trace()
# --------------------------------------------------------
sub trace {

   my($this) = shift;
   my($main) = $this->{'main'};
   my(@errors) = @_;
   my($errfile) = '';

   my( $pak,      $filename,
       $linenum,  $subroutine,
       $hasargs,  $wantarray,
       $evaltext, $req_OR_use,
       @ClockPerl,    $trace,
       $i );

   while (
          (
            $pak,      $filename,
            $linenum,  $subroutine,
            $hasargs,  $wantarray,
            $evaltext, $req_OR_use
          ) = caller( ++$i )
         ) {

      push
         (
            @ClockPerl,
            NL . ' ' x 9 . qq[$i.) $subroutine] .
            NL . ' ' x 12 .
            qq[at line ($linenum) of $filename]
         );
   }

   $i = 0;

   foreach (@errors) {

      ++$i;

      if (length($_) == 0) {

         $_ = NL . ' ' x 9 . qq[$i.) Something is wrong at error number $i...]
      }
      else { $_ = NL . ' ' x 9 . qq[$i.) $_] }
   }

   $trace = join(NL x 2,( reverse( @ClockPerl ), qq[Errors:] . NL x 2 ));

   $trace .= join(NL x 2,@errors);

   return
      (
         NL x 2

         . ('-' x 70)

         . NL x 2

         . qq[Stack trace:] . NL x 2

         . $trace

         . NL x 2

         . ('-' x 70)

         . NL x 2
      );
}

# --------------------------------------------------------
# end ClockPerl Class, return true on import
# --------------------------------------------------------

1;