Latest 100 public
snipts » perl
showing 1-20 of 43 snipts for perl
-
∞ Converts windows line ending to Unix/Linux line ending
perl -pi -e 's/\r\n/\n/g' <input-file> -
∞ Perl to get html form input values
#!/usr/bin/perl my @values; foreach my $file (@ARGV) { open(FILE, $file) || die "can't open file"; while( defined($line = <FILE>)) { chomp $line; if ($line =~ m/<input/) { $line =~ m/name=["'](\w*)["']/; push @values, $1; } elsif ($line =~ m/<select/) { $line =~ m/name=["'](\w*)["']/; push @values, $1; } elsif ($line =~ m/<textarea/) { $line =~ m/name=["'](\w*)["']/; push @values, $1; } } my $elems = join ", ", @values; print "$elems\n"; # foreach my $elem (@values){ # print "$elem\n"; # } }
-
∞ Print a random element in an Array
#!/usr/bin/perl use strict; # Declare an Array my @coins = ("Quarter","Dime","Nickel"); # Print a random element print $coins[rand @coins];
-
∞ uncompress css stylesheet
# quick one-liner to uncompress a stylesheet that has been # compressed down to one line. This will add the newlines back. perl -pi -e "s/\}/\}\n/g" *.css
-
∞ directory tree traversal without File::Find
# this script takes an optional command-line argument, which is the directory to start in # if no argument is passed, it starts in the current directory # as is, the script simply prints the path for each plain file in the tree # a comment indicates where code should be added to execute some action on each file # $startDir = $ARGV[0] or '.'; traverse($startDir); sub traverse { local($dir) = shift; local($path); unless (opendir(DIR, $dir)) { warn "Can't open $dir\n"; closedir(DIR); return; } foreach (readdir(DIR)) { next if $_ eq '.' || $_ eq '..'; $path = "$dir/$_"; if (-d $path) { # a directory traverse($path); } elsif (-f $path) { # a plain file print "$path\n"; # add code here to execute some action on the file } } closedir(DIR); }
-
∞ How to pull values out of closures
use strict; use warnings; use PadWalker qw(closed_over); sub gen { my $var = shift; return sub { my $a = $var; $a *= 2; return $a }; } my $closed_sub = gen(123); print $closed_sub->() . "\n"; my $closed_value = ${closed_over($closed_sub)->{'$var'}}; print $closed_value . "\n";
-
∞ Converting from date to epoch time
#!/usr/bin/perl use Time::Local $time = timelocal($sec,$min,$hour,$mday,$mon,$year); $time = timegm($sec,$min,$hour,$mday,$mon,$year); # Allowed range values # * day of the month: 1..31 # * month: 0..11 (0 = January, 1 = February, etc) # * year: # o If value>999: the value is interpreted as the actual year # o If value is 100..999: the value is interpreted as an offset #from 1900 (for example, 199 is considered year 2099) # o If value is 0..99: the value is interpreted based on the current year: if the current year is in the second half of the century #(for example 1970), then the values in the range 50..99 are considered of be in the current century and the values in the range 0..49 are in the next century. If the current year is in the first half of the century (for example 2007), then the range 0..49 is interpreted as values in the current century and the range 50..99 is interpreted as years from the #previous century.
-
∞ Perl trim function to strip whitespace from a string
#!/usr/bin/perl # Declare the subroutines sub trim($); sub ltrim($); sub rtrim($); # Create a test string my $string = " \t Hello world! "; # Here is how to output the trimmed text "Hello world!" print trim($string)."\n"; print ltrim($string)."\n"; print rtrim($string)."\n"; # Perl trim function to remove whitespace from the start and end of the string sub trim($) { my $string = shift; $string =~ s/^\s+//; $string =~ s/\s+$//; return $string; } # Left trim function to remove leading whitespace sub ltrim($) { my $string = shift; $string =~ s/^\s+//; return $string; } # Right trim function to remove trailing whitespace sub rtrim($) { my $string = shift; $string =~ s/\s+$//; return $string; }
-
∞ Perl API to generate a Log
package uLog; use strict; use POSIX qw(uname strftime); use IO::File; # Next path is the place where MainConfig.pm is defined use lib '/aplicaciones/plataforma/spread/smsc'; use MainConfig; use constant TRUE => 1; use constant FALSE => 0; eval "use Time::HiRes qw(gettimeofday)"; my $HAS_TIME_HIRES = not $@; my $NODATAFIELD = "-"; my $DATEFORMAT = "%F.%H:%m:%S.%Q"; my $CFG = $MainConfig::CFG; my $DIRORDER = [ "$CFG->{paths}->{service_path}/logs/", "./logs/", "/tmp/" ]; my $hrefLevels = { FAT => 1, ERR => 2, WAR => 3, INF => 4, DEB => 5, VER => 6 }; my $_LOGGER; sub _new { my ($args) = @_; my (undef, $sHostname, undef, undef, undef) = uname(); my $self = { _sLogFile => $NODATAFIELD, _iLogLevel => $hrefLevels->{INF}, _sTicket => $NODATAFIELD, _sUser => $ENV{USER} || $< || $NODATAFIELD, _sService => $NODATAFIELD, _sMachine => $sHostname || $NODATAFIELD, _LOG_FH => undef, _iCounter => 0, _iDelta => undef, _iPID => $$, _sModule => $NODATAFIELD }; bless $self, 'uLog'; $self->_init( $args ); $_LOGGER = $self; return $self; } sub getLogger { my ($args) = @_; return ($_LOGGER ? $_LOGGER : uLog::_new ( $args )); } sub _init { my ($self, $args) = @_; my ($sApp) = ($0 =~ /.*\/(.*)/); foreach my $sKey ( keys %{ $args }) { my $sValue = $args->{ $sKey }; if ($sValue) { if ($sKey eq "level") { $self->{_iLogLevel} = $hrefLevels->{ $sValue } if ( $hrefLevels->{ $sValue } ); } elsif ($sKey eq "service") { $self->{_sService} = $sValue; } elsif ($sKey eq "ticket") { $self->{_sTicket} = $sValue; } elsif ($sKey eq "module") { $self->{_sModule} = $sValue; } } } my $sFileName = ($self->{_sService} eq $NODATAFIELD ? $sApp : $self->{_sService}); $sFileName .= ($self->{_sModule} eq $NODATAFIELD ? "" : "_" . $self->{_sModule}) . ".log"; foreach my $sDir (@{ $DIRORDER }) { if (-w $sDir) { $self->{_sLogFile} = $sDir . $sFileName; last; } } } sub _open { my $self = shift; $self->{ _LOG_FH } = new IO::File ">> " . $self->{_sLogFile} if ( $self->{_sLogFile} ); $self->{ _LOG_FH }->autoflush( 1 ); } sub _getLine { my $iCallerLevel = 2; my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask) = caller($iCallerLevel); $filename =~ s/^.*\///g; return $filename . ":" . $line; } sub _round { my $iVal = shift; my $iInt = int $iVal; return $iVal - $iInt >= 0.5 ? $iInt + 1 : $iInt; } sub _log { my ($self, $sType, $sMsg, $iCode) = @_; return if ($hrefLevels->{ $sType } > $self->{_iLogLevel}); my $iEpochSeconds = time(); my $iEpochMilliseconds = 0; if ($HAS_TIME_HIRES) { ($iEpochSeconds, $iEpochMilliseconds) = Time::HiRes::gettimeofday(); $iEpochMilliseconds = _round($iEpochMilliseconds / 1000 ); } unless ($self->{_iDelta}) { $self->{_iDelta} = $iEpochSeconds + ($iEpochMilliseconds /1000); } $self->_open unless($self->{ _LOG_FH } && -w $self->{_sLogFile}); return unless $self->{ _LOG_FH }; my $tmp = $self->{ _LOG_FH }; $sMsg =~ s/\n/\\n/gsi; (my $sTmpformat = $DATEFORMAT) =~ s/\%Q/$iEpochMilliseconds/g; my $sDelta = sprintf("%.3f", ($iEpochSeconds + ($iEpochMilliseconds /1000)) - $self->{_iDelta}); $sTmpformat =~ s/\%q/$sDelta/g; (my $seg, my $min, my $hora, my $dia, my $mes, my $anho, my @zape) = localtime(time); $mes++; $anho+=1900; my $fecha = sprintf("%04d/%02d/%02d %02d:%02d:%02d", $anho, $mes, $dia, $hora, $min, $seg); print $tmp sprintf("[%s] %s %s:%s:%s:%s:%s %s\n", $fecha, $sType, $self->{_sService}, $self->{_sModule}, $self->{_sMachine}, $self->{_sUser}, _getLine(), #$self->{_sTicket}, #$self->{_iCounter}, #$iCode || 0, $sMsg); $self->{_iCounter}++; } sub DESTROY { my $self = shift; undef $self->{ _LOG_FH } if ($self->{ _LOG_FH }); } sub ResetDelta { my ( $self ) = @_; $self->{_iDelta} = 0; } sub LOG { my ( $self, $sType, $sMsg, $iCode ) = @_; $self->_log($sType, $sMsg, $iCode) if (defined $hrefLevels->{ $sType }); } sub FAT { my ( $self, $sMsg, $iCode ) = @_; $self->_log("FAT", $sMsg, $iCode); } sub ERR { my ( $self, $sMsg, $iCode ) = @_; $self->_log("ERR", $sMsg, $iCode); } sub WAR { my ( $self, $sMsg, $iCode ) = @_; $self->_log("WAR", $sMsg, $iCode); } sub INF { my ( $self, $sMsg, $iCode ) = @_; $self->_log("INF", $sMsg, $iCode); } sub DEB { my ( $self, $sMsg, $iCode ) = @_; $self->_log("DEB", $sMsg, $iCode); } sub VER { my ( $self, $sMsg, $iCode ) = @_; $self->_log("VER", $sMsg, $iCode); } 1;
-
∞ Calculate Process Duration in Perl
#!/usr/bin/perl use Time::HiRes qw(gettimeofday tv_interval); my $start_time = [gettimeofday]; for(my $i=0;$i<1000000;$i++) { my $cool = 1; } my $total_time = tv_interval($start_time); print "Process time: $total_time seconds\n";
-
∞ Getting actual date in Perl
$DDMMYYHHMMSS = sprintf("%02d/%02d/%04d %02d:%02d:%02d", sub{($_[3],$_[4]+1,$_[5]+1900,$_[2],$_[1]),$_[0]}->(localtime(time())));
-
∞ Quick Circle Area Calculator
#!/usr/bin/perl -w use strict; print "\nR = "; print "A = ", (<>**2)*3.1415, "\n\n";
-
∞ Generate a generic GNU makefile for the current directory.
#!/usr/bin/perl -w # generate a gnu makefile in the current dir. die "Makefile already exists!\n" if (-f 'Makefile'); my $target = shift(@ARGV) or die "No target name!\n"; my @src = grep /\.cc?$|\.cpp$|\.cxx$/, <*>; die "No source files!\n" if (!@src); @src = sort(@src); my @exts = map { m/\.(.*)$/; $1; } @src; my $prev_ext = $exts[0]; for (@exts) { die "Mixed in extensions in source files!\n" if ($_ ne $prev_ext); } # choose between c and c++ based on file extensions. if it is not c, # then assume it is c++ if ($exts[0] eq "c") { $comp_mac = "CC"; $comp_flags_mac = "CFLAGS"; $comp = "gcc"; } else { $comp_mac = "CXX"; $comp_flags_mac = "CXXFLAGS"; $comp = "g++"; } # write out the makefile... local *F; open(F, ">Makefile") or die "Can't open Makefile: $!"; select(F); print<<MF; EXE = $target SRC = @src OBJ = \$(patsubst %.${exts[0]}, %.o, \$(SRC)) DEP = \$(patsubst %.${exts[0]}, .%.d, \$(SRC)) $comp_mac = $comp $comp_flags_mac = -g -Wall LDFLAGS = .%.d : %.${exts[0]} \t\$\($comp_mac\) -MM \$< > \$@ \$(EXE): \$(OBJ) \t\$\($comp_mac\) \$(LDFLAGS) -o \$(EXE) \$(OBJ) -include \$(DEP) .PHONY: clean distclean clean: \t-\$(RM) \$(EXE) \t-\$(RM) \$(OBJ) distclean: clean \t-\$(RM) \$(DEP) \t-\$(RM) *~ \t-\$(RM) core MF close(F); exit(0);
-
∞ update drupal from subversion tags
# Update a Drupal minor revision using a patch file. # Creating a patch file between cvs tags on the server proved to be # impossible. I've found a way to do this with a subversion mirror # of Drupal core. cd ~/path/to/local/drupal # What is current version of Drupal? cat CHANGELOG.txt | grep Drupal | head -1 ## Drupal 6.13, 2009-07-01 # I'm using a Subversion mirror of Drupal core to create the patch. # (Thanks to the guys at subversible.com!) svn diff http://subversible.com/svn/drupal/tags/DRUPAL-6-13 \ http://subversible.com/svn/drupal/tags/DRUPAL-6-14 > d6-14.patch # The local version of drupal was created from a tarball, and the date # format inside the $Id$ (from CVS) is: YYYY/mm/dd HH:MM:SS, but in the # subversion patch it was YYYY-mm-dd HH:MM:SS. So I had to this quick # find/replace in order to get the patch to apply cleanly. perl -pi -e 's/(\d{4})-(\d{2})-(\d{2})\s(\d{2})/\1\/\2\/\3 \4/g' d6-14.patch # Check to see if you have any outstanding uncommitted local changes. If # there are some changes then execute the commit (commented out below). svn status #svn commit -m "latest changes prior to drupal core update" # Apply the patch. The patch from svn diff command should be in # unified diff format (-u) and the paths should be taken as they are so # files in subfolders are matched (-p0). patch -p0 -u <d6-14.patch #dont forget to commit the updates... svn commit -m "updated core drupal" #optionally, tag the updated code in the repository
-
∞ Number Set Calculator
#!/usr/bin/perl -w use strict; # header print "||--- Number Set Calculator\n\n"; # input my @set = ( ); if (@ARGV){ open(DAT, $ARGV[0]) or die "Error: $!"; @set = split(/ /, <DAT>); close(DAT) or die "Error: $!"; # input for file } else { print "* Input numbers separated by spaces: "; @set = split(/ /, <>); # manual } # print sorted array sub nmc { $a <=> $b; } chomp(@set = sort nmc @set); print "\n||--- Sorted Set: (", join(", ",@set), ")\n"; # print total & average my $ttl = 0; ($ttl += $_) for @set; print "||--- Total: ", $ttl, "\n"; print "||--- Average: ", $ttl/@set, "\n"; # print median (grep(/.5/i,@set/2)) ? print "||--- Median: ", $set[@set/2-.5], "\n" : # if odd print "||--- Median: ", ($set[@set/2-1] + $set[@set/2])/2, "\n"; # if even # print min / max, & range print "||--- Min => Max: (", $set[0], " => ", $set[-1], ")\n"; print "||--- Range: ", $set[-1] - $set[0], "\n\n";
-
∞ Quick Circumference Calculator
#!/usr/bin/perl -w use strict; print "\nR = "; print "C = ", <>*6.2832, "\n\n";
-
∞ Purge Directory
use strict; # This file is used to remove old log files from the given directories. # The syntax of the file is # perl purgeMigrationDirectory.pl DirectoryName NumberOfDaysToPurge # # This will remove all old log files that are older than ARGV[1] days old # Old log files include any text file with _error.txt _log.txt _export.xml _audit.txt # It will not remove any other folders or files if(($#ARGV + 1) == 2){ &startThePurge($ARGV[0], $ARGV[1]); } else{ &printHelp(); } #print help message to the console if the correct number of arguments are not supplied sub printHelp{ print "You must provide the full path of the directory you wish to " . "purge of old migration log files and the number of days back you wish to purge.\nExample:\n\n" . "perl purgeMigrationDirectory.pl 'C:\\ICC Migration Tool\\InformaticaOutputDir' 60 would purge the directory of any of the log files that are older than 60 days.\n\n" . "See the script for more details."; } #purge migration log files sub startThePurge{ #check to see if the directory exists if (-d @_[0]){ my $inputDir = shift; my $numFilesRemoved = 0; my $numDays = shift; print "Removing old migration files from " . $inputDir . " that are older than " . localtime(time() - 60*60*24*$numDays) ."\n"; #open input directory opendir(DIR, $inputDir); #only look at files with the following appends #_error.txt #_log.txt #_audit.txt #_export.xml #_query.txt #_cntl.txt foreach my $file (grep { /_(error.txt|log.txt|audit.txt|query.txt|cntl.txt|export.xml)$/} readdir DIR) { my $tempdm = (stat $inputDir . "\\" . $file)[9]; my $age = int(-M $inputDir . "\\" . $file); if($age >= $numDays){ #remove files older than two months print "Removing file " . $file . " because it was last modified on " . localtime($tempdm) . " days old.\n"; unlink($inputDir . "\\" . $file); #remove file $numFilesRemoved = $numFilesRemoved + 1; } } print "Removed " . $numFilesRemoved . " files from " . $inputDir . "\n"; } #directory does not exist else{ print STDERR @_[0] . " does not exist. Please try again"; } }
-
∞ replaces instances of "SEARCH" with "REPLACE" in files matching "*.txt"
perl -pi -w -e 's/SEARCH/REPLACE/g;' *.txt -
∞ Perl recursive replace
#Perl provides a really nice one-line for this kind of thing: perl -p -i -e ’s///g’ * #It also provides the option of creating a backup of each file changed: perl -p -i.bak -e ’s///g’ *
-
∞ replace specific line within a script
perl -p -i -e 's/nfs\/cl0[0-9]\/h[0-9][0-9]\/mnt/home/g' lame.php sed 's:/nfs/cl[0-9][0-9]/h[0-9][0-9]/mnt:/home:g' lame.php


