Handling both dots and commas as valid decimal separators


    #!/usr/bin/perl -wT

use strict;
use warnings;
use Test::More tests => 20;

ok(&parse_decimal("1,234,567") == 1234567);
ok(&parse_decimal("1,234567") == 1.234567);
ok(&parse_decimal("1.234.567") == 1234567);
ok(&parse_decimal("1.234567") == 1.234567);
ok(&parse_decimal("12,345") == 12345);
ok(&parse_decimal("12,345,678") == 12345678);
ok(&parse_decimal("12,345.67") == 12345.67);
ok(&parse_decimal("12,34567") == 12.34567);
ok(&parse_decimal("12.34") == 12.34);
ok(&parse_decimal("12.345") == 12345);
ok(&parse_decimal("12.345,67") == 12345.67);
ok(&parse_decimal("12.345.678") == 12345678);
ok(&parse_decimal("12.34567") == 12.34567);
ok(&parse_decimal("123,4567") == 123.4567);
ok(&parse_decimal("123.4567") == 123.4567);
ok(&parse_decimal("1234,567") == 1234.567);
ok(&parse_decimal("1234.567") == 1234.567);
ok(&parse_decimal("12345") == 12345);
ok(&parse_decimal("12345,67") == 12345.67);
ok(&parse_decimal("1234567") == 1234567);

sub parse_decimal($) {
    my $input = shift;
    $input =~ s/[^\d,\.]//g;
    if ($input !~ /[,\.]/) {
        return &parse_with_separators($input, '.', ',');
    } elsif ($input =~ /\d,\d+\.\d/) {
        return &parse_with_separators($input, '.', ',');
    } elsif ($input =~ /\d\.\d+,\d/) {
        return &parse_with_separators($input, ',', '.');
    } elsif ($input =~ /\d\.\d+\.\d/) {
        return &parse_with_separators($input, ',', '.');
    } elsif ($input =~ /\d,\d+,\d/) {
        return &parse_with_separators($input, '.', ',');
    } elsif ($input =~ /\d{4},\d/) {
        return &parse_with_separators($input, ',', '.');
    } elsif ($input =~ /\d{4}\.\d/) {
        return &parse_with_separators($input, '.', ',');
    } elsif ($input =~ /\d,\d{3}$/) {
        return &parse_with_separators($input, '.', ',');
    } elsif ($input =~ /\d\.\d{3}$/) {
        return &parse_with_separators($input, ',', '.');
    } elsif ($input =~ /\d,\d/) {
        return &parse_with_separators($input, ',', '.');
    } elsif ($input =~ /\d\.\d/) {
        return &parse_with_separators($input, '.', ',');
    } else {
        return &parse_with_separators($input, '.', ',');
    }
}

sub parse_with_separators($$$) {
    my $input = shift;
    my $decimal_separator = shift;
    my $thousand_separator = shift;
    my $output = $input;
    $output =~ s/\Q${thousand_separator}\E//g;
    $output =~ s/\Q${decimal_separator}\E/./g;
    return $output;
}
    I'm trying to create a method that provides "best effort" parsing of decimal inputs in cases where I do not know which of these two mutually exclusive ways of writing numbers the end-user is using:

    * "." as thousands separator and "," as decimal separator
    * "," as thousands separator and "." as decimal separator

The method is implemented as parse_decimal(..) in the code below. Furthermore, I've defined 20 test cases that show how the heuristics of the method should work.

While the code below passes the tests it is quite horrible and unreadable. I'm sure there is a more compact and readable way to implement the method. Possibly including smarter use of regexpes.
    2009-09-28T15:26:59+00:00
    1053
    Perl
    handling-both-dots-and-commas-as-valid-decimal-separators
    9
    Handling both dots and commas as valid decimal separators
    
    2010-01-25T16:35:05+00:00
    1730
    
      1730
      http://knorv.myopenid.com
      knorv.myopenid.com
      0.0
      0


    #!/usr/bin/perl

