Converts all 8-bit binary numbers in the standard input into text, though there's probably a better way to do this

#!/usr/bin/perl -wn
use strict;
s/\s//g;
print chr oct "0b$1" while /([01]{8})/g;
print "\n";

When passed either an IPv4 address or the name of a domain or server, this script will return either a name or an IP, respectively.

#!/usr/bin/perl -w
use strict;
use Socket;
my $arg = shift;
if ($arg =~ /^(\d+\.){3}\d+$/) {
 print scalar gethostbyaddr(inet_aton($arg), AF_INET), "\n"
} else { printf "%vd\n", scalar gethostbyname $arg }

Converts any nonempty lines in a document that don't start with whitespace into more conventional paragraphs

#!/usr/bin/perl -wni
# para.pl
use strict;

/^\s+/ || /^$/ ? print : write;
format ARGVOUT =
        ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$_
^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
$_
.

1. Searches for files having uppercase extensions (can be mixed with numbers and can be multipart eg: TAR.BZ2 ).
It does not detect files whose extensions contain both upper and lower cases. This is intentional, as if you have part of extension lowercase, you probably intentionally left the other part upper case. Changing this behaviour is trivial. Replace that complex (?:[A-Z]*[0-9]*\.*) with a . (a dot).

2. It then converts them to lowercase.

#!/usr/bin/perl
$files=`ls`;
@files=split(/\n/,$files);
foreach (@files) {
    if(/(.*)\.((?:[A-Z]*[0-9]*\.*)+)$/) {
        $name=$1."."."\L$2\E";
        system("mv $_ $name")
    }
}

Looks quite ugly, but this is what I could do with the Perl I know, and more importantly, it works (at least in my case)!

This code parses through the games.xml file generated by EMUCenter and changes Genre to Letter, also taking the first letter of the Title property and adding it to the Letter property. This allows sorting by letter in the EMUCenter interface. Two things, Change the metadata entry from Genre to Letter and remove the trailing </game> at the very end of the file.

my $holdTerminator = $/;
undef $/;

if (open(FILE, '<c:\games.xml')) {
	$file = <FILE>;
}
$/ = $holdTerminator;

@array = split /\<\/game\>/, $file;
open(FILE1, '>c:\newgames.xml');

foreach $line (@array){
	$line =~
s/(\n\s+.*?"Title">)(.)(.*?)"Genre">.*?(<\/property>)/$1$2$3"Letter">$2$4/is
;
	print FILE1 $line;
	print FILE1 '</game>';

}
close(FILE1);

This little bash script shows how to use curl, grep, tail, sed and perl one-liners in order to compose a bleeding-edge twitter bot.
This one returns daily weather forecasts for Lisbon city based on the BBC weather forecast rss feed.

#! /bin/sh

#Goto here
here=/home/guillaume/Personal
cd $here

#BBC Lisbon weather id
id=0048

#BBC weather RSS feed address
feed="http://feeds.bbc.co.uk/weather/feeds/rss/5day/world/${id}.xml"

#City
city=lisbon

#temporary file
file="weather${city}"

#Weather twitter bot
twitbot=weatherlisbon:*******

#Timestamp the log file
echo .>> $file.log
date >> $file.log

#Read the RSS feed and filter it
curl $feed | grep 'title' | tail -n 1 | perl -wlne'm/title>(.*)<\/title/i && print $1' | sed -e "s/&#xB0;//g" > $file.txt

#Read the forecast into a weather variable
read weather < $file.txt

#Twit the weather variable away
curl --basic --user $twitbot --data status="$weather" http://twitter.com/statuses/update.xml >> $file.log

Rename htm files to html
In windows:

>dir /B /S | perl -wlne"/([^ ]+)\.htm$/i&&rename$1.'.htm',$1.'.html'"

In linux:

>find | grep htm | perl -wlne'/([^ ]+)\.htm$/i&&rename$1.".htm",$1.".html"'

// CGI script for collecting username and password and storing them in a database table

#!/usr/bin/perl

# $Id$

# CGI script for collecting username and password and storing them in a database
# table. The password is encrypted with Crypt::PasswdMD5 ready for passing to
# useradd.

use strict;
use warnings;

## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars)
our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }xms;
## use critic

