Dogcows Code - chaz/p5-CGI-Ex/blob - samples/benchmark/bench_method_calling.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Benchmark qw(cmpthese);
   5 use CGI::Ex::Dump qw(debug);
   6
   7 my $n = 500_000;
   8
   9 {
  10   package A;
  11   use vars qw($AUTOLOAD);
  12   sub AUTOLOAD {
  13     my $self = shift;
  14     my $meth = ($AUTOLOAD =~ /::(\w+)$/) ? $1 : die "Bad method $AUTOLOAD";
  15     die "Unknown property $meth" if ! exists $self->{$meth};
  16     if ($#_ != -1) {
  17       $self->{$meth} = shift;
  18     } else {
  19       return $self->{$meth}
  20     }
  21   }
  22   sub DETROY {}
  23 }
  24
  25 {
  26   package B;
  27   sub add_property {
  28     my $self = shift;
  29     my $prop = shift;
  30     no strict 'refs';
  31     * {"B::$prop"} = sub {
  32       my $self = shift;
  33       if ($#_ != -1) {
  34         $self->{$prop} = shift;
  35       } else {
  36         return $self->{$prop};
  37       }
  38     };
  39     $self->$prop(@_) if $#_ != -1;
  40   }
  41 }
  42
  43 {
  44   package C;
  45   sub add_property {
  46     my $self = shift;
  47     my $prop = shift;
  48     no strict 'refs';
  49     my $name = __PACKAGE__ ."::". $prop;
  50     *$name = sub : lvalue {
  51       my $self = shift;
  52       $self->{$prop} = shift() if $#_ != -1;
  53       $self->{$prop};
  54     } if ! defined &$name;
  55     $self->$prop() = shift() if $#_ != -1;
  56   }
  57 }
  58
  59 my $a = bless {}, 'A';
  60 $a->{foo} = 1;
  61 #debug $a->foo();
  62 #$a->foo(2);
  63 #debug $a->foo();
  64
  65 my $b = bless {}, 'B';
  66 $b->add_property('foo', 1);
  67 #debug $b->foo();
  68 #$b->foo(2);
  69 #debug $b->foo();
  70
  71 my $c = bless {}, 'C';
  72 $c->add_property('foo', 1);
  73 #debug $c->foo();
  74 #$c->foo(2);
  75 #debug $c->foo();
  76
  77 my $d = bless {}, 'C';
  78 $d->add_property('foo', 1);
  79 #debug $d->foo();
  80 #$d->foo = 2;
  81 #debug $d->foo();
  82
  83
  84 use constant do_set => 1;
  85
  86 cmpthese($n, {
  87   autoloadonly => sub {
  88     my $v = $a->foo();
  89     if (do_set) {
  90       $a->foo(2);
  91     }
  92   },
  93   addproperty => sub {
  94     my $v = $b->foo();
  95     if (do_set) {
  96       $b->foo(2);
  97     }
  98   },
  99   addproperty_withlvalue => sub {
 100     my $v = $c->foo();
 101     if (do_set) {
 102       $c->foo(2);
 103     }
 104   },
 105   addproperty_withlvalue2 => sub {
 106     my $v = $d->foo();
 107     if (do_set) {
 108       $d->foo = 2;
 109     }
 110   },
 111 });