throw results from the CPAN

throw

App-Framework-Lite

view release on metacpan or search on metacpan

inc/Module/Install.pm view on Meta::CPAN

	# is unreliable on some platforms and requires write permissions)
	# for now we should catch this and refuse to run.
	if ( -f $0 ) {
		my $s = (stat($0))[9];

		# If the modification time is only slightly in the future,
		# sleep briefly to remove the problem.
		my $a = $s - time;
		if ( $a > 0 and $a < 5 ) { sleep 5 }

		# Too far in the future, throw an error.
		my $t = time;
		if ( $s > $t ) { die <<"END_DIE" }

Your installer $0 has a modification time in the future ($s > $t).

This is known to create infinite loops in make.

Please correct this, then run $0 again.

END_DIE

lib/App/Framework/Lite.pm view on Meta::CPAN


		my ($arg_spec, $summary, $description, $default_val) = @$arg_entry_aref ;
		
		## Process the arg spec
		my ($name, $pod_spec, $dest_type, $arg_type, $arg_direction, $arg_optional, $arg_append, $arg_mode) ;
		($name, $arg_spec, $pod_spec, $dest_type, $arg_type, $arg_direction, $arg_optional, $arg_append, $arg_mode) =
			$this->_process_arg_spec($arg_spec) ;

		if ($last_dest_type)
		{
			$this->throw_fatal("Application definition error: arg $name defined after $last_dest_type defined as array") ;
		}
		$last_dest_type = $name if $dest_type ;
		
		# Set default if required
		$args_href->{$name} = $default_val if (defined($default_val)) ;

		# See if optional
		$arg_optional++ if defined($default_val) ;
		if ($optional && !$arg_optional)
		{
			$this->throw_fatal("Application definition error: arg $name should be optional since previous arg is") ;
		}		
		$optional ||= $arg_optional ;

$this->_dbg_prt(["Args: update() - arg_optional=$arg_optional optional=$optional\n"]) ;
		
		# Create full entry
		my $href = $this->_new_arg_entry($name, $arg_spec, $summary, $description, $default_val, $pod_spec, $arg_type, $arg_direction, $dest_type, $optional, $arg_append, $arg_mode) ;
		$args_names_href->{$name} = $href ;

$this->_dbg_prt(["Arg $name HASH=", $href], 2)   ;

lib/App/Framework/Lite.pm view on Meta::CPAN


=item B<required([$required_href])>

Get/set the required programs list. If specified, B<$required_href> is a HASH ref where the 
keys are the names of the required programs (the values are unimportant).

This method returns the B<$required_href> HASH ref having set the values associated with the
program name keys to the path for that program. Where a program is not found then
it's path is set to undef.

Also, if the L</on_error> field is set to 'warning' or 'fatal' then this method throws a warning
or fatal error if one or more required programs are not found. Sets the message string to indicate 
which programs were not found. 

=cut

sub required
{
	my $this = shift ;
	my ($new_required_href) = @_ ;

lib/App/Framework/Lite.pm view on Meta::CPAN

			{
				$required_href->{$exe} = which($exe) ;
			}
			else
			{
				$required_href->{$exe} = 1 ;
			}
		}
		
		## check for errors
		my $throw = $this->_throw_on_error($this->{on_error}) ;
		if ($throw)
		{
			my $error = "" ;
			foreach my $exe (keys %$new_required_href)
			{
				if (!$required_href->{$exe})
				{
					$error .= "  $exe\n" ;
				}
			}
			
			if ($error)
			{
				$this->$throw("The following programs are required but not available:\n$error\n") ;
			}
		}
	}
	
	return $required_href ;
}

#--------------------------------------------------------------------------------------------

=item B<run( [args] )>

lib/App/Framework/Lite.pm view on Meta::CPAN

	my %set ;
	foreach my $key (qw/debug/)
	{
		$set{$key} = $args{$key} if exists($args{$key}) ;
	}
	$this->set(%set) if keys %set ;
	

	# Get command
	my $cmd = $local{'cmd'} ;
	$this->throw_fatal("command not specified") unless $cmd ;
	
	# Add niceness
	my $nice = $local{'nice'} ;
	if (defined($nice))
	{
		$cmd = "nice -n $nice $cmd" ;
	}
	
	
	# clear vars

