~ubuntu-branches/ubuntu/maverick/padre/maverick

use Padre::Perl     ();

use Padre::Document::Perl::Beginner;

our $VERSION = '0.48';

 

 

 

 

# Ticket #637:

                $limit = 4000;

                $limit = 4000;

                $limit = 4000;

 

 

 

sub guess_filename {

        my $self = shift;

 

        # Don't attempt a content-based guess if the file already has a name.

        if ( $self->filename ) {

                return $self->SUPER::guess_filename;

        }

 

        # Is this a script?

        my $text = $self->text_get;

        if ( $text =~ /^\#\![^\n]*\bperl\b/s ) {

 

                # It's impossible to predict the name of a script in

                # advance, but lets default to a standard "script.pl"

                return 'script.pl';

        }

 

        # Is this a module

        if ( $text =~ /\bpackage\s*([\w\:]+)/s ) {

 

                # Take the last section of the package name, and use that

                # as the file.

                my $name = $1;

                $name =~ s/.*\://;

                return "$name.pm";

        }

 

        # Otherwise, no idea

        return undef;

}

 

        # Run with console Perl to prevent unexpected results under wperl

        # The configuration values is cheaper to get compared to cperl(),

        # try it first.

        my $perl = $config->run_perl_cmd;

 

        # Warn if the Perl interpreter is not executable:

        if ( defined($perl) and ( $perl ne '' ) and ( !-x $perl ) ) {

                my $ret = Wx::MessageBox(

                        Wx::gettext(

                                sprintf( '%s seems to be no executable Perl interpreter, use the system default perl instead?', $perl )

                        ),

                        Wx::gettext('Run'),

                        Wx::wxYES_NO | Wx::wxCENTRE,

                        Padre->ide->wx->main,

                );

                $perl = Padre::Perl::cperl()

                        if $ret == Wx::wxYES;

 

        } else {

                $perl = Padre::Perl::cperl();

        }

        # (Ticket #530) Pack args here, because adding the space later confuses the called Perls @ARGV

        my $Script_Args = '';

        $Script_Args = ' ' . $run_args{script} if defined( $run_args{script} ) and ( $run_args{script} ne '' );

 

                ? qq{"$perl" -Mdiagnostics(-traceonly) $run_args{interpreter} "$filename"$Script_Args}

                : qq{"$perl" $run_args{interpreter} "$filename"$Script_Args};

                my $b = Padre::Document::Perl::Beginner->new( document => $self );

        my $nlchar = $self->newline;

# Run the checks for common beginner errors

sub beginner_check {

        my $self = shift;

 

        # TODO: Make this cool

        # It isn't, because it should show _all_ warnings instead of one and

        # it should at least go to the line it's complaining about.

        # Ticket #534

 

        my $Beginner = Padre::Document::Perl::Beginner->new(

                document => $self,

                editor   => $self->editor

        );

 

        $Beginner->check( $self->text_get );

 

        my $error = $Beginner->error;

 

        if ($error) {

                Padre->ide->wx->main->error( Wx::gettext("Error:\n") . $error );

        } else {

                Padre->ide->wx->main->message( Wx::gettext('No errors found.') );

        }

 

        return 1;

}

 

        # find start of symbol

        # TODO: This could be more robust, no?

        # Ticket #639

 

 

 

 

