#!/usr/bin/perl  -w

{ package P;
	BEGIN{ $::INC{__PACKAGE__.".pm"} = __FILE__."#__LINE__"};
	use 5.10.0;
	use strict;
	our $VERSION='1.0.7';
	# RCS $Revision: 1.15 $ -  $Date: 2012-12-31 16:56:07-08 $
	# 1.0.7 - (2013-1-9) add support for printing blessed objects
	#       - pod corrections
	#       - strip added LF from 'rev' example with tr (looks wrong)
	# 1.0.6 - add manual check for LF at end (chomp doesn't always work)
	# 1.0.5 - if don't recognize ref type, print var
	# 1.0.4 - added support for printing contents of arrays and hashes.
	# 				(tnx 2 MidLifeXis@prlmnks 4 brain reset)
	# 1.0.3 - add Pea
	# 1.0.2 - found 0x83 = "no break here" -- use that for NL suppress
	# 			- added support for easy inclusion in other files 
	# 				(not just as lib);
	# 			- add ISA and EXPORT to 'mem' so they are available @ BEGIN time
	#
	# 1.0.1 - add 0xa0 (non breaking space) to suppress NL
	our (@ISA, @EXPORT);
	BEGIN {@EXPORT=qw(P Pa Pe Pea), @ISA=qw(Exporter) };
	use parent 'Exporter';


	sub P(@) {    # 'safen' to string or FH or STDOUT
		my $_;
		do{ print '(@)'; @_=@$_[0] } if ref $_[0] eq 'ARRAY';
		my ($fh, $f);
		my $explicit_out;
		if (ref $_[0] eq 'GLOB') {
			$fh = shift;
			$explicit_out=1;
		} else {
			$fh =\*STDOUT;
		}
		$f=shift;
		no warnings;
		my $res =  sprintf $f, 	
			map {my $_ 
				= &{ 
					sub {
						return "undef" unless defined $_;
						my ($v, $ref_, $pkg) = ($_, ref $_, '');
						if (0<=(index $v,'=') && m{(\w+)=(\w+)}) { $pkg=$1.":", $ref_=$2 }
						return <$_> if ($ref_) =~ /GLOB/;
						return $_ unless $ref_;
						given ($ref_) {
							when (/^GLOB$/)		{ <*$v> }
							when (/^IO$/)			{ <$$v>}
							when (/^SCALAR$/) { return $pkg.'\\' .$$v }
							when (/^ARRAY$/)	{ return $pkg."[" . ( join ",", 
																  @{ [ map { $_//"(undef)" } @$v ] } ) . "]" }
							when (/^HASH$/)		{ $pkg."{" . (join ", ", @{[
								map {'"'.$_.'"=>"'.($v->{$_}//"(undef)").'"'} keys %$v ]})."}" }
							default								{return $v}
						} 
					} 
				} 
			} @_
		; 
		chomp $res;
		#(index $res,-1,1) eq "\012" and $res=substr $res,0,length($res)-1;
		my $ctx = defined wantarray;
			;	#0x83=128+3=131 = non-breaking space -- if at end, trim it & don't CR;
    {use bytes; #pretend we know what we are doing... ;-)
		if ((ord substr $res,-1) eq 131) {                 #"NO_BREAK_HERE"
      my $w=0; $w=1 if (ord substr $res, -2,1) eq 194; #UTF-8 encoded?
			$res=substr $res,0,-($w+1)+length $res ;
			$ctx=1;
		}};
		if (!$fh && !$ctx) {	#internal consistancy check
			$fh = \*STDERR and P $fh 
	 						"Invalid File Handle presented for output, using STDERR:";
			$explicit_out=1;
		} else { return $res if (!$explicit_out and $ctx) }
		$fh->print ($res . (!$ctx ? "\n" : "")  );
	};
	sub Pa(@) {goto &P};
	sub Pe($;@) {
		return unless @_;
		unshift @_, \*STDERR;
		goto &P 
	};
	sub Pea(@) {goto &Pe};
	sub Pae(@) {goto &Pe};
1;}
{
	package main;
	use utf8;

	(caller 0)[0] || do {
		$/=undef; $$_=<main::DATA>;
		close main::DATA;
		eval "$$_";
		1;
	};
1;
}

############################################################################
#{{{1
#    use P;

=head1 NAME

P, Pe, Pa,  (& TBD: Pea/Pae)          Safer, General Format + Print sub

=head1 VERSION

Version  "$Version"

=head1 SYNOPSIS

P <FILEHANDLE, FORMAT, LIST|FORMAT, LIST|LIST>

Pa @ARRAY

Pe (same forms as P, but to STDERR)

Pae (same form as Pa but to STDERR)

=head1 DESCRIPTION

P, while designed with development in mind, isn't limited to such.

It combines features of printf, sprintf, and say: printing to strings
if its output is assign to something, adding newlines when output is
not to a string, ignoring a single extra newlines if added, allowing
suppression of the auto-newline using the Unicode-control char
"\0x83" "Don't break here".  With few special cases to remember. 

Any items printed as strings that are undef -- will print 'undef'.

=head1 EXAMPLES:

=over 4

=item
S<>

=item  
S<P "Hello %s", "World";        # auto NL when to a FH>

=item
S<>

=item 
S<P "Hello \x83"; P "World";    # \x83: suppress auto-NL to FH's >

=item
S<>

=item
S<$s = P "%s", "Hello %s";      # not needed if printing to string >

=item
S<P $s, "World";                # still prints "Hello World" >

=item 
S<@a = ("%s", "my string");     # using array, fmt as 1st arg >

=item 
S<Pa @a;                        # use 'Pa' have @a as args to 'P'>

=item 
S<P @a;                         # prints count of @a elements>

=item 
S<@a = ("Hello %s", "World");   # format in array[0]>

=item 
S<Pa @a;                        # use @a as args for P>

=item
S<P @a;                         # prints #items in 'a'>

=item
S<P "a=%s", \@a;                # prints contents of 'a': [1,2,3...]>

=item
S<>

=item 
S<P STDERR, @a                  # use @a as args to a specific FH>

=item	
S<                              # NOTE: "," after FH L</*STC>>

=item 
S<Pe  "Output to STDERR"        # 'Shortcut' for P to STDERR>

=item
S<                              # P Hash bucket usage + contents >

=item
S<                              # with hashes>

=item
S<%H = (one =>E<gt>S< 1, two =>E<gt>S< 2, u =>E<gt>S< undef);>

=item
S<P "%H slots used: %s", %H;    # Show bucket or slot usage>

=item
S<P "%H=%s", \%H;               # show contents of hash {x=>E<gt>S<y, ...}>

=back

=head1 NOTES

Note, values given as args to a formatted print statement, are
checked for undef and substitute "(undef)" for undefined values.
If you print vars as numbers, this has the side effect of causing
runtime format errors, so best to print as strings to see 'undef'.
    
While usable in any code, it's use was designed to save typing, time
and work of undef checking, newline handling, and doing the right
thing with given input.  It may not be suitable where speed is
important.

Hidden (but documented) feature: inserting the 'NO BREAK HERE'
control- char (\x83 or UTF-8 string \xc283) as the last char of
a string will suppress a 'break' (newline) where it normally would
be added.

=cut
#}}}1

__DATA__
# line ' .__LINE__ . ' "' ' __FILE__ . "\"\n" . '
foreach (qw{STDERR STDOUT}) {select *$_; $|=1};
use strict; use warnings;
use Carp::Always;
use P;
{
 	my $i;
	my $incr = sub { ++$i};
	sub iter(){"Hello Perl ${\(0+&$incr)}"}
}

my $format="#%-2d %-25s: ";
our $case=0;
sub case ($) {
	$_=P (\*STDOUT, $format, ++$case, "(".$_[0].")");
	"";
}

case "ret from func";
P &iter;                           			# case 1: return from func


case "w/string";
P "${\(+iter())}";                     	# case 2 w/string

case "passed array";
my @msg = ("%s", &iter ); 
Pa @msg;                            		# case 3 (hack around perlbug)

case "w/fmt+string";
P "%s",iter;                        		# case 4

case "to STDERR";
P \*STDERR, iter;                   		# case 5 #needs redirection to see


case "to strng embedded in #7";					# case 6 to string; prints in case 7
my $str = P "%s",iter; 
P "";

case "prev string";											# case 7 - print embedded P output

P "prev str=\"%s\" (no LF) && ${\(+iter())}", $str;

case "p thru '/.../rev' fr/FH ";				# case 8 - P 'pipe'
my $fh;
open $fh, "echo -n \"(echo) ${\(+iter)}\" |rev |tr -d \"\n\" |" or 
	die p(\*STDERR, "Problem opening 'rev' util ($!),".
								   " got PATH?(skipping)\n\n", 1); 
  P \*STDOUT, "%s", $fh;        			


case "P && array ref";
my @ar=qw(one two three 4 5 6);
P "%s",\@ar;														# case 9 - array expansion

case "P HASH ref";											# case 10 - hash expansion
my %hash=(a=>'apple', b=>'bread', c=>'cherry');

P "%s", \%hash;

case "P PKG ref";											# case 11 - blessed object
{	my $hp;
	bless $hp={a=>1, b=>2}, 'PKG';
	P "%s", $hp;
}

#case "as IO::HANDLE handler";					# case 1x - T.B.D.
#P STDERR "Does this goto STDERR?";
#print STDERR "";
#case "as Glob handler?";								# case 1x - T.B.D.
#Pg STDERR "Globing out?"
# vim: ts=2 sw=2