lib/App/Framework/Lite.pm view on Meta::CPAN


	# Update vars
	$this->{'status'} = $rc ;
	chomp foreach (@results) ;
	$this->{'results'} = \@results ;

	$this->_logging('results', \@results) ;
	$this->_logging('status', "Status: $rc\n") ;
	
	## Handle non-zero exit status
	my $throw = $this->_throw_on_error($local{'on_error'}) ;
	if ($throw && $rc)
	{
		my $results = join("\n", @results) ;
		my $error_str = $local{'error_str'} ;
		$this->$throw("Command \"$cmd $args\" exited with non-zero error status $rc : \"$error_str\"\n$results\n") ;
	}
	
	return($this) ;
}

#----------------------------------------------------------------------------

=item B< Run([%args]) >

Alias to L</run>

lib/App/Framework/Lite.pm view on Meta::CPAN

	my $state_href = {} ;
	my $linenum = 0 ;

	# Run inside eval to catch timeout		
	my $pid ;
	my $rc = 0 ;
	my $endtime = (time + $timeout) ;
	eval 
	{
		alarm($timeout);
		$pid = open my $proc, "$cmd $args |" or $this->throw_fatal("Unable to fork $cmd : $!") ;

		while(<$proc>)
		{
			chomp $_ ;
			push @results, $_ ;

			++$linenum ;

			# if it's defined, call the progress checker for each line
			if (defined($progress))

lib/App/Framework/Lite.pm view on Meta::CPAN

		{
print "timed out - stopping command pid=$pid...\n" if $this->{'debug'} ;
			# timed out  - stop command
			kill('INT', $pid) ;
		}
		else
		{
print "unexpected end of program : $@\n" if $this->{'debug'} ; 			
			# Failed
			alarm(0) ;
			$this->throw_fatal( "Unexpected error while timing out command \"$cmd $args\": $@" ) ;
		}
	}
	alarm(0) ;

print "exit program\n" if $this->{'debug'} ; 

	# if it's defined, call the results checker for each line
	$rc ||= $this->_check_results(\@results, $check_results) ;

	return($rc, @results) ;

lib/App/Framework/Lite.pm view on Meta::CPAN

	if (defined($check_results))
	{
		$rc = &$check_results($results_aref) ;
	}

	return $rc ;
}


#----------------------------------------------------------------------
# If the 'on_error' setting is not 'status' then return the "throw" type
#
sub _throw_on_error
{
	my $this = shift ;
	my ($on_error) = @_ ;
	$on_error ||= $ON_ERROR_DEFAULT ;
	
	my $throw = "";
	if ($on_error ne 'status')
	{
		$throw = 'throw_fatal' ;
		if ($on_error =~ m/warn/i)
		{
			$throw = 'throw_warning' ;
		}
	}

	return $throw ;
}






#============================================================================================
# LOGGING
#============================================================================================

lib/App/Framework/Lite.pm view on Meta::CPAN

	## Log
	my $logfile = $this->{logfile} ;
	if ($logfile)
	{
		## start if we haven't yet
		if (!$this->{_started})
		{
			$this->_start_logging() ;
		}

		open my $fh, ">>$logfile" or $this->throw_fatal("Error: unable to append to logfile \"$logfile\" : $!") ;
		print $fh $tolog ;
		close $fh ;
	}

	## Echo
	if ($this->{to_stdout})
	{
		print $tolog ;
	}

lib/App/Framework/Lite.pm view on Meta::CPAN


	my $logfile = $this->{logfile} ;
	if ($logfile)
	{
		my $mode = ">" ;
		if ($this->{mode} eq 'append')
		{
			$mode = ">>" ;
		}
		
		open my $fh, "$mode$logfile" or $this->throw_fatal("Unable to write to logfile \"$logfile\" : $!") ;
		close $fh ;
		
		## set flag
		$this->{_started} = 1 ;
	}
}	

