#!/usr/bin/perl 

## CONFIGURATION SECTION:

## Hey, this file has documentation. Type `perldoc bfserve.pl` to read it.

## your nickname:
my $my_nick    = 'frodo';

## what channel to serve in:
my $channel    = '#shn';

## the location of your list:
my $list_file  = '/home/frodo/shn/frodo[12-18-2003].txt';

## a list of directories to spider when generating a new list:
my @serve_base = (
   "/home/frodo/shn/Pink Floyd",
   "/home/frodo/shn/Oasis"
);

## total max number of concurrent sends
my $num_sends  = 3;

## max queues per person:
my $max_queues = 3;

## max sends per person:
my $max_sends  = 1;

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

use File::Spec::Functions qw/rel2abs catfile/;
use File::Basename;
use File::Find;

our $VERSION = '0.10';

IRC::register("bfserve", $VERSION, "", "");
IRC::add_command_handler(status   => "status");
IRC::add_command_handler(showad   => "show_ad");
IRC::add_command_handler(loadlist => "load_list");
IRC::add_command_handler(genlist  => "gen_list");
IRC::add_command_handler(enqueue  => "manual_enqueue");
IRC::add_command_handler(saveq    => "save_queue");
IRC::add_message_handler(PRIVMSG  => "privmsg");

IRC::add_timeout_handler(5000000, "show_ad_timer");
IRC::add_timeout_handler(10000, "send_files");

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

IRC::command("/query ${my_nick}_sends");
debug("bfserve.pl loaded...");
debug("Use commands: /status /enqueue /loadlist /genlist /showad");
debug("=========================================================");

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

my $file_size;
my @queue;
my %files;

load_list($list_file);

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


sub privmsg {
    my $line = shift;
    
    my ($nick, undef, undef, undef, $chan, $msg) =
        $line =~ /^:([^!]+)!([^\@]+)\@(\S+) (PRIVMSG) (\S+) :(.+)/i;
    
    return if lc $chan ne lc $channel;
    
    if ($msg eq "\@$my_nick") {
        enqueue($nick, $list_file);
    }
    
    if (my ($file) = $msg =~ /^!$my_nick (.+)/) {
        $file =~ s/\s+\d+\.\d\dMB$//;
        $file =~ s/\s+<----.*//;
        $file =~ s/\s*$//;
        
        if (my $path = $files{$file}) {
            enqueue($nick, $path);
        } else {
            IRC::command("/notice $nick I don't know about $file, check your spelling");
        }
    
    }

    if ($msg eq "\@$my_nick-remove") {
        my $orig = @queue;
        @queue = grep { $_->{nick} ne $nick } @queue;
        
        IRC::command("/notice $nick I removed " . ($orig - @queue) . " file(s) from my queue");
    }

    if ($msg =~ /^\@$my_nick-(que(ue)?|status)$/) {
        my @s = grep { $_->{nick} eq $nick } active_sends();
        my @q = grep { $queue[$_]{nick} eq $nick } 0 .. $#queue;
        
        IRC::command("/notice $nick Currently sending you " . basename $_->{path} )
            for @s;
        
        IRC::command("/notice $nick No files queued")
            unless @q;
        
        IRC::command("/notice $nick Queued in slot " . ($_+1)
                   . ": " . basename $queue[$_]{path} )
            for @q;
    }
    
    return 0;
}


sub active_sends {
    my @dccs   = IRC::dcc_list();
    my @fields = qw/nick path receive status/;
    my @sends;
    
    ## reference: xchat-2.0.5/plugins/plugin20.html
    ## "receive" : 0-Send 1-Receive 2-ChatRecv 3-ChatSend
    ## "status" : 0-Queued 1-Active 2-Failed 3-Done 4-Connecting 5-Aborted
    
    while (@dccs) {
        my %xfer;
        @xfer{@fields} = splice @dccs, 0, 9;
        
        next if $xfer{status} == 2
             or $xfer{status} == 3
             or $xfer{status} == 5
             or $xfer{receive};
        push @sends, \%xfer;
    }
    
    return @sends;
}

