#!/usr/local/bin/perl -w # # nzbperl.pl -- version 0.6.8 # # for more information: # http://noisybox.net/computers/nzbperl/ # ######################################################################################### # Copyright (C) 2004 jason plumb # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ######################################################################################### use strict; use File::Basename; use IO::File; use IO::Select; use XML::DOM; use Getopt::Long; use Time::HiRes; # timer stuff use Term::ReadKey; # for no echo password reading use Term::Cap; use Cwd; my $version = '0.6.8'; my $ospeed = 9600; my $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed }; my $recv_chunksize = 5*1024; # How big of chunks we read at once from a connection (this is pulled from ass) my $UPDATE_URL = 'http://noisybox.net/computers/nzbperl/nzbperl_version.txt'; my $dispchunkct = 250; # Number of data lines to read between screen updates. my $targkBps = 0; my ($medbw, $lowbw) = (95, 35); # Defaults for low and medium speed settings. my $sleepdur = 0; # Used when throttling # Make stdout not buffered. my $old_fh = select(STDOUT); $| = 1; select($old_fh); my $quitnow = 0; my $showinghelpscreen = 0; my $skipthisfile = 0; my $usecolor = 1; my $logfile; # These are getting hefty, so they're now 5 per line my ( $server, $port, $user, $pw, $keepparts, $keepbroken, $keepbrokenbin, $help, $nosort, $overwritefiles, $connct, $nocolor, $insane, $dropbad, $skipfilect, $reconndur, $filterregex, $configfile, $uudeview, $daemon, $dlrelative, $dlpath, $noupdate, $ssl, $socks_server, $socks_port, $proxy_user, $proxy_passwd, $http_proxy_server, $http_proxy_port, $dlcreate, $dlcreategrp, $noansi, $queuedir, $rcport, $postDecProg, $postNzbProg, $ipv6, $forever, $DECODE_DBG_FILE, $ifilterregex, $dthreadct, $diskfree ) = ( '', -1, '', '', 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 300, undef, "$ENV{HOME}/.nzbperlrc", undef, 0, undef, undef, 0, undef, undef, -1, undef, undef, undef, -1, undef, undef, 0, undef, undef, undef, undef, undef, undef, undef, undef, 1, undef); # How commandline args are mapped to vars. This map is also used by config file processor my %optionsmap = ('server=s' => \$server, 'user=s' => \$user, 'pw=s' => \$pw, 'help' => \$help, 'med=s' => \$medbw, 'low=s' => \$lowbw, 'speed=s' => \$targkBps, 'keepparts' => \$keepparts, 'keepbroken' => \$keepbroken, 'keepbrokenbin' => \$keepbrokenbin, 'nosort' => \$nosort, 'redo' => \$overwritefiles, 'conn=i' => \$connct, 'nocolor' => \$nocolor, 'log=s' => \$logfile, 'insane' => \$insane, 'dropbad' => \$dropbad, 'skip=i' => \$skipfilect, 'retrywait=i' => \$reconndur, 'filter=s' => \$filterregex, 'config=s' => \$configfile, 'uudeview=s' => \$uudeview, 'daemon' => \$daemon, 'forever' => \$forever, 'dlrelative' => \$dlrelative, 'dlpath=s' => \$dlpath, 'noupdate' => \$noupdate, 'ssl' => \$ssl, 'socks_server=s' => \$socks_server, 'socks_port=i' => \$socks_port, 'socks_user=s' => \$proxy_user, 'socks_passwd=s' => \$proxy_passwd, 'http_proxy=s' => \$http_proxy_server, 'dlcreate'=>\$dlcreate, 'dlcreategrp' => \$dlcreategrp, 'noansi' => \$noansi, 'queuedir=s' => \$queuedir, 'rcport=i' => \$rcport, 'postdec=s' => \$postDecProg, 'postnzb=s' => \$postNzbProg, 'ipv6' => \$ipv6, 'chunksize=s' => \$recv_chunksize, 'decodelog=s' => \$DECODE_DBG_FILE, 'ifilter=s' => \$ifilterregex, 'dthreadct=s' => \$dthreadct, 'diskfree=s' => \$diskfree); if(defined(my $errmsg = handleCommandLineOptions())){ showUsage($errmsg); exit 1; } if(not $ipv6){ use IO::Socket::INET; } if(not $nocolor){ use Term::ANSIColor; } if(not haveUUDeview()){ # Verify that uudeview is installed pc("* Please install and configure uudeview and try again.\n", "bold red"); exit 1; } $uudeview =~ m#^([\w\s\.\_\-\/\\]+)$# or die "Invalid characters in uudeview path."; displayShortGPL(); checkForNewVersion(); if($user and !$pw){ print "Password for '$user': "; $pw = readPassword(); } if(defined($proxy_user) and not defined($proxy_passwd)){ print "SOCKS Password for '$proxy_user': "; $proxy_passwd = readPassword(); } my $lastDirCheckTime = 0; my $lastDiskFullTime = undef; my $lastDiskFreePerc = 0; my %nzbfiles; # the hash/queue of nzb files we're handling # $nzbfiles{'files'}->{}->{'read'} : 1 if we've parsed/loaded it # $nzbfiles{'files'}->{}->{'finished'} : 1 if all files have been downloaded my @fileset; while(scalar(@ARGV) > 0){ my $nzbfilename = shift @ARGV; #$ARGV[0]; my @fsparts = parseNZB($nzbfilename); if(!defined($fsparts[0])){ exit; } @fsparts = regexAndSkipping(@fsparts); # It checks options inside too push @fileset, @fsparts; } print "Looks like we've got " . scalar @fileset . " possible files ahead of us.\n"; my @suspectFileInd; if($insane){ } else{ &doNZBSanityChecks(); if($dropbad){ &dropSuspectFiles(); } } my $rc_sock = undef; my @rc_clients; startRemoteControl(); my %totals = ( 'total size' => computeTotalNZBSize(@fileset), 'finished files' => 0, 'total bytes' => 0, 'total file ct' => scalar @fileset ); my @statusmsgs; statMsg('Welcome -- nzbperl started!'); # Descriptions of what's in the connection hash (for sanity sake) # # $conn->{'sock'} : the socket for comms # $conn->{'msg'} : message that describes what's going on # $conn->{'file'} : the file it's working on # $conn->{'segnum'} : the segment number of the file it's working on # $conn->{'segbytes'} : number of bytes read in the current segment # $conn->{'filebytes'} : number of bytes read in the current file # $conn->{'bstatus'} : status about how we're handling a body (starting/finishing) # $conn->{'buff'} : where body data is buffered # $conn->{'tmpfilename'}: temporary file name # $conn->{'tmpfile'} : temporary file handle # $conn->{'bwstarttime'}: time when the bandwdith applied # $conn->{'bwstartbytes'}: bytes read on file when bandwidth applied # $conn->{'truefname'} : true filename on disk (assumed after decoding) # $conn->{'skipping'} : indicates we're in the middle of a skipping operation # $conn->{'last data'} : time when data was last seen on this channel # $conn->{'sleep start'}: time that we started sleeping (for retries) # $conn->{'isbroken'} : set when one or more parts fails to download # $conn->{'tfseq'} : temporary file sequence id my @lastdrawtime = Time::HiRes::gettimeofday(); my @conn; createNNTPConnections(); if($user){ doLogins() or die "Error authenticating to server.\nPlease check the user/pass info and try again."; } if($daemon){ print "nzbperl is running in --daemon mode, output suppressed\n"; print "Check log for additional details during run...\n"; my $pid = fork; $pid and print "Daemon started [$pid]\n" and exit; #close STDIN; #close STDOUT; #close STDERR; } # Start up the decoding thread(s)... my ($decMsgQ, $decQ, @decThreads); if(usingThreadedDecoding()){ $decMsgQ = Thread::Queue->new; # For status msgs $decQ = Thread::Queue->new; foreach my $i (1..$dthreadct){ push @decThreads, threads->new(\&file_decoder_thread, $i); } } my ($oldwchar, $wchar, $oldhchar, $hchar, $wpixels, $hpixels) = (0); # holds screen size info ($wchar, $hchar, $wpixels, $hpixels) = GetTerminalSize(); clearScreen(); my @queuefileset = @fileset; my @dlstarttime = Time::HiRes::gettimeofday(); while(1){ doFileAssignments(); doBodyRequests(); doReceiverPart(); queueNewNZBFilesFromDir(); # queue up new nzb files from dir (guards inside) # See if queuefileset is empty AND all sockets don't have files # when that happens, that's when we're done. if(not scalar @queuefileset){ # no more files in queue doBodyRequests(); # total hack, but that's where decoding happens... } dequeueNextNZBFileIfNecessary(); doRemoteControls(); $quitnow and last; my $done = no_more_work_to_do(); if($done and defined($forever)){ select undef, undef, undef, 0.25; next; } $done and last; } cursorPos(0, $hchar); pc("All downloads complete!\n", 'bold white'); cursorPos(0, $hchar); if($quitnow){# Do some cleanups foreach my $c (@conn){ next unless $c->{'file'}; if($c->{'tmpfile'}){ pc("Closing and deleting " . $c->{'tmpfilename'} . "...\n", 'bold white'); undef $c->{'tmpfile'}; # causes a close unlink $c->{'tmpfilename'}; } } } # TODO: Clean up server socket for remote control schtuff disconnectAll(); pc("Waiting for file decoding thread(s) to terminate...\n", 'bold white'); foreach my $i (1..$dthreadct){ # Send a quit now message for each decoder thread. usingThreadedDecoding() and $decQ->enqueue('quit now'); } foreach my $i (0..$dthreadct-1){ # Now join on every decoder thread, waiting for all to finish usingThreadedDecoding() and $decThreads[$i]->join; } pc("Thanks for using ", 'bold yellow'); pc("nzbperl", 'bold red'); pc("! Enjoy!\n\n", 'bold yellow'); ######################################################################################### # no_more_work_to_do - returns 1 if there is more work to do, 0 otherwise. Used to # detect when the main loop body should terminate ######################################################################################### sub no_more_work_to_do { foreach my $i (1..$connct){ if($conn[$i-1]->{'file'}){ return 0; } } return scalar(@queuefileset) == 0; # no more files in queue, all done } ######################################################################################### # This is the thread that does file decoding # It uses two queues for communication -- decQ for files to decode, decMsgQ for status # messages back to the main thread. ######################################################################################### sub file_decoder_thread { my $threadNum = shift; my ($nzbpath, $nzbfile, $isbroken, $islastonnzb, $tmpfilename, $truefilename, $decodedir); my $prefixMsg = ($dthreadct > 1) ? "Decoder #$threadNum:" : ''; while(1){ # We get 6 things on the q per file... # nzbpath, $nzbfile, isbroken, tmpfilename, truefilename, decodedir $nzbpath = $decQ->dequeue; last unless defined($nzbpath); ($nzbpath =~ /^quit now$/) and last; # Time to shut down $nzbfile = $decQ->dequeue; $isbroken= $decQ->dequeue; $islastonnzb = $decQ->dequeue; $tmpfilename = $decQ->dequeue; $decodedir = $decQ->dequeue; $truefilename = $decQ->dequeue; doUUDeViewFile($nzbpath, $nzbfile, $isbroken, $islastonnzb, $tmpfilename, $decodedir, $truefilename, $prefixMsg); } } ######################################################################################### # Does multiplexed comms receiving ######################################################################################### sub doReceiverPart { my $select = IO::Select->new(); foreach my $i (1..$connct){ next unless (defined($conn[$i-1]->{'sock'})); #next unless ($conn[$i-1]->{'file'}); $select->add($conn[$i-1]->{'sock'}); } # If there are no active connections, we need to do a little sleep to prevent maxing out cpu. # the select->can_read call passes right through if it has no handles. (not $select->count()) and select undef, undef, undef, 0.1; my @ready = $select->can_read(0.25); foreach my $i (1..$connct){ my $conn = $conn[$i-1]; #next unless $conn->{'file'}; # This connection must be working on a file...otherwise next # TODO: Create a way to disable reconnection (when we don't want to do it) # Reconnect if we don't have a socket but we do have a file. if((not defined($conn->{'sock'})) and $conn->{'file'}){ doReconnectLogicPart($i-1); next; } my $canread = 0; foreach my $fh (@ready) { if (defined($conn->{'sock'}) and $fh == $conn->{'sock'}) { $canread = 1; last; } } if ($canread) { my ($recvret, $buff); if (ref($conn->{'sock'}) eq "IO::Socket::SSL") { $recvret = $conn->{'sock'}->sysread($buff, $recv_chunksize); } else { $recvret = recv($conn->{'sock'}, $buff, $recv_chunksize, 0); if(defined($recvret)){ $recvret = length $buff; } else{ $recvret = -1; } } if(($recvret < 0) or !length($buff)){ # TODO: Determine how to gracefully handle the crap we've already downloaded if (ref($conn->{'sock'}) eq "IO::Socket::SSL") { $conn->{'sock'}->shutdown( 2 ); $conn->{'sock'}->close( SSL_no_shutdown => 1 ); } else { $conn->{'sock'}->close; } $conn->{'sock'} = undef; $conn->{'sleep start'} = time; statMsg(sprintf("* Remote disconnect on connection #%d", $i)); drawStatusMsgs(); $conn->{'buff'} = ''; next; } $conn->{'buff'} .= $buff; if(not connIsStartingSeg($conn)){ # only bump these up if we're not starting... $conn->{'segbytes'} += length($buff); $conn->{'filebytes'} += length($buff); $totals{'total bytes'} += length($buff); } $conn->{'last data'} = time; # Spool all lines from the buffer into the output file. spoolOutConnBuffData($i, $conn); } drawScreenAndHandleKeys(); doThrottling(); } if ($#ready < 0) { drawScreenAndHandleKeys(); doThrottling(); } } ######################################################################################### # spoolOutConnBuffData - spool the given connection's data to the output file. # There's other stuff here too....it should be made simpler. ######################################################################################### sub spoolOutConnBuffData { my ($i, $conn) = @_; return unless defined($conn->{'buff'}) and length($conn->{'buff'}) and defined($conn->{'tmpfile'}); while(1){ my $ind1 = index $conn->{'buff'}, "\r\n"; last unless $ind1 >= 0; my $line = substr $conn->{'buff'}, 0, $ind1+2, ''; if(connIsStartingSeg($conn)){ startSegmentOnConnection($i, $conn, $line); next; } # Try and detect the "real" filename if(not $conn->{'truefname'}){ my $tfn = getTrueFilename($line); if($tfn){ $conn->{'truefname'} = $tfn; statMsg("Conn. $i: Found true filename: $tfn"); my $targdir = getDestDirForFile($conn->{'file'}); # where the file is going on disk makeTargetDirIfNecessary($targdir); my $tfndisk = $targdir . $tfn; if(-e $tfndisk){ if(!$overwritefiles){ # We can't just close and delete, because there will likely still be # data waiting in the receive buffer. As such, we have to set a flag # to indicate that the file already exists and should be skipped... # This is perhaps a bit silly -- we have to finish slurping in the # BODY part before we can start working on the next file... statMsg("Conn $i: File already exists on disk (skipping after segment completes)"); $conn->{'skipping'} = 1; } } } } if($line =~ /^\.\r\n/){ # detect end of BODY.. $conn->{'bstatus'} = 'finished'; if($conn->{'skipping'}){ $totals{'total file ct'}--; $totals{'total bytes'} -= $conn->{'filebytes'}; # Remove bytes downloaded $totals{'total size'} -= $conn->{'file'}->{'totalsize'}; # Remove file bytes from job total undef $conn->{'tmpfile'}; # causes a close unlink $conn->{'tmpfilename'}; $conn->{'file'} = undef; $conn->{'skipping'} = undef; # no longer skipping (for next time) } last; } else{ $line =~ s/^\.\././o; print {$conn->{'tmpfile'}} $line; } } } ######################################################################################### # Figures out where a file will be going on disk. Returns the directory. ######################################################################################### sub getDestDirForFile { my $file = shift; if(defined($dlpath)){ if (defined($dlcreate)) { # if we like to create nicely organized subdirs return $dlpath . $file->{'nzb path'}; } elsif (defined($dlcreategrp)){ return $dlpath . $file->{'groups'}->[0]; } return $dlpath; } elsif(defined($dlrelative)){ return $file->{'nzb path'}; } return undef; #this should not happen...either dlpath or dlrelative should be set } ######################################################################################### # makes the given dowload dir if necessary ######################################################################################### sub makeTargetDirIfNecessary { my $targdir = shift; if( not -d ($targdir) and defined($dlpath) and (defined($dlcreate) or defined($dlcreategrp))){ if(!mkdir($targdir)){ statMsg("ERROR: Could not create $targdir: $!"); } } } ######################################################################################### # connIsStartingSeg - Returns 1 if the segment BODY is being started on a connection, # or returns 0 otherwise. ######################################################################################### sub connIsStartingSeg { my $conn = shift; return (defined($conn) and defined($conn->{'bstatus'}) and ($conn->{'bstatus'} =~ /starting/)); } ######################################################################################### # startSegmentOnConnection - Handles an input line when a segment is just starting # on a connection. This looks into detecting missing segments and handles server # responses that mean various things. ######################################################################################### sub startSegmentOnConnection { my ($i, $conn, $line) = @_; my ($mcode, $msize, $mbody, $mid) = split /\s+/, $line; # We're just starting, need to slurp up 222 (or other) response if($line =~ /^2\d\d\s.*\r\n/s){ # Bad case where server sends a 5xx message after a 2xx (222) if(!$msize and ($conn->{'buff'} =~ /^5\d\d /)){ # Handle this error condition (display message to user) my $errline = $conn->{'buff'}; $errline =~ s/\r\n.*//s; statMsg(sprintf("Conn. %d: Server returned error: %s", $i, $errline)); } else{ $conn->{'segbytes'} = length($conn->{'buff'}); } $conn->{'bstatus'} = 'running'; } else{ # This is an error condition -- often when the server can't find a segment $line =~ s/\r\n$//; statMsg( sprintf("Conn. %d FAILED to fetch part #%d (%s)", $i, $conn->{'segnum'}+1, $line)); drawStatusMsgs(); $conn->{'bstatus'} = 'finished'; # Flag BODY segment as finished $conn->{'isbroken'} = 1; # Ok, so now that a segment fetch FAILED, we need to determine how to continue... # We will look at the keep variables to determine how to continue... # If keepbroken or keepbrokenbin are set, we will keep downloading parts...otherwise we will bump # up the segnum so that we skip all remaining segments (if any) if($keepbroken or $keepbrokenbin){ # If we shound continue downloading this broken file # Subtract the size of the current segment from the totals # (for this file and for the grand totals) my $failedsegsize = @{$conn->{'file'}->{'segments'}}[$conn->{'segnum'}]->{'size'}; $totals{'total size'} -= $failedsegsize ; $conn->{'file'}->{'totalsize'} -= $failedsegsize; } else{ statMsg(sprintf("Conn. %d aborting file (failed to fetch segment #%d)", $i, $conn->{'segnum'}+1)); # Adjust totals due to skipping failed file $totals{'total file ct'}--; $totals{'total bytes'} -= $conn->{'filebytes'}; # Remove bytes downloaded $totals{'total size'} -= $conn->{'file'}->{'totalsize'}; # Remove file bytes from job total $conn->{'segnum'} = scalar @{$conn->{'file'}->{'segments'}} - 1; undef $conn->{'tmpfile'}; # causes a close unlink $conn->{'tmpfilename'}; $conn->{'file'} = undef; } } } ######################################################################################### # Handles reconnection logic ######################################################################################### sub doReconnectLogicPart { my $i = shift; my $forceNow = shift; # can be specified to force a reconnect right now my $conn = $conn[$i]; if(not $forceNow){ my $remain = $reconndur - (time - $conn->{'sleep start'}); if($remain > 0){ # still sleeping return; } } #my $iaddr = inet_aton($server) || die "Error resolving host: $server"; statMsg(sprintf("Connection #%d attempting reconnect to %s:%d...", $i+1, $server, $port)); ($conn->{'sock'}, my $line) = createSingleConnection($i, "$server:$port", 1); if(!$conn->{'sock'}){ # couldn't reconnect statMsg($line); $conn->{'sleep start'} = time; # reset reconnect timer return; } my $msg = sprintf("Connection #%d reestablished.", $i+1); $user and $msg .= "..performing login"; statMsg($msg); drawStatusMsgs(); if($user){ #need to authenticate... doSingleLogin($i, 1); statMsg(sprintf("Login on connection #%d complete.", $i+1)); } $conn->{'sleep start'} = undef; # These two lines reset our state so that we restart the segment we were on # prior to the disconnect. Sure, a bit convoluted, but it's used elsewhere. $conn->{'bstatus'} = 'finished'; defined($conn->{'segnum'}) and $conn->{'segnum'}-- unless $conn->{'segnum'} < 0;; } ######################################################################################### # Heuristically determines the "true" filename. Returns filename or undef ######################################################################################### sub getTrueFilename { my $line = shift; $line =~ s/\s+$//; if($line =~ /^=ybegin/){ # Yenc candidate # I'm assuming that the last tag on the line is "name=...", which I honestly have no idea # if that's always true. :) $line =~ s/.* name=//; return $line; } elsif($line =~ /^begin \d+ /){ # UUencoded candidate $line =~ s/^begin \d+ //; return $line; } else{ return undef; } } ######################################################################################### # Handles segments and detects when we're done with a file ######################################################################################### sub doBodyRequests { foreach my $i (1..$connct){ my $conn = $conn[$i-1]; my $file = $conn->{'file'}; next unless $file; # Bail if we don't have a file if($conn->{'segnum'} < 0){ next unless $conn->{'sock'}; # no socket, perhaps waiting for reconnect $conn->{'segnum'} = 0; my $seg = @{$file->{'segments'}}[0]; #$conn->{'seg'} = $seg; my $msgid = $seg->{'msgid'}; sockSend($conn->{'sock'}, 'BODY <' . $msgid . ">\r\n"); $conn->{'bstatus'} = 'starting'; $conn->{'segbytes'} = 0; } elsif($conn->{'bstatus'} =~ /finished/){ # finished a segment $conn->{'segnum'}++; if($conn->{'segnum'} >= scalar @{$file->{'segments'}}){ # All segments for this file exhausted. cursorPos(5, 6+(3*($i-1))); my $len = pc("File finished! Sending details to decoder queue...", 'bold white'); print ' ' x ($wchar-$len-6); statMsg("Conn. $i: Finished downloading " . $conn->{'file'}->{'name'}); doDecodeOrQueueCompletedFile($conn); drawStatusMsgs(); $totals{'finished files'}++; $conn->{'file'} = undef; #$conn->{'seg'} = undef; } else { next unless $conn->{'sock'}; # no socket, perhaps waiting for reconnect my $segnum = $conn->{'segnum'}; my $seg = @{$file->{'segments'}}[$segnum]; #$conn->{'seg'} = $seg; my $msgid = $seg->{'msgid'}; sockSend($conn->{'sock'}, 'BODY <' . $msgid . ">\r\n"); $conn->{'bstatus'} = 'starting'; $conn->{'segbytes'} = 0; } } } } ######################################################################################### # doStartFileDecoding - initiates or performs a decode for a completed file. # If dthreadct == 0, this will decode in place, otherwise it just queues the request # to decode to the decoder thread. ######################################################################################### sub doDecodeOrQueueCompletedFile { my $conn = shift; my $file = $conn->{'file'}; undef $conn->{'tmpfile'}; # causes a close my $outdir = getDestDirForFile($file); $outdir = cwd unless defined($outdir); # default to current dir my $tmpfilename = $conn->{'tmpfilename'}; my $truefilename = $conn->{'truefname'}; my $isbroken = $conn->{'isbroken'}; $isbroken = 0 unless (defined($isbroken)); # ensure a definite value my $islastonnzb = $file->{'lastonnzb'}; if(usingThreadedDecoding()){ # Queue the items to the decoding thread $decQ->enqueue($file->{'nzb path'}, $file->{'nzb file'}, $isbroken, $islastonnzb, $tmpfilename, $outdir, $truefilename); } else{ doUUDeViewFile($file->{'nzb path'}, $file->{'nzb file'}, $isbroken, $islastonnzb, $tmpfilename, $outdir, $truefilename); } } ######################################################################################### # Decodes a file to disk and handles cleanup (deleting/keeping parts) ######################################################################################### sub doUUDeViewFile { my ($nzbpath, $nzbfile, $isbroken, $islastonnzb, $tmpfilename, $decodedir, $truefilename, $prefixMsg) = @_; $prefixMsg = '' unless defined($prefixMsg); $prefixMsg =~ s/\s+$//; length($prefixMsg) and $prefixMsg .= ' '; statOrQ($prefixMsg . "Starting decode of $truefilename"); # Do the decode and confirm that it worked... if(!$isbroken or $keepbrokenbin){ my $kb = ''; $keepbrokenbin and $kb = '-d'; # If keeping broken, pass -d (desparate mode) to uudeview my $decodelogpart = ''; my $qopts = '-q'; if(defined($DECODE_DBG_FILE)){ $decodelogpart = " >> $DECODE_DBG_FILE"; $qopts = '-n'; } else{ $decodelogpart = " > /dev/null"; } my $rc = system("$uudeview -i -a $kb $qopts \"$tmpfilename\" -p \"$decodedir\"$decodelogpart 2>&1"); $rc and $isbroken = 1; # If decode failed, file is broken if($rc){ # Problem with the decode if(defined($DECODE_DBG_FILE)){ statOrQ($prefixMsg . "FAILED decode of $tmpfilename (see $DECODE_DBG_FILE for details)"); } else{ statOrQ($prefixMsg . "FAILED decode of $tmpfilename"); statOrQ("Consider using --decodelog to troubleshoot."); } } else{ statOrQ($prefixMsg . "Completed decode of " . $truefilename); } } # Decide if we need to keep or delete the temp .parts file if($keepparts or ($isbroken and $keepbroken)){ my $brokemsg = $isbroken ? ' broken' : ''; statOrQ("Keeping$brokemsg file segments in $tmpfilename (--keepparts given)"); # TODO: rename to .broken } else { unlink($tmpfilename) or statOrQ("Error removing $tmpfilename from disk: $!"); } runPostDecodeProgram($tmpfilename, $decodedir, $truefilename, $isbroken); $islastonnzb and (runPostNzbDecodeProgram($nzbpath, $nzbfile, $decodedir, $truefilename)); } ######################################################################################### # runPostDecodeProgram -- Possibly runs an external program after a file has been # decoded (regardless of success). ######################################################################################### sub runPostDecodeProgram { my ($tmpfilename, $decodedir, $truefilename, $isbroken) = @_; return unless defined($postDecProg); $truefilename = $decodedir . (($decodedir =~ /\/$/) ? '' : '/') . $truefilename; runProgWithEnvParams($postDecProg, 'post-decoding', NZBP_FILE => $truefilename, NZBP_TEMPFILE => $tmpfilename, NZBP_ISBROKEN => $isbroken); } ######################################################################################### # runPostNzbDecodeProgram -- Possibly runs external prog when nzb is completed. ######################################################################################### sub runPostNzbDecodeProgram { my ($nzbpath, $nzbfile, $decodedir, $truefilename) = @_; return unless defined($postNzbProg); #option not specified runProgWithEnvParams($postNzbProg, 'post-nzb', NZBP_NZBDIR => $nzbpath, NZBP_NZBFILE => $nzbfile, NZBP_DECODEDIR => $decodedir, NZBP_LASTFILE => $truefilename); } ######################################################################################### # Runs a program with environment vars prepended to the commandline as parameters. # This is used by the post decoder program runner and the post nzb program runner. ######################################################################################### sub runProgWithEnvParams { my ($prog, $desc, %env) = @_; my $cmd = ''; # This is a little strange...but showing the env vars onto the command is # the only way I could find to pass environments from a perl thread to # an external prog. I wish there was a better way (like using $ENV, but # that fails) foreach my $k (keys %env){ my $envitem = $env{$k}; $envitem =~ s/"/\\"/g; # escape double quotes $envitem =~ s/`/\\`/g; # escape backticks (evil) $cmd .= sprintf("export %s=\"%s\"; ", $k, $envitem); } $cmd .= $prog; statMsg("Running $desc program : $prog"); system($cmd); statMsg("Finished running $desc program."); drawStatusMsgs(); } ######################################################################################### # Shifts from the file queue and assigns the files to a connection. When a file is # assigned, the first segment is not assigned. ######################################################################################### sub doFileAssignments { foreach my $i (1..$connct){ my $conn = $conn[$i-1]; next if $conn->{'file'}; # already working on a file if(hitDiskSpaceLimit($queuefileset[0])){ # Do free space checking if option set next; } my $file = shift @queuefileset; last unless $file; statMsg(sprintf("Conn. %d starting file: %s", $i, $file->{'name'})); $conn->{'file'} = $file; $conn->{'segnum'} = -1; $conn->{'filebytes'} = 0; $conn->{'truefname'} = undef; $conn->{'bwstartbytes'} = 0; $conn->{'isbroken'} = 0; # Assume unbroken until we know it is @{$conn->{'bwstarttime'}} = Time::HiRes::gettimeofday(); $conn->{'tfseq'}++; # Create temp filename and open my $tmpfile = 'nzbperl.tmp' . time . '.' . $i . '.' . $conn->{'tfseq'} . '.parts'; if(defined($dlpath)){ # stick in dlpath if given $tmpfile = $dlpath . $tmpfile; } elsif(defined($dlrelative)){ # otherwise stick in relative dir to nzbfile $tmpfile = $file->{'nzb path'} . $tmpfile; if(not -w $file->{'nzb path'}){ statMsg(sprintf("*** ERROR: nzb path %s is not writable! There will be failures!", $file->{'nzb path'})); statMsg("*** Please change the permissions or use --dlpath instead of --dlrelative."); } } ($tmpfile =~ m#^([\w\d\s\.\_\-\/\\]+)$#) and $tmpfile = $1; # untaint tmpfile $conn->{'tmpfilename'} = $tmpfile; $conn->{'tmpfile'} = undef; # just to be absolutely sure open $conn->{'tmpfile'}, ">$tmpfile" or (statMsg("*** ERROR opening $tmpfile (critical!)") and next); statMsg("Opened temp file $tmpfile"); binmode $conn->{'tmpfile'}; } } ######################################################################################### # Returns 1 if the param to prevent disk filling was set and we're within the threshhold ######################################################################################### sub hitDiskSpaceLimit { return 0 unless defined $diskfree; my $file = shift; # Only check freespace every 15 seconds if(defined($lastDiskFullTime)){ return 1 unless (time - $lastDiskFullTime) > 15; } my $freeperc = getFreeDiskPercentage(getDestDirForFile($file)); if($freeperc <= $diskfree){ if(not defined($lastDiskFullTime)){ # the first time we detect free space is out statMsg("Warning: Download disk has less than $diskfree% free."); statMsg("Waiting for free space before continuing downloading."); } $lastDiskFullTime = time; return 1; } $lastDiskFullTime = undef; return 0; } ######################################################################################### # Tries to get the free disk percentage on the provided path ######################################################################################### sub getFreeDiskPercentage { my $path = shift; my @reslines = `df '$path'`; my $line = pop @reslines; chomp $line; # Are all dfs created equal??? If not, we could use col headers? my ($fs, $size, $used, $avail, $dfperc, $mount) = split /\s+/, $line; $dfperc =~ s/%//; $lastDiskFreePerc = 100-$dfperc; return $lastDiskFreePerc; } ######################################################################################### # Decides if its time to do the next nzb file...which is when the @queuefileset array # is empty and there is at least 1 idle connection. ######################################################################################### sub dequeueNextNZBFileIfNecessary { return if scalar(@queuefileset); # still have queued files foreach my $i (1..$connct){ if(not $conn[$i-1]->{'file'}){ # the connection is idle my ($newQueuedCt, $dequeuedNewFile, $reconnAttempts) = (0,0,0); $newQueuedCt = queueNewNZBFilesFromDir(1); # force a dircheck first $dequeuedNewFile = dequeueNextNZBFile(); if($dequeuedNewFile){ $reconnAttempts = reconnectAllDisconnectedNow(); } if($newQueuedCt or $dequeuedNewFile or $reconnAttempts){ drawStatusMsgs(); } return; } } } ######################################################################################### # Forces an immediate reconnect on all not connected connections. # Returns number of connections that had reconnect *attempts* (not necessarily the # number that were actually reconnected) ######################################################################################### sub reconnectAllDisconnectedNow { my $retCt = 0; foreach my $i (1..$connct){ if(not defined($conn[$i-1]->{'sock'})){ doReconnectLogicPart($i-1, 1); $retCt++; } } return $retCt; } ######################################################################################### # Pulls out the next nzb file in queue, parses it, and then add its files/parts to # @queuefileset. ######################################################################################### sub dequeueNextNZBFile { my @keys = keys %{$nzbfiles{'files'}}; foreach my $key (@keys){ if(not $nzbfiles{'files'}->{$key}->{'read'}){ statMsg("Moving to next nzb file in queue: $key"); my @newset = parseNZB($queuedir . '/' . $key, 1); if(!defined($newset[0])){ statMsg("Warning: no new files loaded from queued nzb file"); return 0; } push @queuefileset, @newset; statMsg("Loaded " . scalar(@newset) . " new files to download from nzb file: $key"); $totals{'total file ct'} += scalar @newset; $totals{'total size'} += computeTotalNZBSize(@newset); $nzbfiles{'files'}->{$key}->{'read'} = 1; return 1; } } return 0; } ######################################################################################### # Looks at the nzbfile hash and counts the number that haven't been read (are queued) ######################################################################################### sub countQueuedNZBFiles { my @keys = keys %{$nzbfiles{'files'}}; my $ct = 0; foreach my $key (@keys){ if($nzbfiles{'files'}->{$key}->{'read'} == 0){ $ct++; } } return $ct; } ######################################################################################### # queues new nzb files from the queue dir if they exist and adds them to the hash/queue # of all nzb files we're processing. Returns the number of files dequeued. ######################################################################################### sub queueNewNZBFilesFromDir { my $forcecheck = shift; return 0 unless $queuedir and not scalar @queuefileset; return 0 unless $forcecheck or (time - $lastDirCheckTime > 15); # don't check more than once every 15 seconds $lastDirCheckTime = time; my $retCt = 0; opendir(QDIR, $queuedir); my @candidates = grep(/\.nzb$/, readdir(QDIR)); foreach my $file (@candidates){ if( !defined($nzbfiles{'files'}->{$file})){ # not queued yet statMsg("Queueing new nzb file found on disk: $file"); $nzbfiles{'files'}->{$file}->{'read'} = 0; $retCt++; } } closedir(QDIR); return $retCt; } ######################################################################################### # Start up the remote control(s) ######################################################################################### sub startRemoteControl { return unless defined($rcport); # nuthin to do eval "use XML::Simple;"; ($@) and die "ERROR: XML::Simple required if using remote control...Please install it."; $rc_sock = createRCMasterSocket(); print "Remote control server socket created.\n"; } ######################################################################################### # creates the remote control master port, using either ipv4 or ipv6 ######################################################################################### sub createRCMasterSocket { my $ret; my %opts = (Listen => 5, LocalAddr => 'localhost', LocalPort => $rcport, Proto=>'tcp', Type => SOCK_STREAM, Reuse => 1); if($ipv6){ $ret = IO::Socket::INET6->new( %opts ) or die "Error creating remote control socket: $!"; } else{ $ret = IO::Socket::INET->new( %opts ) or die "Error creating remote control socket: $!"; } return $ret; } ######################################################################################### # Main loop entry point for handling remote control stuff ######################################################################################### sub doRemoteControls { return unless defined($rcport); getNewRcClients(); handleRcClients(); my @tmprcc; foreach my $client (@rc_clients){ #clean up dropped clients if(defined($client->{'closenow'})){ statMsg(sprintf("Remote control client from %s:%s disconnected.", $client->{'ip'}, $client->{'port'})); close $client->{'sock'}; } else{ push @tmprcc, $client; } } @rc_clients = @tmprcc; } ######################################################################################### # handleRcClients -- read and handle all remote commands from all clients ######################################################################################### sub handleRcClients{ for (my $i=0; $i < scalar @rc_clients; $i++){ my $client = $rc_clients[$i]; my $cmd = readRcClientCommand($client); defined($cmd) and handleRcClientCmd($client, $cmd); } } ######################################################################################### # handleRcClientCmd - Handle's an rc client command ######################################################################################### sub handleRcClientCmd { my ($client, $cmdstr) = @_; my ($cmd, $params, $responsemsg) = ($cmdstr, $cmdstr); $cmd =~ s/\s+.*//; $params =~ s/^\w+\s+//; $params = '' unless $params ne $cmd; if($cmd =~ /ping/i){ $responsemsg = sprintf("PONG! %s", $params); } elsif($cmd =~ /^quit/i){ sendRemoteResponse($client, "Nice having ya."); $client->{'closenow'} = 1; return; } elsif($cmd =~ /^keys/i){ my @keys = split //, $params; foreach my $key (@keys){ handleKey($key); } $responsemsg = sprintf("Ok, processed %d keystrokes", scalar @keys); } elsif($cmd =~ /^summary/i){ $responsemsg = generateRcSummary(); } elsif($cmd =~/^speed/i){ if($params =~ /\d+/){ $targkBps = $params; $responsemsg = sprintf("Ok, set download speed to %dkBps", $params); } else{ $responsemsg = "Error: please specify speed in kBps"; } } elsif($cmd =~ /^diskfree/i){ $params =~ s/%//; $diskfree = $params; $responsemsg = "Ok, set max disk free percentage to $diskfree%"; } elsif($cmd =~ /^enqueue/i){ if(defined($nzbfiles{'files'}->{$params})){ # not queued yet $responsemsg = "Error: Refusing to queue file already queued ($params)."; } elsif(not -e $params){ $responsemsg = "Error: File does not exist ($params)"; } else{ $responsemsg = "Queueing new nzb file found on disk: $params"; statMsg($responsemsg); $nzbfiles{'files'}->{$params}->{'read'} = 0; } } else{ $responsemsg = "Sorry, command not understood."; } sendRemoteResponse($client, $responsemsg); } ######################################################################################### # sendRemoteResponse -- send a remote command response to the remote client. ######################################################################################### sub sendRemoteResponse { my ($client, $msg) = @_; my $sock = $client->{'sock'}; # simple protocol, eh? sockSend($sock, sprintf("%d\r\n%s\r\n", length($msg)+2, $msg)); } ######################################################################################### # readRcClientCommand -- Attempts to read a command from the client socket # returns the command or undef ######################################################################################### sub readRcClientCommand { my $client = shift; my $buff = readNewRcClientSockData($client); if(defined($buff)){ my $nlindex = index $client->{'data'}, "\r\n"; if($nlindex >= 0){ #get cmd and replace in client{data} with nothing my $cmd = substr $client->{'data'}, 0, $nlindex+2, ''; $cmd = trimWS($cmd); return $cmd; } } return undef; } ######################################################################################### # readNewRcClientSockData -- Pulls client data off the socket if there is any. ######################################################################################### sub readNewRcClientSockData { my $client = shift; my $sock = $client->{'sock'}; my $sockfn = fileno($sock); my ($rin, $win, $ein) = ('', '', ''); my ($rout, $wout, $eout); vec($rin, $sockfn, 1) = 1; vec($win, $sockfn, 1) = 1; vec($ein, $sockfn, 1) = 1; my $nfound = select($rout=$rin, $wout=$win, $eout=$ein, 0); return undef unless $nfound > 0; if(vec($rout, $sockfn,1) == 1){ my $buff; recv($sock, $buff, $recv_chunksize, 0); if(not length($buff)){ $client->{'closenow'} = 1; return undef; } $client->{'data'} .= $buff; return $buff; } if((vec($eout, $sockfn, 1) == 1) || (vec($wout, $sockfn, 1) != 1)){ $client->{'closenow'} = 1; } return undef; } ######################################################################################### # Accepts new connections from clients and adds them to the list. ######################################################################################### sub getNewRcClients { while(1){ my ($rin,$rout) = ('',''); vec($rin, fileno($rc_sock), 1) = 1; my $nfound = select($rout=$rin, undef, undef, 0); last unless ($nfound > 0); my $nclient; my $client_addr = accept($nclient, $rc_sock); #my $old = select($nclient); #$| = 1; # make nonbuffered #select($old); my ($clientport, $clientippart) = sockaddr_in($client_addr); my $clientip = inet_ntoa($clientippart); statMsg("New remote control connection from " . $clientip . ":" . $clientport); sockSend($nclient, "nzbperl version $version\r\n"); push @rc_clients, {'sock' => $nclient, 'ip' => $clientip, 'port' => $clientport}; } } ######################################################################################### # generateRcSummary - generates a summary of information for a remote request for it. ######################################################################################### sub generateRcSummary { my %s; $s{'connections'} = $connct; my $tspeed = $targkBps ? hrsv($targkBps*1024) . "Bps" : "unlimited"; $s{'speeds'} = {'current' => getCurrentSpeed(), 'target' => $tspeed, 'session' => getTotalSpeed()}; $s{'completed'} = {'files' => $totals{'finished files'}, 'size' => hrsv($totals{'total bytes'})}; $s{'completed'}->{'files'} = 0 unless $s{'completed'}->{'files'}; $s{'remaining'} = {'files' => $totals{'total file ct'}-$totals{'finished files'}, 'time' => getETA(), 'size' => hrsv($totals{'total size'} - $totals{'total bytes'}), 'queued_nzb_files' => countQueuedNZBFiles()}; my $summary = XML::Simple->new()->XMLout(\%s, rootname => 'summary', noattr => 1); $summary =~ s/\s+$//; return $summary ; } ######################################################################################### # Creates all connections and adds them to the @conn global ######################################################################################### sub createNNTPConnections { foreach my $i (1..$connct){ #my $iaddr = inet_aton($server) || die "Error resolving host: $server"; my $paddr = "$server:$port"; ($conn[$i-1]->{'sock'}, my $line) = createSingleConnection($i-1, $paddr); } return 1; } ######################################################################################### # Connects to an NNTP server and attempts to read the greet string line. # Returns the socket and the greet line. ######################################################################################### sub createSingleConnection { my ($i, $paddr, $silent) = @_; my ($osock, $sock) = (undef, undef); if (defined($socks_server)) { porlp(sprintf("Attempting SOCKS connection #%d %s:%d ->%s:%d...", $i+1, $socks_server, $socks_port, $server, $port), $silent); my %sockparam = (ProxyAddr => $socks_server, ProxyPort => $socks_port, ConnectAddr => $server, ConnectPort => $port ); if(defined($proxy_user)){ # Add authentication info $sockparam{'AuthType'} = 'userpass'; $sockparam{'Username'} = $proxy_user; $sockparam{'Password'} = $proxy_passwd; } $osock = IO::Socket::Socks->new( %sockparam ); } elsif (defined($http_proxy_server)) { porlp(sprintf('Attempting HTTP Proxy connection #%d %s:%d -> %s:%d...', $i+1, $http_proxy_server, $http_proxy_port, $server, $port), $silent); $osock = Net::HTTPTunnel->new( 'proxy-host' => $http_proxy_server, 'proxy-port' => $http_proxy_port, 'remote-host' => $server, 'remote-port' => $port ); } else { porlp(sprintf('Attempting connection #%d to %s:%d...', $i+1, $server, $port), $silent); $osock = createNNTPClientSocket($paddr); } if(!$osock){ porlp("Connection FAILED!\n", $silent); return (undef, "Error connecting to server: '$!'"); } porlp("success!\n", $silent); if (defined($ssl)) { porlp(sprintf("Establishing SSL connection #%d to %s:%d...", $i+1, $server, $port), $silent); $sock = IO::Socket::SSL->start_SSL($osock); die "SSL error: " . IO::Socket::SSL::errstr() . $! unless (defined($sock)); } else { $sock = $osock; } my $line = blockReadLine($sock); # read server connection/response string not $line =~ /^(200|201)/ and die "Unexpected server response: $line" . "Expected 200 or 201.\n"; if (ref($sock) eq "IO::Socket::SSL") { my ($subj, $iss, $cipher) = ($sock->peer_certificate("subject"), $sock->peer_certificate("issuer"), $sock->get_cipher()); pc("cipher: $cipher: Subject $subj: Issuer: $iss\n", "bold white"); } return ($sock, $line); } ######################################################################################### # Encapsulates creating a socket for use with NNTP. Pulled to a sub because it can # handle IPv6 sockets if the option is set. ######################################################################################### sub createNNTPClientSocket { my $paddr = shift; my %opts = (PeerAddr => $paddr, Proto => 'tcp', Type => SOCK_STREAM); $ipv6 and return IO::Socket::INET6->new(%opts); return IO::Socket::INET->new(%opts); } ######################################################################################### # Attempts to perform a login on each connection ######################################################################################### sub doLogins { foreach my $i (1..$connct){ doSingleLogin($i-1); } return 1; } ######################################################################################### # Logs in a single connection. Pass in the connection index. ######################################################################################### sub doSingleLogin { my ($i, $silent) = @_; my $conn = $conn[$i]; my $sock = $conn[$i]->{'sock'}; return unless $sock; not $silent and printf("Attempting login on connection #%d...", $i+1); sockSend($sock, "AUTHINFO USER $user\r\n"); my $line = blockReadLine($sock); if($line =~ /^381/){ sockSend($sock, "AUTHINFO PASS $pw\r\n"); $line = blockReadLine($sock); $line =~ s/\r\n//; (not $line =~ /^281/) and not $silent and print ">FAILED<\n* Authentication to server failed: ($line)\n" and exit(0); not $silent and print "success!\n"; } elsif($line =~ /^281/){ # not sure if this happens, but this means no pw needed I guess not $silent and print "no password needed, success!\n"; } else { not $silent and print "server returned: $line\n"; die ">LOGIN FAILED<\n"; } } ######################################################################################### # Computes and returns the total speed for this session. ######################################################################################### sub getTotalSpeed { my $runtime = Time::HiRes::tv_interval(\@dlstarttime); return uc(hrsv($totals{'total bytes'}/$runtime)) . 'Bps'; } ######################################################################################### # Looks at all the current connections and calculates a "current" speed ######################################################################################### sub getCurrentSpeed { my $sumbps = 0; my $suppresshsrv = shift; foreach my $i (1..$connct){ my $c = $conn[$i-1]; next unless $c->{'file'}; # skip inactive connections $sumbps += ($c->{'filebytes'} - $c->{'bwstartbytes'})/Time::HiRes::tv_interval($c->{'bwstarttime'}); } $suppresshsrv and return $sumbps; return uc(hrsv($sumbps)) . 'Bps'; } ######################################################################################### # gets the estimated ETA in hrs:mins:secs ######################################################################################### { my @old_speeds; sub getETA { my ($h, $m, $s); my $curspeed = getCurrentSpeed(1) || 0; # in bytes/sec if (push(@old_speeds, $curspeed) > 20) { # keep the last 20 measurements shift(@old_speeds); } my $avgspeed = 0; foreach my $i (@old_speeds) { $avgspeed += $i; } $avgspeed /= scalar(@old_speeds); if ($avgspeed == 0) { return "??:??:??"; } my $remainbytes = $totals{'total size'} - $totals{'total bytes'}; my $etasec = $remainbytes / $avgspeed; $h = int($etasec/(60*60)); $m = int(($etasec-(60*60*$h))/60); $s = $etasec-(60*60*$h)-(60*$m); if($h > 240){ # likely bogus...just punt return "??:??:??"; } return sprintf("%.2d:%.2d:%.2d", $h, $m, $s); } } ######################################################################################### # Checks the last paint time and updates the screen if necessary. Also checks for # keyboard keys. ######################################################################################### sub drawScreenAndHandleKeys { $daemon and return; # don't draw screen when in daemon mode...RC keys handled elsewhere if($showinghelpscreen){ cursorPos(40, 14); pc("ETA: " . getETA(), 'bold green'); pc(")", 'bold white'); cursorPos(0, $hchar); } elsif((Time::HiRes::tv_interval(\@lastdrawtime) > 0.5) or # Refresh screen every 0.5sec max (usingThreadedDecoding() and $decMsgQ->pending > 0)){ # or we got status messages from decoder thread ($wchar, $hchar, $wpixels, $hpixels) = GetTerminalSize(); if($oldwchar != $wchar){ $oldwchar and statMsg("Terminal was resized (new width = $wchar), redrawing"); clearScreen(); drawBorder(); } $oldwchar = $wchar; @lastdrawtime = Time::HiRes::gettimeofday(); drawHeader(); drawConnInfos(); drawStatusMsgs(); cursorPos(0, $hchar); pc("'?' for help> ", 'bold white'); } my $char; while (defined ($char = getch()) ) { # have a key $char =~ s/[\r\n]//; handleKey($char); } } ######################################################################################### # Simple helper to determine if we're using threaded or nonthreaded decoding. # It looks at the dthreadct variable and returns 1 if dthreadct > 0. ######################################################################################### sub usingThreadedDecoding { return ($dthreadct > 0); } ######################################################################################### # getch -- gets a key in nonblocking mode ######################################################################################### sub getch { $daemon and return; ReadMode ('cbreak'); my $char; $char = ReadKey(-1); ReadMode ('normal'); # restore normal tty settings return $char; } ######################################################################################### # Does bandwidth throttling ######################################################################################### sub doThrottling { not $targkBps and return; # Max setting, don't throttle. $quitnow and return; # Don't bother if quitting my $curbps = getCurrentSpeed(1)/1024; # in kBps # TODO: Using percentages could likely make this way better. # (ie. inc/dec sleep duration by error percentage %) if($curbps > $targkBps){ # We're going too fast... if($sleepdur == 0){ $sleepdur = 0.001; # arbitrary 1ms add } else{ $sleepdur *= 1.5; } if($sleepdur > 1.0){ # cap at 1 second sleep time, which is rediculously long anyway $sleepdur = 1.0; } } elsif($curbps < $targkBps){ if($sleepdur > 0){ if($sleepdur < 0.00001){ # lowest thresshold at 10us $sleepdur = 0; } else{ $sleepdur -= ($sleepdur * 0.5); } } } if($sleepdur > 0){ # throttle if appropriate select undef, undef, undef, $sleepdur; } } ######################################################################################### # Trim the middle out of a string to shorten it to a target length ######################################################################################### sub trimString { my $string = shift; my $target_len = shift; my $len = length($string); if($target_len >= $len || $target_len < 5) { return $string; } my $chop = $len - $target_len + 3; # 3 for the ... substr($string, ($len - $chop) / 2, $chop) = "..."; return $string; } ######################################################################################### # Handles a keypress ######################################################################################### sub handleKey { if($showinghelpscreen){ $showinghelpscreen = 0; clearScreen(); $oldwchar = 0; # Hack to force border(s) to be redrawn return; # cancel help screen display } my $key = shift; if($key =~ /q/){ $quitnow = 1; statMsg("User forced quit...exiting..."); # TODO: Close open files and delete parts files. drawStatusMsgs(); updateBWStartPts(); } elsif($key =~ /1/){ $targkBps = $lowbw; statMsg("Setting bandwidth to low value ($lowbw" . "kBps)"); drawStatusMsgs(); updateBWStartPts(); } elsif($key =~ /2/){ $targkBps = $medbw; statMsg("Setting bandwidth to medium value ($medbw" . "kBps)"); drawStatusMsgs(); updateBWStartPts(); } elsif($key =~ /3/){ $targkBps = 0; # set to high statMsg("Setting bandwidth to maximum (unlimited)"); drawStatusMsgs(); updateBWStartPts(); } elsif($key =~ /h/ or $key =~ /\?/){ statMsg("Displaying help screen at user's request"); showHelpScreen(); } elsif($key =~ /c/){ $usecolor = $usecolor ^ 0x01; #invert value } elsif($key =~ /\+/){ if($targkBps){ $targkBps++; statMsg("Nudging bandwidth setting up to " . $targkBps . "kBps"); drawStatusMsgs(); updateBWStartPts(); } } elsif($key =~ /-/){ if(!$targkBps){ # Set to unlimited $targkBps = int(getCurrentSpeed(1)/1024)-1; statMsg("Nudging bandwidth setting down to " . $targkBps . "kBps"); } elsif($targkBps > 1){ # Bottom out at 1 $targkBps--; statMsg("Nudging bandwidth setting down to " . $targkBps . "kBps"); } drawStatusMsgs(); updateBWStartPts(); } else { statMsg("Unknown key: $key (try 'h' for help)"); } } ######################################################################################### # When the bandwidth changes, update all bw baselines for all connections ######################################################################################### sub updateBWStartPts { foreach my $i (1..$connct){ my $c = $conn[$i-1]; $c->{'bwstartbytes'} = $c->{'filebytes'}; @{$c->{'bwstarttime'}} = Time::HiRes::gettimeofday(); } } ######################################################################################### # Draws the header that contains summary info etc. ######################################################################################### sub drawHeader(){ cursorPos(2, 1); my $len = 0; $len += pc("nzbperl v.$version", 'bold red'); $len += pc(" :: ", 'bold white'); $len += pc("noisybox.net", 'bold red'); my $queuedCount = countQueuedNZBFiles(); if($queuedCount > 0){ $len += pc(" [", 'bold blue'); $len += pc(sprintf("+%d nzb files queued", $queuedCount), 'bold cyan'); $len += pc("]", 'bold blue'); } if(scalar @rc_clients > 0){ $len += pc(" [", 'bold blue'); $len += pc(sprintf("%d remotes", scalar @rc_clients), 'bold cyan'); $len += pc("]", 'bold blue'); } pc((' ' x ($wchar-$len-4)), 'white'); cursorPos(2, 3); $len += pc("Files remaining: ", 'bold white'); $len += pc($totals{'total file ct'} - $totals{'finished files'}, 'bold green'); $len += pc(" of ", 'white'); $len += pc($totals{'total file ct'}, 'bold green'); my $dlperc = $totals{'total size'} == 0 ? 0 : int(100.0*$totals{'total bytes'} / $totals{'total size'}); $len += pc(' [', 'bold blue'); $len += pc(hrsv($totals{'total bytes'}) . 'B', 'bold green'); $len += pc('/', 'bold white'); $len += pc(hrsv($totals{'total size'}) . 'B', 'bold green'); $len += pc(']', 'bold blue'); $len += pc(" ", 'white'); $len += pc($dlperc. '%', 'bold yellow'); $len += pc(" ETA: ", 'bold white'); $len += pc(getETA(), 'bold yellow'); pc((' ' x ($wchar-$len-4)), 'white'); cursorPos(2, 2); $len = pc("Current speed: ", 'bold white'); $len += pc(getCurrentSpeed(), 'bold green'); $len += pc(" (", 'bold blue'); $len += pc("target", 'white'); $len += pc(' = ', 'white'); if($targkBps){ $len += pc(hrsv($targkBps*1024) . "Bps", 'bold green'); } else{ $len += pc("unlimited!", 'bold red'); } $len += pc(")", 'bold blue'); $len += pc(" Session speed: ", 'bold white'); $len += pc(getTotalSpeed(), 'bold green'); pc((' ' x ($wchar-$len-4)), 'white'); } ######################################################################################### # Draws statuses for all individual connections ######################################################################################### sub drawConnInfos(){ my $startrow = 6; my $len; foreach my $i(1..$connct){ my $conn = $conn[$i-1]; cursorPos(2, $startrow+(3*($i-1))); if(not defined($conn->{'file'})){ if(scalar(@queuefileset) == 0){ # This connection has no more work to do... $len = pc(sprintf("%d: Nothing left to do...", $i), 'bold cyan'); if(!defined($conn->{'sock'})){ # connection closed $len += pc(" [", 'bold white'); $len += pc("closed", 'bold red'); $len += pc("]", 'bold white'); } pc((' ' x ($wchar-$len-4)), 'white'); cursorPos(2, $startrow+(3*($i-1))+1); $len = pc(defined($forever) ? " " : " ", 'bold cyan'); pc((' ' x ($wchar-$len-4)), 'white'); } elsif(defined($lastDiskFullTime)) { # connection waiting on free disk space $len = pc(sprintf("%d: Waiting for free space on disk...[%d%% free, limit %d%%]", $i, $lastDiskFreePerc, $diskfree), 'bold yellow'); pc((' ' x ($wchar-$len-4)), 'white'); cursorPos(2, $startrow+(3*($i-1))+1); $len = pc(sprintf(" ", $lastDiskFreePerc, $diskfree), 'bold white'); pc((' ' x ($wchar-$len-4)), 'white'); } next; } if(!defined($conn->{'sock'})){ # connection closed $len = pc(sprintf("%d: ", $i), 'bold white'); $len += pc("Connection is closed", 'bold red'); if($conn->{'sleep start'}){ # will be a reconnect my $remain = $reconndur - (time - $conn->{'sleep start'}); $len += pc(sprintf(" (reconnect in %s)", hrtv($remain)), 'bold yellow'); } pc((' ' x ($wchar-$len-4)), 'white'); cursorPos(2, $startrow+(3*($i-1))+1); pc((' ' x ($wchar-4)), 'white'); next; } my $file = $conn->{'file'}; my $filesize = $file->{'totalsize'}; my $filebytesread = $conn->{'filebytes'}; my $segnum = $conn->{'segnum'}+1; my $segct = scalar @{$conn->{'file'}->{'segments'}}; my $segbytesread = $conn->{'segbytes'}; my $cursegsize = @{$file->{'segments'}}[$segnum-1]->{'size'}; $len = pc(sprintf("%d: Downloading: ", $i), 'bold white'); my $fn = $file->{'name'}; if( length($fn) + $len > $wchar-4){ $fn = substr($fn, 0, $wchar-4-$len); } $len += pc($fn, 'white'); if($len < $wchar-4){ pc(' ' x ($wchar-$len-4), 'white'); } cursorPos(2, $startrow+(3*($i-1))+1); my $perc = 0; $filesize and $perc = int(($filebytesread/$filesize)*25); if ($noansi) { ($perc > 25) and $perc = 25; # cap progress bar length $len = pc(" |", 'bold white'); if($perc){ $len += pc('#' x ($perc-1), 'bold white'); $len += pc('#', 'bold red'); } $len += pc('-' x (25-$perc), 'white'); $len += pc("| ", 'bold white'); } else { $len = pc("\x1B(0" . " [", 'bold white'); if($perc){ $len += pc('a' x ($perc-1), 'bold white'); $len += pc('a', 'bold red'); } $len += pc('q' x (25-$perc), 'white'); $len += pc("] " . "\x1B(B", 'bold white'); } if($filesize){ $len += pc( sprintf("%2d", ($filebytesread/$filesize)*100) . "%", 'bold yellow'); } else{ $len += pc("??%", 'bold yellow'); } $len += pc(' ' x (7-length(hrsv($filebytesread))) . "[", 'bold white'); #$len += pc(sprintf("%5s", hrsv($filebytesread)), 'bold green'); $len += pc(hrsv($filebytesread), 'bold green'); $len += pc("/", 'bold white'); $len += pc(hrsv($filesize), 'bold green'); $len += pc("]", 'bold white'); $len += pc(" [part ", 'bold white'); $len += pc($segnum, 'bold cyan'); $len += pc("/", 'bold white'); $len += pc($segct, 'bold cyan'); $len += pc(" ", 'bold white'); $len += pc(sprintf("%4s", hrsv($segbytesread)), 'bold cyan'); $len += pc("/", 'bold white'); $len += pc(hrsv($cursegsize), 'bold cyan'); $len += pc("]", 'bold white'); pc((' ' x ($wchar - $len - 4)), 'white'); } } ######################################################################################### sub drawStatusMsgs { # TODO: Consider saving state about status messages -- could save cycles by not # automatically drawing every time. $showinghelpscreen and return; return unless defined($wchar); # to prevent decoder thread from trying to draw... my $row = 3*$connct + 6 + 1; my $statuslimit = $hchar - 9 - (3*$connct); # number of lines to show. # Pull any decode messages from the queue and append them # This might not be the *best* place for this... while(usingThreadedDecoding() and $decMsgQ->pending > 0){ statMsg($decMsgQ->dequeue); } # Trim status messages to size while( scalar(@statusmsgs) > $statuslimit){ shift @statusmsgs; } foreach my $line (@statusmsgs){ cursorPos(2, $row); if(length($line) > ($wchar-4)){ $line = substr($line, 0, $wchar-4); # Clip line } else{ $line .= (' ' x ($wchar-4-length($line))); } pc($line, 'white'); $row++; } cursorPos(0, $hchar); pc("'?' for help> ", 'bold white'); } ######################################################################################### # Draws a border around the screen. ######################################################################################### sub drawBorder { drawVLine(0); drawVLine($wchar); drawHLine(0, "top"); drawHLine(4, "middle"); drawHLine(1+5+(3*$connct), "middle"); drawHLine($hchar-2, "bottom"); } sub drawHLine { my $ypos = shift; my $hpos = shift; cursorPos(0, $ypos); if ($noansi) { pc('+' . ('-' x ($wchar-2)) . '+', 'bold white'); } else { if ($hpos eq "top") { pc("\x1B(0" . 'l' . ('q' x ($wchar-2)) . 'k' . "\x1B(B", 'bold white'); } elsif ($hpos eq "middle") { pc("\x1B(0" . 't' . ('q' x ($wchar-2)) . 'u' . "\x1B(B", 'bold white'); } elsif ($hpos eq "bottom") { pc("\x1B(0" . 'm' . ('q' x ($wchar-2)) . 'j' . "\x1B(B", 'bold white'); } } } sub drawVLine { my $xpos = shift; my $height = shift; not $height and $height = ($hchar-2); foreach(0..$height){ cursorPos($xpos, $_); if ($noansi) { pc('|', 'bold white'); } else { pc("\x1B(0" . "x" . "\x1B(B", 'bold white'); } } } ######################################################################################### # helper for printing in color (or not) ######################################################################################### sub pc { my ($string, $colstr) = @_; not defined($colstr) and $colstr = "white"; # default to plain white $daemon and return length($string); if($usecolor){ print colored ($string, $colstr); } else{ print $string; } return length($string); } sub clearScreen { !$daemon and $terminal->Tputs('cl', 1, *STDOUT); # clears screen } ######################################################################################### # Positions the cursor at x,y. Looks at $daemon first. ######################################################################################### sub cursorPos { my ($x, $y) = @_; !$daemon and $terminal->Tgoto('cm', $x, $y, *STDOUT); } ######################################################################################### # Print or log, depending on $silent ######################################################################################### sub porl { porlp(shift, $daemon); } ######################################################################################### # porlp :: "Print or log [with] param" - ######################################################################################### sub porlp { my $msg = shift; my $lognotprint = shift; if($lognotprint){ chomp $msg; statMsg($msg); } else{ print $msg; } } ######################################################################################### # statOrQ - calls statMsg or enqueues the message, based on the value of $dthreadct, # which governs if we're using a threaded approach or not. ######################################################################################### sub statOrQ { my $msg = shift; if(usingThreadedDecoding()){ $decMsgQ->enqueue($msg); } else{ statMsg($msg); } } ######################################################################################### # Adds a status message with timestamp ######################################################################################### sub statMsg { my $str = shift; my @t = localtime; my $msg = sprintf("%0.2d:%0.2d - %s", $t[2], $t[1], $str); my $logtimepart = sprintf("%d-%02d-%02d %0.2d:%0.2d:%0.2d", $t[5]+1900, $t[4]+1, $t[3], $t[2], $t[1], $t[0]); push @statusmsgs, $msg; if($logfile){ open LOGFH, ">>" . $logfile or (push @statusmsgs, sprintf("%0.2d:%0.2d:%0.2d - Error writing to log file %s", $logfile) and return 1); print LOGFH sprintf("%s - %s\n", $logtimepart, $str); close LOGFH; } return 1; } ######################################################################################### # Socket send that can handle both SSL and regular socket... ######################################################################################### sub sockSend { my ($sock, $msg) = @_; if (ref($sock) eq "IO::Socket::SSL") { $sock->syswrite($msg, undef); } else { send $sock, $msg, 0; } } ######################################################################################### # Reads a line from the socket in a blocking manner. ######################################################################################### sub blockReadLine { my $sock = shift; my ($line, $buff) = ('', ''); while(1){ if (ref($sock) eq "IO::Socket::SSL") { $sock->sysread($buff, 1024); } else{ defined(recv($sock, $buff, 1024, 0)) or last; } $line .= $buff; last if $line =~ /\r\n$/; } return $line; } ######################################################################################### # Gracefully close down all server connections. ######################################################################################### sub disconnectAll { foreach my $i (1..$connct){ my $sock = $conn[$i-1]->{'sock'}, print "Closing down connection #$i..."; not $sock and print "(already closed)\n" and next; sockSend($sock, "QUIT\r\n"); my $line = blockReadLine($sock); $line =~ /^205/ and print "closed gracefully!"; print "\n"; if (ref($sock) eq "IO::Socket::SSL") { $sock->shutdown( 2 ); $sock->close( SSL_no_shutdown => 1); } else { close($sock); } $conn[$i-1]->{'sock'} = undef; } } ######################################################################################### # human readable time value (from seconds) ######################################################################################### sub hrtv { my $sec = shift; if($sec < 60){ return $sec . "s"; } my $h = int($sec/(60*60)); my $m = int(($sec - ($h*60*60))/60.0); my $s = $sec - ($h*60*60) - ($m*60); if($h){ return sprintf("%02d:%02d:%02d", $h, $m, $s); } else{ return sprintf("%02d:%02d", $m, $s); } } ######################################################################################### # human readable size value ######################################################################################### sub hrsv { my $size = shift; # presumed bytes $size = 0 unless defined($size); my $k = 1.0*$size/1024; my $m = 1.0*$size/(1024*1024); my $g = 1.0*$size/(1024*1024*1024); if($g > 1){ return sprintf("%0.2fG", $g); } if($m > 1){ return sprintf("%0.2fM", $m); } if($k > 1){ return sprintf("%dk", $k); } return sprintf("%0.2f", $size); } ######################################################################################### # read password without echoing it ######################################################################################### sub readPassword { ReadMode 2; # no echo my $pw = ; chomp $pw; ReadMode 0; # default print "\n"; return $pw; } ######################################################################################### # Determines the total file size for all segments in the NZB file ######################################################################################### sub computeTotalNZBSize { my @fileset = @_; my $tot = 0; foreach my $file (@fileset){ foreach my $seg (@{$file->{'segments'}}){ $tot += $seg->{'size'}; } } return $tot; } ######################################################################################### # Parse NZB file and return array of files # TODO: The structure returned from this function should really be documented....but # for now, if you need it, use Dumper to view the format. Should be self explanatory. ######################################################################################### sub parseNZB { my $nzbfilename = shift; my $lognoprint = shift; $nzbfiles{'files'}->{basename($nzbfilename)}->{'read'} = 1; # set flag indicating we've processed it my $nzbdir = derivePath($nzbfilename); if ((defined($dlpath)) and (defined($dlcreate))) { my $nzbbase = basename($nzbfilename); if ($nzbbase =~ /msgid_[0-9]*_(.*).nzb/) { # Filter name from NewzBin style names $nzbdir = $1 . "/"; } elsif ($nzbbase =~ /(.*).nzb/) { # Strip the .nzb extension and $nzbdir = $1 . "/"; } else { # Just use the nzb file as a directory itself $nzbdir = $nzbbase . "/"; } } $nzbdir .= '/' unless $nzbdir =~ /\/$/; my $parser = new XML::DOM::Parser; my @fileset; porlp("Loading and parsing nzb file: " . $nzbfilename . "\n", $lognoprint); my $nzbdoc; eval { $nzbdoc = $parser->parsefile($nzbfilename); }; if($@){ my $errmsg = trimWS($@); if($lognoprint){ statMsg("The nzb file is BROKEN and the XML could not be parsed."); } else{ pc("\n"); pc(" Sorry, but nzb file is broken! The xml could not be parsed:\n", 'bold yellow'); pc("\n"); pc(" $errmsg\n\n", 'bold yellow'); pc(" *** nzbperl requires valid, well-formed XML documents.\n\n", 'bold red'); } return undef; } my $files = $nzbdoc->getElementsByTagName("file"); my $totalsegct = 0; foreach my $i (0..$files->getLength()-1){ my $fileNode = $files->item($i); my $subj = $fileNode->getAttributes()->getNamedItem('subject'); my $postdate = $fileNode->getAttributes()->getNamedItem('date'); my %file; $file{'nzb path'} = $nzbdir; $file{'nzb file'} = basename($nzbfilename); $file{'name'} = $subj->getValue(); $file{'date'} = $postdate->getValue(); my @groupnames; for my $group ($fileNode->getElementsByTagName('group')) { push @groupnames, $group->getFirstChild()->getNodeValue(); } $file{'groups'} = \@groupnames; my @segments; for my $seg ($fileNode->getElementsByTagName('segment')) { my %seghash; my $size = $seg->getAttributes()->getNamedItem('bytes')->getValue(); $file{'totalsize'} += $size; my $segNumber = $seg->getAttributes()->getNamedItem('number')->getValue(); $seghash{'msgid'} = $seg->getFirstChild()->getNodeValue(); $seghash{'size'} = $size; $seghash{'number'} = $segNumber; push @segments, \%seghash; } # If segment numbers are present, use them to sort. if (defined($segments[0]) && defined($segments[0]->{'number'})){ @segments = sort { $a->{'number'} <=> $b->{'number'} } @segments; } $totalsegct += scalar @segments; $file{'segments'} = \@segments; push @fileset, \%file; } $nzbdoc->dispose; porlp("Loaded $totalsegct total segments for " . $files->getLength() . " file(s).\n", $lognoprint); @fileset = sortFilesBySubject($lognoprint, @fileset); # It checks $sort inside @fileset = resetLastOnNzbFlag(@fileset); return @fileset; } ######################################################################################### # Filters out files if there is a filter regex, and skips over files from --skip ######################################################################################### sub regexAndSkipping { my @fileset = @_; if(defined($filterregex)){ # the inclusive filter @fileset = filterFilesOnSubject(1, $filterregex, @fileset); } if(defined($ifilterregex)){ # the exclusive (inverse) filter @fileset = filterFilesOnSubject(0, $ifilterregex, @fileset); } if($skipfilect){ if($skipfilect >= scalar @fileset){ pc("\nWhoops: --skip $skipfilect would skip ALL " . scalar @fileset . " files...aborting!\n\n", 'bold yellow') and exit 0; } print "Removing $skipfilect files from nzb set (--skip $skipfilect)\n"; while($skipfilect > 0){ shift @fileset; $skipfilect--; } } @fileset = resetLastOnNzbFlag(@fileset); return @fileset; } ######################################################################################### # Takes in a list of files and filters them based on subject. ######################################################################################### sub filterFilesOnSubject { my $inclusiveRegex = shift; my $regex = shift; my @fileset = @_; print "Filtering files on " . ($inclusiveRegex ? '' : 'inverse ') . "regular expression...\n"; my $orgsize = scalar @fileset; my @nset; while(scalar(@fileset) > 0){ my $f = shift @fileset; if( ($inclusiveRegex and ($f->{'name'} =~ /$regex/)) or ( not $inclusiveRegex and (not $f->{'name'} =~ /$regex/))){ push @nset, $f; } } if(scalar @nset < 1){ pc("\nWhoops: Filter removed all files (nothing left)...aborting!\n\n", 'bold yellow') and exit 0; } printf("Kept %d of %d files (filtered %d)\n", scalar(@nset), $orgsize, $orgsize-scalar(@nset)); return @nset; } ######################################################################################### # Sorts files in a fileset based on the name ######################################################################################### sub sortFilesBySubject { my $quiet = shift; my @fileset = @_; if(!$nosort){ porlp("Sorting files by filename (subject)...", $quiet); @fileset = sort { $a->{'name'} cmp $b->{'name'}; } @fileset; porlp("finished.\n", $quiet); } return @fileset; } ######################################################################################### # Traverses a fileset and resets the islastonnzb flag. ######################################################################################### sub resetLastOnNzbFlag { my @fileset = @_; foreach my $i (0..scalar(@fileset)-1){ if($i == scalar(@fileset)-1){ $fileset[$i]->{'lastonnzb'} = 1; } else{ $fileset[$i]->{'lastonnzb'} = 0; } } return @fileset; } ######################################################################################### # Derives a path from a filename (passed on commandline). # The result isn't necessarily absolute, can be relative ######################################################################################### sub derivePath { my $filename = shift; if($filename =~ /\//){ # then it has path information, likely not windows compat $filename =~ s/(^.*\/).*/$1/; return $filename; } return cwd; } ######################################################################################### # Main entry point for NZB file sanity checking ######################################################################################### sub doNZBSanityChecks(){ print "Analyzing sanity of NZB file segment completeness...\n"; @suspectFileInd = getSuspectFileIndexes(); my $badfilect = scalar @suspectFileInd; not $badfilect and pc("All files pass segment size sanity checks! Swell.\n", 'bold green') and return; SMENUDONE: while(1){ pc(sprintf("There are %d of %d files that may have missing or broken segments.\n", $badfilect, scalar @fileset), 'bold yellow'); pc("It is likely that these files will be unusable if downloaded.\n", 'bold yellow'); ($dropbad or $insane) and return; # User selection not needed. print "\n How do you want to proceed?\n\n"; print " k)eep everything and try all files anyway (--insane)\n"; print " d)rop files suspected broken (--dropbad)\n"; print " v)iew gory details about broken segments\n"; print " q)uit now\n"; print "\n -> "; while(1){ my $char; if(defined ($char = getch()) ) { # have a key print "\n"; if($char =~ /q/){ exit 1; } elsif($char =~ /k/){ print "Setting --insane option...\n"; $insane = 1; last SMENUDONE; } elsif($char =~ /d/){ print "Setting --dropbad option...\n"; $dropbad = 1; last SMENUDONE; } elsif($char =~ /v/){ showSuspectDetails(@suspectFileInd); } last; } else{ select undef, undef, undef, 0.1; } } } } ######################################################################################### # Shows details about suspect files... ######################################################################################### sub showSuspectDetails { my @susFileInd = @_; foreach my $fileind (1..scalar @susFileInd){ my $file = @fileset[$susFileInd[$fileind-1]]; my $avgsize = avgFilesize($file); print "------------------------------------------------------\n"; printf(" * File: %s\n", $file->{'name'}); printf(" Posted on: %s (%d days ago)\n", scalar localtime $file->{'date'}, (time - $file->{'date'})/(60*60*24) ); printf(" Adjusted average part size = %d bytes\n", $avgsize); my @sids = getSuspectSegmentIndexes($file, $avgsize); foreach my $si (@sids){ my $seg = @{$file->{'segments'}}[$si]; my $percdiff = 100; $avgsize and $percdiff = 100*(abs($seg->{'size'} - $avgsize)/$avgsize); printf(" Part %d : %d bytes (%.2f%% error from average)\n", $si+1, $seg->{'size'}, $percdiff); } } print "------------------------------------------------------\n"; } ######################################################################################### # Looks at the fileset and returns an array of file indexes that are suspect ######################################################################################### sub getSuspectFileIndexes { my @ret; foreach my $fileind (1..scalar @fileset){ my $file = $fileset[$fileind-1]; my $avg = avgFilesize($file); #printf("File has average size = %d\n", $avg); my $segoffct = 0; my @suspectSegInd = getSuspectSegmentIndexes($file, $avg); if(scalar @suspectSegInd){ push @ret, $fileind-1; } } return @ret; } ######################################################################################### sub getSuspectSegmentIndexes { my $MAX_OFF_PERC = 25; # Percentage of segment size error/diff to trigger invalid my ($file, $avg) = @_; my @ret; foreach my $i (1..(scalar @{$file->{'segments'}}-1)){ # Last segment is allowed to slide... my $seg = @{$file->{'segments'}}[$i-1]; my $percdiff = 100; $avg and $percdiff = 100*(abs($seg->{'size'} - $avg)/$avg); #printf(" seg $i of %d is %0.2f off avg [%d versus %d (avg)]\n", scalar @{$file->{'segments'}}, $percdiff, $seg->{'size'}, $avg); if($percdiff > $MAX_OFF_PERC){ push @ret, $i-1; } } return @ret; } ######################################################################################### sub dropSuspectFiles(){ my @newset; my $dropct = 0; foreach my $i (0..scalar @fileset-1){ if($i == $suspectFileInd[0]){ my $ind = shift @suspectFileInd; my $file = $fileset[$ind]; printf("Dropping [%s] from filset (suspect)\n", $file->{'name'}); $dropct++; next; } push @newset, shift @fileset; } @fileset = @newset; pc(sprintf("Dropped %d suspect files from NZB (%d files remain)\n", $dropct, scalar @fileset), 'bold yellow'); print " -> short delay (for user review)"; foreach(5,4,3,2,1){ print "...$_"; sleep 1; } print "...let's go!\n"; } ######################################################################################### # Not a true average, but an average of all segments except the last one... # ...unless there's only one segment, in which case it's the segment size. ######################################################################################### sub avgFilesize { my $file = shift; my @segs = @{$file->{'segments'}}; return $segs[0]->{'size'} unless scalar @segs > 1; my ($sum, $ct) = (0, 0); foreach my $i (1..scalar(@segs)){ my $seg = $segs[$i-1]; last unless $i < scalar(@segs); $ct++; $sum += $seg->{'size'}; } return $sum*1.0/($ct*1.0); } ######################################################################################### # Parse command line options and assign sane globals etc. ######################################################################################### sub handleCommandLineOptions { my @saveargs = @ARGV; # This extra call is required to set up the --config option, expected below GetOptions(%optionsmap); my $errmsg; # This is the facility for trapping stderr from GetOptions, so that we # can pretty print it at the bottom of the help screen. local $SIG{'__WARN__'} = sub { $errmsg = $_[0]; chomp $errmsg; }; # First see if the config file is there, if so, slurp options from it. my $optionsAreOk; if(-e $configfile){ readConfigFileOptions(); $optionsAreOk = eval 'GetOptions(%optionsmap)'; return $errmsg unless $optionsAreOk; } else { print "Config file $configfile does not exist. Skipping.\n"; } # Now restore the commandline args and parse those (overriding config file options) @ARGV = @saveargs; # restore $optionsAreOk = eval 'GetOptions(%optionsmap)'; return $errmsg unless $optionsAreOk; if($help){ return ""; } $nocolor and $usecolor = 0; not $optionsAreOk and return ""; if(usingThreadedDecoding()){ eval " use threads; use Thread::Queue;"; ($@) and return "ERROR: Could not use Perl thread modules.\r\n" . " Try setting --dthreadct 0 to run with a single threaded Perl."; } if($recv_chunksize =~ /kb?$/i){ $recv_chunksize =~ s/kb?$//i; $recv_chunksize = $recv_chunksize*1024; } if(defined($queuedir) and (not $queuedir =~ /^\//)){ return "--queuedir must specify an ABSOLUTE (not relative) path."; } if(not $ARGV[0] and (not defined $queuedir)){ # No NZB file given? return "Missing nzb file or directory queue."; } if($server =~ /:\d+$/){ $port = $server; $port =~ s/.*://; $server =~ s/:.*//; } if(not length($server)){ $server = $ENV{'NNTPSERVER'}; not $server and return "Must provide --server or set \$NNTPSERVER environment"; } $server = trimWS($server); $dlpath = cwd unless (defined($dlpath) or defined($dlrelative)); if($dlpath and not $dlpath =~ /^\//){ return "--dlpath must specify an ABSOLUTE (not relative) path."; } # Make sure that dlpath ends with a slash if($dlpath and (not ($dlpath =~ /\/$/))){ $dlpath .= '/'; ($dlpath =~ m#^([\w\d\s\.\_\-\/\\]+)$#) and $dlpath = $1; # untaint dlpath } if($dropbad and $insane){ # conflicting return "Error: --dropbad and --insane are conflicting (choose one)"; } if($forever and not (defined($rcport) or defined($queuedir))){ return "Error: --forever requires either --queuedir or --rcport.\n" . " Please choose one and try again."; } if(defined($queuedir) and !$dropbad and !$insane){ return "Use of --queuedir requires either --dropbad or --insane.\n" . " Please choose one and try again."; } if(defined($postDecProg) and not -e $postDecProg){ return "--postdec program \"$postDecProg\" does not exist.\n" . " Please confirm the program and try again."; } if($dlpath and $dlrelative){ # conflicting options return "Error: --dlrelative and --dlpath are conflicting (choose one)"; } # Verify that output dir is writable... if(defined($dlpath) and not -w $dlpath) { return "Error: dlpath '$dlpath' is not writable!\n" . " Please change the permissions or use a different directory."; } if(defined($DECODE_DBG_FILE)){ if(open(DBGTMP,">$DECODE_DBG_FILE")){ close DBGTMP; #all good } else{ return "The decode log file '$DECODE_DBG_FILE' is unwritable!"; } } if($port == -1) { if (defined($ssl)) { (undef, undef, $port, undef) = getservbyname("nntps", "tcp"); } else { (undef, undef, $port, undef) = getservbyname("nntp", "tcp"); } } if(defined($socks_server) and defined($http_proxy_server)){ return "Error: --socks_server and --http_proxy are conflicting (choose one)"; } if(defined($dlcreate) and defined($dlcreategrp)){ return "Error: --dlcreate and --dlcreategrp are conflicting (choose one)"; } if (defined($ssl)) { eval "use IO::Socket::SSL;"; # use module only if option is enabled. ($@) and return "ERROR: --ssl was specified, but IO::Socket::SSL isn't available.\r\n" . " Please install IO::Socket::SSL to use --ssl and try again."; } if (defined($socks_server)) { eval "use IO::Socket::Socks;"; # use module only if option enabled ($@) and return "ERROR: --socks_server was specified, but IO::Socket::Socks isn't available.\r\n" . " Please install IO::Socket::Socks to use a SOCKS server and try again."; if ($socks_port == -1) { if($socks_server =~ /:\d+$/){ $socks_port = $socks_server; $socks_port =~ s/.*://; $socks_server =~ s/:.*//; } else { (undef, undef, $socks_port, undef) = getservbyname("socks", "tcp"); } } $socks_server = trimWS($socks_server); } if (defined($http_proxy_server)) { eval "use Net::HTTPTunnel;"; # use module only if option enabled ($@) and return "ERROR: --http_proxy was specified, but Net::HTTPTunnel isn't available.\r\n" . " Please install Net::HTTPTunnel to use an HTTP proxy and try again."; if($http_proxy_server =~ /:\d+$/){ $http_proxy_port = $http_proxy_server; $http_proxy_port =~ s/.*://; $http_proxy_server =~ s/:.*//; } else { (undef, undef, $http_proxy_port, undef) = getservbyname("webcache", "tcp"); } $http_proxy_server = trimWS($http_proxy_server); } if(defined($ipv6)){ eval "use IO::Socket::INET6;"; # use ipv6 module if option given ($@) and return "ERROR: --ipv6 was given and the IO::Socket::INET6 module could not be found.\r\n" . " You must install the IO::Socket::INET6 module to use IPv6"; } return undef; # success } ######################################################################################### # Helper to detect that uudeview is installed. Always a good idea, ya'know, since we're # dependant on it! ######################################################################################### sub haveUUDeview { if(defined($uudeview)){ # Given on commandline or config file if(-e $uudeview){ pc("uudeview found: $uudeview\n", "bold green"); return 1; } pc("Warning: uudeview not found at location $uudeview\n", "bold yellow"); } my @paths = split /:/, $ENV{'PATH'}; # path sep different on winderz? foreach my $p (@paths){ $p =~ s/\/$//; $p = $p . "/uudeview"; if(-e $p){ pc("uudeview found: $p\n", "bold green"); $uudeview = $p; return 1; } } pc("Error: uudeview not found in path...aborting!\n", "bold red"); return 0; } ######################################################################################### # Reads options from the config file and tucks them into @ARGV, so that they all # look like they were passd on the commandline. So, when this returns (successfully), # ARGV contains the config file contents. ARGV must be preserved externally. ######################################################################################### sub readConfigFileOptions(){ print "Reading config options from $configfile...\n"; open CFG, "<$configfile" or die "Error opening $configfile for config options"; my $line; my @opts; while($line = ){ chomp $line; $line =~ s/^\s+//; $line =~ s/^-+//; # In case dashes in config file $line =~ s/(\s+)?=(\s+)?/=/; # Remove whitespace around equals sign next if $line =~ /^#/; next unless length($line); push @opts, "--$line"; } close CFG; @ARGV = @opts; } ######################################################################################### # Trim ws on both sides of string. Undef is ok. ######################################################################################### sub trimWS { my $s = shift; return $s unless defined $s; $s =~ s/^\s+//; $s =~ s/\s+$//; return $s; } ######################################################################################### # Checks for a newer version, disabled with --noupdate ######################################################################################### sub checkForNewVersion { $noupdate and return; # they don't want update checking print "Checking for availability of newer version...\n"; eval "use LWP::Simple;"; if($@){ print "LWP::Simple is not installed, skipping up-to-date check.\n"; return; } my $remote_ver = eval "get \"$UPDATE_URL\""; if(!defined($remote_ver)){ pc("Error fetching current version during update check: $!\n", 'bold red'); pc("Skipping up-to-date check.\n", 'bold yellow'); return; } chomp $remote_ver; if($remote_ver eq $version){ print "Look like you're running the most current version. Good.\n"; } else{ pc("A newer version of nzbperl is available: ", 'bold red'); pc('version ' . $remote_ver . "\n", 'bold white'); pc("You should consider downloading it from ", 'bold white'); pc("http://noisybox.net/computers/nzbperl/\n", 'bold yellow'); pc("This delay is intentional: "); foreach(1..8){ print "..." . (9-$_); sleep 1; } pc("\n"); } } ######################################################################################### sub displayShortGPL { print < ... where are: --config : Use for config options (default is ~/.nzbperlrc) --server : Usenet server to use (defaults to NNTPSERVER env var) : Port can also be specified with --server --user : Username for server (blank of not needed) --pw : Password for server (blank to prompt if --user given) --conn : Use server connections (default = 2) --ssl : Connect to server using SSL (secure sockets layer). : May be combined with --http_proxy or --socks_server to : use a proxy server with SSL. --socks_server : Connect using as a socks proxy server. Defaults to : port 1080, but can use --socks_server to : use an alternative port. --http_proxy : Use as an http proxy server to use. Defaults : to port 8080, but can use --http_proxy to : use an alternative port. --proxy_user : Authenticate to the proxy using as the username --proxy_passwd

