view release on metacpan or  search on metacpan

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

	###InternalTaPPrinT		name_space => 'Log::Shiras::TapPrint::re_route_print',
	###InternalTaPPrinT		message =>[ "Building the coderef with the data ref: ", $data_ref, ], } );

	my	$code_ref = sub{
			$data_ref->{message} = [ @_ ];
			chomp @{$data_ref->{message}};
			###InternalTaPPrinT	$switchboard->master_talk( { report => 'log_file', level => 2,
			###InternalTaPPrinT		name_space => 'Log::Shiras::TapPrint::print',
			###InternalTaPPrinT		message =>[ "Inbound print statement: ", $data_ref->{message} ], } );
			my $line = (caller( 2 ))[2];
			$data_ref->{name_space} = ((caller( 3 ))[3] and (caller( 3 ))[3] !~ /__ANON__/) ?  (caller( 3 ))[3] : (caller( 2 ))[0];
			$data_ref->{name_space} .= "::$line";
			###InternalTaPPrinT	$switchboard->master_talk( { report => 'log_file', level => 1,
			###InternalTaPPrinT		name_space => 'Log::Shiras::TapPrint::print',
			###InternalTaPPrinT		message =>[ "Added name_space: ", $data_ref->{name_space}, ], } );

			# Dispatch the message
			my $report_count = $switchboard->master_talk( $data_ref );
			###InternalTaPPrinT	$switchboard->master_talk( { report => 'log_file', level => 2,
			###InternalTaPPrinT		name_space => 'Log::Shiras::TapPrint::print',
			###InternalTaPPrinT		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::TapPrint::print',
				###InternalTelephonE		message	=> [ "Message allowed but found no destination!", $data_ref->{message} ], } );
				print STDOUT longmess( "This message sent to the report -$data_ref->{report}- was approved but found no destination objects to use" ), @_;
			}
			return 1;
		};
	select( IO::Callback->new('>', $code_ref) ) or die "Couldn't redirect STDOUT: $!";
	###InternalTaPPrinT	$switchboard->master_talk( { report => 'log_file', level => 0,
	###InternalTaPPrinT		name_space => 'Log::Shiras::TapPrint::re_route_print',
	###InternalTaPPrinT		message =>[ "Finished re_routing print statements" ], } );
	return 1;
}

sub restore_print{
	select( STDOUT ) or
			die "Couldn't reset print: $!";
	###InternalTaPPrinT	$switchboard->master_talk( { report => 'log_file', level => 0,
	###InternalTaPPrinT		name_space => 'Log::Shiras::TapPrint::restore_print',
	###InternalTaPPrinT		message =>[ "Log::Shiras is no longer tapping into 'print' statements!" ], } );
	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::TapPrint - Reroute print to Log::Shiras::Switchboard

=head1 SYNOPSIS

	use Modern::Perl;
	#~ use Log::Shiras::Unhide qw( :InternalTaPPrinT );
	$ENV{hide_warn} = 0;
	use Log::Shiras::Switchboard;
	use Log::Shiras::TapPrint 're_route_print';
	my	$ella_peterson = Log::Shiras::Switchboard->get_operator(
			name_space_bounds =>{
				UNBLOCK =>{
					log_file => 'debug',
				},
				main =>{
					27 =>{
						UNBLOCK =>{
							log_file => 'info',
						},
					},
				},
			},
			reports	=>{ log_file =>[ Print::Log->new ] },
		);
	re_route_print(
		fail_over => 0,
		level => 'debug',
		report => 'log_file',
	);
	print "Hello World 1\n";
	print "Hello World 2\n";
    print STDOUT "Hello World 3\n";
    restore_print;
    print "Hello World 4\n";

	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 STDOUT $output;
		use warnings 'uninitialized';
	}

	1;

	#######################################################################################