#============================================================================================
# UTILITY
#============================================================================================

lib/App/Framework/Lite.pm view on Meta::CPAN


		# mark as expanded
		${$_state_href->{$key}} = 'expanded' ;		

$this->prt_data("State now=", $_state_href) if $this->{debug}>=2;
	}
}

#----------------------------------------------------------------------------

=item B<throw_fatal($message)>

Output error message then exit

=cut

sub throw_fatal
{
	my $this = shift ;
	my ($message, $errorcode) = @_ ;

	print "Fatal Error: $message\n" ;
	$this->exit( $errorcode || 1 ) ;
}

#-----------------------------------------------------------------------------

=item B<throw_nonfatal($message, [$errorcode])>

Add a new error (type=nonfatal) to this object instance, also adds the error to this Class list
keeping track of all runtime errors

=cut

sub throw_nonfatal
{
	my $this = shift ;
	my ($message, $errorcode) = @_ ;
	
	print "Non-Fatal Error: $message\n" ;
	return ($errorcode || 0) ;
}

#-----------------------------------------------------------------------------

=item B<throw_warning($message, [$errorcode])>

Add a new error (type=warning) to this object instance, also adds the error to this Class list
keeping track of all runtime errors

=cut

sub throw_warning
{
	my $this = shift ;
	my ($message, $errorcode) = @_ ;
	
	print "Warning: $message\n" ;
	return ($errorcode || 0) ;
}

#-----------------------------------------------------------------------------

=item B<throw_note($message, [$errorcode])>

Add a new error (type=note) to this object instance, also adds the error to this Class list
keeping track of all runtime errors

=cut

sub throw_note
{
	my $this = shift ;
	my ($message, $errorcode) = @_ ;
	
	print "Info: $message\n" ;
	return ($errorcode || 0) ;
}

#----------------------------------------------------------------------------

lib/App/Framework/Lite/Object.pm view on Meta::CPAN

=cut

sub field_access
{
	my $this = shift ;
	my ($field, $value) = @_ ;

	my $class = ref($this) || $this ;
	my %field_list = ();
	%field_list = %{ $FIELD_LIST{$class} } if exists($FIELD_LIST{$class}) ;
	$this->throw_fatal("Attempting to access an invalid field \"$field\" for this object class \"$class\" ") unless (exists($field_list{$field})) ;

	$this->{$field} = $value if defined($value) ;
	return $this->{$field} ;
}





#----------------------------------------------------------------------------

t/embed/lib/MyObj.pm view on Meta::CPAN


MyObj - Adds error handling to basic object

=head1 SYNOPSIS

use MyObj ;


=head1 DESCRIPTION

Any object derived from this class can throw an error and some registered error handler will catch (and handle) that error.

Hierarchy of catch handlers is:

	catch_fn set for this object instance
	any registered global catch function (last registered first)
	default handler
	
Global catch functions, when registered, are added to a stack so that the last one registered is called first.

Each handler must return either 1=handled, or 0=not handled to tell this object whether to move on to the next handler.

t/embed/lib/MyObj.pm view on Meta::CPAN

# OBJECT HIERARCHY
#============================================================================================
our @ISA = qw(App::Framework::Lite::Object) ; 

#============================================================================================
# GLOBALS
#============================================================================================

my %FIELDS = (
	'errors'	=> [],		# List of errors for this object
	'catch_fn'	=> undef,	# Function called if error is thrown
) ;

# Keep track of all errors
my @all_errors = () ;

# Error type priority
my %ERR_TYPES = (
	'fatal'		=> 0x80,
	'nonfatal'	=> 0x40,
	'warning'	=> 0x08,

t/embed/lib/MyObj.pm view on Meta::CPAN

}


#============================================================================================
# OBJECT METHODS 
#============================================================================================


#-----------------------------------------------------------------------------

=item B<_throw_error($error)>

