Sign up to create your own snipts, or login.

Public snipts » perl The latest public perl snipts.

showing 1-20 of 38 snipts for perl
  • ∞ 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";

    copy | embed

    0 comments - tagged in  posted by absolut_todd on Feb 24, 2010 at 12:56 a.m. EST
  • ∞ 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.

    copy | embed

    0 comments - tagged in  posted by yvoictra on Jan 25, 2010 at 4:29 p.m. EST
  • ∞ 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;
}

    copy | embed

    0 comments - tagged in  posted by yvoictra on Jan 24, 2010 at 8:53 p.m. EST
  • ∞ 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;

    copy | embed

    0 comments - tagged in  posted by yvoictra on Jan 16, 2010 at 4:14 a.m. EST
  • ∞ 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";

    copy | embed

    0 comments - tagged in  posted by yvoictra on Jan 15, 2010 at 5:24 p.m. EST
  • ∞ Getting actual date in Perl 
    $DDMMYYHHMMSS = sprintf("%02d/%02d/%04d %02d:%02d:%02d", sub{($_[3],$_[4]+1,$_[5]+1900,$_[2],$_[1]),$_[0]}->(localtime(time())));

    copy | embed

    0 comments - tagged in  posted by yvoictra on Jan 14, 2010 at 6:40 p.m. EST
  • ∞ Quick Circle Area Calculator 
    #!/usr/bin/perl -w
use strict;
print "\nR = "; print "A = ", (<>**2)*3.1415, "\n\n";

    copy | embed

    0 comments - tagged in  posted by DrAlexJ on Dec 30, 2009 at 4:01 p.m. EST
  • ∞ 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);

    copy | embed

    0 comments - tagged in  posted by marcbutler on Dec 25, 2009 at 12:05 a.m. EST
  • ∞ 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

    copy | embed

    0 comments - tagged in  posted by jrguitar21 on Dec 11, 2009 at 7:45 p.m. EST
  • ∞ 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";

    copy | embed

    0 comments - tagged in  posted by DrAlexJ on Nov 01, 2009 at 12:46 p.m. EST
  • ∞ Quick Circumference Calculator 
    #!/usr/bin/perl -w
use strict;
print "\nR = "; print "C = ", <>*6.2832, "\n\n";

    copy | embed

    0 comments - tagged in  posted by DrAlexJ on Nov 01, 2009 at 12:44 p.m. EST
  • ∞ 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";
	}
}

    copy | embed

    0 comments - tagged in  posted by elaforc on Sep 28, 2009 at 9:59 a.m. EDT
  • ∞ replaces instances of "SEARCH" with "REPLACE" in files matching "*.txt" 
    perl -pi -w -e 's/SEARCH/REPLACE/g;' *.txt

    copy | embed

    0 comments - tagged in  posted by jonbiddle on Aug 14, 2009 at 3:58 p.m. EDT
  • ∞ 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’ *

    copy | embed

    0 comments - tagged in  posted by tayhimself on Aug 12, 2009 at 7:49 p.m. EDT
  • ∞ 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

    copy | embed

    0 comments - tagged in  posted by malkir on Aug 07, 2009 at 5:52 p.m. EDT
  • ∞ find file, replace foo with bar across the whole line, {} is the file name \; ends the -exec. the delimeter can be { } or | and / can be exited with \ 
    find . -name *.html -exec perl -p -i -e "s/foo/bar/g" {} \;

    copy | embed

    0 comments - tagged in  posted by malkir on Jul 02, 2009 at 12:57 a.m. EDT
  • ∞ dump structures 
    my $struct = {
    a => [ 1,2,3 ],
    b => [ 2,3,4 ],
    c => { ff => "pf", br => "mk" },
    d => { ff => "pf", br => "mk" },
};


print "\nData::Dump\n";
use Data::Dump qw/dump/;
print dump $struct;

print "\nData::Dumper\n";
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Terse  = 1;
print Dumper $struct;

print "\nDumpvalue\n";
use Dumpvalue;
my $dumper = Dumpvalue->new(hashDepth => 10, arrayDepth => 10, unctrl => 1);
$dumper->dumpValue($struct);

print "\nYAML::XS\n";
use YAML::XS;
print Dump $struct;

=head1 Output 

    Data::Dump
    {
      a => [1, 2, 3],
      b => [2, 3, 4],
      c => { br => "mk", ff => "pf" },
      d => { br => "mk", ff => "pf" },
    }
    
    Data::Dumper
    {
      'c' => {
        'br' => 'mk',
        'ff' => 'pf'
      },
      'a' => [
        1,
        2,
        3
      ],
      'b' => [
        2,
        3,
        4
      ],
      'd' => {
        'br' => 'mk',
        'ff' => 'pf'
      }
    }

    Dumpvalue
    'a' => ARRAY(0x28ab84)
       0  1
       1  2
       2  3
    'b' => ARRAY(0x28aa64)
       0  2
       1  3
       2  4
    'c' => HASH(0x19045bc)
       'br' => 'mk'
       'ff' => 'pf'
    'd' => HASH(0x190462c)
       'br' => 'mk'
       'ff' => 'pf'

    YAML::XS
    ---
    a:
    - 1
    - 2
    - 3
    b:
    - 2
    - 3
    - 4
    c:
      br: mk
      ff: pf
    d:
      br: mk
      ff: pf

=cut

    copy | embed

    0 comments - tagged in  posted by bobr123 on Jun 09, 2009 at 5:31 a.m. EDT
  • ∞ windows path item per line 
    C:\> path | perl -F/[;=]/ -ane "$,=qq{\n};shift@F;print@F"

    copy | embed

    0 comments - tagged in  posted by bobr123 on Jun 09, 2009 at 5:17 a.m. EDT
  • ∞ randomize loading of mp3 files from archive to portable device of known size 
    ##################################################################### 
