File Coverage

blib/lib/Padre/Plugin/FormBuilder/Dialog.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package Padre::Plugin::FormBuilder::Dialog;

use 5.008;
use strict;
use warnings;
use Class::Inspector                    ();
use Padre::Unload                       ();
use Padre::Plugin::FormBuilder::FBP     ();
use Padre::Plugin::FormBuilder::Preview ();

our $VERSION = '0.04';
our @ISA     = 'Padre::Plugin::FormBuilder::FBP';

# Temporary namespace counter
my $COUNT = 0;

use constant OPTIONS => qw{
	translate
	encapsulation
	version
	padre
};

use constant SINGLE => qw{
	select
	preview
	translate
	encapsulation
	version
	associate
	generate
};

use constant COMPLETE => qw{
	complete_fbp
	complete_shim
};

use constant FRAME => qw{
	complete_app
	complete_script
};





######################################################################
# Customisation

sub new {
	my $class = shift;
	my $main  = shift;

	# Create the dialog
	my $self = $class->SUPER::new($main);
	$self->disable( OPTIONS, SINGLE, COMPLETE, FRAME );
	$self->CenterOnParent;

	# If we don't have a current project, disable the checkbox
	my $project = $main->current->project;
	unless ( $project and $project->isa('Padre::Project::Perl') ) {
		$self->associate->Disable;
	}

	return $self;
}

sub path {
	$_[0]->browse->GetPath;
}

sub selected {
	$_[0]->select->GetStringSelection;
}

sub padre_code {
	!! $_[0]->padre->IsChecked;
}

sub i18n {
	$_[0]->translate->GetSelection > 0;
}

sub i18n_trim {
	$_[0]->translate->GetSelection > 1;
}

sub encapsulate {
	$_[0]->encapsulation->GetSelection == 1;
}

sub project {
	my $self = shift;
	my $path = $self->path or return;
	$self->ide->project_manager->from_file($path);
}





######################################################################
# Event Handlers

sub browse_changed {
	my $self = shift;
	my $path = $self->path;

	# Flush any existing state
	$self->{xml} = undef;
	SCOPE: {
		my $lock = $self->lock_update;
		$self->select->Clear;
		$self->disable( OPTIONS, SINGLE, COMPLETE, FRAME );
	}

	# Attempt to load the file and parse out the dialog list
	local $@;
	eval {
		# Load the file
		require FBP;
		$self->{xml} = FBP->new;
		my $ok = $self->{xml}->parse_file($path);
		die "Failed to load the file" unless $ok;

		# Extract the dialog list
		my $list = [
			sort
			grep { defined $_ and length $_ }
			map  { $_->name }
			$self->{xml}->project->forms
		];
		die "No dialogs found" unless @$list;

		# Find the project for the fbp file
		my $project = $self->project;
		if ( $project->isa('Padre::Project::Perl') ) {
			my $version = $project->version;
			$self->version->SetValue($version) if $version;
		}

		# Populate the dialog list
		my $lock = $self->lock_update;
		$self->select->Append($list);
		$self->select->SetSelection(0);

		# If any of the dialogs are under Padre:: default the
		# Padre-compatible code generation to true.
		if ( grep { /^Padre::/ } @$list ) {
			$self->padre->SetValue(1);
			$self->encapsulation->SetSelection(0);
			$self->translate->SetSelection(1);
		} else {
			$self->padre->SetValue(0);
			$self->encapsulation->SetSelection(0);
			$self->translate->SetSelection(0);
		}

		# Enable the dialog list and buttons
		$self->enable( OPTIONS, SINGLE, COMPLETE );

		# We need at least one frame to build a complete application
		if ( $self->{xml}->project->find_first( isa => 'FBP::Frame' ) ) {
			$self->enable( FRAME );
		} else {
			$self->disable( FRAME );
		}

		# Indicate the FBP file is ok
		if ( $self->browse->HasTextCtrl ) {
			my $ctrl = $self->browse->GetTextCtrl;
			$ctrl->SetBackgroundColour(
				Wx::Colour->new('#CCFFCC')
			);
		}
	};
	if ( $@ ) {
		# Indicate the FBP file is not ok
		if ( $self->browse->HasTextCtrl ) {
			$self->browse->GetTextCtrl->SetBackgroundColour(
				Wx::Colour->new('#FFCCCC')
			);
		}

		# Inform the user directly
		$self->error("Missing, invalid or empty file '$path': $@");
	}

	return;
}