use warnings;
use strict;

my $correct_usage = $ARGV[1];

my $option = $ARGV[0];
my $message = $ARGV[1];

$correct_usage &&= ($option eq "-d" || $option eq "-q");

if (!$correct_usage) {
    print(
"Usage: dvorak_cypher.pl <option> <message>\n".
"Options:\n".
"      -d        Converts <message> from a QWERTY layout to a Dvorak layout\n".
"      -q        Converts <message>  from a Dvorak layout to a QWERTY layout\n";
    );
    exit(0);
}

my $qwerty = quotemeta(
'~!@#$%^&*()_+`1234567890-='.
'QWERTYUIOP{}|qwertyuiop[]\\'.
'ASDFGHJKL:"asdfghjkl;\''.
'ZXCVBNM<>?zxcvbnm,./'
);

my $dvorak = quotemeta(
'~!@#$%^&*(){}`1234567890[]'.
'"<>PYFGCRL?+|\',.pyfgcrl/=\\'.
'AOEUIDHTNS_aoeuidhtns-'.
':QJKXBMWVZ;qjkxbmwvz'
);

if ($option eq "-d") {
   $message =~ tr/$qwerty/$dvorak/;
} elsif ($option eq "-d") {
   $message =~ tr/$dvorak/$qwerty/;
}

print $message."\n";
    I can't quite get the last bit to work. How can I get tr/// to interpolate the variables?

Meanwhile, is there a better way to parse the arguments?
    2009-08-06T03:32:38+00:00
    986
    Perl
    a-dvorak-keyboard-layout-cypher
    2
    A Dvorak keyboard layout cypher
    
    2009-08-20T16:50:36+00:00
    1159
    
      1159
      http://lordzoner.myopenid.com
      lordzoner.myopenid.com
      0.0
      4


    use Time::DaysInMonth;

# Get todays date in the form of YYMMDD
(undef, undef, undef, my $dayLast, my $monthLast, my $yearLast, undef, undef, undef) = localtime(time);
$yearLast	= $yearLast - 100;	# Year is given as YYY, make it YY.

# Grap the name of the first log file (in the form of exYYMMDD.log) for our starting point and extract just the YYMMDD.
my $dateFirst = $logs[0];
$dateFirst =~ s/^ex//; $dateFirst =~ s/$.log//;

# Parse the input of YYMMDD into three separate variables.
my $yearFirst = substr($dateFirst, 0, 2);
my $monthFirst = substr($dateFirst, 2, 2);
my $dayFirst = substr($dateFirst, 4, 2);

for (my $year = $yearFirst; $year <= $yearLast; $year++) {
	if ($yearFirst == $yearLast) {
		$monthStart	= $monthFirst;
		$monthEnd	= $monthLast;
	} elsif ($year == $yearFirst) {
		$monthStart	= $monthFirst;
		$monthEnd	= 12;
	} elsif ($year == $yearLast) {
		$monthStart	= 1;
		$monthEnd	= $monthLast;
	} else {
		$monthStart	= 1;
		$monthEnd	= 12;
	} # End Months initialization.

	for (my $month = $monthStart; $month <= $monthEnd; $month++) {
		if ( ($year == $yearFirst) && ($month == $monthStart) ) {
			$dayStart	= $dayFirst;	
		} else {
			$dayStart	= 1;
		} # End Days initialization.
		$dayEnd = days_in($year + 2000, $month);

		for (my $day = $dayStart; $day <= $dayEnd; $day++) {
			#
			# Push each filename into an array.
			#
		} # End loop through Days.

		#
		# Zip The Files.
		#

	} # End loop through Months
} # End loop through Years.
    The following takes a date in the past as YYMMDD. It then processes files one month at a time from the given date to current date minus the current month.
