Net-Trac-0.16/0000755000175000017500000000000011545655541012072 5ustar spangspangNet-Trac-0.16/MANIFEST0000644000175000017500000000151311545655450013222 0ustar spangspangChanges 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/Net/Trac.pm lib/Net/Trac/Connection.pm lib/Net/Trac/Mechanize.pm lib/Net/Trac/Ticket.pm lib/Net/Trac/TicketAttachment.pm lib/Net/Trac/TicketHistory.pm lib/Net/Trac/TicketHistoryEntry.pm lib/Net/Trac/TicketPropChange.pm lib/Net/Trac/TicketSearch.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml SIGNATURE t/01-dependencies.t t/02-create.t t/10-ticket-cf.t t/50-full-api.t t/99-pod-coverage.t t/99-pod.t t/attachments.t t/comments.t t/keywords.t t/parse_props.t t/search.t t/setup_trac.pl t/update.t Net-Trac-0.16/SIGNATURE0000644000175000017500000000753411545655541013367 0ustar spangspangThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.66. 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: SHA256 SHA1 41532df3140b910cc838690dd4a168c6877918fb Changes SHA1 5cd9a0ecbafeaf43d9a282e4c3a275dcf65a6c0c MANIFEST SHA1 e476d8bd724d46eb9e255cc8afc98b92269e2255 MANIFEST.SKIP SHA1 cf100003c1fd93b522973cbd40752c5945310f62 META.yml SHA1 7bc9a9055ba26fa8ade2837e9f67b528bb50f38f Makefile.PL SHA1 20c73697e1713638140c719d8eaa19a275ed43a5 inc/Module/AutoInstall.pm SHA1 7305dbe2904416e28decb05396988a5d51d578be inc/Module/Install.pm SHA1 ca13d9875e1249f6e84f7070be8152c34837955e inc/Module/Install/AutoInstall.pm SHA1 129960509127732258570c122042bc48615222e1 inc/Module/Install/Base.pm SHA1 cf3356ed9a5bd2f732527ef9e7bc5ef4458c8a93 inc/Module/Install/Can.pm SHA1 bf0a3e1977effc2832d7a813a76dce3f31b437b6 inc/Module/Install/Fetch.pm SHA1 b501b0df59a5cd235cca473889f82c3d3429f39e inc/Module/Install/Include.pm SHA1 b721c93ca5bc9a6aa863b49af15f1b1de6125935 inc/Module/Install/Makefile.pm SHA1 026cc0551a0ad399d195e395b46bdf842e115192 inc/Module/Install/Metadata.pm SHA1 5457015ea5a50e93465bf2dafa29feebd547f85b inc/Module/Install/Win32.pm SHA1 051e7fa8063908befa3440508d0584a2497b97db inc/Module/Install/WriteAll.pm SHA1 5f59c3646f1f0fbbe15cabb63d26947110c45130 lib/Net/Trac.pm SHA1 8bcfaae891eacf71a2618fa36471293d2ebb6d9f lib/Net/Trac/Connection.pm SHA1 3479b0fb66d47b894bdbfa49f6e172da5a7bb835 lib/Net/Trac/Mechanize.pm SHA1 504a5ef2829590aa7b7e527b361eee13643fc7f3 lib/Net/Trac/Ticket.pm SHA1 2297c6a67f6d83feae6571d063f2b3ddcf0fa4db lib/Net/Trac/TicketAttachment.pm SHA1 270e926b8c9fd7da5de8680f4eb67ff53d3e322f lib/Net/Trac/TicketHistory.pm SHA1 45c03697e72b5257d33068c3f6892207e1d35635 lib/Net/Trac/TicketHistoryEntry.pm SHA1 fb89bcd175e10073bbc6d59fe6411e6801e69876 lib/Net/Trac/TicketPropChange.pm SHA1 c48b630f582b7449402ff3412f7ba3cdc98546d3 lib/Net/Trac/TicketSearch.pm SHA1 4124638ff631162a468c9f45d10c9c343e607e7f t/01-dependencies.t SHA1 5bac82567587a272cc5e6e20c534e95e7d914247 t/02-create.t SHA1 ac65cffd1e645d1e9fdddf0b3d3f7fd9457615e5 t/10-ticket-cf.t SHA1 09a4bd062ebf911af1d1bd712edb4cddf50ddbe3 t/50-full-api.t SHA1 43f06b5200a7e849573909a01fd114d972822237 t/99-pod-coverage.t SHA1 bb0da54f2b3f2d7955baa41ee458cb3d1887f475 t/99-pod.t SHA1 8ae786735b791c43280bb5d85578101fd9146b0a t/attachments.t SHA1 9f9e842c9dd7f6f0585cbb872226e92d8988aa7f t/comments.t SHA1 f1dec6d81523033b07caf630e76f8ff2b4db5da3 t/keywords.t SHA1 4b8b427eb4a55d5e645a6f10e6ab20401a65432c t/parse_props.t SHA1 ff41a7acc8fd7ee92e536e04d93c668a0d0cb28a t/search.t SHA1 563d1d685018a9165656743631bcc68bd978b03e t/setup_trac.pl SHA1 64b7d8d50e26f83faba8522a2c52267c9a12d7f4 t/update.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.11 (GNU/Linux) iQIcBAEBCAAGBQJNl1tdAAoJEGSVn+mDjfGcS0IP/3SJN9ErGqORwRWxSjRhYW0t 7aD3yu9vRciuumbrBHJD/zI86LC1fs5Shs00RdaFfjopyW5CKGe+G1lHzdh4jeLI AcRWHNiu9WGHb1+hDvAirEH0zgTa2ihfK7yH1P6R31cR4qIBH1xzYxatSr/ykDyi 2iHRkyL7EgM/aWQJXt4dqcs2bzWKumWqdKNk55U02hMOyNKatv2ROwo8Yw0eXoQX PS+nhVaynaLLCClKmcAdRkLIbyOytIYEYb1D3IKicFYByMuT2wCAm/7LVm/8/8cV 98zAuOcWgYzj5yZVaN+BBF1GqLeuw2ZGwRar/+mR/z0ZSLVdjLRwpv5vez3OhYl6 9cPmPkH3BLUd+YhlFmccJvL3ISKADQgZE4xBDW9WXUQt1ukmUauzYYk/V5pkWIGB zIFk/0pe/tm6qm/0Og01c/EpLdNrpmfUIs5PQGhNfXZe+n1bJ8SjQGY9RuNTG0rt hm9v2YUOP6tKJwUEL54MjONkNVRLAtT4D6ECqU2cyWlPpOmrDgJHqcA88Yg7BjGM 3BdMJBelCqsGs7XwuAh8yWHzB6Dzrz3MA1T9QVeWZes1vxUjp/CjZxKpzvWK1wLc Dm5U5qvQbJ4Z6FsjOvZmC06wmSG06b2poNREvdL6plgqhu1ujV0YPt8h+/nADZ2m /bZsTtP5gj2nAw4+9Z6+ =+Qnj -----END PGP SIGNATURE----- Net-Trac-0.16/META.yml0000644000175000017500000000131611545655535013347 0ustar spangspang--- abstract: 'Interact with a remote Trac instance' author: - 'Jesse Vincent , Thomas Sibley ' build_requires: ExtUtils::MakeMaker: 6.42 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.00' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Net-Trac no_index: directory: - inc - t requires: Any::Moose: 0 DateTime: 0 HTTP::Date: 0 LWP::Simple: 0 Lingua::EN::Inflect: 0 Params::Validate: 0 Text::CSV: 0 URI: 0 URI::Escape: 0 WWW::Mechanize: 1.52 resources: license: http://dev.perl.org/licenses/ version: 0.16 Net-Trac-0.16/Makefile.PL0000644000175000017500000000062411207136755014042 0ustar spangspanguse warnings; use strict; use inc::Module::Install; name 'Net-Trac'; all_from 'lib/Net/Trac.pm'; license 'perl'; requires 'Any::Moose'; requires 'URI'; requires 'LWP::Simple'; requires 'Params::Validate'; requires 'WWW::Mechanize' => '1.52'; requires 'DateTime'; requires 'HTTP::Date'; requires 'Lingua::EN::Inflect'; requires 'URI::Escape'; requires 'Text::CSV'; auto_install; sign; WriteAll; Net-Trac-0.16/Changes0000644000175000017500000000630411545654623013370 0ustar spangspang0.16 Sat Apr 02 13:00:00 EDT 2011 * initial cf fields support and tests -- sunnavy@bestpractical.com, Jacek Pasternak (6af5742, f55d5a, b061eca) * add default arrayref for ticket attachments -- plobsinger@gmail.com (c3bd330) * stick to the update api: trac doesn't support directly update status and resolution since 0.11.7 -- sunnavy@bestpractical.com (4bd778c, 08492c3) 0.15 Mon Jan 18 11:58:06 PST 2010 * Module::Install bump 0.14 Wed Jun 10 10:06:36 EDT 2009 * Use keepalives for slightly better trac performance -- (3abd840) * Fixes for our awful html history parsing heuristics -- (4484ea2) * content_type test for attachment -- (605ac65) * let _load return content and content_type so default values can use them -- (980f388) * added attachment attr and parse it too for TicketHistoryEntry -- (c3d23c5) * pod update for Attachment -- (7e524cb) * added content and content_type attrs for Attachment -- (4c6998c) * update attachment parse part to satisify individual attachment page need -- (1891837) 0.13 Tue May 5 18:38:27 EDT 2009 * Added create transactions to ticket history * Added a flag for "this history entry is a create" * Add a ticket accessor on ticket history entries 0.12 Mon Apr 20 14:20:04 CST 2009 * Better support for running against trac servers you don't have a write access to 0.10 Thu Feb 26 18:42:47 EST 2009 * [rt.cpan.org #43642] Server didn't start up on slow box ANDK++ 0.09 Sat Feb 21 21:22:42 EST 2009 * Loosen our DateTime regex 0.08 Sat Feb 21 20:18:30 EST 2009 * Start using Text::CSV to parse Trac TSV format * Rather than regex dates and then use DateTime::Format::ISO8601, just build a DateTime * Don't fetch ticket update info on ticket load 0.07 Thu Feb 19 18:48:21 EST 2009 * Removed unnecessary use of heavy CPAN modules 0.06 Mon Feb 9 13:44:37 EST 2009 BUGFIX ====== * parsing improvements to deal with issues discovered parsing parrot trac - jesse FEATURE ======= * Support login with Trac's cookie auth - jesse * Skip transaction history types we don't know how to deal with - jesse INSTALL ======= * Remove coerce - jesse * Removing MooseX::ClassAttribute - jesse * Switch to Any::Moose, so we can use Mouse for memory and cpu savings! - jesse * Starting to work on removing MooseX::ClassAccessor Working on props parsing - jesse PERFORMANCE =========== * Better caching of ticket history. Properish handling of the keywords filed - jesse * Improve performance of ticket ops by caching static data Improve detection of ticket update/create forms when the user doesn't have the right to set the requestor - jesse TESTING ======= * added tests for keywords - jesse 0.05 Thu Jan 22 12:11:45 EST 2009 Don't hurt cpan-testers build boxes by trying to kill process undef. 0.04 Wed Jan 21 19:26:56 EST 2009 * Able to log into trac instances which use cookie auth * Able to work with trac instances that don't let all users set the ticket requestor 0.03 Wed Jan 21 15:01:56 EST 2009 First largely API-complete release Net-Trac-0.16/lib/0000755000175000017500000000000011545655535012643 5ustar spangspangNet-Trac-0.16/lib/Net/0000755000175000017500000000000011545655535013371 5ustar spangspangNet-Trac-0.16/lib/Net/Trac/0000755000175000017500000000000011545655535014262 5ustar spangspangNet-Trac-0.16/lib/Net/Trac/TicketPropChange.pm0000644000175000017500000000127011207136756020004 0ustar spangspanguse strict; use warnings; package Net::Trac::TicketPropChange; use Any::Moose; =head1 NAME Net::Trac::TicketPropChange - A single property change in a Trac ticket history entry =head1 DESCRIPTION A very simple class to represent a single property change in a history entry. =head1 ACCESSORS =head2 property =head2 old_value =head2 new_value =cut has property => ( isa => 'Str', is => 'rw' ); has old_value => ( isa => 'Str', is => 'rw' ); has new_value => ( isa => 'Str', is => 'rw' ); =head1 LICENSE Copyright 2008-2009 Best Practical Solutions. This package is licensed under the same terms as Perl 5.8.8. =cut __PACKAGE__->meta->make_immutable; no Any::Moose; 1; Net-Trac-0.16/lib/Net/Trac/Connection.pm0000644000175000017500000001116411213667515016713 0ustar spangspangpackage Net::Trac::Connection; =head1 NAME Net::Trac::Connection - Connection to a remote Trac server =head1 DESCRIPTION This class represents a connection to a remote Trac instance. It is required by all other classes which need to talk to Trac. =head1 SYNOPSIS use Net::Trac::Connection; my $trac = Net::Trac::Connection->new( url => 'http://trac.example.com', user => 'snoopy', password => 'doghouse' ); =cut use Any::Moose; use URI; use Params::Validate; use Text::CSV; use Net::Trac::Mechanize; =head1 ACCESSORS =head2 url The url of the Trac instance used by this connection. Read-only after initialization. =head2 user =head2 password =cut has url => ( isa => 'Str', is => 'ro' ); has user => ( isa => 'Str', is => 'ro' ); has password => ( isa => 'Str', is => 'ro' ); =head1 ACCESSORS / MUTATORS =head2 logged_in [BOOLEAN] Gets/sets a boolean indicating whether or not the connection is logged in yet. =cut has logged_in => ( isa => 'Bool', is => 'rw' ); =head2 mech [MECH] Gets/sets the L (or subclassed) object for this connection to use. Unless you want to replace it with one of your own, the default will suffice. =cut has mech => ( isa => 'Net::Trac::Mechanize', is => 'ro', lazy => 1, default => sub { my $self = shift; my $m = Net::Trac::Mechanize->new( cookie_jar => {}, keep_alive => 4); $m->trac_user( $self->user ); $m->trac_password( $self->password ); return $m; } ); =head1 METHODS =head2 new PARAMHASH Creates a new L given a paramhash with values for the keys C, C, and C. =head2 ensure_logged_in Ensures this connection is logged in. Returns true on success, and undef on failure. Sets the C flag. =cut sub ensure_logged_in { my $self = shift; if ( !defined $self->logged_in ) { $self->_fetch("/login") or return; my ($form, $form_num) = $self->_find_login_form(); if ($form_num) { $self->mech->submit_form( form_number => $form_num, fields => { user => $self->user, password => $self->password, submit => 1 } ); } $self->logged_in(1); } return $self->logged_in; } sub _find_login_form { my $self = shift; my $i = 1; for my $form ( $self->mech->forms() ) { return ($form,$i) if $form->find_input('user'); $i++; } } =head1 PRIVATE METHODS =head2 _fetch URL Fetches the provided B URL from the Trac server. Returns undef on an error (after Cing) and the content (C<$self->mech->content>) on success. =cut sub _fetch { my $self = shift; my $query = shift; my $abs_url = $self->url . $query; $self->mech->get($abs_url); if ( $self->_warn_on_error($abs_url) ) { warn "Failed to fetch $abs_url"; return } else { return $self->mech->content } } =head2 _warn_on_error URL Checks the last request for an error condition and warns about them if found. Returns with a B value if errors occurred and a B value otherwise for nicer conditionals. =cut sub _warn_on_error { my $self = shift; my $url = shift; my $die = 0; if ( !$self->mech->response->is_success ) { warn "Server threw an error " . $self->mech->response->status_line . " for " . $url . "\n"; $die++; } if ( $self->mech->content =~ qr{

(.*?)

(.*?)

}ism ) { warn "$1 $2\n"; $die++; } # Returns TRUE if it got an error, for nicer conditionals when calling if ( $die ) { warn "Request errored out.\n"; return 1; } else { return } } =head2 _tsv_to_struct PARAMHASH Takes a paramhash of the keys C Given TSV data this method will return a reference to an array. =cut sub _tsv_to_struct { my $self = shift; my %args = validate( @_, { data => 1 } ); my $lines = ${ $args{'data'} }; open (my $io, "<",\$lines) || die "Couldn't open in-memory file to data: $!"; my $csv = Text::CSV->new({binary => 1, sep_char => "\t" }); $csv->column_names ($csv->getline ($io)); my @results; while (my $hr = $csv->getline_hr ($io)) { push @results, $hr; } close($io)||die $!; return \@results; } =head1 LICENSE Copyright 2008-2009 Best Practical Solutions. This package is licensed under the same terms as Perl 5.8.8. =cut __PACKAGE__->meta->make_immutable; no Any::Moose; 1; Net-Trac-0.16/lib/Net/Trac/Mechanize.pm0000644000175000017500000000176711207136756016530 0ustar spangspanguse strict; use warnings; package Net::Trac::Mechanize; =head1 NAME Net::Trac::Mechanize - Provides persistent credentials for the Trac instance =head1 DESCRIPTION This class subclasses L to provide persistent HTTP credentials when accessing a Trac instance. =cut use Any::Moose; extends 'WWW::Mechanize'; =head1 ACCESSORS / MUTATORS =head2 trac_user =head2 trac_password =cut has trac_user => ( isa => 'Str', is => 'rw' ); has trac_password => ( isa => 'Str', is => 'rw' ); =head1 METHODS =head2 get_basic_credentials Returns the credentials that L expects. =cut sub get_basic_credentials { my $self = shift; return ( $self->trac_user => $self->trac_password ); } =head1 LICENSE Copyright 2008-2009 Best Practical Solutions. This package is licensed under the same terms as Perl 5.8.8. =cut # This is commented because it breaks the class, causing it to # seemingly not follow HTTP redirects. #__PACKAGE__->meta->make_immutable; no Any::Moose; 1; Net-Trac-0.16/lib/Net/Trac/TicketAttachment.pm0000644000175000017500000001027111222162566020042 0ustar spangspanguse strict; use warnings; package Net::Trac::TicketAttachment; use Any::Moose; use URI::Escape qw(uri_escape); =head1 NAME Net::Trac::TicketAttachment - Represents a single attachment for a Trac ticket =head1 DESCRIPTION This class represents a single attachment for a Trac ticket. You do not want to deal with instantiating this class yourself. Instead let L do the work. =head1 ACCESSORS =head2 connection Returns the L used by this class. =head2 ticket Returns the ID of the ticket to which this attachment belongs. =head2 filename =head2 description =head2 url Relative to the remote Trac instance URL as set in the L. =head2 content returns the content of the attachment =head2 content_type returns the content_type of the attachment =head2 size In bytes. =head2 author =head2 date Returns a L object. =cut has connection => ( isa => 'Net::Trac::Connection', is => 'ro' ); has ticket => ( isa => 'Int', is => 'ro' ); has date => ( isa => 'DateTime', is => 'rw' ); has filename => ( isa => 'Str', is => 'rw' ); has description => ( isa => 'Str', is => 'rw' ); has url => ( isa => 'Str', is => 'rw' ); has author => ( isa => 'Str', is => 'rw' ); has size => ( isa => 'Int', is => 'rw' ); has content => ( isa => 'Str', is => 'rw', lazy => 1, default => sub { ($_[0]->_load)[0] }, ); has content_type => ( isa => 'Str', is => 'rw', lazy => 1, default => sub { ($_[0]->_load)[1] }, ); =head1 PRIVATE METHODS =head2 _parse_html_chunk STRING Parses a specific chunk of HTML (as extracted by L) into the various fields. =cut sub _parse_html_chunk { my $self = shift; my $html = shift; # xl0A1UDD4i # (27 bytes) - added by hiro # 0 seconds ago. # #
# Test description #
# for individual attachment page, the html is like: # #
#

Ticket #2: test.2.txt

# # # # # # # # # #
# File test.2.txt, 5 bytes # (added by sunnavy, 13 seconds ago) #
#

#blalba #

# #
#
$self->filename($1) if $html =~ qr{(.+?)}; $self->url( "/raw-attachment/ticket/" . $self->ticket . "/" . uri_escape( $self->filename ) ) if defined $self->filename; $self->size($1) if $html =~ qr{}; $self->author($1) if $html =~ qr{added by (?:)?\s*(\w+)}; if ( $html =~ qr{} ) { my $scalar_date = $1; $self->date( Net::Trac::Ticket->timestamp_to_datetime($scalar_date) ); } $self->description($1) if $html =~ qr{(?:
|

)\s*(.*?)\s*(?:

|

)}s; return 1; } sub _load { my $self = shift; my $content = $self->connection->_fetch( $self->url ); my $content_type; my $type_header = $self->connection->mech->response->header('Content-Type'); if ( $type_header =~ /(\S+?);/ ) { $content_type = $1; } $self->content( $content ); $self->content_type( $content_type ); return $content, $content_type; } =head1 LICENSE Copyright 2008-2009 Best Practical Solutions. This package is licensed under the same terms as Perl 5.8.8. =cut __PACKAGE__->meta->make_immutable; no Any::Moose; 1; Net-Trac-0.16/lib/Net/Trac/TicketSearch.pm0000644000175000017500000001015011207136756017160 0ustar spangspanguse strict; use warnings; package Net::Trac::TicketSearch; use Any::Moose; use Params::Validate qw(:all); use URI::Escape qw(uri_escape); use Net::Trac::Ticket; =head1 NAME Net::Trac::TicketSearch - A ticket search (custom query) in Trac =head1 SYNOPSIS my $search = Net::Trac::TicketSearch->new( connection => $trac ); $search->query( owner => 'hiro', status => { 'not' => [qw(new reopened)] }, summary => { 'contains' => 'yatta!' }, reporter => [qw( foo@example.com bar@example.com )] ); print $_->id, "\n" for @{$search->results}; =head1 DESCRIPTION This class allows you to run ticket searches on a remote Trac instance. =head1 ACCESSORS =head2 connection =head2 limit [NUMBER] Get/set the maximum number of results to fetch. Default is 500. This may also be limited by the Trac instance itself. =head2 results Returns an arrayref of Ls for the current query. =head2 url Returns the relative URL for the current query (note the format will be CSV). =cut has connection => ( isa => 'Net::Trac::Connection', is => 'ro' ); has limit => ( isa => 'Int', is => 'rw', default => sub { 500 } ); has results => ( isa => 'ArrayRef', is => 'rw', default => sub { [] } ); has url => ( isa => 'Str', is => 'rw' ); =head1 METHODS =head2 query [PARAMHASH] Performs a ticket search with the given search conditions. Specify a hash of C value> pairs for which to search. Values may be a simple scalar, a hashref, or an arrayref. Specifying a hashref allows you to select a different operator for comparison (see below for a list). An arrayref allows multiple values to be B'd for the same column. Unfortunately Trac has no way of Bing multiple values for the same column. Valid operators are C (default), C, C, C, C, and C. Returns undef on error and the L otherwise. =cut sub query { my $self = shift; my %query = @_; my $no_objects = delete $query{'_no_objects'}; # Clear current results $self->results([]); # Build a URL from the fields we want and the query my $base = '/query?format=tab&order=id&max=' . $self->limit; $base .= '&' . join '&', map { "col=$_" } Net::Trac::Ticket->valid_props; $self->url( $self->_build_query( $base, \%query ) ); my $content = $self->connection->_fetch( $self->url ) or return; my $data = $self->connection->_tsv_to_struct( data => \$content); unless ( $no_objects ) { my @tickets = (); for my $ticket_data ( @{$data || []} ) { my $ticket = Net::Trac::Ticket->new( connection => $self->connection ); $ticket->_tweak_ticket_data_for_load($ticket_data); my $id = $ticket->load_from_hashref( $ticket_data ); push @tickets, $ticket if $id; } return $self->results( \@tickets ); } else { return $self->results( $data ); } } our %OPERATORS = ( undef => '', '' => '', is => '', not => '!', contains => '~', lacks => '!~', startswith => '^', endswith => '$', ); sub _build_query { my $self = shift; my $base = shift; my $query = shift || {}; my $defaultop = $OPERATORS{ shift || 'is' } || ''; for my $key ( keys %$query ) { my $value = $query->{$key}; if ( ref $value eq 'ARRAY' ) { $base .= "&$key=" . uri_escape( $defaultop . $_ ) for @$value; } elsif ( ref $value eq 'HASH' ) { my ($op, $v) = %$value; $base .= $self->_build_query( '', { $key => $v }, $op ); } elsif ( not ref $value ) { $base .= "&$key=" . uri_escape( $defaultop . $value ); } else { warn "Skipping '$key = $value' in ticket search: value not understood."; } } return $base; } =head1 LICENSE Copyright 2008-2009 Best Practical Solutions. This package is licensed under the same terms as Perl 5.8.8. =cut __PACKAGE__->meta->make_immutable; no Any::Moose; 1; Net-Trac-0.16/lib/Net/Trac/Ticket.pm0000644000175000017500000003574611545644020016045 0ustar spangspanguse strict; use warnings; package Net::Trac::Ticket; =head1 NAME Net::Trac::Ticket - Create, read, and update tickets on a remote Trac instance =head1 SYNOPSIS my $ticket = Net::Trac::Ticket->new( connection => $trac ); $ticket->load( 1 ); print $ticket->summary, "\n"; =head1 DESCRIPTION This class represents a ticket on a remote Trac instance. It provides methods for creating, reading, and updating tickets and their history as well as adding comments and getting attachments. =cut use Any::Moose; use Params::Validate qw(:all); use Lingua::EN::Inflect qw(); use DateTime; use Net::Trac::TicketSearch; use Net::Trac::TicketHistory; use Net::Trac::TicketAttachment; has connection => ( isa => 'Net::Trac::Connection', is => 'ro' ); has state => ( isa => 'HashRef', is => 'rw' ); has history => ( isa => 'Net::Trac::TicketHistory', is => 'rw', default => sub { my $self = shift; my $hist = Net::Trac::TicketHistory->new( { connection => $self->connection } ); $hist->load($self); return $hist; }, lazy => 1 ); has _attachments => ( isa => 'ArrayRef', is => 'rw', default => sub {[]} ); our $LOADED_NEW_METADATA =0; our $LOADED_UPDATE_METADATA =0; our ( $_VALID_MILESTONES, $_VALID_TYPES, $_VALID_COMPONENTS, $_VALID_PRIORITIES, $_VALID_RESOLUTIONS, $_VALID_SEVERITIES ); sub valid_milestones { shift; $_VALID_MILESTONES = shift if (@_); return $_VALID_MILESTONES || [] } sub valid_types { shift; $_VALID_TYPES = shift if (@_); return $_VALID_TYPES ||[]} sub valid_components { shift; $_VALID_COMPONENTS = shift if (@_); return $_VALID_COMPONENTS || [] } sub valid_priorities { shift; $_VALID_PRIORITIES = shift if (@_); return $_VALID_PRIORITIES || [] } sub valid_resolutions { shift; $_VALID_RESOLUTIONS = shift if (@_); return $_VALID_RESOLUTIONS || []; } sub valid_severities { shift; $_VALID_SEVERITIES = shift if (@_); return $_VALID_SEVERITIES || [] } sub basic_statuses { qw( new accepted assigned reopened closed ) } my @valid_props_arr = (); sub valid_props { return @valid_props_arr } sub add_custom_props { my ($self, @props) = @_; for my $prop (@props) { next if grep { $_ eq $prop } @valid_props_arr; push @valid_props_arr, $prop; no strict 'refs'; *{ "Net::Trac::Ticket::" . $prop } = sub { shift->state->{$prop} }; } } Net::Trac::Ticket->add_custom_props(qw( id summary type status priority severity resolution owner reporter cc description keywords component milestone version time changetime )); sub valid_create_props { grep { !/^(?:resolution|time|changetime)$/i } $_[0]->valid_props } sub valid_update_props { grep { !/^(?:time|changetime)$/i } $_[0]->valid_props } sub created { my $self= shift; $self->timestamp_to_datetime($self->time) } sub last_modified { my $self= shift; $self->timestamp_to_datetime($self->changetime) } =head2 timestamp_to_datetime $stamp Accept's a timestamp in Trac's somewhat idiosyncratic format and returns a DateTime object =cut sub timestamp_to_datetime { my ( $self, $prop ) = @_; if ( $prop =~ /^(\d{4})-(\d\d)-(\d\d)[\sT](\d\d):(\d\d):(\d\d)(?:Z?([+-][\d:]+))?/i ) { my ( $year, $month, $day, $hour, $min, $sec, $offset) = ( $1, $2, $3, $4, $5, $6, $7 ); $offset ||= '00:00'; $offset =~ s/://; return DateTime->new( year => $year, month => $month, day => $day, hour => $hour, minute => $min, second => $sec, time_zone => $offset); } } =head1 METHODS =head2 new HASH Takes a key C with a value of a L. Returns an empty ticket object. =head2 load ID Loads up the ticket with the specified ID. Returns the ticket ID loaded on success and undef on failure. =cut sub load { my $self = shift; my ($id) = validate_pos( @_, { type => SCALAR } ); my $search = Net::Trac::TicketSearch->new( connection => $self->connection ); $search->limit(1); $search->query( id => $id, _no_objects => 1 ); return unless @{ $search->results }; my $ticket_data = $search->results->[0]; $self->_tweak_ticket_data_for_load($ticket_data); my $tid = $self->load_from_hashref( $ticket_data); return $tid; } # We force an order on the keywords prop since trac doesn't let us # really know what the order used to be sub _tweak_ticket_data_for_load { my $self = shift; my $ticket = shift; $ticket->{keywords} = join(' ', sort ( split ( /\s+/,$ticket->{keywords}))); } =head2 load_from_hashref HASHREF [SKIP] You should never need to use this method yourself. Loads a ticket from a hashref of data, optionally skipping metadata loading (values of C accessors). =cut sub load_from_hashref { my $self = shift; my ($hash, $skip_metadata) = validate_pos( @_, { type => HASHREF }, { type => BOOLEAN, default => undef } ); return undef unless $hash and $hash->{'id'}; $self->state( $hash ); return $hash->{'id'}; } sub _get_new_ticket_form { my $self = shift; $self->connection->ensure_logged_in; $self->connection->_fetch("/newticket") or return; my $i = 1; # form number for my $form ( $self->connection->mech->forms() ) { return ($form,$i) if $form->find_input('field_summary'); $i++; } return undef; } sub _get_update_ticket_form { my $self = shift; $self->connection->ensure_logged_in; $self->connection->_fetch("/ticket/".$self->id) or return; my $i = 1; # form number; for my $form ( $self->connection->mech->forms() ) { return ($form,$i) if $form->find_input('field_summary'); $i++; } return undef; } sub _get_possible_values { my $self = shift; my ($form, $field) = @_; my $res = $form->find_input($field); return [] unless defined $res; return [ $res->possible_values ]; } sub _fetch_new_ticket_metadata { my $self = shift; return 1 if $LOADED_NEW_METADATA; my ($form, $form_num) = $self->_get_new_ticket_form; unless ( $form ) { return undef; } $self->valid_milestones( $self->_get_possible_values( $form, 'field_milestone' ) ); $self->valid_types( $self->_get_possible_values( $form, 'field_type' ) ); $self->valid_components( $self->_get_possible_values( $form, 'field_component' ) ); $self->valid_priorities( $self->_get_possible_values( $form, 'field_priority' ) ); my $severity = $form->find_input("field_severity"); $self->valid_severities([ $severity->possible_values ]) if $severity; $LOADED_NEW_METADATA++; return 1; } sub _fetch_update_ticket_metadata { my $self = shift; return 1 if $LOADED_UPDATE_METADATA; my ($form, $form_num) = $self->_get_update_ticket_form; unless ($form) { return undef; } my $resolutions = $form->find_input("action_resolve_resolve_resolution"); $self->valid_resolutions( [$resolutions->possible_values] ) if $resolutions; $LOADED_UPDATE_METADATA++; return 1; } sub _metadata_validation_rules { my $self = shift; my $type = lc shift; # Ensure that we've loaded up metadata $self->_fetch_new_ticket_metadata unless $LOADED_NEW_METADATA; $self->_fetch_update_ticket_metadata if ( ( $type eq 'update' ) && ! $LOADED_UPDATE_METADATA); my %rules; for my $prop ( @_ ) { my $method = "valid_" . Lingua::EN::Inflect::PL($prop); if ( $self->can($method) ) { # XXX TODO: escape the values for the regex? my $values = join '|', grep { defined and length } @{$self->$method}; if ( length $values ) { my $check = qr{^(?:$values)$}i; $rules{$prop} = { type => SCALAR, regex => $check, optional => 1 }; } else { $rules{$prop} = 0; } } else { $rules{$prop} = 0; # optional } } return \%rules; } =head2 create HASH Creates and loads a new ticket with the values specified. Returns undef on failure and the new ticket ID on success. =cut sub create { my $self = shift; my %args = validate( @_, $self->_metadata_validation_rules( 'create' => $self->valid_create_props ) ); my ($form,$form_num) = $self->_get_new_ticket_form(); my %form = map { 'field_' . $_ => $args{$_} } keys %args; $self->connection->mech->submit_form( form_number => $form_num, fields => { %form, submit => 1 } ); my $reply = $self->connection->mech->response; $self->connection->_warn_on_error( $reply->base->as_string ) and return; if ($reply->title =~ /^#(\d+)/) { my $id = $1; $self->load($id); return $id; } else { return undef; } } =head2 update HASH Updates the current ticket with the specified values. Returns undef on failure, and the ID of the current ticket on success. =cut sub update { my $self = shift; my %args = validate( @_, { comment => 0, %{$self->_metadata_validation_rules( 'update' => $self->valid_update_props )} } ); my ($form,$form_num)= $self->_get_update_ticket_form(); # Copy over the values we'll be using my %form = map { "field_".$_ => $args{$_} } grep { !/comment|no_auto_status|status|resolution|owner/ } keys %args; # Copy over comment too -- it's a pseudo-prop $form{'comment'} = $args{'comment'}; $self->connection->mech->form_number( $form_num ); if ( $args{'resolution'} || $args{'status'} && $args{'status'} eq 'closed' ) { $form{'action'} = 'resolve'; $form{'action_resolve_resolve_resolution'} = $args{'resolution'} if $args{'resolution'}; } elsif ( $args{'owner'} || $args{'status'} && $args{'status'} eq 'assigned' ) { $form{'action'} = 'reassign'; $form{'action_reassign_reassign_owner'} = $args{'owner'} if $args{'owner'}; } elsif ( $args{'status'} && $args{'status'} eq 'reopened' ) { $form{'action'} = 'reopen'; } $self->connection->mech->submit_form( form_number => $form_num, fields => { %form, submit => 1 } ); my $reply = $self->connection->mech->response; if ( $reply->is_success ) { delete $self->{history}; # ICK. I really want a Any::Moose "reset to default" return $self->load($self->id); } else { return undef; } } =head2 comment TEXT Adds a comment to the current ticket. Returns undef on failure, true on success. =cut sub comment { my $self = shift; my ($comment) = validate_pos( @_, { type => SCALAR }); $self->update( comment => $comment ); } =head2 history Returns a L object for this ticket. =cut =head2 comments Returns an array or arrayref (depending on context) of history entries which have comments included. This will include history entries representing attachments if they have descriptions. =cut sub comments { my $self = shift; my $hist = $self->history; my @comments; for ( @{$hist->entries} ) { push @comments, $_ if ($_->content =~ /\S/ && ! $_->is_create); } return wantarray ? @comments : \@comments; } sub _get_add_attachment_form { my $self = shift; $self->connection->ensure_logged_in; $self->connection->_fetch("/attachment/ticket/".$self->id."/?action=new") or return; my $i = 1; # form number; for my $form ( $self->connection->mech->forms() ) { return ($form,$i) if $form->find_input('attachment'); $i++; } return undef; } =head2 attach PARAMHASH Attaches the specified C with an optional C. Returns undef on failure and the new L object on success. =cut sub attach { my $self = shift; my %args = validate( @_, { file => 1, description => 0 } ); my ($form, $form_num) = $self->_get_add_attachment_form(); $self->connection->mech->submit_form( form_number => $form_num, fields => { attachment => $args{'file'}, description => $args{'description'}, replace => 0 } ); my $reply = $self->connection->mech->response; $self->connection->_warn_on_error( $reply->base->as_string ) and return; delete $self->{history}; # ICK. I really want a Any::Moose "reset to default" return $self->attachments->[-1]; } sub _update_attachments { my $self = shift; $self->connection->ensure_logged_in; my $content = $self->connection->_fetch("/attachment/ticket/".$self->id."/") or return; if ( $content =~ m{
(.+?)
}is ) { my $html = $1 . '
'; # adding a
here is a hack that lets us # reliably parse this with one regex my @attachments; while ( $html =~ m{
(.+?)(?=
)}gis ) { my $fragment = $1; my $attachment = Net::Trac::TicketAttachment->new({ connection => $self->connection, ticket => $self->id }); $attachment->_parse_html_chunk( $fragment ); push @attachments, $attachment; } $self->_attachments( \@attachments ); } } =head2 attachments Returns an array or arrayref (depending on context) of all the L objects for this ticket. =cut sub attachments { my $self = shift; $self->_update_attachments; return wantarray ? @{$self->_attachments} : $self->_attachments; } =head1 ACCESSORS =head2 connection =head2 id =head2 summary =head2 type =head2 status =head2 priority =head2 severity =head2 resolution =head2 owner =head2 reporter =head2 cc =head2 description =head2 keywords =head2 component =head2 milestone =head2 version =head2 created Returns a L object =head2 last_modified Returns a L object =head2 basic_statuses Returns a list of the basic statuses available for a ticket. Others may be defined by the remote Trac instance, but we have no way of easily getting them. =head2 valid_props Returns a list of the valid properties of a ticket. =head2 add_custom_props Adds custom properties to valid properties list. =head2 valid_create_props Returns a list of the valid properties specifiable when creating a ticket. =head2 valid_update_props Returns a list of the valid updatable properties. =head2 Valid property values These accessors are loaded from the remote Trac instance with the valid values for the properties upon instantiation of a ticket object. =over =item valid_milestones =item valid_types =item valid_components =item valid_priorities =item valid_resolutions - Only loaded when a ticket is loaded. =item valid_severities - May not be provided by the Trac instance. =back =head1 LICENSE Copyright 2008-2009 Best Practical Solutions. This package is licensed under the same terms as Perl 5.8.8. =cut __PACKAGE__->meta->make_immutable; no Any::Moose; 1; Net-Trac-0.16/lib/Net/Trac/TicketHistory.pm0000644000175000017500000000544511207136756017427 0ustar spangspanguse strict; use warnings; package Net::Trac::TicketHistory; use Any::Moose; use Params::Validate qw(:all); use Net::Trac::TicketHistoryEntry; =head1 NAME Net::Trac::TicketHistory - A Trac ticket's history =head1 SYNOPSIS my $history = Net::Trac::TicketHistory->new( connection => $trac ); $history->load( 13 ); # Print the authors of all the changes to ticket #13 for ( @{ $history->entries } ) { print $_->author, "\n"; } =head1 DESCRIPTION This class represents a Trac ticket's history and is really just a collection of L. =head1 ACCESSORS =head2 connection =head2 ticket Returns the ID of the ticket whose history this object represents. =head2 entries Returns an arrayref of Ls. =cut has connection => ( isa => 'Net::Trac::Connection', is => 'ro' ); has ticket => ( isa => 'Net::Trac::Ticket', is => 'rw', weak_ref => 1); has entries => ( isa => 'ArrayRef', is => 'rw' ); =head1 METHODS =head2 load ID Loads the history of the specified ticket. =cut sub load { my $self = shift; my ($ticket_obj) = validate_pos( @_, 1); $self->ticket( $ticket_obj ); # Clone the ticket state so we can morph it backwards to reverse engineer # keywords my $temp_state = { %{ $ticket_obj->state()}}; my $feed_content = $self->connection->_fetch( "/ticket/@{[$ticket_obj->id]}?format=rss" ) or return; my $entries = ''; if ($feed_content =~ m|^(?:.*?)(.*)(?:.*?)$|is) { $entries = $1; } my @entries = split(m|\s*|, $entries); my @history; # Work on the newest entry first so we can back-calculate from the current state foreach my $entry (reverse @entries) { my $e = Net::Trac::TicketHistoryEntry->new({ connection => $self->connection, ticket => $self->ticket }); $e->parse_feed_entry($entry, $temp_state); # newest entry should be at the front of the list in the history later unshift @history, $e; } # trac doesn't have a history entry for ticket creation. Let's fake one up my $creation =Net::Trac::TicketHistoryEntry->new({connection => $self->connection}); # Reporter can change. really, we should work backwards through the whole history # to get the first version $creation->ticket($self->ticket); $creation->is_create(1); $creation->author($self->ticket->reporter); $creation->date($self->ticket->created); $creation->content('Ticket created'); $creation->category('Ticket'); unshift @history, $creation; $self->entries( \@history ); return 1; } =head1 LICENSE Copyright 2008-2009 Best Practical Solutions. This package is licensed under the same terms as Perl 5.8.8. =cut __PACKAGE__->meta->make_immutable; no Any::Moose; 1; Net-Trac-0.16/lib/Net/Trac/TicketHistoryEntry.pm0000644000175000017500000001421511222162566020437 0ustar spangspanguse strict; use warnings; package Net::Trac::TicketHistoryEntry; use Any::Moose; use Net::Trac::TicketPropChange; use DateTime; use HTTP::Date; use URI::Escape qw(uri_escape); =head1 NAME Net::Trac::TicketHistoryEntry - A single history entry for a Trac ticket =head1 DESCRIPTION This class represents a single item in a Trac ticket history. =head1 ACCESSORS =head2 connection Returns a L. =head2 author =head2 date Returns a L object. =head2 category =head2 content =head2 prop_changes Returns a hashref (property names as the keys) of Ls associated with this history entry. =head2 attachment if there's attachment, return it, else, return undef =head2 ticket A weak reference to the ticket object for this ticket history entry =head2 is_create A boolean. Returns true if this is the transaction which created the ticket =cut has connection => ( isa => 'Net::Trac::Connection', is => 'ro' ); has prop_changes => ( isa => 'HashRef', is => 'rw' ); has is_create => ( isa => 'Bool', is => 'rw', default => 0 ); has author => ( isa => 'Str', is => 'rw' ); has date => ( isa => 'DateTime', is => 'rw' ); has category => ( isa => 'Str', is => 'rw' ); has content => ( isa => 'Str', is => 'rw' ); has attachment => ( isa => 'Net::Trac::TicketAttachment', is => 'rw' ); has ticket => ( isa => 'Net::Trac::Ticket', is => 'rw', weak_ref => 1 ); =head1 METHODS =head2 parse_feed_entry Takes a feed entry from a ticket history feed and parses it to fill out the fields of this class. =cut sub parse_feed_entry { my $self = shift; my $e = shift; # We use a reference to a copy of ticket state as it was after this feed # entry to interpret what "x added, y removed" meant for absolute values # of keywords my $ticket_state = shift; if ( $e =~ m|(.*?)|is ) { my $author = $1; $self->author($author); } if ( $e =~ m|(.*?)|is ) { my $date = $1; $self->date( DateTime->from_epoch( epoch => str2time($date) ) ); } if ( $e =~ m|(.*?)|is ) { my $c = $1; $self->category($c); } if ( $e =~ m|\s*(.*?)\s*|is ) { my $desc = $1; if ( $desc =~ s|^\s*?<ul>(.*?)</ul>||is ) { my $props = $1; $self->prop_changes( $self->_parse_props( $props, $ticket_state ) ); } $desc =~ s/>/>/gi; $desc =~ s/</content($desc); } } sub _parse_props { my $self = shift; my $raw = shift || ''; my $ticket_state = shift; $raw =~ s/>/>/gi; $raw =~ s/</ $raw =~ s|^\s*?
  • (.*)
    • \s*?$|$1|is; my @prop_lines = split( m#\s*
  • #s, $raw ); my $props = {}; foreach my $line (@prop_lines) { my ( $prop, $old, $new ); if ( $line =~ m{attachment} ) { my ($name) = $line =~ m!(.*?)!; my $content = $self->connection->_fetch( "/attachment/ticket/" . $self->ticket->id . '/' . uri_escape($name) ) or next; if ( $content =~ m{
    (.+?)
    }is ) { my $frag = $1; my $att = Net::Trac::TicketAttachment->new( connection => $self->connection, ticket => $self->ticket->id, filename => $name, ); $att->_parse_html_chunk($frag); $self->attachment($att); } next; } if ( $line =~ m{description} ) { # We can't parse trac's crazy "go read a diff on a webpage handling # of descriptions next; } if ( $line =~ m{(keywords|cc)(.*)$}is ) { my $value_changes = $2; $prop = $1; my ( @added, @removed ); if ( $value_changes =~ m{^\s*(.*?) added}is ) { my $added = $1; @added = split( m{    \s*}is, $added ); } if ( $value_changes =~ m{(?:^|added;)\s*(.*) removed}is ) { my $removed = $1; @removed = split( m{\s*?}is, $removed ); } my @before = (); my @after = grep defined && length, split( /\s+/, $ticket_state->{keywords} ); for my $value (@after) { next if grep { $_ eq $value } @added; push @before, $value; } $old = join( ' ', sort ( @before, @removed ) ); $new = join( ' ', sort (@after) ); $ticket_state->{$prop} = $old; } elsif ( $line =~ m{(.*?)\s+changed\s+from\s+(.*?)\s+to\s+(.*?)}is ) { $prop = $1; $old = $2; $new = $3; } elsif ( $line =~ m{(.*?)\s+set\s+to\s+(.*?)}is ) { $prop = $1; $old = ''; $new = $2; } elsif ( $line =~ m{(.*?)\s+(.*?)\s+deleted}is ) { $prop = $1; $old = $2; $new = ''; } elsif ( $line =~ m{(.*?)\s+deleted}is ) { $prop = $1; $new = ''; } else { warn "could not parse " . $line; } if ($prop) { my $pc = Net::Trac::TicketPropChange->new( property => $prop, new_value => $new, old_value => $old ); $props->{$prop} = $pc; } else { warn "I found no prop in $line"; } } return $props; } =head1 LICENSE Copyright 2008-2009 Best Practical Solutions. This package is licensed under the same terms as Perl 5.8.8. =cut __PACKAGE__->meta->make_immutable; no Any::Moose; 1; Net-Trac-0.16/lib/Net/Trac.pm0000644000175000017500000000360511545655467014630 0ustar spangspangpackage Net::Trac; use Any::Moose; our $VERSION = '0.16'; use Net::Trac::Connection; use Net::Trac::Ticket; use Net::Trac::TicketHistory; use Net::Trac::TicketAttachment; use Net::Trac::TicketSearch; =head1 NAME Net::Trac - Interact with a remote Trac instance =head1 SYNOPSIS use Net::Trac; my $trac = Net::Trac::Connection->new( url => 'http://trac.someproject.org', user => 'hiro', password => 'yatta' ); my $ticket = Net::Trac::Ticket->new( connection => $trac ); my $id = $ticket->create(summary => 'This product has only a moose, not a pony'); my $other_ticket = Net::Trac::Ticket->new( connection => $trac ); $other_ticket->load($id); print $other_ticket->summary, "\n"; $ticket->update( summary => 'This project has no pony' ); =head1 DESCRIPTION Net::Trac is simple client library for a remote Trac instance. Because Trac doesn't provide a web services API, this module currently "fakes" an RPC interface around Trac's webforms and the feeds it exports. Because of this, it's somewhat more brittle than a true RPC client would be. As of now, this module has been tested against Trac 10.4 and Trac 11.0. The author's needs for this module are somewhat modest and its current featureset reflects this. Right now, only basic read/write functionality for Trac's tickets is provided. Patches would be gratefully appreciated. =head1 BUGS This module currently only deals with Trac's bug tracking system. This module is woefully incomplete. This module's error handling isn't what it should be. There are more. Please send bug reports and patches to bug-net-trac@rt.cpan.org =head1 AUTHOR Jesse Vincent , Thomas Sibley =head1 LICENSE Copyright 2008-2009 Best Practical Solutions. This package is licensed under the same terms as Perl 5.8.8. =cut 'This is the end of the file'; Net-Trac-0.16/inc/0000755000175000017500000000000011545655535012646 5ustar spangspangNet-Trac-0.16/inc/Module/0000755000175000017500000000000011545655535014073 5ustar spangspangNet-Trac-0.16/inc/Module/AutoInstall.pm0000644000175000017500000005423111545655534016674 0ustar spangspang#line 1 package Module::AutoInstall; use strict; use Cwd (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.03'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps ); my ( $PostambleActions, $PostambleUsed ); # 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 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 =~ /^--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::cwd(); $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; 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 combatability 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 = _load($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 _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; print "*** Dependencies will be installed the next time you type '$Config::Config{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 @_; 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 ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } 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( _load($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"; } } 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$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } 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 = $args{force} ? CPAN::Shell->force( install => $pkg ) : 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::cwd() ); 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( _load($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; # class/instance doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # 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)" ); 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; return <<"END_MAKE"; config :: installdeps \t\$(NOECHO) \$(NOOP) checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions END_MAKE } 1; __END__ #line 1071 Net-Trac-0.16/inc/Module/Install/0000755000175000017500000000000011545655535015501 5ustar spangspangNet-Trac-0.16/inc/Module/Install/Makefile.pm0000644000175000017500000002703211545655534017557 0ustar spangspang#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.00'; @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-seperated 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 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } 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.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # 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 $DB::single = 1; 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 541 Net-Trac-0.16/inc/Module/Install/AutoInstall.pm0000644000175000017500000000363211545655534020301 0ustar spangspang#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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 auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; Net-Trac-0.16/inc/Module/Install/Include.pm0000644000175000017500000000101511545655534017416 0ustar spangspang#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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; Net-Trac-0.16/inc/Module/Install/Metadata.pm0000644000175000017500000004302011545655534017555 0ustar spangspang#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } 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 reall 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' => '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<( \Qhttp://rt.cpan.org/\E[^>]+| \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| \Qhttp://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+([\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 hashs 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; Net-Trac-0.16/inc/Module/Install/Can.pm0000644000175000017500000000333311545655535016542 0ustar spangspang#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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 ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # 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 156 Net-Trac-0.16/inc/Module/Install/Base.pm0000644000175000017500000000214711545655534016714 0ustar spangspang#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.00'; } # 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 Net-Trac-0.16/inc/Module/Install/Win32.pm0000644000175000017500000000340311545655535016741 0ustar spangspang#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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; Net-Trac-0.16/inc/Module/Install/Fetch.pm0000644000175000017500000000462711545655535017101 0ustar spangspang#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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; Net-Trac-0.16/inc/Module/Install/WriteAll.pm0000644000175000017500000000237611545655535017572 0ustar spangspang#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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; Net-Trac-0.16/inc/Module/Install.pm0000644000175000017500000003013511545655534016040 0ustar spangspang#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.005; 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.00'; # 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::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); 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::cwd()) 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 //, $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]): $!"; 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]): $!"; 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]): $!"; 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]): $!"; 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($_[0]) <=> _version($_[1]); } # 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 - 2010 Adam Kennedy. Net-Trac-0.16/t/0000755000175000017500000000000011545655535012340 5ustar spangspangNet-Trac-0.16/t/search.t0000644000175000017500000000652711532354416013772 0ustar spangspanguse warnings; use strict; use Test::More; unless (`which trac-admin`) { plan skip_all => 'You need trac installed to run the tests'; } plan tests => 58; use_ok('Net::Trac::Connection'); use_ok('Net::Trac::TicketSearch'); require 't/setup_trac.pl'; my $tr = Net::Trac::TestHarness->new(); ok($tr->start_test_server(), "The server started!"); my $trac = Net::Trac::Connection->new( url => $tr->url, user => 'hiro', password => 'yatta' ); isa_ok( $trac, "Net::Trac::Connection" ); is($trac->url, $tr->url); my $ticket = Net::Trac::Ticket->new( connection => $trac ); isa_ok($ticket, 'Net::Trac::Ticket'); # Ticket 1 can_ok($ticket => 'create'); ok($ticket->create(summary => 'Summary #1')); can_ok($ticket, 'load'); ok($ticket->load(1)); like($ticket->state->{'summary'}, qr/Summary #1/); like($ticket->summary, qr/Summary #1/, "The summary looks correct"); ok($ticket->update( status => 'closed' ), "Status = closed"); is($ticket->status, 'closed', "Set status"); # Ticket 2 can_ok($ticket => 'create'); ok($ticket->create(summary => 'Summary #2', description => 'Any::Moose?')); can_ok($ticket, 'load'); ok($ticket->load(2)); like($ticket->state->{'summary'}, qr/Summary #2/); like($ticket->summary, qr/Summary #2/, "The summary looks correct"); like($ticket->description, qr/Any::Moose/, "The description looks correct"); # Ticket 3 can_ok($ticket => 'create'); ok($ticket->create(summary => 'Summary moose #3', description => 'Any::Moose!')); can_ok($ticket, 'load'); ok($ticket->load(3)); like($ticket->state->{'summary'}, qr/Summary moose #3/); like($ticket->summary, qr/Summary moose #3/, "The summary looks correct"); like($ticket->description, qr/Any::Moose/, "The description looks correct"); my $search = Net::Trac::TicketSearch->new( connection => $trac ); isa_ok( $search, 'Net::Trac::TicketSearch' ); can_ok( $search => 'query' ); ok($search->query); is(@{$search->results}, 3, "Got two results"); isa_ok($search->results->[0], 'Net::Trac::Ticket'); isa_ok($search->results->[1], 'Net::Trac::Ticket'); isa_ok($search->results->[2], 'Net::Trac::Ticket'); is($search->results->[0]->summary, "Summary #1", "Got summary"); is($search->results->[1]->summary, "Summary #2", "Got summary"); is($search->results->[2]->summary, "Summary moose #3", "Got summary"); ok($search->query( id => 2 )); is(@{$search->results}, 1, "Got one result"); isa_ok($search->results->[0], 'Net::Trac::Ticket'); is($search->results->[0]->summary, "Summary #2", "Got summary"); ok($search->query( summary => { contains => '#1' } )); is(@{$search->results}, 1, "Got one result"); isa_ok($search->results->[0], 'Net::Trac::Ticket'); is($search->results->[0]->summary, "Summary #1", "Got summary"); ok($search->query( summary => { contains => ['moose', '#2'] } )); is(@{$search->results}, 2, "Got two tickets"); isa_ok($search->results->[0], 'Net::Trac::Ticket'); isa_ok($search->results->[1], 'Net::Trac::Ticket'); is($search->results->[0]->summary, "Summary #2", "Got ticket #2"); is($search->results->[1]->summary, "Summary moose #3", "Got ticket #3"); ok($search->query( status => ['new','reopened'] )); is(@{$search->results}, 2, "Got two results"); isa_ok($search->results->[0], 'Net::Trac::Ticket'); isa_ok($search->results->[1], 'Net::Trac::Ticket'); is($search->results->[0]->summary, "Summary #2", "Got ticket #2"); is($search->results->[1]->summary, "Summary moose #3", "Got ticket #3"); Net-Trac-0.16/t/99-pod.t0000644000175000017500000000020211207136756013532 0ustar spangspanguse Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Net-Trac-0.16/t/setup_trac.pl0000644000175000017500000000617711532354416015047 0ustar spangspang#!/usr/bin/perl package Net::Trac::TestHarness; use warnings; use strict; use Test::More; use File::Temp qw/tempdir/; use LWP::Simple qw/get/; use Time::HiRes qw/usleep/; #my $x = __PACKAGE__->new(); $x->start_test_server(); warn $x->url; sleep 999; sub new { my $class = shift; my $self = {}; bless $self, $class; return $self; } sub init_test_server { my $self = shift; $self->port( int( 60000 + rand(2000) ) ); $self->dir( tempdir( CLEANUP => 1 ) ); $self->init; if (@_) { open my $fh, '>>', File::Spec->catfile( $self->dir, 'trac', 'conf', 'trac.ini' ) or die $!; print $fh @_; } return 1; } sub start_test_server { my $self = shift; $self->init_test_server(@_); $self->daemonize; return $self->_did_server_start; } sub _did_server_start { my $self = shift; for ( 1 .. 200 ) { return 1 if eval { get( $self->url ) }; usleep 15000; } die "Server didn't start"; } sub port { my $self = shift; if (@_) { $self->{_port} = shift; } return $self->{_port}; } sub dir { my $self = shift; if (@_) { $self->{_dir} = shift; } return $self->{_dir}; } sub pid { my $self = shift; if (@_) { $self->{_pid} = shift; } return $self->{_pid}; } sub url { my $self = shift; if (@_) { $self->{_url} = shift; } return $self->{_url}; } sub init { my $self = shift; my $dir = $self->dir; my $port = $self->port; open( my $sys, "trac-admin $dir/trac initenv proj sqlite:db/trac.db svn ''|" ); my @content = <$sys>; my ($url) = grep { defined $_ } map { /Then point your browser to (.*)\./ ? $1 : undef } @content; close($sys); $url =~ s/8000/$port/; $self->url($url); $self->_grant_hiro(); } sub _grant_hiro { my $self = shift; my $dir = $self->dir; open (my $sysadm, "trac-admin $dir/trac permission add hiro TRAC_ADMIN|"); my @results = <$sysadm>; close ($sysadm); open(my $htpasswd, ">$dir/trac/conf/htpasswd") || die $!; # hiro / yatta print $htpasswd "hiro:trac:98aef54bbd280226ac74b6bc500ff70e\n"; close $htpasswd; }; sub kill_trac { my $self = shift; return unless $self->pid; kill 1, $self->pid; } sub daemonize { my $self = shift; my $dir = $self->dir; my $port = $self->port; my $old_dir = `pwd`; chomp $old_dir; chdir $dir."/trac"; open STDIN, '/dev/null' or die "Can't read /dev/null: $!"; open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!"; defined(my $pid = fork) or die "Can't fork: $!"; if ( $pid ) { $self->pid($pid); chdir($old_dir); return $pid; } else { open STDERR, '>&STDOUT' or die "Can't dup stdout: $!"; exec("tracd -p $port -a trac,$dir/trac/conf/htpasswd,trac $dir/trac") || die "Tracd"; } } sub DESTROY { my $self = shift; $self->kill_trac; } 1; Net-Trac-0.16/t/keywords.t0000644000175000017500000000574011207136756014374 0ustar spangspanguse warnings; use strict; use Test::More; unless (`which trac-admin`) { plan skip_all => 'You need trac installed to run the tests'; } plan tests => 39; use_ok('Net::Trac::Connection'); use_ok('Net::Trac::Ticket'); use_ok('Net::Trac::TicketSearch'); require 't/setup_trac.pl'; my $tr = Net::Trac::TestHarness->new(); ok($tr->start_test_server(), "The server started!"); my $trac = Net::Trac::Connection->new( url => $tr->url, user => 'hiro', password => 'yatta' ); isa_ok( $trac, "Net::Trac::Connection" ); is($trac->url, $tr->url); my $ticket = Net::Trac::Ticket->new( connection => $trac); isa_ok($ticket, 'Net::Trac::Ticket'); can_ok($ticket => '_fetch_new_ticket_metadata'); ok($ticket->_fetch_new_ticket_metadata); can_ok($ticket => 'create'); ok($ticket->create(summary => 'Summary #1')); can_ok($ticket, 'load'); ok($ticket->load(1)); like($ticket->state->{'summary'}, qr/Summary #1/); like($ticket->summary, qr/Summary #1/, "The summary looks correct"); can_ok($ticket => 'update'); ok($ticket->update( status => 'closed' ), "status = closed"); is(@{$ticket->history->entries}, 2, "Got 2 history entries."); is($ticket->status, 'closed', "Got updated status"); sleep(1); # I hate trac { ok($ticket->update( keywords => 'foo bar' ), "I set the keywords"); is(@{$ticket->history->entries}, 3, "Got 3 history entries."); my @entries = @{$ticket->history->entries}; my $keywords_change = pop @entries; my $prop_changes = $keywords_change->prop_changes; is_deeply ( [keys %$prop_changes], ['keywords']); my $pc = $prop_changes->{'keywords'}; is ($pc->old_value, ''); is ($pc->new_value, 'bar foo'); } sleep(1); { ok($ticket->update( keywords => 'foo bar baz' ), "I set the keywords"); is(@{$ticket->history->entries}, 4, "Got n history entries."); my @entries = @{$ticket->history->entries}; my $keywords_change = pop @entries; my $prop_changes = $keywords_change->prop_changes; is_deeply ( [keys %$prop_changes], ['keywords'] , "I found the keywords propchange"); my $pc = $prop_changes->{'keywords'}; is ($pc->old_value, 'bar foo'); is ($pc->new_value, 'bar baz foo'); } sleep(1); { ok($ticket->update( keywords => 'baz foo' ), "I set the keywords"); is(@{$ticket->history->entries}, 5, "Got n history entries."); my @entries = @{$ticket->history->entries}; my $keywords_change = pop @entries; my $prop_changes = $keywords_change->prop_changes; is_deeply ( [keys %$prop_changes], ['keywords']); my $pc = $prop_changes->{'keywords'}; is ($pc->old_value, 'bar baz foo'); is ($pc->new_value, 'baz foo'); } sleep(1); { #Trac thinks we change from "Baz foo" to "foo baz"; ok($ticket->update( keywords => 'foo baz' ), "I set the keywords"); is(@{$ticket->history->entries}, 6, "Got n history entries."); my @entries = @{$ticket->history->entries}; my $keywords_change = pop @entries; my $prop_changes = $keywords_change->prop_changes; is_deeply ( [keys %$prop_changes], ['keywords']); my $pc = $prop_changes->{'keywords'}; is ($pc->old_value, 'baz foo'); is ($pc->new_value, 'baz foo'); } Net-Trac-0.16/t/99-pod-coverage.t0000644000175000017500000000133011207136756015326 0ustar spangspanguse Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; plan skip_all => "Coverage tests only run for authors" unless ( -d 'inc/.author' ); #plan skip_all => "We know our coverage is bad :("; all_pod_coverage_ok({ also_private => [qr/^BUILD$/], trustme => [qr/^(?:time|changetime)$/], }); # Workaround for dumb bug (fixed in 5.8.7) where Test::Builder thinks that # certain "die"s that happen inside evals are not actually inside evals, # because caller() is broken if you turn on $^P like Module::Refresh does # # (I mean, if we've gotten to this line, then clearly the test didn't die, no?) Test::Builder->new->{Test_Died} = 0; Net-Trac-0.16/t/10-ticket-cf.t0000644000175000017500000000205311532354416014602 0ustar spangspanguse warnings; use strict; use Test::More; use File::Spec; unless (`which trac-admin`) { plan skip_all => 'You need trac installed to run the tests'; } plan tests => 11; use_ok('Net::Trac::Connection'); use_ok('Net::Trac::Ticket'); Net::Trac::Ticket->add_custom_props( 'foo', 'bar' ); require 't/setup_trac.pl'; my $tr = Net::Trac::TestHarness->new(); my $cf_conf = <start_test_server($cf_conf), "The server started!"); my $trac = Net::Trac::Connection->new( url => $tr->url, user => 'hiro', password => 'yatta' ); isa_ok( $trac, "Net::Trac::Connection" ); is($trac->url, $tr->url); my $ticket = Net::Trac::Ticket->new( connection => $trac); ok( $ticket->create( summary => 'test cf fields', foo => 'foo_foo', bar => 'bar_bar', ) ); can_ok($ticket, 'load'); ok($ticket->load(1)); ok($ticket->history, "The ticket has some history"); is($ticket->foo, 'foo_foo', "The ticket has cf foo"); is($ticket->bar, 'bar_bar', "The ticket has cf bar"); Net-Trac-0.16/t/comments.t0000644000175000017500000000362511207136756014352 0ustar spangspanguse warnings; use strict; use Test::More; unless (`which trac-admin`) { plan skip_all => 'You need trac installed to run the tests'; } plan tests => 28; use_ok('Net::Trac::Connection'); use_ok('Net::Trac::Ticket'); require 't/setup_trac.pl'; my $tr = Net::Trac::TestHarness->new(); ok($tr->start_test_server(), "The server started!"); my $trac = Net::Trac::Connection->new( url => $tr->url, user => 'hiro', password => 'yatta' ); isa_ok( $trac, "Net::Trac::Connection" ); is($trac->url, $tr->url); my $ticket = Net::Trac::Ticket->new( connection => $trac); isa_ok($ticket, 'Net::Trac::Ticket'); can_ok($ticket => '_fetch_new_ticket_metadata'); ok($ticket->_fetch_new_ticket_metadata); can_ok($ticket => 'create'); ok($ticket->create(summary => 'Summary #1')); can_ok($ticket, 'load'); ok($ticket->load(1)); like($ticket->state->{'summary'}, qr/Summary #1/); like($ticket->summary, qr/Summary #1/, "The summary looks correct"); can_ok($ticket => 'update'); ok($ticket->update( comment => 'I like moose.' ), "Creating comment about moose."); is(@{$ticket->history->entries}, 2, "Got 2 history entries."); like($ticket->history->entries->[1]->content, qr/I like moose./, "The comment looks correct."); can_ok($ticket => 'comment'); sleep(1); # trac can't accept two updates within 1 second on the same ticket. ok($ticket->comment( 'I like fish.' ), "Creating comment about fish."); can_ok( $ticket => 'comments' ); is(@{$ticket->comments}, 2, "Got two comments."); like($ticket->comments->[1]->content, qr/fish/, "The comment looks correct."); like($ticket->comments->[0]->content, qr/moose/, "The previous comment looks correct."); sleep(1); ok($ticket->update( summary => 'Summary #1 updated' ), "Updating summary."); like($ticket->summary, qr/Summary #1 updated/, "The summary looks correct"); is(@{$ticket->history->entries}, 4, "Got 4 history entries"); is(@{$ticket->comments}, 2, "Only two comments"); Net-Trac-0.16/t/50-full-api.t0000644000175000017500000000327311207136756014457 0ustar spangspanguse Test::More; unless (`which trac-admin`) { plan skip_all => 'You need trac installed to run the tests'; } plan tests => 25; use_ok('Net::Trac::Connection'); use_ok('Net::Trac::Ticket'); require 't/setup_trac.pl'; my $tr = Net::Trac::TestHarness->new(); ok($tr->start_test_server(), "The server started!"); my $trac = Net::Trac::Connection->new( url => $tr->url, user => 'hiro', password => 'yatta' ); isa_ok( $trac, "Net::Trac::Connection" ); is($trac->url, $tr->url); my $ticket = Net::Trac::Ticket->new( connection => $trac); isa_ok($ticket, 'Net::Trac::Ticket'); can_ok($ticket => '_fetch_new_ticket_metadata'); ok($ticket->_fetch_new_ticket_metadata); can_ok($ticket => 'create'); ok($ticket->create(summary => 'This product has only a moose, not a pony')); is($ticket->id, 1); can_ok($ticket, 'load'); ok($ticket->load(1)); like($ticket->state->{'summary'}, qr/pony/); like($ticket->summary, qr/pony/, "The summary looks like a pony"); like($ticket->summary, qr/moose/, "The summary looks like a moose"); ok( $ticket->update( summary => 'The product does not contain a pony', description => "This\nis\nmultiline" ), "updated!"); like($ticket->summary, qr/pony/, "The summary looks like a pony"); unlike($ticket->summary, qr/moose/, "The summary does not look like a moose"); like($ticket->description, qr/This/); like($ticket->description, qr/multiline/); my $history = $ticket->history; ok($history, "The ticket has some history"); isa_ok($history, 'Net::Trac::TicketHistory'); can_ok($history, 'entries'); my @entries = @{$history->entries}; my $first = shift @entries; is ($first->category, 'Ticket'); Net-Trac-0.16/t/01-dependencies.t0000644000175000017500000000376311207136756015374 0ustar spangspang#!/usr/bin/env perl use warnings; use strict; =head1 DESCRIPTION Makes sure that all of the modules that are 'use'd are listed in the Makefile.PL as dependencies. =cut use Test::More; use File::Find; eval 'use Module::CoreList'; if ($@) { plan skip_all => 'Module::CoreList not installed' } plan 'no_plan'; my %used; find( \&wanted, qw/ lib t / ); sub wanted { return unless -f $_; return if $File::Find::dir =~ m!/.svn($|/)!; return if $File::Find::name =~ /~$/; return if $File::Find::name =~ /\.(pod|html)$/; # read in the file from disk my $filename = $_; local $/; open( FILE, $filename ) or return; my $data = ; close(FILE); # strip pod, in a really idiotic way. Good enough though $data =~ s/^=head.+?(^=cut|\Z)//gms; # look for use and use base statements $used{$1}{$File::Find::name}++ while $data =~ /^\s*use\s+([\w:]+)/gm; while ( $data =~ m|^\s*use base qw.([\w\s:]+)|gm ) { $used{$_}{$File::Find::name}++ for split ' ', $1; } } my %required; { local $/; ok( open( MAKEFILE, "Makefile.PL" ), "Opened Makefile" ); my $data = ; close(FILE); while ( $data =~ /^\s*?(?:requires|recommends|).*?([\w:]+)'(?:\s*=>\s*['"]?([\d\.]+)['"]?)?.*?(?:#(.*))?$/gm ) { $required{$1} = $2; if ( defined $3 and length $3 ) { $required{$_} = undef for split ' ', $3; } } } for ( sort keys %used ) { my $first_in = Module::CoreList->first_release($_); next if defined $first_in and $first_in <= 5.00803; next if /^(Net::Trac|inc|t)(::|$)/; #warn $_; ok( exists $required{$_}, "$_ in Makefile.PL" ) or diag( "used in ", join ", ", sort keys %{ $used{$_} } ); delete $used{$_}; delete $required{$_}; } for ( sort keys %required ) { my $first_in = Module::CoreList->first_release( $_, $required{$_} ); fail("Required module $_ (v. $required{$_}) is in core since $first_in") if defined $first_in and $first_in <= 5.008003; } 1; Net-Trac-0.16/t/attachments.t0000644000175000017500000000423311213667515015033 0ustar spangspanguse warnings; use strict; use Test::More; unless (`which trac-admin`) { plan skip_all => 'You need trac installed to run the tests'; } plan tests => 30; use_ok('Net::Trac::Connection'); use_ok('Net::Trac::Ticket'); require 't/setup_trac.pl'; use File::Temp qw(tempfile); my $tr = Net::Trac::TestHarness->new(); ok($tr->start_test_server(), "The server started!"); my $trac = Net::Trac::Connection->new( url => $tr->url, user => 'hiro', password => 'yatta' ); isa_ok( $trac, "Net::Trac::Connection" ); is($trac->url, $tr->url); my $ticket = Net::Trac::Ticket->new( connection => $trac); isa_ok($ticket, 'Net::Trac::Ticket'); can_ok($ticket => '_fetch_new_ticket_metadata'); ok($ticket->_fetch_new_ticket_metadata); can_ok($ticket => 'create'); ok($ticket->create(summary => 'Summary #1')); can_ok($ticket, 'load'); ok($ticket->load(1)); like($ticket->state->{'summary'}, qr/Summary #1/); like($ticket->summary, qr/Summary #1/, "The summary looks correct"); can_ok($ticket => 'update'); ok($ticket->update( comment => 'I like moose.' ), "Creating comment about moose."); is(@{$ticket->history->entries}, 2, "Got 2 history entries."); like($ticket->history->entries->[1]->content, qr/I like moose./, "The comment looks correct."); my ($fh, $filename) = tempfile(SUFFIX => '.txt'); my $alpha = join '', 'A'..'Z'; print $fh "$alpha\n"; # 27 bytes close $fh; ok(-e $filename, "temp file exists: $filename"); ok(-s $filename, "temp file has non-zero size"); can_ok($ticket => 'attach'); ok($ticket->attach( file => $filename, description => 'Test description' ), "Attaching file."); is(@{$ticket->history->entries}, 3, "Got 3 history entries."); is(@{$ticket->attachments}, 1, "Got one attachment"); is($ticket->attachments->[-1]->size, 27, "Got right size!"); is($ticket->attachments->[-1]->author, 'hiro', "Got right author!"); like($filename, qr/\E@{[$ticket->attachments->[-1]->filename]}\E/, "Got right filename!"); is($ticket->attachments->[-1]->description, 'Test description', "Got right description!"); is($ticket->attachments->[-1]->content, "$alpha\n", "Got right content!"); is($ticket->attachments->[-1]->content_type, "text/plain", "Got right content type!"); Net-Trac-0.16/t/02-create.t0000644000175000017500000000212011207136756014174 0ustar spangspanguse warnings; use strict; use Test::More; unless (`which trac-admin`) { plan skip_all => 'You need trac installed to run the tests'; } plan tests => 16; use_ok('Net::Trac::Connection'); use_ok('Net::Trac::Ticket'); require 't/setup_trac.pl'; my $tr = Net::Trac::TestHarness->new(); ok($tr->start_test_server(), "The server started!"); my $trac = Net::Trac::Connection->new( url => $tr->url, user => 'hiro', password => 'yatta' ); isa_ok( $trac, "Net::Trac::Connection" ); is($trac->url, $tr->url); my $ticket = Net::Trac::Ticket->new( connection => $trac); isa_ok($ticket, 'Net::Trac::Ticket'); can_ok($ticket => '_fetch_new_ticket_metadata'); ok($ticket->_fetch_new_ticket_metadata); can_ok($ticket => 'create'); ok($ticket->create(summary => 'This product has only a moose, not a pony')); can_ok($ticket, 'load'); ok($ticket->load(1)); like($ticket->state->{'summary'}, qr/pony/); like($ticket->summary, qr/pony/, "The summary looks like a pony"); ok($ticket->history, "The ticket has some history"); ok($ticket->time, "The ticket has a created time: ".$ticket->time); Net-Trac-0.16/t/parse_props.t0000644000175000017500000000110311207136756015047 0ustar spangspanguse Test::More tests => 3; my $props = <<'EOF'; owner changed from somebody to jrv.
  • status changed from new to assigned.
  • type changed from defect to enhancement.
    • EOF use_ok('Net::Trac::TicketHistoryEntry'); my $e = Net::Trac::TicketHistoryEntry->new(); my $prop_data = $e->_parse_props($props); is(scalar keys %$prop_data, 3, "Four properties"); my @keys = sort (qw(owner status type)); is_deeply([sort keys %$prop_data], [sort @keys]); Net-Trac-0.16/t/update.t0000644000175000017500000000402211532354416013773 0ustar spangspanguse warnings; use strict; use Test::More; unless (`which trac-admin`) { plan skip_all => 'You need trac installed to run the tests'; } plan tests => 32; use_ok('Net::Trac::Connection'); use_ok('Net::Trac::Ticket'); use_ok('Net::Trac::TicketSearch'); require 't/setup_trac.pl'; my $tr = Net::Trac::TestHarness->new(); ok($tr->start_test_server(), "The server started!"); my $trac = Net::Trac::Connection->new( url => $tr->url, user => 'hiro', password => 'yatta' ); isa_ok( $trac, "Net::Trac::Connection" ); is($trac->url, $tr->url); my $ticket = Net::Trac::Ticket->new( connection => $trac); isa_ok($ticket, 'Net::Trac::Ticket'); can_ok($ticket => '_fetch_new_ticket_metadata'); ok($ticket->_fetch_new_ticket_metadata); can_ok($ticket => 'create'); ok($ticket->create(summary => 'Summary #1')); can_ok($ticket, 'load'); ok($ticket->load(1)); like($ticket->state->{'summary'}, qr/Summary #1/); like($ticket->summary, qr/Summary #1/, "The summary looks correct"); can_ok($ticket => 'update'); ok($ticket->update( status => 'closed' ), "status = closed"); is(@{$ticket->history->entries}, 2, "Got 2 history entries."); is($ticket->status, 'closed', "Got updated status"); my $search = Net::Trac::TicketSearch->new( connection => $trac ); isa_ok( $search, 'Net::Trac::TicketSearch' ); can_ok( $search => 'query' ); ok($search->query( id => 1 )); is(@{$search->results}, 1, "Got one result"); isa_ok($search->results->[0], 'Net::Trac::Ticket'); is($search->results->[0]->id, 1, "Got id"); is($search->results->[0]->status, 'closed', "Got status"); sleep(1); # trac can't have two updates within one second ok($ticket->update( status => 'reopened' ), "status = reopened"); is(@{$ticket->history->entries}, 3, "Got 3 history entries"); is($ticket->status, 'reopened', "Got updated status"); sleep(1); # trac can't have two updates within one second ok($ticket->update( resolution => 'fixed' ), "resolution = fixed"); is(@{$ticket->history->entries}, 4, "Got 3 history entries"); is($ticket->resolution, 'fixed', "Got updated resolution"); Net-Trac-0.16/MANIFEST.SKIP0000644000175000017500000000012011231573100013737 0ustar spangspangTODO ^Makefile$ blib pm_to_blib .swp$ ~$ .tmp$ .bak$ .git/ .gitignore$ .shipit$