SYNOPSIS:
my $a={};
ref_push $a->{ARRAY}, "some", "list";

sub ref_push{$_[0]?push@{+shift},@_:shift@{$_[0]=[@_]}}
[download]

Take the following definitions.

use strict; 
my %npart; sub cntpart1 { my($n, $m) = @_; $n = 0+$n; $m = 0+$m; my $c
+ = \$npart{$n." ".$m}; defined($$c) and return $$c; $n <= 0 and retur
+n $$c = 1; my $s = 0; for my $k (1 .. ($m < $n ? $m : $n)) { $s += cn
+tpart1($n - $k, $k); } $$c = $s; } 
sub randpart1 { my($n, $m) = @_; $n <= 0 and return; my($s, $k) = 0; f
+or my $j (1 .. ($m < $n ? $m : $n)) { my $p = cntpart1($n - $j, $j); 
+rand($s += $p) < $p and $k = $j; } $k, randpart1($n - $k, $k); } 
sub randpart { my($n) = @_; randpart1($n, $n); }
[download]

Then randpart($n) generates a random partition with uniform probablity among all partitions of the positive integer $n.

Update: You may want to add a no warnings "recursion";

perl -e "print sprintf('%03b',$_).' '.int(rand()+0.5).$/ for 0..7"
[download]

$weekNum = POSIX::strftime("%V", gmtime time);
[download]

Using Date::Manip:

$weekNum = UnixDate(ParseDate("today"), "%W");
[download]

# Returns the week number of NOW
sub currentWeekNumber
{
  # Get current year, day of year (0..364/5) day of week (0..6)
  my ($year, $dayOfWeek, $dayOfYear) = (gmtime time)[5,6,7];
  # Adjust DayOfWeek from American 0==Sunday, to ISO 0==Monday
  # and year from "since 1900" to the real year
  return weekNumber(($dayOfWeek + 6) % 7, $dayOfYear, $year + 1900);
}

# Returns the week number of the specified time
# Year is the real year
# Day of week is 0..6 where 0==Monday
# Day of year is 0..364 (or 365) where 0==Jan1
sub weekNumber
{
  # Get parameters
  my ($dayOfWeek, $dayOfYear, $year) = @_;

  die if ($dayOfWeek < 0);
  die if ($dayOfWeek > 6);
  die if ($dayOfYear < 0);
  die if ($dayOfYear >= 366);
  die if ($year < 0);

  # Locate the nearest Thursday
  # (Done by locating the Monday at or before and going forwards 3 day
+s)
  my $dayOfNearestThurs = $dayOfYear - $dayOfWeek + 3;
  
  # Is nearest thursday in last year or next year?
  if ($dayOfNearestThurs < 0)
  {
    # Nearest Thurs is last year
    # We are at the start of the year
    # Adjust by the number of days in LAST year
    $dayOfNearestThurs += daysInYear($year-1);
  }
  my $daysInThisYear = daysInYear($year);
  if ($dayOfNearestThurs > $daysInThisYear)
  {
    # Nearest Thurs is next year
    # We are at the end of the year
    # Adjust by the number of days in THIS year
    $dayOfNearestThurs -= $daysInThisYear;
  }
  
  # Which week does the Thurs fall into?
  my $weekNum = int ($dayOfNearestThurs / 7);
  
  # Week numbering starts with 1
  $weekNum += 1;
   
  # Pad with 0s to force 2 digit representation
  return substr "0"x2 . $weekNum, -2;
}

# Returns the number of...
sub daysInYear
{
  return 366 unless $_[0] % 400;
  return 365 unless $_[0] % 100;
  return 366 unless $_[0] % 4;
  return 365;
}
[download]

use Hook::LexWrap;
use File::Copy::Recursive qw(dircopy);
use strict;
use vars qw($dir_from $dir_to);
$dir_from = "/tmp/from";
$dir_to = "/tmp/to";

$|=1;

# Using Hook::LexWrap
my @dirs;
wrap *File::Copy::Recursive::copy,
    pre => sub { @dirs = @_ },
    post => sub { printf "copying %s to %s. \r", @dirs };

dircopy($dir_from, $dir_to);
print "\n";
[download]

use File::Copy::Recursive qw(dircopy);
use strict;
use vars qw($dir_from $dir_to *mycopy);
$dir_from = "/tmp/from";
$dir_to = "/tmp/to";

sub mycopy_func {
    # call the original
    &mycopy(@_);

    # call my sub after
    mycopy_showprogress(@_); 
}

sub mycopy_showprogress {
    # this could call anything to show progress or even
    # to operate on the file being copied
    printf "copying %s to %s. \r",@_;
}

$|=1;

# Add the hook
*mycopy = *File::Copy::Recursive::copy;
*File::Copy::Recursive::copy = *mycopy_func;

dircopy($dir_from, $dir_to);
print "\n";
[download]

