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.