view release on metacpan or  search on metacpan

lib/Data/Dumper/Interp.pm  view on Meta::CPAN

# License: Public Domain or CC0 See
# https://creativecommons.org/publicdomain/zero/1.0/
# The author, Jim Avera (jim.avera at gmail) has waived all copyright and
# related or neighboring rights.  Attribution is requested but is not required.

##FIXME: Refaddr(1) has no effect inside Blessed structures
#

use strict; use warnings FATAL => 'all'; use utf8;
#use 5.010; # say, state
#use 5.011; # cpantester gets warning that 5.11 is the minimum acceptable
#use 5.014; # /r for non-destructive substitution
use 5.018;  # lexical_subs
use feature qw(say state lexical_subs current_sub);
use feature 'lexical_subs';
use feature 'unicode_strings';

package
  # newline so Dist::Zilla::Plugin::PkgVersion won't add $VERSION
        DB {
  sub DB_Vis_Evalwrapper {
    eval $Data::Dumper::Interp::string_to_eval; ## no critic
  }
}

package Data::Dumper::Interp;

{ no strict 'refs'; ${__PACKAGE__."::VER"."SION"} = 997.999; }
our $VERSION = '8.000'; # VERSION from Dist::Zilla::Plugin::OurPkgVersion
our $DATE = '2026-04-22'; # DATE from Dist::Zilla::Plugin::OurDate

# Arrgh!  Moose forcibly enables experimental feature warnings!
# So import Moose first and then adjust warnings...
use Moose;

extends 'Data::Visitor' => { -version => 0.32 },
        'Exporter'      => { -version => 5.57 },
        ;

no warnings "experimental::lexical_subs";

use constant _SUPPORTS_CORE_BOOLS => defined &builtin::is_bool;
my $bitwise_supported;
BEGIN {
  $bitwise_supported = eval "use feature 'bitwise'";
  warnings->unimport("experimental::builtin") if _SUPPORTS_CORE_BOOLS;
}
use if $bitwise_supported, "feature", "bitwise";

use re qw/is_regexp regexp_pattern/;
use Data::Dumper ();
use Carp;
use POSIX qw(INT_MAX);
use Scalar::Util qw(blessed reftype refaddr looks_like_number weaken);
use List::Util 1.45 qw(min max first none all any sum0);
use Data::Structure::Util qw/circular_off/;
use Regexp::Common qw/RE_balanced RE_quoted/;
#use Term::ReadKey ();
use Term::Size 0.211 ();
use Sub::Identify qw/sub_name sub_fullname get_code_location/;
use File::Basename qw/basename/;
use overload ();

############################ Exports #######################################
# Short-hand functions/methods are generated on demand (i.e. if imported or
# called as a method) based on a naming convention.
############################################################################

our @EXPORT    = qw( visnew
                     vis avis hvis ivis dvis
                     viso aviso hviso iviso ivisO dviso dvisO
                     visq avisq hvisq ivisq dvisq
                     visr avisr hvisr ivisr dvisr
                     rvis rvisq
                     addrvis addrvisl
                     u quotekey qsh qshlist qshpath
                   );

our @EXPORT_OK = qw(addrvis_digits
                    RefArgFormatter

                    $Debug $MaxStringwidth $Trunctailwidth $Truncsuffix
                    $Objects $Foldwidth $Useqq $Quotekeys $Sortkeys
                    $Maxdepth $Maxrecurse $Deparse $Deepcopy);

our %EXPORT_TAGS = (
  null => [],
);

sub _generate_sub($;$); # forward

our ($COND_LB, $COND_RB, $COND_MULT, $LQ, $RQ);