sub extract_subroutine {

        my ( $self, $newname ) = @_;

 

        my $editor = $self->editor;

        my $code   = $editor->GetSelectedText();

 

        my $sub_comment = <<EOC;

# 

# New subroutine extracted.

#

EOC

 

        # we want to get a list of the subroutines to pick where to place

        # the new sub

        my @functions = $self->get_functions;

 

        #print "printing the functions: " . join( "\n", @functions );

 

        # Show a list of functions

        require Padre::Wx::Dialog::RefactorSelectFunction;

        my $dialog = Padre::Wx::Dialog::RefactorSelectFunction->new( $editor->main, \@functions );

        $dialog->show();

        if ( $dialog->{cancelled} ) {

                return ();

        }

 

        # testing for now hard set:

        #my $subname = 'testing2';

        # check if canceled:

 

        my $subname = $dialog->get_function_name;

 

        # get the new code, replace the selection

        require Devel::Refactor;

        my $refactory = Devel::Refactor->new;

        my ( $new_sub_call, $new_code ) = $refactory->extract_subroutine( $newname, $code, 1 );

 

        # make the change to the selected text

        $editor->BeginUndoAction(); # do the edit atomically

        $editor->ReplaceSelection($new_sub_call);

 

        # with the change made

        # locate the function:

        my ( $start, $end ) = Padre::Util::get_matches(

                $editor->GetText,

                $self->get_function_regex($subname),

                $editor->GetSelection,  # Provides two params

        );

        unless ( defined $start ) {

 

                # This needs to now rollback the

                # the changes made with the editor

                $editor->Undo();

                $editor->EndUndoAction();

 

                # Couldn't find it

                # should be dialog

                #print "Couldn't find the sub: $subname\n";

                return;

        }

 

        # now instert the text into the right location

        my $data = Wx::TextDataObject->new;

        $data->SetText( $sub_comment . $new_code );

        my $length = $data->GetTextLength;

 

        $editor->InsertText( $start, $data->GetText );

        $editor->EndUndoAction();

 

        return ();

 

}

 

# This sub handles a cached C-Tags - Parser object which is much faster

# than recreating it on every autocomplete

 

