view release on metacpan or  search on metacpan

lib/Log/Shiras/TapWarn.pm  view on Meta::CPAN

	###InternalTaPWarN	$switchboard->master_talk( { report => 'log_file', level => 1,
	###InternalTaPWarN		name_space => 'Log::Shiras::TapWarn::re_route_warn',
	###InternalTaPWarN		message =>[ "Adjusting the warn sig handler with the data ref: ", $data_ref, ], } );

	$warn_store = $SIG{__WARN__} if $SIG{__WARN__};
	$SIG{__WARN__} = sub{
			$data_ref->{message} = [ @_ ];
			chomp @{$data_ref->{message}};
			###InternalTaPWarN	$switchboard->master_talk( { report => 'log_file', level => 2,
			###InternalTaPWarN		name_space => 'Log::Shiras::TapWarn::warn',
			###InternalTaPWarN		message =>[ "Inbound warn statement: ", $data_ref->{message},], } );# caller( 0 ), '-----', caller( 1 ), '-----', caller( 2 ), '-----', caller( 3 ), '-----', caller( 4 ),
			my $line = (caller( 0 ))[2];
			$data_ref->{name_space} = ((caller( 1 ))[3] and (caller( 1 ))[3] !~ /__ANON__/) ?  (caller( 1 ))[3] : (caller( 0 ))[0];
			$data_ref->{name_space} .= "::$line";
			###InternalTaPWarN	$switchboard->master_talk( { report => 'log_file', level => 1,
			###InternalTaPWarN		name_space => 'Log::Shiras::TapWarn::warn',
			###InternalTaPWarN		message =>[ "Added name_space: ", $data_ref->{name_space}, ], } );

			# Dispatch the message
			my $report_count = $switchboard->master_talk( $data_ref );
			###InternalTaPWarN	$switchboard->master_talk( { report => 'log_file', level => 2,
			###InternalTaPWarN		name_space => 'Log::Shiras::TapWarn::warn',
			###InternalTaPWarN		message =>[ "Message reported |$report_count| times"], } );

			# Handle fail_over
			if( $report_count == 0 and $data_ref->{fail_over} ){
				###InternalTelephonE	$switchboard->master_talk( { report => 'log_file', level => 4,
				###InternalTelephonE		name_space => 'Log::Shiras::TapWarn::warn',
				###InternalTelephonE		message	=> [ "Message allowed but found no destination!", $data_ref->{message} ], } );
				warn longmess( "This message sent to the report -$data_ref->{report}- was approved but found no destination objects to use" ), @_;
			}
		} or die "Couldn't redirect __WARN__: $!";
	###InternalTaPWarN	$switchboard->master_talk( { report => 'log_file', level => 0,
	###InternalTaPWarN		name_space => 'Log::Shiras::TapWarn::re_route_warn',
	###InternalTaPWarN		message =>[ "Finished re_routing warn statements" ], } );
	return 1;
}

sub restore_warn{
	$SIG{__WARN__} = $warn_store ? $warn_store : undef;
	$warn_store = undef;
	###InternalTaPWarN	$switchboard->master_talk( { report => 'log_file', level => 0,
	###InternalTaPWarN		name_space => 'Log::Shiras::TapWarn::restore_warn',
	###InternalTaPWarN		message =>[ "Log::Shiras is no longer tapping into warnings!" ], } );
	return 1;
}

#########1 Phinish            3#########4#########5#########6#########7#########8#########9

1;

#########1 main pod docs      3#########4#########5#########6#########7#########8#########9
__END__

=head1 NAME

Log::Shiras::TapWarn - Reroute warn to Log::Shiras::Switchboard

=head1 SYNOPSIS

	use Modern::Perl;
	#~ use Log::Shiras::Unhide qw( :InternalTaPWarN );# :InternalSwitchboarD
	$ENV{hide_warn} = 0;
	use Log::Shiras::Switchboard;
	use Log::Shiras::TapWarn qw( re_route_warn restore_warn );
	my	$ella_peterson = Log::Shiras::Switchboard->get_operator(
			name_space_bounds =>{
				UNBLOCK =>{
					log_file => 'trace',
				},
				main =>{
					32 =>{
						UNBLOCK =>{
							log_file => 'fatal',
						},
					},
					34 =>{
						UNBLOCK =>{
							log_file => 'fatal',
						},
					},
				},
			},
			reports	=>{ log_file =>[ Print::Log->new ] },
		);
	re_route_warn(
		fail_over => 0,
		level => 'debug',
		report => 'log_file',
	);
	warn "Hello World 1";
	warn "Hello World 2";
	restore_warn;
	warn "Hello World 3";

	package Print::Log;
	use Data::Dumper;
	sub new{
		bless {}, shift;
	}
	sub add_line{
		shift;
		my @input = ( ref $_[0]->{message} eq 'ARRAY' ) ?
						@{$_[0]->{message}} : $_[0]->{message};
		my ( @print_list, @initial_list );
		no warnings 'uninitialized';
		for my $value ( @input ){
			push @initial_list, (( ref $value ) ? Dumper( $value ) : $value );
		}
		for my $line ( @initial_list ){
			$line =~ s/\n$//;
			$line =~ s/\n/\n\t\t/g;
			push @print_list, $line;
		}
		my $output = sprintf( "| level - %-6s | name_space - %-s\n| line  - %04d   | file_name  - %-s\n\t:(\t%s ):\n",
					$_[0]->{level}, $_[0]->{name_space},
					$_[0]->{line}, $_[0]->{filename},
					join( "\n\t\t", @print_list ) 	);
		print $output;
		use warnings 'uninitialized';
	}