/usr/share/perl5/Devel/Refactor.pm is in libdevel-refactor-perl 0.05-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 | # 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<Devel::Refactor> module is for code refactoring.
While B<Devel::Refactor> may be used from Perl programs, it is also designed to be
used with the B<EPIC> plug-in for the B<eclipse> 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<Devel::Refactor> 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<syntax_check> 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<where> is one of:
path-to-file
path-to-directory
If I<where> is a directory then all Perl files (default is C<.pl>, C<.pm>,
and C<.pod> See the B<perl_file_extensions> method.) in that directory and its'
descendents (to I<max_depth> deep,) are searched.
Default for I<max_depth> is 0 -- just the directory itself;
I<max_depth> of 1 means the specified directory, and it's
immeadiate sub-directories; I<max_depth> 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<undef>, 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<old_name>
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<old_name>
was found and the values are the proposed
new line, with I<old_name> changed to I<new_name>.
=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<perl_file_extensions>, 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<Devel::Refactor> object. In some cases the method also allows
setting the property, e.g. B<perl_file_extensions>.
=cut
=head2 get_new_code
Returns the I<return_snippet> object property.
=cut
sub get_new_code{
my $self = shift;
return $self->{return_snippet};
}
=head2 get_eval_results
Returns the I<eval_err> object property.
=cut
sub get_eval_results{
my $self = shift;
return $self->{eval_err};
}
=head2 get_sub_call
Returns the I<return_sub_call> 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<scalar_vars> 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<array_vars> 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<hash_vars> 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<local_scalars> 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<local_arrays> 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<local_hashes> 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<ACCESSORS>.
=item Add more refactoring features, such as I<add_parameter>.
=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, E<lt>ssotka@barracudanetworks.comE<gt>
=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
|