sub manual_enqueue {
    my $arg = shift;
    my ($nick, $file) = split /\s+/, $arg, 2;
    
    if (my $path = $files{$file}) {
    
        my $num_queued = @queue;
    
        $max_queues += 100;
        enqueue($nick, $path, 1);
        $max_queues -= 100;
        
        debug("Unable to queue [$file] for $nick")
            if $num_queued == @queue;

    } else {
        debug("Don't know about that file! [$file]");
    }

    return 1;
}

sub save_queue {
    debug("/enqueue $_->{nick} " . basename $_->{path})
        for (active_sends(), @queue);

    return 1;
}


sub enqueue {
    my ($nick, $path, $silent) = @_;
    
    my @already_queued = grep { $_->{nick} eq $nick } @queue;
    
    if (grep { $_->{path} eq $path and $_->{nick} eq $nick }
        active_sends(), @queue) {

        IRC::command("/notice $nick That file is already queued or being sent to you")
            unless $silent;
        
    } elsif (@already_queued >= $max_queues and $path ne $list_file) {
        IRC::command("/notice $nick You already have $max_queues things queued")
            unless $silent;

    } else {
        push @queue, { nick => $nick, path => $path };
        my $file = basename $path;

        IRC::command("/notice $nick Queued your request for $file in slot " . @queue)
            unless $silent;
    }
}

sub send_files {
    my @sends = grep { $_->{path} ne $list_file } active_sends();

    IRC::add_timeout_handler(10000, "send_files");
    
    return unless @sends < $num_sends and @queue;
    
    for (0 .. $#queue) {
        my $nick = $queue[$_]{nick};
        
        my @already_sending = grep { $_->{nick} eq $nick } active_sends();
        
        next unless @already_sending < $max_sends
             or     $queue[$_]{path} eq $list_file;
    
        my $xfer = splice @queue, $_, 1;
        
        IRC::command("/notice $nick Sending you " . basename $xfer->{path} );
        IRC::command( qq[/dcc send $nick "$xfer->{path}"] );
        return;
    }
    
}

sub status {
    debug("===============");
    debug("Current Status:");
    debug("  Sending: $_->{nick} / " . basename $_->{path} )
        for active_sends();
    debug("  Queued:  $_->{nick} / " . basename $_->{path} )
        for @queue;

    return 1;
}


sub load_list {
    unless ($_[0]) {
        debug("Usage: /loadlist filename");
        return 1;
    }
    my $arg = rel2abs shift;
    my $fh;
    
    unless (open $fh, "<", $arg) {
        debug("Can't open list [$arg]: $!");
        return 1;
    }
    
    $file_size = 0;
    %files     = ();
    
    local $_;
    my $cur_dir;
    
    while (<$fh>) {
        s/\r?\n$//;
        next if /========|^\s*$/;
        
        if (-d) {
            $cur_dir = $_; next;
        }

        next unless my ($file) = /^!$my_nick (.*?)\s+\d+\.\d\dMB$/o;
        
        my $path = catfile $cur_dir, $file;
        if (-f $path) {
            debug("Warning: $file is an ambiguous filename") if $files{$file};
            
            $file_size += -s _;
            $files{$file} = $path;
        }
    }
    
    debug("Loaded " . (scalar keys %files) . " files");
    debug("Be sure to modify the script's header to point to this new list")
        if $list_file ne $arg;
        
    $list_file = $arg;
    close $fh;
    return 1;
}



sub gen_list {
    unless ($_[0]) {
        debug("Usage: /genlist filename");
        return 1;
    }
    
    my $arg = rel2abs shift;
    my $fh;
    
    unless (open $fh, ">", $arg) {
        debug("Couldn't open file [$arg]: $!");
        return 1;
    }

    my $filter = sub {
        return if /^\./;
    
        if (-d) {
            print $fh "\n==================================\n";
            print $fh "\n$File::Find::name\n\n";
            return;
        }
        return if not -r _;
    
        my $size = (-s _) / (1024 * 1024);
        
        printf $fh "%-70s %8s\n", "!$my_nick $_", (sprintf "%0.2fMB", $size);
    };

    find({
        preprocess => sub { sort @_ },
        wanted     => $filter
    }, @serve_base);

    debug("List generated successfully! [$arg]");
    close $fh;
    return 1;
}

sub channels_open {
    my @list = IRC::channel_list();
    my @channels;
    while (@list) {
        push @channels, shift @list;
        splice @list, 0, 2;
    }

    return @channels;
}

