view release on metacpan or  search on metacpan

lib/Debug/Statements.pm  view on Meta::CPAN

    $suffix = expandEscapes($suffix);
    if ($id) { print "internaldebug:  \$prefix = '$prefix'\n" }
    if ($id) { print "internaldebug:  \$suffix = '$suffix'\n" }

    # Print each $var
    my @vars = split /[, ]+/, $vars;
    if ($id) { print "internaldebug:  \@vars = '@vars'\n" }
    if ( @vars and not $opt{text} ) {
        if ($id) { print "internaldebug:  Iterating through vars\n" }
        for my $i ( 0 .. $#vars ) {
            # Print prefix only on 1st var, print suffix only on last var
            my $p = $i == 0 ? $prefix : "";
            if ($id) { print "internaldebug:  \$p = '$p'\n" }
            my $s = $i == $#vars ? $suffix : "";
            if ($id) { print "internaldebug:  \$s = '$s'\n" }
            #chomp($vars[$i]);
            if ($id) { print "internaldebug:  \$vars[$i] = '$vars[$i]'\n" }
            my $dump = dumpvar( $h, $caller, $vars[$i], \%opt );
            if ( $id and defined $dump ) { print "internaldebug:  \$dump = '$dump'\n" }
            printdebugsub( $caller, $opt{level}, $vars[$i], $dump, $p, $s, \%opt ) if defined $dump;
        }
    } else {
        if ($id) { print "internaldebug:  Just printing everything as text\n" }
        # No variables, just a print
        # SCALAR(0x6484b8)
        if ( $prefix =~ /^(SCALAR|ARRAY|HASH|REF|CODE|GLOB)\(0x/ ) {
            print "WARNING:  Debug::Statements::d() was given a reference to a variable instead of a single-quoted string\n";
            return;
        }
        #printdebugsub($caller, $opt{level}, "", "", $prefix, $suffix, \%opt);   #07/12/13
        # Enable d '.';
        $ovars = '....................................................................................................' if $ovars eq '.';
        $ovars =~ s/^\. (\S)/$1/; # D '. Hello World';
        printdebugsub( $caller, $opt{level}, "", "", "", $ovars, \%opt );
    }
    return;
}

