Trace module 
Author Message
 Trace module

Ok, here's the very second version of Trace, derived from Hans Mulder's
original Trace.pm file.  The Trace subroutine is called like this:

        Trace what, variable [, options, callback, arguments];

where:

        what      = 'variable' :  trace a variable
                  = 'vdelete'  :  disable variable tracing
                  = 'vinfo'    :  return traced variable information

        variable  = a *reference* to a scalar, array, or hash variable.
                    The variable may be my() for "use strict".

        options   = invoke the callback code for 'r' or 'w', or 'rw' or 'wr'
                    'r' == Read and 'w' == Write

        callback  = a code reference of the subroutine to handle read and
                    write requests

        arguments = a list of optional callback parameters

Trace does not require Tk.

Assume this code is *really* alpha -  I'm throwing it out for comments.  The
code has at least these flaws:

        . does not conform to the normal Perl/Tk callback format
        . there is common code I can factor out via subclassing
        . I need to validate incoming arguments
        . there must be bugs!
        . (pod) doumentation is missing
        . tracing arrays really is bad news - trace scalars or hashes instead!
          The overhead for tracing a scalar is just a single variable; for a
          hash just the number of hash keys.  But if you trace array[1000000]
          you've now created a one megabyte array!

Yet, these are implementation problems - the user interface may not change.

------------------------------ trace test program
#!/usr/local/bin/perl -w
use Tk;
use Trace;
use English;
use strict;

# Trace works on plain scalars, arrays, or hashes.  Do *NOT* trace Tk widgets!

my $foo;                        # test scalar trace

my %foo;                        # test hash trace

my $date;

# But Trace does work OK with Tk otherwise.  First, sample Trace runs are
# demonstrated, then a Tk window appears where you can type values for a
# traced scalar, $foo.

my $MW = MainWindow->new;
my $e = $MW->Entry->pack;
$e->bind('<Return>' => sub {$foo = $e->get});
$e->focus;
my $d = $MW->Button(-text => 'Debug', -command => sub {$Trace::DEBUG = 1});
$d->pack;
my $u = $MW->Button(-text => 'Untrace $foo', -command => sub {
    Trace 'vdelete', \$foo;

Quote:
})->pack;

my $l = $MW->Button(-text => 'Quit', -command => \&exit)->pack;

# Here is the generic callback invoked when a traced variable is read and or
# written.  It is passed at least two arguments, and maybe more if you
# specified them on the trace command.  The first is the type of operation,
# either 'r' or 'w', for read/write, respectively.  The second is the current
# value.  The remaining list of arguments you may or may not have previously
# declared.
#
# Since you can only have one callback per variable, the subroutine must be
# able to handle either a read or write operations, hence the $op variable.
# On the other hand, once you've written said callback it can be used for
# tracing scalars, arrays and hashes!
#
# This particular callback simply uppercases write values.

my $callback = sub {

    print ($op =~ /r/ ? 'Read ' : 'Write');

    return ($op =~ /r/ ? $val : uc $val);

Quote:
};

# TraceScalar *****************************************************************

print "\nTest TraceScalar:\n";
chomp($date = `date`);
Trace 'variable', \$foo, 'wr', $callback, $date;
$foo = "hello scalar";


sleep 1;

# TraceArray ******************************************************************

print "\nTest TraceArray:\n";
chomp($date = `date`);

my($a, $b) = ($foo[0], $foo[1]);


sleep 1;

# TraceHash *******************************************************************

print "\nTest TraceHash:\n";
chomp($date = `date`);
Trace 'variable', \%foo, 'wr', $callback, $date;
%foo = ('k1' => "hello", 'k2' => 'hash ');
my($a, $b) = ($foo{k1}, $foo{k2});


foreach (keys %foo) {
    print "key=$ARG, value=$foo{$ARG}.\n";

Quote:
}

if (exists $foo{k2}) {
    print "k2 does exist\n";
Quote:
} else {

    print "k2 does not exists\n";
Quote:
}

delete $foo{k2};
if (exists $foo{k2}) {
    print "k2 does exist\n";
Quote:
} else {

    print "k2 does not exist\n";
Quote:
}

print "keys=", join(', ', keys %foo), ".\n";
print "\n";

MainLoop;
------------------------------ Trace.pm
package Trace;

use Carp;
use English;

$DEBUG = 0;
%TRACE = ();                    # package global hash for vdelete and vinfo