Add a new error to this object instance, also adds the error to this Class list
keeping track of all runtime errors

=cut

sub _throw_error
{
	my $this = shift ;
	my ($error) = @_ ;
	
	# Add to this object's list
	push @{$this->errors()}, $error ;

	# Add to global list
	$this->_global_error($error) ;

t/embed/lib/MyObj.pm view on Meta::CPAN

	if (!$handled)
	{
		my ($msg, $exitcode) = $this->error_split($error) ;
		die "Unhandled Error: $msg ($exitcode)\n" ;
	}

}

#-----------------------------------------------------------------------------

=item B<rethrow_error($error_ref)>

Throws an error for this object based on an error object associated with a different object
 
=cut

sub rethrow_error
{
	my $this = shift ;
	my ($error) = @_ ;
	
	# Create copy of error
	my %err_copy = () ;
	foreach (keys %$error)
	{
		$err_copy{$_} = $error->{$_} ;
	}
	$err_copy{'parent'} = $this ;
	
	$this->_throw_error(\%err_copy) ;
	
}


#-----------------------------------------------------------------------------

=item B<throw_error([%args])>

Add a new error to this object instance, also adds the error to this Class list
keeping track of all runtime errors

%args hash contains:

	* type = fatal, nonfatal, warning, note
	* message = text message
	* errorcode = integer error code value

=cut

sub throw_error
{
	my $this = shift ;
	my (%args) = @_ ;
	
	# Convert args into an error
	my $error = _create_error('parent'=>$this, %args) ;

	$this->_throw_error($error) ;
	
}

#-----------------------------------------------------------------------------

=item B<throw_fatal($message, [$errorcode])>

Add a new error (type=fatal) to this object instance, also adds the error to this Class list
keeping track of all runtime errors

=cut

sub throw_fatal
{
	my $this = shift ;
	my ($message, $errorcode) = @_ ;
	
	# Convert args into an error
	$this->throw_error('type'=>'fatal', 'message'=>$message, 'errorcode'=>$errorcode) ;
	
}


#-----------------------------------------------------------------------------

=item B<throw_nonfatal($message, [$errorcode])>

Add a new error (type=nonfatal) to this object instance, also adds the error to this Class list
keeping track of all runtime errors

=cut

sub throw_nonfatal
{
	my $this = shift ;
	my ($message, $errorcode) = @_ ;
	
	# Convert args into an error
	$this->throw_error('type'=>'nonfatal', 'message'=>$message, 'errorcode'=>$errorcode) ;
	
}

#-----------------------------------------------------------------------------

=item B<throw_warning($message, [$errorcode])>

Add a new error (type=warning) to this object instance, also adds the error to this Class list
keeping track of all runtime errors

=cut

sub throw_warning
{
	my $this = shift ;
	my ($message, $errorcode) = @_ ;
	
	# Convert args into an error
	$this->throw_error('type'=>'warning', 'message'=>$message, 'errorcode'=>$errorcode) ;
	
}

#-----------------------------------------------------------------------------

=item B<throw_note($message, [$errorcode])>

Add a new error (type=note) to this object instance, also adds the error to this Class list
keeping track of all runtime errors

=cut

sub throw_note
{
	my $this = shift ;
	my ($message, $errorcode) = @_ ;
	
	# Convert args into an error
	$this->throw_error('type'=>'note', 'message'=>$message, 'errorcode'=>$errorcode) ;
	
}



#-----------------------------------------------------------------------------

=item B<last_error()>

Returns a hash containing the information from the last (worst case) error stored for this object

t/embed/test3.pl view on Meta::CPAN

#----------------------------------------------------------------------
# Main execution
#
sub app
{
	my ($app) = @_ ;
	
	print "Doing something...\n" ;
	
	my $obj = MyObj->new() ;
	$obj->throw_fatal("Oops! I've called throw_fatal...", 101) ;
	
}


#=================================================================================
# SETUP
#=================================================================================
__DATA__

[SUMMARY]

( run in 0.369 second using v1.01-cache-2.11-cpan-496ff517765 )