sub generate_clicked {
	my $self   = shift;
	my $dialog = $self->selected or return;
	my $fbp    = $self->{xml}    or return;
	my $form   = $fbp->form($dialog);
	unless ( $form ) {
		$self->error("Failed to find form $dialog");
		return;
	}

	# Generate the dialog code
	my $code = $self->generate_form(
		fbp       => $fbp,
		form      => $form,
		package   => $dialog,
		padre     => $self->padre_code,
		version   => $self->version->GetValue || '0.01',
		i18n      => $self->i18n,
		i18n_trim => $self->i18n_trim,
	) or return;

	# Open the generated code as a new file
	$self->show($code);

	return;
}

sub preview_clicked {
	my $self   = shift;
	my $dialog = $self->selected or return;
	my $fbp    = $self->{xml}    or return;
	my $form   = $fbp->form($dialog);
	unless ( $form ) {
		$self->error("Failed to find form $dialog");
		return;
	}

	# Close any previous frame
	$self->clear_preview;

	# Generate the dialog code
	my $name = "Padre::Plugin::FormBuilder::Temp::Dialog" . ++$COUNT;
	SCOPE: {
		local $@ = '';
		my $code = eval {
			$self->generate_form(
				fbp       => $fbp,
				form      => $form,
				package   => $name,
				padre     => $self->padre_code,
				version   => $self->version->GetValue || '0.01',
				i18n      => 0,
				i18n_trim => 0,
			)
		};
		if ( $@ or not $code ) {
			$self->error("Error generating dialog: $@");
			$self->unload($name);
			return;
		}

		# Load the dialog
		eval "$code";
		if ( $@ ) {
			$self->error("Error loading dialog: $@");
			$self->unload($name);
			return;
		}
	}

	# Create the form
	local $@;
	my $preview = eval {
		$form->isa('FBP::FormPanel')
			? Padre::Plugin::FormBuilder::Preview->new( $self->main, $name )
			: $name->new( $self->main )
	};
	if ( $@ ) {
		$self->error("Error constructing dialog: $@");
		$self->unload($name);
		return;
	}

	# Handle the ones we can show modally
	if ( $preview->can('ShowModal') ) {
		# Show the dialog
		my $rv = eval {
			$preview->ShowModal;
		};
		$preview->Destroy;
		if ( $@ ) {
			$self->error("Dialog crashed while in use: $@");
		}
		$self->unload($name);
		return;
	}

	# Show the long way
	$preview->Show;
	$self->{frame} = $preview->GetId;

	return 1;
}

sub clear_preview {
	my $self = shift;
	if ( $self->{frame} ) {
		my $old = Wx::Window::FindWindowById( delete $self->{frame} );
		$old->Destroy if $old;
	}
	return 1;
}

sub complete_refresh {
	my $self = shift;

	# Show the complete button if any box is ticked
	foreach my $name ( COMPLETE ) {
		my $checkbox = $self->$name();
		next unless $checkbox->IsEnabled;
		next unless $checkbox->IsChecked;
		return $self->enable('complete');
	}

	# None of the tick boxes are enabled
	return $self->disable('complete');
}