### ### 
### The purpose of this script is to randomize the loading of mp3 ### 
### files from your archive to a portable device of known size ### 
### size. ie: rio or some other device which mounts as a drive. ### 
### ### 
### Specify File locations as follows: c:\temp\whatever ### 
### Would be: c:\\temp\\whatever ### 
### ### 
### taken from: http://coding.derkeiler.com/Archive/Perl/comp.lang.perl.misc/2004-09/1161.html
### Wishlist features: ### 
### 1. Save list of files into a file and process from that ### 
### file if present instead of reading the source each time. ### 
### 2. Generate playlist based on mp3 tags. ### 
### ### 
##################################################################### 
         
#################################### 
### Begin Configurable options ### 
#################################### 
$mp3_src="c:\\temp\\source"; #Source location of your MP3 Files 
$mp3_dest="c:\\temp\\mp3"; #Destination for files. ie: your 
mp3 player 
$DestSizeMB=512; #Enter destination drive size. ie: 20 = 
20MB 
#################################### 
### End Configurable options ### 
#################################### 


use File::Copy; #Define modules to use 
$Dsize=$DestSizeMB*1000*1024; #Convert the size entered to 
bytes 
&DoStatusDisplay("Space available: $Dsize"); #status 
&DoStatusDisplay("Deleting files"); #status 
&DeleteExistingMP3("$mp3_dest"); #Deleting pre-existing mp3 
files on: <$mp3_dest> 

&DoStatusDisplay("getting files"); #status 
@mp3source=&GetFilesAndSize("$mp3_src"); #build list of files and 
get their size 

&DoStatusDisplay("sorting playlist", "\n"); #status 
@mp3source=array_shuffle(@mp3source); #sort array containing mp3 
files and sizes 

$mp3source_count=@mp3source; #Number of mp3's on source 
location 
while ( 1 ) #keep going 
{ 
        $z=pop(@mp3source); #pull first file from array and 
process 
        ($size,$file)=split(/\|/,$z,3); #split array element into 
filesize & full path 
        $mp3_remaining=@mp3source; #Number of mp3 files remaining in 
array 
        if ($mp3_remaining == 0){ #Check for zero 
           last; #All array elements were exhausted, end 
processing. 
        } 
        if (($Dsize-$size)>0){ #Check for destination full 
           $Dsize=$Dsize-$size; #Decrement remaining size with 
size of current file 
           printf ("%11s\t%-30s\n",&AddCommas($size),$file); #status 
           copy("$file", "$mp3_dest") or die "copy failed: $!"; #Copy files 
from Source -> Destination 
           $i++; #Increment counter 
           } else { 
                    printf ("%11s\t$file -- skipped. File is to large for remaining 
space: %-11s\n",&AddCommas($size),&AddCommas($Dsize)); 
           } 
} 

print "\n\nMp3's Loaded: $i\n"; #status 
printf ("Bytes available: %-10s\n",&AddCommas($Dsize)); #status 
exit; #Bye-Bye! 





sub DoStatusDisplay { 
        local($message)=shift; 
        local($trailer)=shift; 
        print "Status: $message...\n$trailer"; 
} 

sub AddCommas { 
    my $text = reverse $_[0]; 
    $text =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g; 
    return scalar reverse $text; 
} 

sub DeleteExistingMP3 { 
    local($dir) = shift; 
    opendir (DIR, "$dir/"); 
    @FILES = grep(/.mp3/,readdir(DIR)); 
    closedir (DIR); 
    foreach $FILES (@FILES) { 
# print "Deleting: $dir/$FILES\n"; 
                        unlink("$dir/$FILES") or die "Can't delete $FILENAME: $!\n"; 
    } 
} 

sub array_shuffle { 
    my @old = @_; #Assign local array and set to 
value of subrountine inputs 
    srand; #no idea 
    @new = (); #creat new array 
    for( @old ){ #process all elements 
        my $r = rand @new+1; #no idea 
        push(@new,$new[$r]); 
        $new[$r] = $_; 
    } 
        return @new; #Return sorted array to calling function 
} 

sub GetFilesAndSize { 
        local($dir) = shift; #assign subroutine inputs to 
local variable 
    local($path); #local variable 
            unless (opendir(DIR, $dir)) { #Check status of directory 
        warn "Can't open $dir\n"; 
        closedir(DIR); #close filehandle 
        return; 
    } 
    foreach (readdir(DIR)) { #process all contents in 
directory 
        next if $_ eq '.' || $_ eq '..'; #Skip . & .. 
        $path = "$dir/$_"; #Concatenate file and path 
to get full path 
        if ((-d $path) && (! -l $path)) { #Non-symlink dir, 
enter it 
            &GetFilesAndSize($path); #Get it recursively 
        } elsif ((-f _) && (! -l $path)) { #Plain file, but not a 
symlink 
            $size = -s $path; #Get the size in bytes 
                        $ksize = $size / 1000; #Convert to kilobytes 
                        push(@temp_array,"$size|$path"); #Load current element onto 
array 
                } 
    } closedir(DIR); #Be a good boy and clean up after 
yourself 
        return @temp_array; #Return loaded array to calling function 
}

    copy | embed

    0 comments - tagged in  posted by calvinhi on Jun 02, 2009 at 2:08 p.m. EDT
  • ∞ Installing Perl Module on Solaris 
    /usr/perl5/bin/perlgcc Makefile.PL
/usr/sfw/bin/gmake
/usr/sfw/bin/gmake test
/usr/sfw/bin/gmake install

    copy | embed

    0 comments - tagged in  posted by winker on May 13, 2009 at 5:10 a.m. EDT
Sign up to create your own snipts, or login.