view release on metacpan or  search on metacpan

lib/P.pm  view on Meta::CPAN

	use Xporter;

	my $ignore=<<'IGN'									#{{{
	BEGIN {
		use constant EXPERIMENTAL=>0;
		if (EXPERIMENTAL) {				
			sub rm_adjacent {
				my $c = 1;
				($a, $c) = @$a if ref $a;
				$b //= "∄";
				if ($a ne $b) { $c > 1 ? "$a × $c" : $a , $b } 
				else { (undef, [$a, ++$c]) }
			}
			sub reduce(&\[@$]) { my $f = shift;
				my (@final, $i)		= ((), 0);
				my ($cnt, $term) = (0, undef);
				my ($parms, $rv);
				if (@_ < 2 && ARRAY $_[0] ? $_[0] : \@_;
				$parms = q(ARRAY) eq 
				$rv = 

				while (@_ >= 2) {
					my $res = $f->($_[0], $_[1])) {
					if ($f->($_[0], $_[1])) {
						if ($cnt == 0) {
							$term = $_[0];
							++$cnt;
						} else { ++$cnt};
					} else {
						if ($cnt) {
							push @final, "\"$term\" × $cnt";
							($cnt, $term) = (undef, 0);
						}
					}
					shift;
				}
				@final

				for (my $i=0; $i < (@$ar-1); ++$i ) {
					my ($x, $y) = ($ar->[$i], $ar->[$i+1]);
					my @r = &$f($ar->[$i], $ar->[$i+1]);
					push @final, $r[0] if $r[0];
					$ar->[$i+1] = $r[1];
				}
				@final;
			}
		} 
	}												
IGN
	||undef;															#}}}

	

	use constant NoBrHr => 0x83;					# Unicode codepoint="No Break Here"
	our	%_dflts;
	our (%mod_dflts, %types);
	BEGIN {
		%_dflts=(
			depth						=> 3, 
			ellipsis				=> '…', 
			expand_duprefs	=> 0,
			implicit_io			=> 0,
			maxstring				=> undef,
			noquote					=> 1, 
			seen						=> '🔁',		# 🔁
			undef						=> '∄',
		);

		my $bool	 = sub { $_[0] ? 1 : 0 };
		my $intnum = sub { $_[0] =~ m{^([0-9]+)$} ? 0 + $1 : 0 };
		my $string = sub { length($_[0]) ? "$_[0]"  : '' };
		my $true	 = sub { 1 };

		%types=(
			default					=> $true,
			depth						=> $intnum, 
			ellipsis				=> $string,
			expand_duprefs	=> $bool,
			implicit_io			=> $bool,
			maxstring				=> $intnum,
			noquote					=> $bool,
			seen						=> $string,
			undef						=> $string,
		);

		#global default copy
		$mod_dflts{""}	= \%_dflts;
	}


	use constant cc => '\x00-\x1f'; 			## cc = caret class

	sub vrfmt($) {
		my ($v, $pkg)		= (shift || "", "");
		#my ($vl, $ic)		= (length $v, 2+index $v, "::");
		#if ($ic >= 2  &&  $vl - $ic > 0) {
		#	$pkg	= substr $v, 0, $ic;
		#	$v 		= substr $v, $ic;
		#}																						# here, 'v' is a var name
		#if ( $v =~ m{^([\x00-\x1f])(\w*)$} ) {				# varname starting w/ctl-ch
		#	$v = "^" . chr(0x40 + ord $1) . $2;					# use carot encoding
		#}
		$pkg . $v;
	}

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


	sub sw(*):lvalue;
# sub sw_decr(*);

	sub _Px($$;$) { my ($p, $v) = (shift, shift);
		local (*sw); *sw = sub (*):lvalue {
  		defined($p->{$_[0]}) 
              ?  $p->{$_[0]}
              : ($p->{$_[0]} = $mod_dflts{""}->{$_[0]});
		};
#    local (*sw_decr); *sw_decr = sub(*) { my $res;
#      0 >= ($res = sw($_[0])) and return $res;
#      --sw($_[0]); $res };

		unless (sw(expand_duprefs)) {
			if (ref $v && ! SCALAR $v) {
				if ($p->{__P_seen}{$v}) { return "*". sw(seen) . ":" . $v . "*" }
				else { $p->{__P_seen}{$v} = 1 }
			}
		}
		my ($nargs, $lvl, $ro) = (scalar @_, 2, 0);
		if ($nargs) {
			$lvl = $_[0];
			if ($nargs>1) { $ro = $_[1] }
		}
		return sw('undef') unless defined $v;
		my $rv = ref $v;
		if (1 > $lvl-- || !$rv) {													# LAST level actions:
			my $fmt;			# prototypes are documentary (rt#89053)
			my $given = [	
				sub ($$) { $_[0] =~ /^[-+]?[0-9]+\.?\z/						&& 	q{%s}		},
				#sub ($$) { $_[1] && ($_[0] = vrfmt($_[0])), $_[1]	&& qq{%s}		},
				sub ($$) { $_[1] 												 					&& qq{%s}		},
				sub ($$) { 1 == length($_[0]) 										&& q{'%s'}	},
				sub ($$) { $_[0] =~ m{^(?:[+-]?(?:\.\d+)
															|(?:\d+\.\d+))\z}x  				&& q{%.2f}	},
				sub ($$) { substr($_[0],0,5) eq 'HASH('						&& 
																	'{'. sw(q(ellipsis)) .'}' . q{%.0s}	},
				sub ($$) { substr($_[0],0,6) eq 'ARRAY('					&& 
																	'['. sw(q(ellipsis)) .']' . q{%.0s}	},
				sub ($$) { substr($_[0],0,7) eq 'SCALAR('					&& 
																do {'\\' . $p->_Px(${$_[0]}, $lvl) .' ' } },
				#	sub ($$) { $mxstr && length ($_[0])>$mxstr 			&& qq("%.${mxstr}s")},
				sub ($$) { ref $_[0]															&& q{%s}	}, 
				sub ($$) { 1																			&& q{"%s"}	},
			];

			do { $fmt = $_->($v, $ro) and last } for @$given;
			return sprintf($fmt, $v);
		} else { 
			my $pkg = '';

			($pkg, $rv) = ($1, $2) if 0 <= (index $v, '=') && 
																$v =~ m{([\w:]+)=([cc\w][\w:]+)}; 

			local * nonrefs_b4_refs ; * nonrefs_b4_refs = sub {
				ref $v->{$a} cmp ref $v->{$b}  || $a cmp $b 
			};

			local (*IO_glob, *NIO_glob, *IO_io, *NIO_io);
			(*IO_glob, *NIO_glob, *IO_io, *NIO_io) = (
						sub(){'<*'.<$v>.'>'}, sub(){'<*='.$p->_Px($v, $lvl-1).'>'},
						sub(){'<='.<$v>.'>'}, sub(){'<|'.$p->_Px($v, $lvl-1).'|>'},
					);
			no strict 'refs';
			my %actions = ( 
				GLOB	=>	($p->{implicit_io}? *IO_glob: *NIO_glob),
				IO		=>	($p->{implicit_io}? *IO_io	 : *NIO_io),
				REF		=>	sub(){ "\\" . $p->_Px($$_, $lvl-1) . ' '},
				SCALAR=>	sub(){ $pkg.'\\' . $p->_Px($$_, $lvl).' ' },
				ARRAY	=>	sub(){ $pkg."[". 
												(join ', ', 
#	not working: why?			#reduce \&rm_adjacent, (commented out)
												map{ $p->_Px($_, $lvl) } @$v ) ."]" },
				HASH	=>	sub(){ $pkg.'{' . ( join ', ', @{[