sub Trace {

    my $type = ref $name;
    $name = (caller) . "::$name" unless ($name =~ /::|'/ or ref $name);
    if ($what =~ /^variable$/) {
        if ($type =~ /SCALAR/) {

        } elsif ($type =~ /ARRAY/) {

        } elsif ($type =~ /HASH/) {

        } else {
            croak 'Trace possible for SCALAR, ARRAY, or HASH only.';
        }
    } elsif ($what =~ /^vdelete$/) {
        foreach (keys %Trace::TRACE) {
            if ($name eq $ARG) {
                if ($type =~ /SCALAR/) {
                    untie $$name;
                } elsif ($type =~ /ARRAY/) {

                } elsif ($type =~ /HASH/) {
                    untie %$name;
                } else {
                    croak 'Trace possible for SCALAR, ARRAY, or HASH only.';
                }
                return;
            }
        }
    } elsif ($what =~ /^vinfo$/) {
        foreach (keys %Trace::TRACE) {
            return $Trace::TRACE{$ARG}->Vinfo if $name eq $ARG;
        }
    } else {
        croak "Illegal Trace option '$what'.";
    }

Quote:
}

sub Say {

    defined $val ? "'$val'" : "undefined";

Quote:
}

package TraceScalar;


sub TIESCALAR {


    my $trace_obj = {'name'  => $name,
                     'op'    => $op,
                     'cb'    => $cb,
                     'value' => undef,

                    };
    $Trace::TRACE{$name} = $trace_obj;
    return bless $trace_obj, $class;

Quote:
}

sub Vinfo {








Quote:
}

sub DESTROY {

    print "TraceScalar: $self->{'name'} destructor, final value was ",
                $self->Say($self->{'value'}), ".\n" if $Trace::DEBUG;
    delete $Trace::TRACE{$self->{name}};
    undef %$self;

Quote:
}

sub FETCH {

    print "TraceScalar: $self->{'name'} returned ",
                $self->Say($self->{'value'}), ".\n" if $Trace::DEBUG;
    if ($self->{'op'} =~ /r/) {
        $self->{'value'} =

    }
    return $self->{'value'};

Quote:
}

sub STORE {

    print "TraceScalar: $self->{'name'} changed from ",
                $self->Say($self->{'value'}), " to ",
                $self->Say($new_value), ".\n" if $Trace::DEBUG;
    if ($self->{'op'} =~ /w/) {

    }
    return $self->{'value'} = $new_value;

Quote:
}

package TraceArray;


sub TIEARRAY {


    my $trace_obj = {'name' => $name,
                     'op'   => $op,
                     'cb'   => $cb,
                     'ptr'  => [],

                    };
    $Trace::TRACE{$name} = $trace_obj;
    return bless $trace_obj, $class;

Quote:
}

sub Vinfo {








Quote:
}

sub DESTROY {

    print "TraceArray: $self->{'name'} destructor.\n" if $Trace::DEBUG;
    delete $Trace::TRACE{$self->{name}};
    undef %$self;

Quote:
}

sub FETCH {

    print "TraceArray: $self->{'name'}", "[$key] returned ",
                $self->Say($self->{ptr}->[$key]), ".\n" if $Trace::DEBUG;
    if ($self->{'op'} =~ /r/) {
        $self->{'value'} =

    }
    return $self->{ptr}->[$key];

Quote:
}

sub STORE {

    print "TraceArray: $self->{'name'}", "[$key] changed from ",
                $self->Say($self->{ptr}->[$key]), " to ",
                $self->Say($new_value), ".\n" if $Trace::DEBUG;
    if ($self->{'op'} =~ /w/) {

    }
    return $self->{ptr}->[$key] = $new_value;

Quote:
}

package TraceHash;


sub TIEHASH {


    my $trace_obj = {'name' => $name,
                     'op'   => $op,
                     'cb'   => $cb,
                     'ptr'  => {},

                    };
    $Trace::TRACE{$name} = $trace_obj;
    return bless $trace_obj, $class;

Quote:
}

sub CLEAR {

    $self->{ptr} = ();

Quote:
}

sub DELETE {

    delete $self->{ptr}->{$key};

Quote:
}

sub DESTROY {

    print "TraceHash: $self->{'name'} destructor.\n" if $Trace::DEBUG;
    delete $Trace::TRACE{$self->{name}};
    undef %$self;

Quote:
}

sub EXISTS {

    return exists $self->{ptr}->{$key};

Quote:
}

sub FETCH {

    print "TraceHash: $self->{'name'}", "{$key} returned ",
                $self->Say($self->{ptr}->{$key}), ".\n" if $Trace::DEBUG;
    if ($self->{'op'} =~ /r/) {
        $self->{'value'} =

    }
    return $self->{ptr}->{$key};

Quote:
}

sub FIRSTKEY {

    return each %{$self->{ptr}};

Quote:
}

sub NEXTKEY {

    return each %{$self->{ptr}};

Quote:
}

sub STORE {

    print "TraceHash: $self->{'name'}", "{$key} changed from ",
                $self->Say($self->{ptr}->{$key}), " to ",
                $self->Say($new_value), ".\n" if $Trace::DEBUG;
    if ($self->{'op'} =~ /w/) {

    }
    return $self->{ptr}->{$key} = $new_value;

Quote:
}

1;
==========================================================================
This message was posted through the Stanford campus mailing list
server.  If you wish to unsubscribe from this mailing list, send the

--




Mon, 16 Nov 1998 03:00:00 GMT  
 
 [ 1 post ] 

 Relevant Pages 

1. ANNOUNCE: Debug::Trace 0.04 -- tracing subroutine calls

2. module for tracing in perl5?

3. Module for tracing?

4. Tracing NIFE or Cadspa

5. Trace rout with perl

6. Perl equivalent to C's TRACE

7. Whats the meaning of this stack trace

8. Tracing true paths (across mounts & links)

9. Turning debug trace on inside the script?

10. Trace rout with perl

11. command trace in perl (4.003)

12. Debugging question: tracing the origin of an error.

 

 
Powered by phpBB® Forum Software