Changeset 10166


Ignore:
Timestamp:
01/19/10 21:48:29 (2 years ago)
Author:
adamk
Message:
 
Location:
trunk/Padre-Plugin-PerlTidy
Files:
3 edited

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 
Note: See TracChangeset for help on using the changeset viewer.