Know How
Programming
Other things about Perl (German language):
permalink.de/tino/perl
Perl
Here are some code snippets for Perl. They are from my
tinolib, but the current version of this lib has not yet been released, so they are here for convenience. tinolib may contain more recent version, or they may be here, as chaos strikes.
Mostly they are Public Domain, as it's just too simple to claim a real copyright for this.
renamer.pl
Renames files, directories or special files into a name after a timestamp.
Download
renamer.pl (as the text below may be clobbered by Bamboo!)
#!/usr/bin/perl
# $Header: /CVSROOT/tinolib/perl/renamer.pl,v 1.2 2006/03/22 10:33:44 tino Exp $
#
# Copyright (C)2006 by Valentin Hilbig, webmaster@scylla-charybdis.com
#
# This file is dedicated into the Public Domain
# as long as you do not claim a copyright on this.
# (You can remove my copyright but you must make sure that nobody adds another.)
#
# $Log: renamer.pl,v $
# Revision 1.2 2006/03/22 10:33:44 tino
# rename only to non-existing destinations
# (sort of, this is non-atomic, sorry.)
#
# Revision 1.1 2006/03/22 10:04:27 tino
# created
if ($#ARGV < 2) {
print STDERR "Usage: $0 prefix .suffix name...\n";
print STDERR "\tRename the name to prefixYYMMDD-HHMMSS-NNN.suffix\n";
print STDERR "\tThis works on files, diectories or special names\n";
print STDERR "\tIf the destination does not exist this is atomic\n";
print STDERR "\tCaution: It moves the files to the current directory.\n";
print STDERR "\t\tThis may or may not work across drives.\n";
print STDERR "\tIt skips missing names but it stops on the first error.\n";
print STDERR "\tIn rare conditions it may overwrite existing destinations\n";
exit(1);
}
my $prefix=@ARGV[0];
shift @ARGV;
my $suffix=@ARGV[0];
shift @ARGV;
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
$count=0;
for (@ARGV) {
if ( ! -e $_ ) {
print "skipped missing $_\n";
} else {
do {
$out = sprintf("%s%04d%02d%02d-%02d%02d%02d-%03d%s", $prefix, 1900+$year, 1+$mon, $mday, $hour, $min, $sec, $count, $suffix);
$count++;
} while (-e $out);
die "$_: cannot rename to $out" unless rename($_,$out);
print "renamed $out from $_\n";
}
}
mover.pl
Moves files across drive boundaries.
Download
mover.pl (as the text below may be clobbered by Bamboo!)
#!/usr/bin/perl
# $Header: /CVSROOT/tinolib/perl/mover.pl,v 1.2 2006/03/22 10:53:16 tino Exp $
#
# Copyright (C)2006 by Valentin Hilbig, webmaster@scylla-charybdis.com
#
# This file is dedicated into the Public Domain
# as long as you do not claim a copyright on this.
# (You can remove my copyright but you must make sure that nobody adds another.)
#
# $Log: mover.pl,v $
# Revision 1.2 2006/03/22 10:53:16 tino
# forgot to remove some debugging output
#
# Revision 1.1 2006/03/22 10:41:17 tino
# added
#
use File::Copy;
if ($#ARGV != 2) {
print STDERR "Usage: $0 destdir sourcedir regexp\n";
print STDERR "\tMoves matching files from sourcedir to destdir.\n";
print STDERR "\tIf it cannot rename it moves by copying.\n";
print STDERR "\tCAUTION: Existing destinations are overwritten!\n";
print STDERR "\t\tThe last arg is no filename, it's a regexp!\n";
print STDERR "\t\tSo escape dots, like in '\\.log\$' (files ending in .log)\n";
print STDERR "\t\tAlso a*.* is wrong, correct is '^a.*\\..*\$' (or '^a.*\\.')\n";
print STDERR "\tThis is not atomic, see renamer.pl for atomic actions.\n";
exit(1);
}
my $dest=@ARGV[0];
my $source=@ARGV[1];
my $match=@ARGV[2];
die "dir not found $source" unless opendir SRC,$source;
my @files = grep { /$match/ && -f "$source/$_" } readdir(SRC);
die "dir error $source" unless closedir(SRC);
for (@files) {
die "cannot move $_ from $source to $dest" unless move("$source/$_","$dest/$_");
print "$_\n";
}
logcatter.pl
Outputs parts of rotated logfiles to be able to extract some days or so. The names must be named regularily, like renamer.pl above does.
Download
logcatter.pl (as the text below may be clobbered by Bamboo!)
#!/usr/bin/perl
# $Header: /CVSROOT/tinolib/perl/logcatter.pl,v 1.1 2006/03/22 12:17:07 tino Exp $
#
# Copyright (C)2006 by Valentin Hilbig, webmaster@scylla-charybdis.com
#
# This file is free software according to the GNU GPL v2 or higher.
# Use at own risk!
#
# $Log: logcatter.pl,v $
# Revision 1.1 2006/03/22 12:17:07 tino
# This version is nearly untested
#
use File::Basename;
use File::Spec::Functions;
if ($#ARGV < 1) {
print STDERR "Usage: $0 prefix directory file...\n";
print STDERR "\tThe idea is to get a snippet from a rotating logfile:\n";
print STDERR "\tAll files are sorted by their name, except for the last file.\n";
print STDERR "\tThe last given file stays the last file, ever.\n";
print STDERR "\tThen hunt for (possibly) empty list matching prefix and\n";
print STDERR "\tcat the files just before and behind, too, in sequence.\n";
exit(1);
}
my $prefix=@ARGV[0];
shift @ARGV;
my %list;
my $last="";
for (@ARGV) {
if ( -d $_ ) {
my $dir = $_;
die "cannot open dir $dir" unless opendir SRC,$dir;
my @files = grep { -f "$dir/$_" } readdir(SRC);
die "dir error $dir" unless closedir(SRC);
$list{$_}=catfile($dir,$_) for (@files);
} elsif ( -f $_ ) {
$list{basename($last)}=$last if $last ne "";
$last = $_;
}
}
sub cat {
my ($fn)=@_;
# print STDERR "out $fn\n";
die "cannot read $fn" unless open INP, $fn;
print $_ while (<INP>);
die "cannot close $fn" unless close INP;
}
$was = "";
for (sort keys %list) {
my $fi=$_;
# print STDERR "in $fi\n";
if ($fi lt $prefix) {
$was = $list{$fi};
next;
}
if ($was ne "") {
cat($was);
$was="";
}
if (substr($fi,0,length($prefix)) ne $prefix) {
$last = $list{$fi};
last;
}
cat($list{$fi});
}
#print STDERR "last\n";
cat($last) if $last ne "";
