Copy files by date modified
on Jun 04, 2009 at 03:19
|
3 replies
|
by svetho
|
Yesterday I came across a problem to sync files between two computers in a network, but only those that had been created or modified within the last 60 days. Unfortunately rsync doesn't come with such a functionality (or it doesn't seem to - maybe I've overlooked something). It could well be that I've gone to work in a more complicated manner than necessary but I couldn't come up with anything better.
So I took the extra step to copy the files that need to be synchronised to a temporary directory, preserving the original directory structure. Then the files can be effortlessly synced with rsync.
Maybe this will come in handy for somebody else.
#!/usr/bin/perl
use strict;
use warnings;
use File::Path;
use File::Basename;
use File::Spec;
use File::Copy;
use Cwd;
use Getopt::Long;
# make output unbuffered
$| = 1;
my $path = getcwd;
my $mtime = 1;
my $dest;
my $verbose = '';
my $showhelp = '';
my $result = GetOptions("source=s" => \$path,
"mtime=i" => \$mtime,
"dest=s" => \$dest,
"help" => \$showhelp,
"verbose" => \$verbose);
# DEBUG
# print "\$path = $path\n\$mtime = $mtime\n\$dest = $dest\n\$showhelp
+= $showhelp\n\$verbose = $verbose\n";
# exit(0);
my $usage = "Usage: $0 --dest <destination-path>\n\t" .
"[--source <source-path> | --mtime <mtime> | --verbose] [
+--help]\n\t" .
"Type $0 --help for more information.";
my $help = <<EOHELP;
$0 - Copy file hierarchies selectively
based on their modification times
Options:
-s | --source=SourceDir Source path. Default: pwd
-m | --mtime mtime (see man find). Default: 1
-d | --dest=DestDir Destination path. Mandatory option.
-h | --help Print this help screen.
-v | --verbose Be more verbose. Default: false
EOHELP
if ($showhelp) {
print $help;
exit(0);
}
unless ($dest) {
die "$usage\n";
}
# remove trailing slash from $dest
$dest =~ s/\/$//;
my $find = "find $path -type f -mtime -$mtime";
my @files = `$find`;
my %dirs_created;
foreach (@files) {
# debug
print;
chomp;
s/^\.\///;
my ($filename, $directories, $suffix) = fileparse($_);
my $new_dir = File::Spec->canonpath(File::Spec->catdir($dest, $dir
+ectories));
unless (exists $dirs_created{$new_dir}) {
$dirs_created{$new_dir} = mkpath($new_dir);
print "Created $new_dir\n" if $verbose;
}
copy($_, File::Spec->catfile($new_dir, "$filename$suffix"));
print File::Spec->catfile($new_dir, "$filename$suffix") . "\n" if
+$verbose;
}
exit(0);
|
Change Image File Timestamp to Match EXIF Data
on Jun 01, 2009 at 03:10
|
6 replies
|
by shoness
|
I catalog images by the date each was taken. My camera timestamps its images with the date/time. Perfect!
However, when I later "modify" an image, or when I transfer it over BlueTooth, etc. the "Date Modified" for the file changes.
I use this little script to change the atime/mtime for the image file BACK to where it should be.
All the action is inside Image::ExifTool, nevertheless, I welcome your feedback!
UPDATE: Added error checking.
#!/usr/bin/perl
use warnings;
use strict;
use Time::Local;
use Image::ExifTool qw(:Public);
my $exifTool = new Image::ExifTool;
foreach my $file (@ARGV) {
# Read only the "DateTimeOriginal" tag from the file.
my $info = $exifTool->ImageInfo($file, 'DateTimeOriginal');
# Error Handling
if (defined $exifTool->GetValue('Error')) {
print "ERROR: Skipping '$file': " . $exifTool->GetValue('Error') .
+ "\n";
next;
}
if (not exists $info->{'DateTimeOriginal'}) {
warn "File '$file' has no EXIF 'DateTimeOriginal' tag. Skipping it
+.\n";
next;
}
if (defined $exifTool->GetValue('Warning')) { # Can there be a warn
+ing?
print "Warn: Processing '$file': " . $exifTool->GetValue('Warning'
+) . "\n";
}
# I suppose we could still check to make sure the data is "reasonabl
+e".
# There could be garbage data in the DateTimeOriginal field and we'd
+ be
# in trouble...
# Our data comes in the form "YEAR:MON:DAY HOUR:MIN:SEC".
# utime() wants data in the exact opposite order, so we reverse().
my @date = reverse(split(/[: ]/, $info->{'DateTimeOriginal'}));
# Note that the month numbers must be shifted: Jan = 0, Feb = 1
--$date[4];
# Convert to epoch time format
my $time = timelocal(@date);
# Make the change to the mtime and atime
my $status = utime($time, $time, $file);
if ($status != 1) {
print "Warn: utime() on '$file' returned $status instead of 1.\n";
}
}
__END__
=head1 SYNOPSYS
Reads the "DateTimeOriginal" EXIF field out of an image file
and changes the "last accessed time" and "last modified time"
of the file to match it.
=head1 USAGE
On Unix:
thisfile.pl *.jpg another/dir/*.jpg
On Windows:
perl thisfile.pl bunch.jpg of.jpg files.jpg
Everything you give to this file is expected to be a filename.
It accepts no other switches or arguments.
=cut
|
multiple file operations using perl one-liners
on May 17, 2009 at 15:12
|
3 replies
|
by sflitman
|
Sometimes you have a really repetitive task to do on a bunch of files. Sound familiar? You first need to specify the files, then you need to do the same operation on each one. The shell's traditional pipeline can nicely collect the paths, and then use the perl one-liner to do the operation.
Real life example: I needed to identify all the zipfiles in a directory tree and delete all *.exe files hiding inside the zipfiles.
First collect the files:
du -b */*/old.zip | sort -n | xcol 1 >oldfiles
This shows all the zipfiles that were in subdirectories of subdirectories, then sorts them for size so I can decide to leave out the small ones. xcol is a perl script I posted to Code section to extract the column of filenames to file oldfiles.
Then use this perl one-liner:
perl -e 'while (<>) { chop; system qq{zip -d "$_" "*exe*"} }' oldfiles
Love that Perl!
HTH,
SSF
|
Net::Syslog Patch
on Apr 29, 2009 at 15:36
|
0 replies
|
by VinsWorldcom
|
I've been doing a little work coding a Syslog message receiver and needed a Syslog message sender to test with. I used Net::Syslog and it did the trick but it is a bit "lean". I updated it to generate Syslog messages according to RFC 3164 format. This is the patch.
Updated: 12-Jun-2009
Reference: http://rt.cpan.org/Public/Bug/Display.html?id=46898
--- Syslog.pm Mon Apr 27 13:18:10 2009
+++ Syslog.pm Fri Jun 12 15:22:49 2009
@@ -2,6 +2,7 @@
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use IO::Socket;
+use Sys::Hostname;
require Exporter;
@@ -12,35 +13,51 @@
@EXPORT = qw(
);
-$VERSION = '0.03';
+$VERSION = '0.04';
# Preloaded methods go here.
my %syslog_priorities=(
emerg => 0,
+ emergency => 0,
alert => 1,
crit => 2,
+ critical => 2,
err => 3,
+ error => 3,
warning => 4,
notice => 5,
info => 6,
+ informational => 6,
debug => 7
);
my %syslog_facilities=(
kern => 0,
+ kernel => 0,
user => 1,
mail => 2,
daemon => 3,
+ system => 3,
auth => 4,
+ security => 4,
syslog => 5,
+ internal => 5,
lpr => 6,
+ printer => 6,
news => 7,
uucp => 8,
cron => 9,
+ clock => 9,
authpriv=> 10,
+ security2 => 10,
ftp => 11,
+ FTP => 11,
+ NTP => 12,
+ audit => 13,
+ alert => 14,
+ clock2 => 15,
local0 => 16,
local1 => 17,
local2 => 18,
@@ -48,8 +65,10 @@
local4 => 20,
local5 => 21,
local6 => 22,
+ local7 => 23
);
+my @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
sub new{
my $class = shift;
@@ -59,7 +78,7 @@
}
my $self = { Name => $name,
Facility => 'local5',
- Priority => 'err',
+ Priority => 'error',
SyslogPort => 514,
SyslogHost => '127.0.0.1'};
bless $self,$class;
@@ -80,18 +99,21 @@
}
my $pid=$$;
- my $facility_i=$syslog_facilities{$local{Facility}};
- my $priority_i=$syslog_priorities{$local{Priority}};
-
- if(!defined $facility_i){
- $facility_i=21;
- }
- if(!defined $priority_i){
- $priority_i=4;
- }
+ my $facility_i = $syslog_facilities{$local{Facility}} || 21;
+ my $priority_i = $syslog_priorities{$local{Priority}} || 3;
my $d=(($facility_i<<3)|($priority_i));
- my $message = "<$d>$local{Name}\[$pid\]: $msg";
+
+ my $host = inet_ntoa((gethostbyname(hostname))[4]);
+ my @time = localtime();
+ my $ts = $month[$time[4]] . " " . (($time[3] < 10)?(" " . $time[3
+]):$time[3]) . " " . (($time[2] < 10)?("0" . $time[2]):$time[2]) . ":
+" . (($time[1] < 10)?("0" . $time[1]):$time[1]) . ":" . (($time[0] <
+10)?("0" . $time[0]):$time[0]);
+ my $message = '';
+
+ if ($local{rfc3164}) {
+ $message = "<$d>$ts $host $local{Name}\[$pid\]: $msg"
+ } else {
+ $message = "<$d>$local{Name}\[$pid\]: $msg"
+ }
my $sock=new IO::Socket::INET(PeerAddr => $local{SyslogHost},
PeerPort => $local{SyslogPort},
@@ -133,18 +155,22 @@
Name <calling script name>
Facility local5
- Priority err
+ Priority error
SyslogPort 514
SyslogHost 127.0.0.1
Valid Facilities are:
- kern, user, mail, daemon, auth, syslog, lpr, news, uucp, cron,
- authpriv, ftp, local0, local1, local2, local3, local4, local5, lo
+cal6
+ kernel, user, mail, system, security, internal, printer, news,
+ uucp, clock, security2, FTP, NTP, audit, alert, clock2, local0,
+ local1, local2, local3, local4, local5, local6, local7
Valid Priorities are:
- emerg, alert, crit, err, warning, notice, info, debug
-
+ emergency, alert, critical, error, warning, notice, informational
+,
+ debug
+Use:
+ rfc3164 => 1
+to enable RFC 3164 messages including timestamp and hostname.
=head1 AUTHOR
|
torf or Mindy?
on Apr 29, 2009 at 11:11
|
1 reply
|
by metaperl
|
Well, oftentimes when pulling data from somewhere, you will need to humanize booleans... not everyone is a Mork from Ork!
sub torf {
my($val, $true_word, $false_word)=@_;
$true_word ||= 'Yes' ;
$false_word ||= 'No' ;
$val ? $true_word : $false_word ;
}
|
Get a structured tally of XML tags
on Apr 23, 2009 at 21:42
|
0 replies
|
by graff
|
Get a quick snapshot of the quantity and structure of elements in an XML file -- useful for getting acquainted with some new XML source, or for confirming expectations about XML data you created. (Yes, it is worthwhile to use XML::Parser in a one-liner...)
perl -MXML::Parser -le '$p=XML::Parser->new(
Handlers=>{Start=>sub{$k.=".$_[1]";$h{$k}++},
End=>sub{$k=~s/.$_[1]$//;}});
$p->parsefile(shift);
END{print "$h{$_}\t$_" for (sort keys %h)}' some_file.xml
(Line-breaks added for legibility; the first time I did this, it really was all on one line -- honest!)
|
On-disk hash/array data structures
on Apr 16, 2009 at 16:33
|
0 replies
|
by repellent
|
Please note that there are already modules that do this: DBM::Deep and MLDBM come to mind.
Here are a couple of drop-in functions to return a hash or array reference to a temporary DB_File. Not really a new idea - just had to be put together for ease.
This serves as a useful hack if we wanted our large data structure to be on-disk instead of in-memory. Remember to untie the references when done using them.
- Use db_ref() to generate a new hash/array reference.
- Use db_open_ref() to open an existing DB_File.
use warnings;
use strict;
use Data::Dumper;
my $h1 = db_ref("HASH");
my $h2 = db_ref("HASH");
$h1->{hello} = { 123 => 456, 789 => [ 3, 4, 5 ] };
$h1->{crazy} = 747;
$h2->{world} = [ 5, 6, 7, $h1->{hello} ];
print "key> $_\n" for keys %{ $h1 };
print Dumper($h2->{world});
untie %{ $h1 };
untie %{ $h2 };
my $a = db_ref("ARRAY", 1); # no serialization
push @{ $a }, 1..4;
print "item> $_\n" for @{ $a };
untie @{ $a };
sub db_ref {
my $type = shift() || "HASH"; # "HASH" = DB_HASH
# "BTREE" = DB_BTREE
# others = DB_RECNO
my $simple_db = shift(); # set true to disable serialized DB
my $keep_db = shift(); # set true to not remove DB upon exit
# optional 4th arg = CODE ref for filter_store_value()
# optional 5th arg = CODE ref for filter_fetch_value()
require File::Temp;
require File::Spec;
# create temporary file
(undef, my $filename) = File::Temp::tempfile(
File::Spec->catfile(
File::Spec->tmpdir(),
substr($type, 0, 1) . "_XXXXXX",
),
UNLINK => !$keep_db,
);
# open new DB with temporary file
return db_open_ref($filename, $type, $simple_db, @_);
}
sub db_open_ref {
my $filename = shift();
my $type = shift() || "HASH";
my $simple_db = shift();
# optional 4th arg = CODE ref for filter_store_value()
# optional 5th arg = CODE ref for filter_fetch_value()
return () unless defined($filename);
require DB_File;
require Fcntl;
# determine database type
my $db_type;
{
no warnings qw(once);
$db_type = $type eq "HASH"
? $DB_File::DB_HASH
: $type eq "BTREE"
? $DB_File::DB_BTREE
: $DB_File::DB_RECNO;
}
# return tied hash/array reference to database
my $db_ref;
my $db = tie(
($type eq "HASH" || $type eq "BTREE"
? %{ $db_ref }
: @{ $db_ref }
),
"DB_File",
$filename,
Fcntl::O_RDWR() | Fcntl::O_CREAT(),
0600,
$db_type,
) or return ();
# add DB filters to serialize complex data structures
unless ($simple_db)
{
require Storable unless @_ >= 2;
$db->filter_store_value(shift() || sub { $_ = Storable::freeze
+(\$_) });
$db->filter_fetch_value(shift() || sub { $_ = ${ Storable::tha
+w($_) } });
}
undef $db; # avoid untie() gotcha
return $db_ref;
}
|
Win32 BrowseForFolder
on Apr 05, 2009 at 09:01
|
0 replies
|
by nikosv
|
Win32 BrowseForFolder.
Creates a dialog box that enables the user to select a folder.
This small procedure is part of a larger programm that lets you choose a directory and manipulate its contents i.e combines nicely with File::Find
use Win32::API;
use Cwd;
sub choose_dir {
$SHBrowseForFolder=new Win32::API('shell32.dll','SHBrowseForFolder
+','P','N');
$SHGetPathFromIDList=new Win32::API('shell32.dll','SHGetPathFromID
+List','NP','N');
my $display="CHOOSE starting directory...";
my $BrowseInfo=pack('LLLpLLLL',0,0,0,$display,0,0,0,0,0);
my $pidl=$SHBrowseForFolder->Call($BrowseInfo);
my $dir=pack('x100');
$SHGetPathFromIDList->Call($pidl,$dir);
$dir =~ s/\0//g;
chdir $dir;
print "current dir: ",cwd();
}
choose_dir;
|
Net::Telnet::Cisco and IOS-XR
on Mar 19, 2009 at 16:01
|
2 replies
|
by VinsWorldcom
|
Cisco IOS-XR introduces a new prompt format that is "breaking" Net::Telnet::Cisco. Basically, the Route Processor and CPU instance is added with a colon ":" before the router hostname. I was wondering why my Telnet sessions were "failing" but the logs showed they connected and got the prompt.
I looked for an update to Net::Telnet::Cisco, but the latest version I could find was 1.10, which is what I have installed. To get around this, I used the -prompt option when calling Net::Telnet::Cisco->new() from my script.
Under the "sub new" procedure in Cisco.pm, I found the existing prompt regex (you can't miss it). I copied that code and added the new piece and passed that in when I make the Net::Telnet::Cisco->new() call via the "-prompt" option. (See Net::Telnet for more info.)
All we're doing is adding a check for the Route Processor and CPU instance and colon before the hostname - optionally, so we don't break what's currently working. This is done with the addition of:
(?:[\w.\/]+\:)?
near the beginning of the existing regex.
use Net::Telnet::Cisco;
...
my $session = Net::Telnet::Cisco->new(
...
-prompt => '/(?m:^(?:[\w.\/]+\:)?[\w.-]+\s?(?:\(config[^\)]*\))?\s
+?[\$#>]\s?(?:\(enable\))?\s*$)/'
...
)
|
tree-oriented use of HTML::FillInForm
on Mar 13, 2009 at 13:26
|
0 replies
|
by metaperl
|
I repeat my bug report:
Not all templating systems are string-oriented. HTML::Seamstress is not.
It works with HTML::Element instances.
As such, it would be nice if the result of filling in the form could be
returned as a tree for further processing by HTML::Element methods.
As it stands, I am forced to parse the results of HTML::FillInForm back
into a tree (even though it was a tree before HTML::FillInForm
stringified it).
Now, just consider how much is being done.
- seamstress has an HTML tree that it wants the form filled in on
- seamstress converts this to a string
- FillInForm parses the string into an HTML tree and then fills in the form
- FillInForm converts the HTML tree to a string
- seamstress re-parses the HTML for additional processing
If FillInForm could receive and return trees, my apps would be much faster.
For the time being, I at least need to turn this multiline process into a single function call, so here it is.
Of course,
# https://rt.cpan.org/Ticket/Display.html?id=44105
sub tree_fillinform {
my ($tree, $hashref)=@_;
my $html = $tree->as_HTML;
my $new_html = HTML::FillInForm->fill(\$html, $hashref);
HTML::TreeBuilder->new_from_content($new_html);
}
|
|