encryptio.com

#!/usr/bin/perl
#############################################################################
# btmkt.pl - Create bittorrent metafiles (torrents)
# The latest version of this can be found at:
# http://encryptio.com/code/btmkt
#############################################################################
# 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;
$| = 1;

our $VERSION = 0.16;

BEGIN {
    # load sha1() from either Digest::SHA or Digest::SHA1
    eval { require Digest::SHA; Digest::SHA->import( "sha1" ) };
    if ( $@ ) {
        eval { require Digest::SHA1; Digest::SHA1->import( "sha1" ) };
        if ( $@ ) {
            die "Couldn't load sha1() from Digest::SHA or Digest::SHA1. Please install one or both of these modules."
        }
    }
}

use File::Find qw/ find /;
use List::Util qw/ sum /;

sub help {
    print <<EOF;
$0: Create a bittorrent metainfo file.
Usage:
    $0 [-private] http://announce/url path/to/file/or/folder

The -private option creates adds the "private" flag to the torrent
for

EOF
}

sub info {
    my ($path) = @_;
    my $info = { };
    $info->{'name'} = lastpath($path);
    if ( -d $path ) {
        # many-file torrent
        
        my @paths;
        find( { wanted => sub {
                    return unless -f $_; # only files
                    my $name = $File::Find::name;
                    $name =~ s/\/+$//;
                    $name =~ s/^\Q$path\E\/?//;
                    return if $name =~ /^\./
                           or lc($name) eq "thumbs.db";
                    push @paths, $name;
                }, follow => 1 }, $path );
        
        # nice and clean for the exporters.
        @paths = sort { lc($a) cmp lc($b) } @paths;

        # turn the file listing into the proper final format
        my @files = map {
                my $filename = $_;
                my $length = -s "$path/$_";
                my $path = [ split /\//, $_ ];
                { 'length' => $length, path => $path }
            } @paths;

        my $total_size = sum map $_->{'length'}, @files;
        my $piece_size = best_piece_size( $total_size );
        my $pieces = make_hashes( $path, $piece_size, $total_size, @paths );

        # and throw it into the structure
        $info->{'files'} = \@files;
        $info->{'piece length'} = $piece_size;
        $info->{'pieces'} = $pieces;
    } else {
        # single-file
        my $total_size = -s $path;

        my $base = ($path =~ /^\// ? '/' : '.');
        my $piece_size = best_piece_size( $total_size );
        my $pieces = make_hashes( $base, $piece_size, $total_size, $path );

        $info->{'piece length'} = $piece_size;
        $info->{'pieces'} = $pieces;
        $info->{'length'} = $total_size;
    }
    return $info;
}

sub make_hashes {
    my ($basepath, $piece_size, $maxsize, @paths) = @_;
    my $currentpos = 0;
    my $buffer = '';

    my @hashes = (); # returned data - using array here to avoid needless copying
    
    FILE: while ( @paths ) {
        my $current = shift @paths;
        open my $lf, "<", "$basepath/$current"
            or die "Couldn't open $basepath/$current for reading: $!";

        READLOOP: while ( not eof($lf) ) {
            # while there's data in the file, read the next piece data
            my $len = read $lf, $buffer, $piece_size-length($buffer), length($buffer);

            if ( eof($lf) and length($buffer) != $piece_size ) {
                # incomplete piece spanning multiple files - read from the next
                next FILE;
            }

            if ( length($buffer) == $piece_size ) {
                # complete piece
                push @hashes, sha1($buffer);
                $buffer = '';
                $currentpos += $piece_size;
                show_progress( "hashing", $currentpos, $maxsize );
            }
        }
        close $lf;
    }

    if ( length($buffer) ) {
        # incomplete ending piece
        push @hashes, sha1($buffer);
        $buffer = '';
    }

    return join '', @hashes;
}

sub best_piece_size {
    my ($totalbytes) = @_;
    my $size = 2**16; # 64 KiB minimum starting point
    
    $size *= 2 while                   # double it while
        $totalbytes / $size > 1500     # the number of pieces is over 1500.
        and not ($size >= 1024*1024*4) # but keep the piece size under or equal to 4 megs
    ;

    return $size;
}

sub lastpath {
    my ($wholepath) = @_;
    $wholepath =~ s/\/+$//; # trim trailing slashes
    $wholepath =~ s/^.+\///; # greedy, takes all up to the last /
    return $wholepath;
}

{
    my $last_showed = time;
    sub show_progress {
        my ($operation, $cur, $end) = @_;
        return if time() - $last_showed < 1;
        $last_showed = time;
        
        # not using a printf() here because of integer overflows
        my $pctformat = sprintf "%.2f", $cur/$end*100;
        print "\r".$operation." ".$cur."/".$end." (".$pctformat."%)\033[K\r";
    }
}

sub bencode {
    my ($o) = @_;
    return undef if not defined $o;
    my $r = ref $o;
    if ( $r eq "HASH" ) {
        return "d".join("", map { bencode($_).bencode($o->{$_}) } sort keys %$o)."e";
    } elsif ( $r eq "ARRAY" ) {
        return "l" . join("", map bencode($_), @$o) . "e";
    } elsif ( $r ) {
        die "Can't bencode a $r reference.";
    } else {
        if ( $o =~ /^-?\d+$/i ) { # dumb herustic
            return "i".$o."e";
        } else {
            return length($o).":".$o;
        }
    }
}

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

my ($announceurl, $path, $private);
$private = 0;

if ( @ARGV == 2 ) {
    $announceurl = shift @ARGV;
    $path = shift @ARGV;

} elsif ( @ARGV == 3 ) {
    help, die "Bad argument.\n" unless $ARGV[0] eq "-private";
    shift @ARGV; # -private
    $private = 1;
    $announceurl = shift @ARGV;
    $path = shift @ARGV;

} else {
    # wrong number of arguments
    help;
    if ( @ARGV ) {
        die "Wrong number of arguments.\n";
    } else {
        exit 1; # stop without a message
    }
}

help, die "Bad announce url.\n"
    if $announceurl !~ /:\/\//; # all sane urls have "://" in them
help, die "Bad path: doesn't exist.\n"
    unless -e $path;
die "$path.torrent already exists! I won't overwrite it.\n"
    if -e "$path.torrent";

my $torrent = {
    info => info($path),
    announce => $announceurl,
    'created by' => 'btmkt.pl v'.$VERSION,
    'creation date' => int(time),
};

$torrent->{'info'}->{'private'} = 1
    if $private;

# encode and write it out to the file
$path =~ s/[\/\s]*$//;
open my $sf, ">", $path.".torrent"
    or die "Couldn't open $path.torrent for writing: $!";
print $sf bencode($torrent);
close $sf;

print "\r\033[K"; # clear the line

__END__
Revision history:

0.16:
    * Sort names before creating torrent - cleaner for external programs that
      deal with humans.

0.15:
    * Added a couple of explanatory comments and whitespace
    * Unified make_hashes_many and make_hashes_single into one function

0.14:
    * Really skipped Thumbs.DB

0.13:
    * Skipped Thumbs.DB

0.12:
    * Added "creation date" field.

0.11:
    * Adjusted best_piece_size to try to keep the piece size <= 4 megs at all
      times.

0.1:
    * Initial release.