#!/usr/bin/perl -w use strict; use warnings; use subs qw/manpage myuuid usage version where/; use File::Basename; my $backup; my $extension = 'orig'; my $fixed = 0; my $global = 0; my $multiline = 0; my $nocase = 0; my $oldargv = ''; my $regex; my @ARGS = (); # copy of commandline args my $myname = basename($0); $myname =~ s/\.\w*$//; # strip any extension # Handle command line arguments. # We need two passes; first pass handles options, # second pass handles magic <> operator. @ARGV or usage("I need some command line arguments"); ARG: while (@ARGV) { $_ = shift @ARGV; # Handle single-letter options. /^-[fghimMuvw]/ and do { /f/ and $fixed = 1; # no metacharacters. /g/ and $global = 1; # global substitutions. /i/ and $nocase = 1; # case-insensitive substitutions. /m/ and $multiline = 1; # match over multiple lines. /M/ and manpage(); /h/ and usage(); /u/ and myuuid(); /v/ and version(); /w/ and where(); next ARG; }; # Handle args that might hold spaces. /^-e(.*)/ and do { $extension = $1 || shift @ARGV; $extension =~ s/\s+//g; die "usage error\n" if length($extension) == 0; next ARG; }; /^-.*/ and do { usage("unrecognized option: $_"); }; push(@ARGS, $_); } # The user doesn't have to specify a leading dot for the # extension. Easiest fix is to strip any leading dots, # then add one. $extension =~ s/^\.\.*//g; $extension =~ s/^/./; # Restore ARGV and get the patterns. @ARGV = @ARGS; my $from = shift(@ARGV) || usage "no FROM pattern"; my $to = shift(@ARGV) || usage "no TO pattern"; @ARGV or usage("I need at least one file to change"); $from = quotemeta($from) if $fixed; # Compile "$from" into a regular expression and check # for a bad pattern. Fix compiled regular expression # if doing case-independent or multiline matching. # # $regex should hold one of the following: # (?s-xim:string-to-change) is default. # (?si-xm:string-to-change) for case-independent. # (?ms-xi:string-to-change) for multi-line. # (?msi-x:string-to-change) for multi-line and case-independent. # # We can't make the qr/.../ stuff a variable, because the eval # won't create a real regular expression, so we do it the hard way. $regex = eval { qr/$from/s } || die "$from: bad 'from' pattern\n"; if ($nocase && $multiline) { $regex =~ s/s-xim:/msi-x:/; } elsif ($nocase) { $regex =~ s/s-xim:/si-xm:/; } elsif ($multiline) { $regex =~ s/s-xim:/ms-xi:/; } # Sanity check on final pattern. # This can throw a warning about unexpected quantifiers # if we're using positional notation (i.e., $1,$2), so # we disable warnings. However, it may not catch typos. # # Notice we're using {} pairs to delimit substitution strings. # It seems to cause less problems with commands like this: # # me% cat x # (a) # # me% change '(a)' '(b)' x # 1 substitutions made # me% cat x # ((b)) # # me% mv x.orig x # me% change -f '(a)' '(b)' x # 1 substitutions made # me% cat x # (b) # # me% cat x2 # {a} # # me% change '{a}' '(b)' x2 # 1 substitutions made # me% cat x2 # (b) { no warnings; eval 's{$regex}{$to}'; die "problem with final pattern\n" if $@; } # Do substitution in each file. my $k = 0; LINE: while (<>) { if ($ARGV ne $oldargv) { if ($extension !~ /\*/) { $backup = $ARGV . $extension; } else { ($backup = $extension) =~ s/\*/$ARGV/g; } rename($ARGV, $backup); open(ARGVOUT, ">$ARGV"); select(ARGVOUT); undef $/ if $multiline; $oldargv = $ARGV; } # Do the actual replacement. # We need a second eval here to handle regular # expressions or positional variables in "$to". # # s/// returns the number of substitutions made, and # we use this to warn if the "$from" part didn't match # or the "$to" part failed due to a typo. if ($global) { eval "\$k += s{$regex}{$to}g;"; } else { eval "\$k += s{$regex}{$to};"; } } continue { print; # this prints to original filename } select(STDOUT); my $plural = ($k == 1) ? '' : "s"; warn "$k substitution$plural made\n"; exit(0); #--------------------------------------------------------------------- # Print a usage message from the comments and exit. sub usage { my ($emsg) = @_; use Pod::Usage qw(pod2usage); warn "$emsg\n" if defined $emsg; pod2usage(-verbose => 99, -sections => "NAME|SYNOPSIS|OPTIONS"); } sub manpage { use Pod::Man(); my $parser = Pod::Man->new(); open(STDOUT, "| groff -T ascii -man | gcat -s | less") || die "groff\n"; $parser->parse_from_file($0); close STDOUT || die "$myname: can't close stdout: $!\n"; $? = 1 if $? == 255; # from die exit($?); } #--------------------------------------------------------------------- # Print the UUID, current version, or source location. sub myuuid { my $UUID = $1 if q$UUID: 4831ba75-b52b-3716-b360-b83dc3e1fd5f $ =~ /UUID: (.*) /; print "$UUID\n"; exit(0); } sub version { my $VERSION = sprintf("%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/); my $DATE = $1 if q$Date: 2009/10/01 21:26:34 $ =~ /Date: (.*) /; print "$myname $VERSION $DATE\n"; exit(0); } sub where { my $SOURCE = $1 /Source: (.*) /; print "file://$HOST", "$SOURCE\n"; exit(0); } #--------------------------------------------------------------------- __END__ =head1 NAME change - make a text change in one or more files =head1 SYNOPSIS change [-e ext] [-fghimMvw] from to file [file ...] =head1 DESCRIPTION B makes a global change in one or more files, saving the original file with an extension of ".orig". It's similar to using the "-pi.bak" option to perl itself, but we need to make two passes through the argument list to allow user-supplied options. =head1 OPTIONS =over 4 =item B<-e ext> uses "ext" for the backup file extension instead of ".orig". =item B<-f> uses fixed-string patterns, no metacharacters. =item B<-g> does global substitutions; default is the first on each line. =item B<-h> Print a brief help message and exit. =item B<-i> does case-insensitive substitutions. =item B<-m> does multiple-line substitutions. =item B<-M> Print the manual page and exit. =item B<-u> Print the script UUID and exit. =item B<-v> Print the version and exit. =item B<-w> Print the source location and exit. =item B is the pattern to be changed. =item B is the new pattern. =back =head1 EXAMPLES Replace all occurrences of the pattern "foo" with the pattern "bar" in the files "a", "b", and "c". The original files are renamed with their contents unchanged: =over 4 % change -g foo bar a b c =back Change the order of letters using a perl regular expression. =over 4 % cat a abcdefghi % change '(...)def(...)' '${2}xyz${1}' a % cat a ghixyzabc =back =head1 AUTHOR Most of this was taken from the perlrun man entry. Mods by Karl Vogel Oasis Systems, Inc. =cut