use CGI::Pretty qw(:standard -nosticky);
use DBI;
use Crypt::PasswdMD5;

# Schema for database table to store account details:
# 
# CREATE TABLE account (
#     username varchar(50) NOT NULL,
#     password varchar(50) NOT NULL,
#     date_created datetime NOT NULL
# );

my $DBNAME = 'database';
my $DBHOST = 'localhost';
my $DBPORT = 3306;
my $DBUSER = 'username';
my $DBPASS = 'password';

# Header
my $q = new CGI;
print $q->header(),
      $q->start_html(
          -title => 'New Account',
          -lang  => 'en',
      ),
      $q->h1('New Account');

my $submit    = $q->param('submit')    || q{};
my $username  = $q->param('username')  || q{};
my $password1 = $q->param('password1') || q{};
my $password2 = $q->param('password2') || q{};

my %ERROR = (
    no_username         => 'You must specify a username.',
    no_password         => 'You must specify a password.',
    password_not_twice  => 'You must specify your password twice.',
    passwords_not_match => 'Both passwords must match.',
);

my $error = (!$submit)                   ? undef                       :
            (!$username)                 ? $ERROR{no_username}         :
            (!$password1 && !$password2) ? $ERROR{no_password}         :
            (!$password1 || !$password2) ? $ERROR{password_not_twice}  :
            ( $password1 ne  $password2) ? $ERROR{passwords_not_match} :
                                           undef
            ;

if (!$submit) {
    # Form not submitted, so display empty form
    form($q);
}
elsif ($error) {
    # Show error and redisplay form
    print $q->p($error);
    form($q, $username);
}
else {
    # Enter account details into database
    my $dsn = "DBI:mysql:database=$DBNAME;host=$DBHOST;port=$DBPORT";
    my $dbh = DBI->connect($dsn, $DBUSER, $DBPASS);
    
    my $username_quoted = $dbh->quote(param('username'));
    my $password_quoted = $dbh->quote(unix_md5_crypt(param('password1')));
    
    $dbh->do("
        INSERT INTO account
        (username, password, date_created)
        VALUES ($username_quoted, $password_quoted, NOW())
    ");
    
    print $q->p('Your username and password have been recorded.');
}

# Footer
print $q->end_html();

sub form {
    my $q = shift;
    my $username = shift || q{};
    
    print start_form(),
          p('Username:', br(), textfield(
              -name  => 'username',
              -value => $username,
          )),
          p('Password:', br(), password_field(
              -name => 'password1',
          )),
          p('Password (again):', br(), password_field(
              -name => 'password2',
          )),
          p(submit(
              -name  => 'submit',
              -value => 'Submit',
          )),
          end_form();
    
    return;
}

// Run Analog for monthly and yearly reports

#!/usr/bin/perl

# $Id$

use strict;
use warnings;

## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars)
our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }xms;
## use critic

use English qw( -no_match_vars );
use Getopt::Long;
use POSIX qw( WIFEXITED );

my @ANALOG_CMD = qw(/usr/bin/nice /usr/local/packages/analog/analog -G);

my $config = get_config();

do_months($config);
do_years($config);

exit;

# Run yearly Analog reports
sub do_years {
    my ($config) = @_;
    
    my ($year)         = $config->{ startmonth   } =~ m/ \A (\d{4}) /xms;
    my ($current_year) = $config->{ currentmonth } =~ m/ \A (\d{4}) /xms;
    
    # Run Analog for all years except current year (if not already run)
    while ($year != $current_year) {
        run_cmd($config, $year);
        $year++;
    }
    
    return;
}

# Run monthly Analog reports
sub do_months {
    my ($config) = @_;
    
    my $month = $config->{startmonth};
    
    while ($month != $config->{currentmonth}) {
        # Run Analog for this month if not already run
        if ( ! -e $config->{outputdir} . q{/} . $month . '.html' ) {
            run_cmd($config, $month);
        }
        
        # Get next month
        my ($y, $m) = $month =~ m/ \A (\d{4}) (\d{2}) \z /xms;
        $m++;
        if ($m == 13) {
            $m = 1;
            $y++;
        }
        $month = sprintf '%04d%02d', $y, $m;
    }
    
    run_cmd($config, $month);
    
    return;
}

