package Code::Generator::Perl;

use strict;
use warnings;

use Data::Dumper;
use Carp;
use File::Spec::Functions;

my %packages_created;

our $VERSION = '0.02';

sub new {
	my ($class, %details) = @_;
	my $self = {};
	$self->{outdir} = $details{outdir} || '.';
	$self->{base_package} = $details{base_package};
	$self->{readonly} = $details{readonly} || 0;
	$self->{content} = ();
	$self->{generated_by} = $details{generated_by} || 'a script';

	bless ($self, $class);
	return $self;
}

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

	my $uses = $self->{use};
	if (defined $uses) {
	    foreach my $package (@{$uses}) {
		$self->use($package);
	    }
	} else {
	    $self->use(qw/strict warnings/);
	}

	if ($self->{readonly} || $self->{package_readonly}) {
	    $self->use('Readonly');
	}
}

sub use {
	my ($self, @packages) = @_;
	map { $self->_add_if_not_yet_used($_) } @packages;
	return $self;
}

sub _add_if_not_yet_used {
    my ($self, $package) = @_;
    if (! grep { /$package/ } @{$self->{use}}) {
	push @{$self->{use}}, $package;
    }
}

sub new_package {
	my ($self, $package_name, %details) = @_;
	$self->{package} = $package_name
		|| die "new_package: Missing package name";
	$self->{outdir} = $details{outdir} || $self->{outdir};
	$self->{use} = $details{use} || [];
	$self->{package_generated_by} = $details{generated_by};
	unshift @{$self->{use}}, 'warnings' if ! defined $details{nowarnings};
	unshift @{$self->{use}}, 'strict' if ! defined $details{nostrict};

	if (defined $self->{base_package}) {
		$self->{package} = join('::',
					$self->{base_package},
					$self->{package});
	}
	$self->{content} = ();

	$self->{package_readonly} = $self->{readonly};
	$self->{package_readonly} = $details{readonly}
				    if defined $details{readonly};

	$self->_init_use();
	return $self;
}

sub add_comment {
	my ($self, @comments) = @_;
	$self->_add_content("# " . join("\n# ", @comments));
	return $self;
}

sub add {
	my ($self, $name, $value, $options) = @_;
	local $Data::Dumper::Indent = 1;
	local $Data::Dumper::Purity = 1;
	local $Data::Dumper::Deepcopy = 0;
	local $Data::Dumper::Sortkeys = $options->{sortkeys} || 0;

	my $readonly = $self->{readonly};
	$readonly = $self->{package_readonly}
		    if defined $self->{package_readonly};
	$readonly = $options->{readonly} if defined $options->{readonly};

	local $Data::Dumper::Deepcopy = $readonly;

	my $content = Data::Dumper->Dump([$value], [$name]);

	if ($readonly) {
		$self->use('Readonly');
		$content =~ s/=/=>/;
		$self->_add_content('Readonly::Scalar our ' . $content);
	} else {
		$self->_add_content('our ' . $content);
	}
	return $self;
}

sub _add_content {
	my ($self, $content) = @_;
	push @{$self->{content}}, $content;
}

sub get_line_printer_for {
	my ($filename) = @_;

	open my $file, ">$filename" or die "Could not open $filename\n";

	return (
		sub {
			my ($str) = @_;
			$str ||= '';
			print $file "$str\n";
		},
		sub {
			close $file;
		},
	);
}

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

	my $outdir = $self->{outdir};
	my $package = $self->{package};
	if ($packages_created{$package}) {
		croak join("\n",
		     "ERROR: Package $package has already been written before!",
		     "\tMost likely this is not what you want.",
		     "\tBailing out.",
		);
	}
	$packages_created{$package} = 1;

	my @dir = split('::', $self->{package});
	my $filename = pop @dir;
	$outdir = catfile($outdir, @dir);
	$filename = catfile($outdir, $filename . '.pm');

	if (! -d $outdir) {
		`mkdir -p $outdir`;
	}

	my ($print_line, $done)= get_line_printer_for($filename);
	$print_line->("package $package;");
	$print_line->();

	map { $print_line->("use $_;") } @{$self->{use}};
	$print_line->() if (scalar @{$self->{use}});

	$print_line->('# You should never edit this file. '
			 . 'Everything in here is automatically');
	$print_line->('# generated by '
			. ($self->{package_generated_by}
			   || $self->{generated_by})
			. '.');
	$print_line->();

	map { $print_line->($_) } @{$self->{content}};

	$print_line->('1;');
	$done->();
	return $self->_verify_package($package, $filename);
}

