view release on metacpan or  search on metacpan

lib/Bio/Polloc/Polloc/Root.pm  view on Meta::CPAN

      my $msg = "" . ($TIMESTAMP ? "[".time()."] " : '') . ref($self) . " | " . join(' ', @txt) . "\n";
      if(defined $self->DEBUGLOG){ $self->DEBUGLOG->_print($msg) }
      else{ print STDERR $msg }
   }
}


=head2 warn

Launches a warning message.  If verbosity is greater than two, the
message becomes a C<throw>.

=cut

sub warn {
   my ($self, $txt, $value) = @_;
   my $verb = $self->verbosity;
   return if $verb==-1;
   $self->throw($txt,$value,'Bio::Polloc::Polloc::LoudWarningException') if $verb >=3;
   my $out = "\n" . ("-"x10) . " WARNING " . ("-"x10) . "\n" .
   	"MSG: " . $txt . "\n" ;
   $out.= "VALUE: $value - ".ref($value)."\n" if defined $value;
   if($verb>=1){
      $out.= $self->stack_trace_dump;
   }
   $out.= ("-"x29) . "\n";
   print STDERR $out;
   return;
}


=head2 stack_trace_dump

=cut

sub stack_trace_dump {
   my $self = shift;
   my @stack = $self->stack_trace;

   shift @stack; # stack_trace
   shift @stack; # stack_trace_dump
   shift @stack; # error_msg

   my $out = "";
   for my $stack ( @stack ){
      my ($module, $file, $position, $function) = @{$stack};
      $out.= "STACK $function $file:$position\n";
   }
   return $out;
}

=head2 strack_trace

=cut

sub stack_trace {
   my $self = shift;
   my $i = 0;
   my @out = ();
   my $prev = [];
   while( my @call = caller($i++)){
      $prev->[3] = $call[3];
      push @out, $prev;
      $prev = \@call;
   }
   $prev->[3] = 'toplevel';
   push @out, $prev;
   return @out;
}


=head2 vardump

Attempts to display all the content of a given object

=head3 Arguments

Some object (any type)

=head3 Returns

Nothing, the result is sent to STDOUT

=cut

sub vardump {
	my ($self,$value) = @_;
	if(!defined $value){
		print "\nundef.\n";
	}elsif(ref($value) =~ /hash/i){
		print "{\n";
		for my $k ( keys %$value ){
			print "$k=>";
			$self->vardump($value->{$k});
			print "\n";
		}
		print "\n}\n";
	}elsif(ref($value) =~ /array/i){
		print "[\n";
		for (@$value){
			$self->vardump($_);
			print "\n";
		}
		print "\n]\n";
	}else{
		print $value;
	}
}

=head2 rrmdir

Recursively removes a directory.

=cut

sub rrmdir {
   my ($self, $dir) = @_;
   return unless -d $dir;
   while(my $file = <$dir/*>){
      next if $file =~ /^\.\.?$/;
      $file = Bio::Polloc::Polloc::IO->catfile($dir, $file);