encryptio.com

#!/usr/bin/perl
#############################################################################
# torsort.pl - Automated sorting of bittorrent metainfo files, and other
# files too.
# The latest version of this can be found at:
# http://encryptio.com/code/torsort
#############################################################################
# Copyright (c) 2007-2008 Chris Kastorff
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are
# met:
#
#     * Redistributions of source code must retain the above copyright
#       notice, this list of conditions, and the following disclaimer.
#     * Redistributions in binary form must reproduce the above copyright
#       notice, this list of conditions and the following disclaimer in the
#       documentation and/or other materials provided with the distribution.
#     * The name Chris Kastorff may not be used to endorse or promote
#       products derived from this software without specific prior written
#       permission.
#############################################################################
use warnings;
use strict;

our $VERSION = 0.3;

use Bencode qw/ bdecode /;

my %section_paths = (
    tv      => $ENV{HOME}."/p2p/bittorrent/enabled/tv",
    public  => $ENV{HOME}."/p2p/bittorrent/enabled/public",
    usenet  => $ENV{HOME}."/p2p/usenet/nzb/queue",
);


my $MAX_FILE_SIZE = 1024*1024; # 1 mb, only applies to files that are read

my $default_files = # passed to glob()
    join(" ", quotemeta($ENV{HOME})."/p2p/http/*", quotemeta($ENV{HOME})."/Desktop/*");

sub torrent_run_rules {
    my ($filename, $decoded) = @_;
    my $announce = exists $decoded->{'announce'} ? $decoded->{'announce'} : "";
    return "tv"      if $filename =~ /\bs\d{1,2}e\d{2,3}\b|\D\d{1,2}x\d{1,3}\D/i;
    return "public"  if $announce =~ host_regex("legaltorrents.com");
    return undef;
}

sub host_regex {
    my ($partialhost) = @_;
    return qr/^http:\/\/(?:[^\/]+\.)?\Q$partialhost\E(?::\d+)?\//i;
}

###############################################################################

sub after_last_slash { my $t = ($_[0] =~ /\/([^\/]+)$/)[0]; defined $t ? $t : $_[0] }

my %types = (
    ".torrent" => sub {
        my ($file) = @_;
        if ( -s $file > $MAX_FILE_SIZE ) {
            warn "    Skipping because of size limitation\n";
            return undef;
        }

        # slurp contents
        open my $lf, "<", $file
            or do { warn "    Couldn't open file for reading: $!\n"; return undef; };
        my $content = do { local $/; <$lf> };
        close $lf;
        
        my $bdec = bdecode($content);
        unless ( defined $bdec ) {
            warn "    Badly encoded data in file\n";
            return undef;
        }
        
        # get the section to place the file in
        my $section = torrent_run_rules($file, $bdec);
        unless ( defined $section ) {
            warn "    Couldn't figure out where to put the file.\n";
            return undef;
        }
        
        unless ( exists $section_paths{$section} ) {
            die "    Don't know where the \"$section\" section is.\n";
        }

        return $section_paths{$section};
    },
    ".nzb" => sub {
        return $section_paths{"usenet"};
    },
);

for my $file ( @ARGV ? @ARGV : glob($default_files) ) {
    for my $type ( keys %types ) {
        if ( $file =~ /\Q$type\E$/i ) {
            print "Processing $file with $type...\n";

            my $dir = $types{$type}->( $file );
            next unless defined $dir;
            
            # just move the thing already!
            my $target = $dir."/".after_last_slash($file);
            print "    -> $target\n";
            open my $lf, "<", $file
                or die "Couldn't open $file for reading: $!\n";
            open my $sf, ">", $target
                or warn("Couldn't open $target for writing: $!\n"), next;
            print $sf $_ while <$lf>;
            close $lf;
            close $sf;
            unlink $file or die "Couldn't remove $file: $!\n";
        }
    }
}

__END__

Version history:

0.3:
    * Added support for "torsort file" without slashes.

0.2:
    * Moved from homegrown BEncode::Fast to Bencode.pm by CPAN user aristotle

0.1:
    * Initial Release