: Use

as the proxy user password (otherwise prompted) --ipv6 : Use IPv6 sockets for communication --keepparts : Keep all encoded parts files on disk after decoding --keepbroken : Continue downloading files with broken/missing segments : and leave the parts files on disk still encoded. --keepbrokenbin : Decode and keep broken decoded files (binaries) on disk. --dlpath

: Download and decode all files to : (default downloads to current dirctory) --dlrelative : Download and decode to the dir that the nzbfiles are in : (default downloads to current directory) --dlcreate : Create download directories per nzb file --dlcreategrp : Create download dirctories with usenet group names --queuedir : Monitor for nzb files and queue new ones --forever : Run forever, waiting for new nzbs (requires --queuedir) --postdec : Run after each file is decoded, env var params. --postnzb : Run after each NZB file is completed. --diskfree : Stop downloading when dir free space above --redo : Don't skip over existing downloads, do them again --insane : Bypass NZB sanity checks completely --dropbad : Auto-skip files in the NZBs with suspected broken parts --skip : Skip the first files in the nzb (don't process) --med : Set "med" bandwidth to kBps (default is 95kBps) --low : Set "low" bandwidth to kBps (default is 35kBps) --speed : Explicitly specify transfer bandwidth in kBps --log : Log status messages into (default = none) --decodelog : Append uudeview output into (default = none) --dthreadct : Use number of decoder threads. Set ct = 0 for single threaded perl operation. (Note: When ct = 0, downloads will be paused during file decoding) --daemon : Run in background as daemon (use log for status) --rcport : Enable remote control functionality on port --retrywait : Wait seconds between reconnect tries (default = 300) --nosort : Don't sort files by name before processing --chunksize : Amount to read on each recv() call (for tweakers only) : Default = 5k, Can specify in bytes or kb (ie. 5120 or 5k) --filter : Filter NZB contents on in subject line --ifilter : Inverse filter NZB contents on in subject line --uudeview : Specify full path to uudeview (default found in \$PATH) --nocolor : Don't use color --noansi : Don't use ANSI characters (text only) --noupdate : Don't check for newer versions at startup --help : Show this screen During runtime, press 'h' or '?' to see a list of key commands. nzbperl version $version, Copyright (C) 2004 Jason Plumb nzbperl comes with ABSOLUTELY NO WARRANTY; This is free software, and you are welcome to redistribute it under certain conditions; Please see the source for additional details. EOL ; if($errmsg and (length($errmsg))){ print " *****************************************************************\n"; print " ERROR:\n"; print " $errmsg\n"; print " *****************************************************************\n"; } }