sub complete_clicked {
	my $self = shift;
	my $fbp  = $self->{xml} or return;

	# This could change lots of files, so lets wrap some
	# relatively course locking to prevent background task
	# storms and unneeded database operations.
	# Also ensure all notebook titles are updated when we are done.
	my $lock = $self->main->lock('DB', 'REFRESH', 'refresh_notebook');

	# Prepare the common generation options
	my @files  = ();
	my %common = (
		fbp       => $fbp,
		padre     => $self->padre_code,
		version   => $self->version->GetValue || '0.01',
		i18n      => $self->i18n,
		i18n_trim => $self->i18n_trim,
		shim      => $self->complete_shim->IsChecked ? 1 : 0,
	);

	# Generate the launch script for the app
	if ( $self->complete_script->IsChecked ) {
		my $code = $self->generate_script(%common) or return;

		# Make a guess at a sensible default name for the script
		my $file = lc $self->generator(%common)->app_package;
		$file =~ s/:://g;

		push @files, $self->show(
			code => $code,
			file => File::Spec->catfile( 'script', $file ),
		);
	}

	# Generate the Wx::App root class
	if ( $self->complete_app->IsChecked ) {
		my $code = $self->generate_app(%common) or return;
		push @files, $self->show($code);
	}

	# Generate all of the shim dialogs
	if ( $self->complete_shim->IsChecked ) {
		foreach my $form ( $fbp->project->forms ) {
			my $name = $form->name or next;

			# Generate the class
			my $code = $self->generate_shim(
				form => $form,
				name => $name,
				%common,
			) or next;

			# Open the generated code as a new file
			push @files, $self->show($code);
		}
	}

	# Generate all of the FBP dialogs
	if ( $self->complete_fbp->IsChecked ) {
		foreach my $form ( $fbp->project->forms ) {
			my $name = $form->name or next;

			# Generate the class
			my $code = $self->generate_form(
				form => $form,
				name => $name,
				%common,
			) or next;

			# Open the generated code as a new file
			push @files, $self->show($code);
		}
	}

	# Focus on the first document we touched
	@files = grep { !! $_ } @files;
	if ( @files ) {
		my $editor   = $files[0]->editor or return;
		my $notebook = $editor->notebook or return;
		my $id       = $notebook->GetPageIndex($editor);
		$notebook->SetSelection($id);
	}

	return;
}





######################################################################
# Code Generation Methods

# Generate a launch script
sub generate_script {
	my $self = shift;
	my $perl = $self->generator(@_);

	# Generate the script code
	local $@;
	my $string = eval {
		$perl->flatten(
			$perl->script_app
		);
	};
	if ( $@ ) {
		$self->error("Code Generator Error: $@");
		return;
	}

	return $string;
}

# Generate the root Wx app class
sub generate_app {
	my $self = shift;
	my $perl = $self->generator(@_);

	# Generate the app code
	local $@;
	my $string = eval {
		$perl->flatten(
			$perl->app_class
		);
	};
	if ( $@ ) {
		$self->error("Code Generator Error: $@");
		return;
	}

	return $string;
}

# Generate the class code
sub generate_form {
	my $self  = shift;
	my $perl  = $self->generator(@_);
	my %param = @_;

	# Generate the class code
	local $@;
	my $string = eval {
		$perl->flatten(
			$perl->form_class( $param{form} )
		);
	};
	if ( $@ ) {
		$self->error("Code Generator Error: $@");
		return;
	}

	# Customise the package name if requested
	if ( $param{package} ) {
		$string =~ s/^package [\w:]+/package $param{package}/;
	}

	return $string;
}

# Generate the shim code
sub generate_shim {
	my $self  = shift;
	my $perl  = $self->generator(@_);
	my %param = @_;

	# Generate the class code
	local $@;
	my $string = eval {
		$perl->flatten(
			$perl->shim_class($param{form})
		);
	};
	if ( $@ ) {
		$self->error("Code Generator Error: $@");
		return;
	}

	return $string;
}

