1package Data::Printer::Common; 2# Private library of shared Data::Printer code. 3use strict; 4use warnings; 5use Scalar::Util; 6 7my $mro_initialized = 0; 8my $nsort_initialized; 9 10 11sub _filter_category_for { 12 my ($name) = @_; 13 my %core_types = map { $_ => 1 } 14 qw(SCALAR LVALUE ARRAY HASH REF VSTRING GLOB FORMAT Regexp CODE); 15 return exists $core_types{$name} ? 'type_filters' : 'class_filters'; 16} 17 18# strings are tough to process: there are control characters like "\t", 19# unicode characters to name or escape (or do nothing), max_string to 20# worry about, and every single piece of that could have its own color. 21# That, and hash keys and strings share this. So we put it all in one place. 22sub _process_string { 23 my ($ddp, $string, $src_color) = @_; 24 25 # colorizing messes with reduce_string because we are effectively 26 # adding new (invisible) characters to the string. So we need to 27 # handle reduction first. But! Because we colorize string_max 28 # *and* we should escape any colors already present, we need to 29 # do both at the same time. 30 $string = _reduce_string($ddp, $string, $src_color); 31 32 # now we escape all other control characters except for "\e", which was 33 # already escaped in _reduce_string(), and convert any chosen charset 34 # to the \x{} format. These could go in any particular order: 35 $string = _escape_chars($ddp, $string, $src_color); 36 $string = _print_escapes($ddp, $string, $src_color); 37 38 # finally, send our wrapped string: 39 return $ddp->maybe_colorize($string, $src_color); 40} 41 42sub _colorstrip { 43 my ($string) = @_; 44 $string =~ s{ \e\[ [\d;]* m }{}xmsg; 45 return $string; 46} 47 48sub _reduce_string { 49 my ($ddp, $string, $src_color) = @_; 50 my $max = $ddp->string_max; 51 my $str_len = length($string); 52 if ($max && $str_len && $str_len > $max) { 53 my $preserve = $ddp->string_preserve; 54 my $skipped_chars = $str_len - ($preserve eq 'none' ? 0 : $max); 55 my $skip_message = $ddp->maybe_colorize( 56 $ddp->string_overflow, 57 'caller_info', 58 undef, 59 $src_color 60 ); 61 $skip_message =~ s/__SKIPPED__/$skipped_chars/g; 62 if ($preserve eq 'end') { 63 substr $string, 0, $skipped_chars, ''; 64 $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge 65 if $ddp->print_escapes; 66 $string = $skip_message . $string; 67 } 68 elsif ($preserve eq 'begin') { 69 $string = substr($string, 0, $max); 70 $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge 71 if $ddp->print_escapes; 72 $string = $string . $skip_message; 73 } 74 elsif ($preserve eq 'extremes') { 75 my $leftside_chars = int($max / 2); 76 my $rightside_chars = $max - $leftside_chars; 77 my $leftside = substr($string, 0, $leftside_chars); 78 my $rightside = substr($string, -$rightside_chars); 79 if ($ddp->print_escapes) { 80 $leftside =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge; 81 $rightside =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge; 82 } 83 $string = $leftside . $skip_message . $rightside; 84 } 85 elsif ($preserve eq 'middle') { 86 my $string_middle = int($str_len / 2); 87 my $middle_substr = int($max / 2); 88 my $substr_begin = $string_middle - $middle_substr; 89 my $message_begin = $ddp->string_overflow; 90 $message_begin =~ s/__SKIPPED__/$substr_begin/gs; 91 my $chars_left = $str_len - ($substr_begin + $max); 92 my $message_end = $ddp->string_overflow; 93 $message_end =~ s/__SKIPPED__/$chars_left/gs; 94 $string = substr($string, $substr_begin, $max); 95 $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge 96 if $ddp->print_escapes; 97 $string = $ddp->maybe_colorize($message_begin, 'caller_info', undef, $src_color) 98 . $string 99 . $ddp->maybe_colorize($message_end, 'caller_info', undef, $src_color) 100 ; 101 } 102 else { 103 # preserving 'none' only shows the skipped message: 104 $string = $skip_message; 105 } 106 } 107 else { 108 # nothing to do? ok, then escape any colors already present: 109 $string =~ s{\e}{$ddp->maybe_colorize('\\e', 'escaped', undef, $src_color)}ge 110 if $ddp->print_escapes; 111 } 112 return $string; 113} 114 115 116# _escape_chars() replaces characters with their "escaped" versions. 117# Because it may be called on scalars or (scalar) hash keys and they 118# have different colors, we need to be aware of that. 119sub _escape_chars { 120 my ($ddp, $scalar, $src_color) = @_; 121 122 my $escape_kind = $ddp->escape_chars; 123 my %target_for = ( 124 nonascii => '[^\x{00}-\x{7f}]+', 125 nonlatin1 => '[^\x{00}-\x{ff}]+', 126 ); 127 128 if ($ddp->unicode_charnames) { 129 require charnames; 130 if ($escape_kind eq 'all') { 131 $scalar = join('', map { sprintf '\N{%s}', charnames::viacode(ord $_) } split //, $scalar); 132 $scalar = $ddp->maybe_colorize($scalar, 'escaped'); 133 } 134 else { 135 $scalar =~ s{($target_for{$escape_kind})}{$ddp->maybe_colorize( (join '', map { sprintf '\N{%s}', charnames::viacode(ord $_) } split //, $1), 'escaped', undef, $src_color)}ge if exists $target_for{$escape_kind}; 136 } 137 } 138 elsif ($escape_kind eq 'all') { 139 $scalar = join('', map { sprintf '\x{%02x}', ord $_ } split //, $scalar); 140 $scalar = $ddp->maybe_colorize($scalar, 'escaped'); 141 } 142 else { 143 $scalar =~ s{($target_for{$escape_kind})}{$ddp->maybe_colorize((join '', map { sprintf '\x{%02x}', ord $_ } split //, $1), 'escaped', undef, $src_color)}ge if exists $target_for{$escape_kind}; 144 } 145 return $scalar; 146} 147 148# _print_escapes() prints invisible chars if they exist on a string. 149# Because it may be called on scalars or (scalar) hash keys and they 150# have different colors, we need to be aware of that. Also, \e is 151# deliberately omitted because it was escaped from the original 152# string earlier, and the \e's we have now are our own colorized 153# output. 154sub _print_escapes { 155 my ($ddp, $string, $src_color) = @_; 156 157 # always escape the null character 158 $string =~ s/\0/$ddp->maybe_colorize('\\0', 'escaped', undef, $src_color)/ge; 159 160 return $string unless $ddp->print_escapes; 161 162 my %escaped = ( 163 "\n" => '\n', # line feed 164 "\r" => '\r', # carriage return 165 "\t" => '\t', # horizontal tab 166 "\f" => '\f', # formfeed 167 "\b" => '\b', # backspace 168 "\a" => '\a', # alert (bell) 169 ); 170 foreach my $k ( keys %escaped ) { 171 $string =~ s/$k/$ddp->maybe_colorize($escaped{$k}, 'escaped', undef, $src_color)/ge; 172 } 173 return $string; 174} 175 176sub _initialize_nsort { 177 return 'Sort::Key::Natural' if $INC{'Sort/Key/Natural.pm'}; 178 return 'Sort::Naturally' if $INC{'Sort/Naturally.pm'}; 179 return 'Sort::Key::Natural' if eval { require Sort::Key::Natural; 1; }; 180 return 'Sort::Naturally' if eval { require Sort::Naturally; 1; }; 181 return 'core'; 182} 183 184sub _nsort { 185 if (!$nsort_initialized) { 186 my $nsort_class = _initialize_nsort(); 187 if ($nsort_class eq 'Sort::Key::Natural') { 188 $nsort_initialized = \&{ $nsort_class . '::natsort' }; 189 } 190 elsif ($nsort_class ne 'core') { 191 $nsort_initialized = \&{ $nsort_class . '::nsort' }; 192 } 193 else { 194 $nsort_initialized = \&_nsort_pp 195 } 196 } 197 return $nsort_initialized->(@_); 198} 199 200# this is a very simple 'natural-ish' sorter, heavily inspired in 201# http://www.perlmonks.org/?node_id=657130 by thundergnat and tye 202sub _nsort_pp { 203 my $i; 204 my @unsorted = map lc, @_; 205 foreach my $data (@unsorted) { 206 no warnings 'uninitialized'; 207 $data =~ s/((\.0*)?)(\d+)/("\x0" x length $2) . (pack 'aNa*', 0, length $3, $3)/eg; 208 $data .= ' ' . $i++; 209 } 210 return @_[ map { (split)[-1] } sort @unsorted ]; 211} 212 213sub _fetch_arrayref_of_scalars { 214 my ($props, $name) = @_; 215 return [] unless exists $props->{$name} && ref $props->{$name} eq 'ARRAY'; 216 my @valid; 217 foreach my $option (@{$props->{$name}}) { 218 if (ref $option) { 219 # FIXME: because there is no object at this point, we need to check 220 # the 'warnings' option ourselves. 221 _warn(undef, "'$name' option requires scalar values only. Ignoring $option.") 222 if !exists $props->{warnings} || !$props->{warnings}; 223 next; 224 } 225 push @valid, $option; 226 } 227 return \@valid; 228} 229 230sub _fetch_anyof { 231 my ($props, $name, $default, $list) = @_; 232 return $default unless exists $props->{$name}; 233 foreach my $option (@$list) { 234 return $option if $props->{$name} eq $option; 235 } 236 _die( 237 "invalid value '$props->{$name}' for option '$name'" 238 . "(must be one of: " . join(',', @$list) . ")" 239 ); 240}; 241 242 243sub _fetch_scalar_or_default { 244 my ($props, $name, $default) = @_; 245 return $default unless exists $props->{$name}; 246 247 if (my $ref = ref $props->{$name}) { 248 _die("'$name' property must be a scalar, not a reference to $ref"); 249 } 250 return $props->{$name}; 251} 252 253sub _die { 254 my ($message) = @_; 255 my ($file, $line) = _get_proper_caller(); 256 die '[Data::Printer] ' . $message . " at $file line $line.\n"; 257} 258 259sub _warn { 260 my ($ddp, $message) = @_; 261 return if $ddp && !$ddp->warnings; 262 my ($file, $line) = _get_proper_caller(); 263 warn '[Data::Printer] ' . $message . " at $file line $line.\n"; 264} 265 266sub _get_proper_caller { 267 my $frame = 1; 268 while (my @caller = caller($frame++)) { 269 if ($caller[0] !~ /\AD(?:DP|ata::Printer)/) { 270 return ($caller[1], $caller[2]); 271 } 272 } 273 return ('n/d', 'n/d'); 274} 275 276 277# simple eval++ adapted from Try::Tiny. 278# returns a (true) error message if failed. 279sub _tryme { 280 my ($subref_or_string) = @_; 281 282 my $previous_error = $@; 283 my ($failed, $error); 284 285 if (ref $subref_or_string eq 'CODE') { 286 $failed = not eval { 287 local $SIG{'__DIE__'}; # make sure we don't trigger any exception hooks. 288 $@ = $previous_error; 289 $subref_or_string->(); 290 return 1; 291 }; 292 $error = $@; 293 } 294 else { 295 my $code = q(local $SIG{'__DIE__'};) . $subref_or_string; 296 $failed = not eval $code; 297 $error = $@; 298 } 299 $@ = $previous_error; 300 # at this point $failed contains a true value if the eval died, 301 # even if some destructor overwrote $@ as the eval was unwinding. 302 return unless $failed; 303 return ($error || '(unknown error)'); 304} 305 306 307# When printing array elements or hash keys, we may traverse all of it 308# or just a few chunks. This function returns those chunks' indexes, and 309# a scalar ref to a message whenever a chunk was skipped. 310sub _fetch_indexes_for { 311 my ($array_ref, $prefix, $ddp) = @_; 312 313 my $max_function = $prefix . '_max'; 314 my $preserve_function = $prefix . '_preserve'; 315 my $overflow_function = $prefix . '_overflow'; 316 my $max = $ddp->$max_function; 317 my $preserve = $ddp->$preserve_function; 318 319 return (0 .. $#{$array_ref}) if !$max || @$array_ref <= $max; 320 321 my $skip_message = $ddp->maybe_colorize($ddp->$overflow_function, 'overflow'); 322 if ($preserve eq 'begin' || $preserve eq 'end') { 323 my $n_elements = @$array_ref - $max; 324 $skip_message =~ s/__SKIPPED__/$n_elements/g; 325 return $preserve eq 'begin' 326 ? ((0 .. ($max - 1)), \$skip_message) 327 : (\$skip_message, ($n_elements .. $#{$array_ref})) 328 ; 329 } 330 elsif ($preserve eq 'extremes') { 331 my $half_max = int($max / 2); 332 my $last_index_of_chunk_one = $half_max - 1; 333 my $n_elements = @$array_ref - $max; 334 335 my $first_index_of_chunk_two = @$array_ref - ($max - $half_max); 336 $skip_message =~ s/__SKIPPED__/$n_elements/g; 337 return ( 338 (0 .. $last_index_of_chunk_one), 339 \$skip_message, 340 ($first_index_of_chunk_two .. $#{$array_ref}) 341 ); 342 } 343 elsif ($preserve eq 'middle') { 344 my $array_middle = int($#{$array_ref} / 2); 345 my $first_index_to_show = $array_middle - int($max / 2); 346 my $last_index_to_show = $first_index_to_show + $max - 1; 347 my ($message_begin, $message_end) = ($skip_message, $skip_message); 348 $message_begin =~ s/__SKIPPED__/$first_index_to_show/gse; 349 my $items_left = $#{$array_ref} - $last_index_to_show; 350 $message_end =~ s/__SKIPPED__/$items_left/gs; 351 return ( 352 \$message_begin, 353 $first_index_to_show .. $last_index_to_show, 354 \$message_end 355 ); 356 } 357 else { # $preserve eq 'none' 358 my $n_elements = scalar(@$array_ref); 359 $skip_message =~ s/__SKIPPED__/$n_elements/g; 360 return (\$skip_message); 361 } 362} 363 364# helpers below strongly inspired by the excellent Package::Stash: 365sub _linear_ISA_for { 366 my ($class, $ddp) = @_; 367 _initialize_mro($ddp) unless $mro_initialized; 368 my $isa; 369 if ($mro_initialized > 0) { 370 $isa = mro::get_linear_isa($class); 371 } 372 else { 373 # minimal fallback in case Class::MRO isn't available 374 # (should only matter for perl < 5.009_005): 375 $isa = [ $class, _get_superclasses_for($class) ]; 376 } 377 return [@$isa, ($ddp->class->universal ? 'UNIVERSAL' : ())]; 378} 379 380sub _initialize_mro { 381 my ($ddp) = @_; 382 my $error = _tryme(sub { 383 if ($] < 5.009_005) { require MRO::Compat } 384 else { require mro } 385 1; 386 }); 387 if ($error && index($error, 'in @INC') != -1 && $mro_initialized == 0) { 388 _warn( 389 $ddp, 390 ($] < 5.009_005 ? 'MRO::Compat' : 'mro') . ' not found in @INC.' 391 . ' Objects may display inaccurate/incomplete ISA and method list' 392 ); 393 } 394 $mro_initialized = $error ? -1 : 1; 395} 396 397sub _get_namespace { 398 my ($class_name) = @_; 399 my $namespace; 400 { 401 no strict 'refs'; 402 $namespace = \%{ $class_name . '::' } 403 } 404 # before 5.10, stashes don't ever seem to drop to a refcount of zero, 405 # so weakening them isn't helpful 406 Scalar::Util::weaken($namespace) if $] >= 5.010; 407 408 return $namespace; 409} 410 411sub _get_superclasses_for { 412 my ($class_name) = @_; 413 my $namespace = _get_namespace($class_name); 414 my $res = _get_symbol($class_name, $namespace, 'ISA', 'ARRAY'); 415 return @{ $res || [] }; 416} 417 418sub _get_symbol { 419 my ($class_name, $namespace, $symbol_name, $symbol_kind) = @_; 420 421 if (exists $namespace->{$symbol_name}) { 422 my $entry_ref = \$namespace->{$symbol_name}; 423 if (ref($entry_ref) eq 'GLOB') { 424 return *{$entry_ref}{$symbol_kind}; 425 } 426 else { 427 if ($symbol_kind eq 'CODE') { 428 no strict 'refs'; 429 return \&{ $class_name . '::' . $symbol_name }; 430 } 431 } 432 } 433 return; 434} 435 4361; 437