Ticket #1186: PerlTidy.pm

File PerlTidy.pm, 9.0 KB (added by azornik, 3 years ago)
Line 
1package Padre::Plugin::PerlTidy;
2
3# ABSTRACT: Format perl files using Perl::Tidy
4
5=pod
6
7=head1 SYNOPSIS
8
9This is a simple plugin to run Perl::Tidy on your source code.
10
11Currently there are no customisable options (since the Padre plugin system
12doesn't support that yet) - however Perl::Tidy will use your normal .perltidyrc
13file if it exists (see Perl::Tidy documentation).
14
15=cut
16
17use 5.008002;
18use strict;
19use warnings;
20use Params::Util   ();
21use Padre::Current ();
22use Padre::Wx      ();
23use Padre::Plugin  ();
24use base 'Padre::Plugin';
25use Perl::Tidy::perltidy(postfilter => $postaction);
26
27our $VERSION=0.17;
28
29
30# This constant is used when storing
31# and restoring the cursor position.
32# Keep it small to limit resource use.
33use constant {
34    SELECTIONSIZE => 40,
35};
36
37sub padre_interfaces {
38    'Padre::Plugin' => '0.43', 'Padre::Config' => '0.54';
39}
40
41sub plugin_name {
42    Wx::gettext('Perl Tidy');
43}
44
45sub menu_plugins_simple {
46    my $self = shift;
47    return $self->plugin_name => [
48        Wx::gettext("Tidy the active document\tAlt+Shift+F") => \&tidy_document,
49        Wx::gettext("Tidy the selected text\tAlt+Shift+G") =>
50            \&tidy_selection,
51        '---' => undef,
52        Wx::gettext('Export active document to HTML file') =>
53            \&export_document,
54        Wx::gettext('Export selected text to HTML file') =>
55            \&export_selection,
56        '---' => undef,
57        Wx::gettext('Configure tidy') =>
58            \&configure_tidy,
59    ];
60}
61
62sub _tidy {
63    my $main     = shift;
64    my $current  = shift;
65    my $source   = shift;
66    my $perltidyrc = shift;
67    my $document = $current->document;
68
69    # Check for problems
70    unless ( defined $source ) {
71        return;
72    }
73    unless ( $document->isa('Padre::Document::Perl') ) {
74        $main->error( Wx::gettext('Document is not a Perl document') );
75        return;
76    }
77
78    my $destination = undef;
79    my $errorfile   = undef;
80    my %tidyargs    = (
81        argv        => \'-nse -nst',
82        source      => \$source,
83        destination => \$destination,
84        errorfile   => \$errorfile,
85    );
86
87    #Make sure output is visible...
88    $main->show_output(1);
89    my $output = $main->output;
90
91#   CLAUDIO: This code breaks the plugin, temporary disabled.
92#   Have a look at Perl::Tidy line 126 for details: expecting a reference related to a file and not Wx::CommandEvent).
93#   Talk to El_Che for more info.
94#   if (not $perltidyrc) {
95#       $perltidyrc = $document->project->config->config_perltidy;
96#   }
97#   if ($perltidyrc) {
98#       $tidyargs{perltidyrc} = $perltidyrc;
99#       $output->AppendText("Perl::Tidy running with project configuration $perltidyrc\n");
100#   } else {
101#       $output->AppendText("Perl::Tidy running with default or user configuration\n");
102#   }
103
104    # TODO: suppress the senseless warning from PerlTidy
105    require Perl::Tidy;
106    eval { Perl::Tidy::perltidy(%tidyargs); };
107
108    if ($@) {
109        $main->error( Wx::gettext("PerlTidy Error") . ":\n" . $@ );
110        return;
111    }
112
113    if ( defined $errorfile ) {
114        my $filename = $document->filename ? $document->filename : $document->get_title;
115        my $width = length($filename) + 2;
116        $output->AppendText( "\n\n" . "-" x $width . "\n" . $filename . "\n" . "-" x $width . "\n" );
117        $output->AppendText("$errorfile\n");
118    }
119
120    return $destination;
121}
122
123sub tidy_selection {
124    my $main = shift;
125    my $perltidyrc = shift;
126
127    # Tidy the current selected text
128    my $current = $main->current;
129    my $text    = $current->text;
130    my $tidy    = _tidy( $main, $current, $text, $perltidyrc );
131    unless ( defined Params::Util::_STRING($tidy) ) {
132        return;
133    }
134
135    # If the selected text does not have a newline at the end,
136    # trim off any that Perl::Tidy has added.
137    unless ( $text =~ /\n\z/ ) {
138        $tidy =~ s{\n\z}{};
139    }
140
141    # Overwrite the selected text
142    $current->editor->ReplaceSelection($tidy);
143}
144
145sub configure_tidy {
146    require Padre::Plugin::PerlTidy::Dialog;
147    my $d = Padre::Plugin::PerlTidy::Dialog->new;
148    return;
149}
150
151sub tidy_document {
152    my $main = shift;
153    my $perltidyrc = shift;
154
155    # Tidy the entire current document
156    my $current  = $main->current;
157    my $document = $current->document;
158    my $text     = $document->text_get;
159    my $tidy     = _tidy( $main, $current, $text, $perltidyrc );
160    unless ( defined Params::Util::_STRING($tidy) ) {
161        return;
162    }
163
164    # Overwrite the entire document
165    my ( $regex, $start ) = _store_cursor_position($current);
166    $document->text_set($tidy);
167    _restore_cursor_position( $current, $regex, $start );
168}
169
170sub _get_filename {
171    my $main = shift;
172
173    my $doc         = $main->current->document or return;
174    my $current     = $doc->filename;
175    my $default_dir = '';
176
177    if ( defined $current ) {
178        require File::Basename;
179        $default_dir = File::Basename::dirname($current);
180    }
181
182    require File::Spec;
183
184    while (1) {
185        my $dialog = Wx::FileDialog->new(
186            $main, Wx::gettext("Save file as..."),
187#XXX
188            before_hooks;
189            $default_dir, ( $current or $doc->get_title ) . '.html',
190            "*.*", Wx::wxFD_SAVE,
191        );
192        if ( $dialog->ShowModal == Wx::wxID_CANCEL ) {
193            return;
194        }
195        my $filename = $dialog->GetFilename;
196        $default_dir = $dialog->GetDirectory;
197        my $path = File::Spec->catfile( $default_dir, $filename );
198        if ( -e $path ) {
199            return $path if $main->yes_no( Wx::gettext("File already exists. Overwrite it?"), Wx::gettext("Exist") );
200        } else {
201            return $path;
202        }
203    }
204}
205
206sub _export {
207    my ( $main, $src ) = @_;
208
209    require Perl::Tidy;
210
211    return unless defined $src;
212
213    my $doc = $main->current->document;
214
215    if ( !$doc->isa('Padre::Document::Perl') ) {
216        $main->error( Wx::gettext('Document is not a Perl document') );
217        return;
218    }
219
220    my $filename = _get_filename($main);
221
222    return unless defined $filename;
223
224    my ( $output, $error );
225    my %tidyargs = (
226        argv        => \'-html -nnn -nse -nst',
227        source      => \$src,
228        destination => $filename,
229        errorfile   => \$error,
230    );
231
232    # Make sure output window is visible...
233    $main->show_output(1);
234    $output = $main->output;
235
236    if ( my $tidyrc = $doc->project->config->config_perltidy ) {
237        $tidyargs{perltidyrc} = $tidyrc;
238        $output->AppendText("Perl\::Tidy running with project-specific configuration $tidyrc\n");
239    } else {
240        $output->AppendText("Perl::Tidy running with default or user configuration\n");
241    }
242
243    # TODO: suppress the senseless warning from PerlTidy
244    eval { Perl::Tidy::perltidy(%tidyargs); };
245
246    if ($@) {
247        $main->error( Wx::gettext("PerlTidy Error") . ":\n" . $@ );
248        return;
249    }
250
251    if ( defined $error ) {
252        my $width = length( $doc->filename ) + 2;
253        my $main  = Padre::Current->main;
254
255        $output->AppendText( "\n\n" . "-" x $width . "\n" . $doc->filename . "\n" . "-" x $width . "\n" );
256        $output->AppendText("$error\n");
257        $main->show_output(1);
258    }
259
260    return;
261}
262
263sub export_selection {
264    my $main = shift;
265    my $text = $main->current->text;
266    _export( $main, $text );
267    return;
268}
269
270sub export_document {
271
272
273    my $main = shift;
274    my $text = $main->current->document->text_get;
275    _export( $main, $text );
276    return;
277}
278
279# parameter: $main, compiled regex
280sub _restore_cursor_position {
281    my $current = shift;
282    my $regex   = shift;
283    my $start   = shift;
284    my $editor  = $current->editor;
285    my $text    = $editor->GetTextRange(
286        ( $start - SELECTIONSIZE ) > 0 ? $start - SELECTIONSIZE
287        : 0,
288        ( $start + SELECTIONSIZE < $editor->GetLength ) ? $start + SELECTIONSIZE
289        : $editor->GetLength
290    );
291    eval {
292        if ( $text =~ /($regex)/ )
293        {
294            my $pos = $start + length $1;
295            $editor->SetCurrentPos($pos);
296            $editor->SetSelection( $pos, $pos );
297        }
298    };
299    $editor->goto_line_centerize( $editor->GetCurrentLine );
300    return;
301}
302
303# parameter: $current
304# returns: compiled regex, start position
305# compiled regex is /^./ if no valid regex can be reconstructed.
306sub _store_cursor_position {
307    my $current = shift;
308    my $editor  = $current->editor;
309    my $pos     = $editor->GetCurrentPos;
310
311    my $start;
312    if ( ( $pos - SELECTIONSIZE ) > 0 ) {
313        $start = $pos - SELECTIONSIZE;
314    } else {
315        $start = 0;
316    }
317
318    my $prefix = $editor->GetTextRange( $start, $pos );
319    my $regex;
320    eval {
321
322        # Escape non-word chars
323        $prefix =~ s/(\W)/\\$1/gm;
324
325        # Replace whitespace by regex \s+
326        $prefix =~ s/(\\\s+)/(\\s+|\\r*\\n)*/gm;
327
328        $regex = qr{$prefix};
329    };
330    if ($@) {
331        $regex = qw{^.};
332        print STDERR @_;
333    }
334    return ( $regex, $start );
335}
336
337sub plugin_disable {
338    my $self = shift;
339   
340    # Unload all private classese here, so that they can be reloaded
341    require Class::Unload;
342    Class::Unload->unload('Padre::Plugin::PerlTidy::Dialog');
343    Class::Unload->unload('Perl::Tidy');
344    return;
345}
346sub before_hooks {
347    tidy_document;
348} 
3491;
350
351=pod
352
353=head1 INSTALLATION
354
355You can install this module like any other Perl module and it will
356become available in your Padre editor. However, you can also
357choose to install it into your user's Padre configuration directory only:
358
359=over 4
360
361=item * Install the prerequisite modules.
362
363=item * perl Makefile.PL
364
365=item * make
366
367=item * make installplugin
368
369=back
370
371This will install the plugin as PerlTidy.par into your user's ~/.padre/plugins
372directory.
373
374Similarly, "make plugin" will just create the PerlTidy.par which you can
375then copy manually.
376
377=head1 METHODS
378
379=head2 padre_interfaces
380
381Indicates our compatibility with Padre.
382
383=head2 plugin_name
384
385A simple accessor for the name of the plugin.
386
387=head2 menu_plugins_simple
388
389Menu items for this plugin.
390
391=head2 tidy_document
392
393Runs Perl::Tidy on the current document.
394
395=head2 export_document
396
397Export the current document as html.
398
399=head2 tidy_selection
400
401Runs Perl::Tidy on the current code selection.
402
403=head2 export_selection
404
405Export the current code selection as html.
406
407=cut