PadrePluginCookbook03: PerlX.pm

File PerlX.pm, 5.3 KB (added by bowtie, 4 years ago)

Padre::Plugin::FormBuilder::Perl.pm replacement PerlX.pm PBP

Line 
1package Padre::Plugin::FormBuilder::PerlX;
2
3=pod
4
5=head1 NAME
6
7Padre::Plugin::FormBuilder::Perl - wxFormBuilder to Padre dialog code generator
8
9=head1 SYNOPSIS
10
11  my $generator = Padre::Plugin::FormBuilder::Perl->new(
12      dialog => $fbp_object->dialog('MyDialog')
13  );
14
15=head1 DESCRIPTION
16
17This is a L<Padre>-specific variant of L<FBP::Perl>.
18
19It overloads various methods to make things work in a more Padre-specific way.
20
21=cut
22
23use 5.008005;
24use strict;
25use warnings;
26use Scalar::Util ();
27use FBP::Perl 0.38 ();
28use Mouse 0.61;
29
30our $VERSION = '0.02';
31
32extends 'FBP::Perl';
33
34has version => (
35    is       => 'ro',
36    isa      => 'Str',
37    required => 1,
38    default  => '0.01',
39);
40
41has encapsulate => (
42    is       => 'ro',
43    isa      => 'Bool',
44    required => 1,
45    default  => 0,
46);
47
48######################################################################
49# Dialog Generators
50
51sub dialog_class {
52    my $self    = shift;
53    my $name    = shift;
54    my $package = shift;
55    my $code    = $self->SUPER::dialog_class($name);
56
57    # Customise the package name if requested
58    if ($package) {
59        splice( @$code, 0, 1, "package $package;" );
60    }
61
62    # Prepend an auto-generated "Don't Modify" warning
63    my $class = Scalar::Util::blessed($self);
64    splice(
65        @$code,
66        1,
67        0,
68        "",
69        "# This module was generated by $class.",
70        "# To change this module, edit the original .fbp file and regenerate.",
71        "# DO NOT MODIFY BY HAND!",
72    );
73
74    # Append the copywrite statement that Debian/etc need
75    push @$code, <<'END_PERL';
76=pod
77
78=over 4
79
80=item new ()
81
82Constructor. Auto-generated by Padre::Plugin::FormBuilder.
83
84=back
85
86=head1 AUTHOR
87
88Adam Kennedy E<lt>adamk@cpan.orgE<gt>
89
90=head1 SEE ALSO
91
92L<Padre>
93
94=head1 LICENSE AND COPYRIGHT
95
96Copyright (c) 2008-2011 The Padre development team as listed in Padre.pm.
97
98This module is free software; you can redistribute it and/or
99modify it under the same terms as Perl itself.
100
101=cut
102
103END_PERL
104
105    return $code;
106}
107
108sub dialog_new {
109    my $self   = shift;
110    my $dialog = shift;
111    my $lines  = $self->SUPER::dialog_new($dialog);
112
113    # Find the full list of public windows
114    my @public = grep { $_->permission eq 'public' } $dialog->find( isa => 'FBP::Window' );
115
116    if ( $self->encapsulate and @public ) {
117
118        # Generate code to save the wxWidgets id values to the hash slots
119        my @save = ('');
120        foreach my $window (@public) {
121            my $name     = $window->name;
122            my $variable = $self->object_variable($window);
123            push @save, "\t\$self->{$name} = $variable->GetId;";
124        }
125
126        # Splice the bind code into the constructor
127        splice( @$lines, $#$lines - 2, 0, @save );
128    }
129
130    return $lines;
131}
132
133sub use_pragma {
134    my $self   = shift;
135    my $dialog = shift;
136    return [
137        "use 5.010;",
138        "use strict;",
139        "use warnings;",
140        "use diagnostics;",
141        "use utf8;",
142        "use autodie;",
143    ]
144}
145
146sub dialog_version {
147    my $self    = shift;
148    my $dialog  = shift;
149    my $version = $self->version;
150   
151    # use version; our $VERSION = qv(0.04);
152    return [ "use version; our \$VERSION = qv($version);", ];
153}
154
155sub use_wx {
156    my $self   = shift;
157    my $dialog = shift;
158    return [ "use Padre::Wx ();", "use Padre::Wx::Role::Main ();", ];
159}
160
161sub dialog_isa {
162    my $self   = shift;
163    my $dialog = shift;
164
165    return $self->nested(
166        "use parent -norequire, qw(", "Padre::Wx::Role::Main",
167        "Wx::Dialog", ");",
168    );
169}
170
171sub window_accessor {
172    my $self = shift;
173    unless ( $self->encapsulate ) {
174        return $self->SUPER::window_accessor(@_);
175    }
176
177    my $object = shift;
178    my $name   = $object->name;
179    my $space  = q{ };
180
181    my @tmp_pod = [
182        "=pod",
183        "$space",
184        "=over 4",
185        "$space",
186        "=item $name ()",
187        "$space",
188        "Public Accessor $name Auto-generated.",
189        "$space",
190        "=back",
191        "$space",
192        "=cut",
193    ];
194
195    my @tmp_accessor_method = $self->nested(
196        "sub $name {",
197        "my \$self = shift;",
198        "return Wx::Window::FindWindowById(\$self->{$name});",
199        "}",
200    );
201
202    my @conjoined = ( @tmp_pod, @tmp_accessor_method );
203    return @conjoined;
204}
205
206sub window_event {
207    my $self   = shift;
208    my $window = shift;
209    my $event  = shift;
210    my $name   = $window->name;
211    my $method = $window->$event();
212    my $space  = q{ };
213
214    my @tmp_pod = [
215        "=pod",
216        "$space",
217        "=over 4",
218        "$space",
219        "=item $method ()",
220        "$space",
221        "Event Handler for $name.$event (Required). Auto-generated.",
222        "You must implement this Method in your calling class.",
223        "$space",
224        "=back",
225        "$space",
226        "=cut",
227    ];
228
229    my @tmp_required_method = $self->nested(
230        "sub $method {",
231        "my \$self = shift;",
232        "return \$self->main->error('Handler method $method for event $name.$event not implemented');",
233        "}",
234    );
235
236    my @conjoined = ( @tmp_pod, @tmp_required_method );
237    return @conjoined;
238}
239
240# Because we expect everything to be shimmed, apply a stricter interpretation
241# of lexicality if the code is being generated for Padre.
242sub object_lexical {
243    my $self = shift;
244    unless ( $self->encapsulate ) {
245        return $self->SUPER::object_lexical(@_);
246    }
247    return 1;
248}
249
2501;
251
252=pod
253
254=head1 SUPPORT
255
256Bugs should be reported via the CPAN bug tracker at
257
258L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Padre-Plugin-FormBuilder>
259
260For other issues, or commercial enhancement or support, contact the author.
261
262=head1 AUTHOR
263
264Adam Kennedy E<lt>adamk@cpan.orgE<gt>
265
266=head1 SEE ALSO
267
268L<Padre>
269
270=head1 COPYRIGHT
271
272Copyright 2010 Adam Kennedy.
273
274This program is free software; you can redistribute
275it and/or modify it under the same terms as Perl itself.
276
277The full text of the license can be found in the
278LICENSE file included with this module.
279
280=cut