Changeset 10166

Show
Ignore:
Timestamp:
01/19/10 21:48:29 (8 months ago)
Author:
adamk
Message:
 
Location:
trunk/Padre-Plugin-PerlTidy
Files:
3 modified

Legend:

Unmodified
Added
Removed

  • trunk/Padre-Plugin-PerlTidy/Changes

    r10135 r10166  
    11Revision history for Perl extension Padre::Plugin::PerlTidy. 
     2 
     30.10  to be released 
     4    - A variety of cleanups to use Padre::Current more efficiently 
     5    - Added menu separator 
     6    - A somewhat cleaner code style that is closer to general conventions 
     7    - Added project config file that matches that of Padre itself 
     8    - Applied the Perl::Tidy plugin to itself, using the project config 
    29 
    3100.09  Thu Jan 14 2010 

  • trunk/Padre-Plugin-PerlTidy/lib/Padre/Plugin/PerlTidy.pm

    r10135 r10166  
    1717=cut 
    1818 
    19 use 5.008001; 
     19use 5.008002; 
    2020use strict; 
    2121use warnings; 
     22use Params::Util   (); 
    2223use Padre::Current (); 
    2324use Padre::Wx      (); 
    2425use Padre::Plugin  (); 
    25 use constant { SELECTIONSIZE => 40, };  # this constant is used when storing 
    26                                         # and restoring the cursor position. 
    27                                         # Keep it small to limit resource use. 
    28 our $VERSION = '0.09'; 
     26 
     27our $VERSION = '0.10'; 
    2928our @ISA     = 'Padre::Plugin'; 
    3029 
     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 
    3137sub padre_interfaces { 
    32     return 'Padre::Plugin' => '0.43', 
    33         'Padre::Config'    => '0.54'; 
     38        'Padre::Plugin' => '0.43', 'Padre::Config' => '0.54'; 
    3439} 
    3540 
    3641sub plugin_name { 
    37     Wx::gettext( 'Perl Tidy' ); 
     42        Wx::gettext('Perl Tidy'); 
    3843} 
    3944 
    4045sub menu_plugins_simple { 
    41     my $self = shift; 
    42     return $self->plugin_name => [ 
    43         Wx::gettext( "Tidy the active document\tAlt+Shift+F" ) => 
    44             \&tidy_document, 
    45         Wx::gettext( "Tidy the selected text\tAlt+Shift+G" ) => 
    46             \&tidy_selection, 
    47         Wx::gettext( 'Export active document to HTML file' ) => 
    48             \&export_document, 
    49         Wx::gettext( 'Export selected text to HTML file' ) => 
    50             \&export_selection, 
    51     ]; 
     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        ]; 
    5257} 
    5358 
    5459sub _tidy { 
    55     my ( $main, $src ) = @_; 
    56  
    57     require Perl::Tidy; 
    58  
    59     return unless defined $src; 
    60  
    61     my $doc = $main->current->document; 
    62  
    63     if ( !$doc->isa( 'Padre::Document::Perl' ) ) { 
    64         return Wx::MessageBox( 
    65             Wx::gettext( 'Document is not a Perl document' ), 
    66             Wx::gettext( 'Error' ), 
    67             Wx::wxOK | Wx::wxCENTRE, $main 
    68         ); 
    69     } 
    70  
    71     my ( $output, $error ); 
    72     my %tidyargs = ( 
    73         argv        => \'-nse -nst', 
    74         source      => \$src, 
    75         destination => \$output, 
    76         errorfile   => \$error, 
    77     ); 
    78  
    79     if ( my $tidyrc = $doc->project->config->config_perltidy ) { 
    80         $tidyargs{ perltidyrc } = $tidyrc; 
    81         Padre::Current->main->output->AppendText( 
    82             "Perl\::Tidy running with project-specific configuration $tidyrc\n" 
    83         ); 
    84     } 
    85     else { 
    86         Padre::Current->main->output->AppendText( 
    87             "Perl\::Tidy running with default or user configuration\n" ); 
    88     } 
    89  
    90     # TODO: suppress the senseless warning from PerlTidy 
    91     eval { Perl::Tidy::perltidy( %tidyargs ); }; 
    92  
    93     if ( $@ ) { 
    94         my $error_string = $@; 
    95         Wx::MessageBox( 
    96             $error_string, 
    97             Wx::gettext( "PerlTidy Error" ), 
    98             Wx::wxOK | Wx::wxCENTRE, $main 
    99         ); 
    100         return; 
    101     } 
    102  
    103     if ( defined $error ) { 
    104         my $width = length( $doc->filename ) + 2; 
    105         Padre::Current->main->output->AppendText( "\n\n" 
    106                 . "-" x $width . "\n" 
    107                 . $doc->filename . "\n" 
    108                 . "-" x $width 
    109                 . "\n" ); 
    110         Padre::Current->main->output->AppendText( "$error\n" ); 
    111         Padre::Current->main->show_output( 1 ); 
    112     } 
    113     return $output; 
     60        my $main     = shift; 
     61        my $current  = shift; 
     62        my $source   = shift; 
     63        my $document = $current->document; 
     64 
     65        # Check for problems 
     66        unless ( defined $source ) { 
     67                return; 
     68        } 
     69        unless ( $document->isa('Padre::Document::Perl') ) { 
     70                return Wx::MessageBox( 
     71                        Wx::gettext('Document is not a Perl document'), 
     72                        Wx::gettext('Error'), 
     73                        Wx::wxOK | Wx::wxCENTRE, 
     74                        $main 
     75                ); 
     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        my $output     = $main->output; 
     88        my $perltidyrc = $document->project->config->config_perltidy; 
     89        if ($perltidyrc) { 
     90                $tidyargs{perltidyrc} = $perltidyrc; 
     91                $output->AppendText("Perl::Tidy running with project configuration $perltidyrc\n"); 
     92        } else { 
     93                $output->AppendText("Perl::Tidy running with default or user configuration\n"); 
     94        } 
     95 
     96        # TODO: suppress the senseless warning from PerlTidy 
     97        require Perl::Tidy; 
     98        eval { Perl::Tidy::perltidy(%tidyargs); }; 
     99 
     100        if ($@) { 
     101                Wx::MessageBox( 
     102                        $@, 
     103                        Wx::gettext("PerlTidy Error"), 
     104                        Wx::wxOK | Wx::wxCENTRE, 
     105                        $main 
     106                ); 
     107                return; 
     108        } 
     109 
     110        if ( defined $errorfile ) { 
     111                my $filename = $document->filename; 
     112                my $width    = length($filename) + 2; 
     113                $output->AppendText( "\n\n" . "-" x $width . "\n" . $filename . "\n" . "-" x $width . "\n" ); 
     114                $output->AppendText("$errorfile\n"); 
     115                $main->show_output(1); 
     116        } 
     117 
     118        return $destination; 
    114119} 
    115120 
    116121sub tidy_selection { 
    117     my ( $main, $event ) = @_; 
    118     my $src = $main->current->text; 
    119  
    120     my $newtext = _tidy( $main, $src ); 
    121  
    122     return unless defined $newtext && length $newtext; 
    123  
    124     $newtext =~ s{\n$}{}; 
    125  
    126     my $editor = $main->current->editor; 
    127     $editor->ReplaceSelection( $newtext ); 
     122        my $main = shift; 
     123 
     124        # Tidy the current selected text 
     125        my $current = $main->current; 
     126        my $text    = $current->text; 
     127        my $tidy    = _tidy( $main, $current, $text ); 
     128        unless ( defined Params::Util::_STRING($tidy) ) { 
     129                return; 
     130        } 
     131 
     132        # If the selected text does not have a newline at the end, 
     133        # trim off any that Perl::Tidy has added. 
     134        unless ( $text =~ /\n\z/ ) { 
     135                $tidy =~ s{\n\z}{}; 
     136        } 
     137 
     138        # Overwrite the selected text 
     139        $current->editor->ReplaceSelection($tidy); 
    128140} 
    129141 
    130142sub tidy_document { 
    131     my ( $main, $event ) = @_; 
    132  
    133     my $doc = $main->current->document; 
    134     my $src = $doc->text_get; 
    135  
    136     my $newtext = _tidy( $main, $src ); 
    137  
    138     return unless defined $newtext && length $newtext; 
    139  
    140     my ( $regex, $start ) = _store_cursor_position( $main ); 
    141     $doc->text_set( $newtext ); 
    142     _restore_cursor_position( $main, $regex, $start ); 
     143        my $main = shift; 
     144 
     145        # Tidy the entire current document 
     146        my $current  = $main->current; 
     147        my $document = $current->document; 
     148        my $text     = $document->text_get; 
     149        my $tidy     = _tidy( $main, $current, $text ); 
     150        unless ( defined Params::Util::_STRING($tidy) ) { 
     151                return; 
     152        } 
     153 
     154        # Overwrite the entire document 
     155        my ( $regex, $start ) = _store_cursor_position($current); 
     156        $document->text_set($tidy); 
     157        _restore_cursor_position( $current, $regex, $start ); 
    143158} 
    144159 
    145160sub _get_filename { 
    146     my $main = shift; 
    147  
    148     my $doc         = $main->current->document or return; 
    149     my $current     = $doc->filename; 
    150     my $default_dir = ''; 
    151  
    152     if ( defined $current ) { 
    153         require File::Basename; 
    154         $default_dir = File::Basename::dirname( $current ); 
    155     } 
    156  
    157     require File::Spec; 
    158  
    159     while ( 1 ) { 
    160         my $dialog = Wx::FileDialog->new( 
    161             $main, Wx::gettext( "Save file as..." ), 
    162             $default_dir, $doc->filename . '.html', 
    163             "*.*", Wx::wxFD_SAVE, 
    164         ); 
    165         if ( $dialog->ShowModal == Wx::wxID_CANCEL ) { 
    166             return; 
    167         } 
    168         my $filename = $dialog->GetFilename; 
    169         $default_dir = $dialog->GetDirectory; 
    170         my $path = File::Spec->catfile( $default_dir, $filename ); 
    171         if ( -e $path ) { 
    172             my $res = Wx::MessageBox( 
    173                 Wx::gettext( "File already exists. Overwrite it?" ), 
    174                 Wx::gettext( "Exist" ), 
    175                 Wx::wxYES_NO, $main, 
    176             ); 
    177             if ( $res == Wx::wxYES ) { 
    178                 return $path; 
    179             } 
    180         } 
    181         else { 
    182             return $path; 
    183         } 
    184     } 
     161        my $main = shift; 
     162 
     163        my $doc         = $main->current->document or return; 
     164        my $current     = $doc->filename; 
     165        my $default_dir = ''; 
     166 
     167        if ( defined $current ) { 
     168                require File::Basename; 
     169                $default_dir = File::Basename::dirname($current); 
     170        } 
     171 
     172        require File::Spec; 
     173 
     174        while (1) { 
     175                my $dialog = Wx::FileDialog->new( 
     176                        $main,        Wx::gettext("Save file as..."), 
     177                        $default_dir, $doc->filename . '.html', 
     178                        "*.*",        Wx::wxFD_SAVE, 
     179                ); 
     180                if ( $dialog->ShowModal == Wx::wxID_CANCEL ) { 
     181                        return; 
     182                } 
     183                my $filename = $dialog->GetFilename; 
     184                $default_dir = $dialog->GetDirectory; 
     185                my $path = File::Spec->catfile( $default_dir, $filename ); 
     186                if ( -e $path ) { 
     187                        my $res = Wx::MessageBox( 
     188                                Wx::gettext("File already exists. Overwrite it?"), 
     189                                Wx::gettext("Exist"), 
     190                                Wx::wxYES_NO, $main, 
     191                        ); 
     192                        if ( $res == Wx::wxYES ) { 
     193                                return $path; 
     194                        } 
     195                } else { 
     196                        return $path; 
     197                } 
     198        } 
    185199} 
    186200 
    187201sub _export { 
    188     my ( $main, $src ) = @_; 
    189  
    190     require Perl::Tidy; 
    191  
    192     return unless defined $src; 
    193  
    194     my $doc = $main->current->document; 
    195  
    196     if ( !$doc->isa( 'Padre::Document::Perl' ) ) { 
    197         return Wx::MessageBox( 
    198             Wx::gettext( 'Document is not a Perl document' ), 
    199             Wx::gettext( 'Error' ), 
    200             Wx::wxOK | Wx::wxCENTRE, $main 
    201         ); 
    202     } 
    203  
    204     my $filename = _get_filename( $main ); 
    205  
    206     return unless defined $filename; 
    207  
    208     my ( $output, $error ); 
    209     my %tidyargs = ( 
    210         argv        => \'-html -nnn -nse -nst', 
    211         source      => \$src, 
    212         destination => $filename, 
    213         errorfile   => \$error, 
    214     ); 
    215  
    216     if ( my $tidyrc = $doc->project->config->config_perltidy ) { 
    217         $tidyargs{ perltidyrc } = $tidyrc; 
    218         Padre::Current->main->output->AppendText( 
    219             "Perl\::Tidy running with project-specific configuration $tidyrc\n" 
    220         ); 
    221     } 
    222  
    223     else { 
    224         Padre::Current->main->output->AppendText( 
    225             "Perl::Tidy running with default or user configuration\n" ); 
    226     } 
    227  
    228     # TODO: suppress the senseless warning from PerlTidy 
    229     eval { Perl::Tidy::perltidy( %tidyargs ); }; 
    230  
    231     if ( $@ ) { 
    232         my $error_string = $@; 
    233         Wx::MessageBox( 
    234             $error_string, 
    235             Wx::gettext( 'PerlTidy Error' ), 
    236             Wx::wxOK | Wx::wxCENTRE, $main 
    237         ); 
    238         return; 
    239     } 
    240  
    241     if ( defined $error ) { 
    242         my $width = length( $doc->filename ) + 2; 
    243         my $main  = Padre::Current->main; 
    244         $main->output->AppendText( "\n\n" 
    245                 . "-" x $width . "\n" 
    246                 . $doc->filename . "\n" 
    247                 . "-" x $width 
    248                 . "\n" ); 
    249         $main->output->AppendText( "$error\n" ); 
    250         $main->show_output( 1 ); 
    251     } 
    252  
    253     return; 
     202        my ( $main, $src ) = @_; 
     203 
     204        require Perl::Tidy; 
     205 
     206        return unless defined $src; 
     207 
     208        my $doc = $main->current->document; 
     209 
     210        if ( !$doc->isa('Padre::Document::Perl') ) { 
     211                return Wx::MessageBox( 
     212                        Wx::gettext('Document is not a Perl document'), 
     213                        Wx::gettext('Error'), 
     214                        Wx::wxOK | Wx::wxCENTRE, $main 
     215                ); 
     216        } 
     217 
     218        my $filename = _get_filename($main); 
     219 
     220        return unless defined $filename; 
     221 
     222        my ( $output, $error ); 
     223        my %tidyargs = ( 
     224                argv        => \'-html -nnn -nse -nst', 
     225                source      => \$src, 
     226                destination => $filename, 
     227                errorfile   => \$error, 
     228        ); 
     229 
     230        if ( my $tidyrc = $doc->project->config->config_perltidy ) { 
     231                $tidyargs{perltidyrc} = $tidyrc; 
     232                Padre::Current->main->output->AppendText("Perl\::Tidy running with project-specific configuration $tidyrc\n"); 
     233        } 
     234 
     235        else { 
     236                Padre::Current->main->output->AppendText("Perl::Tidy running with default or user configuration\n"); 
     237        } 
     238 
     239        # TODO: suppress the senseless warning from PerlTidy 
     240        eval { Perl::Tidy::perltidy(%tidyargs); }; 
     241 
     242        if ($@) { 
     243                my $error_string = $@; 
     244                Wx::MessageBox( 
     245                        $error_string, 
     246                        Wx::gettext('PerlTidy Error'), 
     247                        Wx::wxOK | Wx::wxCENTRE, $main 
     248                ); 
     249                return; 
     250        } 
     251 
     252        if ( defined $error ) { 
     253                my $width = length( $doc->filename ) + 2; 
     254                my $main  = Padre::Current->main; 
     255                $main->output->AppendText( "\n\n" . "-" x $width . "\n" . $doc->filename . "\n" . "-" x $width . "\n" ); 
     256                $main->output->AppendText("$error\n"); 
     257                $main->show_output(1); 
     258        } 
     259 
     260        return; 
    254261} 
    255262 
    256263sub export_selection { 
    257     my ( $main, $event ) = @_; 
    258     my $src = $main->current->text; 
    259  
    260     _export( $main, $src ); 
    261     return; 
     264        my $main = shift; 
     265        my $text = $main->current->text; 
     266        _export( $main, $text ); 
     267        return; 
    262268} 
    263269 
    264270sub export_document { 
    265     my ( $main, $event ) = @_; 
    266  
    267     my $doc = $main->current->document; 
    268     my $src = $doc->text_get; 
    269  
    270     _export( $main, $src ); 
    271     return; 
    272 } 
    273  
     271        my $main = shift; 
     272        my $text = $main->current->document->text_get; 
     273        _export( $main, $text ); 
     274        return; 
     275} 
     276 
     277# parameter: $main, compiled regex 
    274278sub _restore_cursor_position { 
    275  
    276     # parameter: $main, compiled regex 
    277     my ( $main, $regex, $start ) = @_; 
    278     my $doc    = $main->current->document; 
    279     my $editor = $doc->editor; 
    280     my $text   = $editor->GetTextRange( 
    281         ( $start - SELECTIONSIZE ) > 0 ? $start - SELECTIONSIZE 
    282         : 0, 
    283         ( $start + SELECTIONSIZE < $editor->GetLength() ) 
    284         ? $start + SELECTIONSIZE 
    285         : $editor->GetLength() 
    286     ); 
    287     eval { 
    288         if ( $text =~ /($regex)/ ) 
    289         { 
    290             my $pos = $start + length $1; 
    291             $editor->SetCurrentPos( $pos ); 
    292             $editor->SetSelection( $pos, $pos ); 
    293         } 
    294     }; 
    295     $editor->goto_line_centerize( $editor->GetCurrentLine ); 
    296     return; 
    297 } 
    298  
     279        my $current = shift; 
     280        my $regex   = shift; 
     281        my $start   = shift; 
     282        my $editor  = $current->editor; 
     283        my $text    = $editor->GetTextRange( 
     284                ( $start - SELECTIONSIZE ) > 0 ? $start - SELECTIONSIZE 
     285                : 0, 
     286                ( $start + SELECTIONSIZE < $editor->GetLength ) ? $start + SELECTIONSIZE 
     287                : $editor->GetLength 
     288        ); 
     289        eval { 
     290                if ( $text =~ /($regex)/ ) 
     291                { 
     292                        my $pos = $start + length $1; 
     293                        $editor->SetCurrentPos($pos); 
     294                        $editor->SetSelection( $pos, $pos ); 
     295                } 
     296        }; 
     297        $editor->goto_line_centerize( $editor->GetCurrentLine ); 
     298        return; 
     299} 
     300 
     301# parameter: $current 
     302# returns: compiled regex, start position 
     303# compiled regex is /^./ if no valid regex can be reconstructed. 
    299304sub _store_cursor_position { 
    300  
    301     # parameter: $main 
    302     # returns: compiled regex, start position 
    303     # compiled regex is /^./ if no valid regex can be reconstructed. 
    304     my $main   = shift; 
    305     my $doc    = $main->current->document; 
    306     my $editor = $doc->editor; 
    307     my $pos    = $editor->GetCurrentPos; 
    308     my $start; 
    309  
    310     if ( ( $pos - SELECTIONSIZE ) > 0 ) { 
    311         $start = $pos - SELECTIONSIZE; 
    312     } 
    313     else { 
    314         $start = 0; 
    315     } 
    316     my $prefix = $editor->GetTextRange( $start, $pos ); 
    317     my $regex; 
    318     eval { 
    319         $prefix =~ s/(\W)/\\$1/gm;    # Escape non-word chars 
    320         $prefix 
    321             =~ s/(\\\s+)/(\\s+|\\r*\\n)*/gm; # Replace whitespace by regex \s+ 
    322         $regex = qr{$prefix}; 
    323     }; 
    324     if ( $@ ) { 
    325         $regex = qw{^.}; 
    326         print STDERR @_; 
    327     } 
    328     return ( $regex, $start ); 
     305        my $current = shift; 
     306        my $editor  = $current->editor; 
     307        my $pos     = $editor->GetCurrentPos; 
     308 
     309        my $start; 
     310        if ( ( $pos - SELECTIONSIZE ) > 0 ) { 
     311                $start = $pos - SELECTIONSIZE; 
     312        } else { 
     313                $start = 0; 
     314        } 
     315 
     316        my $prefix = $editor->GetTextRange( $start, $pos ); 
     317        my $regex; 
     318        eval { 
     319 
     320                # Escape non-word chars 
     321                $prefix =~ s/(\W)/\\$1/gm; 
     322 
     323                # Replace whitespace by regex \s+ 
     324                $prefix =~ s/(\\\s+)/(\\s+|\\r*\\n)*/gm; 
     325 
     326                $regex = qr{$prefix}; 
     327        }; 
     328        if ($@) { 
     329                $regex = qw{^.}; 
     330                print STDERR @_; 
     331        } 
     332        return ( $regex, $start ); 
    329333} 
    330334 

  • trunk/Padre-Plugin-PerlTidy/padre.yml

    r10165 r10166  
    11--- 
     2editor_indent_tab: 1 
     3editor_indent_tab_width: 8 
     4editor_indent_width: 8 
    25config_perltidy: ../tools/perltidyrc