sub _perltags_parser {

        my $self = shift;

 

        require Parse::ExuberantCTags;

 

        my $perltags_file = $self->{_perltags_file};

 

        # Temporary until this is configurable:

        if ( !defined($perltags_file) ) {

                $self->{_perltags_file} = File::Spec->catfile( $ENV{PADRE_HOME}, 'perltags' );

                $perltags_file = $self->{_perltags_file};

        }

 

        # If we don't have a file (none specified in config, for example), return undef

        # as the object and noone will try to use it

        return undef if !defined($perltags_file);

 

        my $parser;

 

        # Use the cached parser if

        #  - there is one

        #  - the last check is younger than 5 seconds (don't check the file again)

        #    or the file's mtime matches our cached mtime

        if (    defined( $self->{_perltags_parser} )

                and defined( $self->{_perltags_parser_time} )

                and (  ( $self->{_perltags_parser_last} > ( time - 5 ) )

                        or ( $self->{_perltags_parser_time} == ( stat($perltags_file) )[9] ) )

                )

        {

                $parser = $self->{_perltags_parser};

                $self->{_perltags_parser_last} = time;

        } else {

                $parser                        = Parse::ExuberantCTags->new($perltags_file);

                $self->{_perltags_parser}      = $parser;

                $self->{_perltags_parser_time} = ( stat($perltags_file) )[9];

                $self->{_perltags_parser_last} = time;

        }

 

        return $parser;

}

 

 

        # (Ticket #676)

 

                my $parser = $self->_perltags_parser;

        # check for hashs

        elsif ( $prefix =~ /(\$\w+(?:\-\>)?)\{([\'\"]?)([\$\&]?\w*)$/ ) {

                my $hashname   = $1;

                my $textmarker = $2;

                my $keyprefix  = $3;

 

                my $last = $editor->GetLength();

                my $text = $editor->GetTextRange( 0, $last );

 

                my %words;

                while ( $text =~ /\Q$hashname\E\{(([\'\"]?)\Q$keyprefix\E.+?\2)\}/g ) {

                        $words{$1} = 1;

                }

 

                return (

                        length( $textmarker . $keyprefix ),

                        sort {

                                my $a1 = $a;

                                my $b1 = $b;

                                $a1 =~ s/^([\'\"])(.+)\1/$2/;

                                $b1 =~ s/^([\'\"])(.+)\1/$2/;

                                $a1 cmp $b1;

                                } ( keys(%words) )

                );

 

        }

 

                my $parser = $self->_perltags_parser;

                my $parser = $self->_perltags_parser;

 

        eval { $regex = qr{\b(\Q$prefix\E\w+(?:::\w+)*)\b} };

sub newline_keep_column {

        my $self = shift;

 

        my $editor = $self->editor or return;

        my $pos    = $editor->GetCurrentPos;

        my $line   = $editor->LineFromPosition($pos);

        my $first  = $editor->PositionFromLine($line);

        my $col    = $pos - $editor->PositionFromLine( $editor->LineFromPosition($pos) );

        my $text   = $editor->GetTextRange( $first, ( $pos - $first ) );

 

        $editor->AddText( $self->newline );

 

        $pos   = $editor->GetCurrentPos;

        $first = $editor->PositionFromLine( $editor->LineFromPosition($pos) );

 

        #       my $col2 = $pos - $first;

        #       $editor->AddText( ' ' x ( $col - $col2 ) );

 

        # TODO: Remove the part made by auto-ident before addtext:

        $text =~ s/[^\s\t\r\n]/ /g;

        $editor->AddText($text);

 

        $editor->SetCurrentPos( $first + $col );

 

        return 1;

}

 

 

        my $config = Padre->ide->config;

        my $main   = Padre->ide->wx->main;

 

        my $pos   = $editor->GetCurrentPos;

        my $line  = $editor->LineFromPosition($pos);

        my $first = $editor->PositionFromLine($line);

        my $last  = $editor->PositionFromLine( $line + 1 ) - 1;

 

        if ( $config->autocomplete_brackets ) {

                                unless ( defined($nextChar) && ord($nextChar) == $table{$key}

                                        and ( !$config->autocomplete_multiclosebracket ) )

        # This only matches if all conditions are met:

        #  - config option enabled

        #  - none of the following keys pressed: a-z, A-Z, 0-9, _

        #  - cursor position is at end of line

        if ($config->autocomplete_method

                and (  ( $key < 48 )

                        or ( ( $key > 57 ) and ( $key < 65 ) )

                        or ( ( $key > 90 ) and ( $key < 95 ) )

                        or ( $key == 96 )

                        or ( $key > 122 ) )

                and ( $pos == $last )

                )

        {

 

                # from beginning to current position

                my $prefix = $editor->GetTextRange( 0, $pos );

 

                # methods can't live outside packages, so ignore them

                if ( $prefix =~ /package / ) {

                        my $linetext = $editor->GetTextRange( $first, $last );

 

                        # we only match "sub foo" at the beginning of a line

                        # but no inline subs (eval, anonymus, etc.)

                        # The end-of-subname match is included in the first if

                        # which match the last key pressed (which is not part of

                        # $linetext at this moment:

                        if ( $linetext =~ /^sub[\s\t]+\w+$/ ) {

 

                                # Add the default skeleton of a method,

                                # the \t should be replaced by

                                # (space * current_indent_width)

                                $editor->AddText( ' {'

                                                . $self->newline . "\t"

                                                . 'my $self = shift;'

                                                . $self->newline . "\t"

                                                . $self->newline . '}'

                                                . $self->newline

                                                . $self->newline );

 

                                # Ready for typing in the new method:

                                $editor->GotoPos( $last + 23 );

 

                        }

                }

        }

 

 

        $main->on_autocompletion if $config->autocomplete_always;

 

                if ( $point != Wx::wxDefaultPosition ) {

 

                        # Then it is really a mouse event...

                        # On Windows, context menu is faked

                        # as a Mouse event

                        $pos = $editor->PositionFromPoint($point);

                }

        }

 

        unless ($pos) {

                $pos = $editor->GetCurrentPos();

#

# Returns Perl's Help Provider

#

sub get_help_provider {

        require Padre::HelpProvider::Perl;

        return Padre::HelpProvider::Perl->new;

}

 

#

# Returns Perl's Quick Fix Provider

#

sub get_quick_fix_provider {

        require Padre::QuickFixProvider::Perl;

        return Padre::QuickFixProvider::Perl->new;

}