# NOTE: Not in use yet, intended for arbitrary class entry later
sub dialog_class {
	my $self = shift;
	my $name = shift || '';
	my $main = $self->main;

	# What class name?
	my $dialog = Wx::TextEntryDialog->new(
		$main,
		Wx::gettext("Enter Class Name"),
		$self->plugin_name,
		$name,
	);
	while ( $dialog->ShowModal != Wx::wxID_CANCEL ) {
		my $package = $dialog->GetValue;
		unless ( defined $package and length $package ) {
			$self->error("Did not provide a class name");
			next;
		}
		unless ( Params::Util::_CLASS($package) ) {
			$self->error("Not a valid class name");
			next;
		}

		return $package;
	}

	return;
}





######################################################################
# Support Methods

# Display a generated document
sub show {
	my $self    = shift;
	my %param   = (@_ == 1) ? ( code => shift ) : @_;
	my $code    = $param{code};
	my $file    = $param{file};
	my $main    = $self->main;
	my $project = $self->project;

	# Auto-detect the file name if we can
	unless ( defined Params::Util::_STRING($file) ) {
		# Is this a module?
		if ( $code =~ /^package\s+([\w:]+)/ ) {
			# Where should the module be on the filesystem
			my $module = $1;
			$file = File::Spec->catfile(
				'lib',
				split( /::/, $1 )
			) . '.pm';
		}
	}

	# If we have a file name and it exists, overwrite the
	# content in an existing editor rather than making a new
	# document.
	if ( defined Params::Util::_STRING($file) ) {
		my $path = File::Spec->catfile( $project->root, $file );

		# Do we have the module open
		my $id = $main->editor_of_file($path);
		unless ( defined $id ) {
			# Open the file if it exists on disk
			if ( -f $path and -r $path ) {
				# Always use the plural "setup_editors" as
				# it clears the unused current document and
				# does update and refresh locking.
				$main->setup_editors($path);
				$id = $main->editor_of_file($path);
				unless ( defined $id ) {
					warn "Failed to open '$path'";
					return;
				}
			}
		}
		if ( defined $id ) {
			# Apply to the existing file by delta
			my $editor   = $main->notebook->GetPage($id);
			my $document = $editor->{Document} or return;
			$document->text_replace($code);
			return $document;
		}
	}

	# Not open, does not exist, or no special handling
	my $lock     = $main->lock('REFRESH');
	my $document = $main->new_document_from_string(
		$code => 'application/x-perl',
	);

	# If we have a file name for the new file, set it early.
	if ( defined Params::Util::_STRING($file) ) {
		$document->set_filename(
			File::Spec->catfile( $project->root, $file )
		);
	}

	return $document;
}

sub generator {
	my $self  = shift;
	my %param = @_;

	# Use the version tweaked for Padre?
	if ( $param{padre} ) {
		require Padre::Plugin::FormBuilder::Perl;
		return Padre::Plugin::FormBuilder::Perl->new(
			project     => $param{fbp}->project,
			version     => $param{version},
			encapsulate => $self->encapsulate,
			prefix      => 2,
			nocritic    => 1,
			i18n        => $param{i18n},
			i18n_trim   => $param{i18n_trim},
			shim        => $param{shim},
			shim_deep   => $param{shim},
		);
	}

	# Just use the normal version
	require FBP::Perl;
	return FBP::Perl->new(
		project   => $param{fbp}->project,
		version   => $param{version},
		nocritic  => 1,
		i18n      => $param{i18n},
		i18n_trim => $param{i18n_trim},
		shim      => $param{shim},
		shim_deep => $param{shim},
	);
}

# Enable a set of controls
sub enable {
	my $self = shift;
	foreach my $name ( @_ ) {
		$self->$name()->Enable(1);
	}
	return;
}

# Disable a set of controls
sub disable {
	my $self = shift;
	foreach my $name ( @_ ) {
		$self->$name()->Disable;
	}
	return;
}

# Convenience integration with Class::Unload
sub unload {
	my $either = shift;
	foreach my $package (@_) {
		Padre::Unload::unload($package);
	}
	return 1;
}

# Convenience
sub error {
	shift->main->error(@_);
}

1;

# Copyright 2008-2012 The Padre development team as listed in Padre.pm.
# LICENSE
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl 5 itself.