# Find value of each variable (and checking for special vars)
sub dumpvar {
    my ( $h, $caller, $var, $opt ) = @_;
    if ($id) { print "sub dumpvar()\n" }

    # Convert ${var} to ${var}
    if ($id) { print "internaldebug dumpvar:  \$vvar = '$var'\n" }
    $var =~ s/^([\$\@\%])\{(\S+)\}$/$1$2/;
    if ($id) { print "internaldebug dumpvar:  \$vvar = '$var'\n" }

    # Convert $h->{'$listvar[0]'}      to  $h->{'@listvar'}[0]
    # Convert $h->{'$hashvar{one}'}    to  $h->{'%hashvar'}{one}
    # Convert $h->{'$listref->[1]'}    to  ${$h->{'$listref'}}->[1]
    # Convert $h->{'$hashref->{one}'}  to  ${$h->{'$hashref'}}->{'one'}

    my $sigil = ( split //, $var )[0];
    if ($id) { print "internaldebug dumpvar:  \$sigil = '$sigil'\n" }
    my $newsigil = $sigil;
    my $reference;

    # Ugly way to handle these:  $hash{$key} and $hash{$key}{$key2}
    # Will not work for more complicated cases like $hash{$hash2{$key}}
    while ( $var =~ /^(\$.*)(\$[a-zA-Z_]\w*)(.*)$/ ) {
        my ( $pre, $internalvar, $post ) = ( $1, $2, $3 );
        if ($id) { print "internaldebug dumpvar:  \$internalvar = $internalvar\n" }
        my $e = "\$h->{'$internalvar'}";
        if ($id) { print "internaldebug dumpvar:  \$e = $e\n" }
        my $reference = evlwrapper( $h, $e, 'dumpvar $hash{$key}' );
        if ($id) { print "internaldebug dumpvar:  \$reference = $reference\n" }
        #my $dump = cleanDump( $reference, undef );
        my $dump;
        if ($data_printer_installed) {
            $dump = Data::Printer::p($reference);
        } else {
            $dump = Dumper($reference);
        }
        $dump =~ s/^\\//;
        chomp $dump;
        if ($id) { print "internaldebug dumpvar:  \$dump = '$dump'\n" }
        $var = $pre . $dump . $post;
        if ($id) { print "internaldebug dumpvar:  \$var = '$var'\n" }
    }

    #               sig varbase       open    elem close
    if ( $var =~ /^(\$)([^\[\{\]\}]+)([\[\{])(\S+)([\]\}])$/ ) {
        # array or hash element starting with $
        my ( $sigil, $varbase, $opened, $element, $closed ) = ( $1, $2, $3, $4, $5 );
        if ($id) { print "internaldebug dumpvar:  (\$sigil, \$varbase, \$opened, \$element, \$closed) = ($sigil, $varbase, $opened, $element, $closed)\n" }

        if ($id) { print "internaldebug:  \$varbase = $varbase\n" }

        if ( $opened eq '[' and $closed eq ']' ) {
            if ($id) { print "internaldebug:  Found array\n" }
            #$reference = $h->{'@'.$varbase}[$element];
            #my $e = "\$h->{'\@'.\"$varbase\"}[$element]";
            #if ($id) { print "internaldebug:  \$e = $e\n" }
            #$reference = eval($e);
            if ( $element =~ /:/ ) {
                print "DEBUG sub $caller:  d() cannot be used on an array slice!  Found $var\n";
                return;
            } elsif ( $element =~ /[^-\d\[\]]/ ) {
                print "DEBUG sub $caller:  d() cannot be used on an array element with non-digits!  Found $var\n";
                return;
            } else {
                $newsigil = '@';
            }
        } elsif ( $opened eq '{' and $closed eq '}' ) {
            if ($id) { print "internaldebug dumpvar:  Found hash\n" }
            $element =~ s/"//g;
            #$reference = $h->{'%'.$varbase}{$element};
            #my $e = "\$h->{'\%'.\"$varbase\"}{$element}";
            #if ($id) { print "internaldebug:  \$e = $e\n" }
            #$reference = eval($e);
            $newsigil = '%';
        } else {
            print "DEBUG sub $caller:  WARNING:  Debug::Statements::d() did not understand opening/closing brackets $opened and $closed on $var\n";
            return;
        }
        if ($id) { print "internaldebug dumpvar:  \$newsigil = '$newsigil'\n" }
        my $e;

        if ( $varbase =~ s/->// ) {
            # ${$h->{'$listref'}}->[1]
            # ${$h->{'$hashref'}}->{'one'}
            $e = "\${\$h->{'\$$varbase'}}->$opened$element$closed";
            if ($id) { print "internaldebug dumpvar:  \$e = $e\n" }
        } else {
            #internaldebug:  $e = $h->{'@listvar'}[10]
            #internaldebug:  $e = $h->{'%hashvar'}{ten}
            #internaldebug:  $e = $h->{'@listvar'}[0]
            #internaldebug:  $e = $h->{'@nestedlist'}[1]
            #internaldebug:  $e = $h->{'@nestedlist'}[1][1]
            #internaldebug:  $e = $h->{'%hashvar'}{one}
            #internaldebug:  $e = $h->{'%hashvar'}{one}
            #internaldebug:  $e = $h->{'%nestedhash'}{flintstones}
            #internaldebug:  $e = $h->{'%nestedhash'}{flintstones}{pal
            $e = "\$h->{'$newsigil$varbase'}$opened$element$closed";
        }

        if ($id) { print "internaldebug dumpvar:  \$e = $e\n" }
        $reference = evlwrapper( $h, $e, 'dumpvar $e' );

    } else {
        # $_ @_ $1 $&
        if ( $var =~ /^(\$_|\@_|\$[1-9]\d*|\$\&)$/ ) {
            ( my $var2 = $var ) =~ s/^([\$\@\%])//;
            #my $sigil = $1;
            print "DEBUG sub $caller:  WARNING:  Debug::Statements::d() does not support Special variables such as $var\n";
            print "DEBUG sub $caller:            Use double-quotes as a workaround:  d(\"$var2 = $var\")\n";
            return;
        }
        # Special variables
        # Package variables
        elsif (( $var =~ /^(\$0|\$\$|\$\?|\$\.|\@ARGV|\$LIST_SEPARATOR|\$PROCESS_ID|\$PID|\$PROGRAM_NAME|\$REAL_GROUP_ID|\$GID|\$EFFECTIVE_GROUP_ID|\$EGID\|\$REAL_USER_ID|\$UID|\$EFFECTIVE_USER_ID|\$EID|\$SUBSCRIPT_SEPARATOR|\$SUBSEP|\%ENV|\@INC|\$IN...
            or ( $var =~ /^[\$\@\%]\{?[a-zA-Z_][\w:{}\[\]]*$/ and $var =~ /::/ ) )
        {
            return handlelocalvar( $var, $opt );
        }
        # $list[1..3]
        elsif ( $var =~ /^(\@)([^\[\{\]\}]+)([\[\{])(\S*:\S*)([\]\}])$/ ) {
            print "DEBUG sub $caller:  d() cannot be used on an array slice!  Found $var\n";
            return;
        }
        # $scalar @list %hash
        elsif ( $var =~ /^[\$\@\%]\{?[a-zA-Z_][\w{}\[\]]*$/ ) {
            # normal variable
            $reference = $h->{$var};
        }
        # $#list
        elsif ( $var =~ /^\$#/ ) {
            ( my $var2 = $var ) =~ s/^[\$\@\%]//;
            print "DEBUG sub $caller:  WARNING:  Debug::Statements::d() does not support \$# used in $var\n";
            print "DEBUG sub $caller:            Use double-quotes as a workaround:  d(\"$var2 = $var\")\n";
            return;
        }
        # anything else
        elsif ( $var =~ /^[\$\@\%]/ ) {
            ( my $var2 = $var ) =~ s/^([\$\@\%])//;
            #print "DEBUG sub $caller:  WARNING:  Debug::Statements::d() does not support special variables such as $var\n";
            #print "DEBUG sub $caller:            Use double-quotes as a workaround:  d(\"$var2 = $var\")\n";
            return handlelocalvar( $var, $opt );
        } else {
            if ($id) { print "internaldebug dumpvar:  \$var is bad!\n" }
            return;
        }
    }

    # Sanity check
    if ( !defined $reference ) {
        print "DEBUG sub $caller:  $var is not a defined local variable!\n";
        print "DEBUG sub $caller:      Check if you misspelled your variable name when you called d() or used the wrong sigil (\$/\@/\%)\n";
        #print "DEBUG sub $caller:      ! defined \$h->{$var}\n";
        return;
    }
    if ($id) { print "internaldebug dumpvar:  \$reference = '$reference'\n" }

    # Get value
    my $ref = ref($reference);
    if ($id) { print "internaldebug dumpvar:  \$ref = '$ref'\n" }
    my $dump = cleanDump( $reference, $opt );
    if ( $opt->{compress} ) {
        if ( $ref !~ /^SCALAR/ or $newsigil ne '$' ) {
            $dump =~ s/\s+/ /g;
        }
    }