Class/Tom/Code.pm

package Class::Tom::Code;


use B qw(class main_root main_start main_cv svref_2object);
use B::Deparse;

use strict;
use vars qw ( $VERSION );

$VERSION = '2.00';

sub new {
  my $class = shift;

  my $self = {};
  $self->{Deparser} = bless {
                         'curcv'      => main_cv,
                         'subs_todo'  => [],
                         'curstash'   => "main",
                         'cuddle'     => "\n",
                      }, 'B::Deparse';

  bless $self, $class;
}

sub code ($$) {
  my $self = shift;
  my $coderef = shift;
  return $self->{Deparser}->code($coderef);
}

package B::Deparse;

sub code {
  my $self = shift;
  my $method = shift;             # reference to a subroutine
  if (ref($method) ne 'CODE') {
    return undef;
  }
  my $stash;
  { no strict 'refs'; $stash  = svref_2object($method); }
  local ($self->{'curcv'}) = $stash;
  local ($self->{'curstash'}) = $stash->STASH->NAME;

  my $code = "{\n\t" . $self->deparse($stash->ROOT->first, 0) . "\n\b}";

  my $package = $stash->STASH->NAME;
  my $subname = $self->gv_name($stash->GV);

  my $name;
  if ($subname ne '__ANON__') {
    if ($package) {
      $name = $package . '::' . $subname;
    } else {
      $name = $subname;
    }
  }
  if ($name eq '__ANON__') {
    return $self->indent("sub $code;");
  } else {
    return $self->indent("sub $name $code;");
  }
}

1;

1	joko	1.1	package Class::Tom::Code;
2
3
4			use B qw(class main_root main_start main_cv svref_2object);
5			use B::Deparse;
6
7			use strict;
8			use vars qw ( $VERSION );
9
10			$VERSION = '2.00';
11
12			sub new {
13			my $class = shift;
14
15			my $self = {};
16			$self->{Deparser} = bless {
17			'curcv' => main_cv,
18			'subs_todo' => [],
19			'curstash' => "main",
20			'cuddle' => "\n",
21			}, 'B::Deparse';
22
23			bless $self, $class;
24			}
25
26			sub code ($$) {
27			my $self = shift;
28			my $coderef = shift;
29			return $self->{Deparser}->code($coderef);
30			}
31
32			package B::Deparse;
33
34			sub code {
35			my $self = shift;
36			my $method = shift; # reference to a subroutine
37			if (ref($method) ne 'CODE') {
38			return undef;
39			}
40			my $stash;
41			{ no strict 'refs'; $stash = svref_2object($method); }
42			local ($self->{'curcv'}) = $stash;
43			local ($self->{'curstash'}) = $stash->STASH->NAME;
44
45			my $code = "{\n\t" . $self->deparse($stash->ROOT->first, 0) . "\n\b}";
46
47			my $package = $stash->STASH->NAME;
48			my $subname = $self->gv_name($stash->GV);
49
50			my $name;
51			if ($subname ne '__ANON__') {
52			if ($package) {
53			$name = $package . '::' . $subname;
54			} else {
55			$name = $subname;
56			}
57			}
58			if ($name eq '__ANON__') {
59	joko	1.2	return $self->indent("sub $code;");
60	joko	1.1	} else {
61	joko	1.2	return $self->indent("sub $name $code;");
62	joko	1.1	}
63			}
64
65			1;
66
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26