#---------------------------------------------------------------------------
my $sane_cW = $^W;
my $sane_cH = $^H;
our @save_stack;
sub _SaveAndResetPunct() {
  # Save things which will later be restored
  push @save_stack, [ $@, $!+0, $^E+0, $., $,, $/, $\, $?, $^W ];
  # Reset sane values
  $,  = "";       # output field separator is null string
  $/  = "\n";     # input record separator is newline
  $\  = "";       # output record separator is null string
  $?  = 0;        # child process exit status
  $^W = $sane_cW; # our load-time warnings
  #$^H = $sane_cH; # our load-time pragmas (strict etc.)
}
sub _RestorePunct_NoPop() {
  ( $@, $!, $^E, $., $,, $/, $\, $?, $^W ) = @{ $save_stack[-1] };
}
sub _RestorePunct() {
  &_RestorePunct_NoPop;
  pop @save_stack;

lib/Data/Dumper/Interp.pm  view on Meta::CPAN

      }
      next if $_ eq ""; # null specifier
      if (/style=((?:[^:,]+|\\.)+),((?:[^:]|\\.)+)/) {
        $q_pfx = ""; $q_lq = $1; $q_rq = $2;
        $q_lq =~ s/\\(.)/$1/g; $q_rq =~ s/\\(.)/$1/g;
        next
      }
      oops "Invalid ",_dbvis($_)," in Useqq specifier ",_dbvis($useqq),"\n";
    }
  }

  my $pad = $self->Pad() // "";

  $indent_unit = 2; # make configurable?

  my $maxlinelen = $foldwidth1 || $foldwidth || INT_MAX;
  my $maxlineNlen = ($foldwidth // INT_MAX) - length($pad);

  if ($debug) {
    our $_dbmaxlen = INT_MAX;
    btw "## DD result: fw1=",u($foldwidth1)," fw=",u($foldwidth)," pad='${pad}' maxll=$maxlinelen maxlNl=$maxlineNlen\n   result=",_dbrawstr($_);
  }

  my $top = { tlen => 0, children => [] };
  my $context = $top;
  my $prepending = "";

  my sub atom($;$) {
    (local $_, my $mode) = @_;
    $mode //= "";

    __unmagic_atom ;
    __unesc_unicode          if $unesc_unicode;
    __unesc_nonoctal         if $octet_strings;
    __subst_controlpic_backesc      if $controlpics;
    __subst_visiblespaces    if $showspaces;
    __condense_strings(8)    if $condense_strings;
    __change_quotechars($q_pfx, $q_lq, $q_rq) if defined($q_pfx);
    __nums_in_hex            if $nums_in_hex;
    __nums_with_underscores  if $underscores;

    if ($prepending) { $_ = $prepending . $_; $prepending = ""; }

    btwN 1,"###atom",_mycallloc(), _dbrawstr($_),"($mode)"
      ,"\n context:",_dbvisnew($context)->Sortkeys(sub{[grep{exists $_[0]->{$_}} qw/O C tlen children CLOSE_AFTER_NEXT/]})->Dump()
      if $debug;
    if ($mode eq "prepend_to_next") {
      $prepending .= $_;
    } else {
      if ($mode eq "") {
        push @{ $context->{children} }, $_;
      }
      elsif ($mode eq "open") {
        my $child = {
          O => $_,
          tlen => 0, # incremented below
          children => [],
          C => undef,
          parent => $context,
        };
        weaken( $child->{parent} );
        push @{ $context->{children} }, $child;
        $context = $child;
      }
      elsif ($mode eq "close") {
        oops if defined($context->{C});
        $context->{C} = $_;
        $context->{tlen} += length;
        $context = $context->{parent}; # undef if closing the top item
      }
      elsif ($mode eq "append_to_prev") {
        my $prev = $context;
        { #block for 'redo'
          oops "No previous!" unless @{$prev->{children}} > 0;
          if (ref($prev->{children}->[-1] // oops)) {
            $prev = $prev->{children}->[-1];
            if (! $prev->{C}) { # empty or not-yet-read closer?
              redo; # ***
            }
            $prev->{C} .= $_;
          } else {
            $prev->{children}->[-1] .= $_;
          }
        }
      }
      else {
        oops "mode=",_dbvis($mode);
      }
      my $c = $context;
      while(defined $c) {
        $c->{tlen} += length($_);
        $c = $c->{parent};
      }
      if ($context->{CLOSE_AFTER_NEXT}) {
        oops(_dbvis($context)) if defined($context->{C});
        $context->{C} = "";
        $context = $context->{parent};
      }
    }
  }#atom

  my sub fat_arrow($) {  # =>
    my $lhs = $context->{children}->[-1] // oops;
    oops if ref($lhs);
    my $newchild = {
      O => "",
      tlen => length($lhs),
      children => [ $lhs ],
      C => undef,
      parent => $context,
    };
    weaken($newchild->{parent});
    $context->{children}->[-1] = $newchild;
    $context = $newchild;
    atom($_[0]); # the " => "
    oops unless $context == $newchild;
    $context->{CLOSE_AFTER_NEXT} = 1;
  }

  # There is a trade-off between compactness (e.g. want a single line when
  # possible), and ease of reading large structures.
  #
  # At any nesting level, if everything (including any nested levels) fits
  # on a single line, then that part is output without folding;
  #
  # 4/25/2023: Now controlled by constant _WRAP_STYLE:
  #
  # (_WRAP_STYLE == _WRAP_ALWAYS):
  # If folding is necessary, then *every* member of the folded block
  # appears on a separate line, so members all vertically align.
  #
  # *(_WRAP_STYLE & _WRAP_ALLHASH): Members of a hash (key => value)
  # are shown on separate lines, but not members of an array.
  #
  # Otherwise:
  #
  # When folding is necessary, every member appears on a separate
  # line if ANY of them will not fit on a single line; however if
  # they all fit individually, then shorter members will be run
  # together on the same line.  For example:
  #
  #    [aaa,bbb,[ccc,ddd,[eee,fff,hhhhhhhhhhhhhhhhhhhhh,{key => value}]]]
  #
  # might be shown as
  #    [ aaa,bbb,  # N.B. space inserted before aaa to line up with next level
  #      [ ccc,ddd,  # packed because all siblings fit individually
  #        [eee,fff,hhhhhhhhhhhhhhhhhhhhh,{key => value}] # entirely fits
  #      ]
  #    ]
  # but if Foldwidth is smaller then like this:
  #    [ aaa,bbb,
  #      [ ccc,  # sibs vertically-aligned because not all of them fit
  #        ddd,
  #        [ eee,fff,  # but within this level, all siblings fit
  #          hhhhhhhhhhhhhhhhhhhhh,
  #          {key => value}
  #        ]
  #      ]
  #    ]
  # or if Foldwidth is very small then:
  #    [ aaa,
  #      bbb,
  #      [ ccc,
  #        ddd,
  #        [ eee,
  #          fff,
  #          hhhhhhhhhhhhhhhhhhhhh,
  #          { key
  #            =>
  #            value
  #          }
  #        ]