Transmission-Client-0.0805/0000755001161000116100000000000012747415654014202 5ustar olofolofTransmission-Client-0.0805/Makefile.PL0000644001161000116100000000105712747415010016141 0ustar olofolof# ex:ts=4:sw=4:sts=4:et use inc::Module::Install; my $vcs = 'https://github.com/olof/Transmission-Client'; name q(Transmission-Client); all_from q(lib/Transmission/Client.pm); requires q(DateTime) => 0.50; requires q(JSON::MaybeXS) => 0; requires q(LWP::UserAgent) => 5.8; requires q(MIME::Base64) => 3.00; requires q(Moose) => 0.80; requires q(MooseX::Types) => 0.20; requires q(Sub::Exporter) => 0.95; requires q(List::MoreUtils) => 0; test_requires q(Test::More) => 0; repository $vcs; bugtracker "$vcs/issues"; auto_install; WriteAll(sign => 1); Transmission-Client-0.0805/META.yml0000644001161000116100000000151312747415650015447 0ustar olofolof--- abstract: 'Interface to Transmission' author: - '-2013, Jan Henning Thorsen and contributors' build_requires: ExtUtils::MakeMaker: 6.36 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.36 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.16' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Transmission-Client no_index: directory: - inc - t requires: DateTime: 0.5 JSON::MaybeXS: 0 LWP::UserAgent: 5.8 List::MoreUtils: 0 MIME::Base64: 3 Moose: 0.8 MooseX::Types: 0.2 Sub::Exporter: 0.95 resources: bugtracker: https://github.com/olof/Transmission-Client/issues license: http://dev.perl.org/licenses/ repository: https://github.com/olof/Transmission-Client version: '0.0805' Transmission-Client-0.0805/SIGNATURE0000644001161000116100000000711112747415654015466 0ustar olofolofThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.80. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA512 SHA1 ed15376fcf88189f4baef72bac241dfbbda6ae5c Changes SHA1 6272f6705e8869321d3eda276c7e0b7e7e303930 MANIFEST SHA1 9c6195dde9986212699ac40813eb37601fc48db3 MANIFEST.SKIP SHA1 f9dc384d8896e3f16575e83437082cd5a27f842c META.yml SHA1 ef7816bc64cae01a0401ab1256685a4b6ca68a52 Makefile.PL SHA1 25970f30f2a2790c5e58d447ae1d444a411035a9 README SHA1 fe12845a06227e1efbc38e6ce1e65be91bcca9ac bin/transmission-client.pl SHA1 9d3b2104a620fbaa1e5291400cb14385b205c8da inc/Module/AutoInstall.pm SHA1 bce3c51bb369419603298064b78e14077b93af66 inc/Module/Install.pm SHA1 93283b6d98078acdd04b242b3e994258821f4fe5 inc/Module/Install/AutoInstall.pm SHA1 fe220f215f645500ce8f14ff5e19d9a28692af56 inc/Module/Install/Base.pm SHA1 b56ed8e42c600e08007d152cf0b1438a7c3b7f6e inc/Module/Install/Can.pm SHA1 99c531a17a67ce5250df2ae151cc48c80d914cde inc/Module/Install/Fetch.pm SHA1 3e43ac0f1912c7d202dc102f6c31ad96fbf3a044 inc/Module/Install/Include.pm SHA1 76efdca3603159e0ae0e18f19fe72a0211a69529 inc/Module/Install/Makefile.pm SHA1 2e33e87882d60db3913da6284dd5295e5315e18a inc/Module/Install/Metadata.pm SHA1 c830b819e61bda5eca077c6291293bba61b3b9f2 inc/Module/Install/Win32.pm SHA1 cb52b9d6f88d512d448a6f35ed0af0d1201a134b inc/Module/Install/WriteAll.pm SHA1 edc750486cb6911cbf22cf34ba380c67c9c92036 lib/Transmission/AttributeRole.pm SHA1 df6d9eea53691be52a455adf5102238e94ac4a25 lib/Transmission/Client.pm SHA1 11202a5076d86bf99eeeebc0aa409b37c267f8f0 lib/Transmission/Session.pm SHA1 5528f808ad751231a3f2cf56f7d863df35ddac42 lib/Transmission/Stats.pm SHA1 7f030e485a5aee3e7d15d224f7df759340fa3f74 lib/Transmission/Torrent.pm SHA1 1b81c2d63dfe3b503fab6e50e07a2ff38e3769d2 lib/Transmission/Torrent/File.pm SHA1 ff54868614dabaaf5c4f10097c987803288df16c lib/Transmission/Types.pm SHA1 d4a58883248d6de7b3f16449f590f239f7c12665 lib/Transmission/Utils.pm SHA1 97edfe3f9c9622e867a9e3c1ca8716c9fb548494 t/00-load.t SHA1 883ff308e3ecd9acd2ce28ffd27e230df83ad6a9 t/00-pod-coverage.t SHA1 beba99dd1875b0f83c7662f2f932e69731ceeae2 t/00-pod.t SHA1 ea06e8f607c61c88273352b2c8d88c2877fe988e t/05-utils.t SHA1 9ee626086b93bf2254f483c2ec6c60ba4c2cb8b4 t/10-client.t SHA1 67408d6a997369be88add6cfa2869789405c2ebc t/10-torrent.t SHA1 1ccbfc08071ab4ea3a76949e9333de508a5560df t/10-types.t SHA1 385390cb7ad6483281fdefdbbdb03861450fec1b t/20-real.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1 iQIcBAEBCgAGBQJXnhupAAoJEFDVLxLOThOZ4eQQAITThqpH+I2EWA8EmmWdxkaf JG55lKA77X1RTpzc4Q29Jc9i2KZBn93pfl4tN+ahzhkm4SkItbs4NGvZNH6lHahp 0Q3Nn0NPekTc8ZWetqyA1j/+kfqk6lZhdOT5r7xM4FJpHfVunfTjX0Bu0RPMsCsF V4rtl50LlPN5lHOkGS21xePmuoka+EznBtGTOL7UWM68bMJ40xclIbXTfJyXcqqe iD/qSXZ9ujvBFW2F+QrBA1bULXKF/Bj7oMHrRK9cK8KmAe7DWU+39hrRLKSPeuZe cqfADRB32moIMyGdcuJgNn27umypoLfmNoCqhIiBFj/OeNUjSxAqFKNS+6ytCTvy tAHNxuzMl0678he4lpyN1b2MkgexKBi9VBnV3e+N0tm738i4+X002pnchnFOOe2q TNW1LjRQSatdkfyvlWq9/2FwCfL8EYI222bR1EPpquZv62kmabMNeETJY8WO/RDk KkRa5QqPjU4gannMleaHsEKy89aetbr1txw32vkzFxxlBZz61FhCQD5BxHMMJjcl kLvI5L6YuRQ/h0kSTVt8A7DCTinuxEoWXtMvnHS/uX9VemVMAqb4RiXs1+rVFMG6 bWvpzOtXNKHDXf2U6kb/tOnsRFy0l+pEYwl+P+v+GK0wKUccnMNa3ONMsBXDkPay wV8dzbOlXvB2U76G/quD =Cz+1 -----END PGP SIGNATURE----- Transmission-Client-0.0805/README0000644001161000116100000001501312747415575015064 0ustar olofolofNAME Transmission::Client - Interface to Transmission VERSION 0.0805 DESCRIPTION Transmission::Client is the main module in a collection of modules to communicate with Transmission. Transmission is: Transmission is a cross-platform BitTorrent client that is: * Easy * Lean * Native * Powerful * Free If you want to communicate with "transmission-daemon", this is a module which can help you with that. The documentation is half copy/paste from the Transmission RPC spec: This module differs from P2P::Transmission in (at least) two ways: This one use Moose and it won't die. The latter is especially annoying in the constructor. SYNOPSIS use Transmission::Client; my $client = Transmission::Client->new; my $torrent_id = 2; my $data = base64_encoded_data(); $client->add(metainfo => $data) or confess $client->error; $client->remove($torrent_id) or confess $client->error; for my $torrent (@{ $client->torrents }) { print $torrent->name, "\n"; for my $file (@{ $torrent->files }) { print "> ", $file->name, "\n"; } } print $client->session->download_dir, "\n"; FAULT HANDLING In 0.06 Transmission::Client can be constructed with "autodie" set to true, to make this object confess instead of just setting "error". Example: my $client = Transmission::Client->new(autodie => 1); eval { $self->add(filename => 'foo.torrent'); } or do { # add() failed... }; SEE ALSO Transmission::AttributeRole Transmission::Session Transmission::Torrent Transmission::Utils ATTRIBUTES url $str = $self->url; Returns an URL to where the Transmission rpc api is. Default value is "http://localhost:9091/transmission/rpc"; error $str = $self->error; Returns the last error known to the object. All methods can return empty list in addition to what specified. Check this attribute if so happens. Like "autodie"? Create your object with "autodie" set to true and this module will throw exceptions in addition to setting this variable. username $str = $self->username; Used to authenticate against Transmission. password $str = $self->password; Used to authenticate against Transmission. timeout $int = $self->timeout; Number of seconds to wait for RPC response. session $session_obj = $self->session; $stats_obj = $self->stats; Returns an instance of Transmission::Session. "stats()" is a proxy method on "session". torrents $array_ref = $self->torrents; $self->clear_torrents; Returns an array-ref of Transmission::Torrent objects. Default value is a full list of all known torrents, with as little data as possible read from Transmission. This means that each request on a attribute on an object will require a new request to Transmission. See "read_torrents" for more information. version $str = $self->version; Get Transmission version. session_id $self->session_id($str); $str = $self->session_id; The session ID used to communicate with Transmission. METHODS add $bool = $self->add(%args); key | value type & description -----------------+------------------------------------------------- download_dir | string path to download the torrent to filename | string filename or URL of the .torrent file metainfo | string torrent content paused | boolean if true, don't start the torrent peer_limit | number maximum number of peers Either "filename" or "metainfo" MUST be included. All other arguments are optional. See "3.4 Adding a torrent" from remove $bool = $self->remove(%args); key | value type & description -------------------+------------------------------------------------- ids | array torrent list, as described in 3.1 delete_local_data | boolean delete local data. (default: false) "ids" can also be the string "all". "ids" is required. See "3.4 Removing a torrent" from move $bool = $self->move(%args); string | value type & description ------------+------------------------------------------------- ids | array torrent list, as described in 3.1 location | string the new torrent location move | boolean if true, move from previous location. | otherwise, search "location" for files "ids" can also be the string "all". "ids" and "location" is required. See "3.5 moving a torrent" from start $bool = $self->start($ids); Will start one or more torrents. $ids can be a single int, an array of ints or the string "all". stop $bool = $self->stop($ids); Will stop one or more torrents. $ids can be a single int, an array of ints or the string "all". verify $bool = $self->stop($ids); Will verify one or more torrents. $ids can be a single int, an array of ints or the string "all". read_torrents @list = $self->read_torrents(%args); $array_ref = $self->read_torrents(%args); key | value type & description ------------+------------------------------------------------- ids | array torrent list, as described in 3.1 | this is optional lazy_read | will create objects with as little data as possible. List context Returns a list of Transmission::Torrent objects and sets the "torrents" attribute. Scalar context Returns an array-ref of Transmission::Torrent. rpc $any = $self->rpc($method, %args); Communicate with backend. This methods is meant for internal use. read_all 1 == $self->read_all; This method will try to populate ALL torrent, session and stats information, using three requests. LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. COPYRIGHT Copyright 2009-2013, Jan Henning Thorsen and contributors Current maintainer: Olof Johansson - "olof@cpan.org" Transmission-Client-0.0805/bin/0000755001161000116100000000000012747415651014747 5ustar olofolofTransmission-Client-0.0805/bin/transmission-client.pl0000755001161000116100000000555212573102655021315 0ustar olofolof#!/usr/bin/perl # Copyright 2009-2010, Jan Henning Thorsen # and contributors # # All rights reserved. # # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. =head1 NAME transmission-client.pl - Alternative to transmission-remote =head1 SYNOPSIS transmission-client.pl list; transmission-client.pl session; transmission-client.pl session $key $value; transmission-client.pl stats; =head1 DESCRIPTION This is an example application for L =cut use strict; use warnings; use lib qw(lib); use Transmission::Client; my $action = shift @ARGV or _help(); my $tc = Transmission::Client->new; if($action eq 'list') { printf "%3s %-34s %4s %4s %5s %5s\n", 'id', 'name', 'lcrs', 'sdrs', 'rate', 'eta'; print "-" x 79, "\n"; for my $torrent ($tc->read_torrents) { printf "%3i %-34s %4s %4s %5s %5s\n", $torrent->id, substr($torrent->name, 0, 34), _peers($torrent->leechers), _peers($torrent->seeders), _rate($torrent->rate_download), _eta($torrent->eta), ; } } elsif($action eq 'session') { if(my $set = shift @ARGV) { $tc->session->$set(shift @ARGV); $tc->session->${ \"clear_$set" }; printf "%s: %s\n", $set, $tc->session->$set; print $tc->error; } else { my $res = $tc->session->read_all; for my $key (sort keys %$res) { printf "%-30s %s\n", $key, $res->{$key}; } } } elsif($action eq 'stats') { my $res = $tc->session->stats->read_all; for my $key (sort keys %$res) { printf "%-30s %s\n", $key, $res->{$key}; } } else { _help(); } print "\n"; #============================================================================== sub _peers { my $n = shift; if($n < 0) { return 'na'; } elsif($n < 9999) { return $n; } else { return '++'; } } sub _rate { my $kbps = shift; if($kbps < 0) { return '0'; } elsif($kbps < 1000) { return $kbps; } elsif($kbps < 1e6) { return int($kbps / 1e3) . 'k'; } elsif($kbps < 1e6) { return int($kbps / 1e6) . 'M'; } else { return '++'; } } sub _eta { my $sec = shift; if($sec < 0) { return 'inf'; } elsif($sec < 60) { return $sec . "s"; } elsif($sec < 3600) { return int($sec / 6) / 10 . "m"; } elsif($sec < 86400) { return int($sec / 360) / 10 . "h"; } else { return '>1d'; } } sub _help { exec perldoc => -tT => $0; } =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L =head1 AUTHOR Jan Henning Thorsen =cut exit; Transmission-Client-0.0805/Changes0000644001161000116100000000704512747415305015474 0ustar olofolofRevision history for Transmission-Client 0.0805 Sun Jul 31 17:35:16 CEST 2016 - Update metadata: bugtracker and VCS repository, pointing to github. - Use JSON::MaybeXS instead of JSON::Any (Fixes rt.cpan.org#102465) 0.0804 Sun Oct 19 18:30:59 CEST 2014 - Fix perl precedence warning in Types 0.0803 Mon Sep 16 19:22:46 CEST 2013 - Fix POD issues (NAME section syntax) - Add explicit copyright statements - Add .gitignore to MANIFEST.SKIP - Add AUTHORS file Thanks to Marius Gavrilescu of the Debian Perl team for reporting the above issues. 0.0802 Wed Aug 21 17:49:02 CEST 2013 - Update types of Transmission::Torrent attributes With the stricter type coercions introduced with 0.08, types specified in the transmission rpc spec to be doubles were truncated to integers. This is now fixed. 0.0801 Sat Aug 17 10:53:07 CEST 2013 - Don't use the defined or operator (//). It's only available since perl 5.10.0. Fixes test failures. 0.08 Fri Aug 16 17:28:12 CEST 2013 - Improvements in type coercions for numeric types Numeric types that got encoded in JSON as strings were silently ignored by Transmission. Now we make sure that they are converted to numeric types (SVp_IOK | SVp_NOK), regardless of input. 0.0701 Mon Jul 22 19:31:56 CEST 2013 - Fix build failure introduced in 0.07 - New maintainer: Olof Johansson 0.07 Sat Jul 20 00:40:58 2013 - Fix test failures due to hash randomization (RT #81561) Merge pull request #3 from afresh1/master - Make fields parameter to read_torrents overrideable Merge pull request #5 from olof/topic/override_fields 0.0603 Mon May 7 19:29:53 2012 - Use correct var when adding torrent Reference: https://rt.cpan.org/Ticket/Display.html?id=76859 0.0602 Fri Apr 29 22:18:36 CEST 2011 - Fix RT#67691: rpc() can now handle ids as hashes 0.0601 Wed Apr 20 12:17:43 CEST 2011 - Fix fail to load json, with json-any http://www.cpantesters.org/cpan/report/f1e67256-36b4-11e0-afb0-adca6bb533f3 0.06 Sun Feb 6 18:33:13 CET 2011 - Fix RT62805: location to the rpc-spec is updated: https://trac.transmissionbt.com/browser/trunk/extras/rpc-spec.txt - Fix RT62805: methods given to rpc() can contain both underscores and hyphens. - Adding "autodie" to new() will make the module throw exceptions, instead of silently setting "error". 0.05 Sat May 29 22:27:02 CEST 2010 - Fix RT57970: username() and password() does not work 0.04 Mon Apr 26 22:35:37 CEST 2010 - Fix boolean type was true even when "false" - Fix setting of boolean data in Session attributes - Add Session and Stats attributes can will build its own value. The attributes can also be cleared and rebuilt. 0.03 Mon Apr 26 21:54:28 CEST 2010 - Change read_all() returns fetched data in a hash - Add example script 0.02 Sat Dec 19 21:43:19 2009 +0100 - Fix file->id bug: id is set - Fix file->key bug: File has no "key" - Add torrent->write_wanted() - Add torrnte->write_priority() 0.01 Mon Okt 5 20:43:19 2009 +0200 - can connect to deamon - can retrieve session data/stats - can retrieve torrent data/stats - can retrieve torrent files - can add torrent - can execute actions on a torrent: start/stop/remove/verify Transmission-Client-0.0805/t/0000755001161000116100000000000012747415651014442 5ustar olofolofTransmission-Client-0.0805/t/10-torrent.t0000644001161000116100000000374712573105200016534 0ustar olofolof# ex:ts=4:sw=4:sts=4:et use warnings; use strict; use Test::More; use Transmission::Torrent; use Transmission::Client; use JSON::MaybeXS; $SIG{'__DIE__'} = \&Carp::confess; my $client = Transmission::Client->new; my (%rpc_return, %rpc_callbacks); { no warnings 'redefine'; *Transmission::Client::rpc = sub { my $self = shift; my $method = shift; my $test = shift @{$rpc_callbacks{$method}}; $test->($self, $method, {@_}) if $test; return shift @{$rpc_return{$method}}; }; } my $torrent = new_ok 'Transmission::Torrent' => [ id => 1, client => $client, upload_ratio => 0.10, eta => 3.14, ]; is $torrent->upload_ratio, 0.10, "expected upload ratio (0.10)"; is $torrent->eta, 3, "expected upload ratio (3) (truncated double)"; # FIXME: ugly. :-( sub test_torrent_set { my %args = (@_); my $attr = $client->_camel2Normal($args{attribute}); push @{$rpc_return{'torrent-set'}}, {}; push @{$rpc_callbacks{'torrent-set'}}, $args{set_test}; push @{$rpc_return{'torrent-get'}}, { torrents => [ { $args{torrent}->id => { $args{attribute} => $args{value} } }, ] }; my $get_val = defined $args{coerced_val} ? $args{coerced_val} : $args{value}; is $torrent->$attr($args{value}), $get_val, 'get return should be the same as value supplied to set'; } test_torrent_set( torrent => $torrent, attribute => 'uploadLimit', value => '123', set_test => sub { my $self = shift; my ($method, $args) = @_; is_deeply $args->{ids}, [1], 'set should pass ids=[1]'; is $args->{uploadLimit}, 123, 'set should pass uploadLimit=123'; is encode_json([$args->{uploadLimit}]), encode_json([123]), 'JSON value for uploadLimit should be numeric'; }, post_test => sub { is shift, 123, 'get return should be same as arg to get' }, ); done_testing(); Transmission-Client-0.0805/t/00-load.t0000644001161000116100000000052712573102655015761 0ustar olofolof# ex:ts=4:sw=4:sts=4:et use lib qw(lib); use Test::More; plan tests => 8; use_ok('Transmission::AttributeRole'); use_ok('Transmission::Client'); use_ok('Transmission::Session'); use_ok('Transmission::Stats'); use_ok('Transmission::Torrent'); use_ok('Transmission::Torrent::File'); use_ok('Transmission::Types'); use_ok('Transmission::Utils'); Transmission-Client-0.0805/t/00-pod-coverage.t0000644001161000116100000000031112573102655017404 0ustar olofolof# ex:ts=4:sw=4:sts=4:et use lib qw(lib); use Test::More; eval 'use Test::Pod::Coverage;1' or plan skip_all => 'Test::Pod::Coverage required'; all_pod_coverage_ok({ also_private => [ qr/^[A-Z_]+$/ ] });Transmission-Client-0.0805/t/10-client.t0000644001161000116100000002170012573105225016311 0ustar olofolof# ex:ts=4:sw=4:sts=4:et use warnings; use strict; use lib qw(lib); use Test::More; use Transmission::Client; use JSON::MaybeXS; $SIG{'__DIE__'} = \&Carp::confess; my($client, $rpc_response, $rpc_request, @torrents); my $rpc_response_code = 409; { no warnings 'redefine'; *LWP::UserAgent::post = sub { my($lwp, $url, %args) = @_; my $res = HTTP::Response->new; $rpc_request = $args{'Content'}; my($tag) = $rpc_request =~ /"tag":\s*(\d+)/; $rpc_response =~ s/"tag":\s*\w+/"tag":$tag/; $res->code($rpc_response_code); $res->content($rpc_response); $res->header('X-Transmission-Session-Id' => '1234567890') unless($client->session_id); $rpc_response_code = 200 if($rpc_response_code == 409); return $res; }; Transmission::Session->meta->add_method(read_all => sub {}); } { # generic $client = Transmission::Client->new(autodie => 1); is($client->_autodie, 1, 'Transmission::Client will die on error'); is($client->url, 'http://localhost:9091/transmission/rpc', 'default url is set'); is($client->_url, $client->url, 'default _url is without username/password'); isa_ok($client->_ua, 'LWP::UserAgent'); $rpc_response = '{ "tag": TAG, "result": "success", "arguments": 123 }'; is($client->session_id, '', 'session ID is not set until the first rpc() request'); is($client->rpc('foo_bar'), 123, 'rpc() request responded with 123'); request_has(method => 'foo-bar', 'foo_bar method was transformed to foo-bar'); is($client->session_id, '1234567890', 'session ID was set by mocked HTTP request'); $rpc_response = '{ "tag": TAG, "result": "success", "arguments": { "version": 42 } }'; is($client->version, 42, 'got mocked Transmission version'); } { # add my %args = ( download_dir => 'some/dir', paused => 1, peer_limit => 42, ); eval { $client->add }; like($@, qr{Need either filename or metainfo argument}, 'add() require filename or metainfo'); eval { $client->add(filename => 'foo', metainfo => 'bar') }; like($@, qr{Filename and metainfo argument crash}, 'add() cannot handle both filename and metainfo'); $rpc_response = '{ "tag": TAG, "result": "success", "arguments": 1 }'; ok($client->add(filename => 'foo.torrent'), 'add() torrent by filename'); request_has( arguments => { filename => "foo.torrent", }, method => "torrent-add", 'add() with filename'); ok($client->add(metainfo => {}), 'add() torrent with metainfo'); request_has( arguments => { metainfo => undef, }, method => "torrent-add", 'add() with metainfo'); } { # remove, move, start, stop, verify / _do_ids_action() eval { $client->remove }; like($@, qr{ids is required as argument}, 'remove() require ids argument'); ok(!$client->has_torrents, 'remove() does not clear "torrents" attribute on failure'); ok($client->remove(ids => 'all'), 'remove() with ids = "all"'); ok($rpc_request !~ /ids/, 'remove() did not pass on ids, when ids = "all"'); request_has(method => "torrent-remove", 'remove() does rpc method torrent-remove'); ok($client->remove(ids => 42), 'remove() can take a single id'); ok($client->remove(ids => [24, 42]), 'remove() can take a list of ids'); like($rpc_request, qr{[24,\s*42]}, 'remove() with list of ids'); ok(!$client->has_torrents, 'remove() also cleared "torrents" attribute'); eval { $client->move }; like($@, qr{location argument is required}, 'move() require "location"'); ok($client->move(location => '/some/path', ids => 42), 'move() with location and ids'); request_has( method => "torrent-set-location", arguments => { location => '/some/path', ids => [42], }, 'move() does rpc method torrent-set-location'); ok($client->start(ids => 42), 'start() with location and ids'); request_has( method => "torrent-start", arguments => { ids => [42], }, 'start() does rpc method torrent-start'); ok($client->stop(ids => 42), 'stop() with location and ids'); request_has( method => "torrent-stop", arguments => { ids => [42], }, 'stop() does rpc method torrent-stop'); ok($client->verify(ids => 42), 'verify() with location and ids'); request_has( method => "torrent-verify", arguments => { ids => [42], }, 'verify() does rpc method torrent-verify'); } { $rpc_response = '{ "tag": TAG, "result": "success", "arguments": { "torrents":[] } }'; is(my @torrents = $client->torrent_list, 0, 'torrent_list() contains zero objects'); is_deeply($client->torrents, \@torrents, 'torrent_list() returns a list, while "torrents" contains an array-ref'); $rpc_response = '{ "tag": TAG, "result": "success", "arguments": { "torrents":[] } }'; $client->read_torrents; request_has( method => 'torrent-get', arguments => { fields => [qw( creator uploadRatio leechers sizeWhenDone recheckProgress maxConnectedPeers activityDate id swarmSpeed peersConnected pieceCount torrentFile name isPrivate webseedsSendingToUs timesCompleted addedDate downloadedEver downloaders peersKnown seeders downloadDir startDate desiredAvailable status peersSendingToUs peersGettingFromUs rateDownload corruptEver leftUntilDone uploadedEver error rateUpload manualAnnounceTime doneDate totalSize dateCreated pieceSize percentDone errorString haveValid hashString eta haveUnchecked comment uploadLimit downloadLimit seedRatioMode bandwidthPriority downloadLimited seedRatioLimit uploadLimited honorsSessionLimits)] }, 'read_torrents() with all fields', ); $client->read_torrents(fields => [qw(name eta)]); request_has( method => 'torrent-get', arguments => { fields => [qw(id name eta)], }, 'read_torrents() with only specific fields', ); $client->read_torrents(lazy_read => 1); request_has( method => 'torrent-get', arguments => { fields => ["id"], }, 'read_torrents() with lazy_read', ); $client->read_torrents(ids => 42); request_has( method => 'torrent-get', arguments => { ids => [42], }, 'read_torrents() with ids', ); } { # RT#67691 $client->rpc(foo_bar => ids => [1,2,'foo']); like($rpc_request, qr{"ids":\[1,2,"foo"\]}, 'Fix RT#67691: id "foo" is still a string'); } TODO: { local $TODO = 'require better testing'; ok(!$client->has_session, 'client has no session'); ok($client->read_all, 'read_all() information'); ok($client->has_session, 'read_all() set session attribute'); } sub request_has { my $description = pop; my %args = @_; my @failed; note $description; # $rpc_request is set to the latest post request the test would have done my $rpc_req = decode_json($rpc_request); # All requests must have a method parameter ok exists $rpc_req->{method}, 'Existance of methods key'; for my $top (keys %args) { if (ref $args{$top}) { for my $key (keys %{$args{$top}}) { if (not defined $args{$top}->{$key}) { ok exists $rpc_req->{$top}->{$key}, "Existance of $top\->{$key}"; next; } if (not ref $rpc_req->{$top}->{$key} and not ref $args{$top}->{$key}) { is $rpc_req->{$top}->{$key}, $args{$top}->{$key}, "Comparing value for $top\->{$key}"; next; } is ref $rpc_req->{$top}->{$key}, 'ARRAY', "$top\->{$key} should be an array"; SKIP: { skip "See previous test failure", @{$args{$top}->{$key}} + 1 unless ref $rpc_req->{$top}->{$key} eq 'ARRAY'; # Make sure all expected values exist my %seen; for my $elm (@{$args{$top}->{$key}}) { ok( grep({$elm eq $_} @{$rpc_req->{$top}->{$key}}), "$top\->{$key} should have expected values ($elm)"); $seen{$elm} = 1; } # Make sure no unexpected values exist is_deeply [ grep {! exists $seen{$_}} @{$rpc_req->{$top}->{$key}}, ], [], "No unexpected elements found in $top\->{$key}"; } } } else { is $rpc_req->{$top}, $args{$top}, "Comparing value for $top"; } } } done_testing(); Transmission-Client-0.0805/t/05-utils.t0000644001161000116100000000141612573102655016205 0ustar olofolof#!perl # ex:ts=4:sw=4:sts=4:et use strict; use lib qw(lib); use Transmission::Utils (); use Test::More; plan tests => 8; my $numeric = 16; my $str = "stopped"; ok(!*from_numeric_status{'CODE'}, "from_numeric_status not imported"); ok(!*to_numeric_status{'CODE'}, "to_numeric_status not imported"); Transmission::Utils->import('from_numeric_status'); ok(*from_numeric_status{'CODE'}, "from_numeric_status imported"); is(from_numeric_status($numeric), $str, "from_numeric_status ok"); is(from_numeric_status(-1), "", "from_numeric_status ok"); Transmission::Utils->import('to_numeric_status'); ok(*to_numeric_status{'CODE'}, "to_numeric_status imported"); is(to_numeric_status($str), $numeric, "to_numeric_status ok"); is(to_numeric_status("foo"), -1, "to_numeric_status ok"); Transmission-Client-0.0805/t/00-pod.t0000644001161000116100000000021512573102655015616 0ustar olofolof# ex:ts=4:sw=4:sts=4:et use lib qw(lib); use Test::More; eval 'use Test::Pod;1' or plan skip_all => 'Test::Pod required'; all_pod_files_ok();Transmission-Client-0.0805/t/10-types.t0000644001161000116100000000221712573102655016205 0ustar olofolof# ex:ts=4:sw=4:sts=4:et # Tests for helper functions in Transmission::Types use warnings; use strict; use Test::More tests => 11; use Transmission::Types; ok Transmission::Types::_is_num(10), '_is_num(10)'; ok Transmission::Types::_is_num(10.0), '_is_num(10.0)'; ok !Transmission::Types::_is_num("foo"), 'not _is_num("foo")'; ok !Transmission::Types::_is_num("10.0"), 'not _is_num("10.0")'; is Transmission::Types::_coerce_num("10"), 10, 'coerced numeric str "10" should become 10'; is Transmission::Types::_coerce_num("10.1"), 10.1, 'coerced numeric str "10.1" should become 10.1'; is Transmission::Types::_coerce_num("foo"), -1, 'coerced non-numeric str "foo" should become -1'; ok Transmission::Types::_is_num(Transmission::Types::_coerce_num("10")), 'coerced numeric str should become num'; ok Transmission::Types::_is_num(Transmission::Types::_coerce_num(10)), 'coerced integer should still be num'; ok Transmission::Types::_is_num(Transmission::Types::_coerce_num(10.0)), 'coerced double should still be num'; ok Transmission::Types::_is_num(Transmission::Types::_coerce_num("foo")), 'coerced non-numeric str "foo" should become num'; Transmission-Client-0.0805/t/20-real.t0000644001161000116100000000375312573102655015773 0ustar olofolof#!perl # ex:ts=4:sw=4:sts=4:et use strict; use warnings; use lib qw(lib); use Transmission::Client; use Test::More; plan skip_all => "REAL_TEST is not set" unless($ENV{'REAL_TEST'}); plan tests => 24; my $obj = Transmission::Client->new(username => 'testman', password => 'test'); my $id = $ENV{'REAL_TEST'}; is($obj->url, 'http://localhost:9091/transmission/rpc', '->url'); is($obj->_url, 'http://testman:test@localhost:9091/transmission/rpc', '->_url'); isa_ok($obj->session, 'Transmission::Session', '->session'); isa_ok($obj->stats, 'Transmission::Stats', '->stats'); ok($obj->torrents, '->torrents'); like($obj->version || '__undef__', qr{^\d+.\d+}, '->version'); ok(!$obj->add, "Could not add") or diag($obj->error); ok(!$obj->remove, "Could not remove") or diag($obj->error); ok(!$obj->start, "Could not start") or diag($obj->error); ok(!$obj->stop, "Could not stop") or diag($obj->error); ok(!$obj->verify, "Could not verify") or diag($obj->error); SKIP: { is(int(@_ = $obj->read_torrents(eager_read => $id)), 3, "->read_torrents eagerly"); is(int(@_ = $obj->read_torrents(ids => $id)), 1, "->read_torrents with ids") or skip 'fail to read torrent', 11; my $torrent = $obj->torrents->[0]; ok(@{ $torrent->files } > 0, 'torrent has files'); my $file = $torrent->files->[0]; like($file->name, qr{\w}, 'torrent has name'); ok($file->length > 0, 'torrent has size'); is($file->priority, 0, 'torrent has normal priority'); $file->priority(1); $file->wanted(0); ok($torrent->write_priority, 'torrent priority has been written'); ok($torrent->write_wanted, 'torrent wanted has been written'); ok($obj->read_all, "data is refreshed"); $file = $torrent->files->[0]; is($file->priority, 1, 'file has high priority'); is($file->wanted, 0, 'file is not wanted'); $file->priority(0); $file->wanted(1); ok($torrent->write_priority, 'torrent priority has reset'); ok($torrent->write_wanted, 'torrent wanted has reset'); } #print $obj->dump; Transmission-Client-0.0805/MANIFEST0000644001161000116100000000151212747415651015327 0ustar olofolofbin/transmission-client.pl Changes inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Transmission/AttributeRole.pm lib/Transmission/Client.pm lib/Transmission/Session.pm lib/Transmission/Stats.pm lib/Transmission/Torrent.pm lib/Transmission/Torrent/File.pm lib/Transmission/Types.pm lib/Transmission/Utils.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml README t/00-load.t t/00-pod-coverage.t t/00-pod.t t/05-utils.t t/10-client.t t/10-torrent.t t/10-types.t t/20-real.t SIGNATURE Public-key signature (added by MakeMaker) Transmission-Client-0.0805/inc/0000755001161000116100000000000012747415651014750 5ustar olofolofTransmission-Client-0.0805/inc/Module/0000755001161000116100000000000012747415651016175 5ustar olofolofTransmission-Client-0.0805/inc/Module/AutoInstall.pm0000644001161000116100000006231112747415647021002 0ustar olofolof#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.16'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, $UpgradeDeps ); my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub _installdeps_target { $InstallDepsTarget = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { $UpgradeDeps = 1; __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::getcwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward compatibility while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _version_of($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or $InstallDepsTarget or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { require Config; my $make = $Config::Config{make}; if ($InstallDepsTarget) { print "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; } else { print "*** Dependencies will be installed the next time you type '$make'.\n"; } # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; if ($ENV{PERL5_CPANM_IS_RUNNING}) { return _running_under('cpanminus'); } my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed, @modules_to_upgrade ); while (my ($pkg, $ver) = splice(@_, 0, 2)) { # grep out those already installed if (_version_cmp(_version_of($pkg), $ver) >= 0) { push @installed, $pkg; if ($UpgradeDeps) { push @modules_to_upgrade, $pkg, $ver; } } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @modules_to_upgrade; @installed = (); @modules_to_upgrade = (); } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } push @config, 'prereqs', $value; } elsif ( $key eq 'force' ) { push @config, $key, $value; } elsif ( $key eq 'notest' ) { push @config, 'skiptest', $value; } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^(?:force|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $opt eq 'urllist' ? [$arg] : $arg; } if ($args{notest} && (not CPAN::Shell->can('notest'))) { die "Your version of CPAN is too old to support the 'notest' pragma"; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = do { if ($args{force}) { CPAN::Shell->force( install => $pkg ) } elsif ($args{notest}) { CPAN::Shell->notest( install => $pkg ) } else { CPAN::Shell->install($pkg) } }; $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::getcwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # report version without loading a module sub _version_of { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; foreach my $dir ( @INC ) { next if ref $dir; my $path = File::Spec->catfile($dir, $file); next unless -e $path; require ExtUtils::MM_Unix; return ExtUtils::MM_Unix->parse_version($path); } return undef; } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); my $deps_list = join( ',', @Missing, @Existing ); $PostambleActionsUpgradeDeps = "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; my $config_notest = join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 'notest', 1 ) if $Config; $PostambleActionsNoTest = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); $PostambleActionsUpgradeDepsNoTest = "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; $PostambleActionsListDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); my @all = (@Missing, @Existing); $PostambleActionsListAllDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; my $fragment; $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) AUTO_INSTALL $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions installdeps_notest :: \t$PostambleActionsNoTest upgradedeps :: \t$PostambleActionsUpgradeDeps upgradedeps_notest :: \t$PostambleActionsUpgradeDepsNoTest listdeps :: \t$PostambleActionsListDeps listalldeps :: \t$PostambleActionsListAllDeps END_MAKE return $fragment; } 1; __END__ #line 1197 Transmission-Client-0.0805/inc/Module/Install/0000755001161000116100000000000012747415651017603 5ustar olofolofTransmission-Client-0.0805/inc/Module/Install/AutoInstall.pm0000644001161000116100000000416212747415647022410 0ustar olofolof#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub installdeps_target { my ($self, @args) = @_; $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall::_installdeps_target(1); $self->auto_install(@args); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; Transmission-Client-0.0805/inc/Module/Install/Include.pm0000644001161000116100000000101512747415647021526 0ustar olofolof#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; Transmission-Client-0.0805/inc/Module/Install/WriteAll.pm0000644001161000116100000000237612747415650021673 0ustar olofolof#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Transmission-Client-0.0805/inc/Module/Install/Can.pm0000644001161000116100000000615712747415650020652 0ustar olofolof#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 Transmission-Client-0.0805/inc/Module/Install/Base.pm0000644001161000116100000000214712747415647021024 0ustar olofolof#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.16'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Transmission-Client-0.0805/inc/Module/Install/Metadata.pm0000644001161000116100000004330212747415647021670 0ustar olofolof#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Transmission-Client-0.0805/inc/Module/Install/Makefile.pm0000644001161000116100000002743712747415647021700 0ustar olofolof#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Transmission-Client-0.0805/inc/Module/Install/Fetch.pm0000644001161000116100000000462712747415650021202 0ustar olofolof#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Transmission-Client-0.0805/inc/Module/Install/Win32.pm0000644001161000116100000000340312747415650021042 0ustar olofolof#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Transmission-Client-0.0805/inc/Module/Install.pm0000644001161000116100000003021712747415647020151 0ustar olofolof#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.16'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Transmission-Client-0.0805/lib/0000755001161000116100000000000012747415651014745 5ustar olofolofTransmission-Client-0.0805/lib/Transmission/0000755001161000116100000000000012747415651017436 5ustar olofolofTransmission-Client-0.0805/lib/Transmission/Client.pm0000644001161000116100000003326712747415555021230 0ustar olofolof# ex:ts=4:sw=4:sts=4:et package Transmission::Client; # Copyright 2009-2013, Jan Henning Thorsen # and contributors # # All rights reserved. # # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. =head1 NAME Transmission::Client - Interface to Transmission =head1 VERSION 0.0805 =head1 DESCRIPTION L is the main module in a collection of modules to communicate with Transmission. Transmission is: Transmission is a cross-platform BitTorrent client that is: * Easy * Lean * Native * Powerful * Free If you want to communicate with "transmission-daemon", this is a module which can help you with that. The documentation is half copy/paste from the Transmission RPC spec: L This module differs from L in (at least) two ways: This one use L and it won't die. The latter is especially annoying in the constructor. =head1 SYNOPSIS use Transmission::Client; my $client = Transmission::Client->new; my $torrent_id = 2; my $data = base64_encoded_data(); $client->add(metainfo => $data) or confess $client->error; $client->remove($torrent_id) or confess $client->error; for my $torrent (@{ $client->torrents }) { print $torrent->name, "\n"; for my $file (@{ $torrent->files }) { print "> ", $file->name, "\n"; } } print $client->session->download_dir, "\n"; =head1 FAULT HANDLING In C<0.06> L can be constructed with "autodie" set to true, to make this object confess instead of just setting L. Example: my $client = Transmission::Client->new(autodie => 1); eval { $self->add(filename => 'foo.torrent'); } or do { # add() failed... }; =head1 SEE ALSO L L L L =cut use Moose; use DateTime; use DateTime::Duration; use JSON::MaybeXS; use LWP::UserAgent; use MIME::Base64; use Transmission::Torrent; use Transmission::Session; use constant RPC_DEBUG => $ENV{'TC_RPC_DEBUG'}; our $VERSION = '0.0805'; our $SESSION_ID_HEADER_NAME = 'X-Transmission-Session-Id'; my $JSON = JSON::MaybeXS->new; with 'Transmission::AttributeRole'; =head1 ATTRIBUTES =head2 url $str = $self->url; Returns an URL to where the Transmission rpc api is. Default value is "http://localhost:9091/transmission/rpc"; =cut has url => ( is => 'ro', isa => 'Str', default => 'http://localhost:9091/transmission/rpc', ); # this is subject for change! has _url => ( is => 'ro', isa => 'Str', lazy_build => 1, ); sub _build__url { my $self = shift; my $url = $self->url; if($self->username or $self->password) { my $auth = join ':', $self->username, $self->password; $url =~ s,://,://$auth@,; } return $url; } =head2 error $str = $self->error; Returns the last error known to the object. All methods can return empty list in addition to what specified. Check this attribute if so happens. Like L? Create your object with C set to true and this module will throw exceptions in addition to setting this variable. =cut has error => ( is => 'rw', isa => 'Str', default => '', clearer => '_clear_error', trigger => sub { $_[0]->_autodie and confess $_[1] }, ); has _autodie => ( is => 'ro', init_arg => 'autodie', isa => 'Bool', default => 0, ); =head2 username $str = $self->username; Used to authenticate against Transmission. =cut has username => ( is => 'ro', isa => 'Str', default => '', ); =head2 password $str = $self->password; Used to authenticate against Transmission. =cut has password => ( is => 'ro', isa => 'Str', default => '', ); =head2 timeout $int = $self->timeout; Number of seconds to wait for RPC response. =cut has _ua => ( is => 'rw', isa => 'LWP::UserAgent', lazy => 1, handles => [qw/timeout/], default => sub { LWP::UserAgent->new( agent => 'Transmission-Client' ); }, ); =head2 session $session_obj = $self->session; $stats_obj = $self->stats; Returns an instance of L. C is a proxy method on L. =cut has session => ( is => 'ro', lazy => 1, predicate => 'has_session', handles => [qw/stats/], default => sub { Transmission::Session->new( client => $_[0] ); }, ); =head2 torrents $array_ref = $self->torrents; $self->clear_torrents; Returns an array-ref of L objects. Default value is a full list of all known torrents, with as little data as possible read from Transmission. This means that each request on a attribute on an object will require a new request to Transmission. See L for more information. =cut has torrents => ( is => 'rw', traits => ['Array'], lazy => 1, clearer => "clear_torrents", builder => "read_torrents", predicate => 'has_torrents', handles => { torrent_list => 'elements', }, ); =head2 version $str = $self->version; Get Transmission version. =cut has version => ( is => 'ro', isa => 'Str', lazy_build => 1, ); sub _build_version { my $self = shift; if(my $data = $self->rpc('session-get')) { return $data->{'version'} || q(); } return q(); } =head2 session_id $self->session_id($str); $str = $self->session_id; The session ID used to communicate with Transmission. =cut has session_id => ( is => 'rw', isa => 'Str', default => '', trigger => sub { $_[0]->_ua->default_header($SESSION_ID_HEADER_NAME => $_[1]); }, ); =head1 METHODS =head2 add $bool = $self->add(%args); key | value type & description -----------------+------------------------------------------------- download_dir | string path to download the torrent to filename | string filename or URL of the .torrent file metainfo | string torrent content paused | boolean if true, don't start the torrent peer_limit | number maximum number of peers Either "filename" or "metainfo" MUST be included. All other arguments are optional. See "3.4 Adding a torrent" from L =cut sub add { my $self = shift; my %args = @_; if($args{'filename'} and $args{'metainfo'}) { $self->error("Filename and metainfo argument crash"); return; } elsif($args{'filename'}) { return $self->rpc('torrent-add', %args); } elsif($args{'metainfo'}) { $args{'metainfo'} = encode_base64($args{'metainfo'}); return $self->rpc('torrent-add', %args); } else { $self->error("Need either filename or metainfo argument"); return; } } =head2 remove $bool = $self->remove(%args); key | value type & description -------------------+------------------------------------------------- ids | array torrent list, as described in 3.1 delete_local_data | boolean delete local data. (default: false) C can also be the string "all". C is required. See "3.4 Removing a torrent" from L =cut sub remove { my $self = shift; if($self->_do_ids_action('torrent-remove' => @_)) { $self->clear_torrents; # torrent list might be out of sync return 1; } else { return 0; } } =head2 move $bool = $self->move(%args); string | value type & description ------------+------------------------------------------------- ids | array torrent list, as described in 3.1 location | string the new torrent location move | boolean if true, move from previous location. | otherwise, search "location" for files C can also be the string "all". C and C is required. See "3.5 moving a torrent" from L =cut sub move { my $self = shift; my %args = @_; if(!defined $args{'location'}) { $self->error("location argument is required"); return; } return $self->_do_ids_action('torrent-set-location' => %args); } =head2 start $bool = $self->start($ids); Will start one or more torrents. C<$ids> can be a single int, an array of ints or the string "all". =head2 stop $bool = $self->stop($ids); Will stop one or more torrents. C<$ids> can be a single int, an array of ints or the string "all". =head2 verify $bool = $self->stop($ids); Will verify one or more torrents. C<$ids> can be a single int, an array of ints or the string "all". =cut sub start { return shift->_do_ids_action('torrent-start' => @_); } sub stop { return shift->_do_ids_action('torrent-stop' => @_); } sub verify { return shift->_do_ids_action('torrent-verify' => @_); } sub _do_ids_action { my $self = shift; my $method = shift; my %args = @_ == 1 ? (ids => $_[0]) : @_; my $ids; unless(defined $args{'ids'}) { $self->error('ids is required as argument'); return; } unless(ref $args{'ids'} eq 'ARRAY') { if($args{'ids'} eq 'all') { delete $args{'ids'}; } else { $args{'ids'} = [$args{'ids'}]; } } return $self->rpc($method, %args) ? 1 : 0; } =head2 read_torrents @list = $self->read_torrents(%args); $array_ref = $self->read_torrents(%args); key | value type & description ------------+------------------------------------------------- ids | array torrent list, as described in 3.1 | this is optional lazy_read | will create objects with as little data as possible. =over 4 =item List context Returns a list of L objects and sets the L attribute. =item Scalar context Returns an array-ref of L. =back =cut sub read_torrents { my $self = shift; my %args = @_ == 1 ? (ids => $_[0]) : @_; my $list; # set fields... if(exists $args{'fields'}) { # ... based on user input # We should always request id push @{$args{'fields'}}, 'id' unless grep {'id' eq $_} @{$args{'fields'}}; } elsif($args{'lazy_read'}) { # ... as few fields as possible $args{'fields'} = ['id']; } else { # ... all fields $args{'fields'} = [ keys %Transmission::Torrent::READ, keys %Transmission::Torrent::BOTH, ]; } # set ids if($args{'ids'}) { if($args{'ids'} eq 'all') { delete $args{'ids'}; } elsif(ref $args{'ids'} eq "") { $args{'ids'} = [ $args{'ids'} ]; } } if(my $data = $self->rpc('torrent-get' => %args)) { $list = $data->{'torrents'}; } else { $list = []; } for my $torrent (@$list) { $torrent = Transmission::Torrent->new( client => $self, id => $torrent->{'id'}, %$torrent, ); } if(wantarray) { $self->torrents($list); return @$list; } else { return $list; } } =head2 rpc $any = $self->rpc($method, %args); Communicate with backend. This methods is meant for internal use. =cut sub rpc { my $self = shift; my $method = shift or return; my %args = @_; my $nested = delete $args{'_nested'}; # internal flag my($tag, $res, $post); $method = $self->_normal2Camel($method); # The keys need to be dashes as well # _normal2Camel modifies a hashref in places $self->_normal2Camel( \%args ); # make sure ids are numeric if(ref $args{'ids'} eq 'ARRAY') { for my $id (@{ $args{'ids'} }) { # Need to convert string integer to "real" integer # FLAGS = (IOK,POK,pIOK,pPOK) # IV = 42 # ...to... # FLAGS = (PADTMP,IOK,pIOK) # IV = 42 $id += 0 if($id =~ /^\d+$/); } } $tag = int rand 2*16 - 1; $post = $JSON->encode({ method => $method, tag => $tag, arguments => \%args, }); $res = $self->_ua->post($self->_url, Content => $post); if(RPC_DEBUG) { print "post: $post\n"; print "status_line: ", $res->status_line, "\n"; } unless($res->is_success) { if($res->code == 409 and !$nested) { $self->session_id($res->header($SESSION_ID_HEADER_NAME)); return $self->rpc($method => %args, _nested => 1); } else { $self->error($res->status_line); return; } } $res = $JSON->decode($res->content); unless($res->{'tag'} == $tag) { $self->error("Tag mismatch"); return; } unless($res->{'result'} eq 'success') { $self->error($res->{'result'}); return; } $self->_clear_error; return $res->{'arguments'}; } =head2 read_all 1 == $self->read_all; This method will try to populate ALL torrent, session and stats information, using three requests. =cut sub read_all { my $self = shift; $self->session->read_all; $self->stats->read_all; () = $self->read_torrents; return 1; } =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 COPYRIGHT AND AUTHORS Copyright 2009-2013, Jan Henning Thorsen and contributors Current maintainer: Olof Johansson - C =head2 CONTRIBUTORS =over =item Andrew Fresh =back =cut no MIME::Base64; no Moose; 1; Transmission-Client-0.0805/lib/Transmission/Session.pm0000644001161000116100000001353012573102655021413 0ustar olofolof# ex:ts=4:sw=4:sts=4:et package Transmission::Session; # See Transmission::Client for copyright statement. =head1 NAME Transmission::Session - Transmission session =head1 DESCRIPTION See "4 Session requests" from L This class holds data, regarding the Transmission session. =cut use Moose; use Transmission::Types ':all'; use Transmission::Stats; BEGIN { with 'Transmission::AttributeRole'; } =head1 ATTRIBUTES =head2 stats $stats_obj = $self->stats; Returns a L object. =cut has stats => ( is => 'ro', isa => 'Object', lazy => 1, default => sub { Transmission::Stats->new(client => $_[0]->client); } ); =head2 alt_speed_down $number = $self->alt_speed_down max global download speed (in K/s) =head2 alt_speed_enabled $boolean = $self->alt_speed_enabled true means use the alt speeds =head2 alt_speed_time_begin $number = $self->alt_speed_time_begin when to turn on alt speeds (units: minutes after midnight) =head2 alt_speed_time_enabled $boolean = $self->alt_speed_time_enabled true means the scheduled on/off times are used =head2 alt_speed_time_end $number = $self->alt_speed_time_end when to turn off alt speeds (units: same) =head2 alt_speed_time_day $number = $self->alt_speed_time_day what day(s) to turn on alt speeds (look at tr_sched_day) =head2 alt_speed_up $number = $self->alt_speed_up max global upload speed (in K/s) =head2 blocklist_enabled $boolean = $self->blocklist_enabled true means enabled =head2 dht_enabled $boolean = $self->dht_enabled true means allow dht in public torrents =head2 encryption $string = $self->encryption "required", "preferred", "tolerated" =head2 download_dir $string = $self->download_dir default path to download torrents =head2 peer_limit_global $number = $self->peer_limit_global maximum global number of peers =head2 peer_limit_per_torrent $number = $self->peer_limit_per_torrent maximum global number of peers =head2 pex_enabled $boolean = $self->pex_enabled true means allow pex in public torrents =head2 peer_port $number = $self->peer_port port number =head2 peer_port_random_on_start $boolean = $self->peer_port_random_on_start true means pick a random peer port on launch =head2 port_forwarding_enabled $boolean = $self->port_forwarding_enabled true means enabled =head2 seedRatioLimit $double = $self->seedRatioLimit the default seed ratio for torrents to use =head2 seedRatioLimited $boolean = $self->seedRatioLimited true if seedRatioLimit is honored by default =head2 speed_limit_down $number = $self->speed_limit_down max global download speed (in K/s) =head2 speed_limit_down_enabled $boolean = $self->speed_limit_down_enabled true means enabled =head2 speed_limit_up $number = $self->speed_limit_up max global upload speed (in K/s) =head2 speed_limit_up_enabled $boolean = $self->speed_limit_up_enabled true means enabled =cut BEGIN { my %both = ( 'alt-speed-down' => number, 'alt-speed-enabled' => boolean, 'alt-speed-time-begin' => number, 'alt-speed-time-enabled' => boolean, 'alt-speed-time-end' => number, 'alt-speed-time-day' => number, 'alt-speed-up' => number, 'blocklist-enabled' => boolean, 'dht-enabled' => boolean, 'encryption' => string, 'download-dir' => string, 'peer-limit-global' => number, 'peer-limit-per-torrent' => number, 'pex-enabled' => boolean, 'peer-port' => number, 'peer-port-random-on-start' => boolean, 'port-forwarding-enabled' => boolean, 'seedRatioLimit' => number, 'seedRatioLimited' => boolean, 'speed-limit-down' => number, 'speed-limit-down-enabled' => boolean, 'speed-limit-up' => number, 'speed-limit-up-enabled' => boolean, ); for my $camel (keys %both) { my $name = __PACKAGE__->_camel2Normal($camel); __PACKAGE__->meta->add_attribute($name => ( is => 'rw', isa => $both{$camel}, coerce => 1, lazy => 1, clearer => "clear_$name", trigger => sub { return if($_[0]->lazy_write); $_[0]->client->rpc('session-set' => $camel => ($both{$camel} eq boolean and $_[1]) ? 'true' : ($both{$camel} eq boolean and !$_[1]) ? 'false' : $_[1] ); }, default => sub { my $self = shift; my $val = delete $self->_tmp_store->{$name}; if(defined $val) { return $val; } else { $self->_clear_tmp_store; return delete $self->_tmp_store->{$name}; } }, )); } __PACKAGE__->meta->add_attribute(_tmp_store => ( is => 'ro', isa => 'HashRef', lazy => 1, builder => 'read_all', clearer => '_clear_tmp_store', )); __PACKAGE__->meta->add_method(read_all => sub { my $self = shift; my $lazy = $self->lazy_write; my($rpc, %res); $rpc = $self->client->rpc('session-get') or return; $self->lazy_write(1); for my $camel (keys %both) { my $name = __PACKAGE__->_camel2Normal($camel); $res{$name} = $rpc->{$camel}; $self->$name($rpc->{$camel}); } $self->lazy_write($lazy); return \%res; }); } =head1 LICENSE =head1 AUTHOR See L =cut 1; Transmission-Client-0.0805/lib/Transmission/Stats.pm0000644001161000116100000000462312573102655021071 0ustar olofolof# ex:ts=4:sw=4:sts=4:et package Transmission::Stats; # See Transmission::Client for copyright statement. =head1 NAME Transmission::Stats - Transmission session statistics =head1 DESCRIPTION See "4.2 Sesion statistics" from L =cut use Moose; use Transmission::Types ':all'; with 'Transmission::AttributeRole'; =head1 ATTRIBUTES =head2 active_torrent_count $num = $self->active_torrent_count; =head2 download_speed $num = $self->download_speed; =head2 paused_torrent_count $num = $self->paused_torrent_count; =head2 torrent_count $num = $self->torrent_count; =head2 upload_speed $num = $self->upload_speed; =cut BEGIN { my %both = ( activeTorrentCount => number, downloadSpeed => number, pausedTorrentCount => number, torrentCount => number, uploadSpeed => number, ); for my $camel (keys %both) { (my $name = $camel) =~ s/([A-Z]+)/{ "_" .lc($1) }/ge; __PACKAGE__->meta->add_attribute($name => ( is => 'ro', isa => $both{$camel}, coerce => 1, writer => "_set_$name", clearer => "clear_$name", lazy => 1, default => sub { my $self = shift; my $val = delete $self->_tmp_store->{$name}; if(defined $val) { return $val; } else { $self->_clear_tmp_store; return delete $self->_tmp_store->{$name}; } }, )); } __PACKAGE__->meta->add_attribute(_tmp_store => ( is => 'ro', isa => 'HashRef', lazy => 1, builder => 'read_all', clearer => '_clear_tmp_store', )); __PACKAGE__->meta->add_method(read_all => sub { my $self = shift; my $lazy = $self->lazy_write; my(%res, $rpc); $rpc = $self->client->rpc('session-stats') or return; $self->lazy_write(1); for my $camel (keys %both) { my $name = __PACKAGE__->_camel2Normal($camel); my $writer = "_set_$name"; $res{$name} = $rpc->{$camel}; $self->$writer($rpc->{$camel}); } $self->lazy_write($lazy); return \%res; }); } =head1 LICENSE =head1 AUTHOR See L =cut 1; Transmission-Client-0.0805/lib/Transmission/Types.pm0000644001161000116100000000350212573102655021072 0ustar olofolof# ex:ts=4:sw=4:sts=4:et package Transmission::Types; # See Transmission::Client for copyright statement. =head1 NAME Transmission::Types - Moose types for Transmission =head1 DESCRIPTION The types below is pretty much what you would expect them to be, execpt for some (maybe weird?) default values - that is for coercion from "Any". The type names correspond to types used in the Transmission RPC specification. =head1 TYPES =head2 number =head2 double =head2 string =head2 boolean =head2 array =cut use MooseX::Types -declare => [qw/number double string boolean array/]; use MooseX::Types::Moose ':all'; use B; # If Perl thinks a value is a string, JSON will encode it as such. But # Transmission is picky about how parameters are encoded in the JSON # request, so we make sure Perl knows how to store numeric types. sub _coerce_num { local $_ = shift; return -1 unless defined $_ and /^[0-9]+(?:\.[0-9]+)?$/; return 0+$_; } sub _is_num { my $sv = shift; my $flags = B::svref_2object(\$sv)->FLAGS; # Make sure perl internally thinks of $sv as an integer # or numeric value. In earlier releases I also made sure that # it's not a string ($flags & B::SVp_POK), but POK and # (NOK|IOK) seem to be mutually exclusive. return $flags & (B::SVp_NOK | B::SVp_IOK); } subtype number, as Num, where { _is_num($_) and $_ == int $_}; coerce number, from Any, via { int _coerce_num($_) }; subtype double, as Num, where { _is_num($_) }; coerce double, from Any, via { _coerce_num($_) }; subtype string, as Str; coerce string, from Any, via { defined $_ ? "$_" : "__UNDEF__" }; type boolean, where { defined $_ and $_ =~ /^(1|0)$/ }; coerce boolean, from Object, via { int $_ }; subtype array, as ArrayRef; coerce array, from Any, via { [] }; =head1 LICENSE =head1 NAME See L =cut 1; Transmission-Client-0.0805/lib/Transmission/Torrent.pm0000644001161000116100000003332512573102655021431 0ustar olofolof# ex:ts=4:sw=4:sts=4:et package Transmission::Torrent; # See Transmission::Client for copyright statement. =head1 NAME Transmission::Torrent - Transmission torrent object =head1 DESCRIPTION See "3.2 Torrent Mutators" and "3.3 Torrent accessors" from L This class handles data related to a torrent known to Transmission. =head1 SEE ALSO L =cut use Moose; use List::MoreUtils qw(uniq); use Transmission::Torrent::File; use Transmission::Types ':all'; BEGIN { with 'Transmission::AttributeRole'; } =head1 ATTRIBUTES =head2 id $id = $self->id; Returns the id that identifies this torrent in transmission. =cut has id => ( is => 'ro', isa => 'Int', writer => '_set_id', required => 1, ); =head2 bandwidth_priority $self->bandwidth_priority($num); This torrent's bandwidth. =head2 download_limit $self->download_limit($num); Maximum download speed (in K/s). =head2 download_limited $self->download_limited($bool); True if "downloadLimit" is honored. =head2 honors_session_limits $self->honors_session_limits($bool); True if session upload limits are honored. =head2 location $self->location($str); New location of the torrent's content =head2 peer_limit $self->peer_limit($num); Maximum number of peers =head2 seed_ratio_limit $self->seed_ratio_limit($num); Session seeding ratio. =head2 seed_ratio_mode $self->seed_ratio_mode($num); Which ratio to use. See tr_ratiolimit. =head2 upload_limit $self->upload_limit($num); Maximum upload speed (in K/s) =head2 upload_limited $self->upload_limited($bool); True if "upload_limit" is honored =head2 activity_date $num = $self->activity_date; =head2 added_date $num = $self->added_date; =head2 bandwidth_priority $num = $self->bandwidth_priority; =head2 comment $str = $self->comment; =head2 corrupt_ever $num = $self->corrupt_ever; =head2 creator $str = $self->creator; =head2 date_created $num = $self->date_created; =head2 desired_available $num = $self->desired_available; =head2 done_date $num = $self->done_date; =head2 download_dir $str = $self->download_dir; =head2 downloaded_ever $num = $self->downloaded_ever; =head2 downloaders $num = $self->downloaders; =head2 download_limit $num = $self->download_limit; =head2 download_limited $bool = $self->download_limited; =head2 error $num = $self->error; =head2 error_string $str = $self->error_string; =head2 eta $num = $self->eta; =head2 hash_str $str = $self->hash_string; =head2 have_unchecked $num = $self->have_unchecked; =head2 have_valid $num = $self->have_valid; =head2 honors_session_limits $bool = $self->honors_session_limits; =head2 is_private $bool = $self->is_private; =head2 leechers $num = $self->leechers; =head2 left_until_done $num = $self->left_until_done; =head2 manual_announce_time $num = $self->manual_announce_time; =head2 max_connected_peers $num = $self->max_connected_peers; =head2 name $str = $self->name; =head2 peer $num = $self->peer; =head2 peers_connected $num = $self->peers_connected; =head2 peers_getting_from_us $num = $self->peers_getting_from_us; =head2 peers_known $num = $self->peers_known; =head2 peers_sending_to_us $num = $self->peers_sending_to_us; =head2 percent_done $num = $self->percent_done; =head2 pieces $str = $self->pieces; =head2 piece_count $num = $self->piece_count; =head2 piece_size $num = $self->piece_size; =head2 rate_download $num = $self->rate_download; =head2 rate_upload $num = $self->rate_upload; =head2 recheck_progress $num = $self->recheck_progress; =head2 seeders $num = $self->seeders; =head2 seed_ratio_limit $num = $self->seed_ratio_limit; =head2 seed_ratio_mode $num = $self->seed_ratio_mode; =head2 size_when_done $num = $self->size_when_done; =head2 start_date $num = $self->start_date; =head2 status $str = $self->status; =head2 swarm_speed $num = $self->swarm_speed; =head2 times_completed $num = $self->times_completed; =head2 total_size $num = $self->total_size; =head2 torrent_file $str = $self->torrent_file; =head2 uploaded_ever $num = $self->uploaded_ever; =head2 upload_limit $num = $self->upload_limit; =head2 upload_limited $bool = $self->upload_limited; =head2 upload_ratio $num = $self->upload_ratio; =head2 webseeds_sending_to_us $num = $self->webseeds_sending_to_us; =cut BEGIN { my $create_setter = sub { my $camel = $_[0]; return sub { return if($_[0]->lazy_write); $_[0]->client->rpc('torrent-set' => ids => [ $_[0]->id ], $camel => $_[1], ); }; }; my $create_getter = sub { my $camel = $_[0]; return sub { my $data = $_[0]->client->rpc('torrent-get' => ids => [ $_[0]->id ], fields => [ $camel ], ); return unless($data); return $data->{'torrents'}[0]{$camel}; }; }; my %SET = ( #'files-wanted' => array, #'files-unwanted' => array, 'location' => string, 'peer-limit' => number, #'priority-high' => array, #'priority-low' => array, #'priority-normal' => array, ); our %BOTH = ( # meant for internal usage bandwidthPriority => number, downloadLimit => number, downloadLimited => boolean, honorsSessionLimits => boolean, seedRatioLimit => double, seedRatioMode => number, uploadLimit => number, uploadLimited => boolean, ); our %READ = ( # meant for internal usage activityDate => number, addedDate => number, comment => string, corruptEver => number, creator => string, dateCreated => number, desiredAvailable => number, doneDate => number, downloadDir => string, downloadedEver => number, downloaders => number, error => number, errorString => string, eta => number, hashString => string, haveUnchecked => number, haveValid => number, isPrivate => boolean, leechers => number, leftUntilDone => number, manualAnnounceTime => number, maxConnectedPeers => number, name => string, peersConnected => number, peersGettingFromUs => number, peersKnown => number, peersSendingToUs => number, percentDone => double, pieceCount => number, pieceSize => number, rateDownload => number, rateUpload => number, recheckProgress => double, seeders => number, sizeWhenDone => number, startDate => number, status => string, swarmSpeed => number, timesCompleted => number, totalSize => number, torrentFile => string, uploadedEver => number, uploadRatio => double, webseedsSendingToUs => number, ); #peers => array, #peersFrom => object, #pieces => string, #priorities => array, #trackers => array, #trackerStats => array, #wanted => array, #webseeds => array, for my $camel (keys %SET) { my $name = __PACKAGE__->_camel2Normal($camel); my $setter = $create_setter->($camel); __PACKAGE__->meta->add_method("write_$name" => $setter); has $name => ( is => 'rw', isa => $SET{$camel}, coerce => 1, trigger => $setter, ); } for my $camel (keys %BOTH) { my $name = __PACKAGE__->_camel2Normal($camel); my $setter = $create_setter->($camel); my $getter = $create_getter->($camel); __PACKAGE__->meta->add_method("write_$name" => $setter); has $name => ( is => 'rw', isa => $BOTH{$camel}, coerce => 1, lazy => 1, trigger => $setter, default => $getter, ); } for my $camel (keys %READ) { my $name = __PACKAGE__->_camel2Normal($camel); my $getter = $create_getter->($camel); has $name => ( is => 'ro', isa => $READ{$camel}, coerce => 1, writer => "_set_$name", lazy => 1, default => $getter, ); } __PACKAGE__->meta->add_method(read => sub { my $self = shift; my @fields = uniq(@_, 'id'); # id should always be requested my $lazy = $self->lazy_write; my $data; $data = $self->client->rpc('torrent-get' => ids => [ $self->id ], fields => [ @fields ], ) or return; $data = $data->{'torrents'}[0] or return; # prevent from fireing off trigger in attributes $self->lazy_write(1); for my $camel (keys %$data) { my $name = __PACKAGE__->_camel2Normal($camel); my $writer = $READ{$camel} ? "_set_$name" : $name; $self->$writer($data->{$camel}); } # reset lazy_write $self->lazy_write($lazy); return 1; }); __PACKAGE__->meta->add_method(read_all => sub { my $self = shift; return $self->read(keys %BOTH, keys %READ); }); $READ{'id'} = 'Int'; # this is required to be read } =head2 files $array_ref = $self->files; $self->clear_files; Returns an array of Ls. =cut has files => ( is => 'ro', isa => 'ArrayRef', lazy_build => 1, ); sub _build_files { my $self = shift; my $files = []; my $stats = []; my $id = 0; my $data; $data = $self->client->rpc('torrent-get' => ids => [ $self->id ], fields => [ qw/ files fileStats / ], ); return [] unless($data); $files = $data->{'torrents'}[0]{'files'}; $stats = $data->{'torrents'}[0]{'fileStats'}; # this has to be true: @$files == @$stats while(@$stats) { my $stats = shift @$stats or last; my $file = shift @$files; push @$files, Transmission::Torrent::File->new(id => $id, %$stats, %$file); $id++; } return $files; } =head1 METHODS =head2 BUILDARGS $hash_ref = $self->BUILDARGS(\%args); Convert keys in C<%args> from "CamelCase" to "camel_case". =cut sub BUILDARGS { my $self = shift; my $args = $self->SUPER::BUILDARGS(@_); $self->_camel2Normal($args); return $args; } =head2 read $bool = $self->read('id', 'name', 'eta'); This method will refresh all requested attributes in one RPC request, while calling one and one attribute, results in one-and-one request. =head2 read_all $bool = $self->read_all; Similar to L, but requests all attributes. =head2 start See L. =head2 stop See L. =head2 verify See L. =cut { for my $name (qw/ start stop verify /) { __PACKAGE__->meta->add_method($name => sub { $_[0]->client->$name(ids => $_[0]->id); }); } } =head2 move $bool = $self->move($path); Will move the torrent content to C<$path>. =cut sub move { my $self = shift; my $path = shift; unless($path) { $self->client_error("Required argument 'path' is missing"); return; } return $self->client->move( ids => [$self->id], location => $path, move => 1, ); } =head2 write_wanted $bool = $self->write_wanted; Will write "wanted" information from L to transmission. =cut sub write_wanted { my $self = shift; my %wanted = ( wanted => [], unwanted => [] ); my $ok; for my $file (@{ $self->files }) { push @{ $wanted{ $file->wanted ? 'wanted' : 'unwanted' } }, $file->id; } for my $key (qw/wanted unwanted/) { # Transmission interpret an empty list to mean all files next unless @{$wanted{$key}}; $self->client->rpc('torrent-set' => ids => [ $self->id ], "files-$key" => $wanted{$key} ) or return; } return 1; } =head2 write_priority $bool = $self->write_priority; Will write "priorty" information from L to transmission. =cut sub write_priority { my $self = shift; my %priority = ( low => [], normal => [], high => [] ); my %map = ( -1 => 'low', 0 => 'normal', 1 => 'high' ); for my $file (@{ $self->files }) { my $key = $map{ $file->priority } || 'normal'; push @{ $priority{$key} }, $file->id; } for my $key (qw/low normal high/) { $self->client->rpc('torrent-set' => ids => [ $self->id ], "priority-$key" => $priority{$key} ) or return; } return 1; } =head1 LICENSE =head1 AUTHOR See L. =cut 1; Transmission-Client-0.0805/lib/Transmission/Utils.pm0000644001161000116100000000172012573102655021066 0ustar olofolof# ex:ts=4:sw=4:sts=4:et package Transmission::Utils; # See Transmission::Client for copyright statement. =head1 NAME Transmission::Utils - Utilies for modules that use Transmission::* =cut use strict; use warnings; use Sub::Exporter -setup => { exports => [qw/ from_numeric_status to_numeric_status /], }; my %numeric_status = qw/ 1 queued 2 checking 4 downloading 8 seeding 16 stopped /; =head1 FUNCTIONS =head2 from_numeric_status $str = from_numeric_status($int); Will translate a numeric status description from Transmission to something readable. =cut sub from_numeric_status { return $numeric_status{$_[0]} || q(); } =head2 to_numeric_status $int = to_numeric_status($str); Will translate a status description to a number used by Transmission. =cut sub to_numeric_status { my %tmp = reverse %numeric_status; return $tmp{$_[0]} || -1; } =head1 LICENSE =head1 AUTHOR See L =cut 1; Transmission-Client-0.0805/lib/Transmission/AttributeRole.pm0000644001161000116100000000406012573102655022553 0ustar olofolof# ex:ts=4:sw=4:sts=4:et package Transmission::AttributeRole; # See Transmission::Client for copyright statement. =head1 NAME Transmission::AttributeRole - For Torrent and Client =head1 DESCRIPTION This role is used by L and L. It requires the consuming class to provide the method C. =cut use Moose::Role; =head1 ATTRIBUTES =head2 client $obj = $self->client; Returns a L object. =cut has client => ( is => 'ro', isa => 'Object', handles => { client_error => 'error' }, ); =head2 lazy_write $bool = $self->lazy_write; $self->lazy_write($bool); Will prevent writeable attributes from sending a request to Transmission. L can then later be used to sync data. =cut has lazy_write => ( is => 'rw', isa => 'Bool', default => 0, ); =head2 eager_read $bool = $self->eager_read; Setting this attribute in constructor forces L to be called. This will again populate all (or most) attributes right after the object is constructed (if Transmission answers the request). =cut has eager_read => ( is => 'ro', isa => 'Bool', default => 0, trigger => sub { $_[0]->read_all if($_[1]) }, ); # this method name exists to prove a point - not to be readable... sub _convert { if(ref $_[1] eq 'HASH') { for my $camel (keys %{ $_[1] }) { my $key = $_[2]->($camel); if(ref $_[1]->{$camel} eq 'HASH') { __PACKAGE__->_convert($_[1]->{$camel}, $_[2]); } $_[1]->{$key} = delete $_[1]->{$camel}; } } else { return $_[2]->($_[1]); } } sub _camel2Normal { $_[0]->_convert( $_[1], sub { local $_ = $_[0]; tr/-/_/; s/([A-Z]+)/{ "_" .lc($1) }/ge; return $_; } ); } sub _normal2Camel { $_[0]->_convert( $_[1], sub { local $_ = $_[0]; tr/_/-/; s/_(\w)/{ uc($1) }/ge; # wild guess... return $_; } ); } =head1 LICENSE =head1 AUTHOR See L =cut 1; Transmission-Client-0.0805/lib/Transmission/Torrent/0000755001161000116100000000000012747415651021073 5ustar olofolofTransmission-Client-0.0805/lib/Transmission/Torrent/File.pm0000644001161000116100000000354012573102655022304 0ustar olofolof# ex:ts=4:sw=4:sts=4:et package Transmission::Torrent::File; # See Transmission::Client for copyright statement. =head1 NAME Transmission::Torrent::File - file within a Transmission torrent =cut use Moose; use Transmission::Types ':all'; with 'Transmission::AttributeRole'; =head1 ATTRIBUTES =head2 id $int = $self->id; This file index in the files list. =cut has id => ( is => 'ro', isa => 'Int', default => -1, ); =head2 length $num = $self->length; File size in bytes. =head2 name $str = $self->name; =head2 bytes_completed $num = $self->bytes_completed; Bytes downloaded. =head2 wanted $bool = $self->wanted; Flag which decides if this file will be downloaded or not. =cut has wanted => ( is => 'rw', isa => boolean, coerce => 1, default => 1, ); =head2 priority $int = $self->priority; Low, Normal or High, with the respectable values: -1, 0 and 1. =cut has priority => ( is => 'rw', isa => number, coerce => 1, default => 0, ); { my %read = ( key => string, length => number, name => string, bytesCompleted => number, ); for my $camel (keys %read) { my $name = __PACKAGE__->_camel2Normal($camel); has $name => ( is => 'ro', isa => $read{$camel}, coerce => 1, writer => "_set_$name", ); } } =head1 METHODS =head2 BUILDARGS $hash_ref = $class->BUILDARGS(\%args); Convert keys in C<%args> from "CamelCase" to "camel_case". =cut sub BUILDARGS { my $self = shift; my $args = $self->SUPER::BUILDARGS(@_); for my $camel (keys %$args) { my $key = __PACKAGE__->_camel2Normal($camel); $args->{$key} = delete $args->{$camel}; } return $args; } =head1 LICENSE =head1 AUTHOR See L =cut 1; Transmission-Client-0.0805/MANIFEST.SKIP0000644001161000116100000000013212573102655016063 0ustar olofolof^Transmission-Client ^pm_to_blib$ ^MYMETA\. ^blib/ \.bak$ ^Makefile$ ^\.git/ ^.gitignore$