The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

RFOLEY / Perlbug-2.93 / scripts / bugrun 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120

              
#!/usr/bin/perl 
# Perlbug runnable interface (for tests etc.)
# (C) 2000 Richard Foley RFI perlbug@rfi.net 
# $Id: bugrun,v 1.1 2001/12/01 15:24:43 richardf Exp $
# 
# 
package Testit;
use strict;
use vars(qw($VERSION $AUTOLOAD));
$VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; 
$|=1;
use Benchmark;
my $iterations = $ARGV[0] || 0;
die "Usage: $0 \$i_num # (number of iterations)\n" unless $iterations;
use Data::Dumper;
use Perlbug::Interface::Cmd;
use Perlbug::Test;
my $pb = Perlbug::Interface::Email->new(@ARGV);
my $o_test = Perlbug::Test->new($pb);
$o_test->debug(1, "$0: starting($o_test)");
my $o_obj = $o_test->object('user');
$o_obj->read('19870502.007');
$o_obj->read('richardf');
$DB::single=2;
print $o_obj->template('a');
# print Dumper($o_obj); exit;
__END__
sub new {
        my $class = shift;
        my $self = {
                'attribute'     => 'of some sort',
        };
        bless($self, $class); 
}       
sub xattr { # test method
        my $self = shift;
        my $get  = shift;
        my @ret  = ();
        if (!defined($get)) {
                @ret = keys %{$self->{'_attr'}};                     # ref
        } else {
                if (ref($get) ne 'HASH') {                                      # get
                        @ret = ($self->{'_attr'}{$get});
                } else {                                                                        # set
                        my $keys = join('|', keys %{$self->{'_attr'}});      # ref
                        SET:
                        foreach my $key (keys %{$get}) {
                                if ($key =~ /^($keys)$/) {
                                        $self->{'_attr'}->{$key} = $$get{$key}; # SET
                                        push(@ret, $$get{$key});
                                } else {
                                        $self->debug(2, ref($self)." has no such attribute key($key) valid($keys)") if $Perlbug::DEBUG;
                                }
                        }
                }
        }
        return wantarray ? @ret : $ret[0];
}
sub AUTOLOAD {
    my $self = shift;
    my $get  = shift || '';     
        my $meth = $AutoLoader::AUTOLOAD = $AUTOLOAD;
    return if $meth =~ /::DESTROY$/o;
    $meth =~ s/^(.*):://o;
        my $pkg = ref($self);
        my @ret = ();
    if ($meth !~ /^(attr|data|flag)$/) {
        $self->error("$pkg->$meth($get, @_) called with a duff method($AUTOLOAD)!  Try: 'perldoc $pkg'");
    } else { 
                no strict 'refs';
                *{$AUTOLOAD} = sub { # this bit is virtually identical to the xattr() sub
                        my $self = shift;
                        my $get  = shift;
                        my @ret  = ();
                        if (!defined($get)) {
                                @ret = keys %{$self->{"_$meth"}};                    #
                        } else {
                                $DB::single=2;
                                if (ref($get) ne 'HASH') {                                      # get
                                        @ret = ($self->{"_$meth"}{$get});
                                } else {                                                                        # set
                                        my $keys = join('|', keys %{$self->{"_$meth"}});
                                        SET:
                                        foreach my $key (keys %{$get}) {
                                                if ($key =~ /^($keys)$/) {
                                                        $self->{"_$meth"}->{$key} = $$get{$key}; # SET
                                                        push(@ret, $$get{$key});
                                                } else {
                                                        $self->debug(2, "$pkg has no such $meth key($key) valid($keys)") if $Perlbug::DEBUG;
                                                }
                                        }
                                }
                        }
                        return wantarray ? @ret : $ret[0];
                }
    }
        return wantarray ? @ret : $ret[0];
}
my $o_obj = Testit->new;
timethese($iterations, {
        'anonymous'     => q|call('attr')|,
        'explicit'      => q|call('xattr')|,
});
sub call { my $call = shift; return $o_obj->$call('objectid'); }
exit 0;