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