Ticket #1183: PerlTidy.pm

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