1 | package Padre::Plugin::PerlTidy; |
---|
2 | |
---|
3 | # ABSTRACT: Format perl files using Perl::Tidy |
---|
4 | |
---|
5 | =pod |
---|
6 | |
---|
7 | =head1 SYNOPSIS |
---|
8 | |
---|
9 | This is a simple plugin to run Perl::Tidy on your source code. |
---|
10 | |
---|
11 | Currently there are no customisable options (since the Padre plugin system |
---|
12 | doesn't support that yet) - however Perl::Tidy will use your normal .perltidyrc |
---|
13 | file if it exists (see Perl::Tidy documentation). |
---|
14 | |
---|
15 | =cut |
---|
16 | |
---|
17 | use 5.008002; |
---|
18 | use strict; |
---|
19 | use warnings; |
---|
20 | use Params::Util (); |
---|
21 | use Padre::Current (); |
---|
22 | use Padre::Wx (); |
---|
23 | use Padre::Plugin (); |
---|
24 | use base 'Padre::Plugin'; |
---|
25 | #XXX |
---|
26 | use Perl::Tidy::perltidy(postfilter => $postaction); |
---|
27 | |
---|
28 | our $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. |
---|
34 | use constant { |
---|
35 | SELECTIONSIZE => 40, |
---|
36 | }; |
---|
37 | |
---|
38 | sub padre_interfaces { |
---|
39 | 'Padre::Plugin' => '0.43', 'Padre::Config' => '0.54'; |
---|
40 | } |
---|
41 | |
---|
42 | sub plugin_name { |
---|
43 | Wx::gettext('Perl Tidy'); |
---|
44 | } |
---|
45 | |
---|
46 | sub 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 | |
---|
66 | sub _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 | |
---|
127 | sub 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 | |
---|
149 | sub configure_tidy { |
---|
150 | require Padre::Plugin::PerlTidy::Dialog; |
---|
151 | my $d = Padre::Plugin::PerlTidy::Dialog->new; |
---|
152 | return; |
---|
153 | } |
---|
154 | |
---|
155 | sub 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 | |
---|
174 | sub _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 | |
---|
208 | sub _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 | |
---|
265 | sub export_selection { |
---|
266 | my $main = shift; |
---|
267 | my $text = $main->current->text; |
---|
268 | _export( $main, $text ); |
---|
269 | return; |
---|
270 | } |
---|
271 | |
---|
272 | sub 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 |
---|
282 | sub _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. |
---|
308 | sub _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 | |
---|
339 | sub 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 |
---|
349 | sub before_save_action { |
---|
350 | |
---|
351 | |
---|
352 | return $postaction; |
---|
353 | } |
---|
354 | |
---|
355 | 1; |
---|
356 | |
---|
357 | =pod |
---|
358 | |
---|
359 | =head1 INSTALLATION |
---|
360 | |
---|
361 | You can install this module like any other Perl module and it will |
---|
362 | become available in your Padre editor. However, you can also |
---|
363 | choose 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 | |
---|
377 | This will install the plugin as PerlTidy.par into your user's ~/.padre/plugins |
---|
378 | directory. |
---|
379 | |
---|
380 | Similarly, "make plugin" will just create the PerlTidy.par which you can |
---|
381 | then copy manually. |
---|
382 | |
---|
383 | =head1 METHODS |
---|
384 | |
---|
385 | =head2 padre_interfaces |
---|
386 | |
---|
387 | Indicates our compatibility with Padre. |
---|
388 | |
---|
389 | =head2 plugin_name |
---|
390 | |
---|
391 | A simple accessor for the name of the plugin. |
---|
392 | |
---|
393 | =head2 menu_plugins_simple |
---|
394 | |
---|
395 | Menu items for this plugin. |
---|
396 | |
---|
397 | =head2 tidy_document |
---|
398 | |
---|
399 | Runs Perl::Tidy on the current document. |
---|
400 | |
---|
401 | =head2 export_document |
---|
402 | |
---|
403 | Export the current document as html. |
---|
404 | |
---|
405 | =head2 tidy_selection |
---|
406 | |
---|
407 | Runs Perl::Tidy on the current code selection. |
---|
408 | |
---|
409 | =head2 export_selection |
---|
410 | |
---|
411 | Export the current code selection as html. |
---|
412 | |
---|
413 | =cut |
---|