sub show_ad {
    my $curr_sends = active_sends();
    my $num_queued = @queue;
    my $num_files  = keys %files;
    my $gb         = sprintf "%0.2f", $file_size / (1024 * 1024 * 1024);
    
    my $advert =
        "Type \@$my_nick for my list, \@$my_nick-queue for stats. "
      . "Serving ${gb}GB in $num_files files. "
      . "Sends: $curr_sends/$num_sends, $num_queued queued.";

    unless (grep { $_ eq $channel } channels_open()) {
        debug("Not in channel $channel to show advert. Text would have read:");
        debug($advert);
        return 1;
    }
    
    IRC::command("/msg $channel $advert");
    return 1;
}

sub show_ad_timer {
    IRC::add_timeout_handler(5000000, "show_ad_timer");
    show_ad;
}

sub debug {
	IRC::print_with_channel(shift, "${my_nick}_sends");

	return;
}


__END__

=head1 NAME

bfserve.pl - Basic xchat2 fileserving script

=head1 SYNOPSIS

Serves files on an IRC channel using DCC. Leechers wishing to get your files
can issue the following commands in the channel:

  @nickname          - sends the leecher your list of shared files
  !nickname filename - queues the given file
  @nickname-queue    - lists files the user has in the queue
  @nickname-remove   - removes user's files from the queue

=head1 QUICK START

=over

=item *

Copy bfserve.pl into ~/.xchat2/, and edit the top section of the script
labelled "CONFIGURATION" to point to the right places, etc.

=item *

Start up xchat2 and verify that the script is loaded. It should open a debug
window called C<your_nickname_sends>. It may give an error that it cannot
open your list

=item *

Generate a new list by typing C</genlist filename>. Look at the list file it
generates and load it by typing C</loadlist filename>. If the filename is
different than the one listed in the configuration section, you will need
to edit the script to point to the new file, so it will find the correct
file next time.

=item *

Sign onto IRC, join the channel you listed in the configuration channel and
type C</showad>, you're now serving!

=item *

At any time, type /status to see a list of the current sends and queues in
the debug window.

=back

=head1 USAGE

When a user requests a file, it is added to the bottom of the queue (even
if there are open send slots). The script checks every 10 seconds to see if
there are open send slots, and sends the first valid thing in the queue.

The only exception is your list file. Presumably this file is very small, so
even if there are no send slots open, the script will still send your list
the next time it checks for things to send.

=head1 COMMANDS

=over

=item C</status>

Shows a list of the current sends and queues in the debug window.

=item C</genlist filename>

Generates a new list by spidering the directories listed in the configuration
section, and saves the list in the given file. 

=item C</loadlist filename>

This script will only serve files listed in your list! So if you have new
files to be served, they will not be served by the script until you load a new
list. This function is here since it's convenient to change list files while
running.

=item C</showad>

Manually shows your advertisement in the channel. Normally it will only be
shown at a regular interval.

=item C</enqueue nickname file>

This does the same thing as if the user with that nickname had typed
C<!your_nickname file> in the channel, it adds their request to the queue.
However, this version allows you to override the max_queue setting in the
configuration, so you can manually give someone more queue slots.

Be sure you are online before you C</enqueue> things (see below) -- the script
doesn't (yet) check before trying to send files.

=item C</saveq>

This prints a corresponding C</enqueue> line for each person in the current
list of sends and queues. You can copy this text, if you need to restart
xchat and come back while keeping queues intact. Just paste the /enqueue
commands back when you return -- the sends will resume and the queue will
remain as it was.

=back

=head1 CAVEATS

=over

=item *

Some things require a restart of xchat2.

=item *

Probably some bugs here and there, and a lot fewer features than other scripts.

=item *

Sends aren't instantaneous when there are open slots, they are queued and
then sent after some delay.

=item *

Not a lot of error checking to make sure we are online before sending, etc.

=item *

We don't keep track of users leaving or changing nicknames.

=back

=head1 AUTHOR

bfserve.pl is written by Mike Rosulek E<lt>mike@mikero.comE<gt>. Feel free to
contact me with comments, questions, patches, or whatever.

=head1 COPYRIGHT

Copyright (c) 2003 Mike Rosulek. All rights reserved. This module is free 
software; you can redistribute it and/or modify it under the same terms as Perl 
itself.