# Run Analog 
sub run_cmd {
    my ($config, $date) = @_;
    
    my @cmd;
    
    push @cmd, @ANALOG_CMD;
    
    # Config files
    foreach my $configfile ( @{$config->{configfiles}} ) {
        my $file = $config->{configdir} . "/$configfile";
        push @cmd, "+g$file";
    }
    
    # Year or month config file
    push @cmd, '+g' . $config->{configdir} . q{/}
               . ( length $date == 4 ? 'year.cfg' : 'month.cfg' );
    
    # Output options
    my $prefix = $date;
    if ($date == $config->{currentmonth}) {
        $prefix = 'current';
    }
    push @cmd, '+O' . $config->{outputdir} . q{/} . $prefix . '.html';
    push @cmd, "+CCHARTDIR $prefix-";
    push @cmd, '+CLOCALCHARTDIR ' . $config->{outputdir} . "/$prefix-";
    
    # Date range
    my $from;
    my $to;
    if (length $date == 4) {
        # Year
        $from = $date . '0101';
        $to   = $date . '1231';
    }
    elsif (length $date == 6) {
        # Month
        $from = $date . '01';
        $to   = $date . '31';
    }
    # Year needs to be in two digit format
    substr $from, 0, 2, q{};
    substr $to,   0, 2, q{};
    push @cmd, "+F$from";
    push @cmd, "+T$to";
    
    # Get logs
    my $need_prev = 1;
    my $got_log = 0;
    # Iterate over all logs
    LOG:
    for my $i ( 0 .. $#{$config->{logs}} ) {
        if ( $config->{logs}->[$i] =~ m/\D$date/xms ) {
            # Got a matching log
            $got_log = 1;
            if ($need_prev) {
                # Get the previous log(s)
                my $j = $i - 1;
                my $prev_date;
                while ( $j >= 0 ) {
                    if (!defined $prev_date) {
                        # Get previous log
                        push @cmd, $config->{logs}->[$j];
                        ($prev_date) = $config->{logs}->[$j] =~ m/(\d+)/xms;
                    }
                    else {
                        # Get other previous logs with the same date
                        my ($prev_date2) = $config->{logs}->[$j] =~ m/(\d+)/xms;
                        if ($prev_date == $prev_date2) {
                            push @cmd, $config->{logs}->[$j];
                        }
                        else {
                            $need_prev = 0;
                            last;
                        }
                    }
                    $j--;
                }
            }
            push @cmd, $config->{logs}->[$i];
        }
        else {
            if ($got_log) {
                # Get the next log(s)
                push @cmd, $config->{logs}->[$i];
                my ($next_date) = $config->{logs}->[$i] =~ m/(\d+)/xms;
                # Get other next logs with the same date
                my $j = $i + 1;
                while ( $j <= $#{$config->{logs}} ) {
                    my ($next_date2) = $config->{logs}->[$j] =~ m/(\d+)/xms;
                    if ($next_date == $next_date2) {
                        push @cmd, $config->{logs}->[$j];
                    }
                    else {
                        last LOG;
                    }
                    $j++;
                }
            }
        }
    }
    
    WIFEXITED(system @cmd) or die "Couldn't run: @cmd ($OS_ERROR)\n";
    
    return;
}

# Get command line options, check them and get all logs
sub get_config {
    my $config = {};
    
    $config->{ startmonth   } = q{};
    $config->{ currentmonth } = q{};
    $config->{ outputdir    } = q{};
    $config->{ configdir    } = q{};
    $config->{ configfiles  } = [];
    $config->{ logglobs     } = [];
    
    GetOptions(
          'startmonth=s' => \$config->{ startmonth   },
        'currentmonth=s' => \$config->{ currentmonth },
           'outputdir=s' => \$config->{ outputdir    },
           'configdir=s' => \$config->{ configdir    },
          'configfile=s' =>  $config->{ configfiles  },
             'logglob=s' =>  $config->{ logglobs     },
    );
    
    # Check config
    foreach my $configfile ( @{$config->{configfiles}} ) {
        my $file = $config->{configdir} . "/$configfile";
        die "$file does not exist\n" if ! -e $file;
        die "$file cannot be read\n" if ! -r $file;
    }
    if ( ! -w $config->{outputdir} ) {
        die $config->{outputdir} . " cannot be written to\n";
    }
    if ($config->{startmonth}   !~ m/ \A \d{6} \z /xms) {
        die "--startmonth should be YYYYMM\n";
    }
    if ($config->{currentmonth} !~ m/ \A \d{6} \z /xms) {
        die "--currentmonth should be YYYYMM\n";
    }
    
    # Get logs from globs
    $config->{logs} = [];
    foreach my $logglob ( @{$config->{logglobs}} ) {
        my @logs = glob $logglob;
        push @{$config->{logs}}, @logs;
    }
    die "No logs found\n" if !@{$config->{logs}};
    
    # Sort logs by date
    @{$config->{logs}} = sort sort_logs @{$config->{logs}};
    
    return $config;
}

