blib/lib/P.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 172 | 220 | 78.1 |
branch | 66 | 116 | 56.9 |
condition | 18 | 37 | 48.6 |
subroutine | 37 | 42 | 88.1 |
pod | 0 | 4 | 0.0 |
total | 293 | 419 | 69.9 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | #!/usr/bin/perl -w | ||||||
2 | # vim=:SetNumberAndWidth | ||||||
3 | |||||||
4 | =encoding utf-8 | ||||||
5 | |||||||
6 | =head1 NAME | ||||||
7 | ################################################################################ | ||||||
8 | P - Safer, friendlier printf/print/sprintf + say | ||||||
9 | |||||||
10 | =head1 VERSION | ||||||
11 | |||||||
12 | Version "1.1.39" | ||||||
13 | |||||||
14 | =cut | ||||||
15 | |||||||
16 | { package P; | ||||||
17 | 2 | 2 | 143827 | use warnings; use strict;use mem; | |||
2 | 2 | 21 | |||||
2 | 2 | 61 | |||||
2 | 10 | ||||||
2 | 4 | ||||||
2 | 35 | ||||||
2 | 409 | ||||||
2 | 210 | ||||||
2 | 10 | ||||||
18 | our $VERSION='1.1.39'; | ||||||
19 | |||||||
20 | # RCS $Revision: 1.55 $ - $Date: 2018-06-16 04:34:53-07 $ | ||||||
21 | # 1.1.39 - fix in carat encoding; had Single Quote (SQ) included in string | ||||||
22 | # of chars to match for encoding resulting in SQ being converted | ||||||
23 | # for carat encoding (print SQ though %s printed ^G ) | ||||||
24 | # 1.1.38 - split declare + definition in "local *fn=sub" to | ||||||
25 | # "local (*fn); *fn=sub" | ||||||
26 | # - expand SCALAR refs even past limit as they don't take much space | ||||||
27 | # and they aren't likly to contain nested refs | ||||||
28 | # - moderate code cleanups | ||||||
29 | # - handle 'undef' if 1st param passed: | ||||||
30 | # - 1) if only parm, unshift in a format "%s", so undef will print | ||||||
31 | # - 2) if 2nd parm looks like format, discard the null(ignore) | ||||||
32 | # - OUTPUT CHANGE: if 1st char of a variable is a control character | ||||||
33 | # then print it as carat(0x40+cc), so ctl-W, becomes ^W. | ||||||
34 | # - remove unneeded reference to '@ISA' (Xporter doesn't need it) | ||||||
35 | # - refactor module-default handling; have global default module | ||||||
36 | # default and single-usage OO method to supply non-default params | ||||||
37 | # 1.1.37 - instead of trying to disable non-working tests in early perl's, | ||||||
38 | # require perl 5.8.5 and perlIO 1.0.3 to build; | ||||||
39 | # - only do win32 checks in P.Pt | ||||||
40 | # 1.1.36 - instead of disabling broken perl's, in a Major series, disabled all. | ||||||
41 | # fixed that (changes in P.Pt test). | ||||||
42 | # 1.1.35 - Add per-MAJOR-series min req'd. perl (else skip test) | ||||||
43 | # 1.1.34 - Compensating for odd Strawberry Perl var-values... | ||||||
44 | # 1.1.33 - Trying to Compensate for Strawberry Perl bugs... | ||||||
45 | # 1.1.32 - Change FAILS in 1.1.31 for bad env's to "skips" | ||||||
46 | # 1.1.31 - More pruning of bad test environments | ||||||
47 | # 1.1.30 - Attempt to prune unsupported OS's (WinXP) | ||||||
48 | # 1.1.29 - sprintf broken: include zero-width string spec to workaround | ||||||
49 | # 1.1.28 - testsuite fix - unknown failure case in sprintf: | ||||||
50 | # "Redundant argument in sprintf "... for "return sprintf $fmt, $v"; | ||||||
51 | # Trying parens around sprintf($fmt, $v); | ||||||
52 | # (shot in dark for strawberry win32 perl on win10...) | ||||||
53 | # 1.1.27 - test fix -- Makefile.PL improperly specified "test", rather | ||||||
54 | # rather than using t/*.*t as pattern | ||||||
55 | # 1.1.26 - add code to allow changing defaults for literals and run-time | ||||||
56 | # constants previously only accessible through the OO method | ||||||
57 | # - Allow setting defaults globally as well as per-package | ||||||
58 | # - fix for bug in testcase 5 in "P.t" in some later versions | ||||||
59 | # of Strawberry Perl (5.22, 5.20?). Where the perlvar '$^X' | ||||||
60 | # contained a win32-backslash-separated path to perl. In double | ||||||
61 | # quotes, the backslashes are removed as literalizing the next | ||||||
62 | # character. Changing the path usage to not have double-quotes | ||||||
63 | # around the path should prevent the backslash-removal and pass | ||||||
64 | # the literal string to the perl 'system' call. | ||||||
65 | # 1.1.25 - put initial POD w/VERSION @ top to keep version #'s together | ||||||
66 | # - remove BEGIN that was needed for running/passing tests | ||||||
67 | # and instead use 'mem' | ||||||
68 | # - move changelog to column one and use vim markers to hide | ||||||
69 | # older changes | ||||||
70 | # - add dflts hash to allow 'use' time change of defaults (W.I.P.) | ||||||
71 | # - split local define+assignment ~#283 due to side effects | ||||||
72 | # 1.1.24 - respin for another Makefile change | ||||||
73 | # 1.1.23 - respin for a Makefile change | ||||||
74 | # 1.1.22 - respin to use alt version format | ||||||
75 | # 1.1.21 - respin to have BUID_REQ include more modern Ext:MM | ||||||
76 | # 1.1.20 - respin to have Makefile rely on Xporter 1.0.6 | ||||||
77 | # 1.1.19 - Prereqs not being loaded in Cpantesters; attempt fix | ||||||
78 | # 1.1.18 - Unreported bugfix: | ||||||
79 | # the words HASH & ARRAY were sometimes printed in ref notation | ||||||
80 | # - remove included 'Types' code to use Types::Core (now published) | ||||||
81 | # 1.1.17 - Documentation refinements/fixes; Found possible culprit as to | ||||||
82 | # why Windows native tests could fail -- my source files in | ||||||
83 | # lib have pointed back to my real lib dir via a symlink. | ||||||
84 | # Windows wouldn't like those. Why any other platform did is | ||||||
85 | # likely some fluke of directory organization during test | ||||||
86 | # 1.1.16 - Different shot in dark to see if a change in P.env can make | ||||||
87 | # things work on Win-native | ||||||
88 | # 1.1.15 - Shot in dark to get 5.8.x to work(5.10 and newer seem to | ||||||
89 | # be working! | ||||||
90 | # 1.1.14 - and write out buffer from editor! (arg!) | ||||||
91 | # 1.1.13 - get perl w/ ^X rather than config | ||||||
92 | # 1.1.12 - Found another potential problem in the test prog. | ||||||
93 | # 1.1.11 - May have found another test bug.... trying fix for some fails | ||||||
94 | # 1.1.10 - Another internal format error bug (unreported), but caught | ||||||
95 | # in testing. | ||||||
96 | # 1.1.9 - Try to fix paths for test | ||||||
97 | # 1.1.8 - use ptar to generate Archive::tar compat archives | ||||||
98 | # 1.1.7 - Fix Makefile.PL | ||||||
99 | # 1.1.6 - Use t/P.env for premodifying ENV | ||||||
100 | # Document effect of printing to a FH & recording return val; | ||||||
101 | # 1.1.5 - Distribution change: use --format=v7 on tar to produce tarball | ||||||
102 | # (rt#90165) | ||||||
103 | # - Use shell script to preset env for test since | ||||||
104 | # Test::More doesn't set ENV | ||||||
105 | # 1.1.4 - Quick patch to enable use of state w/CORE::state | ||||||
106 | # 1.1.3 - [#$@%&!!!] | ||||||
107 | # 1.1.2 - Second try for test in P.t to get prereq's right | ||||||
108 | # 1.1.1 - Fix rest of (rt#89050) | ||||||
109 | # 1.1.0 - Fixed Internal bug#001, below & embedded \n@end of int. str | ||||||
110 | # (rt#89064) | ||||||
111 | # Version history continued... #{{{ | ||||||
112 | # 1.0.32 - Fix double nest test case @{[\*STDERR, ["fmt:%s", "string"]]} | ||||||
113 | # (rt#89056) | ||||||
114 | # only use sprintf's numeric formats (e.g. %d, %f...) on | ||||||
115 | # numbers supported by sprintf (for now only arabic numerals). | ||||||
116 | # Otherwise print as string. (rt#89063) | ||||||
117 | # its numeric formats (ex "%d", "%f"...) | ||||||
118 | # 1.0.31 - Fix check for previously printed items to apply only to | ||||||
119 | # - the current output statement; | ||||||
120 | # 1.0.30 - Fix LF suppression -- instead of suppressing EOL, suppressed | ||||||
121 | # all output in the case where no FD was specified (code was | ||||||
122 | # confused in deciding whether or not to suppress output and | ||||||
123 | # return it as a string. (rt#89058) | ||||||
124 | # - Add missing quote in Synopsis (rt#89047) | ||||||
125 | # - Change NAME section to reference module following CPAN | ||||||
126 | # standard to re-list name of module instead of functions | ||||||
127 | # (rt#89046) | ||||||
128 | # - Fix L<> in POD that referenced "module" P::P instead of name, "P" | ||||||
129 | # (forms bad link in HTML) (rt#89051) | ||||||
130 | # - Since ($;@) prototypes cause more problems than (@), clean p | ||||||
131 | # proto's to use '@'; impliciation->remove array variations | ||||||
132 | # (rt@89052, #89055) (rt#89058) | ||||||
133 | # - fix outdated and inconsistent doc examples regarding old protos | ||||||
134 | # (rt#89056)(rt#89058) | ||||||
135 | # Had broken P's object oriented flag passing in adding | ||||||
136 | # the 'seen' function (to prevent recursive outptut. Fixed this | ||||||
137 | # while testing that main::DATA is properly closed (rt#89057,#89067) | ||||||
138 | # - Internal Bug #001 | ||||||
139 | # #our @a = ("Hello %s", "World"); | ||||||
140 | # #P(\*STDERR, \@a); | ||||||
141 | # # prints-> ARRAY(0x1003b40) | ||||||
142 | # 1.0.29 - Convert to using 'There does not exist' sign (∄), U+2204 | ||||||
143 | # instead of (undef); use '🔁 ' for recursion/repeat; | ||||||
144 | # U+1F500 | ||||||
145 | # 1.0.28 - When doing explicit out (FH specified), be sure to end | ||||||
146 | # with newln. | ||||||
147 | # 1.0.27 - DEFAULT change - don't do implicit IO reads (change via | ||||||
148 | # impicit_io option) | ||||||
149 | # - not usually needed in debugging or most output; | ||||||
150 | # could cause problems | ||||||
151 | # reading data from a file and causing desychronization problems; | ||||||
152 | # 1.0.26 - detect recursive data structs and don't expand them | ||||||
153 | # 1.0.25 - Add expansion for 'REF'; | ||||||
154 | # - WIP: Trying to incorporate enumeration of duplicate adjacent | ||||||
155 | # data: Work In Progress: status: disabled | ||||||
156 | # 1.0.24 - limit default max string expanded to 140 chars (maybe want to | ||||||
157 | # do this only in brace expansions?) Method to change in OOO | ||||||
158 | # not documented at this time. NOTE: limiting output by default | ||||||
159 | # is not a great idea. | ||||||
160 | # 1.0.23 - When printing contents of a hash, print non-refs before | ||||||
161 | # refs, and print each subset in alpha sorted order | ||||||
162 | # 1.0.22 - Switch to {…} instead of HASH(0x12356892) or | ||||||
163 | # […] for arrays | ||||||
164 | # 1.0.21 - Doc change: added example of use in "die". | ||||||
165 | # 1.0.20 - Rewrite of testcase 5 in self-execution; no external progs | ||||||
166 | # anymore: use fork and print from P in perl child, then | ||||||
167 | # print from FH in parent, including uses of \x83 to | ||||||
168 | # inhibit extra LF's; | ||||||
169 | # 1.0.19 - Regretting fancy thru 'rev' P direct from FH test case (a bit) | ||||||
170 | # **seems** like some people don't have "." in path for test | ||||||
171 | # cases, so running "t/prog" doesn't work, trying "./t/prog" | ||||||
172 | # (1 fail on a Win32 base on a x64 system...so tempted | ||||||
173 | # to just ignore it...) >;^); guess will up this for now | ||||||
174 | # and think about that test case some more... | ||||||
175 | # I'm so gonna rewrite that case! (see xtodox below) | ||||||
176 | # 1.0.18 - convert top format-case statement to load-time compile | ||||||
177 | # and see if that helps BSD errors; | ||||||
178 | # - change test case w/array to use P & not old Pa-form | ||||||
179 | # - change test case to print to STDERR to use Pe | ||||||
180 | # - fix bug in decrement of $lvl in conditional (decrement must | ||||||
181 | # be in first part of conditional) | ||||||
182 | # - xtodox fix adaptation of 'rev' test case to work w/o | ||||||
183 | # separate file(done) | ||||||
184 | # 1.0.17 - another try at fixing pod decoding on metacpan | ||||||
185 | # 1.0.16 - pod '=encoding' move to before '=head' | ||||||
186 | # (ref:https://github.com/CPAN-API/metacpan-web/issues/800 ) | ||||||
187 | # 1.0.15 - remove 'my $_' usage; old perl compat probs; use local | ||||||
188 | # in once instance were needed local copy of $_ | ||||||
189 | # 1.0.14 - arg! misspelled Win nul: devname(fixed) | ||||||
190 | # 1.0.13 - test case change only to better test print to STDERR | ||||||
191 | # 1.0.12 - test case change: change of OBJ->print to print OBJ to | ||||||
192 | # try to get around problem on BSD5.12 in P.pm (worked!) | ||||||
193 | # - change embedded test case to not use util 'rev', but | ||||||
194 | # included perl script 'rev' in 't' directory...(for native win) | ||||||
195 | # 1.0.11 - revert printing decimals using %d: dropped significant leading | ||||||
196 | # zero's; Of NOTE: floating point output in objects is | ||||||
197 | # not default: we use ".2f" | ||||||
198 | # - left off space after comma in arrays(fixed) | ||||||
199 | # - rewrite of sections using given/when/default to not use | ||||||
200 | # them; try for 5.8 compat | ||||||
201 | # - call perl for invoking test vs. relying on #! invokation | ||||||
202 | # - pod updates mentioning 'ops'/depth | ||||||
203 | # 1.0.10 - remove Carp::Always from test (wasn't needed and caused it | ||||||
204 | # to fail on most test systems) | ||||||
205 | # add OO-oriented way to set internal P ops (to be documented) | ||||||
206 | # - fixed bug in logic trimming recursion depth on objects | ||||||
207 | # 1.0.9 - Add Px - recursive object print in squished form; | ||||||
208 | # Default to using Px for normal print | ||||||
209 | # 1.0.8 - fix when ref to IO -- wasn't dereferenced properly | ||||||
210 | # - upgrade of self-test/demo to allow specifying which test | ||||||
211 | # to run from cmd line; test numbers are taken from | ||||||
212 | # the displayed examples when run w/no arguments | ||||||
213 | # B:still doesn't run cleanly under test harness may need to | ||||||
214 | # change cases for that (Fixed) | ||||||
215 | # - POD update to current code | ||||||
216 | # 1.0.7 - (2013-1-9) add support for printing blessed objects | ||||||
217 | # - pod corrections | ||||||
218 | # - strip added LF from 'rev' example with tr (looks wrong) | ||||||
219 | # 1.0.6 - add manual check for LF at end (chomp doesn't always work) | ||||||
220 | # 1.0.5 - if don't recognize ref type, print var | ||||||
221 | # 1.0.4 - added support for printing contents of arrays and hashes. | ||||||
222 | # (tnx 2 MidLifeXis@prlmnks 4 brain reset) | ||||||
223 | # 1.0.3 - add Pea | ||||||
224 | # 1.0.2 - found 0x83 = "no break here" -- use that for NL suppress | ||||||
225 | # - added support for easy inclusion in other files | ||||||
226 | # (not just as lib); | ||||||
227 | # - add ISA and EXPORT to 'mem' so they are available @ BEGIN time | ||||||
228 | # | ||||||
229 | # 1.0.1 - add 0xa0 (non breaking space) to suppress NL | ||||||
230 | # #}}} | ||||||
231 | |||||||
232 | 2 | 2 | 218 | use utf8; | |||
2 | 4 | ||||||
2 | 11 | ||||||
233 | 2 | 2 | 48 | { no warnings "once"; *IO::Handle::P = \&P::P } | |||
2 | 5 | ||||||
2 | 124 | ||||||
234 | |||||||
235 | 2 | 2 | 387 | use Types::Core qw(blessed); | |||
2 | 3426 | ||||||
2 | 12 | ||||||
236 | |||||||
237 | our @EXPORT; | ||||||
238 | 2 | 2 | 741 | use mem(@EXPORT=qw(P Pe)); | |||
2 | 4 | ||||||
2 | 9 | ||||||
239 | 2 | 2 | 60 | use Xporter; | |||
2 | 3 | ||||||
2 | 8 | ||||||
240 | |||||||
241 | my $ignore=<<'IGN' #{{{ | ||||||
242 | BEGIN { | ||||||
243 | use constant EXPERIMENTAL=>0; | ||||||
244 | if (EXPERIMENTAL) { | ||||||
245 | sub rm_adjacent { | ||||||
246 | my $c = 1; | ||||||
247 | ($a, $c) = @$a if ref $a; | ||||||
248 | $b //= "∄"; | ||||||
249 | if ($a ne $b) { $c > 1 ? "$a × $c" : $a , $b } | ||||||
250 | else { (undef, [$a, ++$c]) } | ||||||
251 | } | ||||||
252 | sub reduce(&\[@$]) { my $f = shift; | ||||||
253 | my (@final, $i) = ((), 0); | ||||||
254 | my ($cnt, $term) = (0, undef); | ||||||
255 | my ($parms, $rv); | ||||||
256 | if (@_ < 2 && ARRAY $_[0] ? $_[0] : \@_; | ||||||
257 | $parms = q(ARRAY) eq | ||||||
258 | $rv = | ||||||
259 | |||||||
260 | while (@_ >= 2) { | ||||||
261 | my $res = $f->($_[0], $_[1])) { | ||||||
262 | if ($f->($_[0], $_[1])) { | ||||||
263 | if ($cnt == 0) { | ||||||
264 | $term = $_[0]; | ||||||
265 | ++$cnt; | ||||||
266 | } else { ++$cnt}; | ||||||
267 | } else { | ||||||
268 | if ($cnt) { | ||||||
269 | push @final, "\"$term\" × $cnt"; | ||||||
270 | ($cnt, $term) = (undef, 0); | ||||||
271 | } | ||||||
272 | } | ||||||
273 | shift; | ||||||
274 | } | ||||||
275 | @final | ||||||
276 | |||||||
277 | for (my $i=0; $i < (@$ar-1); ++$i ) { | ||||||
278 | my ($x, $y) = ($ar->[$i], $ar->[$i+1]); | ||||||
279 | my @r = &$f($ar->[$i], $ar->[$i+1]); | ||||||
280 | push @final, $r[0] if $r[0]; | ||||||
281 | $ar->[$i+1] = $r[1]; | ||||||
282 | } | ||||||
283 | @final; | ||||||
284 | } | ||||||
285 | } | ||||||
286 | } | ||||||
287 | IGN | ||||||
288 | ||undef; #}}} | ||||||
289 | |||||||
290 | |||||||
291 | |||||||
292 | 2 | 2 | 158 | use constant NoBrHr => 0x83; # Unicode codepoint="No Break Here" | |||
2 | 3 | ||||||
2 | 533 | ||||||
293 | our %_dflts; | ||||||
294 | our (%mod_dflts, %types); | ||||||
295 | BEGIN { | ||||||
296 | 2 | 2 | 32 | %_dflts=( | |||
297 | depth => 3, | ||||||
298 | ellipsis => '…', | ||||||
299 | expand_duprefs => 0, | ||||||
300 | implicit_io => 0, | ||||||
301 | maxstring => undef, | ||||||
302 | noquote => 1, | ||||||
303 | seen => '🔁', # 🔁 | ||||||
304 | undef => '∄', | ||||||
305 | ); | ||||||
306 | |||||||
307 | 2 | 0 | 9 | my $bool = sub { $_[0] ? 1 : 0 }; | |||
0 | 0 | ||||||
308 | 2 | 0 | 36 | my $intnum = sub { $_[0] =~ m{^([0-9]+)$} ? 0 + $1 : 0 }; | |||
0 | 0 | ||||||
309 | 2 | 0 | 19 | my $string = sub { length($_[0]) ? "$_[0]" : '' }; | |||
0 | 0 | ||||||
310 | 2 | 8 | my $true = sub { 1 }; | ||||
0 | 0 | ||||||
311 | |||||||
312 | 2 | 14 | %types=( | ||||
313 | default => $true, | ||||||
314 | depth => $intnum, | ||||||
315 | ellipsis => $string, | ||||||
316 | expand_duprefs => $bool, | ||||||
317 | implicit_io => $bool, | ||||||
318 | maxstring => $intnum, | ||||||
319 | noquote => $bool, | ||||||
320 | seen => $string, | ||||||
321 | undef => $string, | ||||||
322 | ); | ||||||
323 | |||||||
324 | #global default copy | ||||||
325 | 2 | 66 | $mod_dflts{""} = \%_dflts; | ||||
326 | } | ||||||
327 | |||||||
328 | |||||||
329 | 2 | 2 | 12 | use constant cc => '\x00-\x1f'; ## cc = caret class | |||
2 | 3 | ||||||
2 | 2334 | ||||||
330 | |||||||
331 | sub vrfmt($) { | ||||||
332 | 68 | 50 | 68 | 0 | 141 | my ($v, $pkg) = (shift || "", ""); | |
333 | 68 | 128 | my ($vl, $ic) = (length $v, 2+index $v, "::"); | ||||
334 | 68 | 50 | 33 | 152 | if ($ic >= 2 && $vl - $ic > 0) { | ||
335 | 0 | 0 | $pkg = substr $v, 0, $ic; | ||||
336 | 0 | 0 | $v = substr $v, $ic; | ||||
337 | } # here, 'v' is a var name | ||||||
338 | 68 | 50 | 134 | if ( $v =~ m{^([\x00-\x1f])(\w*)$} ) { # varname starting w/ctl-ch | |||
339 | 0 | 0 | $v = "^" . chr(0x40 + ord $1) . $2; # use carot encoding | ||||
340 | } | ||||||
341 | 68 | 329 | $pkg . $v; | ||||
342 | } | ||||||
343 | |||||||
344 | ################################################################################ | ||||||
345 | |||||||
346 | |||||||
347 | sub sw(*):lvalue; | ||||||
348 | # sub sw_decr(*); | ||||||
349 | |||||||
350 | 218 | 218 | 346 | sub _Px($$;$) { my ($p, $v) = (shift, shift); | |||
351 | 218 | 352 | local (*sw); *sw = sub (*):lvalue { | ||||
352 | defined($p->{$_[0]}) | ||||||
353 | ? $p->{$_[0]} | ||||||
354 | 231 | 100 | 231 | 1255 | : ($p->{$_[0]} = $mod_dflts{""}->{$_[0]}); | ||
355 | 218 | 548 | }; | ||||
356 | # local (*sw_decr); *sw_decr = sub(*) { my $res; | ||||||
357 | # 0 >= ($res = sw($_[0])) and return $res; | ||||||
358 | # --sw($_[0]); $res }; | ||||||
359 | |||||||
360 | 218 | 50 | 360 | unless (sw(expand_duprefs)) { | |||
361 | 218 | 100 | 66 | 445 | if (ref $v && ! SCALAR $v) { | ||
362 | 50 | 50 | 574 | if ($p->{__P_seen}{$v}) { return "*". sw(seen) . ":" . $v . "*" } | |||
0 | 0 | ||||||
363 | 50 | 101 | else { $p->{__P_seen}{$v} = 1 } | ||||
364 | } | ||||||
365 | } | ||||||
366 | 218 | 339 | my ($nargs, $lvl, $ro) = (scalar @_, 2, 0); | ||||
367 | 218 | 50 | 663 | if ($nargs) { | |||
368 | 218 | 241 | $lvl = $_[0]; | ||||
369 | 218 | 100 | 313 | if ($nargs>1) { $ro = $_[1] } | |||
155 | 160 | ||||||
370 | } | ||||||
371 | 218 | 100 | 309 | return sw('undef') unless defined $v; | |||
372 | 209 | 263 | my $rv = ref $v; | ||||
373 | 209 | 100 | 100 | 480 | if (1 > $lvl-- || !$rv) { # LAST level actons: | ||
374 | 163 | 179 | my $fmt; # prototypes are documentary (rt#89053) | ||||
375 | my $given = [ | ||||||
376 | 163 | 100 | 163 | 770 | sub ($$) { $_[0] =~ /^[-+]?[0-9]+\.?\z/ && q{%s} }, | ||
377 | 95 | 66 | 95 | 229 | sub ($$) { $_[1] && ($_[0] = vrfmt($_[0])), $_[1] && qq{%s} }, | ||
100 | |||||||
378 | 27 | 100 | 27 | 78 | sub ($$) { 1 == length($_[0]) && q{'%s'} }, | ||
379 | 18 | 50 | 18 | 73 | sub ($$) { $_[0] =~ m{^(?:[+-]?(?:\.\d+) | ||
380 | |(?:\d+\.\d+))\z}x && q{%.2f} }, | ||||||
381 | 18 | 100 | 18 | 59 | sub ($$) { substr($_[0],0,5) eq 'HASH(' && | ||
382 | '{'. sw(q(ellipsis)) .'}' . q{%.0s} }, | ||||||
383 | 14 | 50 | 14 | 41 | sub ($$) { substr($_[0],0,6) eq 'ARRAY(' && | ||
384 | '['. sw(q(ellipsis)) .']' . q{%.0s} }, | ||||||
385 | sub ($$) { substr($_[0],0,7) eq 'SCALAR(' && | ||||||
386 | 14 | 50 | 14 | 77 | do {'\\' . $p->_Px(${$_[0]}, $lvl) .' ' } }, | ||
0 | 0 | ||||||
0 | 0 | ||||||
387 | # sub ($$) { $mxstr && length ($_[0])>$mxstr && qq("%.${mxstr}s")}, | ||||||
388 | 14 | 50 | 14 | 48 | sub ($$) { ref $_[0] && q{%s} }, | ||
389 | 14 | 14 | 34 | sub ($$) { 1 && q{"%s"} }, | |||
390 | 163 | 1255 | ]; | ||||
391 | |||||||
392 | 163 | 100 | 311 | do { $fmt = $_->($v, $ro) and last } for @$given; | |||
377 | 520 | ||||||
393 | 163 | 1670 | return sprintf($fmt, $v); | ||||
394 | } else { | ||||||
395 | 46 | 61 | my $pkg = ''; | ||||
396 | |||||||
397 | 46 | 50 | 33 | 111 | ($pkg, $rv) = ($1, $2) if 0 <= (index $v, '=') && | ||
398 | $v =~ m{([\w:]+)=([cc\w][\w:]+)}; | ||||||
399 | |||||||
400 | 46 | 111 | local * nonrefs_b4_refs ; * nonrefs_b4_refs = sub { | ||||
401 | 54 | 100 | 54 | 199 | ref $v->{$a} cmp ref $v->{$b} || $a cmp $b | ||
402 | 46 | 133 | }; | ||||
403 | |||||||
404 | 46 | 110 | local (*IO_glob, *NIO_glob, *IO_io, *NIO_io); | ||||
405 | (*IO_glob, *NIO_glob, *IO_io, *NIO_io) = ( | ||||||
406 | 0 | 0 | 0 | sub(){'<*'.<$v>.'>'}, sub(){'<*='.$p->_Px($v, $lvl-1).'>'}, | |||
0 | 0 | ||||||
407 | 0 | 0 | 0 | sub(){'<='.<$v>.'>'}, sub(){'<|'.$p->_Px($v, $lvl-1).'|>'}, | |||
0 | 0 | ||||||
408 | 46 | 244 | ); | ||||
409 | 2 | 2 | 14 | no strict 'refs'; | |||
2 | 4 | ||||||
2 | 1580 | ||||||
410 | my %actions = ( | ||||||
411 | GLOB => ($p->{implicit_io}? *IO_glob: *NIO_glob), | ||||||
412 | IO => ($p->{implicit_io}? *IO_io : *NIO_io), | ||||||
413 | 0 | 0 | 0 | REF => sub(){ "\\" . $p->_Px($$_, $lvl-1) . ' '}, | |||
414 | 0 | 0 | 0 | SCALAR=> sub(){ $pkg.'\\' . $p->_Px($$_, $lvl).' ' }, | |||
415 | ARRAY => sub(){ $pkg."[". | ||||||
416 | (join ', ', | ||||||
417 | # not working: why? #reduce \&rm_adjacent, (commented out) | ||||||
418 | 9 | 9 | 22 | map{ $p->_Px($_, $lvl) } @$v ) ."]" }, | |||
63 | 134 | ||||||
419 | 37 | 37 | 62 | HASH => sub(){ $pkg.'{' . ( join ', ', @{[ | |||
420 | 37 | 149 | map { $p->_Px($_, $lvl, 1) . '=>'. | ||||
421 | 73 | 180 | $p->_Px($v->{$_}, $lvl,0) } | ||||
422 | sort nonrefs_b4_refs keys %$v]} ) . '}' }, | ||||||
423 | 46 | 50 | 474 | ); | |||
50 | |||||||
424 | 46 | 50 | 100 | if (my $act=$actions{$rv}) { &$act } | |||
46 | 68 | ||||||
425 | 0 | 0 | else { return "$v" } | ||||
426 | } | ||||||
427 | } | ||||||
428 | |||||||
429 | 14 | 14 | 21 | sub _init_p($) { my $p; my $caller = $_[0]; | |||
14 | 20 | ||||||
430 | 14 | 50 | 35 | croak P "FATAL: P::_init_p called with wrong# args (%s)", 0+@_ | |||
431 | unless (@_ == 1); | ||||||
432 | 14 | 100 | 52 | if (blessed $mod_dflts{$caller}) { # blessed caller already stored | |||
50 | |||||||
433 | 8 | 77 | $p = $mod_dflts{$caller}; | ||||
434 | } elsif (HASH $mod_dflts{$caller}) { # have hash, so bless it | ||||||
435 | 0 | 0 | bless $p = $mod_dflts{$caller}; | ||||
436 | } else { | ||||||
437 | 6 | 107 | bless $p = $mod_dflts{$caller} = {}; # init caller's flag hash | ||||
438 | } | ||||||
439 | 14 | 30 | $p; | ||||
440 | } | ||||||
441 | |||||||
442 | |||||||
443 | sub P(@) { | ||||||
444 | 9 | 9 | 0 | 25670 | my $undef_cnt=0; | ||
445 | 9 | 50 | 31 | if (!defined($_[0])) { | |||
446 | 0 | 0 | my $fmt = ("%s, " x (@_-1))."%s"; | ||||
447 | 0 | 0 | unshift @_, $fmt; | ||||
448 | } | ||||||
449 | |||||||
450 | 9 | 100 | 36 | my $p = ref $_[0] eq 'P' ? shift : _init_p(caller); | |||
451 | |||||||
452 | 9 | 24 | local (*sw); *sw = sub (*):lvalue { | ||||
453 | defined($p->{$_[0]}) | ||||||
454 | ? $p->{$_[0]} | ||||||
455 | 18 | 100 | 18 | 74 | : ($p->{$_[0]} = $mod_dflts{""}->{$_[0]}); | ||
456 | 9 | 38 | }; | ||||
457 | |||||||
458 | 9 | 50 | 42 | $p->{__P_seen} = {} unless ref $p->{__P_seen}; | |||
459 | |||||||
460 | local * unsee_ret = sub ($) { | ||||||
461 | 9 | 50 | 9 | 50 | delete $p->{__P_seen} if exists $p->{__P_seen}; | ||
462 | 9 | 30 | $_[0] }; | ||||
9 | 60 | ||||||
463 | |||||||
464 | 9 | 13 | my $v = $_[0]; | ||||
465 | 9 | 14 | my $rv = ref $v; | ||||
466 | 9 | 21 | my ($depth, $noquote) = (sw(depth), sw(noquote)); | ||||
467 | |||||||
468 | 9 | 50 | 24 | if (HASH eq $rv) { | |||
469 | 0 | 0 | my $params = $v; $v = shift; $rv = ref $v; | ||||
0 | 0 | ||||||
0 | 0 | ||||||
470 | 0 | 0 | 0 | $depth = $params->{depth} if exists $params->{depth}; | |||
471 | } | ||||||
472 | 9 | 50 | 49 | if (ARRAY eq $rv ) { $v = shift; | |||
0 | 0 | ||||||
473 | 0 | 0 | @_ = (@$v, @_); $v = $_[0]; $rv = ref $v } | ||||
0 | 0 | ||||||
0 | 0 | ||||||
474 | |||||||
475 | 9 | 35 | my ($fh, $explicit_out); | ||||
476 | 9 | 50 | 33 | 17 | if ($rv eq GLOB || $rv eq IO) { | ||
477 | 0 | 0 | ($fh, $explicit_out) = (shift, 1); | ||||
478 | 0 | 0 | $v = $_[0]; $rv = ref $v; | ||||
0 | 0 | ||||||
479 | 9 | 80 | } else { $fh =\*STDOUT } | ||||
480 | |||||||
481 | 9 | 50 | 15 | if (ARRAY eq $rv ) { $v = shift; | |||
0 | 0 | ||||||
482 | 0 | 0 | @_=(@$v, @_); $v=$_[0]; $rv = ref $v } | ||||
0 | 0 | ||||||
0 | 0 | ||||||
483 | |||||||
484 | 9 | 34 | my $fmt = shift; | ||||
485 | 9 | 11 | my $res = do { | ||||
486 | 2 | 2 | 13 | no warnings; | |||
2 | 6 | ||||||
2 | 340 | ||||||
487 | sprintf $fmt, | ||||||
488 | 9 | 17 | map {local $_ = $p->_Px($_, $depth, $noquote) } @_ | ||||
9 | 23 | ||||||
489 | }; | ||||||
490 | |||||||
491 | 9 | 71 | chomp $res; | ||||
492 | |||||||
493 | 9 | 50 | 25 | my ($nl, $ctx) = ("\n", defined wantarray ? 1 : 0); | |||
494 | |||||||
495 | 9 | 50 | 46 | ($res, $nl, $ctx) = (substr($res, 0, -1 + length $res), "", 2) if | |||
496 | ord(substr $res,-1) == NoBrHr; #"NO_BREAK_HERE" | ||||||
497 | |||||||
498 | 9 | 50 | 33 | 27 | if (!$fh && !$ctx) { #internal consistancy check | ||
499 | 0 | 0 | 0 | ($fh = \*STDERR) and | |||
500 | P $fh "Invalid File Handle presented for output, using STDERR"; | ||||||
501 | 0 | 0 | ($explicit_out, $nl) = (1, "\n") } | ||||
502 | |||||||
503 | 9 | 50 | 33 | 39 | else { return unsee_ret($res) if (!$explicit_out and $ctx == 1) } | ||
504 | |||||||
505 | 2 | 2 | 13 | no warnings 'utf8'; | |||
2 | 3 | ||||||
2 | 1102 | ||||||
506 | 0 | 0 | 0 | 0 | print $fh ($res . (!$ctx && (!$\ || $\ ne "\n") ? "\n" : "") ); | ||
507 | 0 | 0 | unsee_ret($res); | ||||
508 | } | ||||||
509 | |||||||
510 | |||||||
511 | sub Pe(@) { | ||||||
512 | 0 | 0 | 0 | 0 | 0 | my $p = ref $_[0] eq 'P' ? shift : _init_p(caller); | |
513 | 0 | 0 | unshift @_, \*STDERR; | ||||
514 | 0 | 0 | 0 | unshift @_, $p if ref $p; | |||
515 | 0 | 0 | goto &P | ||||
516 | } | ||||||
517 | |||||||
518 | |||||||
519 | 6 | 50 | 6 | 1642 | sub import { my $p = ref $_[0] eq 'P' ? $_[0] : _init_p(caller); | ||
520 | 6 | 14 | my ($modname, @args) = @_; | ||||
521 | 6 | 50 | 17 | goto &Xporter::import if caller eq 'P'; | |||
522 | 6 | 100 | 14 | if (@args) { | |||
523 | 4 | 5 | my @others; | ||||
524 | 4 | 6 | my $default = 0; | ||||
525 | 4 | 5 | my $got_default = 0; | ||||
526 | 4 | 6 | my $save_p = []; | ||||
527 | my @tags = grep { | ||||||
528 | 4 | 7 | my $full_switch; # has tag+args, but no colon | ||||
5 | 6 | ||||||
529 | 5 | 50 | 13 | if (0 == index $_, ':') { | |||
530 | 5 | 10 | $_ = substr $_, 1; | ||||
531 | 5 | 7 | $full_switch = $_; # includes any '=' fields | ||||
532 | 5 | 10 | my ($l, $tag, $val) = (-1, $_); | ||||
533 | 5 | 100 | 10 | if (($l = index $_, '=') > 0) { | |||
534 | 4 | 9 | $tag = substr $_, 0, $l; | ||||
535 | 4 | 5 | $val = substr $_, $l+1; | ||||
536 | } | ||||||
537 | 5 | 100 | 66 | 19 | if ($tag eq 'default' && !$got_default) { #can only have 1 dflt sec. | ||
50 | |||||||
538 | 1 | 1 | $default = 1; | ||||
539 | 1 | 2 | push @$save_p, $p; | ||||
540 | 1 | 3 | $p = $mod_dflts{""}; | ||||
541 | } elsif ($tag eq '--') { #end of dflts (:--) | ||||||
542 | 0 | 0 | $p = pop @$save_p; | ||||
543 | 0 | 0 | $default = 0; | ||||
544 | 0 | 0 | $got_default = 1; | ||||
545 | } else { | ||||||
546 | warnings::warn P "Unrecognized flag: %s", $tag unless | ||||||
547 | 4 | 50 | 20 | exists $mod_dflts{""}->{$tag}; | |||
548 | 4 | 50 | 36 | $p->{"$tag"} = defined("$val") ? "$val" : -1; | |||
549 | } | ||||||
550 | } else { | ||||||
551 | 0 | 0 | push @others, $_; | ||||
552 | } | ||||||
553 | } @args; | ||||||
554 | 4 | 11 | @_=($modname, @others); | ||||
555 | } | ||||||
556 | 6 | 21 | goto &Xporter::import; | ||||
557 | } | ||||||
558 | |||||||
559 | |||||||
560 | |||||||
561 | |||||||
562 | 1 | 33 | 1 | 0 | 542 | sub ops($) { my $p = shift; my $c = ref $p || $p; | |
1 | 6 | ||||||
563 | 1 | 3 | bless $p = {}; | ||||
564 | 2 | 2 | 15 | use Carp qw(croak); | |||
2 | 10 | ||||||
2 | 351 | ||||||
565 | 1 | 4 | my $caller = (caller)[0]; | ||||
566 | 1 | 2 | my $args = $_[0]; | ||||
567 | 1 | 50 | 4 | croak "ops takes a hash to pass arguments" unless HASH $args; | |||
568 | 1 | 15 | foreach (sort keys %$args) { | ||||
569 | 1 | 50 | 4 | if (defined $_dflts{$_}) { $p->{$_} = $args->{$_} } | |||
1 | 6 | ||||||
570 | else { | ||||||
571 | 0 | 0 | warn "Unknown key \"$_\" passed to ops";} | ||||
572 | } | ||||||
573 | $p | ||||||
574 | 1 | 3 | } | ||||
575 | 1} | ||||||
576 | |||||||
577 | { | ||||||
578 | package main; | ||||||
579 | 2 | 2 | 14 | use utf8; | |||
2 | 2 | ||||||
2 | 20 | ||||||
580 | |||||||
581 | unless ((caller 0)[0]) { | ||||||
582 | binmode P::DATA, ":utf8"; | ||||||
583 | binmode *STDOUT, ":utf8"; | ||||||
584 | binmode *STDERR, ":utf8"; | ||||||
585 | $_=do{ $/=undef, |
||||||
586 | close P::DATA; | ||||||
587 | our @globals; | ||||||
588 | eval $_; | ||||||
589 | die "self-test failed: $@" if $@; | ||||||
590 | 1; | ||||||
591 | } else { | ||||||
592 | close P::DATA; | ||||||
593 | } | ||||||
594 | 1; | ||||||
595 | } | ||||||
596 | ########################################################################### | ||||||
597 | # Pod documentation {{{1 | ||||||
598 | # use P; | ||||||
599 | |||||||
600 | =head1 SYNOPSIS | ||||||
601 | |||||||
602 | use P qw[:depth=5 :undef="(undef)"]; | ||||||
603 | |||||||
604 | P FILEHANDLE FORMAT, LIST | ||||||
605 | P FILEHANDLE, LIST # comma is not disallowed | ||||||
606 | P FORMAT, (LIST) | ||||||
607 | P (LIST) | ||||||
608 | P @ARRAY # may contain FH, FMT+ARGS & return string | ||||||
609 | $s = P @ARRAY; P $s; # can be same output as "P @ARRAY" | ||||||
610 | Pe # same as P STDERR,... | ||||||
611 | $s = P FILEHANDLE ... # sends same output to $s and FILEHANDLE | ||||||
612 | |||||||
613 | =head1 DESCRIPTION | ||||||
614 | |||||||
615 | C is a combined print, printf, sprintf & say in 1 routine. It saves |
||||||
616 | tremendously on development time. It's not just a 1 character verb, | ||||||
617 | but has other time-saving and powerful features: | ||||||
618 | |||||||
619 | =over | ||||||
620 | |||||||
621 | =item o B |
||||||
622 | |||||||
623 | =back | ||||||
624 | |||||||
625 | A fixed string can be changed to formatted output with no change of | ||||||
626 | verb: | ||||||
627 | |||||||
628 | Example: | ||||||
629 | # Starting with a "die" statement. | ||||||
630 | 1) die "Wrong number of params"; | ||||||
631 | # Then number of arguments passed is added: | ||||||
632 | 2) die P "Expecting 2 params, got %s", scalar @ARGV; | ||||||
633 | # Then contents of @ARGV can be printed as well (no loop needed): | ||||||
634 | 3) die P "Expecting 2 params, got %s (ARGV=%s), 0+@ARGV, \@ARGV; | ||||||
635 | |||||||
636 | |||||||
637 | C can replacing C |
||||||
638 | variable and without printing cryptic representations for @ARGV, | ||||||
639 | like "C |
||||||
640 | C displays the actual contents of the array, showing |
||||||
641 | ["arg1", "arg2"]. | ||||||
642 | |||||||
643 | |||||||
644 | =over | ||||||
645 | |||||||
646 | =item B<· Auto-Newline Handling> | ||||||
647 | |||||||
648 | =back | ||||||
649 | |||||||
650 | When it comes to C
|
||||||
651 | attempts to look at context. If output is assigned to a variable, | ||||||
652 | then C acts like C |
||||||
653 | it will act like C |
||||||
654 | Unlike C can use formatted output and print to a file |
||||||
655 | handle. Printing to STDERR is simplified with the C |
||||||
656 | C , which is a short form of 'P STDERR, "..."'. |
||||||
657 | |||||||
658 | When C prints to strings, any one newline at the end of the |
||||||
659 | string will be suppressed. Conversely it will add one if | ||||||
660 | printing to a device. If printing to a string and a device | ||||||
661 | at the same time, it will favor suppression and not output | ||||||
662 | a newline to the device. | ||||||
663 | |||||||
664 | =over | ||||||
665 | |||||||
666 | =item B<· Trapping C |
||||||
667 | |||||||
668 | =back | ||||||
669 | |||||||
670 | Rather than aborting output when C |
||||||
671 | C prints a configurable symbol, '∄', by default, the symbol |
||||||
672 | for "does not exist" where the undef would have printed and the | ||||||
673 | rest of the string is printed normally. | ||||||
674 | |||||||
675 | =over | ||||||
676 | |||||||
677 | =item B<· Less restrictive syntax> | ||||||
678 | |||||||
679 | =back | ||||||
680 | |||||||
681 | C tries not to have arbitrary restrictions on it's arguments. |
||||||
682 | |||||||
683 | It handles cases that the equivalent perl statement won't. | ||||||
684 | |||||||
685 | |||||||
686 | |||||||
687 | VERB -> P print printf sprintf say | ||||||
688 | V --FEATURE-- V --- ----- ------ ------- --- | ||||||
689 | 1) to a FH Yes Yes Yes No Yes | ||||||
690 | 2) to $fh Yes Yes Yes No No | ||||||
691 | 3) to a string Yes No No Yes No | ||||||
692 | 4) add EOL-NL to FH? Yes No No No Yes | ||||||
693 | 5) sub EOL-NL in string Yes No No No No | ||||||
694 | 6) FMT Yes No Yes Yes No | ||||||
695 | 7) @[FMT,ARGS] Yes No Yes No No | ||||||
696 | 8) undef to "%s" Yes No No No No | ||||||
697 | 9) @[$fh,FMT,ARGS] Yes No No No No | ||||||
698 | 10) like "tee" Yes No No No No | ||||||
699 | |||||||
700 | (9) - File Handle in 1st member of ARRAY used for output. | ||||||
701 | |||||||
702 | (10) - When P is being used as a string formatter like sprintf, | ||||||
703 | it can still have a "$fh" as the first argument that will | ||||||
704 | print the formatted string to the file handle as well as | ||||||
705 | returning it's value (note: this will force the string | ||||||
706 | to be printed w/o a trailing newline). | ||||||
707 | |||||||
708 | |||||||
709 | |||||||
710 | |||||||
711 | =head3 Undefs | ||||||
712 | |||||||
713 | |||||||
714 | When printed as strings (C<"%s">), undefs are automatically caught and | ||||||
715 | "E<0x2204>", (U+2204 - meaning "I |
||||||
716 | printed in place of "C | ||||||
717 | |||||||
718 | By default C , prints the content of references (instead HASH |
||||||
719 | (or ARRAY)=(0x12345678). By default, it prints three levels deep with | ||||||
720 | deeper nesting replaced by by the unicode ellipsis character (U+2026). | ||||||
721 | |||||||
722 | While designed for development use, it is useful in many more situations, as | ||||||
723 | tries to "do the right thing" based on context. It can usually be used | ||||||
724 | as a drop-in replacement the perl functions C |
||||||
725 | and, C |
||||||
726 | |||||||
727 | P tries to smartly handle newlines at the end of the line -- adding them | ||||||
728 | or subtracting them based on if they are going to a file handle or to another | ||||||
729 | variable. | ||||||
730 | |||||||
731 | The newline handling at the end of a line can be supressed by adding | ||||||
732 | the Unicode control char "Don't break here" (0x83) at the end of a string | ||||||
733 | or by assigning the return value B |
||||||
734 | argument. Ex: C |
||||||
735 | |||||||
736 | |||||||
737 | C |
||||||
738 | in front of the reference. Note that these substitutions are performed only with | ||||||
739 | references printed through a string (C<"%s">) format -- features designed | ||||||
740 | to give useful output in development or debug situations. | ||||||
741 | |||||||
742 | One difference between C and C can take |
||||||
743 | an array with the format in the 0th element, and parameters following. | ||||||
744 | C |
||||||
745 | to it, as it will force the array into scalar context -- which as | ||||||
746 | the manpage says "is almost never useful", and the perl-developers | ||||||
747 | admit "is never useful". Rather than follow in the | ||||||
748 | design flaws of its predecessors, P I |
||||||
749 | |||||||
750 | |||||||
751 | B |
||||||
752 | is if it is used as the last line of a subroutine. By default, this | ||||||
753 | won't print it's arguments to STDOUT unless you explicity specify the | ||||||
754 | filehandle, as it will think it is supposed to return the result -- not | ||||||
755 | print it. An alternate workaround -- return another value, like a | ||||||
756 | status value. OR use it as a feature. A subroutine that has | ||||||
757 | a C |
||||||
758 | can be used for direct output. | ||||||
759 | |||||||
760 | =head1 EXAMPLE: Duel-Use Subroutines for Strings or Printing | ||||||
761 | |||||||
762 | |||||||
763 | sub items_in_list() { | ||||||
764 | my $numitems = get_num(); | ||||||
765 | P "num items=%s", $numitems; | ||||||
766 | } # can be used: | ||||||
767 | |||||||
768 | my $s=items_in_list(); | ||||||
769 | # or | ||||||
770 | $items_in_list(); # prints to STDOUT w/newline on end | ||||||
771 | |||||||
772 | |||||||
773 | |||||||
774 | |||||||
775 | |||||||
776 | =head2 Special Use Features | ||||||
777 | |||||||
778 | |||||||
779 | While C is normally called procedurally, and not as an object, there are |
||||||
780 | some rare cases where one would really like it to print "just 1 level | ||||||
781 | deeper". To do that, you need to get a pointer to C 's C |
||||||
782 | |||||||
783 | To get that pointer, call C 's options and |
||||||
784 | save the return value. Use that pointer to call P. See following example. | ||||||
785 | |||||||
786 | =head1 EXAMPLE: (changing P's defaults) | ||||||
787 | |||||||
788 | Suppose you had an array of objects, and you wanted to see the contents | ||||||
789 | of the objects in the array. Normally P would only print the first two levels: | ||||||
790 | |||||||
791 | |||||||
792 | my %complex_probs = ( | ||||||
793 | questions =E |
||||||
794 | answers =E |
||||||
795 | {real => 0, i => -2 } ] ); | ||||||
796 | my $prob_ref = \%complex_problems; | ||||||
797 | P "my probs = %s", [$prob_ref]; | ||||||
798 | |||||||
799 | |||||||
800 | The above would normally produce: | ||||||
801 | |||||||
802 | my probs = [{answers=>[{…}, {…}], questions=>["sqrt(-4)", "(1-i)**2"]}] | ||||||
803 | |||||||
804 | |||||||
805 | Instead of the contents of the hashes, P shows the ellipses (a | ||||||
806 | 1 char-width wide character) for the interior of the hashes. If you | ||||||
807 | wanted the interior to print, you'd need to raise the default data | ||||||
808 | expansion I as we do here: |
||||||
809 | |||||||
810 | |||||||
811 | my %complex_probs = ( | ||||||
812 | questions => [ "sqrt(-4)", "(1-i)**2" ], | ||||||
813 | answers => [ {real => 0, i =>2 }, { real => 0, i => -2 } ] ); | ||||||
814 | my $p=P::->ops({depth=>4}); | ||||||
815 | $p->P("my array = %s", \%complex_probs); | ||||||
816 | |||||||
817 | |||||||
818 | The above allows 1 extra level of depth to be printed, so the elements in the | ||||||
819 | hash are displayed producing: | ||||||
820 | |||||||
821 | my probs = [{answers=>[{i=>2, real=>0}, {i=>-2, real=>0}], # extra "\n" | ||||||
822 | questions=>["sqrt(-4)", "(1-i)**2"]}] | ||||||
823 | |||||||
824 | |||||||
825 | B |
||||||
826 | needed to tell perl you are not talking about the function name. | ||||||
827 | |||||||
828 | Please don't expect data printed by P to be "pretty" or parseable. It's not | ||||||
829 | meant to be a Perl::Tidy or Data::Dumper. I |
||||||
830 | references, it was designed as a development aid. | ||||||
831 | |||||||
832 | |||||||
833 | |||||||
834 | =head2 Summary of possible OO args to "ops" (and defaults) | ||||||
835 | |||||||
836 | =over | ||||||
837 | |||||||
838 | =item C |
||||||
839 | |||||||
840 | =over | ||||||
841 | |||||||
842 | Allows setting depth of nested structure printing. NOTE: regardless of depth, | ||||||
843 | recursive structures in the same call to C , will not expand but be displayed |
||||||
844 | in an abbreviated form. | ||||||
845 | |||||||
846 | =back | ||||||
847 | |||||||
848 | =item C |
||||||
849 | |||||||
850 | =over | ||||||
851 | |||||||
852 | When printing references, GLOBS and IO refs do not have their | ||||||
853 | contents printed (since printing contents of such refs may do I/O that | ||||||
854 | changes the object's state). If this is wanted, one would call C |
||||||
855 | |||||||
856 | =back | ||||||
857 | |||||||
858 | =item C |
||||||
859 | |||||||
860 | =over | ||||||
861 | |||||||
862 | In printing items in hashes or arrays, data that are Read-Only or do not need | ||||||
863 | quoting won't have quoting (contrast to Data::Dumper, where it can be turned | ||||||
864 | off or on, but not turned on, only when needed). | ||||||
865 | |||||||
866 | =back | ||||||
867 | |||||||
868 | =item C |
||||||
869 | |||||||
870 | =over 2 | ||||||
871 | |||||||
872 | Allows specifying a maximum length of any single datum when expanded from an indirection expansion. | ||||||
873 | |||||||
874 | =back | ||||||
875 | |||||||
876 | =back | ||||||
877 | |||||||
878 | =head2 Example 2: Not worrying about "undefs" | ||||||
879 | |||||||
880 | Looking at some old code of mine, I found this: | ||||||
881 | |||||||
882 | print sprintf STDERR, | ||||||
883 | "Error: in parsing (%s), proto=%s, host=%s, page=%s\n", | ||||||
884 | $_[0] // "null", $proto // "null", $host // "null", | ||||||
885 | $path // "null"; | ||||||
886 | die "Exiting due to error." | ||||||
887 | |||||||
888 | Too many words and effort in upgrading a die message! Now it looks like: | ||||||
889 | |||||||
890 | die P "Error: in parsing (%s), proto=%s, host=%s, page=%s", | ||||||
891 | $_[0], $proto, $host, $path; | ||||||
892 | |||||||
893 | It's not just about formatting or replacing sprintf -- but automatically | ||||||
894 | giving you sanity in places like error messages and debug output when | ||||||
895 | the variables you are printing may be 'undef' -- which would abort the | ||||||
896 | output entirely! | ||||||
897 | |||||||
898 | |||||||
899 | |||||||
900 | =head1 MORE EXAMPLES | ||||||
901 | |||||||
902 | |||||||
903 | P "Hello %s", "World"; # auto NL when to a FH | ||||||
904 | P "Hello \x83"; P "World"; # \x83: suppress auto-NL to FH's | ||||||
905 | $s = P "%s", "Hello %s"; # not needed if printing to string | ||||||
906 | P $s, "World"; # still prints "Hello World" | ||||||
907 | |||||||
908 | @a = ("Hello %s", "World"); # using array, fmt as 1st arg | ||||||
909 | P @a; # print "Hello World" | ||||||
910 | P 0 + @a; # prints #items in '@a': 2 | ||||||
911 | |||||||
912 | P "a=%s", \@a; # prints contents of 'a': [1,2,3...] | ||||||
913 | |||||||
914 | P STDERR @a # use @a as args to a specific FH | ||||||
915 | # Uses indirect method calls when | ||||||
916 | # invoked like "print FH ARGS" | ||||||
917 | # | ||||||
918 | Pe "Output to STDERR" # 'Shortcut' for P to STDERR | ||||||
919 | |||||||
920 | %H=(one=>1, two=>2, u=>undef); # P Hash bucket usage + contents: | ||||||
921 | |||||||
922 | P "%H hash usage: %s", "".%H; # Shows used/total Hash bucket usage | ||||||
923 | P "%H=%s", \%H; # print contents of hash: | ||||||
924 | |||||||
925 | %H={u=>(undef), one=>1, two=>2} | ||||||
926 | |||||||
927 | bless my $h=\%H, 'Hclass'; # Blessed objects... | ||||||
928 | P "Obj_h = %s", $h; # & content: | ||||||
929 | |||||||
930 | Obj_h = Hclass{u=>(undef), one=>1, two=>2} | ||||||
931 | |||||||
932 | |||||||
933 | =head1 Sample Code + Test + Demo | ||||||
934 | |||||||
935 | To demonstrate the various usages of P, several examples are embedded | ||||||
936 | with this documenation in a special C section. If this module | ||||||
937 | is executed as with C |
||||||
938 | set to be executable, it will run a short program that shows | ||||||
939 | different features of P as well as doing a short run-time test | ||||||
940 | (that is actually part of the test suite). | ||||||
941 | |||||||
942 | The demo/example/test code embedded in this module is NOT compiled or | ||||||
943 | accessed when it is C | ||||||
944 | |||||||
945 | As of this writing there are 13 examples. The output of these | ||||||
946 | examples follows: | ||||||
947 | |||||||
948 | =over | ||||||
949 | |||||||
950 | #1 (ret from func) : Hello Perl 1 | ||||||
951 | #2 (w/string) : Hello Perl 2 | ||||||
952 | #3 (passed array) : Hello Perl 3 | ||||||
953 | #4 (w/fmt+string) : Hello Perl 4 | ||||||
954 | #5 (to STDERR) : Hello Perl 5 | ||||||
955 | #6 (to strng embedded in #7): | ||||||
956 | #7 (prev string) : prev str="Hello Perl 6" (no LF) && Hello Perl 7 | ||||||
957 | #8 (P && array ref) : ["one", "two", "three", 4, 5, 6] | ||||||
958 | #9 (P HASH ref) : {a=>"apple", b=>"bread", c=>"cherry"} | ||||||
959 | #10 (P Pkg ref) : Pkg{a=>1, b=>2, x=>'y'} | ||||||
960 | #11 (P @{[FH,["fmt:%s",…]]}) : fmt:Hello Perl 11 | ||||||
961 | #12 (truncate embedded float): norm=3.14159265358979324, embed={pi=>3.14} | ||||||
962 | #13 (test mixed digit string): embed roman pi = ["3.ⅰⅳⅰⅴⅸ"] | ||||||
963 | |||||||
964 | =back | ||||||
965 | |||||||
966 | The code uses a function C |
||||||
967 | an autoincrementing counter that also is used as the test or example | ||||||
968 | number. | ||||||
969 | |||||||
970 | Putting the format + its arguments in an array is simple and does not | ||||||
971 | change if P is printing to output or to a string (cf. sprintf/printf). | ||||||
972 | P goes further than allowing the format specification in an array -- it | ||||||
973 | also allows putting the file handle as the 1st element in the array as | ||||||
974 | shown in #11. | ||||||
975 | |||||||
976 | P is not picky about how file handles can be used -- they can be | ||||||
977 | followed by a space or by a comma. No special syntax is needed for the | ||||||
978 | arguments of P, it can follow the example of printf or the standard | ||||||
979 | usage of using commas to separate arguments. | ||||||
980 | |||||||
981 | |||||||
982 | =head1 NOTES | ||||||
983 | |||||||
984 | Values given as args with a format statement, are checked for B |
||||||
985 | and have "E<0x2204>" substituted for undefined values. If you print | ||||||
986 | vars as in decimal or floating point, they'll likely show up as 0, which | ||||||
987 | doesn't stand out as well. | ||||||
988 | |||||||
989 | Sometimes the perl parser gets confused about what args belong to P and | ||||||
990 | which do not. Using parentheses (I ) can help |
||||||
991 | in those cases. | ||||||
992 | |||||||
993 | Usable in any code, P was was designed to save typing, time and work of | ||||||
994 | undef checking, newline handling, peeking at data structures in small | ||||||
995 | spaces during development. It tries to do the "right thing" with the | ||||||
996 | given input. It may not be suitable where speed is paramount. | ||||||
997 | |||||||
998 | =cut | ||||||
999 | |||||||
1000 | |||||||
1001 | #}}}1 | ||||||
1002 | |||||||
1003 | package P; | ||||||
1004 | __DATA__ |