view release on metacpan or  search on metacpan

lib/Module/Generate.pm  view on Meta::CPAN

sub abstract {
	$CLASS{CURRENT}{ABSTRACT} = $_[1];
	return $_[0];
}

sub no_warnings {
	my $self = shift;
	$CLASS{CURRENT}{NO_WARNINGS} ||= [];
	push @{ $CLASS{CURRENT}{NO_WARNINGS} }, @_;
	return $self;
}

sub no_strict {
	my $self = shift;
	$CLASS{CURRENT}{NO_STRICT} ||= [];
	push @{ $CLASS{CURRENT}{NO_STRICT} }, @_;
	return $self;
}

sub use {
	my $self = shift;
	$CLASS{CURRENT}{USE} ||= [];
	push @{ $CLASS{CURRENT}{USE} }, @_;
	return $self;
}

sub base {
	my $self = shift;
	$CLASS{CURRENT}{BASE} ||= [];
	push @{ $CLASS{CURRENT}{BASE} }, @_;
	return $self;
}

sub parent {
	my $self = shift;
	$CLASS{CURRENT}{PARENT} ||= [];
	push @{ $CLASS{CURRENT}{PARENT} }, @_;
	return $self;
}

sub require {
	my $self = shift;
	$CLASS{CURRENT}{REQUIRE} ||= [];
	push @{ $CLASS{CURRENT}{REQUIRE} }, @_;
	return $self;
}

sub our {
	my $self = shift;
	$CLASS{CURRENT}{GLOBAL} ||= [];
	push @{ $CLASS{CURRENT}{GLOBAL} }, @_;
	return $self;
}

sub begin {
	$CLASS{CURRENT}{BEGIN} = $_[1];
	return $_[0];
}

sub unitcheck {
	$CLASS{CURRENT}{UNITCHECK} = $_[1];
	return $_[0];
}

sub check {
	$CLASS{CURRENT}{CHECK} = $_[1];
	return $_[0];
}

sub init {
	$CLASS{CURRENT}{INIT} = $_[1];
	return $_[0];
}

sub end {
	$CLASS{CURRENT}{END} = $_[1];
	return $_[0];
}

sub new {
	my ($self, $sub) = @_;
	$CLASS{CURRENT}{SUBS}{CURRENT} = $CLASS{CURRENT}{SUBS}{new} = {
		INDEX => $SUB_INDEX++,
		POD => "Instantiate a new $CLASS{CURRENT}{NAME} object.",
		EXAMPLE => "$CLASS{CURRENT}{NAME}\-\>new"
	};
	$CLASS{CURRENT}{SUBS}{CURRENT}{CODE} = $sub ? $sub : eval "sub {
		my (\$cls, \%args) = (shift, scalar \@_ == 1 ? \%{\$_[0]} : \@_);
		bless \\%args, \$cls;
	}";
	$CLASS{CURRENT}{SUBS}{CURRENT}{TEST} = [
		['ok', sprintf 'my $obj = %s->new', $CLASS{CURRENT}{NAME}],
		['isa_ok', '$obj', qq|'$CLASS{CURRENT}{NAME}'|],
	];
	return $self;
}

sub accessor {
	my ($self, $sub, $code) = @_;
	$CLASS{CURRENT}{SUBS}{CURRENT} = $CLASS{CURRENT}{SUBS}{$sub} = {
		INDEX => $SUB_INDEX++,
		ACCESSOR => 1,
		POD => "get or set ${sub}.",
		EXAMPLE => "\$obj->${sub}\;\n\n\t\$obj->${sub}(\$value)\;"
	};
	$CLASS{CURRENT}{SUBS}{CURRENT}{CODE} = $code ? $code : eval "sub {
		my (\$self, \$value) = \@_;
		if (defined \$value) {
			\$self->{$sub} = \$value;
		}
		return \$self->{$sub}
	}";
	$CLASS{CURRENT}{SUBS}{CURRENT}{TEST} = [
		['can_ok', qq|\$obj|, qq|'$sub'|],
		['is',  qq|\$obj->$sub|, 'undef'],
		['is',  qq|\$obj->$sub('test')|, qq|'test'|],
		['deep',qq|\$obj->$sub({ a => 'b' })|, qq|{ a => 'b' }|],
		['deep',qq|\$obj->$sub|, qq|{ a => 'b' }|]
	];
	return $self;
}

lib/Module/Generate.pm  view on Meta::CPAN

	_make_path($file);
	open(my $fh, '>', $file) or die "Cannot open file to write $!";
	print $fh $test_file;
	close $fh;
}


sub _make_path {
	my $path = abs_path();
	for (split '/', $_[0]) {
		next if $_ =~ m/\.pm|\.t/;
		$path .= "/$_";
		$path =~ m/(.*)/;
		if (! -d $1) {
			mkdir $1 or die "Cannot open file for writing $!";
		}
	}
	return $path;
}

