PadrePluginCookbook03: PerlX.pm

package Padre::Plugin::FormBuilder::PerlX;

=pod

=head1 NAME

Padre::Plugin::FormBuilder::Perl - wxFormBuilder to Padre dialog code generator

=head1 SYNOPSIS

  my $generator = Padre::Plugin::FormBuilder::Perl->new(
      dialog => $fbp_object->dialog('MyDialog')
  );

=head1 DESCRIPTION

This is a L<Padre>-specific variant of L<FBP::Perl>.

It overloads various methods to make things work in a more Padre-specific way.

=cut

use 5.008005;
use strict;
use warnings;
use Scalar::Util ();
use FBP::Perl 0.38 ();
use Mouse 0.61;

our $VERSION = '0.02';

extends 'FBP::Perl';

has version => (
    is       => 'ro',
    isa      => 'Str',
    required => 1,
    default  => '0.01',
);

has encapsulate => (
    is       => 'ro',
    isa      => 'Bool',
    required => 1,
    default  => 0,
);

######################################################################
# Dialog Generators

sub dialog_class {
    my $self    = shift;
    my $name    = shift;
    my $package = shift;
    my $code    = $self->SUPER::dialog_class($name);

    # Customise the package name if requested
    if ($package) {
        splice( @$code, 0, 1, "package $package;" );
    }

    # Prepend an auto-generated "Don't Modify" warning
    my $class = Scalar::Util::blessed($self);
    splice(
        @$code,
        1,
        0,
        "",
        "# This module was generated by $class.",
        "# To change this module, edit the original .fbp file and regenerate.",
        "# DO NOT MODIFY BY HAND!",
    );

    # Append the copywrite statement that Debian/etc need
    push @$code, <<'END_PERL';
=pod

=over 4

=item new ()

Constructor. Auto-generated by Padre::Plugin::FormBuilder.

=back

=head1 AUTHOR

Adam Kennedy E<lt>adamk@cpan.orgE<gt>

=head1 SEE ALSO

L<Padre>

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2008-2011 The Padre development team as listed in Padre.pm.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

END_PERL

    return $code;
}

sub dialog_new {
    my $self   = shift;
    my $dialog = shift;
    my $lines  = $self->SUPER::dialog_new($dialog);

    # Find the full list of public windows
    my @public = grep { $_->permission eq 'public' } $dialog->find( isa => 'FBP::Window' );

    if ( $self->encapsulate and @public ) {

        # Generate code to save the wxWidgets id values to the hash slots
        my @save = ('');
        foreach my $window (@public) {
            my $name     = $window->name;
            my $variable = $self->object_variable($window);
            push @save, "\t\$self->{$name} = $variable->GetId;";
        }

        # Splice the bind code into the constructor
        splice( @$lines, $#$lines - 2, 0, @save );
    }

    return $lines;
}

sub use_pragma {
    my $self   = shift;
    my $dialog = shift;
    return [
        "use 5.010;",
        "use strict;",
        "use warnings;",
        "use diagnostics;",
        "use utf8;",
        "use autodie;",
    ]
}

sub dialog_version {
    my $self    = shift;
    my $dialog  = shift;
    my $version = $self->version;
    
    # use version; our $VERSION = qv(0.04);
    return [ "use version; our \$VERSION = qv($version);", ];
}

sub use_wx {
    my $self   = shift;
    my $dialog = shift;
    return [ "use Padre::Wx ();", "use Padre::Wx::Role::Main ();", ];
}

sub dialog_isa {
    my $self   = shift;
    my $dialog = shift;

    return $self->nested(
        "use parent -norequire, qw(", "Padre::Wx::Role::Main",
        "Wx::Dialog", ");",
    );
}

sub window_accessor {
    my $self = shift;
    unless ( $self->encapsulate ) {
        return $self->SUPER::window_accessor(@_);
    }

    my $object = shift;
    my $name   = $object->name;
    my $space  = q{ };

    my @tmp_pod = [
        "=pod",
        "$space",
        "=over 4",
        "$space",
        "=item $name ()",
        "$space",
        "Public Accessor $name Auto-generated.",
        "$space",
        "=back",
        "$space",
        "=cut",
    ];

    my @tmp_accessor_method = $self->nested(
        "sub $name {",
        "my \$self = shift;",
        "return Wx::Window::FindWindowById(\$self->{$name});",
        "}",
    );

    my @conjoined = ( @tmp_pod, @tmp_accessor_method );
    return @conjoined;
}

sub window_event {
    my $self   = shift;
    my $window = shift;
    my $event  = shift;
    my $name   = $window->name;
    my $method = $window->$event();
    my $space  = q{ };

    my @tmp_pod = [
        "=pod",
        "$space",
        "=over 4",
        "$space",
        "=item $method ()",
        "$space",
        "Event Handler for $name.$event (Required). Auto-generated.",
        "You must implement this Method in your calling class.",
        "$space",
        "=back",
        "$space",
        "=cut",
    ];

    my @tmp_required_method = $self->nested(
        "sub $method {",
        "my \$self = shift;",
        "return \$self->main->error('Handler method $method for event $name.$event not implemented');",
        "}",
    );

    my @conjoined = ( @tmp_pod, @tmp_required_method );
    return @conjoined;
}

# Because we expect everything to be shimmed, apply a stricter interpretation
# of lexicality if the code is being generated for Padre.
sub object_lexical {
    my $self = shift;
    unless ( $self->encapsulate ) {
        return $self->SUPER::object_lexical(@_);
    }
    return 1;
}

1;

=pod

=head1 SUPPORT

Bugs should be reported via the CPAN bug tracker at

L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Padre-Plugin-FormBuilder>

For other issues, or commercial enhancement or support, contact the author.

=head1 AUTHOR

Adam Kennedy E<lt>adamk@cpan.orgE<gt>

=head1 SEE ALSO

L<Padre>

=head1 COPYRIGHT

Copyright 2010 Adam Kennedy.

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.

=cut