#Convert Gnome2::Canvas::Pixbuf To Image::Magick Array
sub convert_gnome2pixbuf_im {
    my $pixbuf_g = shift;
    print $pixbuf_g , "\n";
    #Convert Gnome2::Canvas::Pixbuf To Gtk2::Gdk::Pixbuf
    my $pixbuf = $pixbuf_g->get('pixbuf');
    print $pixbuf , "\n";
    #Convert Gtk2::Gdk::Pixbuf To BLOb
    my $blob = $pixbuf->save_to_buffer('jpeg');
    my $im = Image::Magick->new;
    #Convert BLOb to Image::Magick Array
    $im->BlobToImage($blob);
    return $im
}
[download]

#!/usr/bin/perl -w

use strict;

use WWW::Mechanize;
use DateTime;

my @urls = (
          "http://mysite.net",
          "http://myothersite.org"
);

# Command to execute the webrestart shell script
my $fcgi_restart = "./webrestart";

# Command to restart Lighttpd (may vary by distro)
my $lighttpd_restart = "/etc/init.d/lighttpd restart";

# Set the current date and time for the log file using DateTime from C
+PAN
my $date_time = DateTime->now;

# Set path to the log file you want to use
my $log = '/path/to/log.txt';

# Loop through each of your sites
foreach my $site (@urls) {
     # Get the Status using WWW::Mechanize from CPAN
     my $mech = WWW::Mechanize->new();
     $mech->get( $site );
     my $status = $mech->status($site);
 
     # If there is a server error, we will restart all the FastCGI pro
+cesses.
     if ($status == '500') {
          system $fcgi_restart;
          # Log this site failed and when
          open(DAT,">>$log") || die("Cannot Open File");
          print DAT "$site || $status || $date_time \n";
          close DAT;
     }
     # If the site was not found, we will restart Lighttpd.
     elsif ($status == '404') {
          system $lighttpd_restart;
     }
}
# Log that the sites were checked and when
open(DAT,">>$log") || die("Cannot Open File");
print DAT "Sites checked $date_time \n";
close DAT;
[download]

# Thanks Russell Jurney <rjurney (at) lucision.com>
pkill -f fcgi

pkill -f fcgi-pm

pkill -9 -f fcgi

pkill -9 -f fcgi-pm

/path/to/mysite.net/fastcgi.pl -l /tmp/mysite.socket -n 3 -d

/path/to/myothersite.com/fastcgi.pl -l /tmp/mysite.socket -n 3 -d
[download]

$/="";$l=length($w=<>);map{print+chop}sort+map{substr"$w\0$w",$_,$l+1}
+0..$l

push@w,split//for<>;map{@_=sort@_;$_[$_]=$w[$_].$_[$_]for+0..$#w}0..$#
+w;print+grep{s/\0$//}@_
[download]

#!/usr/bin/perl -w
# Created by Ben Okopnik on Mon Mar 24 23:35:26 EDT 2008
# Regex Explorer

use strict qw/vars/;
use Term::ReadLine;
my $term = new Term::ReadLine 'Regex Explorer';
my $OUT = $term -> OUT || \*STDOUT;

print $OUT "Exit by entering an empty string at any prompt.\n\n";

{
    my $string = $term->readline("String: ");
    exit if $string =~ /^$/i;
    my $regex = $term->readline("Regex: ");
    exit if $regex =~ /^$/i;
    if ($regex !~ /^\s*((?:y|tr|s|m)\W|\/)/){
        print $OUT "The regex must be a valid match or a substitute ex
+pression.\n\n";
        redo;
    }
    my $tr = $regex =~ /^\s*(?:y|tr)\W/ ? 1 : 0;
    my $cap = $regex =~ /\([^?]/ ? 1 : 0;

    # This eval should fail on anything except a match, subst, or tr
    my $old_string = $string;
    eval "\$string =~ $regex";
    if ($@){
        print $OUT "$@\n\n";
        redo;
    }
    # Restore original after this eval
    $string = $old_string;

    # Variables declared in the eval must be escaped; those that aren'
+t
    # will be interpreted in the scope of the surrounding script.
    my $ret = eval qq%
        my \$match = \$string =~ $regex;
        my \$out = 'Matched: ' . (\$match ? "Yes" : "No");
        if (\@+ > 1 && ! $tr && $cap){
            \$out .= "\nCaptures:";
            \$out .= qq" [#\$_: '" . (\${\$_} || '') . "']" for 1 .. \
+$#+;
        }
        return "\$out\n";
        %;                      # End of eval

    print $OUT $@ ? "\nERROR: $@\n" : "\nResult: $string\n$ret\n";
    redo;
}
[download]

    use perltugues;
    
    inteiro: i, j;
    texto: k;
    inteiro: l;
    
    para i (de 1 a 100 a cada 5) {
       escreva i, quebra de linha;
       k = "lalala";
       escreva k, quebra de linha;
       escreva j, quebra de linha;
    }
    
    enquanto(i >= j){
       escreva 'i e j => ', i, " >= ", j++, quebra de linha;
    }
    
    escreva quebra de linha; 
    
    escreva de 0 a 50 a cada 10, quebra de linha;
[download]