view release on metacpan or  search on metacpan

lib/Driver/Program.pm  view on Meta::CPAN

# This object is big and the 'context'-related stuff and possibly the
# 'generate'-related stuff could be split out.

@ISA = qw(Exporter);
	# Oddly enough, the PERL_* tags here must be in order.
@EXPORT_OK = (qw(package_to_path path_to_package
				PERL_HEAD PERL_USE PERL_VARS PERL_SUBS PERL_TAIL
				PERL_DOCS));
%EXPORT_TAGS = (
	sections	=> [ grep { /^PERL_/ } @EXPORT_OK ],
	all			=> \@EXPORT_OK,
		);

	# To insert various things into the Perl code.
sub PERL_HEAD	() { 0 }
sub PERL_USE	() { 1 }
sub PERL_VARS	() { 2 }
sub PERL_SUBS	() { 3 }
sub PERL_TAIL	() { 4 }
sub PERL_DOCS	() { 5 }

my $DEBUGLABELS = 0;

%PROGS = (
	"/foo/bar"	=> new Anarres::Mud::Driver::Program(Path=>"/foo/bar"),
		);

# Class methods

sub new {
	my $class = shift;
	my $self = ($#_ == 0) ? { %{ (shift) } } : { @_ };

	confess "No Path in program" unless $self->{Path};

	$self->{Perl} = [ ];
	$self->{PerlGlobals} = [ ];

	$self->{Inherits} = { };
	$self->{Statics} = { };
	$self->{Globals} = { };
	$self->{Locals} = { };
	$self->{Labels} = { };
	$self->{LabelDefault} = undef;
	$self->{Methods} = efuns;
	$self->{MethodFlags} = efunflags;

	$self->{ScopeStack} = [ ];
	$self->{LabelStack} = [ ];

	$self->{Warnings} = [ ];
	$self->{Errors} = [ ];

	$self->{Label} = 0;

	$self->{Closures} = [ ];

	$self->{Classes} = { };

	return bless $self, $class;
}

sub find {	# find Anarres::Mud::Driver::Program $path
	return $PROGS{$_[1]};
}

sub path_to_package {
	my $path = shift;
	$path =~ s,/,::,g;
	$path =~ s/\.c$//;
	$path =~ s,^/*,,;
	return "Anarres::Mud::Library::" . $path;
}

sub package_to_path {
	my $package = shift;
	die "package_to_path: Invalid package name"
			unless $package =~ s/^Anarres::Mud::Library//;
	$package =~ s,::,/,g;
	return $package;
}

# Debugging methods

sub warning {
	my $self = shift;
	print "WARNING: $_\n" foreach @_;
	push(@{ $self->{Warnings} }, @_);
}

sub error {
	my $self = shift;
	print "ERROR: $_\n" foreach @_;
	push(@{ $self->{Errors} }, @_);
}

# Instance query methods

sub path { return $_[0]->{Path}; }
sub source { return $_[0]->{Source}; }
sub ppsource { return $_[0]->{PPSource}; }
sub package { return path_to_package $_[0]->{Path}; }

sub methods	{ return values %{ $_[0]->{Methods} }; }
# sub locals	{ return values %{ $_[0]->{Globals} }; }
sub globals	{ return values %{ $_[0]->{Globals} }; }

sub variable {
	my ($self, $name) = @_;
	return $self->{Locals}->{$name}
		|| $self->{Globals}->{$name}
		|| undef;
}

# Instance modification methods

sub closure {
	my ($self, $clousure) = @_;
	return (push(@{ $self->{Closures} }, $clousure) - 1);
}

lib/Driver/Program.pm  view on Meta::CPAN

	return $out;
}

# Semantics

sub check {
	my $self = shift;

	my @meth = grep { ! ($self->{MethodFlags}->{$_} & M_EFUN) }
					keys %{$self->{Methods}};

	my $ret = 1;
	foreach (@meth) {
		my $tcm = $self->{Methods}->{$_}->check($self, 0);
		$ret &&= $tcm;
	}

	return $ret;
}

# Output

sub perl {
	my ($self, $section, @code) = @_;
	if (@code) {
		push(@{ $self->{Perl}->[$section] }, @code);
		return ();
	}
	else {
		return join("\n", @{ $self->{Perl}->[$section] });
	}
}

sub perl_global {
	my ($self, @globals) = @_;
	push( @{ $self->{PerlGlobals} }, @globals);
}

sub generate {
	my ($self) = @_;

	my $path = $self->{Path};
	my $package = $self->package;

	$self->perl(PERL_HEAD, "# program $path;");
	$self->perl(PERL_HEAD, "package $package;");
	$self->perl(PERL_USE, "use strict;");
	$self->perl(PERL_USE, "use warnings;");

	$self->perl_global(q[$PROGRAM]);

	if (scalar %{ $self->{Inherits} }) {
		my $inh = join " ",
				map { $_->package }
						values %{ $self->{Inherits} };
		$self->perl_global(q[@ISA]);
		$self->perl(PERL_VARS, qq[\@ISA = qw($inh);]);
	}
	else {
		$self->perl(PERL_SUBS, qq[sub new { bless { }, shift; }\n]);
	}

	$self->perl(PERL_USE, 'use vars qw(' .
							join(" ", @{ $self->{PerlGlobals} }) .
							");");
	# XXX $path forms part of a Perl program. Beware.
	$self->perl(PERL_VARS,
			'*PROGRAM = \$' . __PACKAGE__ . "::PROGS{'$path'};");
	$self->perl(PERL_TAIL, '1;');
	$self->perl(PERL_TAIL, '__END__');

	# These have a very large extent.
	local *::methods = $self->{Methods};
	local *::methodflags = $self->{MethodFlags};

	# Should we be doing these in order of definition? I've just
	# put them into alpha order so I can find methods more easily
	# in the generated Perl, but we lose definition order in the
	# hash.
	my @meth = map { $::methods{$_}->generate(0, $path) }
				grep { ! ($::methodflags{$_} & M_EFUN) }
					sort keys %::methods;


	$self->perl(PERL_SUBS, @meth);

	my $out = '';
	foreach (0..$#{$self->{Perl}}) {
		$out .= "# === Section " .
						$EXPORT_TAGS{sections}->[$_] . "\n";
		$out .= $self->perl($_) . "\n\n";
	}
	return $out;
}

1;