# Sort logs by date then alphabetically
sub sort_logs {
    my ($a_date) = $a =~ m/(\d+)/xms;
    my ($b_date) = $b =~ m/(\d+)/xms;
    return $a_date <=> $b_date || $a cmp $b;
}

// Rewrite Apache logs that have incorrect dates

#!/usr/bin/perl

# $Id$

# Rewrite Apache logs that have incorrect dates.
# Example usage: $0 '28/May/2006:01:17:14 +0200' '19/Jan/2007:08:49:14 +0100' \
#                access_log.* error_log.*

use strict;
use warnings;

## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars)
our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }xms;
## use critic

use HTTP::Date;

my @DAYS   = qw(Sun Mon Tue Wed Thu Fri Sat);
my @MONTHS = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);

my $wrong_datetime = shift @ARGV;
my $right_datetime = shift @ARGV;

my ($timezone) = $right_datetime =~ m/ ([+-]\d\d\d\d)\z/xms;

my $seconds_diff = str2time($right_datetime) - str2time($wrong_datetime);

foreach my $file (@ARGV) {
    print "Rewriting $file\n";
    open my $IN,  '<', $file
        or die "Can't open $file: $!\n";
    open my $OUT, '>', "$file.rewritten"
        or die "Can't write to $file.rewritten: $!\n";
    while (<$IN>) {
        if (m{
               \A
               (.+\s+) # Before date and time (if any)
               \[
               (
                   \d\d/\w\w\w/\d\d\d\d # Date
                   :\d\d:\d\d:\d\d      # Time
                   \s
                   [\+\-]\d\d\d\d       # Time zone
               )
               \]
               (\s+.+) # After date and time
               \z
             }xms) {
            print {$OUT} 
              $1, q{[},
              rewrite_access_datetime($2, $seconds_diff, $timezone),
              q{]}, $3;
        }
        elsif (m{
               \A
               \[
               (
                   \w\w\w \s \w\w\w \s \d\d \s # Date
                   \d\d:\d\d:\d\d \s           # Time
                   \d\d\d\d                    # Year
               )
               \]
               (\s+.+) # After date and time
               \z
             }xms) {
            print {$OUT} 
              q{[},
              rewrite_error_datetime($1, $seconds_diff),
              q{]}, $2;
        }
        else {
            print {$OUT} $_;
        }
    }
}

sub rewrite_access_datetime {
    my ($datetime, $seconds_diff, $timezone) = @_;
    
    my ($sign, $hours, $minutes) = $timezone =~ m/\A([+-])(\d\d)(\d\d)\z/xms;
    my $seconds_offset = ($hours * 60 + $minutes) * 60;
    
    $datetime = str2time($datetime) + $seconds_diff;
    if    ($sign eq q{+}) {
        $datetime = $datetime + $seconds_offset;
    }
    elsif ($sign eq q{-}) {
        $datetime = $datetime - $seconds_offset;
    }
    
    my ($sec, $min, $hour, $mday, $mon, $year) = gmtime $datetime;
    return sprintf '%02d/%s/%04d:%02d:%02d:%02d %s',
        $mday, $MONTHS[$mon], $year + 1900, $hour, $min, $sec, $timezone;
}

sub rewrite_error_datetime {
    my ($datetime, $seconds_diff) = @_;
    
    $datetime = str2time($datetime) + $seconds_diff;
    
    my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime $datetime;
    return sprintf '%s %s %02d %02d:%02d:%02d %04d',
        $DAYS[$wday], $MONTHS[$mon], $mday, $hour, $min, $sec, $year + 1900;
}