Devel-Refactor-0.05/0040755000127700001440000000000010216406241013104 5ustar cpanusersDevel-Refactor-0.05/t/0040755000127700001440000000000010216406241013347 5ustar cpanusersDevel-Refactor-0.05/t/rename_subroutine.t0100755000127700001440000001114410204577151017271 0ustar cpanusers#!/usr/bin/perl # $Header: $ # use strict; use Getopt::Long; use Test::More tests => 73; #use Test::More qw( no_plan ); use FindBin qw($Bin); # Where was this script installed? use lib "$Bin/.."; # Add .. to @INC; use Data::Dumper; use Refactor; ## Parse options my ($verbose); GetOptions( "verbose" => \$verbose, ); my $refactory = Devel::Refactor->new($verbose); my ($where,$old_name,$new_name) = ('t/testfile_1.pl','oldSub','newSub'); ok ($refactory->is_perlfile($where),"$where is a perl file"); my $found; eval { $found = $refactory->rename_subroutine($where,$old_name,$new_name);}; ok ( $found, "Call rename_subroutine with file '$where'") or die("Failed: rename_subroutine($where,$old_name,$new_name)"); # Check if we found all expected instances of $old_name in the file my %file1_expected = ( 11 => q{# We will eventually want to change the name of newSub} . "\n", 12 => q{my $string = newSub(1,2,3);} ."\n", 16 => q{my $string2 = newSub ($string,'a','b');} . "\n", 21 => q{my $string3 = $object->newSub(6,7);} . "\n", 25 => q{newSub('d','e','f') or die("Couldn't execute newSub: $!");} . "\n", 29 => 'sub newSub {' . "\n", ); my @file1_expected_lines = sort keys %file1_expected; _check_results ($old_name, $where, $found, \@file1_expected_lines, \%file1_expected); ($where,$old_name,$new_name) = ('t','oldSub','newSub'); eval { $found = $refactory->rename_subroutine($where,$old_name,$new_name);}; ok ( $found, "Call rename_subroutine with directory '$where' and depth of 0") or die("Failed: rename_subroutine($where,$old_name,$new_name)"); _check_results ($old_name, 't/testfile_1.pl', $found, \@file1_expected_lines, \%file1_expected); my %file2_expected = ( 15 => ' $self->newSub(@args);' ."\n", 18 => 'sub newSub {' . "\n", ); my @file2_expected_lines = sort keys %file2_expected; _check_results ($old_name, 't/testfile_2.pm', $found, \@file2_expected_lines, \%file2_expected); my %file3_expected = ( 8 => 'finds this line of text, because it contains newSub, but it shouldn\'t find' . "\n", ); my @file3_expected_lines = sort keys %file3_expected; eval { $found = $refactory->rename_subroutine($where,$old_name,$new_name,1);}; ok ( $found, "Call rename_subroutine with directory '$where' and depth of 1") or die("Failed: rename_subroutine($where,$old_name,$new_name)"); _check_results ($old_name, 't/testfile_1.pl', $found, \@file1_expected_lines, \%file1_expected); _check_results ($old_name, 't/testfile_2.pm', $found, \@file2_expected_lines, \%file2_expected); _check_results ($old_name, 't/test_subdirectory/testfile_3.pod', $found, \@file3_expected_lines, \%file3_expected); exit; ############################################################################### sub _check_results { my $old_name = shift; my $where = shift; my $found = shift; my $expected_lines = shift; my $expected = shift; foreach my $exp_line (@$expected_lines) { my $hash = shift @{ $found->{$where} }; my ( $line_num, $new_line ) = each %$hash; SKIP: { ok( $line_num, "Find expected line number $exp_line in $where") || skip "Didn't get line_num/new_line pair for $exp_line in $where",2; ok( $exp_line == $line_num, "$where line $line_num - find $old_name" ) || skip "Didn't find expected change in $where line $line_num", 1; ok( $new_line eq $expected->{$line_num}, "$where line $line_num - replacement line looks correct" ) || diag "Expected: '$expected->{$line_num}'\nGot '$new_line'"; } } } __END__ ok ($found == scalar @expected_line_numbers, "Found all $expected_count instances of $old_name") or diag "Found $found instances, expected $expected_count", Dumper($changed->{$where}); # Try looking in a directory of files. ($where,$old_name,$new_name,$how_deep) = ('t','oldSub','newSub',1); eval { $changed = $refactory->rename_subroutine($where,$old_name,$new_name,$how_deep);}; ok ( $changed && ($@ eq ''), "Call rename_subroutine with directory '$where'") or diag "$@\n", Dumper($changed); # TODO: This hash could contain lists of expected line numbers my %expected_files = ( 't/testfile_1.pl' => 1, 't/testfile_2.pm' => 1); $found = 0; my $extra = 0; foreach my $f (keys %expected_files) { $found++ if exists $changed->{$f}; } foreach my $f (keys %{$changed}) { $extra++ unless exists $expected_files{$f}; } ok ($found == 2, "Found all files.") or diag "Found: $found\n", Dumper($changed); ok ($extra == 0, "No extra files found.") or diag "Extra: $extra\n", Dumper($changed);Devel-Refactor-0.05/t/extract_subroutine.t0100755000127700001440000000343610204577151017501 0ustar cpanusers#!/usr/bin/perl # $Header: $ # use strict; use Getopt::Long; use Test::More tests => 3; use FindBin qw($Bin); # Where was this script installed? use lib "$Bin/.."; # Add .. to @INC; use Refactor; ## Parse options my ($verbose); GetOptions( "verbose" => \$verbose, ); my $code = <<'eos'; my @results; my %hash; my $date = localtime; $hash{foo} = 'value 1'; $hash{bar} = 'value 2'; for my $loopvar (@array) { print "Checking $loopvar\n"; push @results, $hash{$loopvar} || ''; } eos my $refactory = Devel::Refactor->new($verbose); my ($new_sub_call,$new_code) = $refactory->extract_subroutine('newSub',$code); if ($verbose) { diag "new sub call:\n####\n$new_sub_call\n####"; diag "new code:\n####\n$new_code\n####"; diag "Scalars:\n " , join "\n ", $refactory->get_scalars, "\n"; diag "Arrays: \n ", join "\n ", $refactory->get_arrays, "\n"; diag "Hashes:\n ",join "\n ", $refactory->get_hashes, "\n"; } # Check return values my $expected_result = 'my ($date, $hash, $results) = newSub (\@array);'; my $result = $new_sub_call; chop $result; # remove newline, just to make diagnostic message prettier. ok ($result eq $expected_result, 'New subroutine signature') or diag("Expected '$expected_result'\ngot '$result' instead"); eval $new_code; ok ( $@ eq '', 'eval extracted subroutine declaration') or diag "New code failed to eval\n####\n$new_code\n####\n$@"; $code = <<'eos'; my @array = qw( foo bar baz ); eos $code .= $new_sub_call; $code .= <<'eos'; if ($verbose) { diag "\$date: $date"; diag "\@results: ", join ', ', @$results; } eos diag "About to eval code\n####\n$code\n####" if $verbose; eval $code; ok ( $@ eq '', 'run extracted subroutine') or diag "Error eval'ing '$code': $@"; __END__ Devel-Refactor-0.05/t/testfile_1.pl0100755000127700001440000000123010204577151015745 0ustar cpanusers#!/usr/bin/perl # $Header: $ # # This file is fodder for various Devel::Refactor tests ############################################################################### use strict; use warnings; # We will eventually want to change the name of oldSub my $string = oldSub(1,2,3); package FakeClass; my $string2 = oldSub ($string,'a','b'); my $object = {}; bless $object, 'FakeClass'; my $string3 = $object->oldSub(6,7); print "Got $string and then $string2 and then $string3\n"; oldSub('d','e','f') or die("Couldn't execute oldSub: $!"); ################### sub oldSub { my ($arg1,$arg2,$arg3) = @_; my $result = $arg1 . $arg2; return $result; }Devel-Refactor-0.05/t/testfile_2.pm0100755000127700001440000000065210204577151015756 0ustar cpanusers# $Header: $ # # This file is fodder for various Devel::Refactor tests ############################################################################### package MyClass; use strict; use warnings; sub new { my ($class,@args) = @_; my $self = {}; $class = ref $class ? ref $class : $class; bless $self, $class; $self->oldSub(@args); } sub oldSub { my $self = shift; $self->{values} = join ',', @_; }Devel-Refactor-0.05/t/test_subdirectory/0040755000127700001440000000000010216406241017124 5ustar cpanusersDevel-Refactor-0.05/t/test_subdirectory/testfile_3.pod0100644000127700001440000000037710204577151021703 0ustar cpanusers# $Header: $ =pod This is a test file for B. For example, we might want to see if the I method finds this line of text, because it contains oldSub, but it shouldn't find this line, which contains oldSubroutine. =cutDevel-Refactor-0.05/t/basic.t0100755000127700001440000000135610204577151014630 0ustar cpanusers#!/usr/bin/perl # $Header: $ # use strict; use Test::More tests => 7; use Data::Dumper; BEGIN { # diag "\@INC contains:\n", join("\n",@INC); use_ok 'Refactor'; } my $rf = Devel::Refactor->new; ok($rf && ref $rf && $rf->isa('Devel::Refactor'), "Get a new Devel::Refactor object."); my @perlfiles = qw( foo.pl foo.pm foo.pod ); foreach my $fn (@perlfiles) { ok($rf->is_perlfile($fn), "'$fn' recognized as Perl file name."); } ok (! $rf->is_perlfile('foo.t'), "'foo.t' rejected as Perl file name."); diag "Adding .t as valid Perl extension"; my @perl_extensions = qw( .t ); my $perlfiles = $rf->perl_file_extensions(\@perl_extensions); # diag Dumper($perlfiles); ok($rf->is_perlfile('foo.t'), "'foo.t' recognized as Perl file name."); Devel-Refactor-0.05/README0100644000127700001440000000150410204576715013774 0ustar cpanusersDevel/Refactor version 0.04 ========================= The Devel::Refactor module is for code refactoring. Pass it a a snippet of Perl code that belongs in its own subroutine as well as a name for that sub. It figures out which variables need to be passed into the sub, and which variables might be passed back. It then produces the sub along with a call to the sub. Included in this module is an example script that pulls the snippet of code from the KDE clipboard in Linux and passes back the transformed code the same way. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES None. COPYRIGHT AND LICENCE Copyright (C) 2005 Scott Sotka This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Devel-Refactor-0.05/Changes0100644000127700001440000000151410216405453014401 0ustar cpanusersRevision history for Perl extension Devel::Refactor. 0.5 Thu March 17 14:47:00 PST 2005 + Fixed example/factory.pl to work with latest version of Refactor. 0.4 Sun Feb 6 18:32:44 PST 2005 + added rename_subroutine + added several tests in t/ + extract_subroutine is now a object method + added perldoc for accessor methods + refactored code and perldoc, hopefully better organized. - Removes t/1.t (replaced with t/basic.t) 0.03 Mon, 24 Jan 2005 + Added patches submitted by J Matisse Enzer and removed 'use 5.008' requirement + Also added a few cosmetic changes. 0.02 Mon Dec 22 23:08:00 2003 + Added optional syntax checking to the results of the refactoring. 0.01 Sat Dec 20 00:48:19 2003 - original version; created by h2xs 1.22 with options -XA -n Devel::Refactor Devel-Refactor-0.05/test.pl0100755000127700001440000000134110204577062014426 0ustar cpanusers#!/usr/bin/perl # # $Header: $ # ############################################################################## use strict; use FindBin qw($Bin); use lib "$Bin"; # Add the current directory to the start of @INC use Test::Harness qw( runtests $verbose ); $Test::Harness::verbose = 1; my @tests; if ($#ARGV >= 0) { while (my $testName = shift @ARGV) { $testName .= ".t" unless ($testName =~ /\.t$/); push @tests, "t/".$testName; } } else { opendir(DIR, "t") || die "can't opendir test directory t: $!"; while(defined (my $file = readdir(DIR)) ) { next unless ($file =~ /^.*?\.t$/) && (!($file =~ /^template/)); push @tests, "t/".$file; } closedir DIR; } runtests(@tests); 1; Devel-Refactor-0.05/Makefile.PL0100644000127700001440000000113310204576473015065 0ustar cpanusersuse 5.008; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Devel::Refactor', 'VERSION_FROM' => 'Refactor.pm', # finds $VERSION 'PREREQ_PM' => { 'Test::More' => '.47', }, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'Refactor.pm', # retrieve abstract from module AUTHOR => 'Scott Sotka ') : ()), ); Devel-Refactor-0.05/Refactor.pm0100644000127700001440000004475110216405551015222 0ustar cpanusers# Refactor.pm - refactor Perl code. # $Header: $ # ############################################################################### =head1 NAME Devel::Refactor - Perl extension for refactoring Perl code. =head1 VERSION $Revision: $ This is the CVS revision number. =head1 SYNOPSIS use Devel::Refactor; my $refactory = Devel::Refactor->new; my ($new_sub_call,$new_sub_code) = $refactory->extract_subroutine($sub_name, $code_snippet); my $files_to_change = $refactory->rename_subroutine('./path/to/dir', 'oldSubName','newSubName'); # $files_to_change is a hashref where keys are file names, and values are # arrays of hashes with line_number => new_text =head1 ABSTRACT Perl module that facilitates refactoring Perl code. =head1 DESCRIPTION The B module is for code refactoring. While B may be used from Perl programs, it is also designed to be used with the B plug-in for the B integrated development environment. =cut package Devel::Refactor; use strict; use warnings; use Cwd; use File::Basename; require Exporter; our @ISA = qw(Exporter); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. # This allows declaration use Dev::Refactor ':all'; # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK # will save memory. our %EXPORT_TAGS = ( 'all' => [ qw( ) ] ); our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); our @EXPORT = qw( ); our $VERSION = '0.05'; our $DEBUG = 0; # Preloaded methods go here. our %perl_file_extensions = ( '\.pl$' => 1, '\.pm$' => 1, '\.pod$' => 1, ); =head1 CLASS METHODS Just the constructor for now. =head2 new Returns a new B object. =cut # TODO: List the object properties that are initialized. sub new { my $class = shift; $DEBUG = shift; # TODO: Should these really be object properties? No harm I guess, but most # of them are for the extract_subroutine method, and so maybe they # should go in a data structure dedicated to that method? my $self = { sub_name => '', code_snippet => '', return_snippet => '', return_sub_call => '', eval_err => '', scalar_vars => {}, array_vars => {}, hash_vars => {}, local_scalars => {}, loop_scalars => {}, local_arrays => {}, local_hashes => {}, parms => [], inner_retvals => [], outer_retvals => [], perl_file_extensions => { %perl_file_extensions }, }; bless $self, $class; return $self; } =head1 PUBLIC OBJECT METHODS Call on a object returned by new(). =head2 extract_subroutine($new_name,$old_code [,$syntax_check]) Pass it a snippet of Perl code that belongs in its own subroutine as well as a name for that sub. It figures out which variables need to be passed into the sub, and which variables might be passed back. It then produces the sub along with a call to the sub. Hashes and arrays within the code snippet are converted to hashrefs and arrayrefs. If the I argument is true then a sytax check is performed on the refactored code. Example: $new_name = 'newSub'; $old_code = <<'eos'; my @results; my %hash; my $date = localtime; $hash{foo} = 'value 1'; $hash{bar} = 'value 2'; for my $loopvar (@array) { print "Checking $loopvar\n"; push @results, $hash{$loopvar} || ''; } eos ($new_sub_call,$new_code) = $refactory->extract_subroutine($new_name,$old_code); # $new_sub_call is 'my ($date, $hash, $results) = newSub (\@array);' # $new_code is # sub newSub { # my $array = shift; # # my @results; # my %hash; # my $date = localtime; # $hash{foo} = 'value 1'; # $hash{bar} = 'value 2'; # for my $loopvar (@$array) { # print "Checking $loopvar\n"; # push @results, $hash{$loopvar} || ''; # } # # # return ($date, \%hash, \@results); # } Included in the examples directory is a script for use in KDE under Linux. The script gets its code snippet from the KDE clipboard and returns the transformed code the same way. The new sub name is prompted for via STDIN. =cut sub extract_subroutine { my $self = shift; my $sub_name = shift; my $code_snippet = shift; my $syntax_check = shift; $DEBUG and print STDERR "sub name : $sub_name\n"; $DEBUG and print STDERR "snippet : $code_snippet\n"; $self->{sub_name} = $sub_name; $self->{code_snippet} = $code_snippet; $self->_parse_vars(); $self->_parse_local_vars(); $self->_transform_snippet(); if ($syntax_check) { $self->_syntax_check(); } return ( @$self{'return_sub_call','return_snippet'} ); } =head2 rename_subroutine($where,$old_name,$new_name,[$max_depth]) I is one of: path-to-file path-to-directory If I is a directory then all Perl files (default is C<.pl>, C<.pm>, and C<.pod> See the B method.) in that directory and its' descendents (to I deep,) are searched. Default for I is 0 -- just the directory itself; I of 1 means the specified directory, and it's immeadiate sub-directories; I of 2 means the specified directory, it's sub-directories, and their sub-directrories, and so forth. If you want to scan very deep, use a high number like 99. If no matches are found then returns I, otherwise: Returns a hashref that tells you which files you might want to change, and for each file gives you the line numbers and proposed new text for that line. The hashref looks like this, where I was found on two lines in the first file and on one line in the second file: { ./path/to/file1.pl => [ { 11 => "if (myClass->newName($x)) {\n" }, { 27 => "my $result = myClass->newName($foo);\n"}, ], ./path/to/file2.pm => [ { 235 => "sub newName {\n"}, ], } The keys are paths to individual files. The values are arraryrefs containing hashrefs where the keys are the line numbers where I was found and the values are the proposed new line, with I changed to I. =cut sub rename_subroutine { my $self = shift; my $where = shift; my $old_name = shift; my $new_name = shift; my $max_depth = shift || 0; # How many level to descend into directories return undef unless ($new_name and $old_name); $DEBUG and warn "Looking for $where in ", getcwd(), "\n"; my $found = {}; # hashref of file names if (-f $where){ # it's a file or filehandle $found->{$where} = $self->_scan_file_for_string ($old_name,$new_name,$where); } elsif ( -d $where ) { # it's a directory or directory handle $self->_scan_directory_for_string($old_name,$new_name,$where,$found,$max_depth); } else { # uh oh. Should we allow it to be a code snippet? die "'$where' does not appear to be a file nor a directory." } return %$found ? $found : undef; } =head2 is_perlfile($filename) Takes a filename or path and returns true if the file has one of the extensions in B, otherwise returns false. =cut sub is_perlfile { my ($self,$filename) = @_; my ($name,$path,$suffix) = fileparse($filename,keys %{$self->perl_file_extensions}); return $suffix; } =head1 OBJECT ACCESSORS These object methods return various data structures that may be stored in a B object. In some cases the method also allows setting the property, e.g. B. =cut =head2 get_new_code Returns the I object property. =cut sub get_new_code{ my $self = shift; return $self->{return_snippet}; } =head2 get_eval_results Returns the I object property. =cut sub get_eval_results{ my $self = shift; return $self->{eval_err}; } =head2 get_sub_call Returns the I object property. =cut sub get_sub_call{ my $self = shift; return $self->{return_sub_call}; } =head2 get_scalars Returns an array of the keys from I object property. =cut sub get_scalars { my $self = shift; return sort keys %{ $self->{scalar_vars} }; } =head2 get_arrays Returns an array of the keys from the I object property. =cut sub get_arrays { my $self = shift; return sort keys %{ $self->{array_vars} }; } =head2 get_hashes Returns an array of the keys from the I object property. =cut sub get_hashes { my $self = shift; return sort keys %{ $self->{hash_vars} }; } =head2 get_local_scalars Returns an array of the keys from the I object property. =cut sub get_local_scalars { my $self = shift; return sort keys %{ $self->{local_scalars} }; } =head2 get_local_arrays Returns an array of the keys from the I object property. =cut sub get_local_arrays { my $self = shift; return sort keys %{ $self->{local_arrays} }; } =head2 get_local_hashes Returns an array of the keys from the I object property. =cut sub get_local_hashes { my $self = shift; return sort keys %{ $self->{local_hashes} }; } =head2 perl_file_extensions([$arrayref|$hashref]) Returns a hashref where the keys are regular expressions that match filename extensions that we think are for Perl files. Default are C<.pl>, C<.pm>, and C<.pod> If passed a hashref then it replaces the current values for this object. The keys should be regular expressions, e.g. C<\.cgi$>. If passed an arrayref then the list of values are added as valid Perl filename extensions. The list should be filename extensions, NOT regular expressions, For example: my @additonal_filetypes = qw( .ipl .cgi ); my $new_hash = $refactory->perl_file_extensions(\@additional_filetypes); # $new_hash = { # '\.pl$' => 1, # '\.pm$' => 1, # '\.pod$' => 1, # '\.ipl$' => 1, # '\.cgi$' => 1, # '\.t$' => 1, # } =cut sub perl_file_extensions { my($self,$args) = @_; if (ref $args eq 'HASH') { $self->{perl_file_extensions} = $args; } elsif (ref $args eq 'ARRAY') { map $self->{perl_file_extensions}->{"\\$_\$"} = 1 , @$args; } return $self->{perl_file_extensions}; } =head1 TODO LIST =over 2 =item Come up with a more uniform approach to B. =item Add more refactoring features, such as I. =item Add a SEE ALSO section with URLs for eclipse/EPIC, refactoring.com, etc. =back =cut ################################################################################### ############################## Utility Methods #################################### sub _parse_vars { my $self = shift; my $var; my $hint; # find the variables while ( $self->{code_snippet} =~ /([\$\@]\w+?)(\W\W)/g ) { $var = $1; $hint = $2; if ( $hint =~ /^{/ ) { #}/ $var =~ s/\$/\%/; $self->{hash_vars}->{$var}++; } elsif ( $hint =~ /^\[>/ ) { $var =~ s/\$/\@/; $self->{array_vars}->{$var}++; } elsif ( $var =~ /^\@/ ){ $self->{array_vars}->{$var}++; } elsif ( $var =~ /^\%/ ) { $self->{hash_vars}->{$var}++; } else { $self->{scalar_vars}->{$var}++; } } } sub _parse_local_vars { my $self = shift; my $reg; my $reg2; my $reg3; # To find loops variables declared in for and foreach # figure out which are declared in the snippet foreach my $var ( keys %{ $self->{scalar_vars} } ) { $reg = "\\s*my\\s*\\$var\\s*[=;\(]"; $reg2 = "\\s*my\\s*\\(.*?\\$var.*?\\)"; $reg3 = "(?:for|foreach)\\s+my\\s*\\$var\\s*\\("; if ( $var =~ /(?:\$\d+$|\$[ab]$)/ ) { $self->{local_scalars}->{$var}++; } elsif ( $self->{code_snippet} =~ /$reg|$reg2/ ) { $self->{local_scalars}->{$var}++; # skip loop variables if ( $self->{code_snippet} =~ /$reg3/ ) { $self->{loop_scalars}->{$var}++; } } } foreach my $var ( keys %{ $self->{array_vars}} ) { $var =~ s/\$/\@/; $reg = "\\s*my\\s*\\$var\\s*[=;\(]"; $reg2 = "\\s*my\\s*\\(.*?\\$var.*?\\)"; if ( $self->{code_snippet} =~ /$reg|$reg2/ ) { $self->{local_arrays}->{$var}++; } } foreach my $var ( keys %{ $self->{hash_vars}} ) { $var =~ s/\$/\%/; $reg = "\\s*my\\s*\\$var\\s*[=;\(]"; $reg2 = "\\s*my\\s*\\(.*?\\$var.*?\\)"; if ( $self->{code_snippet} =~ /$reg|$reg2/ ) { $self->{local_hashes}->{$var}++; } } } sub _syntax_check{ my $self = shift; my $tmp; my $eval_stmt = "my (". join ', ', @{$self->{parms}}; $eval_stmt .= ");\n"; $eval_stmt .= $self->get_sub_call(); $eval_stmt .= $self->get_new_code(); $self->{eval_code} = $eval_stmt; eval " $eval_stmt "; if ($@) { $self->{eval_err} = $@; my @errs = split /\n/, $self->{eval_err}; my @tmp = split /\n/, $self->{return_snippet}; my $line; foreach my $err (@errs){ if ($err =~ /line\s(\d+)/){ $line = ($1 - 3); $tmp[$line] .= " #<--- ".$err; } } $self->{return_snippet} = join "\n", @tmp; } } sub _transform_snippet { my $self = shift; my $reg; my $reg2; my $arref; my $href; # Create a sub call that accepts all non-locally declared # vars as parameters foreach my $parm ( keys %{$self->{scalar_vars} } ) { if ( !defined( $self->{local_scalars}->{$parm} ) ) { push @{$self->{parms}}, $parm; } else { # Don't return loop variables next if grep $parm eq $_, keys %{$self->{loop_scalars}}; if ( $parm !~ /\$\d+$/ ) { push @{$self->{inner_retvals}}, $parm; push @{$self->{outer_retvals}}, $parm; } } } foreach my $parm ( keys %{ $self->{array_vars}} ) { $parm =~ s/\$/\@/; if ( !defined( $self->{local_arrays}->{$parm} ) ) { push @{$self->{parms}}, $parm; $reg2 = "\\$parm"; ($arref = $parm) =~ s/\@/\$/; $self->{code_snippet} =~ s/$reg2/\@$arref/g; $parm =~ s/\@/\$/; $reg = "\\$parm\\["; $self->{code_snippet} =~ s/$reg/$parm\-\>\[/g; } else { push @{$self->{inner_retvals}}, "\\$parm"; # \@array push @{$self->{outer_retvals}}, "$parm"; } } foreach my $parm ( keys %{ $self->{hash_vars} } ) { $parm =~ s/\$/\%/; if ( !defined( $self->{local_hashes}->{$parm} ) ) { push @{$self->{parms}}, $parm; $reg2 = "\\$parm"; ($href = $parm) =~ s/\%/\$/; $self->{code_snippet} =~ s/$reg2/\%$href/g; $parm =~ s/\%/\$/; $reg = "\\$parm\\{"; $self->{code_snippet} =~ s/$reg/$parm\-\>\{/g; } else { push @{$self->{inner_retvals}}, "\\$parm"; # \%hash push @{$self->{outer_retvals}}, "$parm"; } } my $retval; my $return_call; my $tmp; $return_call .= "my ("; $return_call .= join ', ', map {my $tmp; ($tmp = $_) =~ s/[\@\%](.*)/\$$1/; $tmp} sort @{$self->{outer_retvals}}; $return_call .= ") = ".$self->{sub_name}." ("; $return_call .= join ', ', map { ( $tmp = $_ ) =~ s/(\%|\@)(.*)/\\$1$2/; $tmp } @{$self->{parms}}; $return_call .= ");\n"; $retval = "sub ".$self->{sub_name}." {\n"; $retval .= join '', map {($tmp = $_) =~ tr/%@/$/; " my $tmp = shift;\n" } @{$self->{parms}}; $retval .= "\n" . $self->{code_snippet}; $retval .= "\n return ("; $retval .= join ', ', sort @{$self->{inner_retvals}}; $retval .= ");\n"; $retval .= "}\n"; # protect quotes and dollar signs # $retval =~ s/\"/\\"/g; # $retval =~ s/(\$)/\\$1/g; $self->{return_snippet} = $retval; $self->{return_sub_call} = $return_call; } # returns arrayref of hashrefs, or undef sub _scan_file_for_string { my $self = shift; my $old_name = shift; my $new_name = shift; my $file = shift; my $fh; open $fh, "$file" || die("Could not open code file '$file' - $!"); my $line_number = 0; my @lines; my $regex1 = '(\W)(' . $old_name . ')(\W)'; # Surrounded by non-word characters my $regex2 = "^$old_name(" . '\W)'; # At start of line while (<$fh>) { $line_number++; # Look for $old_name surrounded by non-word characters, or at start of line if (/$regex1/o or /$regex2/o) { my $new_line = $_; $new_line =~ s/$regex1/$1$new_name$3/g; $new_line =~ s/$regex2/$new_name$1/; my $hash = {$line_number => $new_line}; push @lines, $hash; } } close $fh; return @lines ? \@lines : undef; } # Scan a directory, possibly recuring into sub-directories. sub _scan_directory_for_string { my ($self,$old_name,$new_name,$where,$hash,$depth) = @_; my $dh; opendir $dh, $where || die "Could not open directory '$where': $!"; my @files = grep { $_ ne '.' and $_ ne '..' } readdir $dh; close $dh; $depth--; foreach my $file (@files) { $file = "$where/$file"; # add the directory back on to the path if (-f $file && $self->is_perlfile($file)) { $hash->{$file} = $self->_scan_file_for_string($old_name,$new_name,$file); } if (-d $file && $depth >= 0) { # It's a directory, so call this method on the directory. $self->_scan_directory_for_string($old_name,$new_name,$file,$hash,$depth); } } return $hash; } 1; # File must return true when compiled. Keep Perl happy, snuggly and warm. __END__ =head1 AUTHOR Scott Sotka, Essotka@barracudanetworks.comE =head1 COPYRIGHT AND LICENSE Copyright 2005 by Scott Sotka This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Devel-Refactor-0.05/META.yml0100644000127700001440000000052510216406241014354 0ustar cpanusers# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Devel-Refactor version: 0.05 version_from: Refactor.pm installdirs: site requires: Test::More: .47 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 Devel-Refactor-0.05/examples/0040755000127700001440000000000010216406241014722 5ustar cpanusersDevel-Refactor-0.05/examples/factory.pl0100755000127700001440000000111610216405141016723 0ustar cpanusers#!/usr/bin/perl use Data::Dumper; use Devel::Refactor; $|++; # Get the contents of the clipboard. Requires dcop from KDE. my $clipboard = `dcop klipper klipper getClipboardContents`; print "Subroutine Name? "; my $name = ; chomp $name; my $refactory = Devel::Refactor->new; my ($new_sub_call,$new_code) = $refactory->extract_subroutine($name,$clipboard); my $retval = $new_sub_call . $new_code; # protect quotes and dollar signs $retval =~ s/\"/\\"/g; $retval =~ s/(\$)/\\$1/g; #Put the results back on the clipboard. `dcop klipper klipper setClipboardContents "$retval"`; Devel-Refactor-0.05/MANIFEST0100644000127700001440000000042410204577572014247 0ustar cpanusersChanges MANIFEST Makefile.PL README Refactor.pm examples/factory.pl t/basic.t t/extract_subroutine.t t/rename_subroutine.t t/test_subdirectory/testfile_3.pod t/testfile_1.pl t/testfile_2.pm test.pl META.yml Module meta-data (added by MakeMaker)