sub _verify_package {
	my ($self, $package, $filename) = @_;
	eval "use lib '" . $self->{outdir} . "';";
	eval "use $package;";
	if ($@) {
		warn "Error while generating $filename:\n\t$@";
		return 0;
	} else {
		if ($ENV{verbose}) {
			print STDERR "$filename\n";
		}
	}
	return 1;
}

sub create_or_die {
	my ($self, $die_message) = shift;
	$die_message ||= '';
	if (! $self->create()) {
		die "$die_message $!";
	}
}

1;
__END__
=head1 NAME

Code::Generator::Perl - Perl module for generating perl modules

=head1 SYNOPSIS

  use Code::Generator::Perl;

  my $generator = new Code::Generator::Perl(
			generated_by => 'somescript.pl',
  );

  my @fib_sequence = ( 1, 1, 2, 3, 5, 8 );

  $generator->new_package('Fibonacci');

  $generator->add_comment('Single digit fibonacci numbers');
  $generator->add(fib_sequence => \@fib_sequence);
  $generator->create_or_die();
  # This will generate the file Fibonacci.pm:
  #
  #     package Fibonacci;
  #
  #     use strict;
  #     use warnings;
  #
  #     # You should never edit this file. Everything in here is automatically
  #     # generated by somescript.pl.
  #
  #     # Single digit fibonacci numbers
  #     our $sequence = [
  #       1,
  #       1,
  #       2,
  #       3,
  #       5,
  #       8
  #     ];
  #
  #     1;

  my @single_digit_numbers = ( 1..9 );
  $generator->new_package('Number::Single::Digit');
  $generator->add(single_digits => \@single_digit_numbers);

  # Generates Number/Single/Digit.pm
  $generator->create_or_die();

=head1 DESCRIPTION

Code::Generator::Perl generates perl modules for you.

The idea is that you specify the module name and what variables it has and it
will spit out the .pm files for you, using Data::Dumper to do the actual
nitty-gritty work.

It was born out of the need to generate perl modules for representing static
data relationship from relational database tables. The static data doesn't
change all that often so having them pre-calculated in some perl module
somewhere saves precious cpu time that would have been spent on doing table
joins to come up with the same data.

=head2 Methods

=over 4

=item new(option => value, ...)

Creates the generator object.  Available options are

=over 4

=item outdir

Specifies the directory where the generated files will be saved to.

=item base_package

The base package to be prepended to the package name.

=item readonly

Set this to true if you would like all the variables in all the packages to be
generated to be readonly. This requires the Readonly module. You can overide
this in per-package or per-variable readonly option.

=item generated_by

Set this to the name of your script so that people that view the generated file
know which script generates your generated files.

=back

=item new_package('Package::Name', option => value, ...)

Prepare the generator for creating a new package. Previous contents are cleared.
Valid options are:

=over 4

=item outdir

The output directory for this package.

=item use

An array ref to a list of other modules to use. By default 'strict' and
'warnings' are included. Specify the 'nowarnings' and 'nostrict' if you don't
want them (see below).

=item nowarnings

Exclude 'use warnings' if set to true.

=item nostrict

Exclude 'use strict' if set to true.

=item package_generated_by

Similar to 'generated_by' option to new but for this package only.

=item base_package

The base package name to be prepended to this package.

=item package_readonly

Set to 1 if you would like all variables in this package to be readonly.

=back

=item add_comment('some comment', 'another comment')

Add comments. They will be joined with newlines.

=item add(variable_name => $ref, { option => value })

Add a variable with the given name, pointing to $ref. Options are:

=over 4

=item sortkeys

This value will be passed to I<$Data::Dumper::Sortkeys>. See the
Data::Dumper documentation for how this value is used.

=item readonly

If set to 1 the variable will be set to readonly using the Readonly module.

=back

=back

=head1 SEE ALSO

Data::Dumper

=head1 AUTHOR

Nazri Ramliy, E<lt>ayiehere@gmail.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2011 by Nazri Ramliy

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.1 or,
at your option, any later version of Perl 5 you may have available.


=cut
