twatch-0.0.7/0000755000175000017500000000000011517522540012032 5ustar rubinrubintwatch-0.0.7/t/0000755000175000017500000000000011517522540012275 5ustar rubinrubintwatch-0.0.7/t/10_project.t0000644000175000017500000000201411316156171014425 0ustar rubinrubin#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More tests => 3; use Encode qw(decode); ################################################################################ # Use tests ################################################################################ BEGIN { # Prepare for utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; diag("************* Test Project *************"); use_ok('TWatch'); use_ok('TWatch::Project'); } ################################################################################ # Tests ################################################################################ sub t_1 { return 1; } ############################################################################### # Make ################################################################################ ok(t_1, ''); twatch-0.0.7/t/1_script.t0000644000175000017500000000214111316156171014204 0ustar rubinrubin#!/usr/bin/perl =head1 1_script.t Compilation test =cut use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More tests => 1; use Encode qw(decode); ################################################################################ # Use tests ################################################################################ BEGIN { # Prepare for utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; diag("************* Test twatch *************"); } ################################################################################ # Tests ################################################################################ sub t_compile { `perl -c twatch &> /dev/null`; exec 'perl -c twatch' if $?; return 1; } ############################################################################### # Make ################################################################################ ok(t_compile, 'Compilation test');twatch-0.0.7/t/100_pod.t0000644000175000017500000000154611316156171013632 0ustar rubinrubin#!/bin/bash NUMBER=0 list_files=`\ find lib -type f '(' -name '*.p[lm]' ')' \ | grep -v '\.svn' \ | tee list_perl_files.txt` total=`wc -l list_perl_files.txt|awk '{print $1}'` rm -f list_perl_files.txt echo 1..$total echo "**************** Test inline documentation : Pod ********" begin=$1 test -z "$begin" && begin=0 for file in $list_files; do NUMBER=$[ $NUMBER + 1 ] if test $NUMBER -lt $begin; then echo skip $NUMBER - podchecker $file continue fi output=`podchecker $file 2>&1` if test $? -eq 0; then if echo $output|grep -q WARNING:; then echo fail $NUMBER - podchecker $file exec podchecker $file fi echo ok $NUMBER - podchecker $file else quit_code=$? echo fail $NUMBER - podchecker $file exec podchecker $file fi done twatch-0.0.7/po/0000755000175000017500000000000011517522540012450 5ustar rubinrubintwatch-0.0.7/po/ru.po0000644000175000017500000000036111272654611013441 0ustar rubinrubin"Project-Id-Version: twatch\n" "Last-Translator: Roman V Nikolaev \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" #: twatch: translate part: #1 msgid "" msgstr ""twatch-0.0.7/po/en.po0000644000175000017500000000006011272654611013411 0ustar rubinrubin#: twatch: translate part: #1 msgid "" msgstr ""twatch-0.0.7/config/0000755000175000017500000000000011517522540013277 5ustar rubinrubintwatch-0.0.7/config/crontab0000644000175000017500000000036311276035003014647 0ustar rubinrubin################################################################################ # Execute TWatch # # Recommends to start ones per hour. ################################################################################ 0 * * * * /usr/bin/twatchtwatch-0.0.7/config/example.com.xml0000644000175000017500000001335511515067355016246 0ustar rubinrubin LostFilm http://lostfilm.tv 0 FormLogin test_login FormPassword 123456 my_cookie 1234567890 House M.D. http://www.lostfilm.tv/browse.php?cat=51 0 season 6 =]]> twatch-0.0.7/config/complete/0000755000175000017500000000000011517522540015107 5ustar rubinrubintwatch-0.0.7/config/twatch.conf0000644000175000017500000000300311410412203015416 0ustar rubinrubin################################################################################ # # TWatch default configuration file # ################################################################################ ### Paths ###################################################################### # Project files directory # Default: ~/.twatch/project/*.xml Project = ~/.twatch/project/*.xml # Path to save *.torrent files. # Typically, from this path your torrent client get *.torrent files to # start download. # Default: ~/.twatch/torrents Save = ~/.twatch/torrents # Downloaded torrents info # Default: ~/.twatch/complete/*.xml Complete = ~/.twatch/complete/*.xml # Plugin path # Default: /usr/share/perl5/Twatch/Plugin/*.pm Plugin = /usr/share/perl5/Twatch/Plugin/*.pm ### Download ################################################################### # Update time # Not used in this version. Use cron and see man. # Default: 3600 #Time = 3600 # Don`t use proxy # Default: no NoProxy = no ### Email ###################################################################### # User email # Default: root Email = root # Email level: [none | [info,error]] # error - send errors only # info - send completed # none - don`t send any message # Default: info,error EmailLevel = info,error ### Timeouts ################################################################### # Sleep time between watches # Default: 10 TimeoutWatch = 10 # Sleep time between content downloads # Default: 10 TimeoutDownloads = 1twatch-0.0.7/config/project/0000755000175000017500000000000011517522540014745 5ustar rubinrubintwatch-0.0.7/config/project/rutor.org.xml0000644000175000017500000000452711464000262017431 0ustar rubinrubin RuTor http://rutor.org 1 The Big Bang Theory http://rutor.org/search/0/0/000/0/Теория большого взрыва 1 season 3 =]]> quality HDTVRip How I Met Your Mother http://rutor.org/search/Как я встретил вашу маму 2 season 5 =]]> twatch-0.0.7/config/project/kinozal.tv.xml0000644000175000017500000000721211515563465017601 0ustar rubinrubin Kinozal http://kinozal.tv 9 username rshadow password s4zj7u9EmV Naruto 2 quality /HDTVRip/i =~ translate /.*голосый.*?(Venom64|Ancord).*/i =~ Игромания 1 <![CDATA[//div/b[starts-with(text(),'Оригинальное название:')]/following-sibling::text()[1]]]> <![CDATA[^\s*(\S.*\S)\s*$]]> format PDF eq year 2011 =]]> twatch-0.0.7/config/project/lostfilm.tv.xml0000644000175000017500000001571711515070170017756 0ustar rubinrubin LostFilm http://lostfilm.tv 10 FormLogin rshadow FormPassword 0jX0lET21r usess 0d7df7285b0876bac90b1374682e6eea Star Wars: The Clone Wars http://www.lostfilm.tv/browse.php?cat=96 1 season 2 =]]> House M.D. http://www.lostfilm.tv/browse.php?cat=51 2 season 6 =]]> Stargate Universe http://www.lostfilm.tv/browse.php?cat=109 3 season 2 =]]> The IT Crowd http://www.lostfilm.tv/browse.php?cat=46 4 season 3 ]]> Eureka http://www.lostfilm.tv/browse.php?cat=37 5 season 3 ]]> Futurama http://www.lostfilm.tv/browse.php?cat=127 6 season 3 ]]> V http://www.lostfilm.tv/browse.php?cat=111 7 twatch-0.0.7/config/twatch.xsd0000644000175000017500000000273011316156171015313 0ustar rubinrubin Project schema for TWatch twatch-0.0.7/twatch0000755000175000017500000000553211517522266013264 0ustar rubinrubin#!/usr/bin/perl use warnings; use strict; use lib qw(lib); use utf8; use open qw(:utf8 :std); use vars qw($VERSION $PROGRAM); $VERSION = '0.0.7'; $PROGRAM = 'twatch'; use Getopt::Long; use Pod::Usage; use TWatch; use TWatch::Config; use TWatch::Plugin; use TWatch::Message; ################################################################################ # Processing options ################################################################################ my ($help, $verbose, $execute, $debug); GetOptions( 'help|?' => \$help, 'verbose|?' => \$verbose, 'execute=s' => \$execute, 'debug|?' => \$debug, ) or pod2usage(2); pod2usage(1) if $help; # Disable output buffering if verbose $|=1 if $verbose; config->set(verbose => $verbose); config->set(execute => $execute); config->set(debug => $debug); ################################################################################ # Execute ################################################################################ notify('Loading'); # Create main programm object my $twatch = TWatch->new() or die "Can`t create Twatch object."; notify('Start execute projects'); # Execute projects $twatch->run; notify('Send notification mail'); # Send notification mail message->send(); notify('Execute post plugins'); # Execute post plugins my $plugins = TWatch::Plugin->new(verbose => $verbose) or die "Can`t create TWatch::Plugin object."; $plugins->post( $twatch ); notify('Done'); exit 0; __END__ =head1 NAME twatch - watch torrent trackers and automatically download new torrents =head1 SYNOPSIS twatch [options] Options: -v|--verbose - Verbose output -h|--help - Read this help and exit -d|--debug - Debug mode print all params derived and parsed from torrent tracker -e|--execute FILENAME - Run project by it`s FILENAME =head1 DESCRIPTION twatch is a simple and flexible watcher torrent trackers, based on regular and xpath expressions. It can download new torrent files and information about them by customizable filters. =head1 REQUESTS & BUGS Roman V. Nikolaev =head1 AUTHORS Copyright (C) 2008 Roman V. Nikolaev =head1 LICENSE 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 3 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, see . =cuttwatch-0.0.7/Makefile0000644000175000017500000000577611460252043013504 0ustar rubinrubin############################################################################ # # Makefile for TWatch. # Get progect from svn, create source code archive, generate documentation # and build deb package. # # Simple create directory "twatch" # copy this file in it # and execute: make all # ############################################################################ VERSION = $(shell grep -P "^[$$]VERSION" twatch | sed "s~[^[:digit:].]~~g") SVN = http://svn.twatch.rshadow.ru/trunk/ # Make new release from local path (deb package and files for mainteiner) .PHONY: all all: @echo "*** Full build from local ***" @make clean @make get && make doc && make orig && make build # Get source from local path (prepare to make deb package) .PHONY: get get: @echo "*** Get last from local ***" @test -d build || mkdir build @cd build/ && svn export ../ twatch-$(VERSION) # Make new release from svn (deb package and files for mainteiner) .PHONY: all_svn all_svn: @echo "*** Full build form SVN ***" @make clean @make get_svn && make doc && make orig && make build # Get source from svn (prepare to make deb package) .PHONY: get_svn get_svn: @echo "*** Get last from SVN ***" @test -d build || mkdir build @cd build/ && svn export $(SVN)/twatch/ twatch-$(VERSION) # Creatre doc in cource directory (prepare to make deb package) .PHONY: doc doc: @echo "*** Create man pages ***" @cd build/ && pod2man twatch-$(VERSION)/twatch > twatch-$(VERSION)/man/twatch.man # Create orig archive .PHONY: orig orig: @echo "*** Create sorce archive ***" @cd build/ && tar -czvf twatch_$(VERSION).orig.tar.gz twatch-$(VERSION) \ --exclude twatch-$(VERSION)/debian # Create local deb package .PHONY: build build: @echo "*** Create deb package ***" @cd build/ && chmod -R a+x twatch-$(VERSION)/debian/rules @cd build/ && cd twatch-$(VERSION) && debuild -sa # Clear all files in build/ directory .PHONY: clean clean: @echo "*** Clean all ***" @echo "Pause 5 sec. You can stop it by press Ctrl+C..." @sleep 5 @cd build/ && rm -fr ./*twatch* # Install use Debian package system .PHONY: install install: @echo "*** Install packages ***" @cd build/ && dpkg --install ./*twatch*.deb # Uninstall use Debian package system .PHONY: uninstall uninstall: @echo "*** Uninstall packages ***" @cd build/ && dpkg --purge twatch libtwatch-perl # Test source code by scripts in t/ directory .PHONY: tests tests: @set -e; find t/ -name '*.t'|while read test; do perl $$test; done # Send new release to mainteiner via email .PHONY: mail mail: @echo "New files attached" | \ @mutt -x -s "New TWatch version $(VERSION)" \ -a build/twatch_$(VERSION).dsc \ build/twatch_$(VERSION).tar.gz \ build/twatch_$(VERSION).orig.tar.gz \ -- dimka@uvw.ru # Sent to mentors.debian.net .PHONY: mentors mentors: @cd build/ && dput mentors twatch_$(VERSION)*.changes # Get source from svn. After usage delete this file because in created twatch # directory has one and newest. .PHONY: src src: @echo "*** Get source from svn ***" @svn checkout $(SVN)/twatch/ ./twatch twatch-0.0.7/doc/0000755000175000017500000000000011517522540012577 5ustar rubinrubintwatch-0.0.7/doc/twatch.Changelog0000644000175000017500000000006711515244472015710 0ustar rubinrubin0.0.6 (17.01.2011) * Add cookie 0.0.5 * Fix spellingtwatch-0.0.7/doc/twatch.TODO0000644000175000017500000000005611316156171014561 0ustar rubinrubin * Make site - catalog of regular expressions.twatch-0.0.7/lib/0000755000175000017500000000000011517522540012600 5ustar rubinrubintwatch-0.0.7/lib/TWatch.pm0000644000175000017500000001005311517522266014334 0ustar rubinrubinpackage TWatch; =head1 NAME TWatch - track for links on tracker and download new torrents. =cut our $VERSION = '0.0.7'; use strict; use warnings; use utf8; use TWatch::Config; use TWatch::Project; use TWatch::Watch; =head1 CONSTRUCTOR AND MAIN =cut =head2 new Main constructor =cut sub new { my ($class, %opts) = @_; my %obj = %opts; my $self = bless \%obj ,$class; $self->load; return $self; } =head2 run Run execute downloads. =cut sub run { my ($self) = @_; my @projects = $self->get; notify(sprintf 'Total projects: %s', scalar @projects); for my $project (@projects) { notify(sprintf 'Start project: %s (%s), last update %s', $project->param('name'), $project->param('url'), $project->param('update') || 'Never'); notify(sprintf 'Watches: %d', scalar $project->watches); $project->run or warn sprintf 'Project "%s" aborted!', $project->param('name'); notify('Project complete'); } } =head1 PROJECT METHODS =cut =head2 load Load projects from files. Return count of loaded projects. =cut sub load { my ($self) = @_; # Get projects paths my @pfiles = glob(config->get('Project')); return unless @pfiles; # Get completed path my @cfiles = glob(config->get('Complete')); # Get executed param my $execute = config->get('execute'); notify(sprintf 'Execute param set. Run just "%s" project', $execute) if $execute; for my $pfile ( @pfiles ) { # Get complete file by related file name my ($pname) = $pfile =~ m~^.*/(.*?)$~; my ($cfile) = grep {m~/$pname$~} @cfiles; # If set --execute option, then skip project by filename next if $execute and $pname ne $execute; # Load project my $project = TWatch::Project->new(file => $pfile, cfile => $cfile); # Add in hash $self->{project}{$project->param('name')} = $project; } return scalar keys %{$self->{project}}; } =head2 get $name Return project by $name. If $name not defined return a hash or sorted array. =cut sub get { my ($self, $name) = @_; return sort {$a->param('order') <=> $b->param('order')} values %{$self->{project}} if ! defined $name and wantarray; return $self->{project} if ! defined $name; return $self->{project}{$name}; } =head1 UNSUPPORTED OR JUST FOR TWATCH-GTK COMPATIBLE =cut =head2 delete_project $name Delete project by $name. =cut sub delete_project { my ($self, $name) = @_; # Get project my $project = $self->get($name); warn 'Can`t delete project: Project does not exists.', return unless $project; # Delete project and unlink it`s files $project->delete(); # Delete project from projects hash delete $self->{project}{$name}; return 1; } =head2 add_project $new Add $new project. $new must be TWatch::Project object. Function fail if project this same name already exists. =cut sub add_project { my ($self, $new) = @_; if( $self->get( $new->param('name') ) ) { warn sprintf('Can`t add project "%s". This project already exists.', $new->param('name')); return; } $self->{project}{ $new->param('name') } = $new; } 1; =head1 REQUESTS & BUGS Roman V. Nikolaev =head1 AUTHORS Copyright (C) 2008 Roman V. Nikolaev =head1 LICENSE 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 3 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, see . =cut twatch-0.0.7/lib/TWatch/0000755000175000017500000000000011517522540013772 5ustar rubinrubintwatch-0.0.7/lib/TWatch/Plugin.pm0000644000175000017500000000371111425742272015574 0ustar rubinrubinpackage TWatch::Plugin; =head1 NAME TWatch::Plugin - Load and execute plugins =cut use strict; use warnings; use utf8; use File::Basename qw(dirname); use File::Path qw(make_path); use base qw(Exporter); our @EXPORT=qw(config DieDumper Dumper); use TWatch::Config; =head1 CONSTRUCTOR =cut =head2 new =cut sub new { my ($class, %opts) = @_; my $self = bless \%opts ,$class; return $self; } =head2 post Execute post plugins. =cut sub post { my ($self, $twatch) = @_; my @modules = glob(config->get('Plugin')); for my $module ( @modules ) { # Get plugin module name s/^.*\/(.*?)\.pm$/$1/, s/^(.*)$/TWatch::Plugin::$1/ for $module; # Load plugin eval "require $module"; printf("Can`t load plugin \"%s\": %s\n", $module, $@), next if $@; # Crape plugin object and set current cinfig my $plugin = eval{ $module->new( config ) }; printf("Can`t create plugin \"%s\": %s\n", $module, $@), next if $@ or !$plugin; # Execute plugin with TWatch object eval{ $plugin->run( $twatch ) }; printf("Can`t run plugin \"%s\": %s\n", $module, $@), next if $@; } } 1; =head1 REQUESTS & BUGS Roman V. Nikolaev =head1 AUTHORS Copyright (C) 2008 Roman V. Nikolaev =head1 LICENSE 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 3 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, see . =cut twatch-0.0.7/lib/TWatch/Watch/0000755000175000017500000000000011517522540015040 5ustar rubinrubintwatch-0.0.7/lib/TWatch/Watch/ResultList.pm0000644000175000017500000000545211430714145017514 0ustar rubinrubinpackage TWatch::Watch::ResultList; use warnings; use strict; use utf8; =head1 NAME TWatch::Watch::ResultList - Work with parsing page results list. =cut =head1 CONSTRUCTOR =cut sub new { my ($class, %opts) = @_; my $self = bless \%opts ,$class; return $self; } =head1 METHODS =cut =head2 delete $link Delete from results list by $link name. =cut sub delete { my ($self, $link) = @_; warn 'No result for delete' unless $self->{result}{ $link }; delete $self->{result}{ $link }; } =head2 get $param Add new result. If $param is hash, add result from it. If list of results hash, add all of them. =cut sub add { my ($self, $param) = @_; if( 'HASH' eq ref $param ) { $self->{result}{ $param->{link} } = $param; return $self->{result}{$param}; } elsif( 'ARRAY' eq ref $param ) { $self->{result}{ $_->{link} } = $_ for @$param; return scalar @$param; } } =head2 get $link Get result by $link =cut sub get { my ($self, $link) = @_; return %{ $self->{result} } if wantarray and !defined $link; return $self->{result}{$link}; } =head2 exists $link Return true if result by $link exists. =cut sub exists { my ($self, $link) = @_; return exists $self->{result}{$link}; } =head2 count Return count of list elements =cut sub count { my ($self) = @_; return scalar keys %{ $self->{result} }; } =head2 param $link, $name, $value Get parameter by $name from $link name. If set $value, then it`s apply first. =cut sub param { my ($self, $link, $name, $value) = @_; if(defined $link) { die 'Result not set' unless exists $self->{result}{$link}; $self->{result}{$link}{$name} = $value if defined $value; return $self->{result}{$link}{$name}; } elsif( defined $value ) { $self->{result}{$_}{$name} = $value for keys %{ $self->{result} }; } } =head2 keys Return results names list =cut sub keys { my ($self) = @_; return keys %{ $self->{result} }; } 1; =head1 REQUESTS & BUGS Roman V. Nikolaev =head1 AUTHORS Copyright (C) 2008 Roman V. Nikolaev =head1 LICENSE 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 3 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, see . =cut twatch-0.0.7/lib/TWatch/Watch/FilterList.pm0000644000175000017500000000336311425742272017470 0ustar rubinrubinpackage TWatch::Watch::FilterList; use warnings; use strict; use utf8; =head1 NAME TWatch::Watch::FilterList - Filters list module. =cut =head1 CONSTRUCTOR =cut sub new { my ($class, %opts) = @_; my $self = bless \%opts ,$class; return $self; } =head1 METHODS =cut =head2 count Return count of list elements =cut sub count { my ($self) = @_; return scalar keys %{ $self->{filters} }; } =head2 param $filter, $name, $value Get parameter by $name from $filter name. If set $value, then it`s apply first. =cut sub param { my ($self, $filter, $name, $value) = @_; die 'Can`t find filter' unless exists $self->{filters}{$filter}; return $self->{filters}{$filter} unless defined $name or defined $value; $self->{filters}{$filter}{$name} = $value if defined $value; return $self->{filters}{$filter}{$name}; } =head2 keys Return filters names list =cut sub keys { my ($self) = @_; return keys %{ $self->{filters} }; } 1; =head1 REQUESTS & BUGS Roman V. Nikolaev =head1 AUTHORS Copyright (C) 2008 Roman V. Nikolaev =head1 LICENSE 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 3 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, see . =cuttwatch-0.0.7/lib/TWatch/Watch/Reg.pm0000644000175000017500000001074511430714145016120 0ustar rubinrubinpackage TWatch::Watch::Reg; use warnings; use strict; use utf8; use HTML::TreeBuilder; use HTML::TreeBuilder::XPath; use TWatch::Config; =head1 NAME TWatch::Watch::Reg - Модуль работы с регулярниками пользователя =cut use constant DEFAULT_XPATH_LINK => '//a[contains(@href, ".torrent")]/@href'; =head1 CONSTRUCTOR =cut sub new { my ($class, %opts) = @_; my $self = bless \%opts ,$class; # Set defaul params if not set $self->xparam('link', DEFAULT_XPATH_LINK) unless $self->xparam('link'); return $self; } =head1 METHODS =cut =head2 rparam $name, $value Get or set new regexp parameter value =cut sub rparam { my ($self, $name, $value) = @_; $self->{reg}{$name} = $value if defined $value; return $self->{reg}{$name}; } =head2 xparam $name, $value Get or set new xpath parameter value =cut sub xparam { my ($self, $name, $value) = @_; $self->{xpath}{$name} = $value if defined $value; return $self->{xpath}{$name}; } =head2 xkeys Get xpath params keys =cut sub xkeys { my ($self) = @_; return keys %{ $self->{xpath} }; } =head2 rkeys Get regexp params keys =cut sub rkeys { my ($self) = @_; return keys %{ $self->{reg} }; } =head2 tparam $value Get or set new xpath parameter for tree mode =cut sub tparam { my ($self, $value) = @_; $self->{tree} = $value if defined $value; return $self->{tree}; } =head2 xmatch $content Parse $content by xpath and return matches. Parsing depends of tracker $type. =cut sub match { my ($self, $content) = @_; my $tree = HTML::TreeBuilder::XPath->new_from_content( $content ); $tree->eof(); $tree->elementify(); my %result; for my $name ( $self->xkeys ) { my @value = $tree->findnodes( $self->xparam($name) ); unless( @value ) { push @{ $result{$name} }, (); next; } @value = map {$_->getValue} @value; # Try to apply regexp to value if it exist # Get regexp and clean it my $reg = $self->rparam($name) || ''; s/^\s+//, s/\s+$// for $reg; if($reg) { for my $value ( @value ) { ($value) = $value =~ m/$reg/si; next unless $value; $value = int $value if $value =~ m/^\d+$/; } } # Add values to result push @{ $result{$name} }, @value; } my $count = scalar @{ $result{link} }; for my $name ( $self->xkeys ) { next if $count == scalar @{ $result{$name} }; warn sprintf 'Data sizes for "%s" not match. XPath corrupted.', $name; $result{$name} = [(undef) x $count]; } $tree->delete(); # Transform to easy use form my @result; while (@{ $result{link} }) { my %res; $res{$_} = shift @{$result{$_}} for keys %result; # Clean from tags ($res{$_}) ?() :next, $res{$_} =~ s/<\/?\s*br>/\n/g, $res{$_} =~ s/<.*?>//g for keys %res; push @result, \%res; } printf "Debug (Find params):\n%s\n", Dumper \@result if config->get('debug'); return @result if wantarray; return \@result; } =head2 url Get url fro tree =cut sub url { my ($self, $content) = @_; my $tree = HTML::TreeBuilder::XPath->new_from_content( $content ); $tree->eof(); $tree->elementify(); my @result; {{ @result = $tree->findnodes( $self->tparam ); last unless @result; @result = map {$_->getValue} @result; }} printf "Debug (Find url for Tree mode):\n%s\n", Dumper \@result if config->get('debug'); return @result if wantarray; return \@result; } 1; =head1 REQUESTS & BUGS Roman V. Nikolaev =head1 AUTHORS Copyright (C) 2008 Roman V. Nikolaev =head1 LICENSE 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 3 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, see . =cut twatch-0.0.7/lib/TWatch/Plugin/0000755000175000017500000000000011517522540015230 5ustar rubinrubintwatch-0.0.7/lib/TWatch/Plugin/Example.pm0000644000175000017500000000331711410410513017151 0ustar rubinrubinpackage TWatch::Plugin::Example; =head1 NAME TWatch::Plugin::Example - example of TWatch post plugin =head1 SYNOPTICS use TWatch::Config; sub new { my ($class, $config) = @_; ... # Initialization code } sub run { my ($self, $twatch) = @_; ... # Get TWatch object and work with it. It contain all projects, # it tasks and info about completed tasks } =head1 DESCRIPTION Use this example to write you own behavior after new *.torrent files download. For example add downloaded *.torrents in your torrent client to start download them, if your client not support autostart torrent form listen directory. =cut use strict; use warnings; use utf8; use TWatch::Config; sub new { my ($class, $config) = @_; return bless {string => 'Example plugin successfully attached.'}, $class; } sub run { my ($self, $twatch) = @_; printf "%s\n", $self->{string}; } =head1 REQUESTS & BUGS Roman V. Nikolaev =head1 AUTHORS Copyright (C) 2008 Roman V. Nikolaev =head1 LICENSE 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 3 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, see . =cut 1;twatch-0.0.7/lib/TWatch/Config.pm0000644000175000017500000002006411425742272015543 0ustar rubinrubinpackage TWatch::Config; =head1 NAME TWatch::Config - Load project configuretion =cut use strict; use warnings; use utf8; use File::Basename qw(dirname); use File::Path qw(make_path); use POSIX qw(strftime); use base qw(Exporter); our @EXPORT=qw(config notify DieDumper Dumper); ############################################################################### # This section contains some paths for use in this program # Edit this for some OS # I think no any place to change. If it`s wrong, please inform me. # (Except config file) ################################################################################ use constant TWATCH_SYSTEM_CONFIG_PATH => '/etc/twatch/twatch.conf'; use constant TWATCH_CONFIG_PATH => '~/.twatch/twatch.conf'; use constant TWATCH_LOG_PATH => '~/.twatch/twatch.log'; ############################################################################### # Colors for highlight console output use constant COLOR_RED => "\e[1;31m"; use constant COLOR_GREEN => "\e[1;32m"; use constant COLOR_YELLOW => "\e[1;33m"; use constant COLOR_CLEAR => "\e[0m"; =head1 CONSTRUCTOR =cut =head2 config Load and cache configuratuon. Use this funtction for access configuration params. =cut sub config { our $config; return $config if $config; $config = TWatch::Config->new; return $config; } =head2 new Load and return configuration object =cut sub new { my ($class, %opts) = @_; my %config = (dir => {}, param => {}); # Версии конфигов $config{dir}{config} = [ TWATCH_SYSTEM_CONFIG_PATH, TWATCH_CONFIG_PATH, ]; my $self = bless \%config ,$class; # Load config $self->load; # Check configuration # $self->check; # Create dirs (if not exists) $self->create_dir; # Open log file and print data my $path = TWATCH_LOG_PATH; $path =~ s/^~/$ENV{HOME}/;# glob $path; $self->set('Log', $path); open my $h, '+>>:encoding(UTF-8)', $path or die 'Can`t open log file: '.$!; printf $h "*** %s ***\n", POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime(time)); $self->set('hLog', $h); return $self; } sub DESTROY { my ($self) = @_; # Close log file if( $self->get('hLog') ) { close $self->get('hLog') or die 'Can`t close log file: '.$!; } } ################################################################################ =head1 METHODS =cut =head2 load Load current config =cut sub load { my ($self) = @_; # Flag successful loaded my $loaded = 'no'; # Loading: first default config, next over users config for my $config ( @{$self->{dir}{config}} ) { # Get abcoulete path ($config) = glob $config; # Next if file not exists next unless -f $config; # Open config file open my $file, '<', $config or warn sprintf('Can`t read config file %s : %s', $config, $!); next unless $file; # Read and parse file. Next hash write over previus configuration hash %{ $self->{param} } = ( %{ $self->{param} }, ( map{ split m/\s*=\s*/, $_, 2 } grep m/=/, map { s/#\s.*//; s/^\s*#.*//; s/\s+$//; s/^\s+//; $_ } <$file> ) ); # Close file and mark successful loaded close $file; $loaded = 'yes'; } # Exit if no one config exists die 'Config file not exists' unless $loaded eq 'yes'; # Save original because it can be edit by user (twatch-gtk) %{ $self->{orig} } = %{ $self->{param} }; # Transform some parameters for comfort usage $self->{param}{EmailLevel} = [ split ',', $self->{param}{EmailLevel} ]; s/^\s*//, s/\s*$// for @{ $self->{param}{EmailLevel} }; $self->{param}{NoProxy} = ($self->{param}{NoProxy} =~ m/^(1|yes|true|on)$/i) ?1 :0; return 1; } =head2 get $name Get parameter by $name. =cut sub get { my ($self, $name) = @_; return $self->{param}{$name}; } =head2 get_orig $name Get original (as in config file) parameter by $name. =cut sub get_orig { my ($self, $name) = @_; return $self->{orig}{$name}; } =head2 set $name, $value Set new $value for parameter by $name. =cut sub set { my ($self, $name, $value) = @_; $self->{param}{$name} = $value; } ################################################################################ =head1 NOTIFICATIONS METHODS =cut =head2 notify $message, $level, $wait Send $message to standart output. Param $level ( good|warn|bad ) highlight the message. The $wait indicate print or not \n in the end of message. =cut sub notify { my ($message, $level, $wait) = @_; # Skip unless message return unless $message; # Format message by module $message = ((' ') x 2) . $message if caller eq 'TWatch'; $message = ((' ') x 4) . $message if caller eq 'TWatch::Project'; $message = ((' ') x 6) . $message if caller eq 'TWatch::Watch'; # Unless waiting flag print \n $message .= "\n" unless $wait; # Print to log file my $h = config->get('hLog'); print $h $message; # Skip if output disabled return unless config->get('verbose'); # Highlight message $level = lc $level || ''; if( $level eq 'good' ) { $message = COLOR_GREEN . $message . COLOR_CLEAR } elsif( $level eq 'warn' ) { $message = COLOR_YELLOW . $message . COLOR_CLEAR } elsif( $level eq 'bad' ) { $message = COLOR_RED . $message . COLOR_CLEAR } print $message; } ################################################################################ =head1 MORE FUNCTIONS =cut =head2 create_dir Create directories in user home path if it is not exists. =cut sub create_dir { my ($self) = @_; # Create list of directories for my $param ('Save', 'Project', 'Complete') { # Get path my $path = $self->get($param); # Get absoulete path $path =~ s/^~/$ENV{HOME}/;# glob $path; # Set new absoulete path in configuration $self->set($param, $path); # Get dirs from params (It can consist mask and etc.) # (Save is a directory) my $dir = $path; $dir = dirname( $dir ) unless $param eq 'Save'; # Next if directory exists next if -d $dir; # Create one eval{ make_path $dir; }; die sprintf("Can`t create store directory: %s, %s\n", $dir, $@) if $@; } } ################################################################################ =head1 DEBUG METHODS =cut =head2 DieDumper Print all params and die =cut sub DieDumper { require Data::Dumper; $Data::Dumper::Indent = 1; $Data::Dumper::Terse = 1; $Data::Dumper::Useqq = 1; $Data::Dumper::Deepcopy = 1; $Data::Dumper::Maxdepth = 0; my $dump = Data::Dumper->Dump([@_]); # юникодные символы преобразуем в них самих # вметсто \x{уродство} $dump=~s/(\\x\{[\da-fA-F]+\})/eval "qq{$1}"/eg; die $dump; } =head2 Dumper Get all params description =cut sub Dumper { require Data::Dumper; $Data::Dumper::Indent = 1; $Data::Dumper::Terse = 1; $Data::Dumper::Useqq = 1; $Data::Dumper::Deepcopy = 1; $Data::Dumper::Maxdepth = 0; my $dump = Data::Dumper->Dump([@_]); return $dump; } 1; =head1 REQUESTS & BUGS Roman V. Nikolaev =head1 AUTHORS Copyright (C) 2008 Roman V. Nikolaev =head1 LICENSE 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 3 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, see . =cut twatch-0.0.7/lib/TWatch/Project.pm0000644000175000017500000002441011517303620015733 0ustar rubinrubinpackage TWatch::Project; =head1 NAME TWatch::Project - Project module: work with torrent tracker. =cut use strict; use warnings; use utf8; use XML::Simple; use WWW::Mechanize; use HTTP::Cookies; use TWatch::Config; use TWatch::Watch; use TWatch::Complete; =head1 CONSTRUCTOR =cut =head2 new Create new project =head3 Required options: =over =item file Path to project file =back =cut sub new { my ($class, %opts) = @_; my $self = bless \%opts ,$class; # If project file path exists then load them $self->load if $self->param('file'); return $self; } =head1 DATA METHODS =cut =head2 param $name, $value If defined $value set param $name value. Unless return it`s value. =cut sub param { my ($self, $name, $value) = @_; die 'Undefined param name' unless $name; die 'Use public methods' if $name eq 'watches'; $self->{$name} = $value if defined $value; return $self->{$name}; } =head2 auth $name, $value If defined $name get project authtorization parameter. If defined $value then first set it. Unless defined $name but defined $value, then set auth hash and return it. Return auth hash unless defined params. =cut sub auth { my ($self, $name, $value) = @_; $self->{authtorization} = $value if !defined $name and 'HASH' eq ref $value; if($name eq 'url') { $self->{authtorization}{url} = $value if defined $value; return $self->{authtorization}{url}; } elsif($name eq 'login_name') { $self->{authtorization}{login}{name} = $value if defined $value; return $self->{authtorization}{login}{name}; } elsif($name eq 'password_name') { $self->{authtorization}{password}{name} = $value if defined $value; return $self->{authtorization}{password}{name}; } elsif($name eq 'login_value') { $self->{authtorization}{login}{value} = $value if defined $value; return $self->{authtorization}{login}{value}; } elsif($name eq 'password_value') { $self->{authtorization}{password}{value} = $value if defined $value; return $self->{authtorization}{password}{value}; } return $self->{authtorization}; } =head2 cookies $name Get additional cookies from config. =cut sub cookies { my ($self) = @_; return values %{$self->{cookies}}; } =head2 watches $param Get/Set task $param. If $param not set, then return list of watches or return count in scalar context. =cut sub watches { my ($self, $param) = @_; if( defined $param ) { # Set task if $param is set and it`s object $self->{watches}->{ $param->param('name') } = $param if ref $param; # Return task if $param is set return $self->{watches}{$param}; } else { # Unless defined param return sort watches array # or count in scalar context return sort {$a->param('order') <=> $b->param('order')} values %{ $self->{watches} } if wantarray; return scalar keys %{ $self->{watches} }; } } =head2 complete Get complete list object. =cut sub complete { return shift()->{complete} } =head1 LOAD METHODS =cut =head2 load Load project from file =cut sub load { my ($self) = @_; # Load completed $self->{complete} = TWatch::Complete->new(cfile => $self->param('cfile')) or die 'Can`t load complete object'; $self->param('update' => $self->complete->param('update')); # Load project from file my $xs = XML::Simple->new( NoAttr => 1, ForceArray => ['watch', 'result', 'filter'], GroupTags => { 'watches' => 'watch', 'complete' => 'result', 'filters' => 'filter', }, ); my $project = $xs->XMLin( $self->param('file') ); return unless $project; # Add tasks in project for my $name ( keys %{ $project->{watches} } ) { # Create task object my $watch = TWatch::Watch->new( %{ $project->{watches}{$name} }, name => $name, complete => $self->complete->get($name) ); # Add task to project $self->watches( $watch ); } # Delete tasks from bufer (all already in project) delete $project->{watches}; # Append additional params $self->{$_} = $project->{$_} for keys %$project; return $self; } =head2 delete Delete project and it`s files =cut sub delete { my ($self) = @_; # Delete project files unlink $self->param('file') or warn sprintf 'Can`t delete project file %s', $self->param('file'); unlink $self->param('cfile') or warn sprintf 'Can`t delete complete file %s', $self->param('cfile'); undef $self; } =head1 DOWNLOAD METHODS =cut =head2 run Execute project =cut sub run { my ($self) = @_; unless( scalar $self->watches ) { notify('No watches. Skip project.'); return; } # Get brauser object already authtorized on tracker notify('Authtorization...'); my $browser = $self->get_auth_browser; # Skip unless brouser or authtorized unless ($browser) { warn sprintf 'Link break. Skip project.'; return; } # Run all tasks my @watches = $self->watches; for my $watch ( @watches ) { notify(sprintf 'Start watch: %s', $watch->param('name') ); # Execute task $watch->run( $browser ) or warn sprintf 'Watch aborted!'; notify('Watch complete'); # Sleep between watches unless( $watch->param('name') eq $watches[$#watches]->param('name') ) { notify(sprintf 'Sleep %d seconds', config->get('TimeoutWatch')); sleep config->get('TimeoutWatch'); } } # Set last update time $self->param('update', POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime(time)) ); notify(sprintf 'Complete at %s', $self->param('update')); # Save completed to file notify('Save completed list'); $self->complete->save( $self ); return $self; } =head2 get_auth_browser Get browser object authtorized on tracker =cut sub get_auth_browser { my ($self) = @_; return undef unless $self->param('url'); # Get domain from url my ($domain) = $self->param('url') =~ m{^(?:\w+://)?(.*?)(?:/|$)}; # Set cookie if exists my $cookie_jar = HTTP::Cookies->new; $cookie_jar->set_cookie( $_->{version} || undef, $_->{name}, $_->{value}, $_->{path} || '/', $_->{domain} || $domain || '*', $_->{port} || undef, $_->{path_spec} || 1, $_->{secure} || undef, $_->{maxage} || 86400, $_->{discard} || undef) for $self->cookies; # Create browser object my $browser = WWW::Mechanize->new( agent => 'Mozilla/5.0'. ' (Windows; U; Windows NT 6.0; en-US; rv:1.9.1.1)'. ' Gecko/20090715 Firefox/3.5.1', cookie_jar => $cookie_jar, noproxy => config->get('NoProxy'), quiet => (config->get('verbose')) ?0 :1, ); if( $self->param('url') ) { notify('Go to main page'); # Many sites have protection from outside coming. # So go to main page first. eval{ $browser->get( $self->param('url') ); }; if( !$browser->success or ($@ and $@ =~ m/Can't connect/) ) { notify( sprintf 'Can`t connect to link: %s.', $self->param('url')); return undef; } } # If authtorization form not on main page (and set in config) then go to # this page if( $self->auth('url') and $self->auth('url') !~ m/^\s*$/ and $self->auth('url') ne $self->param('url') ) { notify('Go to authtorization page'); eval{ $browser->get( $self->auth('url') ); }; if( !$browser->success or ($@ and $@ =~ m/Can't connect/) ) { notify( sprintf 'Can`t connect to auth link: %s.', $self->auth('url')); return undef; } } # If authtorization exists params then do authtorization if($self->auth('login_name') and $self->auth('password_name') and $self->auth('login_value') and $self->auth('password_value')) { notify('Make authtorization'); # Find authtorization form (it`s set to default form) my $form = $browser->form_with_fields( $self->auth('login_name'), $self->auth('password_name') ); # Skip if can`t find authtorization form unless( $form ) { notify( sprintf 'Can`t find authtorization form in "%s" project.', $self->param('name') ); return undef; } # Set authtorization params in form $browser->field( $self->auth('login_name'), $self->auth('login_value') ) if $self->auth('login_name') and $self->auth('login_value'); $browser->field( $self->auth('password_name'), $self->auth('password_value') ) if $self->auth('password_name') and $self->auth('password_value'); # Authtorization eval{ $browser->click(); }; # Check if all OK if( !$browser->success or ($@ and $@ =~ m/Can't connect/) or !$browser->is_html() ) { notify( sprintf 'Can`t authtorize in "%s" project.', $self->param('name')); return undef; } } # Return browser return $browser; } 1; =head1 REQUESTS & BUGS Roman V. Nikolaev =head1 AUTHORS Copyright (C) 2008 Roman V. Nikolaev =head1 LICENSE 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 3 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, see . =cut twatch-0.0.7/lib/TWatch/Message.pm0000644000175000017500000000707711425742272015733 0ustar rubinrubinpackage TWatch::Message; =head1 NAME TWatch::Message - collect and send messges to user =head1 SYNOPSIS use TWatch::Message; =cut use strict; use warnings; use utf8; use base qw(Exporter); our @EXPORT=qw(message); use MIME::Lite; use MIME::Base64; use MIME::Words ':all'; use Sys::Hostname; use Encode qw(decode encode is_utf8); use TWatch::Config; =head1 MESSAGE METHODS =cut =head2 message Return singleton message object =cut sub message { # Object singleton our $object; return $object if $object; $object = TWatch::Message->new; return $object; } =head2 new Create message object =cut sub new { my ($class, %opts) = @_; my $self = bless \%opts ,$class; $self->{quie} = []; return $self; } =head2 add %opts Add message %opts to collector. Message consist from =over =item message Message text. =item level Message level: info, error. =back =cut sub add { my ($self, %opts) = @_; push @{ $self->{quie} }, \%opts; return 1; } =head2 get Get messages from collector =cut sub get { my ($self) = @_; return @{ $self->{quie} } if wantarray; return $self->{quie}; } =head2 has How many messages in collector. Can be used as boolean flag. =cut sub count { my ($self) = @_; return scalar @{ $self->{quie} }; } =head1 EMAIL METHODS =cut =head2 send Send collected messages on email =cut sub send { my ($self) = @_; # Skip if no messages return 0 unless $self->count; # Skip if level = none return 0 if 'none' ~~ @{ config->get('EmailLevel') }; # Skip if no destination address return 0 unless config->get('Email'); my @messages = $self->get; @messages = grep {$_->{level} ~~ @{ config->get('EmailLevel') }} @messages; # Style messages for mail @messages = map { my $message = $_; my $str = $message->{message}; $str .= "\n"; $str .= sprintf("%-18s %s\n", $_.':', $message->{data}{$_} || '') for keys %{ $message->{data} }; $str; } @messages; # Send mail { my $msg = new MIME::Lite( From => sprintf( 'TWatch ', hostname), To => config->get('Email'), Subject => sprintf( 'TWatch: %d messages', scalar @messages), Type => "text/plain; charset=utf-8", Data => encode( utf8 => join( ("\n".('#') x 80 ."\n\n"), @messages) ), 'X-Service' => 'twatch', ); eval { $msg->send; }; if( $@ ) { warn sprintf 'Can`t send email to %s : $s', config->get('Email'), $@; } else { notify( sprintf 'Sended %d messages in mail', scalar @messages ); } # Clean memory undef @messages, $msg; } } 1; =head1 REQUESTS & BUGS Roman V. Nikolaev =head1 AUTHORS Copyright (C) 2008 Roman V. Nikolaev =head1 LICENSE 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 3 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, see . =cut twatch-0.0.7/lib/TWatch/Complete.pm0000644000175000017500000001065011425753702016106 0ustar rubinrubinpackage TWatch::Complete; =head1 NAME TWatch::Watch::CompleteList - Load and save completed tasks for watch =cut use strict; use warnings; use utf8; use XML::Simple; use TWatch::Config; use TWatch::Watch::ResultList; =head1 CONSTRUCTORS =cut =head2 new Load completed tasks and return this object =cut sub new { my ($class, %opts) = @_; my $self = bless \%opts ,$class; $self->load if $self->{cfile}; return $self; } =head1 METHODS =cut =head2 load Load completed tasks =cut sub load { my ($self) = @_; my $xs = XML::Simple->new( NoAttr => 1, ForceArray => ['watch', 'result'], GroupTags => { 'watches' => 'watch', 'complete' => 'result', } ); # Load completed tasks for project my $complete = $xs->XMLin( $self->{cfile} ); # Fix XML in for my $name ( keys %{ $complete->{watches} } ) { # Add empty array even watch empty $complete->{watches}{$name}{complete} = [] unless %{ $complete->{watches}{$name} }; # Convert empty hashes in empty strings for my $result ( @{ $complete->{watches}{$name}{complete} } ) { for my $key ( keys %$result) { $result->{$key} = '' if 'HASH' eq ref $result->{$key} and !%{$result->{$key}}; } } my $results = TWatch::Watch::ResultList->new; $results->add( $complete->{watches}{$name}{complete} ); # Convert hash to result list object $complete->{watches}{$name} = $results; } # Set data to object $self->{$_} = $complete->{$_} for keys %$complete; return $self; } =head2 param $name, $value If defined $value set param $name value. Unless return it`s value. =cut sub param { my ($self, $name, $value) = @_; die 'Undefined param name' unless $name; die 'Use public methods' if $name eq 'watches'; $self->{$name} = $value if defined $value; return $self->{$name}; } =head2 get $name Get completed tasks for $name watch =cut sub get { my ($self, $name) = @_; # If completed not exists then create new one empty. $self->{watches}{$name} = TWatch::Watch::ResultList->new( name => $name, complete => [] ) unless exists $self->{watches}{$name}; return $self->{watches}{$name}; } =head2 save $project Save list completed tasks for $project =cut sub save { my ($self, $project) = @_; # Prepare watches array my @watches = $project->watches; for my $watch ( @watches ) { my %result = $watch->complete->get; $watch = { name => $watch->param('name'), ($watch->complete->count) ?(complete => { result => [values %result] }) :(), } }; # Make data to save my $save = { name => $project->param('name'), update => $project->param('update'), watches => { watch => \@watches }, }; # Get file name to save my $file = $project->param('cfile'); # Full path consists of completed path and project filename if it is # new file $file = (config->get('Complete') =~ m/^(.*)\/.*?$/)[0] . ($project->param('file') =~ m/^.*(\/.*?\.xml)$/)[0] unless $file; # Save completed my $xs = XML::Simple->new( AttrIndent => 1, KeepRoot => 1, RootName => 'project', NoAttr => 1, # NoEscape => 1, NoSort => 1, ForceArray => ['watch', 'result'], XMLDecl => 1, OutputFile => $file, ); my $xml = $xs->XMLout($save); return 1; } 1; =head1 REQUESTS & BUGS Roman V. Nikolaev =head1 AUTHORS Copyright (C) 2008 Roman V. Nikolaev =head1 LICENSE 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 3 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, see . =cut twatch-0.0.7/lib/TWatch/Watch.pm0000644000175000017500000002660011517260444015404 0ustar rubinrubinpackage TWatch::Watch; =head1 NAME TWatch::Watch task module to load torrents. =cut use strict; use warnings; use utf8; use POSIX (qw(strftime)); use WWW::Mechanize; use Safe; use TWatch::Config; use TWatch::Message; use TWatch::Watch::Reg; use TWatch::Watch::ResultList; use TWatch::Watch::FilterList; =head1 CONSTRUCTOR =cut sub new { my ($class, %opts) = @_; # Get params my ($reg, $xpath, $filters, $tree) = ( delete $opts{reg}, delete $opts{xpath}, delete $opts{filters}, delete $opts{tree} ); $opts{tree} = 1 if $tree; die 'Need complete list object' unless 'TWatch::Watch::ResultList' eq ref $opts{complete}; my $self = bless \%opts ,$class; # Replace oprs to objects $self->{reg} = TWatch::Watch::Reg->new( reg => $reg, xpath => $xpath, tree => $tree) or die 'Can`t create regexp object'; $self->{results} = TWatch::Watch::ResultList->new or die 'Can`t create result list object'; $self->{filters} = TWatch::Watch::FilterList->new( filters => $filters ) or die 'Can`t create filter list object'; # Set type of tracker # If tracker layout like this: # - Torrents list # |- Torrent 1 description # |- Link to 1.torrent # |- Torrent 2 description # |- Link to 2.torrent # |- Torrent 3 description # |- Link to 3.torrent # # this is tree type. List of torrents contain links to description # page. Then description page have link to torrent file. # This is main trackers layout. Example: thepiratebay.org, torrents.ru # If tracker layout like this: # - Torrent description # |- Link to 1.torrent # |- Link to 2.torrent # |- Link to 3.torrent # # this is linear type. Torrent have one description page and many # *.torrents links on it. # This trackers typically for series. Example: lostfilm.tv ($tree) ?$self->param('type', 'tree') :$self->param('type', 'linear'); return $self; } =head1 DATA METHODS =cut =head2 param $name, $value Get or set new parameter value =cut sub param { my ($self, $name, $value) = @_; $self->{$name} = $value if defined $value; return $self->{$name}; } =head2 reg Return regular expression object for user defined params. =cut sub reg { return shift()->{reg} } =head2 results Return results list object for task. =cut sub results { return shift()->{results} } =head2 filters Return filters list object for task. =cut sub filters { return shift()->{filters} } =head2 complete Return completed list object for task. =cut sub complete { return shift()->{complete} } =head1 DOWNLOAD METHODS =cut =head2 run $browser Do job to get new torrent files =over =item $browser WWW::Mechanize object. It`s must be authtorized and prepared for unlimited usage. =back =cut sub run { my ($self, $browser) = @_; unless( $self->param('url') ) { notify('Url not set. Skip watch.'); return; } notify(sprintf 'Get links list from %s', $self->param('url') ); # Get torrents links page eval{ $browser->get( $self->param('url') ); }; # Check for page content if( !$browser->success or ($@ and $@ =~ m/Can't connect/) ) { warn sprintf 'Can`t get content (links list) by link: %s', $self->param('url'); return; } # Get page content my $content = $browser->content; # Define torrent type (tree or linear) and get links for torrent description my @links; if ($self->param('type') eq 'tree') { # Parse links to description pages @links = $self->reg->url( $content ); } else { # Current page contain links. @links = ($self->param('url')); } notify(sprintf 'Watch type: %s', $self->param('type')); notify(sprintf 'Links count: %d', scalar @links) if $self->param('type') eq 'tree'; # For all description page get *.torrent files from them for my $url ( @links ) { # Get description page if( $self->param('type') eq 'tree' ) { notify(sprintf 'Get torrent page by tree from: %s.', $url); notify(sprintf 'Sleep %d seconds', config->get('TimeoutDownloads')); sleep config->get('TimeoutDownloads'); eval{ $browser->get( $url ); }; # Check for content if( !$browser->success or ($@ and $@ =~ m/Can't connect/) ) { warn sprintf 'Can`t get content (torrent page) by link: %s',$url; next; } # Get content $content = $browser->content; } # Remember absolutly url my $absoulete = $browser->uri->as_string(); # Parse links for *.torrents $self->parse( $content ); notify('Nothing to download. Skip Watch.'), next unless $self->results->count; # Add current page in result $self->results->param(undef, page => $absoulete); # Download torrents notify('NEW TORRENTS AVAILABLE!', 'good'); $self->download( $browser ); notify('Has not dowloaded torrents') if $self->results->count; } return $self; } =head2 parse $content Parse content for torrent data =over =item $content content of html page for parsing =back =cut sub parse { my ($self, $content) = @_; # Use users regexp to get fields notify('Get data by user regexp/xpath'); my @result = $self->reg->match( $content, $self->param('type') ); for my $result ( @result ) { # Skip if no fields found notify( sprintf('Links not found. Wrong regexp?: %s', $self->reg->rparam('link')), 'warn'), return unless $result->{link}; } $self->results->add( \@result ); # Remove from results already completed torrents if( $self->complete->count ) { notify('Drop completed torrents'); for my $key ( $self->complete->keys ) { $self->results->delete( $key ) if $self->results->exists( $key ); } } # Skip if no new torrents notify('All torrent already completed.'), return unless $self->results->count; {{ # Remove torrents by filters notify('Filter torrents'); # Skip if no filters last unless $self->filters->count; # Create sandbox for users expressions my $sandbox = Safe->new; # For each results for my $key ( $self->results->keys ) { # Get result my $result = $self->results->get($key); # Flag - result suit to filter (and be download) my $flag = 1; # For all filters for my $name ( $self->filters->keys ) { # printf "FILTER name: %s, value: %s, method: %s\n", # $name, $self->filters->param($name, 'value'), # $self->filters->param($name, 'method'); # printf "DATA: %s\n", $result->{$name}; # Remove result if no filters for them $flag = 0, last unless $result->{$name}; # Check filter my $left = $result->{$name}; my $right = $self->filters->param($name, 'value'); my $method = $self->filters->param($name, 'method') || '=~'; if($method eq '=~' or $method eq '!~') { # Eval filter $flag &&= $sandbox->reval(qq{"$left" $method $right}) } else { # Add squares for non digit values to prevent warnings $_ = ($_ =~ m/^\d+$/ ) ?$_ :'"'.$_.'"' for $left, $right; # Eval filter $flag &&= $sandbox->reval(qq{$left $method $right}); } # Skip if expression not valid warn sprintf( 'Can`t set filter %s: "%s %s %s", becouse %s', $name, $left, $method, $right, $@), next if $@; # results not coincide last unless $flag; } # Remove result if filter check fail $self->results->delete( $key ) unless $flag; } }} # Skip if no results (all filtered) notify('All links filtered'), return unless $self->results->count; return $self->results->count; } =head2 download $browser Download torrents listed in watch results. =over =item $browser WWW::Mechanize object. It`s must be authtorized and prepared for unlimited usage. =back =cut sub download { my ($self, $browser) = @_; # For each result download torrent for my $key ( $self->results->keys ) { my $result = $self->results->get( $key ); # Download torrent $browser->get( $result->{link} ); # If download complete store result in completed array if ($browser->success) { # Get torrent file data my $torrent = $browser->content; my $filename = $browser->response->filename; # Set path to store my $save = config->get('Save').'/'.$filename; # Save file or skip already dowloaded unless (-f $save or -s _) { open my $fh, '+>', $save or die $!; print $fh $torrent or die $!; close $fh or die $!; notify( sprintf 'Download complete: %s', $save ); # Add message about this completed result message->add( level => 'info', message => sprintf('Download complete: %s', $save), data => $result); } else { notify( sprintf 'Already exists. Skip download: %s', $save ); } # Put additional parameters $result->{datetime} = POSIX::strftime( "%Y-%m-%d %H:%M:%S", localtime(time)); $result->{torrent} = $filename; # Move result to completed $self->complete->add( $result ); $self->results->delete( $key ); } # If download fail add message about it else { notify( sprintf 'Can`t download from %s', $result->{link} ); message->add( level => 'error', message => sprintf('Can`t download from %s', $result->{link}), data => $result); } } return $self->results->count; } 1; =head1 REQUESTS & BUGS Roman V. Nikolaev =head1 AUTHORS Copyright (C) 2008 Roman V. Nikolaev =head1 LICENSE 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 3 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, see . =cut twatch-0.0.7/build/0000755000175000017500000000000011517522540013131 5ustar rubinrubintwatch-0.0.7/man/0000755000175000017500000000000011517522540012605 5ustar rubinrubintwatch-0.0.7/man/twatch.man0000644000175000017500000001246611517522541014606 0ustar rubinrubin.\" Automatically generated by Pod::Man 2.22 (Pod::Simple 3.07) .\" .\" Standard preamble: .\" ======================================================================== .de Sp \" Vertical space (when we can't use .PP) .if t .sp .5v .if n .sp .. .de Vb \" Begin verbatim text .ft CW .nf .ne \\$1 .. .de Ve \" End verbatim text .ft R .fi .. .\" Set up some character translations and predefined strings. \*(-- will .\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left .\" double quote, and \*(R" will give a right double quote. \*(C+ will .\" give a nicer C++. Capital omega is used to do unbreakable dashes and .\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff, .\" nothing in troff, for use with C<>. .tr \(*W- .ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' .ie n \{\ . ds -- \(*W- . ds PI pi . if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch . if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch . ds L" "" . ds R" "" . ds C` "" . ds C' "" 'br\} .el\{\ . ds -- \|\(em\| . ds PI \(*p . ds L" `` . ds R" '' 'br\} .\" .\" Escape single quotes in literal strings from groff's Unicode transform. .ie \n(.g .ds Aq \(aq .el .ds Aq ' .\" .\" If the F register is turned on, we'll generate index entries on stderr for .\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index .\" entries marked with X<> in POD. Of course, you'll have to process the .\" output yourself in some meaningful fashion. .ie \nF \{\ . de IX . tm Index:\\$1\t\\n%\t"\\$2" .. . nr % 0 . rr F .\} .el \{\ . de IX .. .\} .\" .\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). .\" Fear. Run. Save yourself. No user-serviceable parts. . \" fudge factors for nroff and troff .if n \{\ . ds #H 0 . ds #V .8m . ds #F .3m . ds #[ \f1 . ds #] \fP .\} .if t \{\ . ds #H ((1u-(\\\\n(.fu%2u))*.13m) . ds #V .6m . ds #F 0 . ds #[ \& . ds #] \& .\} . \" simple accents for nroff and troff .if n \{\ . ds ' \& . ds ` \& . ds ^ \& . ds , \& . ds ~ ~ . ds / .\} .if t \{\ . ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" . ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' . ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' . ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' . ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' . ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' .\} . \" troff and (daisy-wheel) nroff accents .ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' .ds 8 \h'\*(#H'\(*b\h'-\*(#H' .ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] .ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' .ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' .ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] .ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] .ds ae a\h'-(\w'a'u*4/10)'e .ds Ae A\h'-(\w'A'u*4/10)'E . \" corrections for vroff .if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' .if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' . \" for low resolution devices (crt and lpr) .if \n(.H>23 .if \n(.V>19 \ \{\ . ds : e . ds 8 ss . ds o a . ds d- d\h'-1'\(ga . ds D- D\h'-1'\(hy . ds th \o'bp' . ds Th \o'LP' . ds ae ae . ds Ae AE .\} .rm #[ #] #H #V #F C .\" ======================================================================== .\" .IX Title "TWATCH 1" .TH TWATCH 1 "2011-01-25" "perl v5.10.1" "User Contributed Perl Documentation" .\" For nroff, turn off justification. Always turn off hyphenation; it makes .\" way too many mistakes in technical documents. .if n .ad l .nh .SH "NAME" twatch \- watch torrent trackers and automatically download new torrents .SH "SYNOPSIS" .IX Header "SYNOPSIS" twatch [options] .PP .Vb 6 \& Options: \& \-v|\-\-verbose \- Verbose output \& \-h|\-\-help \- Read this help and exit \& \-d|\-\-debug \- Debug mode print all params derived and parsed \& from torrent tracker \& \-e|\-\-execute FILENAME \- Run project by it\`s FILENAME .Ve .SH "DESCRIPTION" .IX Header "DESCRIPTION" twatch is a simple and flexible watcher torrent trackers, based on regular and xpath expressions. It can download new torrent files and information about them by customizable filters. .SH "REQUESTS & BUGS" .IX Header "REQUESTS & BUGS" Roman V. Nikolaev .SH "AUTHORS" .IX Header "AUTHORS" Copyright (C) 2008 Roman V. Nikolaev .SH "LICENSE" .IX Header "LICENSE" This program is free software: you can redistribute it and/or modify it under the terms of the \s-1GNU\s0 General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. .PP This program is distributed in the hope that it will be useful, but \s-1WITHOUT\s0 \&\s-1ANY\s0 \s-1WARRANTY\s0; without even the implied warranty of \s-1MERCHANTABILITY\s0 or \&\s-1FITNESS\s0 \s-1FOR\s0 A \s-1PARTICULAR\s0 \s-1PURPOSE\s0. See the \s-1GNU\s0 General Public License for more details. .PP You should have received a copy of the \s-1GNU\s0 General Public License along with this program. If not, see .