sub _build_no_strict {
	if ($_[0] && scalar @{$_[0]}) {
		return sprintf "\nno strict qw/%s/;\n", join " ", @{$_[0]};
	}
	return '';
}

sub _build_no_warnings {
	if ($_[0] && scalar @{$_[0]}) {
		return sprintf "\nno warnings qw/%s/;\n", join " ", @{$_[0]};
	}
	return '';
}

sub _build_use {
	my @codes;
	if ($_[0]->{USE}) {
		my @use = @{$_[0]->{USE}};
		while (@use) {
			my $mod = shift @use;
			$mod .= ' ' . shift @use if ($use[0] && $use[0] =~ s/^\[(.*)\]$/$1/sg);
			push @codes, "use $mod;";
		}
	}
	push @codes, sprintf("use base qw/%s/;", join " ", @{$_[0]->{BASE}}) if $_[0]->{BASE};
	push @codes, sprintf("use base qw/%s/;", join " ", @{$_[0]->{PARENT}}) if $_[0]->{PARENT};
	push @codes, map { "use $_;" } @{$_[0]->{REQUIRE}} if $_[0]->{REQUIRE};
	return join "\n", @codes;
}

sub _build_global {
	my @codes = map { "our $_;" } @{$_[0]};
	$CLASS{VERSION} ||= 0.01;
	unshift @codes, "our \$VERSION = $CLASS{VERSION};";
	return join "\n", @codes;
}

sub _build_phase {
	my $phases = shift;
	my @codes;
	for (qw/BEGIN UNITCHECK CHECK INIT END/) {
		if ($phases->{$_}) {
			my $code = ref $phases->{$_} ? Dumper $phases->{$_} : $phases->{$_};
			$code =~ s/\$VAR1 = //;
			$code =~ s/^\s*sub\s*//;
			$code =~ s/\s*\n*\s*package Module\:\:Generate\;|use warnings\;|use strict\;//g;
			$code =~ s/};$/}/;	
			$code = sprintf "%s %s;", 'BEGIN', $code;
			push @codes, $code;
		}
	}
	return join "\n", @codes;
}

sub _stringify_struct {
	my ($MACROS, @struct) = @_;
	if ($#struct > 0) {
		return '(' . (join ", ", map {  _stringify_struct($MACROS, $_) } @struct) . ')';
	}
	$struct[0] = ref $struct[0] ? Dumper $struct[0] : $struct[0];
	return unless defined $struct[0];
	$struct[0] =~ s/\$VAR1 = //;
	$struct[0] =~ s/\s*\n*\s*package Module\:\:Generate\;|use warnings\;|use strict\;//g;
	$struct[0] =~ s/{\s*\n*/{/;
	$struct[0] =~ s/};$/}/;
	$struct[0] =~ s/\&($MACROS)/$CLASS{MACRO}{$1}/g;
	return $struct[0];
}

sub _build_subs {
	my ($class) = @_;
	my @codes;
	delete $class->{SUBS}{CURRENT};
	my $MACROS = join '|', map { quotemeta($_) } keys %{$CLASS{MACRO}};
	for my $sub (sort {
		$class->{SUBS}{$a}{INDEX} <=> $class->{SUBS}{$b}{INDEX}
	} keys %{$class->{SUBS}}) {
		next if $class->{SUBS}{$sub}{NO_CODE};
		my $code;
		if ($class->{SUBS}{$sub}{KEYWORD}) {
			my $meta = $class->{SUBS}{$sub};
			my $keyword = $CLASS{KEYWORD}{$class->{SUBS}{$sub}{KEYWORD}};
			$meta->{CODE} = _stringify_struct(
				$MACROS,
				((ref($meta->{CODE}) || "") eq "ARRAY" ? @{$meta->{CODE}} : $meta->{CODE})
			) if defined $meta->{CODE};
			$code = $keyword->{CODE} ? $keyword->{CODE}->($meta, $keyword->{KEYWORDS}) : $meta->{CODE};
		} elsif ($class->{SUBS}{$sub}{CODE}) {
			$code = ref $class->{SUBS}{$sub}{CODE} ? Dumper $class->{SUBS}{$sub}{CODE} : $class->{SUBS}{$sub}{CODE};
			$code =~ s/\$VAR1 = //;
			$code =~ s/^\s*sub\s*//;
			$code =~ s/\s*\n*\s*package Module\:\:Generate\;|use warnings\;|use strict\;//g;
			$code =~ s/{\s*\n*/{/;
			$code =~ s/};$/}/;
			$code =~ s/\&($MACROS)/$CLASS{MACRO}{$1}/g if $MACROS;
			$code = sprintf "sub %s %s", $sub, $code;
		} else {
			$code = sprintf "sub %s {\n\n\n}", $sub;
		}
		push @codes, $code;
	}