The final product zips IIS Log files one month at a time.
It all works, but like my description, appears to be a mess.
    2009-02-26T16:08:26+00:00
    770
    Perl
    processing-files-by-date
    5
    Processing files by date.
    
    2010-01-12T14:55:58+00:00
    1372
    
      1372
      http://trirnoth.pip.verisignlabs.com
      trirnoth
      0.0
      1


    #!/usr/bin/perl
use strict;
use warnings;

use Data::Dumper;
use File::Find;
use File::stat;
use Carp;

my $files_path = "/tmp/files/";

my %files;

sub files_wanted { 
    if (/\.tgz$/) {
        my $current_file_mtime       = stat($File::Find::name)->mtime or croak "Error, could not stat file $File::Find::name";
        $files{$current_file_mtime}  = $File::Find::name;
    };
}

find( \&files_wanted ,$files_path);
print '%files:' . "\n" . Dumper(\%files);

my @sorted_files_mtimes =  reverse sort keys %files; 
print "sorted_files_mtimes=$sorted_files_mtimes[0]\n";

my $newest_file     = $files{$sorted_files_mtimes[0]};
print "$newest_file\n";
    Here's a small script that looks in a certain directory for files with a spesific extention, and returns the file with the highest mtime.

Currently, a hash is created with the mtime as keys and filenames as values. So if 2 or more files have the same mtime, each will be inserted into the hash, overwriting one another and only the last will remain in the hash.
    2009-01-07T07:19:32+00:00
    698
    Perl
    find-the-file-with-the-highest-mtime
    2
    Find the file with the highest mtime in a directory
    
    2009-01-07T15:28:46+00:00
    1256
    
      1256
      http://bonzobo.blogspot.com
      bonzobo.blogspot.com
      0.0
      1


    
      #!/usr/bin/perl
      #smtp scanner by Tak
      use strict;
      use warnings;
      use Net::Ping;
      use Net::Telnet;
      print "ip list: ";  #asks for ip's
      chomp(my $input=<STDIN>); #takes file
      #
      #if nothing was entered
      #
      if ($input=~/^$/) {
		print "ip range, ex 0.0.0.0-1.1.1.1 :";
		chomp($input=<STDIN>); 
		#idea for most of this ip generator i stole from  Asia Pacific Network Information Center (APNIC2)
		#
		#generateing a log.
		
		$|=1; #pipes become super pipes
		print "where to log ip range: ";   
		chomp(my $log=<STDIN>);    #takes a file name to log
		open(LOG, '>>', "$log") or die "couldent open $log file\n";    #opens the log file
		my @ip0=split(/-/, $input);  #seperates ip ranges
		my @ip1=split(/\./, $ip0[0]);  #seperates numbers
		my @ip2=split(/\./, $ip0[$#ip0]);    
		#complicates loops that generate every ip address inbetween the ranges
			for (my $a=$ip1[0]; $a<1+$ip2[0]; $a++) { 

				for (my $b=$ip1[1]; $b<1+$ip2[1]; $b++) {

					for (my $c=$ip1[2]; $c<1+$ip2[2]; $c++) {

						for (my $d=$ip1[3]; $d<1+$ip2[3]; $d++) {

							print "$a.$b.$c.$d\n";
							print LOG "$a.$b.$c.$d\n";
						}
					}
				}
			}
		close(LOG);
		exit 0;
	}
      
      open(IP, "$input") or die "couldent open ip file\n"; #opens file
      ##now to split the file by newline characters,. into a varible
      #
      my @ip; #all ip addresses
      my @liveip; #all working ip addresses
      my @deadip; #all dead ip addresses
      #
      #
      foreach(my $line = <IP>) {
        $line =~ s/\n//g; #rid of the newline.
        push(@ip, "$line");
      }
      close(IP); #closeing the file
      ##########################################
      ##starting the test to see if their alive
      #########################################
      foreach my $ip (@ip) {
      #if it exists
        if (pingecho($ip, 10)) {
            push(@liveip, "$ip");
            next;
        }
      #if its dead
        else {
            push(@deadip, "$ip");
        }
      #if nothing is alive
        if ($#ip eq $#deadip) {
            die "no live hosts\n";
        }
      }
      #wipeing the useless variables
      @deadip=();
      @ip=();
      ################################################################################
      #we got all the alive ip addresses, now to probe with Telnet for SMTP running!
      ###############################################################################
      my @testsmtp; #ip's to be tested for smtp
      #makeing the live ip's into telnet objects.
      foreach my $ip (@liveip) {
		#if no port is there, it gives WTF message. and moves on
          my $thing = new Net::Telnet (Host => $ip, Port => '25', Errmode => 'return') or print "WTF?!\n" and next;

      #now that we have the objects we can test them.
		if ($thing->open()) {
            print $thing->host . " has smtp alive\n";
		}
	  }
    I wrote this a LOONGG time ago, so my style is a bit messey, but im curious, how would anyone improve the actual code
    2008-12-16T04:07:22+00:00
    669
    Perl
    smtp-scanner
    4
    Smtp Scanner
    
    2009-10-20T22:51:04+00:00
    1220
    
      1220
      http://tak11.myopenid.com
      tak11.myopenid.com
      0.0
      1
      pirate.zapto.org


    #!/usr/bin/perl -w
use strict;

if (!$ARGV[0]) {
    die "useage ./delete.pl [file] [options]\n";
}
my $list = $ARGV[0];
my $option = $ARGV[1];

if ($option eq '-h' or $list eq '--help') {
    print "-b           => backup the file\n";
    die "-h || --help => this menu\n";
}

my @words;
open(LS, "$list") || die "couldnt open list\n";
foreach my $pass (<LS>) {
    push(@words, $pass);
}
close(LS);

if ($option eq '-b') {
    open(BK, ">$list" . '.bak') || die "couldnt open backup list\n";
    foreach (@words) {
        print BK $_;
    }
    print "File Backed up\n";
}

my %final;
foreach my $word (@words) {
    $final{$word} = 1;
}
my @final;

foreach (keys %final) {
    push(@final, $_);
}
open(LS, ">$list") || die "couldnt open list for edit\n";

foreach (@final) {
    print LS "$_";
}
close(LS);
print "complete\n";
exit 0;
    ment to cycle through a password list, or dictionary, etc. and remove doubles, **has option of backing up file
    2008-12-16T03:54:44+00:00
    668
    Perl
    deldup
    4
    deldup
    
    2009-11-17T21:55:18+00:00
    1220
    
      1220
      http://tak11.myopenid.com
      tak11.myopenid.com
      0.0
      1
      pirate.zapto.org


    #!/usr/bin/perl -w

use strict;
use Time::localtime;
use File::Find;
use File::Copy;

my $vmlogpath = $ARGV[0] or die "y'all didn't enter no arguments";

find(\&sortFile, $ARGV[0]);

sub sortFile {
    if ( -f ) {
        my $filename=$_;
        $filename =~ /([0-9]{5,})/;
        my $unixtime = $1 or print "Not a log file: $filename\n";
        my $dirname=makeDirName($unixtime);
        unless(-e "${ARGV[0]}/${dirname}/${filename}") {
            my $path=makeDir($ARGV[0], $dirname);
            moveFile($filename, $path);
            print "$filename is the file name.\n";
            print "$unixtime is the extracted unixtime.\n";
            print "$dirname is the directory name.\n";
            print "$path is the path.\n";
        }
    }
    else { print "Not a plain file: $_\n"; }
}

sub moveFile {
    my $tehfile=$_[0];
    my $tehdir=$_[1];

    move($tehfile, $tehdir) or die "Could not move files!\n$!";

    return 1;
}

sub makeDir {
    my $currentdir=$_[0];
    my $newdir=$_[1];
    my $newpath="${currentdir}/${newdir}";
    unless (-d $newpath) {
        mkdir($newpath,755) or die "mkdir failed for $newpath: $!\n"
    }
    return $newpath;
}

sub makeDirName {
    my $tehunix=$_[0];
    my $day_of_year=localtime(int($tehunix))->yday;
    my $week_of_year=int($day_of_year / 7) + 1;
    my $year=1900+localtime(int($tehunix))->year;

    return $year . $week_of_year;
}
    I have a huge amount of log files on my hard drive and regularly download more.  All of the files end up in a single directory.  The log file names contain UNIX timestamps.  I wrote this script to execute in a given directory and then move the found files to a new path based on the UNIX timestamp.  Each new directory is named after a year and the week of the year, e.g. 200801, the first week of 2008.  (Actually, the month doesn't have a leading zero yet.  I just realized.)
    2008-11-18T16:22:53+00:00
    607
    Perl
    apache-log-file-sorting
    1
    Apache log file sorting
    
    2008-11-21T15:33:06+00:00
    1175
    
      1175
      http://hourback.openid.org
      hourback
      0.0
      1
      http://hourback.blogspot.com/


    #!/usr/bin/perl  
# Load the Net::FTP package 
use Net::FTP;  

$host = 'http://refactormycode.com/';
$path = '/httpdocs/rep/';


$ftp = Net::FTP->new($host, Timeout => 60, Passive => 1)
	or die "Cannot contact $host : $!";
$ftp->login('****', '*****')
	or die "Can't login ( $host) : " . $ftp->message;

print "Login eseguito\n";

$ftp->cwd($path)
	or die "Can't change directory ($oath):" . $ftp->message;
print "Switching to dir $path\n";

#Take filelist and sort by last modified field
@filelist = $ftp->dir();
@filelist = sort {(stat($a))[9] >= (stat($b))[9]} @filelist;

#Take the first element 
$file =  $filelist[0];

#Extract filename form $file
$_ = $file;
m/^(.*)(\d+:\d+\s)(.*)$/;	
$filename = $3;

print "Download " . $filename . "...";
$ftp->get($filename)
	or die "$!";
print "done\n";

#I want to untar in backup directory
print "Create folder...";
system('mkdir backup');
#system("mv $filename backup/");
print "done\n";

print "unpacking....";
$command = "tar xvf " . $filename . " -C backup/";
system($command);
print "done\n";

print "Delete old file...";
$command = "rm " . $filename;
system($command);
print "done\n";
    I code this script for need, it's about 2 years I don't code in Perl...
    2008-10-18T12:41:24+00:00
    541
    Perl
    take-last-modified-file-in-my-ftp-server
    1
    Take Last modified file in my FTP server
    
    2008-11-05T15:40:48+00:00
    296
    
      296
      http://ipepito.myopenid.com
      iPepito
      0.0
      0
      http://www.ipepito.net


    #!/usr/bin/perl  
# Load the Net::FTP package 
use Net::FTP;  

$host = 'http://refactormycode.com/';
$path = '/httpdocs/rep/';

#Get Time for filename
$ora = time();
@ltime = localtime($ora);
$data = $ltime[3] . ($ltime[4] + 1) . "0" . ($ltime[5] - 100) . "_" . $ltime[2] . $ltime[1];

$filename = "backup_" . $data  . ".tar";


print "Begin to compress...\n";
$command = "tar -cvf " . $filename . " *"; 
system($command);      
printf "\n\nFINISHED!\n";

$ftp = Net::FTP->new($host, Timeout => 60, Passive => 1)
	or die "Cannot contact $host : $!";
$ftp->login('******', '******')
	or die "Can't login ( $host) : " . $ftp->message;
print "Login eseguito\n";

$ftp->cwd($path)
	or die "Can't change directory ($oath):" . $ftp->message;
print "Switching to dir $path\n";

print "Begin backup upload\n";
$ftp->put($filename)
	or die "Cannot put file : $!";
print "File transfer complete\n";


$ftp->quit ;

print "Backup eseguito con successo\n";
system("rm $filename");


    I code this script for need, it's about 2 years I don't code in Perl...
This code tar all the file on the dir and send it in my ftp server.
    2008-10-18T12:37:14+00:00
    540
    Perl
    create-backup-and-send-to-ftp-server
    1
    Create Backup and send to FTP server
    
    2009-08-30T01:16:20+00:00
    296
    
      296
      http://ipepito.myopenid.com
      iPepito
      0.0
      0
      http://www.ipepito.net


    use File::Spec;

sub purge_archive{
    print "\nPurging files from: $_[0]\n";
    opendir(DIR,$_[0]) or die "Cannot open $_[0]: $!";
    my @files = grep{!/^\./ } readdir(DIR);
    foreach my $file (@files){
        unlink File::Spec->catfile($_[0],$file) or die "Can't remove files from $_[0]: $!";
    }
    closedir(DIR);
}
    I want to remove all files from a given directory. This code returns the list of files except for '.' files that I loop over and remove each one separately. The reference states that unlink accepts a LIST (arrays or even wildcards), but when I pass the file array from readdir it states it can't find the files.  I added the reference to File::Spec to provide a complete path, but it feels very dirty to me.
    2008-10-14T21:12:31+00:00
    532
    Perl
    delete-files-from-a-directory
    2
    Delete files from a directory
    
    2009-11-16T02:11:31+00:00
    1077
    
      1077
      http://kire.notneb.net
      kire
      0.0
      0


    ## Bdecode.pm
#!/usr/bin/perl -w
package Bdecode;
use strict;
use Carp;

our %bdecode_funcs = (
    list => sub {return [bdecode_list($_[0])]},
    dict => sub {return {bdecode_list($_[0])}},
    int => sub {return 0 + $_[1]},
    string => sub {return substr ${$_[0]}, 0, $_[1], ''},
);

# on return, contains unparsed text
sub bdecode(\$) {
    my ($str) = @_;
    my $key =
        $$str =~ /^l/ ? 'list' :
        $$str =~ /^d/ ? 'dict' :
        $$str =~ /^i(0|-?[1-9]\d*)e/ ? 'int' :
        $$str =~ /^(0|[1-9]\d*):/ ? 'string' :
        undef;
    $key or croak 'invalid sequence';
    $$str =~ s///;
    return $bdecode_funcs{$key}->($str, $+);
}

sub bdecode_list($) {
    my ($str) = @_;
    my @result;
    push @result, bdecode($$str) while $$str !~ /^e/;
    $$str =~ s///;
    return @result;
}

1;
## bdecode
#!/usr/bin/perl -w0777
use strict;
use Bdecode;
use Data::Dumper;

my $input = <STDIN>;
my $obj = Bdecode::bdecode($input);
push @ARGV, '' unless @ARGV;
for my $path (@ARGV) {
    my $cur = $obj;
    for my $item (split '/', $path) {
        my ($name, @indices) = split /:/, $item;
        $name =~ s/%([[:xdigit:]]{2})/chr hex $1/eg;
        $cur = $cur->{$name} if length $name;
        $cur = $cur->[$_] for @indices;
    }
    my $dumper = new Data::Dumper([$cur], [$path]);
    print $dumper->Dump;
}

    The BitTorrent .torrent file format uses Bencode, so this program allows you to unpack .torrent files into something more intelligible. Note that the hashes are in binary, so be sure to escape the output before writing it to your terminal!
    2008-08-22T01:19:59+00:00
    455
    Perl
    bencode-decoder
    0
    Bencode decoder
    
    2008-08-22T01:20:33+00:00
    611
    
      611
      http://chris.jester-young.name/
      Chris Jester-Young
      4.3333
      29


    #!/usr/bin/perl
use strict;
use warnings;

# sample snmp return
my $mac_address = '0x001617479a5e';

print qq{Original MAC Address: $mac_address\n};

# reformat the address as a standard MAC
$mac_address =~ s/\A..//xms;     # remove the 0x
$mac_address =~ s/(..)/$1:/g;    # add a colon between bytes
$mac_address =~ s/:$//;          # remove the trailing :

print qq{Reformatted MAC Address: $mac_address\n};

    Converting the return from an SNMP walk into a colon-delimited MAC address.
    2008-07-20T23:25:46+00:00
    390
    Perl
    mac-formatting
    6
    MAC Formatting
    
    2009-09-03T23:25:54+00:00
    698
    
      698
      http://xinu.myopenid.com
      mrxinu
      4.0
      4
      http://www.xinu.org/


    #!/usr/bin/env perl
#What follows is the demented codings of someone bored.
package upsidedown;
use strict;
use warnings;
sub runs() {bless {}}
sub eats
{shift=~y///;my $funnyhat=shift;$funnyhat=$funnyhat+7;return($funnyhat);}
package demise;
sub expect() {bless{}}
sub run()
{shift=~y///;my $uation=shift;eval($uation);return(1);}
	package main;
			use strict;use warnings;#Heh
			sub
yes			{return("no")}
			sub
its			{return((shift)-3);}
			sub
crazy		{return(chr(shift));}
			sub 
silly		{if($#_==0){return($_[0]);sub int{};}else{my($Il,$L,$i)=(shift,shift,shift);return(chr(CORE::int(unpack("H",$Il)*($L+$i+1))));}}
			sub
this		{return(substr(shift,1,1))}
			sub 
works		{my $job=shift;return(chr($job))}
			sub
in			{my$force=shift;return($force.="m");}
			sub
the			{my$foot=shift;return(CORE::int(substr($foot,0,1))/CORE::int(substr($foot,1,1))*2);}
			sub
end			{return(works(shift))}
			sub
is			{if($_[0]=~/[0-9.]/){return(chr(shift))}else{return(" ")if($_[0]eq'not');}}
			sub
very		{if($#_=~/[0-9a-zA-G]*/){&int(eval($_[0]));return(shift)if(1)}else{return(shift);}}
			sub
great		{return("~")}
			sub
like		{return(shift)}
			sub
killing		{return((shift))}
			sub
without		{my$idiots=(shift);my$pace=like($idiots);return($idiots);}
			sub
you			{return(this(shift))}sub
   r		{my$ecret=shift;if(shift){return(chr(CORE::int($ecret)));}else{return(($ecret));}}
			sub
odd			{for(1..100){return$_ if is($_/2)eq"@"};}
			sub 
actors 		{return(shift);}


my $this;#is silly, I know
my $iguanna=runs upsidedown;
my $hoes=1337;
my $trangly=silly($iguanna->eats($hoes));
my $evil=14;
$hoes=$trangly/$evil;
$this.=$hoes;
$this=works($this);
my $plot=$iguanna->eats(its($evil));
my $dream=$hoes+$plot;
$this.=crazy($dream);end($trangly);
my $newplot=killing($this);
my $toes=in($newplot);
$this=$toes;
my$hat=0;
if($hat<$hoes){$hat=the($hoes);}
$this.=silly(without(chr(actors($hoes/$hat))));
my ($luck,$y)=("num","ber");
$luck=~y/num/ber/;
$luck=~s/be./13/;
$newplot=$luck;
my$hacke=r(you($luck));
$hacke=r($hoes/$hacke+r($luck));
$this.=($hacke=r($hacke,"y"));
$this.=this($this);
my$fate=yes;
$this.=silly($fate, $luck,$hat);
$this.=(is("very"). odd);
$this.=is("not"). great;
my$odd=$this;
my$self=great("ly");$odd=~
s/^((.?).*)/$1$2/;
my $advice=expect demise;
my $you=silly($advice);

$this=very($odd);
if($you->run($this)){die("for stupidity");}
    As the title implies, guess what the code does!
    2008-03-24T04:51:16+00:00
    266
    Perl
    guess-the-code
    1
    Guess the Code
    
    2008-03-31T09:57:32+00:00
    536
    
      536
      http://dbrweb.co.uk
      dbr
      0.0
      1
      http://neverfear.org


    perl -le'*{$#_}=sub{world},s;"*;$,=$";e,*{$"}=sub{Hello},print$_--->(),&$_'
    Can you refactor this to make it even more obscure?
    2008-03-18T13:49:28+00:00
    262
    Perl
    hello-world
    3
    Hello world!
    
    2009-11-17T21:52:06+00:00
    533
    
      533
      http://sfllaw.livejournal.com
      Simon Law
      0.0
      3
      http://www.law.yi.org/~sfllaw/


    curl http://www.cnn.com | perl -ne 'm/>([^<].*?[^>])<\// && print$1."\n"'
    Hello,
I'm a web-scrapping enthusiast and I script short one-liners in bash using sed, awk, perl, grep, tail, head, tr,... that sort of programs. Here's a really cool perl one-liner that basically extracts values from any xml(html) tag. You should try it. Can you make it shorter, or any more powerful?
Cheers,
Guillaume
    2007-11-13T17:19:53+00:00
    151
    Perl
    perl-one-liner-to-extract-xml-tags-values
    4
    Perl one-liner to extract xml tags values
    
    2009-12-29T17:58:39+00:00
    123
    
      123
      http://griflet.myopenid.com/
      griflet
      0.0
      3
      http://webtopmania.blogspot.com


    use Cache::FileCache;

$cache = new Cache::FileCache( );

# this subroutine works just fine
sub stockInfoFresh
{
	my $tick = $_[0];
	
	$tick =~ tr/a-z/A-Z/;
	
	my $first_let = substr($tick,0,1);
	
	my $name = "Ticker not found";
	my $exch = '';
	
	my $sth = $dbh->prepare("SELECT * FROM `Stock` WHERE `Ticker` = '$tick'"); $sth->execute;
	
	my @stockid = $sth->fetchrow_array;
	
	if ($stockid[0]) {
		$name = $stockid[2];
		$exch = $stockid[3];
	}
	
	$sth->finish;
	
	my @out; 
	
	return($tick, $first_let, $name, $exch, @stockid);
}

# this subroutine fails
sub stockInfo
{
	my $tick = $_[0];
	
	my @stockInfo = $cache->get( "stockInfo" . $tick );
	
	if( not defined @stockInfo )
	{
		@stockInfo = &stockInfoFresh($tick);
		
		$cache->set( "stockInfo" . $tick, \@stockInfo, "1 hour" );
	}

	# at this point, $stockInfo[0] is empty

	return @stockInfo;
}

# this fails

my($tick, $first_let, $name, $exch, @stockid) = &stockInfo($t);
    I'm having serious trouble with Perl's syntactic niceties... I can get a function like this to work with a single scalar or a single array but this doesn't work. Please help me figure out where my syntax is wrong (and if we can make this cleaner, all the better!)
    2007-10-11T19:17:12+00:00
    76
    Perl
    cache-cache-subroutine-with-multiple-variables-returned
    2
    Cache::Cache subroutine with multiple variables returned
    
    2007-10-11T19:19:33+00:00
    185
    
      185
      http://montoya.myopenid.com
      montoya
      0.0
      1
      http://www.christianmontoya.net


    #!/usr/bin/perl

use LWP::Simple;
$url = "http://suggestqueries.google.com/complete/search?output=firefox&qu=";
$word = $ARGV[0];
for (1..25) {
    $content = get($url . $word);
    @matches = $content =~ /\"([^\"]+\\s)(\\w+)\"/g;
    last if not @matches;
    $x = int(rand(@matches / 2));
    $line .= $matches[2 * $x];
    $word = $matches[2 * $x + 1];
}
print $line . "\n";

    Random sentence generator
    2007-09-27T19:31:59+00:00
    24
    Perl
    random-sentence-generator
    7
    Random sentence generator
    
    2009-05-12T15:38:22+00:00
    15
    
      15
      http://expertprogrammer.myopenid.com/
      EXPERTPROGRAMMER
      0.0
      0