@@ -0,0 +1,46 @@
+use 5.008;
+use strict;
+use warnings;
+use Module::Build;
+
+my $class = Module::Build->subclass(
+ class => 'My::Builder',
+ code => q{
+ sub ACTION_authortest {
+ my ($self) = @_;
+ $self->test_files( qw< xt > );
+ $self->recursive_test_files(1);
+ $self->depends_on('test');
+ return;
+ }
+ sub ACTION_distdir {
+ my ($self) = @_;
+ $self->depends_on('authortest');
+ return $self->SUPER::ACTION_distdir();
+ }
+ }
+);
+
+my $builder = $class->new(
+ module_name => 'TheSchwartz',
+ license => 'perl',
+ dist_author => 'Six Apart <cpan@sixapart.com>',
+ dist_version_from => 'lib/TheSchwartz.pm',
+ configure_requires => { 'Module::Build' => 0 },
+ build_requires => {
+ 'Module::Build' => 0,
+ 'Test::More' => 0,
+ 'Data::ObjectDriver' => 0.04,
+ 'Digest::MD5' => 0,
+ 'Storable' => 0,
+ },
+ requires => {
+ 'Data::ObjectDriver' => 0.04,
+ 'Digest::MD5' => 0,
+ 'Storable' => 0,
+ },
+ add_to_cleanup => [ 'TheSchwartz-*', 'tmp', 'blib', '*.bak', 'META.*' ],
+ script_files => ['bin/schwartzmon'],
+);
+
+$builder->create_build_script();
@@ -1,33 +1,49 @@
+1.11 Mon Nov 03 2014
+- Move from Make to Module::Build
+- Remove inc & autobuild
+- Add perltidyrc and run over all perl files.
+- Add perlcritic test & fix errors
+- Add Test::Spelling and fix all spelling errors in POD. RT #89165
+- Reorder jobs when prioritize is set. RT #99075
+- Fix wrong return precedence. RT #87222
+- Fix get_server_time for Oracle. # RT #58049
+- Support Data::ObjectDriver->get_dbh. RT #50022
+- Use sort by jobid on selects. RT #34843
+- Added floor methods to limit priortity job selection. RT #50842
+- Add batch_size methods to expose FIND_JOB_BATCH_SIZE. RT #72815
+- Add run_after param to decline. RT #60797
+- Add jobid param to list_jobs.
+
1.10 (2010-03-15)
- - Add $job->declined method for workers to be able to decline handling
- a job at this time.
- - Added $client->grab_and_work_on($handle) to securely work on a job
- you know the handle of. Yann Kerherve (yannk@cpan.org)
- - Fixed docs and tests (miyagawa, athomason, simonw)
+- Add $job->declined method for workers to be able to decline handling
+ a job at this time.
+- Added $client->grab_and_work_on($handle) to securely work on a job
+ you know the handle of. Yann Kerherve (yannk@cpan.org)
+- Fixed docs and tests (miyagawa, athomason, simonw)
1.07 (2008-07-31)
- - bchoate: Updates to support optional prioritization of jobs.
- - ykerherve: Croak with a nice message id a driver cannot be
- found for a handle
+- bchoate: Updates to support optional prioritization of jobs.
+- ykerherve: Croak with a nice message id a driver cannot be
+ found for a handle
1.06 (2007-09-07)
- - Code to allow a 'top' like view of runnin schwartz workers.
- - include postgres schema in docs. from Michael Zedeler
- <michael@zedeler.dk> Currently not tested in regression
- tests, though, so not "officially" supported yet.
- - start of work on gearman-based schwartz server.
+- Code to allow a 'top' like view of runnin schwartz workers.
+- include postgres schema in docs. from Michael Zedeler
+ <michael@zedeler.dk> Currently not tested in regression
+ tests, though, so not "officially" supported yet.
+- start of work on gearman-based schwartz server.
1.05
- - Set TheSchwartz::Job::insert_time to current server time when
- inserting a new job.
+- Set TheSchwartz::Job::insert_time to current server time when
+ inserting a new job.
1.04 (2007-05-22)
- - no code changes, just packaging/dep/test fixes, as pointed out
- by Dan Rench <drench@dren.ch>
+- no code changes, just packaging/dep/test fixes, as pointed out
+ by Dan Rench <drench@dren.ch>
1.03
- - first packaged release, now that all SixApart products have been
- using this heavily for quite some time. it's overdue.
+- first packaged release, now that all SixApart products have been
+ using this heavily for quite some time. it's overdue.
@@ -1,24 +1,13 @@
bin/schwartzmon
+Build.PL
CHANGES
doc/http-mappings.txt
doc/notes.txt
doc/schema-postgres.sql
doc/schema.sql
extras/check_schwartz
-extras/TheSchwartz.spec
+extras/perl-TheSchwartz.spec
extras/thetop
-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/Scripts.pm
-inc/Module/Install/Win32.pm
-inc/Module/Install/WriteAll.pm
lib/TheSchwartz.pm
lib/TheSchwartz/Error.pm
lib/TheSchwartz/ExitStatus.pm
@@ -26,10 +15,11 @@ lib/TheSchwartz/FuncMap.pm
lib/TheSchwartz/Job.pm
lib/TheSchwartz/JobHandle.pm
lib/TheSchwartz/Worker.pm
-Makefile.PL
MANIFEST This list of files
MANIFEST.SKIP
META.yml
+perltidyrc
+README.md
server/bin/schwartzd
server/doc/deps.txt
server/doc/protocol.txt
@@ -61,5 +51,7 @@ t/scoreboard.t
t/server-time.t
t/unique.t
t/work-before-funcids-exist.t
+xt/perlcritic.t
xt/pod-coverage.t
+xt/pod-spelling.t
xt/pod.t
@@ -11,6 +11,8 @@ svn-commit.tmp
\bCVS\b
,v$
\B\.svn\b
+\B\.git\b
+\B\.gitignore\b
# Avoid Makemaker generated and utility files.
\bMANIFEST\.bak
@@ -22,6 +24,8 @@ svn-commit.tmp
# Avoid Module::Build generated and utility files.
\bBuild$
\b_build/
+^Notes.md$
+\bTheSchwartz-[\d\.\_]+
# Avoid temp and backup files.
~$
@@ -29,3 +33,23 @@ svn-commit.tmp
\#$
\b\.#
\.git/
+\cover_db/
+^MYMETA.*$
+
+# Avoid Devel::Cover and Devel::CoverX::Covered files.
+\bcover_db\b
+\bcovered\b
+
+# Avoid temp and backup files.
+~$
+\.old$
+\#$
+\b\.#
+\.bak$
+\.tmp$
+\.#
+\.rej$
+\.swp$
+\.swo$
+
+
@@ -1,27 +1,41 @@
---
+abstract: 'reliable job queue'
author:
- 'Six Apart <cpan@sixapart.com>'
build_requires:
- ExtUtils::MakeMaker: 6.42
- Test::More: 0.88
+ Data::ObjectDriver: 0.04
+ Digest::MD5: 0
+ Module::Build: 0
+ Storable: 0
+ Test::More: 0
configure_requires:
- ExtUtils::MakeMaker: 6.42
-distribution_type: module
-generated_by: 'Module::Install version 0.95'
+ Module::Build: 0
+generated_by: 'Module::Build version 0.3624'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: TheSchwartz
-no_index:
- directory:
- - inc
- - t
- - xt
+provides:
+ TheSchwartz:
+ file: lib/TheSchwartz.pm
+ version: 1.11
+ TheSchwartz::Error:
+ file: lib/TheSchwartz/Error.pm
+ TheSchwartz::ExitStatus:
+ file: lib/TheSchwartz/ExitStatus.pm
+ TheSchwartz::FuncMap:
+ file: lib/TheSchwartz/FuncMap.pm
+ TheSchwartz::Job:
+ file: lib/TheSchwartz/Job.pm
+ TheSchwartz::JobHandle:
+ file: lib/TheSchwartz/JobHandle.pm
+ TheSchwartz::Worker:
+ file: lib/TheSchwartz/Worker.pm
requires:
Data::ObjectDriver: 0.04
Digest::MD5: 0
Storable: 0
resources:
license: http://dev.perl.org/licenses/
-version: 1.10
+version: 1.11
@@ -1,21 +0,0 @@
-# $Id$
-
-use 5.008;
-use inc::Module::Install;
-
-name('TheSchwartz');
-version_from('lib/TheSchwartz.pm');
-author('Six Apart <cpan@sixapart.com>');
-license('perl');
-build_requires 'Test::More', 0.88;
-
-requires('Data::ObjectDriver' => '0.04');
-requires('Digest::MD5');
-requires('Storable');
-
-tests( -e "inc/.author" ? "t/*.t xt/*.t" : "t/*.t" );
-
-install_script('bin/schwartzmon');
-
-auto_install();
-WriteAll();
@@ -0,0 +1,43 @@
+TheSchwartz
+=============
+
+**TheSchwartz** is a reliable job queue system. Your application can put jobs into the system, and your worker processes can pull jobs from the queue atomically to perform. Failed jobs can be left in the queue to retry later.
+
+**Abilities** specify what jobs a worker process can perform. Abilities are the names of *TheSchwartz::Worker* subclasses, as in the synopsis: the *MyWorker* class name is used to specify that the worker script can perform the job. When using the *TheSchwartz* client's *work* functions, the class-ability duality is used to automatically dispatch to the proper class to do the actual work.
+
+TheSchwartz clients will also prefer to do jobs for unused abilities before reusing a particular ability, to avoid exhausting the supply of one kind of job while jobs of other types stack up.
+
+Some jobs with high set-up times can be performed more efficiently if a group of related jobs are performed together. TheSchwartz offers a facility to **coalesce** jobs into groups, which a properly constructed worker can find and perform at once. For example, if your worker were delivering email, you might store the domain name from the recipient's address as the coalescing value. The worker that grabs that job could then batch deliver all the mail for that domain once it connects to that domain's mail server.
+
+INSTALLATION
+------------
+
+Just follow the usual procedure:
+
+ perl Build.PL
+ ./Build
+ ./Build test
+ ./Build install
+
+If you want to install a private copy of this module-suite in your home directory, then you should try to produce the initial Makefile with something like this command:
+
+ perl Build.PL PREFIX=~/perl
+
+See perldoc perlmodinstall for more information on installing modules.
+
+SUPPORT
+-------
+
+Just follow the usual procedure:
+
+ perl Build.PL
+ ./Build
+
+Questions, bug reports, useful code bits, and suggestions for this module should just be sent to JFEARN@cpan.org or open a ticket in the [CPAN RT](https://rt.cpan.org//Dist/Display.html?Queue=TheSchwartz)
+
+AVAILABILITY
+-------
+The latest version of this module is available from the Comprehensive Perl Archive Network (CPAN). Visit (http://www.perl.com/CPAN/) to find a CPAN site near you.
+
+The source is available on github (https://github.com/jfearn/TheSchwartz), patches should be sent as pull requests against this repository.
+
@@ -3,11 +3,11 @@ use strict;
use DBI;
use Getopt::Long;
-my $dbname = "schwartz";
-my $user = "root";
-my $pass = "";
-my $job = "";
-my $max_age = 0;
+my $dbname = "schwartz";
+my $user = "root";
+my $pass = "";
+my $job = "";
+my $max_age = 0;
my $max_count = 0;
=head1 NAME
@@ -60,20 +60,22 @@ USAGE
}
my $opt_help = 0;
-my ($opt_follow, $opt_last, $opt_inlast, $opt_func, $dsn);
-usage() unless GetOptions("job=s" => \$job,
- "maxage=i" => \$max_age,
- "maxcount=i" => \$max_count,
- "help" => \$opt_help,
- "follow|f" => \$opt_follow,
- "last=i" => \$opt_last,
- "inlast=i" => \$opt_inlast,
- "user=s" => \$user,
- "pass=s" => \$pass,
- "dsn=s" => \$dsn,
- "database=s" => \$dbname,
- "func=s" => \$opt_func,
- );
+my ( $opt_follow, $opt_last, $opt_inlast, $opt_func, $dsn );
+usage()
+ unless GetOptions(
+ "job=s" => \$job,
+ "maxage=i" => \$max_age,
+ "maxcount=i" => \$max_count,
+ "help" => \$opt_help,
+ "follow|f" => \$opt_follow,
+ "last=i" => \$opt_last,
+ "inlast=i" => \$opt_inlast,
+ "user=s" => \$user,
+ "pass=s" => \$pass,
+ "dsn=s" => \$dsn,
+ "database=s" => \$dbname,
+ "func=s" => \$opt_func,
+ );
usage() if $opt_help;
my $cmd = shift || "queues";
@@ -83,45 +85,54 @@ my $dbset = DBSet->new;
$dsn ||= "DBI:mysql:$dbname";
-$dbset->add(DBHandle->new({ dsn => $dsn, user => $user, pass => $pass}));
+$dbset->add( DBHandle->new( { dsn => $dsn, user => $user, pass => $pass } ) );
-if ($cmd eq "queues") { queues($dbset); }
-if ($cmd eq "errors") { errors($dbset); }
+if ( $cmd eq "queues" ) { queues($dbset); }
+if ( $cmd eq "errors" ) { errors($dbset); }
exit 0;
#################
sub queues {
- my $dbs = shift;
+ my $dbs = shift;
my $some_alert = 0;
- $dbs->foreach(sub {
- my $db = shift;
- my $dbh = $db->dbh or next;
-
- my $funcmap = $dbh->selectall_hashref("SELECT funcid, funcname FROM funcmap", "funcid");
-
- foreach my $funcid (sort { $funcmap->{$a}{funcname} cmp $funcmap->{$b}{funcname} } keys %$funcmap) {
- my $funcname = $funcmap->{$funcid}{funcname};
- next if $job && $funcname ne $job;
-
- my $now = time();
- my $inf = $dbh->selectrow_hashref("SELECT COUNT(*) as 'ct', MIN(run_after) 'oldest' FROM job WHERE funcid=? AND run_after <= $now",
- undef, $funcid);
- my $behind = $inf->{ct} ? ($now - $inf->{oldest}) : 0;
-
- # okay by default, then we apply rules:
- my $okay = 1;
- $okay = 0 if $behind > $max_age;
- $okay = 0 if $inf->{ct} > $max_count;
- next if $okay;
- $some_alert = 1;
-
- print "$funcname\n";
- print " outstanding: $inf->{ct}\n";
- print " behind_secs: $behind\n";
+ $dbs->foreach(
+ sub {
+ my $db = shift;
+ my $dbh = $db->dbh or next;
+
+ my $funcmap = $dbh->selectall_hashref(
+ "SELECT funcid, funcname FROM funcmap", "funcid" );
+
+ foreach my $funcid (
+ sort { $funcmap->{$a}{funcname} cmp $funcmap->{$b}{funcname} }
+ keys %$funcmap
+ )
+ {
+ my $funcname = $funcmap->{$funcid}{funcname};
+ next if $job && $funcname ne $job;
+
+ my $now = time();
+ my $inf = $dbh->selectrow_hashref(
+ "SELECT COUNT(*) as 'ct', MIN(run_after) 'oldest' FROM job WHERE funcid=? AND run_after <= $now",
+ undef, $funcid
+ );
+ my $behind = $inf->{ct} ? ( $now - $inf->{oldest} ) : 0;
+
+ # okay by default, then we apply rules:
+ my $okay = 1;
+ $okay = 0 if $behind > $max_age;
+ $okay = 0 if $inf->{ct} > $max_count;
+ next if $okay;
+ $some_alert = 1;
+
+ print "$funcname\n";
+ print " outstanding: $inf->{ct}\n";
+ print " behind_secs: $behind\n";
+ }
}
- });
- exit($some_alert ? 1 : 0);
+ );
+ exit( $some_alert ? 1 : 0 );
}
sub errors {
@@ -134,35 +145,39 @@ sub errors {
$opt_last = 100 unless $opt_last || $opt_inlast;
my @rows;
- $dbs->foreach(sub {
- my $db = shift;
- my $dbh = $db->dbh
- or next;
-
- my $extra_where = '';
- if ($opt_func) {
- my $funcid = $db->funcid_of_func($opt_func) || 0;
- $extra_where = "AND funcid=$funcid";
- }
+ $dbs->foreach(
+ sub {
+ my $db = shift;
+ my $dbh = $db->dbh
+ or next;
- my $sql;
- if ($opt_last) {
- $sql = "SELECT error_time, jobid, message FROM error WHERE 1=1 $extra_where " .
- "ORDER BY error_time DESC LIMIT $opt_last";
- } elsif ($opt_inlast) {
- my $since = time() - $opt_inlast;
- $sql = "SELECT error_time, jobid, message FROM error WHERE error_time >= $since $extra_where " .
- "ORDER BY error_time LIMIT 50000";
- }
+ my $extra_where = '';
+ if ($opt_func) {
+ my $funcid = $db->funcid_of_func($opt_func) || 0;
+ $extra_where = "AND funcid=$funcid";
+ }
+ my $sql;
+ if ($opt_last) {
+ $sql
+ = "SELECT error_time, jobid, message FROM error WHERE 1=1 $extra_where "
+ . "ORDER BY error_time DESC LIMIT $opt_last";
+ }
+ elsif ($opt_inlast) {
+ my $since = time() - $opt_inlast;
+ $sql
+ = "SELECT error_time, jobid, message FROM error WHERE error_time >= $since $extra_where "
+ . "ORDER BY error_time LIMIT 50000";
+ }
- my $sth = $dbh->prepare($sql);
- $sth->execute;
- push @rows, $_ while $_ = $sth->fetchrow_hashref;
- });
+ my $sth = $dbh->prepare($sql);
+ $sth->execute;
+ push @rows, $_ while $_ = $sth->fetchrow_hashref;
+ }
+ );
@rows = sort { $a->{error_time} <=> $b->{error_time} } @rows;
- if ($opt_last && @rows > $opt_last) {
+ if ( $opt_last && @rows > $opt_last ) {
shift @rows while @rows > $opt_last;
}
@@ -176,68 +191,74 @@ sub follow_errors {
my $dbs = shift;
while (1) {
- $dbs->foreach(sub {
- my $db = shift;
- my $dbh = $db->dbh
- or next;
- my $notes = $db->notes;
+ $dbs->foreach(
+ sub {
+ my $db = shift;
+ my $dbh = $db->dbh
+ or next;
+ my $notes = $db->notes;
+
+ my $lastmax = $notes->{lastmax} || time();
+ my $seen = $notes->{seen} ||= {};
+
+ my $extra_where = '';
+ if ($opt_func) {
+ my $funcid = $db->funcid_of_func($opt_func) || 0;
+ $extra_where = "AND funcid=$funcid";
+ }
+
+ my $sth
+ = $dbh->prepare(
+ "SELECT error_time, jobid, message FROM error WHERE error_time >= ? $extra_where ORDER BY error_time"
+ );
+ $sth->execute($lastmax);
+ my @errors;
+ push @errors, $_ while $_ = $sth->fetchrow_hashref;
+
+ my $newmax = $lastmax;
+ foreach my $r (@errors) {
+ my $sig = join( ",", map { $_, $r->{$_} } sort keys %$r );
+ next if $seen->{$sig};
+ $seen->{$sig} = $r->{error_time};
+ print_error($r);
+ $newmax = $r->{error_time} if $r->{error_time} > $newmax;
+ }
+
+ $notes->{lastmax} = $newmax;
+
+ foreach my $sig ( keys %$seen ) {
+ my $time = $seen->{$sig};
+ delete $seen->{$sig} if $time < $newmax;
+ }
- my $lastmax = $notes->{lastmax} || time();
- my $seen = $notes->{seen} ||= {};
-
- my $extra_where = '';
- if ($opt_func) {
- my $funcid = $db->funcid_of_func($opt_func) || 0;
- $extra_where = "AND funcid=$funcid";
}
-
- my $sth = $dbh->prepare("SELECT error_time, jobid, message FROM error WHERE error_time >= ? $extra_where ORDER BY error_time");
- $sth->execute($lastmax);
- my @errors;
- push @errors, $_ while $_ = $sth->fetchrow_hashref;
-
- my $newmax = $lastmax;
- foreach my $r (@errors) {
- my $sig = join(",", map { $_, $r->{$_} } sort keys %$r);
- next if $seen->{$sig};
- $seen->{$sig} = $r->{error_time};
- print_error($r);
- $newmax = $r->{error_time} if $r->{error_time} > $newmax;
- }
-
- $notes->{lastmax} = $newmax;
-
- foreach my $sig (keys %$seen) {
- my $time = $seen->{$sig};
- delete $seen->{$sig} if $time < $newmax;
- }
-
- });
+ );
sleep 1;
}
}
sub print_error {
- my $r = shift;
+ my $r = shift;
my $msg = $r->{message};
$msg =~ s/\s+$//g;
- printf scalar(localtime($r->{error_time})) . " [$r->{jobid}]: $msg\n";
+ printf scalar( localtime( $r->{error_time} ) ) . " [$r->{jobid}]: $msg\n";
}
-
package DBSet;
sub new {
- return bless [];
+ my ( $this, $args ) = @_;
+ my $class = ref($this) || $this;
+ return bless {}, $class;
}
sub add {
- my ($self, $db) = @_;
+ my ( $self, $db ) = @_;
push @$self, $db;
}
sub foreach {
- my ($self, $cb) = @_;
+ my ( $self, $cb ) = @_;
foreach my $dbh (@$self) {
$cb->($dbh);
}
@@ -246,7 +267,7 @@ sub foreach {
package DBHandle;
sub new {
- my ($class, $dbinf) = @_;
+ my ( $class, $dbinf ) = @_;
return bless $dbinf, $class;
}
@@ -258,23 +279,23 @@ sub notes {
# returns DBI handle
sub dbh {
my $self = shift;
- return $self->{_dbh} ||=
- DBI->connect($self->{dsn}, $self->{user}, $self->{pass})
+ return $self->{_dbh}
+ ||= DBI->connect( $self->{dsn}, $self->{user}, $self->{pass} )
}
sub funcid_of_func {
- my ($self, $func) = @_;
+ my ( $self, $func ) = @_;
my $notes = $self->notes;
return $notes->{"funcid_of_$func"} if exists $notes->{"funcid_of_$func"};
my $dbh = $self->dbh;
- return $notes->{"funcid_of_$func"} =
- $dbh->selectrow_array("SELECT funcid FROM funcmap WHERE funcname=?",
- undef, $func);
+ return $notes->{"funcid_of_$func"}
+ = $dbh->selectrow_array(
+ "SELECT funcid FROM funcmap WHERE funcname=?",
+ undef, $func );
}
-
=head1 COPYRIGHT, LICENSE & WARRANTY
This software is Copyright 2007, 2008 Six Apart Ltd, cpan@sixapart.com. All
@@ -283,7 +304,7 @@ rights reserved.
TheSchwartz is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.
-TheScwhartz comes with no warranty of any kind.
+TheSchwartz comes with no warranty of any kind.
=cut
@@ -1,34 +0,0 @@
-Name: perl-TheSchwartz
-Version: 0.01
-Release: 1
-Summary: Reliable distributed job system
-License: perl
-Group: Applications/Internet
-BuildRoot: %{_tmppath}/%name-%version-root
-AutoReqProv: no
-Packager: <cpan@sixapart.com>
-
-%description
-
-%prep
-
-%build
-rm -rf trunk
-svn export http://code.sixapart.com/svn/TheSchwartz/trunk
-cd trunk
-%{__perl} Makefile.PL PREFIX=%{buildroot}%{_prefix}
-make
-
-%install
-rm -rf %{buildroot}
-cd trunk
-make install
-rm -rf %{buildroot}/%{_prefix}/lib64
-
-%clean
-rm -rf %{buildroot}
-
-%files
-%{_bindir}/*
-%{_prefix}/lib/*
-#%{_mandir}/*
@@ -13,11 +13,11 @@ use constant QUEUE_CRITICAL => 100;
use constant QUEUE_WARNING => 30;
GetOptions(
- 'h|help!' => \my($help),
- 'v|verbose' => \my($verbose),
- 'dsn=s' => \my($dsn),
- 'user=s' => \my($user),
- 'password=s' => \my($pass),
+ 'h|help!' => \my ($help),
+ 'v|verbose' => \my ($verbose),
+ 'dsn=s' => \my ($dsn),
+ 'user=s' => \my ($user),
+ 'password=s' => \my ($pass),
);
if ($help) {
@@ -25,7 +25,7 @@ if ($help) {
exit $ERRORS{OK};
}
-unless ($dsn && $user) {
+unless ( $dsn && $user ) {
print <<USAGE;
You have to supply a database DSN and username.
@@ -37,28 +37,30 @@ USAGE
}
sub exit_with {
- my($code, $msg) = @_;
+ my ( $code, $msg ) = @_;
$msg = $msg ? ' - ' . $msg : '';
print "TheSchwartz $dsn $code$msg";
exit $ERRORS{$code};
}
-my $dbh = DBI->connect($dsn, $user, $pass)
+my $dbh = DBI->connect( $dsn, $user, $pass )
or exit_with 'CRITICAL', "Can't connect to $dsn: $DBI::errstr";
-my $inf = $dbh->selectrow_arrayref(<<SQL, undef, time);
+my $inf = $dbh->selectrow_arrayref( <<SQL, undef, time );
SELECT COUNT(*)
FROM job
WHERE run_after <= ?
SQL
-unless ($inf && defined $inf->[0]) {
+unless ( $inf && defined $inf->[0] ) {
exit_with 'CRITICAL', "Failed getting job count: " . $dbh->errstr;
}
-if ($inf->[0] < QUEUE_WARNING) {
+if ( $inf->[0] < QUEUE_WARNING ) {
exit_with 'OK';
-} elsif ($inf->[0] < QUEUE_CRITICAL) {
+}
+elsif ( $inf->[0] < QUEUE_CRITICAL ) {
exit_with 'WARNING', "Schwartz queue depth is $inf->[0]";
-} else {
+}
+else {
exit_with 'CRITICAL', "Schwartz queue depth is $inf->[0]";
}
@@ -0,0 +1,52 @@
+Name: perl-TheSchwartz
+Version: 1.11
+Release: 1%{?dist}
+Summary: Reliable job queue
+License: GPL+ or Artistic
+Group: Development/Libraries
+URL: http://search.cpan.org/dist/TheSchwartz/
+Source0: http://www.cpan.org/modules/by-module/TheSchwartz/TheSchwartz-%{version}.tar.gz
+BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)
+BuildArch: noarch
+BuildRequires: perl(Data::ObjectDriver) >= 0.04
+BuildRequires: perl(Module::Build)
+BuildRequires: perl(Test::More)
+BuildRequires: perl(DBD::SQLite)
+Requires: perl(Data::ObjectDriver) >= 0.04
+Requires: perl(:MODULE_COMPAT_%(eval "`%{__perl} -V:version`"; echo $version))
+
+%description
+TheSchwartz is a reliable job queue system. Your application can put jobs
+into the system, and your worker processes can pull jobs from the queue
+atomically to perform. Failed jobs can be left in the queue to retry later.
+
+%prep
+%setup -q -n TheSchwartz-%{version}
+
+%build
+%{__perl} Build.PL installdirs=site
+./Build
+
+%install
+rm -rf $RPM_BUILD_ROOT
+
+./Build install destdir=$RPM_BUILD_ROOT create_packlist=0
+find $RPM_BUILD_ROOT -depth -type d -exec rmdir {} 2>/dev/null \;
+
+%{_fixperms} $RPM_BUILD_ROOT/*
+
+find $RPM_BUILD_ROOT -type f -print | sed "s@^$RPM_BUILD_ROOT@@g" > filelist
+
+%check
+./Build test
+
+%clean
+rm -rf $RPM_BUILD_ROOT
+
+%files -f filelist
+%defattr(-,root,root,-)
+%doc CHANGES doc README.md
+
+%changelog
+* Mon Nov 03 2014 Jeff Fearn 1.11-1
+- Specfile autogenerated by cpanspec 1.79.
@@ -33,43 +33,45 @@ BEGIN {
my $termios = POSIX::Termios->new;
$termios->getattr;
$OSPEED = $termios->getospeed || 9600;
-};
+}
-our $TERM = Term::Cap->Tgetent({OSPEED=>$OSPEED});
+our $TERM = Term::Cap->Tgetent( { OSPEED => $OSPEED } );
#--------------------------------------#
# Main Program
-my ($score_dir, $delay, $func_col, @arg_col, $sort);
+my ( $score_dir, $delay, $func_col, @arg_col, $sort );
-GetOptions('score-dir=s' => \$score_dir,
- 'delay|d=s' => \$delay,
- 'func=s' => \$func_col,
- 'arg=s' => \@arg_col,
- 'sort|s=s' => \$sort,
- );
+GetOptions(
+ 'score-dir=s' => \$score_dir,
+ 'delay|d=s' => \$delay,
+ 'func=s' => \$func_col,
+ 'arg=s' => \@arg_col,
+ 'sort|s=s' => \$sort,
+);
# Make sure we know where to find the scoreboard files
unless ($score_dir) {
foreach my $d (qw(/var/run /dev/shm /tmp)) {
- if (-e "$d/theschwartz") {
+ if ( -e "$d/theschwartz" ) {
$score_dir = "$d/theschwartz";
last;
}
}
die "Can't find scoreboard directory. Use '--score-dir'\n"
- unless $score_dir;
+ unless $score_dir;
}
# If we got some formatting instructions for the arg column, parse it out
my %arg_col_by_func;
if (@arg_col) {
foreach my $a (@arg_col) {
- if ($a =~ /=/) {
- my ($func, $fmt) = split('=', $a);
+ if ( $a =~ /=/ ) {
+ my ( $func, $fmt ) = split( '=', $a );
$arg_col_by_func{$func} = $fmt;
- } else {
+ }
+ else {
$arg_col_by_func{'__ALL__'} = $a;
}
}
@@ -81,7 +83,7 @@ $delay ||= 3;
# Start reporting
clr_screen();
while (1) {
- report($score_dir, $func_col, \%arg_col_by_func, $sort);
+ report( $score_dir, $func_col, \%arg_col_by_func, $sort );
sleep($delay);
clr_screen();
}
@@ -89,85 +91,89 @@ while (1) {
################################################################################
sub report {
- my ($dir, $func_col, $arg_col_by_func, $sort) = @_;
+ my ( $dir, $func_col, $arg_col_by_func, $sort ) = @_;
# Find the files available
- opendir(SD, $dir) or die "Can't read directory '$dir': $!\n";
- my @files = map { $dir."/$_" } readdir(SD);
+ opendir( SD, $dir ) or die "Can't read directory '$dir': $!\n";
+ my @files = map { $dir . "/$_" } readdir(SD);
closedir(SD);
# Grab the data out of them
my @data;
foreach my $f (@files) {
next unless $f =~ /scoreboard\.[0-9]+$/;
- open(SF, '<', $f) or die "Can't open score file '$f': $!\n";
+ open( SF, '<', $f ) or die "Can't open score file '$f': $!\n";
my %dat = map { chomp; split('=') } <SF>;
close(SF);
- $dat{arg_array} = [split(',', $dat{arg}||'')];
+ $dat{arg_array} = [ split( ',', $dat{arg} || '' ) ];
push @data, \%dat;
}
- my $num = scalar(@data);
- my $width = 80-17-$num;
- printf("Workers: %d total %${width}s\n\n", $num, scalar localtime);
- printf("% 5s % 20s % 2s % 7s % 41s\n", 'PID', 'FUNC', 'S', 'TIME', 'ARGS');
- foreach my $d (sort { order_by($sort, $a, $b) } @data) {
- my $func_str = fmt_func($d, $func_col);
-
- printf("% 5s % 20s % 2s % 7s % 41s\n",
- $d->{pid},
- $func_str,
- ($d->{done} ? 'S' : 'R'),
- fmt_time($d),
- fmt_arg($d, $arg_col_by_func, $func_str),
- );
+ my $num = scalar(@data);
+ my $width = 80 - 17 - $num;
+ printf( "Workers: %d total %${width}s\n\n", $num, scalar localtime );
+ printf( "% 5s % 20s % 2s % 7s % 41s\n",
+ 'PID', 'FUNC', 'S', 'TIME', 'ARGS' );
+ foreach my $d ( sort { order_by( $sort, $a, $b ) } @data ) {
+ my $func_str = fmt_func( $d, $func_col );
+
+ printf(
+ "% 5s % 20s % 2s % 7s % 41s\n",
+ $d->{pid}, $func_str, ( $d->{done} ? 'S' : 'R' ),
+ fmt_time($d), fmt_arg( $d, $arg_col_by_func, $func_str ),
+ );
}
}
sub order_by {
- my ($sort, $a, $b) = @_;
+ my ( $sort, $a, $b ) = @_;
if ($sort) {
- } else {
+ }
+ else {
+
# Default to push running tasks to the top
- return ($a->{done}||0) <=> ($b->{done}||0) ||
- ($a->{started}||0) <=> ($b->{started}||0);
+ return ( $a->{done} || 0 ) <=> ( $b->{done} || 0 )
+ || ( $a->{started} || 0 ) <=> ( $b->{started} || 0 );
}
}
sub fmt_func {
- my ($d, $fmt) = @_;
+ my ( $d, $fmt ) = @_;
my $val = $d->{funcname};
if ($fmt) {
- if ($fmt eq 'trim') {
+ if ( $fmt eq 'trim' ) {
$val =~ s/^.+:://g;
- } else {
+ }
+ else {
$val =~ /($fmt)/;
$val = $1;
}
}
- return substr($val, 0, 20),
+ return substr( $val, 0, 20 ),;
}
sub fmt_time {
my ($d) = @_;
- my $secs = ($d->{done}||time) - $d->{started};
-
- if ($secs < 60) {
- return sprintf("%02d:%02d", 0, $secs);
- } elsif ($secs < 3600) {
- my $min = int($secs/60);
- $secs = $secs%60;
- return sprintf("%02d:%02d", $min, $secs);
- } else {
- my $hr = int($secs/60/60);
- my $min = int($secs/60%60);
- $secs = $secs%60;
- return sprintf("%d:%02d:%02d", $hr, $min, $secs);
+ my $secs = ( $d->{done} || time ) - $d->{started};
+
+ if ( $secs < 60 ) {
+ return sprintf( "%02d:%02d", 0, $secs );
+ }
+ elsif ( $secs < 3600 ) {
+ my $min = int( $secs / 60 );
+ $secs = $secs % 60;
+ return sprintf( "%02d:%02d", $min, $secs );
+ }
+ else {
+ my $hr = int( $secs / 60 / 60 );
+ my $min = int( $secs / 60 % 60 );
+ $secs = $secs % 60;
+ return sprintf( "%d:%02d:%02d", $hr, $min, $secs );
}
}
@@ -175,23 +181,26 @@ sub fmt_time {
## and printing out the appropriate element.
sub fmt_arg {
- my ($d, $arg_col_by_func, $func_str) = @_;
- my $val = $d->{arg};
+ my ( $d, $arg_col_by_func, $func_str ) = @_;
+ my $val = $d->{arg};
my $func_orig = $d->{funcname};
if ($arg_col_by_func) {
- my $fmt = ($arg_col_by_func{$func_str} ||
- $arg_col_by_func{$func_orig} ||
- $arg_col_by_func{'__ALL__'});
+ my $fmt
+ = ( $arg_col_by_func{$func_str}
+ || $arg_col_by_func{$func_orig}
+ || $arg_col_by_func{'__ALL__'} );
if ($fmt) {
my $arg_array = $d->{arg_array};
# If its a number treat the args as an array
- if ($fmt =~ /^[0-9]+$/) {
+ if ( $fmt =~ /^[0-9]+$/ ) {
$val = $arg_array->[$fmt];
}
+
# otherwise, treat the args as a hash
else {
+
# Compensate for odd numbers of args
push @$arg_array, undef if scalar(@$arg_array) % 2;
@@ -201,9 +210,9 @@ sub fmt_arg {
}
}
- return substr($val||'', 0, 41),
+ return substr( $val || '', 0, 41 ),;
}
sub clr_screen {
- $TERM->Tputs('cl', 1, \*STDOUT);
+ $TERM->Tputs( 'cl', 1, \*STDOUT );
}
@@ -1,818 +0,0 @@
-#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';
-}
-
-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() : <LOCK> == 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 (<FAILED>) { 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 1069
@@ -1,61 +0,0 @@
-#line 1
-package Module::Install::AutoInstall;
-
-use strict;
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';
- @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;
-
- Module::AutoInstall->import(
- (@config ? (-config => \@config) : ()),
- (@core ? (-core => \@core) : ()),
- $self->features,
- );
-
- $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;
@@ -1,78 +0,0 @@
-#line 1
-package Module::Install::Base;
-
-use strict 'vars';
-use vars qw{$VERSION};
-BEGIN {
- $VERSION = '0.95';
-}
-
-# 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->VERSION;
-}
-
-sub DESTROY {}
-
-package Module::Install::Base::FakeAdmin;
-
-my $fake;
-
-sub new {
- $fake ||= bless(\@_, $_[0]);
-}
-
-sub AUTOLOAD {}
-
-sub DESTROY {}
-
-# Restore warning handler
-BEGIN {
- $SIG{__WARN__} = $SIG{__WARN__}->();
-}
-
-1;
-
-#line 154
@@ -1,81 +0,0 @@
-#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 = '0.95';
- @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
@@ -1,93 +0,0 @@
-#line 1
-package Module::Install::Fetch;
-
-use strict;
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';
- @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;
@@ -1,34 +0,0 @@
-#line 1
-package Module::Install::Include;
-
-use strict;
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';
- @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;
@@ -1,405 +0,0 @@
-#line 1
-package Module::Install::Makefile;
-
-use strict 'vars';
-use ExtUtils::MakeMaker ();
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';
- @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} 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 );
-}
-
-my %test_dir = ();
-
-sub _wanted_t {
- /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
-}
-
-sub tests_recursive {
- my $self = shift;
- if ( $self->tests ) {
- die "tests_recursive will not work if tests are already defined";
- }
- my $dir = shift || 't';
- unless ( -d $dir ) {
- die "tests_recursive dir '$dir' does not exist";
- }
- %test_dir = ();
- require File::Find;
- File::Find::find( \&_wanted_t, $dir );
- if ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
- File::Find::find( \&_wanted_t, 'xt' );
- }
- $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
-}
-
-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 ( -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
- my $subdirs = ($args->{DIR} ||= []);
- if ($self->bundles) {
- foreach my $bundle (@{ $self->bundles }) {
- my ($file, $dir) = @$bundle;
- push @$subdirs, $dir if -d $dir;
- delete $build_prereq->{$file}; #Delete from build prereqs only
- }
- }
-
- 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: $!";
- my $makefile = do { local $/; <MAKEFILE> };
- close MAKEFILE or die $!;
-
- $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;
-
- open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
- 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 531
@@ -1,694 +0,0 @@
-#line 1
-package Module::Install::Metadata;
-
-use strict 'vars';
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';
- @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;
-}
-
-#Stolen from M::B
-my %license_urls = (
- perl => 'http://dev.perl.org/licenses/',
- apache => 'http://apache.org/licenses/LICENSE-2.0',
- 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()'
- );
- $self->{values}->{license} = $license;
-
- # Automatically fill in license URLs
- if ( $license_urls{$license} ) {
- $self->resources( license => $license_urls{$license} );
- }
-
- return 1;
-}
-
-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) );
-}
-
-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<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
- }
- $self->author($author);
- } else {
- warn "Cannot determine author info from $_[0]\n";
- }
-}
-
-sub _extract_license {
- my $pod = shift;
- my $matched;
- return __extract_license(
- ($matched) = $pod =~ m/
- (=head \d \s+ (?:licen[cs]e|licensing)\b.*?)
- (=head \d.*|=cut.*|)\z
- /ixms
- ) || __extract_license(
- ($matched) = $pod =~ m/
- (=head \d \s+ (?:copyrights?|legal)\b.*?)
- (=head \d.*|=cut.*|)\z
- /ixms
- );
-}
-
-sub __extract_license {
- my $license_text = shift or return;
- my @phrases = (
- 'under the same (?:terms|license) as (?:perl|the perl 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,
- 'BSD license' => 'bsd', 1,
- 'Artistic license' => 'artistic', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 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;
- }
- }
-}
-
-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;
-}
-
-
-
-
-
-######################################################################
-# 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;
@@ -1,29 +0,0 @@
-#line 1
-package Module::Install::Scripts;
-
-use strict 'vars';
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';
- @ISA = 'Module::Install::Base';
- $ISCORE = 1;
-}
-
-sub install_script {
- my $self = shift;
- my $args = $self->makemaker_args;
- my $exe = $args->{EXE_FILES} ||= [];
- foreach ( @_ ) {
- if ( -f $_ ) {
- push @$exe, $_;
- } elsif ( -d 'script' and -f "script/$_" ) {
- push @$exe, "script/$_";
- } else {
- die("Cannot find script '$_'");
- }
- }
-}
-
-1;
@@ -1,64 +0,0 @@
-#line 1
-package Module::Install::Win32;
-
-use strict;
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';
- @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;
@@ -1,63 +0,0 @@
-#line 1
-package Module::Install::WriteAll;
-
-use strict;
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';;
- @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;
@@ -1,441 +0,0 @@
-#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 FindBin;
-
-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 = '0.95';
-
- # 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} ) {
- 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"};
- }
-
- *{"${who}::AUTOLOAD"} = $self->autoload;
- $self->preload;
-
- # Unregister loader and worker packages so subdirs can use them again
- delete $INC{"$self->{file}"};
- delete $INC{"$self->{path}.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;
- }
- $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
- 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 ) {
- *{"${who}::$name"} = sub {
- ${"${who}::AUTOLOAD"} = "${who}::$name";
- goto &{"${who}::AUTOLOAD"};
- };
- }
-}
-
-sub new {
- my ($class, %args) = @_;
-
- # 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) = @_;
-
- unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
- unshift @INC, $self->{prefix};
- }
-
- foreach my $rv ( $self->find_extensions($path) ) {
- my ($file, $pkg) = @{$rv};
- next if $self->{pathnames}{$pkg};
-
- local $@;
- my $new = eval { require $file; $pkg->can('new') };
- unless ( $new ) {
- warn $@ if $@;
- next;
- }
- $self->{pathnames}{$pkg} = delete $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 $/; <FH> };
- 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 $/; <FH> };
- 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.
@@ -4,9 +4,10 @@ package TheSchwartz::Error;
use strict;
use base qw( Data::ObjectDriver::BaseObject );
-__PACKAGE__->install_properties({
- columns => [ qw( jobid funcid message error_time ) ],
- datasource => 'error',
- });
+__PACKAGE__->install_properties(
+ { columns => [qw( jobid funcid message error_time )],
+ datasource => 'error',
+ }
+);
1;
@@ -4,11 +4,14 @@ package TheSchwartz::ExitStatus;
use strict;
use base qw( Data::ObjectDriver::BaseObject );
-__PACKAGE__->install_properties({
- columns => [ qw( jobid status funcid
- completion_time delete_after ) ],
- datasource => 'exitstatus',
- primary_key => 'jobid',
- });
+__PACKAGE__->install_properties(
+ { columns => [
+ qw( jobid status funcid
+ completion_time delete_after )
+ ],
+ datasource => 'exitstatus',
+ primary_key => 'jobid',
+ }
+);
1;
@@ -6,21 +6,22 @@ use base qw( Data::ObjectDriver::BaseObject );
use Carp qw( croak );
-__PACKAGE__->install_properties({
- columns => [ qw( funcid funcname ) ],
- datasource => 'funcmap',
- primary_key => 'funcid',
- });
+__PACKAGE__->install_properties(
+ { columns => [qw( funcid funcname )],
+ datasource => 'funcmap',
+ primary_key => 'funcid',
+ }
+);
sub create_or_find {
my $class = shift;
- my($driver, $funcname) = @_;
+ my ( $driver, $funcname ) = @_;
## Attempt to select funcmap record by name. If successful, return
## object, otherwise proceed with insertion and return.
- my ($map) = $driver->search('TheSchwartz::FuncMap' =>
- { funcname => $funcname }
- );
+ my ($map)
+ = $driver->search(
+ 'TheSchwartz::FuncMap' => { funcname => $funcname } );
return $map if $map;
## Attempt to insert a new funcmap row. Since the funcname column is
@@ -32,10 +33,11 @@ sub create_or_find {
## If we got an exception, try to load the record with this funcname;
## in all likelihood, the exception was that the record was added by
## another process.
- if (my $err = $@) {
- ($map) = $driver->search('TheSchwartz::FuncMap' =>
- { funcname => $funcname }
- ) or croak "Can't find or create funcname $funcname: $err";
+ if ( my $err = $@ ) {
+ ($map)
+ = $driver->search(
+ 'TheSchwartz::FuncMap' => { funcname => $funcname } )
+ or croak "Can't find or create funcname $funcname: $err";
}
return $map;
}
@@ -10,56 +10,65 @@ use TheSchwartz::Error;
use TheSchwartz::ExitStatus;
use TheSchwartz::JobHandle;
-__PACKAGE__->install_properties({
- columns => [qw(jobid funcid arg uniqkey insert_time
- run_after grabbed_until priority coalesce)],
- datasource => 'job',
- column_defs => { arg => 'blob' },
- primary_key => 'jobid',
- });
-
-__PACKAGE__->add_trigger(pre_save => sub {
- my ($job) = @_;
- my $arg = $job->arg
- or return;
- if (ref($arg)) {
- $job->arg(Storable::nfreeze($arg));
+__PACKAGE__->install_properties(
+ { columns => [
+ qw(jobid funcid arg uniqkey insert_time
+ run_after grabbed_until priority coalesce)
+ ],
+ datasource => 'job',
+ column_defs => { arg => 'blob' },
+ primary_key => 'jobid',
}
-});
-
-__PACKAGE__->add_trigger(post_load => sub {
- my ($job) = @_;
- my $arg = $job->arg
- or return;
- $job->arg(_cond_thaw($job->arg))
-});
+);
+
+__PACKAGE__->add_trigger(
+ pre_save => sub {
+ my ($job) = @_;
+ my $arg = $job->arg
+ or return;
+ if ( ref($arg) ) {
+ $job->arg( Storable::nfreeze($arg) );
+ }
+ }
+);
+
+__PACKAGE__->add_trigger(
+ post_load => sub {
+ my ($job) = @_;
+ my $arg = $job->arg
+ or return;
+ $job->arg( _cond_thaw( $job->arg ) );
+ }
+);
sub new_from_array {
my $class = shift;
- my(@arg) = @_;
+ my (@arg) = @_;
croak "usage: new_from_array(funcname, arg)" unless @arg == 2;
return $class->new(
- funcname => $arg[0],
- arg => $arg[1],
- );
+ funcname => $arg[0],
+ arg => $arg[1],
+ );
}
sub new {
- my $class = shift;
- my(%param) = @_;
- my $job = $class->SUPER::new;
- if (my $arg = $param{arg}) {
- if (ref($arg) eq 'SCALAR') {
+ my $class = shift;
+ my (%param) = @_;
+ my $job = $class->SUPER::new;
+ if ( my $arg = $param{arg} ) {
+ if ( ref($arg) eq 'SCALAR' ) {
$param{arg} = Storable::thaw($$arg);
- } elsif (!ref($arg)) {
+ }
+ elsif ( !ref($arg) ) {
+
# if a regular scalar, test to see if it's a storable or not.
$param{arg} = _cond_thaw($arg);
}
}
$param{run_after} ||= time;
$param{grabbed_until} ||= 0;
- for my $key (keys %param) {
- $job->$key($param{$key});
+ for my $key ( keys %param ) {
+ $job->$key( $param{$key} );
}
return $job;
}
@@ -71,11 +80,13 @@ sub funcname {
}
# lazily load,
- if (!$job->{__funcname}) {
+ if ( !$job->{__funcname} ) {
my $handle = $job->handle;
my $client = $handle->client;
- my $driver = $client->driver_for($handle->dsn_hashed);
- my $funcname = $client->funcid_to_name($driver, $handle->dsn_hashed, $job->funcid)
+ my $driver = $client->driver_for( $handle->dsn_hashed );
+ my $funcname
+ = $client->funcid_to_name( $driver, $handle->dsn_hashed,
+ $job->funcid )
or die "Failed to lookup funcname of job $job";
return $job->{__funcname} = $funcname;
}
@@ -92,52 +103,53 @@ sub handle {
sub driver {
my $job = shift;
- unless (exists $job->{__driver}) {
+ unless ( exists $job->{__driver} ) {
my $handle = $job->handle;
- $job->{__driver} = $handle->client->driver_for($handle->dsn_hashed);
+ $job->{__driver} = $handle->client->driver_for( $handle->dsn_hashed );
}
return $job->{__driver};
}
sub add_failure {
- my $job = shift;
- my($msg) = @_;
+ my $job = shift;
+ my ($msg) = @_;
my $error = TheSchwartz::Error->new;
- $error->error_time(time());
- $error->jobid($job->jobid);
- $error->funcid($job->funcid);
- $error->message($msg || '');
+ $error->error_time( time() );
+ $error->jobid( $job->jobid );
+ $error->funcid( $job->funcid );
+ $error->message( $msg || '' );
my $driver = $job->driver;
$driver->insert($error);
# and let's lazily clean some errors while we're here.
my $unixtime = $driver->dbd->sql_for_unixtime;
- my $maxage = $TheSchwartz::T_ERRORS_MAX_AGE || (86400*7);
- $driver->remove('TheSchwartz::Error', {
- error_time => \ "< $unixtime - $maxage",
- }, {
- nofetch => 1,
- limit => $driver->dbd->can_delete_with_limit ? 1000 : undef,
- });
+ my $maxage = $TheSchwartz::T_ERRORS_MAX_AGE || ( 86400 * 7 );
+ $driver->remove(
+ 'TheSchwartz::Error',
+ { error_time => \"< $unixtime - $maxage", },
+ { nofetch => 1,
+ limit => $driver->dbd->can_delete_with_limit ? 1000 : undef,
+ }
+ );
return $error;
}
sub exit_status { shift->handle->exit_status }
sub failure_log { shift->handle->failure_log }
-sub failures { shift->handle->failures }
+sub failures { shift->handle->failures }
sub set_exit_status {
- my $job = shift;
- my($exit) = @_;
- my $class = $job->funcname;
- my $secs = $class->keep_exit_status_for or return;
+ my $job = shift;
+ my ($exit) = @_;
+ my $class = $job->funcname;
+ my $secs = $class->keep_exit_status_for or return;
my $status = TheSchwartz::ExitStatus->new;
- $status->jobid($job->jobid);
- $status->funcid($job->funcid);
+ $status->jobid( $job->jobid );
+ $status->funcid( $job->funcid );
$status->completion_time(time);
- $status->delete_after($status->completion_time + $secs);
+ $status->delete_after( $status->completion_time + $secs );
$status->status($exit);
my $driver = $job->driver;
@@ -148,14 +160,17 @@ sub set_exit_status {
# time, and deleting up to n*10 queries while we're at it.
# default n is 10% of the time, doing 100 deletes.
my $clean_thres = $TheSchwartz::T_EXITSTATUS_CLEAN_THRES || 0.10;
- if (rand() < $clean_thres) {
+ if ( rand() < $clean_thres ) {
my $unixtime = $driver->dbd->sql_for_unixtime;
- $driver->remove('TheSchwartz::ExitStatus', {
- delete_after => \ "< $unixtime",
- }, {
- nofetch => 1,
- limit => $driver->dbd->can_delete_with_limit ? int(1 / $clean_thres * 100) : undef,
- });
+ $driver->remove(
+ 'TheSchwartz::ExitStatus',
+ { delete_after => \"< $unixtime", },
+ { nofetch => 1,
+ limit => $driver->dbd->can_delete_with_limit
+ ? int( 1 / $clean_thres * 100 )
+ : undef,
+ }
+ );
}
return $status;
@@ -169,7 +184,6 @@ sub was_declined {
return $job->{__was_declined};
}
-
sub did_something {
my $job = shift;
if (@_) {
@@ -179,14 +193,14 @@ sub did_something {
}
sub debug {
- my ($job, $msg) = @_;
- $job->handle->client->debug($msg, $job);
+ my ( $job, $msg ) = @_;
+ $job->handle->client->debug( $msg, $job );
}
sub completed {
my $job = shift;
$job->debug("job completed");
- if ($job->did_something) {
+ if ( $job->did_something ) {
$job->debug("can't call 'completed' on already finished job");
return 0;
}
@@ -196,30 +210,45 @@ sub completed {
}
sub permanent_failure {
- my ($job, $msg, $ex_status) = @_;
- if ($job->did_something) {
+ my ( $job, $msg, $ex_status ) = @_;
+ if ( $job->did_something ) {
$job->debug("can't call 'permanent_failure' on already finished job");
return 0;
}
- $job->_failed($msg, $ex_status, 0);
+ $job->_failed( $msg, $ex_status, 0 );
}
sub declined {
- my ($job) = @_;
- if ($job->did_something) {
+ my $job = shift;
+ my $run_after = shift;
+
+ if ( $job->did_something ) {
$job->debug("can't call 'declined' on already finished job");
return 0;
}
- $job->debug("job declined. retry will be considered after lease is up at " . $job->grabbed_until);
$job->was_declined(1);
+ if ($run_after) {
+ $job->run_after($run_after);
+ $job->grabbed_until(0);
+ $job->driver->update($job);
+ $job->debug(
+ "job declined. retry will be considered after lease is up at "
+ . $job->run_after );
+ }
+ else {
+ $job->debug(
+ "job declined. retry will be considered after lease is up at "
+ . $job->grabbed_until );
+ }
+
# we do nothing regarding the job's status
}
sub failed {
- my ($job, $msg, $ex_status) = @_;
- if ($job->did_something) {
+ my ( $job, $msg, $ex_status ) = @_;
+ if ( $job->did_something ) {
$job->debug("can't call 'failed' on already finished job");
return 0;
}
@@ -227,61 +256,66 @@ sub failed {
## If this job class specifies that jobs should be retried,
## update the run_after if necessary, but keep the job around.
- my $class = $job->funcname;
- my $failures = $job->failures + 1; # include this one, since we haven't ->add_failure yet
+ my $class = $job->funcname;
+ my $failures = $job->failures
+ + 1; # include this one, since we haven't ->add_failure yet
my $max_retries = $class->max_retries($job);
- $job->debug("job failed. considering retry. is max_retries of $max_retries >= failures of $failures?");
- $job->_failed($msg, $ex_status, $max_retries >= $failures, $failures);
+ $job->debug(
+ "job failed. considering retry. is max_retries of $max_retries >= failures of $failures?"
+ );
+ $job->_failed( $msg, $ex_status, $max_retries >= $failures, $failures );
}
sub _failed {
- my ($job, $msg, $exit_status, $_retry, $failures) = @_;
+ my ( $job, $msg, $exit_status, $_retry, $failures ) = @_;
$job->did_something(1);
- $job->debug("job failed: " . ($msg || "<no message>"));
+ $job->debug( "job failed: " . ( $msg || "<no message>" ) );
## Mark the failure in the error table.
$job->add_failure($msg);
if ($_retry) {
my $class = $job->funcname;
- if (my $delay = $class->retry_delay($failures)) {
- $job->run_after(time() + $delay);
+ if ( my $delay = $class->retry_delay($failures) ) {
+ $job->run_after( time() + $delay );
}
$job->grabbed_until(0);
$job->driver->update($job);
- } else {
- $job->set_exit_status($exit_status || 1);
+ }
+ else {
+ $job->set_exit_status( $exit_status || 1 );
$job->driver->remove($job);
}
}
sub replace_with {
my $job = shift;
- my(@jobs) = @_;
+ my (@jobs) = @_;
- if ($job->did_something) {
+ if ( $job->did_something ) {
$job->debug("can't call 'replace_with' on already finished job");
return 0;
}
- # Note: we don't set 'did_something' here because completed does it down below.
+
+# Note: we don't set 'did_something' here because completed does it down below.
## The new jobs @jobs should be inserted into the same database as $job,
## which they're replacing. So get a driver for the database that $job
## belongs to.
- my $handle = $job->handle;
- my $client = $handle->client;
+ my $handle = $job->handle;
+ my $client = $handle->client;
my $hashdsn = $handle->dsn_hashed;
- my $driver = $job->driver;
+ my $driver = $job->driver;
- $job->debug("replacing job with " . (scalar @jobs) . " other jobs");
+ $job->debug( "replacing job with " . ( scalar @jobs ) . " other jobs" );
## Start a transaction.
$driver->begin_work;
## Insert the new jobs.
for my $j (@jobs) {
- $client->insert_job_to_driver($j, $driver, $hashdsn);
+ $client->insert_job_to_driver( $j, $driver, $hashdsn );
}
## Mark the original job as completed successfully.
@@ -298,7 +332,7 @@ sub replace_with {
}
sub set_as_current {
- my $job = shift;
+ my $job = shift;
my $client = $job->handle->client;
$client->set_current_job($job);
}
@@ -307,14 +341,20 @@ sub _cond_thaw {
my $data = shift;
my $magic = eval { Storable::read_magic($data); };
- if ($magic && $magic->{major} && $magic->{major} >= 2 && $magic->{major} <= 5) {
+ if ( $magic
+ && $magic->{major}
+ && $magic->{major} >= 2
+ && $magic->{major} <= 5 )
+ {
my $thawed = eval { Storable::thaw($data) };
if ($@) {
+
# false alarm... looked like a Storable, but wasn't.
return $data;
}
return $thawed;
- } else {
+ }
+ else {
return $data;
}
}
@@ -381,13 +421,13 @@ The C<insert_time> field is not used.
=head2 C<run_after>
The UNIX system time after which the job can next be attempted by a worker
-process. This timestamp is set when a job is first created or is released after
+process. This time stamp is set when a job is first created or is released after
a failure.
=head2 C<grabbed_until>
The UNIX system time after which the job can next be available by a worker
-process. This timestamp is set when a job is grabbed by a worker process, and
+process. This time stamp is set when a job is grabbed by a worker process, and
reset to C<0> when is released due to failure to complete the job.
=head2 C<priority>
@@ -398,7 +438,7 @@ details.
=head2 C<coalesce>
-A string used to discover jobs that can be efficiently pipelined with a given
+A string used to discover jobs that can be efficiently pipe-lined with a given
job due to some shared resource. For example, for email delivery jobs, the
domain of an email address could be used as the C<coalesce> value. A worker
process could then deliver all the mail queued for a given mail host after
@@ -512,17 +552,20 @@ C<failed()>, but that the job should I<not> be reattempted, no matter how many
times the job has been attempted before. The job's exit status is thus recorded
as C<$exit_status> (or C<1>), and the job is removed from the queue.
-=head2 C<$job-E<gt>declined()>
+=head2 C<$job-E<gt>declined([ $run_after ])>
Report that the job has been declined for handling at this time, which means that
the job will be retried after the next grabbed_until interval, and does not count
against the max_retries count.
+If $run_after is set then the job will be grabbed_until will be reset and the job
+will be reconsidered at $run_after, and does not count against the max_retries count.
+
=head2 C<$job-E<gt>replace_with( @jobs )>
Atomically replaces the single job C<$job> with the given set of jobs.
-This can be used to decompose one "metajob" posted by your application into a
+This can be used to decompose one "meta job" posted by your application into a
set of jobs workers can perform, or to post a job or jobs required to complete
the process already partly performed.
@@ -11,12 +11,13 @@ use TheSchwartz::Job;
sub new_from_string {
my $class = shift;
- my($hstr) = @_;
- my($hashdsn, $jobid) = split /\-/, $hstr, 2;
- return TheSchwartz::JobHandle->new({
- dsn_hashed => $hashdsn,
+ my ($hstr) = @_;
+ my ( $hashdsn, $jobid ) = split /\-/, $hstr, 2;
+ return TheSchwartz::JobHandle->new(
+ { dsn_hashed => $hashdsn,
jobid => $jobid,
- });
+ }
+ );
}
sub as_string {
@@ -26,15 +27,16 @@ sub as_string {
sub driver {
my $handle = shift;
- unless (exists $handle->{__driver}) {
- $handle->{__driver} = $handle->client->driver_for($handle->dsn_hashed);
+ unless ( exists $handle->{__driver} ) {
+ $handle->{__driver}
+ = $handle->client->driver_for( $handle->dsn_hashed );
}
return $handle->{__driver};
}
sub job {
my $handle = shift;
- my $job = $handle->client->lookup_job($handle->as_string) or return;
+ my $job = $handle->client->lookup_job( $handle->as_string ) or return;
$job->handle($handle);
return $job;
}
@@ -46,17 +48,17 @@ sub is_pending {
sub exit_status {
my $handle = shift;
- my $status = $handle->driver->lookup(
- 'TheSchwartz::ExitStatus' => $handle->jobid
- ) or return;
+ my $status
+ = $handle->driver->lookup(
+ 'TheSchwartz::ExitStatus' => $handle->jobid )
+ or return;
return $status->status;
}
sub failure_log {
- my $handle = shift;
- my @failures = $handle->driver->search('TheSchwartz::Error' =>
- { jobid => $handle->jobid },
- );
+ my $handle = shift;
+ my @failures = $handle->driver->search(
+ 'TheSchwartz::Error' => { jobid => $handle->jobid }, );
return map { $_->message } @failures;
}
@@ -8,17 +8,17 @@ use Storable ();
sub grab_job {
my $class = shift;
- my($client) = @_;
- return $client->find_job_for_workers([ $class ]);
+ my ($client) = @_;
+ return $client->find_job_for_workers( [$class] );
}
-sub keep_exit_status_for { 0 }
-sub max_retries { 0 }
-sub retry_delay { 0 }
-sub grab_for { 60 * 60 } ## 1 hour
+sub keep_exit_status_for {0}
+sub max_retries {0}
+sub retry_delay {0}
+sub grab_for { 60 * 60 } ## 1 hour
sub work_safely {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
my $client = $job->handle->client;
my $res;
@@ -26,9 +26,7 @@ sub work_safely {
$job->set_as_current;
$client->start_scoreboard;
- eval {
- $res = $class->work($job);
- };
+ eval { $res = $class->work($job); };
my $errstr = $@;
my $cjob = $client->current_job;
@@ -36,13 +34,14 @@ sub work_safely {
$job->debug("Eval failure: $errstr");
$cjob->failed($@);
}
- if (! $cjob->was_declined && ! $cjob->did_something) {
- $cjob->failed('Job did not explicitly complete, fail, or get replaced');
+ if ( !$cjob->was_declined && !$cjob->did_something ) {
+ $cjob->failed(
+ 'Job did not explicitly complete, fail, or get replaced');
}
$client->end_scoreboard;
- # FIXME: this return value is kinda useless/undefined. should we even return anything? any callers? -brad
+# FIXME: this return value is kinda useless/undefined. should we even return anything? any callers? -brad
return $res;
}
@@ -78,10 +77,10 @@ TheSchwartz::Worker - superclass for defining task behavior
=head1 DESCRIPTION
I<TheSchwartz::Worker> objects are the salt of the reliable job queuing earth.
-The behavior required to perform posted jobs are defined in subclasses of
-I<TheSchwartz::Worker>. These subclasses are named for the ability required of
+The behavior required to perform posted jobs are defined in sub-classes of
+I<TheSchwartz::Worker>. These sub-classes are named for the ability required of
a C<TheSchwartz> client to do the job, so that the clients can dispatch
-automatically to the approprate worker routine.
+automatically to the appropriate worker routine.
Because jobs can be performed by any machine running code for capable worker
classes, C<TheSchwartz::Worker>s are generally stateless. All mutable state is
@@ -1,10 +1,12 @@
# $Id$
package TheSchwartz;
+use 5.008;
use strict;
-use fields qw( databases retry_seconds dead_dsns retry_at funcmap_cache verbose all_abilities current_abilities current_job cached_drivers driver_cache_expiration scoreboard prioritize );
+use fields
+ qw( databases retry_seconds dead_dsns retry_at funcmap_cache verbose all_abilities current_abilities current_job cached_drivers driver_cache_expiration scoreboard prioritize floor batch_size );
-our $VERSION = "1.10";
+our $VERSION = "1.11";
use Carp qw( croak );
use Data::ObjectDriver::Errors;
@@ -16,7 +18,8 @@ use TheSchwartz::Job;
use TheSchwartz::JobHandle;
use constant RETRY_DEFAULT => 30;
-use constant OK_ERRORS => { map { $_ => 1 } Data::ObjectDriver::Errors->UNIQUE_CONSTRAINT, };
+use constant OK_ERRORS =>
+ { map { $_ => 1 } Data::ObjectDriver::Errors->UNIQUE_CONSTRAINT, };
# test harness hooks
our $T_AFTER_GRAB_SELECT_BEFORE_UPDATE;
@@ -35,16 +38,22 @@ sub new {
my $databases = delete $args{databases};
$client->{retry_seconds} = delete $args{retry_seconds} || RETRY_DEFAULT;
- $client->set_prioritize(delete $args{prioritize});
- $client->set_verbose(delete $args{verbose});
- $client->set_scoreboard(delete $args{scoreboard});
- $client->{driver_cache_expiration} = delete $args{driver_cache_expiration} || 0;
- croak "unknown options ", join(', ', keys %args) if keys %args;
+ $client->set_prioritize( delete $args{prioritize} );
+ $client->set_verbose( delete $args{verbose} );
+ $client->set_scoreboard( delete $args{scoreboard} );
+ $client->{driver_cache_expiration} = delete $args{driver_cache_expiration}
+ || 0;
+ $client->{batch_size} = delete $args{batch_size} || $FIND_JOB_BATCH_SIZE;
+
+ my $floor = delete $args{floor};
+ $client->set_floor($floor) if ($floor);
+
+ croak "unknown options ", join( ', ', keys %args ) if keys %args;
$client->hash_databases($databases);
$client->reset_abilities;
- $client->{dead_dsns} = {};
- $client->{retry_at} = {};
+ $client->{dead_dsns} = {};
+ $client->{retry_at} = {};
$client->{funcmap_cache} = {};
return $client;
@@ -53,22 +62,30 @@ sub new {
sub debug {
my TheSchwartz $client = shift;
return unless $client->{verbose};
- $client->{verbose}->(@_); # ($msg, $job) but $job is optional
+ $client->{verbose}->(@_); # ($msg, $job) but $job is optional
}
sub hash_databases {
my TheSchwartz $client = shift;
- my($list) = @_;
+ my ($list) = @_;
for my $ref (@$list) {
my $var;
my @parts;
- if ($ref->{driver}) {
- my $dbh = tied(%{$ref->{driver}->dbh});
- my $dsn = "dbd:".$dbh->{Driver}->{Name}.":".$dbh->{Name};
- my $user = $dbh->{Username} || '';
- @parts = ($dsn, $user);
- } else {
- @parts = map { $ref->{$_} || '' } qw(dsn user);
+ if ( $ref->{driver} ) {
+ my $dbh;
+ if ( my $getter = $ref->{driver}->get_dbh ) {
+ $dbh = $getter->();
+ }
+ else {
+ $dbh = $ref->{driver}->dbh;
+ }
+ $dbh = tied( %{$dbh} );
+ my $dsn = "dbd:" . $dbh->{Driver}->{Name} . ":" . $dbh->{Name};
+ my $user = $dbh->{Username} || '';
+ @parts = ( $dsn, $user );
+ }
+ else {
+ @parts = map { $ref->{$_} || '' } qw(dsn user);
}
my $full = join '|', @parts;
$client->{databases}{ md5_hex($full) } = $ref;
@@ -77,28 +94,35 @@ sub hash_databases {
sub driver_for {
my TheSchwartz $client = shift;
- my($hashdsn) = @_;
+ my ($hashdsn) = @_;
my $driver;
- my $t = time;
+ my $t = time;
my $cache_duration = $client->{driver_cache_expiration};
- if ($cache_duration && $client->{cached_drivers}{$hashdsn}{create_ts} && $client->{cached_drivers}{$hashdsn}{create_ts} + $cache_duration > $t) {
+ if ( $cache_duration
+ && $client->{cached_drivers}{$hashdsn}{create_ts}
+ && $client->{cached_drivers}{$hashdsn}{create_ts} + $cache_duration
+ > $t )
+ {
$driver = $client->{cached_drivers}{$hashdsn}{driver};
- } else {
+ }
+ else {
my $db = $client->{databases}{$hashdsn}
- or croak "Ouch, I don't know about a database whose hash is $hashdsn";
- if ($db->{driver}) {
+ or croak
+ "Ouch, I don't know about a database whose hash is $hashdsn";
+ if ( $db->{driver} ) {
$driver = $db->{driver};
- } else {
+ }
+ else {
$driver = Data::ObjectDriver::Driver::DBI->new(
- dsn => $db->{dsn},
- username => $db->{user},
- password => $db->{pass},
- );
+ dsn => $db->{dsn},
+ username => $db->{user},
+ password => $db->{pass},
+ );
}
- $driver->prefix($db->{prefix}) if exists $db->{prefix};
+ $driver->prefix( $db->{prefix} ) if exists $db->{prefix};
if ($cache_duration) {
- $client->{cached_drivers}{$hashdsn}{driver} = $driver;
+ $client->{cached_drivers}{$hashdsn}{driver} = $driver;
$client->{cached_drivers}{$hashdsn}{create_ts} = $t;
}
}
@@ -107,22 +131,23 @@ sub driver_for {
sub mark_database_as_dead {
my TheSchwartz $client = shift;
- my($hashdsn) = @_;
+ my ($hashdsn) = @_;
$client->{dead_dsns}{$hashdsn} = 1;
- $client->{retry_at}{$hashdsn} = time + $client->{retry_seconds};
+ $client->{retry_at}{$hashdsn} = time + $client->{retry_seconds};
}
sub is_database_dead {
my TheSchwartz $client = shift;
- my($hashdsn) = @_;
+ my ($hashdsn) = @_;
## If this database is marked as dead, check the retry time. If
## it has passed, try the database again to see if it's undead.
- if ($client->{dead_dsns}{$hashdsn}) {
- if ($client->{retry_at}{$hashdsn} < time) {
+ if ( $client->{dead_dsns}{$hashdsn} ) {
+ if ( $client->{retry_at}{$hashdsn} < time ) {
delete $client->{dead_dsns}{$hashdsn};
delete $client->{retry_at}{$hashdsn};
return 0;
- } else {
+ }
+ else {
return 1;
}
}
@@ -131,71 +156,90 @@ sub is_database_dead {
sub lookup_job {
my TheSchwartz $client = shift;
- my $handle = $client->handle_from_string(@_);
- my $driver = $client->driver_for($handle->dsn_hashed);
+ my $handle = $client->handle_from_string(@_);
+ my $driver = $client->driver_for( $handle->dsn_hashed );
my $id = $handle->jobid;
- my $job = $driver->lookup('TheSchwartz::Job' => $handle->jobid)
+ my $job = $driver->lookup( 'TheSchwartz::Job' => $handle->jobid )
or return;
$job->handle($handle);
- $job->funcname( $client->funcid_to_name($driver, $handle->dsn_hashed, $job->funcid) );
+ $job->funcname(
+ $client->funcid_to_name( $driver, $handle->dsn_hashed, $job->funcid )
+ );
return $job;
}
sub list_jobs {
my TheSchwartz $client = shift;
my $arg = shift;
- my @options;
- push @options, run_after => { op => '<=', value => $arg->{run_after} } if exists $arg->{run_after};
- push @options, grabbed_until => { op => '<=', value => $arg->{grabbed_until} } if exists $arg->{grabbed_until};
+
+ my ( %terms, %options );
+
+ $terms{run_after} = { op => '<=', value => $arg->{run_after} }
+ if exists $arg->{run_after};
+
+ $terms{grabbed_until} = { op => '<=', value => $arg->{grabbed_until} }
+ if exists $arg->{grabbed_until};
+
+ $terms{jobid} = { op => '=', value => $arg->{jobid} }
+ if exists $arg->{jobid};
+
die "No funcname" unless exists $arg->{funcname};
$arg->{want_handle} = 1 unless defined $arg->{want_handle};
- my $limit = $arg->{limit} || $FIND_JOB_BATCH_SIZE;
- if ($arg->{coalesce}) {
+ my $limit = $arg->{limit} || $client->batch_size;
+
+ if ( $arg->{coalesce} ) {
$arg->{coalesce_op} ||= '=';
- push @options, coalesce => { op => $arg->{coalesce_op}, value => $arg->{coalesce}};
+ }
+
+ $options{limit} = $limit;
+ if ( $client->prioritize ) {
+ $options{sort} = [
+ { column => 'priority', direction => 'descend' },
+ { column => 'jobid' },
+ ];
+ }
+ else { # RT #34843
+ $options{sort} = [ { column => 'jobid' }, ];
+ }
+
+ if ( $client->floor ) {
+ $terms{priority} = { op => '>=', value => $client->floor };
}
my @jobs;
- for my $hashdsn ($client->shuffled_databases) {
+ for my $hashdsn ( $client->shuffled_databases ) {
## If the database is dead, skip it
next if $client->is_database_dead($hashdsn);
my $driver = $client->driver_for($hashdsn);
- my $funcid;
- if (ref($arg->{funcname})) {
- $funcid = [map { $client->funcname_to_id($driver, $hashdsn, $_) } @{$arg->{funcname}}];
- } else {
- $funcid = $client->funcname_to_id($driver, $hashdsn, $arg->{funcname});
+ if ( ref( $arg->{funcname} ) ) {
+ $terms{funcid}
+ = [ map { $client->funcname_to_id( $driver, $hashdsn, $_ ) }
+ @{ $arg->{funcname} } ];
+ }
+ else {
+ $terms{funcid} = $client->funcname_to_id( $driver, $hashdsn,
+ $arg->{funcname} );
}
- if ($arg->{want_handle}) {
+ if ( $arg->{want_handle} ) {
push @jobs, map {
- my $handle = TheSchwartz::JobHandle->new({
- dsn_hashed => $hashdsn,
- client => $client,
- jobid => $_->jobid
- });
+ my $handle = TheSchwartz::JobHandle->new(
+ { dsn_hashed => $hashdsn,
+ client => $client,
+ jobid => $_->jobid
+ }
+ );
$_->handle($handle);
$_;
- } $driver->search('TheSchwartz::Job' => {
- funcid => $funcid,
- @options
- }, { limit => $limit,
- ( $client->prioritize ? ( sort => 'priority',
- direction => 'descend' ) : () )
- });
- } else {
- push @jobs, $driver->search('TheSchwartz::Job' => {
- funcid => $funcid,
- @options
- }, { limit => $limit,
- ( $client->prioritize ? ( sort => 'priority',
- direction => 'descend' ) : () )
- }
- );
+ } $driver->search( 'TheSchwartz::Job' => \%terms, \%options );
+ }
+ else {
+ push @jobs,
+ $driver->search( 'TheSchwartz::Job' => \%terms, \%options );
}
}
return @jobs;
@@ -203,27 +247,38 @@ sub list_jobs {
sub find_job_with_coalescing_prefix {
my TheSchwartz $client = shift;
- my ($funcname, $coval) = @_;
+ my ( $funcname, $coval ) = @_;
$coval .= "%";
- return $client->_find_job_with_coalescing('LIKE', $funcname, $coval);
+ return $client->_find_job_with_coalescing( 'LIKE', $funcname, $coval );
}
sub find_job_with_coalescing_value {
my TheSchwartz $client = shift;
- return $client->_find_job_with_coalescing('=', @_);
+ return $client->_find_job_with_coalescing( '=', @_ );
}
sub _find_job_with_coalescing {
my TheSchwartz $client = shift;
- my ($op, $funcname, $coval) = @_;
+ my ( $op, $funcname, $coval ) = @_;
- for my $hashdsn ($client->shuffled_databases) {
+ for my $hashdsn ( $client->shuffled_databases ) {
## If the database is dead, skip it
next if $client->is_database_dead($hashdsn);
- my $driver = $client->driver_for($hashdsn);
+ my $driver = $client->driver_for($hashdsn);
my $unixtime = $driver->dbd->sql_for_unixtime;
+ my %options = ( limit => $client->batch_size );
+ if ( $client->prioritize ) {
+ $options{sort} = [
+ { column => 'priority', direction => 'descend' },
+ { column => 'jobid' },
+ ];
+ }
+ else { # RT #34843
+ $options{sort} = [ { column => 'jobid' }, ];
+ }
+
my @jobs;
eval {
## Search for jobs in this database where:
@@ -231,40 +286,57 @@ sub _find_job_with_coalescing {
## 2. the job is scheduled to be run (run_after is in the past);
## 3. no one else is working on the job (grabbed_until is in
## in the past).
- my $funcid = $client->funcname_to_id($driver, $hashdsn, $funcname);
-
- @jobs = $driver->search('TheSchwartz::Job' => {
- funcid => $funcid,
- run_after => \ "<= $unixtime",
- grabbed_until => \ "<= $unixtime",
- coalesce => { op => $op, value => $coval },
- }, { limit => $FIND_JOB_BATCH_SIZE,
- ( $client->prioritize ? ( sort => 'priority',
- direction => 'descend' ) : () )
- }
+ my $funcid
+ = $client->funcname_to_id( $driver, $hashdsn, $funcname );
+
+ my %terms = (
+ funcid => $funcid,
+ run_after => \"<= $unixtime",
+ grabbed_until => \"<= $unixtime",
+ coalesce => { op => $op, value => $coval },
+ );
+
+ if ( $client->floor ) {
+ $terms{priority} = { op => '>=', value => $client->floor };
+ }
+
+ @jobs = $driver->search(
+ 'TheSchwartz::Job' => \%terms,
+ \%options,
);
};
if ($@) {
- unless (OK_ERRORS->{ $driver->last_error || 0 }) {
+ unless ( OK_ERRORS->{ $driver->last_error || 0 } ) {
$client->mark_database_as_dead($hashdsn);
}
}
- my $job = $client->_grab_a_job($hashdsn, @jobs);
+ my $job = $client->_grab_a_job( $hashdsn, @jobs );
return $job if $job;
}
}
sub find_job_for_workers {
my TheSchwartz $client = shift;
- my($worker_classes) = @_;
+ my ($worker_classes) = @_;
$worker_classes ||= $client->{current_abilities};
- for my $hashdsn ($client->shuffled_databases) {
+ my %options = ( limit => $client->batch_size );
+ if ( $client->prioritize ) {
+ $options{sort} = [
+ { column => 'priority', direction => 'descend' },
+ { column => 'jobid' },
+ ];
+ }
+ else { # RT #34843
+ $options{sort} = [ { column => 'jobid' }, ];
+ }
+
+ for my $hashdsn ( $client->shuffled_databases ) {
## If the database is dead, skip it.
next if $client->is_database_dead($hashdsn);
- my $driver = $client->driver_for($hashdsn);
+ my $driver = $client->driver_for($hashdsn);
my $unixtime = $driver->dbd->sql_for_unixtime;
my @jobs;
@@ -274,65 +346,80 @@ sub find_job_for_workers {
## 2. the job is scheduled to be run (run_after is in the past);
## 3. no one else is working on the job (grabbed_until is in
## in the past).
- my @ids = map { $client->funcname_to_id($driver, $hashdsn, $_) }
- @$worker_classes;
-
- @jobs = $driver->search('TheSchwartz::Job' => {
- funcid => \@ids,
- run_after => \ "<= $unixtime",
- grabbed_until => \ "<= $unixtime",
- }, { limit => $FIND_JOB_BATCH_SIZE,
- ( $client->prioritize ? ( sort => 'priority',
- direction => 'descend' ) : () )
- }
+ my @ids = map { $client->funcname_to_id( $driver, $hashdsn, $_ ) }
+ @$worker_classes;
+
+ my %terms = (
+ funcid => \@ids,
+ run_after => \"<= $unixtime",
+ grabbed_until => \"<= $unixtime",
+ );
+
+ if ( $client->floor ) {
+ $terms{priority} = { op => '>=', value => $client->floor };
+ }
+
+ @jobs = $driver->search(
+ 'TheSchwartz::Job' => \%terms,
+ \%options,
);
};
if ($@) {
- unless (OK_ERRORS->{ $driver->last_error || 0 }) {
+ unless ( OK_ERRORS->{ $driver->last_error || 0 } ) {
$client->mark_database_as_dead($hashdsn);
}
}
# for test harness race condition testing
- $T_AFTER_GRAB_SELECT_BEFORE_UPDATE->() if $T_AFTER_GRAB_SELECT_BEFORE_UPDATE;
+ $T_AFTER_GRAB_SELECT_BEFORE_UPDATE->()
+ if $T_AFTER_GRAB_SELECT_BEFORE_UPDATE;
- my $job = $client->_grab_a_job($hashdsn, @jobs);
+ my $job = $client->_grab_a_job( $hashdsn, @jobs );
return $job if $job;
}
}
sub get_server_time {
my TheSchwartz $client = shift;
- my($driver) = @_;
- my $unixtime_sql = $driver->dbd->sql_for_unixtime;
+ my ($driver) = @_;
+ my $unixtime_sql = $driver->dbd->sql_for_unixtime;
+
+ # RT #58049
+ $unixtime_sql .= ' FROM DUAL'
+ if ( $driver->dbd->isa('Data::ObjectDriver::Driver::DBD::Oracle') );
+
return $driver->rw_handle->selectrow_array("SELECT $unixtime_sql");
}
sub _grab_a_job {
my TheSchwartz $client = shift;
- my $hashdsn = shift;
- my $driver = $client->driver_for($hashdsn);
+ my $hashdsn = shift;
+ my $driver = $client->driver_for($hashdsn);
## Got some jobs! Randomize them to avoid contention between workers.
my @jobs = shuffle(@_);
- JOB:
- while (my $job = shift @jobs) {
+JOB:
+ while ( my $job = shift @jobs ) {
## Convert the funcid to a funcname, based on this database's map.
- $job->funcname( $client->funcid_to_name($driver, $hashdsn, $job->funcid) );
+ $job->funcname(
+ $client->funcid_to_name( $driver, $hashdsn, $job->funcid ) );
## Update the job's grabbed_until column so that
## no one else takes it.
- my $worker_class = $job->funcname;
+ my $worker_class = $job->funcname;
my $old_grabbed_until = $job->grabbed_until;
my $server_time = $client->get_server_time($driver)
or die "expected a server time";
- $job->grabbed_until($server_time + ($worker_class->grab_for || 1));
+ $job->grabbed_until(
+ $server_time + ( $worker_class->grab_for || 1 ) );
## Update the job in the database, and end the transaction.
- if ($driver->update($job, { grabbed_until => $old_grabbed_until }) < 1) {
+ if ( $driver->update( $job, { grabbed_until => $old_grabbed_until } )
+ < 1 )
+ {
## We lost the race to get this particular job--another worker must
## have got it and already updated it. Move on to the next job.
$T_LOST_RACE->() if $T_LOST_RACE;
@@ -340,19 +427,19 @@ sub _grab_a_job {
}
## Now prepare the job, and return it.
- my $handle = TheSchwartz::JobHandle->new({
- dsn_hashed => $hashdsn,
- jobid => $job->jobid,
- });
+ my $handle = TheSchwartz::JobHandle->new(
+ { dsn_hashed => $hashdsn,
+ jobid => $job->jobid,
+ }
+ );
$handle->client($client);
$job->handle($handle);
return $job;
}
- return undef;
+ return;
}
-
sub shuffled_databases {
my TheSchwartz $client = shift;
my @dsns = keys %{ $client->{databases} };
@@ -361,12 +448,13 @@ sub shuffled_databases {
sub insert_job_to_driver {
my $client = shift;
- my($job, $driver, $hashdsn) = @_;
+ my ( $job, $driver, $hashdsn ) = @_;
eval {
## Set the funcid of the job, based on the funcname. Since each
## database has a separate cache, this needs to be calculated based
## on the hashed DSN. Also: this might fail, if the database is dead.
- $job->funcid( $client->funcname_to_id($driver, $hashdsn, $job->funcname) );
+ $job->funcid(
+ $client->funcname_to_id( $driver, $hashdsn, $job->funcname ) );
## This is sub-optimal because of clock skew, but something is
## better than a NULL value. And currently, nothing in TheSchwartz
@@ -378,21 +466,23 @@ sub insert_job_to_driver {
$driver->insert($job);
};
if ($@) {
- unless (OK_ERRORS->{ $driver->last_error || 0 }) {
+ unless ( OK_ERRORS->{ $driver->last_error || 0 } ) {
$client->mark_database_as_dead($hashdsn);
}
- } elsif ($job->jobid) {
+ }
+ elsif ( $job->jobid ) {
## We inserted the job successfully!
## Attach a handle to the job, and return the handle.
- my $handle = TheSchwartz::JobHandle->new({
- dsn_hashed => $hashdsn,
+ my $handle = TheSchwartz::JobHandle->new(
+ { dsn_hashed => $hashdsn,
client => $client,
jobid => $job->jobid
- });
+ }
+ );
$job->handle($handle);
return $handle;
}
- return undef;
+ return;
}
sub insert_jobs {
@@ -402,18 +492,19 @@ sub insert_jobs {
## Try each of the databases that are registered with $client, in
## random order. If we successfully create the job, exit the loop.
my @handles;
- DATABASE:
- for my $hashdsn ($client->shuffled_databases) {
+DATABASE:
+ for my $hashdsn ( $client->shuffled_databases ) {
## If the database is dead, skip it.
next if $client->is_database_dead($hashdsn);
my $driver = $client->driver_for($hashdsn);
$driver->begin_work;
for my $j (@jobs) {
- my $h = $client->insert_job_to_driver($j, $driver, $hashdsn);
+ my $h = $client->insert_job_to_driver( $j, $driver, $hashdsn );
if ($h) {
push @handles, $h;
- } else {
+ }
+ else {
$driver->rollback;
@handles = ();
next DATABASE;
@@ -430,16 +521,16 @@ sub insert_jobs {
sub insert {
my TheSchwartz $client = shift;
my $job = shift;
- if (ref($_[0]) eq "TheSchwartz::Job") {
+ if ( ref( $_[0] ) eq "TheSchwartz::Job" ) {
croak "Can't insert multiple jobs with method 'insert'\n";
}
- unless (ref($job) eq 'TheSchwartz::Job') {
- $job = TheSchwartz::Job->new_from_array($job, $_[0]);
+ unless ( ref($job) eq 'TheSchwartz::Job' ) {
+ $job = TheSchwartz::Job->new_from_array( $job, $_[0] );
}
## Try each of the databases that are registered with $client, in
## random order. If we successfully create the job, exit the loop.
- for my $hashdsn ($client->shuffled_databases) {
+ for my $hashdsn ( $client->shuffled_databases ) {
## If the database is dead, skip it.
next if $client->is_database_dead($hashdsn);
@@ -447,12 +538,12 @@ sub insert {
## Try to insert the job into this database. If we get a handle
## back, return it.
- my $handle = $client->insert_job_to_driver($job, $driver, $hashdsn);
+ my $handle = $client->insert_job_to_driver( $job, $driver, $hashdsn );
return $handle if $handle;
}
## If the job wasn't submitted successfully to any database, return.
- return undef;
+ return;
}
sub handle_from_string {
@@ -464,14 +555,14 @@ sub handle_from_string {
sub can_do {
my TheSchwartz $client = shift;
- my($class) = @_;
- push @{ $client->{all_abilities} }, $class;
+ my ($class) = @_;
+ push @{ $client->{all_abilities} }, $class;
push @{ $client->{current_abilities} }, $class;
}
sub reset_abilities {
my TheSchwartz $client = shift;
- $client->{all_abilities} = [];
+ $client->{all_abilities} = [];
$client->{current_abilities} = [];
}
@@ -482,37 +573,36 @@ sub restore_full_abilities {
sub temporarily_remove_ability {
my $client = shift;
- my($class) = @_;
- $client->{current_abilities} = [
- grep { $_ ne $class } @{ $client->{current_abilities} }
- ];
- if (!@{ $client->{current_abilities} }) {
+ my ($class) = @_;
+ $client->{current_abilities}
+ = [ grep { $_ ne $class } @{ $client->{current_abilities} } ];
+ if ( !@{ $client->{current_abilities} } ) {
$client->restore_full_abilities;
}
}
sub work_on {
my TheSchwartz $client = shift;
- my $hstr = shift; # Handle string
- my $job = $client->lookup_job($hstr) or
- return 0;
+ my $hstr = shift; # Handle string
+ my $job = $client->lookup_job($hstr)
+ or return 0;
return $client->work_once($job);
}
sub grab_and_work_on {
my TheSchwartz $client = shift;
- my $hstr = shift; # Handle string
- my $job = $client->lookup_job($hstr) or
- return 0;
-
+ my $hstr = shift; # Handle string
+ my $job = $client->lookup_job($hstr)
+ or return 0;
+
## check that the job is grabbable
- my $hashdsn = $job->handle->dsn_hashed;
- my $driver = $client->driver_for($hashdsn);
+ my $hashdsn = $job->handle->dsn_hashed;
+ my $driver = $client->driver_for($hashdsn);
my $current_time = $client->get_server_time($driver);
return 0 if $current_time < $job->grabbed_until;
-
+
## grab the job the usual way
- $job = $client->_grab_a_job($hashdsn, $job)
+ $job = $client->_grab_a_job( $hashdsn, $job )
or return 0;
return $client->work_once($job);
@@ -520,7 +610,7 @@ sub grab_and_work_on {
sub work {
my TheSchwartz $client = shift;
- my($delay) = @_;
+ my ($delay) = @_;
$delay ||= 5;
while (1) {
sleep $delay unless $client->work_once;
@@ -537,7 +627,7 @@ sub work_until_done {
## Returns true if it did something, false if no jobs were found
sub work_once {
my TheSchwartz $client = shift;
- my $job = shift; # optional specific job to work on
+ my $job = shift; # optional specific job to work on
## Look for a job with our current set of abilities. Note that the
## list of current abilities may not be equal to the full set of
@@ -546,8 +636,9 @@ sub work_once {
## If we didn't find anything, restore our full abilities, and try
## again.
- if (!$job &&
- @{ $client->{current_abilities} } < @{ $client->{all_abilities} }) {
+ if ( !$job
+ && @{ $client->{current_abilities} } < @{ $client->{all_abilities} } )
+ {
$client->restore_full_abilities;
$job = $client->find_job_for_workers;
}
@@ -555,8 +646,10 @@ sub work_once {
my $class = $job ? $job->funcname : undef;
if ($job) {
my $priority = $job->priority ? ", priority " . $job->priority : "";
- $job->debug("TheSchwartz::work_once got job of class '$class'$priority");
- } else {
+ $job->debug(
+ "TheSchwartz::work_once got job of class '$class'$priority");
+ }
+ else {
$client->debug("TheSchwartz::work_once found no jobs");
}
@@ -578,17 +671,17 @@ sub work_once {
sub funcid_to_name {
my TheSchwartz $client = shift;
- my($driver, $hashdsn, $funcid) = @_;
+ my ( $driver, $hashdsn, $funcid ) = @_;
my $cache = $client->_funcmap_cache($hashdsn);
return $cache->{funcid2name}{$funcid};
}
sub funcname_to_id {
my TheSchwartz $client = shift;
- my($driver, $hashdsn, $funcname) = @_;
+ my ( $driver, $hashdsn, $funcname ) = @_;
my $cache = $client->_funcmap_cache($hashdsn);
- unless (exists $cache->{funcname2id}{$funcname}) {
- my $map = TheSchwartz::FuncMap->create_or_find($driver, $funcname);
+ unless ( exists $cache->{funcname2id}{$funcname} ) {
+ my $map = TheSchwartz::FuncMap->create_or_find( $driver, $funcname );
$cache->{funcname2id}{ $map->funcname } = $map->funcid;
$cache->{funcid2name}{ $map->funcid } = $map->funcname;
}
@@ -597,11 +690,11 @@ sub funcname_to_id {
sub _funcmap_cache {
my TheSchwartz $client = shift;
- my($hashdsn) = @_;
- unless (exists $client->{funcmap_cache}{$hashdsn}) {
+ my ($hashdsn) = @_;
+ unless ( exists $client->{funcmap_cache}{$hashdsn} ) {
my $driver = $client->driver_for($hashdsn);
- my @maps = $driver->search('TheSchwartz::FuncMap');
- my $cache = { funcname2id => {}, funcid2name => {} };
+ my @maps = $driver->search('TheSchwartz::FuncMap');
+ my $cache = { funcname2id => {}, funcid2name => {} };
for my $map (@maps) {
$cache->{funcname2id}{ $map->funcname } = $map->funcid;
$cache->{funcid2name}{ $map->funcid } = $map->funcname;
@@ -620,8 +713,8 @@ sub verbose {
sub set_verbose {
my TheSchwartz $client = shift;
- my $logger = shift; # or non-coderef to just print to stderr
- if ($logger && ref $logger ne "CODE") {
+ my $logger = shift; # or non-coderef to just print to stderr
+ if ( $logger && ref $logger ne "CODE" ) {
$logger = sub {
my $msg = shift;
$msg =~ s/\s+$//;
@@ -644,7 +737,8 @@ sub set_scoreboard {
return unless $dir;
# They want the scoreboard but don't care where it goes
- if (($dir eq '1') or ($dir eq 'on')) {
+ if ( ( $dir eq '1' ) or ( $dir eq 'on' ) ) {
+
# Find someplace in tmpfs to save this
foreach my $d (qw(/var/run /dev/shm)) {
$dir = $d;
@@ -653,11 +747,12 @@ sub set_scoreboard {
}
$dir .= '/theschwartz';
- unless (-e $dir) {
- mkdir($dir, 0755) or die "Can't create scoreboard directory '$dir': $!";
+ unless ( -e $dir ) {
+ mkdir( $dir, 0755 )
+ or die "Can't create scoreboard directory '$dir': $!";
}
- $client->{scoreboard} = $dir."/scoreboard.$$";
+ $client->{scoreboard} = $dir . "/scoreboard.$$";
}
sub start_scoreboard {
@@ -673,15 +768,18 @@ sub start_scoreboard {
my $class = $job->funcname;
- open(SB, '>', $scoreboard)
- or $job->debug("Could not write scoreboard '$scoreboard': $!");
- print SB join("\n", ("pid=$$",
- 'funcname='.($class||''),
- 'started='.($job->grabbed_until-($class->grab_for||1)),
- 'arg='._serialize_args($job->arg),
- )
- ), "\n";
- close(SB);
+ open( my $SB, '>', $scoreboard )
+ or $job->debug("Could not write scoreboard '$scoreboard': $!");
+ print $SB join(
+ "\n",
+ ( "pid=$$",
+ 'funcname=' . ( $class || '' ),
+ 'started=' . ( $job->grabbed_until - ( $class->grab_for || 1 ) ),
+ 'arg=' . _serialize_args( $job->arg ),
+ )
+ ),
+ "\n";
+ close($SB);
return;
}
@@ -691,17 +789,18 @@ sub start_scoreboard {
sub _serialize_args {
my ($args) = @_;
- if (ref $args) {
- if (ref $args eq 'HASH') {
- return join ',',
- map { ($_||'').'='.substr($args->{$_}||'', 0, 200) }
- keys %$args;
- } elsif (ref $args eq 'ARRAY') {
- return join ',',
- map { substr($_||'', 0, 200) }
- @$args;
+ if ( ref $args ) {
+ if ( ref $args eq 'HASH' ) {
+ return join ',', map {
+ ( $_ || '' ) . '=' . substr( $args->{$_} || '', 0, 200 )
+ }
+ keys %$args;
}
- } else {
+ elsif ( ref $args eq 'ARRAY' ) {
+ return join ',', map { substr( $_ || '', 0, 200 ) } @$args;
+ }
+ }
+ else {
return $args;
}
}
@@ -715,10 +814,10 @@ sub end_scoreboard {
my $job = $client->current_job;
- open(SB, '>>', $scoreboard)
- or $job->debug("Could not append scoreboard '$scoreboard': $!");
- print SB "done=".time."\n";
- close(SB);
+ open( my $SB, '>>', $scoreboard )
+ or $job->debug("Could not append scoreboard '$scoreboard': $!");
+ print $SB "done=" . time . "\n";
+ close($SB);
return;
}
@@ -743,6 +842,28 @@ sub set_prioritize {
$client->{prioritize} = shift;
}
+sub floor {
+ my TheSchwartz $client = shift;
+ return $client->{floor};
+}
+
+sub set_floor {
+ my TheSchwartz $client = shift;
+ die "set_floor only works if prioritize is set."
+ unless ( $client->prioritize );
+ $client->{floor} = shift;
+}
+
+sub batch_size {
+ my TheSchwartz $client = shift;
+ return $client->{batch_size};
+}
+
+sub set_batch_size {
+ my TheSchwartz $client = shift;
+ $client->{batch_size} = shift;
+}
+
# current job being worked. so if something dies, work_safely knows which to mark as dead.
sub current_job {
my TheSchwartz $client = shift;
@@ -756,8 +877,9 @@ sub set_current_job {
DESTROY {
foreach my $arg (@_) {
+
# Call 'clean_scoreboard' on TheSchwartz objects
- if (ref($arg) and $arg->isa('TheSchwartz')) {
+ if ( ref($arg) and $arg->isa('TheSchwartz') ) {
$arg->clean_scoreboard;
}
}
@@ -811,7 +933,7 @@ the system, and your worker processes can pull jobs from the queue atomically
to perform. Failed jobs can be left in the queue to retry later.
I<Abilities> specify what jobs a worker process can perform. Abilities are the
-names of C<TheSchwartz::Worker> subclasses, as in the synopsis: the C<MyWorker>
+names of C<TheSchwartz::Worker> sub-classes, as in the synopsis: the C<MyWorker>
class name is used to specify that the worker script can perform the job. When
using the C<TheSchwartz> client's C<work> functions, the class-ability duality
is used to automatically dispatch to the proper class to do the actual work.
@@ -852,7 +974,7 @@ The database DSN for this database.
=item * C<user>
-The username to use when connecting to this database.
+The user name to use when connecting to this database.
=item * C<pass>
@@ -885,6 +1007,15 @@ A value indicating whether to utilize the job 'priority' field when selecting
jobs to be processed. If unspecified, jobs will always be executed in a
randomized order.
+=item * C<floor>
+
+A value indicating the minimum priority a job needs to be for this worker to
+perform. If unspecified all jobs are considered.
+
+=item * C<batch_size>
+
+A value indicating how many jobs should be fetched from the DB for consideration.
+
=item * C<driver_cache_expiration>
Optional value to control how long database connections are cached for in seconds.
@@ -936,10 +1067,15 @@ much faster since it is can do a btree index lookup
if you want all your jobs to be set up using a handle. defaults to true.
this option might be removed, as you should always have this on a Job object.
+=item * C<jobid>
+
+if you want a specific job you can pass in it's ID and if it's available it
+will be listed.
+
=back
-It is important to remember that this function doesnt lock anything, it just
-returns as many jobs as there is up to amount of databases * FIND_JOB_BATCH_SIZE
+It is important to remember that this function does not lock anything, it just
+returns as many jobs as there is up to amount of databases * $client->{batch_size}
=head2 C<$client-E<gt>lookup_job( $handle_id )>
@@ -962,7 +1098,7 @@ Adds the given C<TheSchwartz::Job> to one of the client's job databases.
=head2 C<$client-E<gt>insert( $funcname, $arg )>
-Adds a new job with funcname C<$funcname> and arguments C<$arg> to the queue.
+Adds a new job with function name C<$funcname> and arguments C<$arg> to the queue.
=head2 C<$client-E<gt>insert_jobs( @jobs )>
@@ -973,6 +1109,14 @@ databases. All the given jobs are recorded in I<one> job database.
Set the C<prioritize> value as described in the constructor.
+=head2 C<$client-E<gt>set_floor( $floor )>
+
+Set the C<floor<gt> value as described in the constructor.
+
+=head2 C<$client-E<gt>set_batch_size( $batch_size )>
+
+Set the C<batch_size<gt> value as described in the constructor.
+
=head1 WORKING
The methods of TheSchwartz clients for use in worker processes are:
@@ -1008,7 +1152,7 @@ Similar to L<$client-E<gt>work_on($handle)>, except that the job will be grabbed
before being run. It guarantees that only one worker will work on it (at least
in the C<grab_for> interval).
-Returns false if the worker couldn't grab the job, and true if the worker worked
+Returns false if the worker could not grab the job, and true if the worker worked
on it.
=head2 C<$client-E<gt>find_job_for_workers( [$abilities] )>
@@ -1037,9 +1181,9 @@ Given an open driver I<$driver> to a database, gets the current server time from
=head1 THE SCOREBOARD
-The scoreboards can be used to monitor what the TheSchwartz::Worker subclasses are
+The scoreboards can be used to monitor what the TheSchwartz::Worker sub-classes are
currently working on. Once the scoreboard has been enabled in the workers with
-C<set_scoreboard> method the C<thetop> utility (shipped with TheSchwartz distribuition
+C<set_scoreboard> method the C<thetop> utility (shipped with TheSchwartz distribution
in the C<extras> directory) can be used to list all current jobs being worked on.
=head2 C<< $client->set_scoreboard( $dir ) >>
@@ -1096,7 +1240,7 @@ rights reserved.
TheSchwartz is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.
-TheScwhartz comes with no warranty of any kind.
+TheSchwartz comes with no warranty of any kind.
=cut
@@ -0,0 +1,16 @@
+-l=78 # Max line width is 78 cols
+-i=4 # Indent level is 4 cols
+-ci=4 # Continuation indent is 4 cols
+-st # Output to STDOUT
+-se # Errors to STDERR
+-vt=2 # Maximal vertical tightness
+-cti=0 # No extra indentation for closing brackets
+-pt=1 # Medium parenthesis tightness
+-bt=1 # Medium brace tightness
+-sbt=1 # Medium square bracket tightness
+-bbt=1 # Medium block brace tightness
+-nsfs # No space before semicolons
+-nolq # Don't outdent long quoted strings
+-wbb="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x="
+ # Break before all operators
+
@@ -14,18 +14,21 @@ use JSON::Any;
my $j = JSON::Any->new;
-my $ts = TheSchwartz->new(databases => [{
- dsn => "dbi:mysql:database=t_sch_unnamed",
- user => "root",
- pass => "",
-}]);
+my $ts = TheSchwartz->new(
+ databases => [
+ { dsn => "dbi:mysql:database=t_sch_unnamed",
+ user => "root",
+ pass => "",
+ }
+ ]
+);
# FIXME: use embedded gearman server, and workers be child processes
my $worker = Gearman::Worker->new;
$worker->job_servers('127.0.0.1:7003');
-$worker->register_function("insert_job" => handler(\&insert_job));
+$worker->register_function( "insert_job" => handler( \&insert_job ) );
$worker->work while 1;
############################################################################
@@ -33,27 +36,27 @@ $worker->work while 1;
sub handler {
my ($code) = @_;
return sub {
- my $job = shift;
- my $arg = $job->arg;
- my $jreq = eval { $j->jsonToObj($job->arg) };
- unless ($jreq) {
- die "not a valid JSON request";
- }
- return $code->($job, $jreq);
+ my $job = shift;
+ my $arg = $job->arg;
+ my $jreq = eval { $j->jsonToObj( $job->arg ) };
+ unless ($jreq) {
+ die "not a valid JSON request";
+ }
+ return $code->( $job, $jreq );
};
}
sub insert_job {
- my ($job, $json) = @_;
+ my ( $job, $json ) = @_;
my $funcname = $json->{funcname} or die "No funcname";
my $job = TheSchwartz::Job->new(
- funcname => $json->{funcname},
- arg => $json->{arg},
- uniqkey => $json->{uniqkey},
- coalesce => $json->{coalesce},
- );
- my $h = $ts->insert($job) or
- die "insert_failure\n";
+ funcname => $json->{funcname},
+ arg => $json->{arg},
+ uniqkey => $json->{uniqkey},
+ coalesce => $json->{coalesce},
+ );
+ my $h = $ts->insert($job)
+ or die "insert_failure\n";
return $h->as_string;
}
@@ -8,9 +8,8 @@ require 't/lib/testlib.pl';
my $db = TestDB->new;
plan tests => 1;
-ok($db, "got a test database");
+ok( $db, "got a test database" );
my $srv = TestServer->new($db);
-ok($srv, "got a test server");
-
+ok( $srv, "got a test server" );
@@ -3,6 +3,7 @@
use strict;
use warnings;
use Test::More;
+
BEGIN {
require 't/lib/testlib.pl';
}
@@ -12,10 +13,10 @@ use Data::Dumper;
my $db = TestDB->new;
plan tests => 1;
-ok($db, "got a test database");
+ok( $db, "got a test database" );
my $srv = TestServer->new($db);
-ok($srv, "got a test server");
+ok( $srv, "got a test server" );
my $cl = $srv->gearman_client;
@@ -24,22 +25,23 @@ my $ret;
# FIXME: test currently requires running gearmand on localhost
{
use IO::Socket::INET;
- my $sock = IO::Socket::INET->new(PeerAddr => "127.0.0.1:7003");
- ok($sock, "local gearmand is up for testing")
+ my $sock = IO::Socket::INET->new( PeerAddr => "127.0.0.1:7003" );
+ ok( $sock, "local gearmand is up for testing" )
or die "can't continue";
}
sub do_req {
my $req = shift;
- my $ret = $cl->do_task("insert_job", json($req));
+ my $ret = $cl->do_task( "insert_job", json($req) );
return undef unless $ret;
return $$ret unless $$ret =~ /^\s*[\[\{]/;
return unjson($$ret);
}
-$ret = do_req({
- funcname => "foo",
- arg => "fooarg",
-});
-like($ret, qr/^\w+-\d+$/, "got a job handle");
+$ret = do_req(
+ { funcname => "foo",
+ arg => "fooarg",
+ }
+);
+like( $ret, qr/^\w+-\d+$/, "got a job handle" );
@@ -24,66 +24,72 @@ sub unjson {
sub test_client {
my %opts = @_;
- my $dbs = delete $opts{dbs};
- my $init = delete $opts{init};
- my $pfx = delete $opts{dbprefix};
+ my $dbs = delete $opts{dbs};
+ my $init = delete $opts{init};
+ my $pfx = delete $opts{dbprefix};
croak "'dbs' not an ARRAY" unless ref $dbs eq "ARRAY";
croak "unknown opts" if %opts;
$init = 1 unless defined $init;
if ($init) {
- setup_dbs({ prefix => $pfx }, $dbs);
+ setup_dbs( { prefix => $pfx }, $dbs );
}
- return TheSchwartz->new(databases => [
- map { {
- dsn => dsn_for($_),
- user => "root",
- pass => "",
- prefix => $pfx,
- } } @$dbs
- ]);
+ return TheSchwartz->new(
+ databases => [
+ map {
+ { dsn => dsn_for($_),
+ user => "root",
+ pass => "",
+ prefix => $pfx,
+ }
+ } @$dbs
+ ]
+ );
}
package TestDB;
use strict;
+
sub new {
my $class = shift;
- my $name = shift || "unnamed";
- my $db = TestDB::MySQL->new($name) || TestDB::SQLite->new($name);
+ my $name = shift || "unnamed";
+ my $db = TestDB::MySQL->new($name) || TestDB::SQLite->new($name);
if ($db) {
- my $dbh = $db->dbh;
- my $schema = $db->schema_file;
- my @sql = _load_sql($schema);
+ my $dbh = $db->dbh;
+ my $schema = $db->schema_file;
+ my @sql = _load_sql($schema);
for my $sql (@sql) {
- $db->alter_create(\$sql);
+ $db->alter_create( \$sql );
$dbh->do($sql);
}
$dbh->disconnect;
- return $db;
+ return $db;
}
eval {
- Test::More::plan(skip_all => "MySQL or SQLite not available for testing");
+ Test::More::plan(
+ skip_all => "MySQL or SQLite not available for testing" );
};
if ($@) {
- return undef;
+ return undef;
}
exit(0);
}
sub dbh {
my ($self) = @_;
- return DBI->connect($self->dsn, "root", "", { RaiseError => 1 });
+ return DBI->connect( $self->dsn, "root", "", { RaiseError => 1 } );
}
sub alter_create {
my $sqlref = shift;
+
# subclasses can override
}
sub _load_sql {
- my($file) = @_;
+ my ($file) = @_;
open my $fh, $file or die "Can't open $file: $!";
my $sql = do { local $/; <$fh> };
close $fh;
@@ -95,13 +101,13 @@ use strict;
use base 'TestDB';
sub new {
- my ($class, $name) = @_;
+ my ( $class, $name ) = @_;
- my $dbh = eval { _mysql_dbh() } or return undef;
+ my $dbh = eval { _mysql_dbh() } or return undef;
my $self = bless {
- basename => $name,
- dbname => "t_sch_$name",
- root_dbh => $dbh,
+ basename => $name,
+ dbname => "t_sch_$name",
+ root_dbh => $dbh,
}, $class;
$dbh->do("DROP DATABASE IF EXISTS $self->{dbname}");
@@ -115,12 +121,12 @@ sub dsn {
}
sub _mysql_dbh {
- return DBI->connect("DBI:mysql:mysql", "root", "", { RaiseError => 1 })
+ return DBI->connect( "DBI:mysql:mysql", "root", "", { RaiseError => 1 } )
or die "Couldn't connect to database";
}
sub alter_create {
- my ($self, $sqlref) = @_;
+ my ( $self, $sqlref ) = @_;
$$sqlref .= " ENGINE=INNODB\n";
}
@@ -140,18 +146,16 @@ package TestServer;
use strict;
sub new {
- my ($class, $db) = @_;
+ my ( $class, $db ) = @_;
$db ||= TestDB->new || return undef;
my $pid = fork;
die "out of memory" unless defined $pid;
if ($pid) {
- return bless {
- pid => $pid,
- }, $class;
+ return bless { pid => $pid, }, $class;
}
my $bin = "$FindBin::Bin/../bin/schwartzd";
- die "Not exist: $bin" unless -e $bin;
+ die "Not exist: $bin" unless -e $bin;
die "Not executable: $bin" unless -x $bin;
exec $bin;
die "Failed to exec test schwartzd!";
@@ -159,15 +163,15 @@ sub new {
sub gearman_client {
my $self = shift;
- my $cl = Gearman::Client->new;
+ my $cl = Gearman::Client->new;
$cl->job_servers('127.0.0.1:7003');
return $cl;
}
sub DESTROY {
my $self = shift;
- if ($self->{pid}) {
- kill 9, $self->{pid};
+ if ( $self->{pid} ) {
+ kill 9, $self->{pid};
}
}
@@ -11,59 +11,75 @@ use Storable;
# been inserted into the database because we have no client object
# yet with which to insert.
-my $args = { scoops => 2, with => ['cheese','love'] };
+my $args = { scoops => 2, with => [ 'cheese', 'love' ] };
my $fargs = Storable::nfreeze($args);
-my $job1 = TheSchwartz::Job->new_from_array("feedmajor", $fargs);
-isa_ok($job1, 'TheSchwartz::Job');
-my $job2 = TheSchwartz::Job->new_from_array("feedmajor", \$fargs);
-isa_ok($job2, 'TheSchwartz::Job');
-my $job3 = TheSchwartz::Job->new(funcname => 'feedmajor', arg => $args);
-isa_ok($job3, 'TheSchwartz::Job');
-my $job4 = TheSchwartz::Job->new(funcname => 'feedmajor', arg => $fargs);
-isa_ok($job4, 'TheSchwartz::Job');
-my $job5 = TheSchwartz::Job->new(funcname => 'feedmajor', arg => \$fargs);
-isa_ok($job5, 'TheSchwartz::Job');
+my $job1 = TheSchwartz::Job->new_from_array( "feedmajor", $fargs );
+isa_ok( $job1, 'TheSchwartz::Job' );
+my $job2 = TheSchwartz::Job->new_from_array( "feedmajor", \$fargs );
+isa_ok( $job2, 'TheSchwartz::Job' );
+my $job3 = TheSchwartz::Job->new( funcname => 'feedmajor', arg => $args );
+isa_ok( $job3, 'TheSchwartz::Job' );
+my $job4 = TheSchwartz::Job->new( funcname => 'feedmajor', arg => $fargs );
+isa_ok( $job4, 'TheSchwartz::Job' );
+my $job5 = TheSchwartz::Job->new( funcname => 'feedmajor', arg => \$fargs );
+isa_ok( $job5, 'TheSchwartz::Job' );
-is_deeply($job1->column_values, $job2->column_values, "job2 is equivalent");
-is_deeply($job1->column_values, $job3->column_values, "job3 is equivalent");
-is_deeply($job1->column_values, $job4->column_values, "job4 is equivalent");
-is_deeply($job1->column_values, $job5->column_values, "job5 is equivalent");
+is_deeply( $job1->column_values, $job2->column_values, "job2 is equivalent" );
+is_deeply( $job1->column_values, $job3->column_values, "job3 is equivalent" );
+is_deeply( $job1->column_values, $job4->column_values, "job4 is equivalent" );
+is_deeply( $job1->column_values, $job5->column_values, "job5 is equivalent" );
my $job6 = TheSchwartz::Job->new(
- funcname => 'feeddog',
- run_after => time() + 60,
- priority => 7,
- arg => { scoops => 2, with => ['cheese','love'] },
- coalesce => 'major',
- jobid => int(rand()*5000),
- );
+ funcname => 'feeddog',
+ run_after => time() + 60,
+ priority => 7,
+ arg => { scoops => 2, with => [ 'cheese', 'love' ] },
+ coalesce => 'major',
+ jobid => int( rand() * 5000 ),
+);
isa_ok $job6, 'TheSchwartz::Job';
# second arg can also be an arrayref
-my $job_a1 = TheSchwartz::Job->new_from_array("feedmajor", [ 'cheese', 'water', 'beer' ]);
-my $job_a2 = TheSchwartz::Job->new(funcname => "feedmajor",
- arg => [ 'cheese', 'water', 'beer' ]);
-is_deeply($job_a1->column_values, $job_a2->column_values, "ctors with arrayrefs match");
+my $job_a1 = TheSchwartz::Job->new_from_array( "feedmajor",
+ [ 'cheese', 'water', 'beer' ] );
+my $job_a2 = TheSchwartz::Job->new(
+ funcname => "feedmajor",
+ arg => [ 'cheese', 'water', 'beer' ]
+);
+is_deeply( $job_a1->column_values, $job_a2->column_values,
+ "ctors with arrayrefs match" );
-my $jobbad = eval { TheSchwartz::Job->new(
- funcname => 'feeddog',
- run_atter => time() + 60, # [sic] typo
- ) };
-ok(!$jobbad, "no bad job");
-ok($@, "error creating job with bad argument");
+my $jobbad = eval {
+ TheSchwartz::Job->new(
+ funcname => 'feeddog',
+ run_atter => time() + 60, # [sic] typo
+ );
+};
+ok( !$jobbad, "no bad job" );
+ok( $@, "error creating job with bad argument" );
# can't have multiple non-ref args
-$jobbad = eval { TheSchwartz::Job->new_from_array("feeddog", "scalar1", "scalar2") };
-ok(!$jobbad, "no bad job");
-ok($@, "error creating job with bad argument");
+$jobbad = eval {
+ TheSchwartz::Job->new_from_array( "feeddog", "scalar1", "scalar2" );
+};
+ok( !$jobbad, "no bad job" );
+ok( $@, "error creating job with bad argument" );
# can't have multiple non-ref args, even if first is scalarref
-$jobbad = eval { TheSchwartz::Job->new_from_array("feeddog", \ "scalar1", "scalar2") };
-ok(!$jobbad, "no bad job");
-ok($@, "error creating job with bad argument");
+$jobbad = eval {
+ TheSchwartz::Job->new_from_array( "feeddog", \"scalar1", "scalar2" );
+};
+ok( !$jobbad, "no bad job" );
+ok( $@, "error creating job with bad argument" );
# can't have multiple non-ref args, even if first is hashrf
-$jobbad = eval { TheSchwartz::Job->new_from_array("feeddog", { with => 'poison' }, { extra => 'arg' }); };
-ok(!$jobbad, "no bad job");
-ok($@, "error creating job with bad argument");
+$jobbad = eval {
+ TheSchwartz::Job->new_from_array(
+ "feeddog",
+ { with => 'poison' },
+ { extra => 'arg' }
+ );
+};
+ok( !$jobbad, "no bad job" );
+ok( $@, "error creating job with bad argument" );
@@ -7,111 +7,136 @@ use warnings;
require 't/lib/db-common.pl';
use TheSchwartz;
-use Test::More tests => 54*3;
-
-run_tests(54, sub {
- foreach my $pfx ("", "testprefix_") {
-
- my $client = test_client(dbs => ['ts1'],
- dbprefix => $pfx,
- );
-
- my $handle;
-
- $handle = $client->insert("feedmajor", { scoops => 2, with => ['cheese','love'] });
- isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
- is($handle->is_pending, 1, "job is still pending");
- is($handle->exit_status, undef, "job hasn't exitted yet");
-
- # to give to javascript, perl, etc...
- my $hstr = $handle->as_string; # <digestofdsn>-<jobid>
- ok($hstr, "handle stringifies");
-
- my $job = $handle->job;
- isa_ok $job, 'TheSchwartz::Job';
- is $job->funcname, 'feedmajor', 'handle->job gives us the right job';
- cmp_ok $job->insert_time, '>', 0, 'insert_time is non-zero';
-
- # getting a handle object back
- my $hand2 = $client->handle_from_string($hstr);
- ok($hand2, "handle recreated from stringified version");
- is($handle->is_pending, 1, "job is still pending");
- is($handle->exit_status, undef, "job hasn't exitted yet");
-
- $job = $handle->job;
- isa_ok $job, 'TheSchwartz::Job';
- is $job->funcname, 'feedmajor', 'recreated handle gives us the right job';
-
- $job = TheSchwartz::Job->new(
- funcname => 'feedmajor',
- run_after=> time() + 60,
- priority => 7,
- arg => { scoops => 2, with => ['cheese','love'] },
- coalesce => 'major',
- jobid => int rand(5000),
- );
- ok($job);
-
- $handle = $client->insert($job);
- isa_ok $handle, 'TheSchwartz::JobHandle';
-
- # inserting multiple at a time in scalar context
- {
- my $job1 = TheSchwartz::Job->new(funcname => 'feedmajor');
- my $job2 = TheSchwartz::Job->new(funcname => 'feedmajor');
- my $rv = $client->insert_jobs($job1, $job2);
- is($rv, 2, "inserted two jobs");
- }
-
- # inserting multiple at a time in list context
- {
- my $job1 = TheSchwartz::Job->new(funcname => 'feedmajor');
- my $job2 = TheSchwartz::Job->new(funcname => 'feedmajor');
- my @handles = $client->insert_jobs($job1, $job2);
- is(scalar @handles, 2, "inserted two jobs");
- isa_ok $handles[0], 'TheSchwartz::JobHandle', "got job handle";
- }
+use Test::More tests => 58 * 3;
+
+run_tests(
+ 58,
+ sub {
+ foreach my $pfx ( "", "testprefix_" ) {
+
+ my $client = test_client(
+ dbs => ['ts1'],
+ dbprefix => $pfx,
+ );
+
+ my $handle;
+
+ $handle = $client->insert( "feedmajor",
+ { scoops => 2, with => [ 'cheese', 'love' ] } );
+ isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
+ is( $handle->is_pending, 1, "job is still pending" );
+ is( $handle->exit_status, undef, "job hasn't exitted yet" );
+
+ # to give to javascript, perl, etc...
+ my $hstr = $handle->as_string; # <digestofdsn>-<jobid>
+ ok( $hstr, "handle stringifies" );
+
+ my $job = $handle->job;
+ isa_ok $job, 'TheSchwartz::Job';
+ is $job->funcname, 'feedmajor',
+ 'handle->job gives us the right job';
+ cmp_ok $job->insert_time, '>', 0, 'insert_time is non-zero';
+
+ # getting a handle object back
+ my $hand2 = $client->handle_from_string($hstr);
+ ok( $hand2, "handle recreated from stringified version" );
+ is( $handle->is_pending, 1, "job is still pending" );
+ is( $handle->exit_status, undef, "job hasn't exitted yet" );
+
+ $job = $handle->job;
+ isa_ok $job, 'TheSchwartz::Job';
+ is $job->funcname, 'feedmajor',
+ 'recreated handle gives us the right job';
+
+ # grab an job by ID.
+ my $id = $job->jobid;
+ my @jobs = $client->list_jobs(
+ { funcname => 'feedmajor', jobid => $id } );
+ is( scalar @jobs, 1, 'one job' );
+ is( $jobs[0]->jobid, $id, 'expected jobid' );
- # inserting with a regular scalar arg
- {
$job = TheSchwartz::Job->new(
- funcname => 'feedmajor',
- arg => "gruel that's longer than 11 bytes, for sure!",
- );
+ funcname => 'feedmajor',
+ run_after => time() + 60,
+ priority => 7,
+ arg => { scoops => 2, with => [ 'cheese', 'love' ] },
+ coalesce => 'major',
+ jobid => int rand(5000),
+ );
ok($job);
+
$handle = $client->insert($job);
isa_ok $handle, 'TheSchwartz::JobHandle';
-
- my $same = $client->lookup_job($handle->as_string);
- ok $same;
- isa_ok $same, 'TheSchwartz::Job';
- is $same->handle->as_string, $handle->as_string;
-
- }
-
- ## Just test that handles for unknown database croak with an explicit message
- {
- eval { $client->lookup_job( ("6a" x 16) ."-666") };
- ok $@ && unlike($@, qr/No Driver/) && like($@, qr/database.*hash/);
- }
- # inserting multiple with wrong method fails
- eval {
- my $job1 = TheSchwartz::Job->new(funcname => 'feedmajor');
- my $job2 = TheSchwartz::Job->new(funcname => 'feedmajor');
- my @handles = $client->insert($job1, $job2);
- };
- like($@, qr/multiple jobs with method/, "used wrong method");
-
- # insert multiple that fail
- {
- my $job1 = TheSchwartz::Job->new(funcname => 'feedmajor', uniqkey => 'u1');
- my $job2 = TheSchwartz::Job->new(funcname => 'feedmajor', uniqkey => 'u1');
- my @handles = $client->insert_jobs($job1, $job2);
- is(scalar @handles, 0, "failed to insert anything");
+ # inserting multiple at a time in scalar context
+ {
+ my $job1 = TheSchwartz::Job->new( funcname => 'feedmajor' );
+ my $job2 = TheSchwartz::Job->new( funcname => 'feedmajor' );
+ my $rv = $client->insert_jobs( $job1, $job2 );
+ is( $rv, 2, "inserted two jobs" );
+ }
+
+ # inserting multiple at a time in list context
+ {
+ my $job1 = TheSchwartz::Job->new( funcname => 'feedmajor' );
+ my $job2 = TheSchwartz::Job->new( funcname => 'feedmajor' );
+ my @handles = $client->insert_jobs( $job1, $job2 );
+ is( scalar @handles, 2, "inserted two jobs" );
+ isa_ok $handles[0], 'TheSchwartz::JobHandle',
+ "got job handle";
+ }
+
+ # inserting with a regular scalar arg
+ {
+ $job = TheSchwartz::Job->new(
+ funcname => 'feedmajor',
+ arg => "gruel that's longer than 11 bytes, for sure!",
+ );
+ ok($job);
+ $handle = $client->insert($job);
+ isa_ok $handle, 'TheSchwartz::JobHandle';
+
+ my $same = $client->lookup_job( $handle->as_string );
+ ok $same;
+ isa_ok $same, 'TheSchwartz::Job';
+ is $same->handle->as_string, $handle->as_string;
+
+ }
+
+ ## Just test that handles for unknown database croak with an explicit message
+ {
+ eval { $client->lookup_job( ( "6a" x 16 ) . "-666" ) };
+ ok $@
+ && unlike( $@, qr/No Driver/ )
+ && like( $@, qr/database.*hash/ );
+ }
+
+ # inserting multiple with wrong method fails
+ eval {
+ my $job1 = TheSchwartz::Job->new( funcname => 'feedmajor' );
+ my $job2 = TheSchwartz::Job->new( funcname => 'feedmajor' );
+ my @handles = $client->insert( $job1, $job2 );
+ };
+ like( $@, qr/multiple jobs with method/, "used wrong method" );
+
+ # insert multiple that fail
+ {
+ my $job1 = TheSchwartz::Job->new(
+ funcname => 'feedmajor',
+ uniqkey => 'u1'
+ );
+ my $job2 = TheSchwartz::Job->new(
+ funcname => 'feedmajor',
+ uniqkey => 'u1'
+ );
+ my @handles = $client->insert_jobs( $job1, $job2 );
+ is( scalar @handles, 0, "failed to insert anything" );
+ }
+
+ teardown_dbs('ts1');
}
+ }
+);
+done_testing();
- teardown_dbs('ts1');
- }
-});
@@ -9,79 +9,93 @@ use TheSchwartz;
use Test::More tests => 30;
# for testing:
-$TheSchwartz::T_EXITSTATUS_CLEAN_THRES = 1; # delete 100% of the time, not 10% of the time
-$TheSchwartz::T_ERRORS_MAX_AGE = 2; # keep errors for 3 seconds, not 1 week
-
-run_tests(10, sub {
- my $client = test_client(dbs => ['ts1']);
- my $dbh = DBI->connect(dsn_for("ts1"), $ENV{TS_DB_USER}, $ENV{TS_DB_PASS});
- $client->can_do("Worker::Fail");
- $client->can_do("Worker::Complete");
-
- # insert a job which will fail, then succeed.
- {
- my $handle = $client->insert("Worker::Fail");
- isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
-
- $client->work_until_done;
- is($handle->failures, 1, "job has failed once");
-
- my $min;
- my $rows = $dbh->selectrow_array("SELECT COUNT(*) FROM exitstatus");
- is($rows, 1, "has 1 exitstatus row");
-
- ok($client->insert("Worker::Complete"), "inserting to-pass job");
- $client->work_until_done;
- $rows = $dbh->selectrow_array("SELECT COUNT(*) FROM exitstatus");
- is($rows, 2, "has 2 exitstatus rows");
- ($rows, $min) = $dbh->selectrow_array("SELECT COUNT(*), MIN(jobid) FROM error");
- is($rows, 1, "has 1 error rows");
- is($min, 1, "error jobid is the old one");
-
- # wait for exit status to pass
- sleep 3;
-
- # now make another job fail to cleanup some errors
- $handle = $client->insert("Worker::Fail");
- $client->work_until_done;
-
- $rows = $dbh->selectrow_array("SELECT COUNT(*) FROM exitstatus");
- is($rows, 1, "1 exit status row now");
-
- ($rows, $min) = $dbh->selectrow_array("SELECT COUNT(*), MIN(jobid) FROM error");
- is($rows, 1, "has 1 error row still");
- is($min, 3, "error jobid is only the new one");
-
+$TheSchwartz::T_EXITSTATUS_CLEAN_THRES
+ = 1; # delete 100% of the time, not 10% of the time
+$TheSchwartz::T_ERRORS_MAX_AGE = 2; # keep errors for 3 seconds, not 1 week
+
+run_tests(
+ 10,
+ sub {
+ my $client = test_client( dbs => ['ts1'] );
+ my $dbh = DBI->connect( dsn_for("ts1"), $ENV{TS_DB_USER},
+ $ENV{TS_DB_PASS} );
+ $client->can_do("Worker::Fail");
+ $client->can_do("Worker::Complete");
+
+ # insert a job which will fail, then succeed.
+ {
+ my $handle = $client->insert("Worker::Fail");
+ isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
+
+ $client->work_until_done;
+ is( $handle->failures, 1, "job has failed once" );
+
+ my $min;
+ my $rows
+ = $dbh->selectrow_array("SELECT COUNT(*) FROM exitstatus");
+ is( $rows, 1, "has 1 exitstatus row" );
+
+ ok( $client->insert("Worker::Complete"),
+ "inserting to-pass job" );
+ $client->work_until_done;
+ $rows = $dbh->selectrow_array("SELECT COUNT(*) FROM exitstatus");
+ is( $rows, 2, "has 2 exitstatus rows" );
+ ( $rows, $min )
+ = $dbh->selectrow_array(
+ "SELECT COUNT(*), MIN(jobid) FROM error");
+ is( $rows, 1, "has 1 error rows" );
+ is( $min, 1, "error jobid is the old one" );
+
+ # wait for exit status to pass
+ sleep 3;
+
+ # now make another job fail to cleanup some errors
+ $handle = $client->insert("Worker::Fail");
+ $client->work_until_done;
+
+ $rows = $dbh->selectrow_array("SELECT COUNT(*) FROM exitstatus");
+ is( $rows, 1, "1 exit status row now" );
+
+ ( $rows, $min )
+ = $dbh->selectrow_array(
+ "SELECT COUNT(*), MIN(jobid) FROM error");
+ is( $rows, 1, "has 1 error row still" );
+ is( $min, 3, "error jobid is only the new one" );
+
+ }
+
+ teardown_dbs('ts1');
}
-
- teardown_dbs('ts1');
-});
+);
############################################################################
package Worker::Fail;
use base 'TheSchwartz::Worker';
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
$job->failed("an error message");
return;
}
-sub keep_exit_status_for { 1 } # keep exit status for 20 seconds after on_complete
+sub keep_exit_status_for {
+ 1
+} # keep exit status for 20 seconds after on_complete
-sub max_retries { 0 }
+sub max_retries {0}
-sub retry_delay { 1 }
+sub retry_delay {1}
# ---------------
package Worker::Complete;
use base 'TheSchwartz::Worker';
+
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
$job->completed;
return;
}
-sub keep_exit_status_for { 1 }
+sub keep_exit_status_for {1}
@@ -12,7 +12,9 @@ use strict;
use warnings;
# make time() be overridable in the future at runtime, rather than be an opcode:
-BEGIN { *CORE::GLOBAL::time = sub { time() }; }
+BEGIN {
+ *CORE::GLOBAL::time = sub { time() };
+}
no warnings 'redefine';
require 't/lib/db-common.pl';
@@ -21,54 +23,58 @@ use TheSchwartz;
use Test::More tests => 2;
# how we keep track of if job was done twice: signal from children back up to us
-my $got_job = 0;
+my $got_job = 0;
my $got_done = 0;
$SIG{USR1} = sub { $got_job++; };
$SIG{USR2} = sub { $got_done++; };
# kill children on exit
-my %children; # pid -> 1
+my %children; # pid -> 1
my $parent = $$;
+
END {
- if ($$ == $parent) {
+ if ( $$ == $parent ) {
my @pids = keys %children;
kill 9, @pids if @pids;
}
}
-run_tests_innodb(2, sub {
+run_tests_innodb(
+ 2,
+ sub {
- # put one job into database
- my $client = test_client(dbs => ['ts1']);
- $client->insert("Worker::Addition", { numbers => [1, 2] })
- or die;
+ # put one job into database
+ my $client = test_client( dbs => ['ts1'] );
+ $client->insert( "Worker::Addition", { numbers => [ 1, 2 ] } )
+ or die;
- # two children to race. this one with normal time:
- work();
+ # two children to race. this one with normal time:
+ work();
- # let first dude get started first
- select(undef, undef, undef, 1.5);
+ # let first dude get started first
+ select( undef, undef, undef, 1.5 );
- # make this worker 60 seconds in the future: (well past the grabbed until time)
- work(60);
+# make this worker 60 seconds in the future: (well past the grabbed until time)
+ work(60);
- # hang out waiting for children to finish or timeout
- my $now = time();
- while ($got_done < 2 && time() < $now + 7) {
- sleep 1;
- }
+ # hang out waiting for children to finish or timeout
+ my $now = time();
+ while ( $got_done < 2 && time() < $now + 7 ) {
+ sleep 1;
+ }
- is($got_done, 2, "two children finished");
- is($got_job, 1, "only did one job");
+ is( $got_done, 2, "two children finished" );
+ is( $got_job, 1, "only did one job" );
- teardown_dbs('ts1');
-});
+ teardown_dbs('ts1');
+ }
+);
sub work {
my $future = shift;
# parent:
- if (my $childpid = fork()) {
+ if ( my $childpid = fork() ) {
$children{$childpid} = 1;
return;
}
@@ -77,12 +83,13 @@ sub work {
*CORE::GLOBAL::time = sub { CORE::time() + $future };
}
- my $client = test_client(dbs => ['ts1'],
- init => 0);
-
+ my $client = test_client(
+ dbs => ['ts1'],
+ init => 0
+ );
# child:
- while (my $job = Worker::Addition->grab_job($client)) {
+ while ( my $job = Worker::Addition->grab_job($client) ) {
eval { Worker::Addition->work($job); };
}
@@ -95,7 +102,7 @@ package Worker::Addition;
use base 'TheSchwartz::Worker';
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
sleep 3;
kill 'USR1', getppid();
$job->completed;
@@ -104,5 +111,5 @@ sub work {
# tell framework to set 'grabbed_until' to time() + 60. because if
# we can't add some numbers in 30 seconds, our process probably
# failed and work should be reassigned.
-sub grab_for { 5 }
+sub grab_for {5}
@@ -8,36 +8,39 @@ require 't/lib/db-common.pl';
use TheSchwartz;
use Test::More tests => 14 * 3;
-run_tests(14, sub {
- my $client = test_client(dbs => ['ts1']);
-
- my @keys = qw(foo bar baz);
- my $n = 0;
- for (1..10) {
- my $key = $keys[$n++ % 3];
- my $job = TheSchwartz::Job->new(
- funcname => 'Worker::CoalesceTest',
- arg => { key => $key, num => $_ },
- coalesce => $key
- );
- my $h = $client->insert($job);
- ok($h, "inserted $h ($_ = $key)");
- }
+run_tests(
+ 14,
+ sub {
+ my $client = test_client( dbs => ['ts1'] );
+
+ my @keys = qw(foo bar baz);
+ my $n = 0;
+ for ( 1 .. 10 ) {
+ my $key = $keys[ $n++ % 3 ];
+ my $job = TheSchwartz::Job->new(
+ funcname => 'Worker::CoalesceTest',
+ arg => { key => $key, num => $_ },
+ coalesce => $key
+ );
+ my $h = $client->insert($job);
+ ok( $h, "inserted $h ($_ = $key)" );
+ }
- $client->reset_abilities;
- $client->can_do("Worker::CoalesceTest");
+ $client->reset_abilities;
+ $client->can_do("Worker::CoalesceTest");
- Worker::CoalesceTest->set_client($client);
+ Worker::CoalesceTest->set_client($client);
- for (1..3) {
+ for ( 1 .. 3 ) {
+ my $rv = eval { $client->work_once; };
+ ok( $rv, "did stuff" );
+ }
my $rv = eval { $client->work_once; };
- ok($rv, "did stuff");
- }
- my $rv = eval { $client->work_once; };
- ok(!$rv, "nothing to do now");
+ ok( !$rv, "nothing to do now" );
- teardown_dbs('ts1');
-});
+ teardown_dbs('ts1');
+ }
+);
############################################################################
package Worker::CoalesceTest;
@@ -47,28 +50,41 @@ my $client;
sub set_client { $client = $_[1]; }
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
my $args = $job->arg;
my $key = $args->{key};
$job->completed;
- if ($key eq "foo") {
- while (my $job = $client->find_job_with_coalescing_prefix("Worker::CoalesceTest", "f")) {
+ if ( $key eq "foo" ) {
+ while (
+ my $job = $client->find_job_with_coalescing_prefix(
+ "Worker::CoalesceTest", "f"
+ )
+ )
+ {
$job->completed;
}
- } else {
- while (my $job = $client->find_job_with_coalescing_value("Worker::CoalesceTest", $key)) {
+ }
+ else {
+ while (
+ my $job = $client->find_job_with_coalescing_value(
+ "Worker::CoalesceTest", $key
+ )
+ )
+ {
$job->completed;
}
}
}
-sub keep_exit_status_for { 20 } # keep exit status for 20 seconds after on_complete
+sub keep_exit_status_for {
+ 20
+} # keep exit status for 20 seconds after on_complete
-sub grab_for { 10 }
+sub grab_for {10}
-sub max_retries { 1 }
+sub max_retries {1}
-sub retry_delay { my $class = shift; my $fails = shift; return 2 ** $fails; }
+sub retry_delay { my $class = shift; my $fails = shift; return 2**$fails; }
@@ -9,37 +9,43 @@ require 't/lib/db-common.pl';
use TheSchwartz;
use Test::More tests => 6;
-run_tests(2, sub {
- setup_dbs('ts1');
- teardown_dbs('ts2'); # doesn't exist
-
- my $client = test_client(dbs => ['ts2', 'ts1'],
- init => 0);
-
- # insert a job
- my $n_handles = 0;
- for (1..50) {
- my $handle = $client->insert("Worker::Addition", { numbers => [1, 2] });
- $n_handles++ if $handle;
+run_tests(
+ 2,
+ sub {
+ setup_dbs('ts1');
+ teardown_dbs('ts2'); # doesn't exist
+
+ my $client = test_client(
+ dbs => [ 'ts2', 'ts1' ],
+ init => 0
+ );
+
+ # insert a job
+ my $n_handles = 0;
+ for ( 1 .. 50 ) {
+ my $handle = $client->insert( "Worker::Addition",
+ { numbers => [ 1, 2 ] } );
+ $n_handles++ if $handle;
+ }
+ is( $n_handles, 50, "got 50 handles" );
+
+# let's do some work. the tedious way, specifying which class should grab a job
+ my $n_grabbed = 0;
+ while ( my $job = Worker::Addition->grab_job($client) ) {
+ $n_grabbed++;
+ }
+ is( $n_grabbed, 50, "grabbed 50 times" );
+
+ teardown_dbs('ts1');
}
- is($n_handles, 50, "got 50 handles");
-
- # let's do some work. the tedious way, specifying which class should grab a job
- my $n_grabbed = 0;
- while (my $job = Worker::Addition->grab_job($client)) {
- $n_grabbed++;
- }
- is($n_grabbed, 50, "grabbed 50 times");
-
- teardown_dbs('ts1');
-});
+);
############################################################################
package Worker::Addition;
use base 'TheSchwartz::Worker';
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
# ....
}
@@ -47,5 +53,5 @@ sub work {
# tell framework to set 'grabbed_until' to time() + 60. because if
# we can't add some numbers in 30 seconds, our process probably
# failed and work should be reassigned.
-sub grab_for { 30 }
+sub grab_for {30}
@@ -4,52 +4,130 @@ use warnings;
require 't/lib/db-common.pl';
use TheSchwartz;
-use Test::More;
+use Test::More tests => (5 + 21) * 3;
-run_tests(8, sub {
- my $client = test_client(dbs => ['ts1']);
+our $decline = 1;
- # insert a job which will fail, fail, then succeed.
- {
- my $handle = $client->insert("Worker::CompleteEventually");
- isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
+run_tests(
+ 5,
+ sub {
+ my $client = test_client( dbs => ['ts1'] );
- $client->can_do("Worker::CompleteEventually");
- $client->work_until_done;
+ # insert a job which will fail, fail, then succeed.
+ {
+ my $handle = $client->insert("Worker::CompleteEventually");
+ isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
- is($handle->failures, 0, "job hasn't failed");
- is($handle->is_pending, 1, "job is still pending");
+ $client->can_do("Worker::CompleteEventually");
+ $client->work_until_done;
- my $job = Worker::CompleteEventually->grab_job($client);
- ok(!$job, "a job isn't ready yet"); # hasn't been two seconds
- sleep 3; # 2 seconds plus 1 buffer second
+ is( $handle->failures, 0, "job hasn't failed" );
+ is( $handle->is_pending, 1, "job is still pending" );
- $job = Worker::CompleteEventually->grab_job($client);
- ok(!$job, "didn't get a job, because job is 'held' not retrying");
- }
+ my $job = Worker::CompleteEventually->grab_job($client);
+ ok( !$job, "a job isn't ready yet" ); # hasn't been two seconds
+ sleep 3; # 2 seconds plus 1 buffer second
+
+ $job = Worker::CompleteEventually->grab_job($client);
+ ok( !$job,
+ "didn't get a job, because job is 'held' not retrying" );
+ }
- teardown_dbs('ts1');
-});
+ teardown_dbs('ts1');
+ }
+);
+
+run_tests(
+ 21,
+ sub {
+ my $client = test_client( dbs => ['ts2'] );
+
+ {
+ $decline = 1;
+ $client->reset_abilities;
+ $client->can_do("Worker::DeclineWithTime");
+ $client->verbose(1);
+ Worker::DeclineWithTime->set_client($client);
+
+ for ( 1 .. 5 ) {
+ my $job = TheSchwartz::Job->new(
+ funcname => 'Worker::DeclineWithTime',
+ arg => { num => $_ },
+ );
+ my $h = $client->insert($job);
+ ok( $h, "inserted job $_" );
+ }
+
+ for ( 1 .. 5 ) {
+ my $rv = eval { $client->work_once; };
+ ok( $rv, "did stuff 1-5" );
+ }
+
+ my $job = Worker::DeclineWithTime->grab_job($client);
+ ok( !$job, "didn't get a job, because run_after" );
+
+ sleep 5;
+
+ $decline = 0;
+
+ for ( 1 .. 5 ) {
+ my $rv = eval { $client->work_once; };
+ ok( $rv, "end stuff 1-5" );
+ }
+ }
+
+ teardown_dbs('ts2');
+ }
+);
-done_testing;
+done_testing();
############################################################################
package Worker::CompleteEventually;
use base 'TheSchwartz::Worker';
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
$job->declined;
return;
}
-sub keep_exit_status_for { 20 } # keep exit status for 20 seconds after on_complete
+sub keep_exit_status_for {
+ 20;
+} # keep exit status for 20 seconds after on_complete
-sub max_retries { 2 }
+sub max_retries {2}
sub retry_delay {
my $class = shift;
my $fails = shift;
- return [undef,2,0]->[$fails]; # fails 2 seconds first time, then immediately
+ return [ undef, 2, 0 ]->[$fails]
+ ; # fails 2 seconds first time, then immediately
+}
+
+1;
+############################################################################
+package Worker::DeclineWithTime;
+use base 'TheSchwartz::Worker';
+use strict;
+use Test::More;
+
+my $client;
+sub set_client { $client = $_[1]; }
+
+sub work {
+ my ( $class, $job ) = @_;
+ if ($main::decline) {
+ $job->declined( time() + 2 );
+ }
+ else {
+ ok( $job->run_after < time(), 'ensure time out' );
+ }
+
+ return;
}
+sub keep_exit_status_for {
+ 20;
+} # keep exit status for 20 seconds after on_complete
+1;
@@ -9,27 +9,33 @@ require 't/lib/db-common.pl';
use TheSchwartz;
use Test::More tests => 9;
-run_tests(3, sub {
- teardown_dbs("tempty1");
-
- my $client = TheSchwartz->new(databases => [
- {
- dsn => dsn_for('tempty1'),
- user => $ENV{TS_DB_USER},
- pass => $ENV{TS_DB_PASS},
- },
- ]);
-
- # insert a job
- {
- my $handle;
- $handle = $client->insert("Worker::Addition", { numbers => [1, 2] });
- ok(!$handle, "can't insert into empty database");
- $handle = $client->insert("Worker::Addition", { numbers => [1, 2] });
- ok(!$handle, "still can't insert into empty database");
+run_tests(
+ 3,
+ sub {
+ teardown_dbs("tempty1");
+
+ my $client = TheSchwartz->new(
+ databases => [
+ { dsn => dsn_for('tempty1'),
+ user => $ENV{TS_DB_USER},
+ pass => $ENV{TS_DB_PASS},
+ },
+ ]
+ );
+
+ # insert a job
+ {
+ my $handle;
+ $handle = $client->insert( "Worker::Addition",
+ { numbers => [ 1, 2 ] } );
+ ok( !$handle, "can't insert into empty database" );
+ $handle = $client->insert( "Worker::Addition",
+ { numbers => [ 1, 2 ] } );
+ ok( !$handle, "still can't insert into empty database" );
+ }
+
+ ok( 1, "test finishes" );
+ teardown_dbs("tempty1");
}
-
- ok(1, "test finishes");
- teardown_dbs("tempty1");
-});
+);
@@ -9,54 +9,62 @@ require 't/lib/db-common.pl';
use TheSchwartz;
use Test::More tests => 12;
-run_tests(4, sub {
- my $client = test_client(dbs => ['ts1', 'ts2']);
-
- my $n_jobs = 60;
- for (1..$n_jobs) {
- my $handle = $client->insert("Worker::Foo");
- die unless $handle;
- }
-
- my $db1 = DBI->connect(dsn_for("ts1"), $ENV{TS_DB_USER}, $ENV{TS_DB_PASS});
- my $db2 = DBI->connect(dsn_for("ts2"), $ENV{TS_DB_USER}, $ENV{TS_DB_PASS});
- die unless $db1 && $db2;
-
- my $jobs1 = $db1->selectrow_array("SELECT COUNT(*) FROM job");
- my $jobs2 = $db2->selectrow_array("SELECT COUNT(*) FROM job");
- is($jobs1 + $jobs2, $n_jobs, "inserted all $n_jobs");
-
- ok($jobs1 > $n_jobs / 4, "at least a quarter of jobs went to db1 ($jobs1 / $n_jobs)");
- ok($jobs2 > $n_jobs / 4, "at least a quarter of jobs went to db1 ($jobs2 / $n_jobs)");
-
- my $do_jobs = int($n_jobs / 2);
- $client->can_do("Worker::Foo");
- for (1..$do_jobs) {
- $client->work_once
- or die;
+run_tests(
+ 4,
+ sub {
+ my $client = test_client( dbs => [ 'ts1', 'ts2' ] );
+
+ my $n_jobs = 60;
+ for ( 1 .. $n_jobs ) {
+ my $handle = $client->insert("Worker::Foo");
+ die unless $handle;
+ }
+
+ my $db1 = DBI->connect( dsn_for("ts1"), $ENV{TS_DB_USER},
+ $ENV{TS_DB_PASS} );
+ my $db2 = DBI->connect( dsn_for("ts2"), $ENV{TS_DB_USER},
+ $ENV{TS_DB_PASS} );
+ die unless $db1 && $db2;
+
+ my $jobs1 = $db1->selectrow_array("SELECT COUNT(*) FROM job");
+ my $jobs2 = $db2->selectrow_array("SELECT COUNT(*) FROM job");
+ is( $jobs1 + $jobs2, $n_jobs, "inserted all $n_jobs" );
+
+ ok( $jobs1 > $n_jobs / 4,
+ "at least a quarter of jobs went to db1 ($jobs1 / $n_jobs)" );
+ ok( $jobs2 > $n_jobs / 4,
+ "at least a quarter of jobs went to db1 ($jobs2 / $n_jobs)" );
+
+ my $do_jobs = int( $n_jobs / 2 );
+ $client->can_do("Worker::Foo");
+ for ( 1 .. $do_jobs ) {
+ $client->work_once
+ or die;
+ }
+
+ my $jobs1b = $db1->selectrow_array("SELECT COUNT(*) FROM job");
+ my $jobs2b = $db2->selectrow_array("SELECT COUNT(*) FROM job");
+
+ my $remain_jobs = $n_jobs - $do_jobs;
+ is( $jobs1b + $jobs2b, $remain_jobs, "expected jobs remain" );
+
+ # deltas: how much work gone done each
+ my $jobs1d = $jobs1 - $jobs1b;
+ my $jobs2d = $jobs2 - $jobs2b;
+
+ # difference in work done:
+ my $workdiff = abs( $jobs1d - $jobs2d );
+
+ teardown_dbs( 'ts1', 'ts2' );
}
-
- my $jobs1b = $db1->selectrow_array("SELECT COUNT(*) FROM job");
- my $jobs2b = $db2->selectrow_array("SELECT COUNT(*) FROM job");
-
- my $remain_jobs = $n_jobs - $do_jobs;
- is($jobs1b + $jobs2b, $remain_jobs, "expected jobs remain");
-
- # deltas: how much work gone done each
- my $jobs1d = $jobs1 - $jobs1b;
- my $jobs2d = $jobs2 - $jobs2b;
-
- # difference in work done:
- my $workdiff = abs($jobs1d - $jobs2d);
-
- teardown_dbs('ts1', 'ts2');
-});
+);
sub max { $_[0] > $_[1] ? $_[0] : $_[1] }
package Worker::Foo;
use base 'TheSchwartz::Worker';
+
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
$job->completed;
}
@@ -8,54 +8,59 @@ require 't/lib/db-common.pl';
use TheSchwartz;
use Test::More tests => 12;
-run_tests(4, sub {
- my $client = test_client(dbs => ['ts1']);
-
- my $job2h;
- for (1..2) {
- my $job = TheSchwartz::Job->new(
- funcname => 'Worker::CoalesceTest',
- arg => { n => $_ },
- coalesce => "a$_",
- );
- my $h = $client->insert($job);
- $job2h = $h if $_ == 2;
- ok($h, "inserted $h");
+run_tests(
+ 4,
+ sub {
+ my $client = test_client( dbs => ['ts1'] );
+
+ my $job2h;
+ for ( 1 .. 2 ) {
+ my $job = TheSchwartz::Job->new(
+ funcname => 'Worker::CoalesceTest',
+ arg => { n => $_ },
+ coalesce => "a$_",
+ );
+ my $h = $client->insert($job);
+ $job2h = $h if $_ == 2;
+ ok( $h, "inserted $h" );
+ }
+
+ $client->reset_abilities;
+ $client->can_do("Worker::CoalesceTest");
+
+ my $job = $client->find_job_with_coalescing_prefix(
+ "Worker::CoalesceTest", "a1" );
+ Worker::CoalesceTest->work_safely($job);
+
+ # this one should have succeeded:
+ is( $job->handle->failures, 0, "no failures on first job" );
+
+ # the second one should have failures:
+ is( $job2h->failures, 1, "1 failure on second job" );
+
+ teardown_dbs('ts1');
}
-
- $client->reset_abilities;
- $client->can_do("Worker::CoalesceTest");
-
- my $job = $client->find_job_with_coalescing_prefix("Worker::CoalesceTest", "a1");
- Worker::CoalesceTest->work_safely($job);
-
- # this one should have succeeded:
- is($job->handle->failures, 0, "no failures on first job");
-
- # the second one should have failures:
- is($job2h->failures, 1, "1 failure on second job");
-
- teardown_dbs('ts1');
-});
+);
############################################################################
package Worker::CoalesceTest;
use base 'TheSchwartz::Worker';
-
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
$job->completed;
my $arg = $job->arg;
- my $job2 = $job->handle->client->find_job_with_coalescing_prefix("Worker::CoalesceTest", "a2");
+ my $job2 = $job->handle->client->find_job_with_coalescing_prefix(
+ "Worker::CoalesceTest", "a2" );
$job2->set_as_current;
die "Failed working on job2\n";
}
-sub keep_exit_status_for { 20 } # keep exit status for 20 seconds after on_complete
-sub grab_for { 10 }
-sub max_retries { 1 }
-sub retry_delay { 10 }
-
+sub keep_exit_status_for {
+ 20
+} # keep exit status for 20 seconds after on_complete
+sub grab_for {10}
+sub max_retries {1}
+sub retry_delay {10}
@@ -9,36 +9,40 @@ require 't/lib/db-common.pl';
use TheSchwartz;
use Test::More tests => 24;
-run_tests(8, sub {
-
- my $client = test_client(dbs => ['ts1']);
-
- my $handle;
- $handle = $client->insert("feedmajor", { scoops => 2, with => ['cheese','love'] });
- isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
-
- my $job = $handle->job;
- isa_ok $job, 'TheSchwartz::Job';
-
- ok($job->funcid, 'jobs have funcids');
- is $job->funcname, 'feedmajor', 'handle->job gives us the right job';
-
- my $job2 = TheSchwartz::Job->new(
- funcname => 'feedmajor',
- run_after=> time() + 60,
- priority => 7,
- arg => { scoops => 2, with => ['cheese','love'] },
- coalesce => 'major',
- jobid => int rand(5000),
- );
- ok($job2);
-
- my $h2 = $client->insert($job2);
- isa_ok $h2, 'TheSchwartz::JobHandle';
-
- my $job2_back = $h2->job;
- ok($job2->funcid, "internal: funcid present");
- is($job2->funcname, "feedmajor", "funcname mapping worked");
-
- teardown_dbs('ts1');
-});
+run_tests(
+ 8,
+ sub {
+
+ my $client = test_client( dbs => ['ts1'] );
+
+ my $handle;
+ $handle = $client->insert( "feedmajor",
+ { scoops => 2, with => [ 'cheese', 'love' ] } );
+ isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
+
+ my $job = $handle->job;
+ isa_ok $job, 'TheSchwartz::Job';
+
+ ok( $job->funcid, 'jobs have funcids' );
+ is $job->funcname, 'feedmajor', 'handle->job gives us the right job';
+
+ my $job2 = TheSchwartz::Job->new(
+ funcname => 'feedmajor',
+ run_after => time() + 60,
+ priority => 7,
+ arg => { scoops => 2, with => [ 'cheese', 'love' ] },
+ coalesce => 'major',
+ jobid => int rand(5000),
+ );
+ ok($job2);
+
+ my $h2 = $client->insert($job2);
+ isa_ok $h2, 'TheSchwartz::JobHandle';
+
+ my $job2_back = $h2->job;
+ ok( $job2->funcid, "internal: funcid present" );
+ is( $job2->funcname, "feedmajor", "funcname mapping worked" );
+
+ teardown_dbs('ts1');
+ }
+);
@@ -24,44 +24,52 @@ $SIG{USR1} = sub {
}
# kill children on exit
-my %children; # pid -> 1
+my %children; # pid -> 1
+
END {
my @pids = keys %children;
kill -9, @pids if @pids;
}
-run_tests_innodb(2, sub {
-
- # get one job into database, to see if children do it twice:
- {
- my $client = test_client(dbs => ['ts1']);
- my $handle = $client->insert("Worker::Addition", { numbers => [1, 2] });
- isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
+run_tests_innodb(
+ 2,
+ sub {
+
+ # get one job into database, to see if children do it twice:
+ {
+ my $client = test_client( dbs => ['ts1'] );
+ my $handle = $client->insert( "Worker::Addition",
+ { numbers => [ 1, 2 ] } );
+ isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
+ }
+
+ # two children to race to get the above job.
+ work();
+ work();
+
+ # hang out for 3 seconds waiting for children to init/race/finish
+ my $now = time();
+ while ( time() < $now + 3 ) {
+ sleep 1;
+ }
+
+ is( $work_count, 1, "only got one signal from worker children" );
+ teardown_dbs('ts1');
}
-
- # two children to race to get the above job.
- work();
- work();
-
- # hang out for 3 seconds waiting for children to init/race/finish
- my $now = time();
- while (time() < $now + 3) {
- sleep 1;
- }
-
- is($work_count, 1, "only got one signal from worker children");
- teardown_dbs('ts1');
-});
+);
sub work {
+
# parent:
- if (my $childpid = fork()) {
+ if ( my $childpid = fork() ) {
$children{$childpid} = 1;
return;
}
- my $client = test_client(dbs => ['ts1'],
- init => 0);
+ my $client = test_client(
+ dbs => ['ts1'],
+ init => 0
+ );
# child:
my $job = Worker::Addition->grab_job($client);
@@ -76,7 +84,7 @@ package Worker::Addition;
use base 'TheSchwartz::Worker';
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
kill 'USR1', getppid();
$job->completed;
}
@@ -84,5 +92,5 @@ sub work {
# tell framework to set 'grabbed_until' to time() + 60. because if
# we can't add some numbers in 30 seconds, our process probably
# failed and work should be reassigned.
-sub grab_for { 30 }
+sub grab_for {30}
@@ -8,41 +8,43 @@ require 't/lib/db-common.pl';
use TheSchwartz;
use Test::More tests => 27;
-run_tests(9, sub {
- my $client = test_client(dbs => ['ts1']);
-
- my $available = TheSchwartz::Job->new(
- funcname => 'Worker::Grabber',
- );
- my $grabbed_until = time + 2;
- my $grabbed = TheSchwartz::Job->new(
- funcname => 'Worker::Grabber',
- grabbed_until => $grabbed_until,
- );
- my $available_handle = $client->insert($available);
- my $grabbed_handle = $client->insert($grabbed);
-
- $client->reset_abilities;
- $client->can_do("Worker::Grabber");
-
- Worker::Grabber->set_client($client);
-
- my $rv = $client->grab_and_work_on($grabbed_handle->as_string);
- ok(!$rv, "we couldn't grab it");
- is scalar $grabbed->failure_log, 0, "no errors";
- $grabbed->refresh;
- is $grabbed->grabbed_until, $grabbed_until, "Still grabbed";
-
- $rv = $client->grab_and_work_on($available_handle->as_string);
- is scalar $available->failure_log, 0, "no errors";
- ok($rv, "we worked on it");
-
- $rv = $client->grab_and_work_on($available_handle->as_string);
- is scalar $available->failure_log, 0, "no errors";
- ok(!$rv, "There is nothing to do for it now.");
-
- teardown_dbs('ts1');
-});
+run_tests(
+ 9,
+ sub {
+ my $client = test_client( dbs => ['ts1'] );
+
+ my $available
+ = TheSchwartz::Job->new( funcname => 'Worker::Grabber', );
+ my $grabbed_until = time + 2;
+ my $grabbed = TheSchwartz::Job->new(
+ funcname => 'Worker::Grabber',
+ grabbed_until => $grabbed_until,
+ );
+ my $available_handle = $client->insert($available);
+ my $grabbed_handle = $client->insert($grabbed);
+
+ $client->reset_abilities;
+ $client->can_do("Worker::Grabber");
+
+ Worker::Grabber->set_client($client);
+
+ my $rv = $client->grab_and_work_on( $grabbed_handle->as_string );
+ ok( !$rv, "we couldn't grab it" );
+ is scalar $grabbed->failure_log, 0, "no errors";
+ $grabbed->refresh;
+ is $grabbed->grabbed_until, $grabbed_until, "Still grabbed";
+
+ $rv = $client->grab_and_work_on( $available_handle->as_string );
+ is scalar $available->failure_log, 0, "no errors";
+ ok( $rv, "we worked on it" );
+
+ $rv = $client->grab_and_work_on( $available_handle->as_string );
+ is scalar $available->failure_log, 0, "no errors";
+ ok( !$rv, "There is nothing to do for it now." );
+
+ teardown_dbs('ts1');
+ }
+);
############################################################################
package Worker::Grabber;
@@ -53,13 +55,13 @@ my $client;
sub set_client { $client = $_[1]; }
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
- ok(($job->grabbed_until > time), "this job is locked");
+ ok( ( $job->grabbed_until > time ), "this job is locked" );
## try to work on it
- my $rv = $client->grab_and_work_on($job->handle->as_string);
- ok(!$rv, "We are already working on it, so we can't grab it");
-
+ my $rv = $client->grab_and_work_on( $job->handle->as_string );
+ ok( !$rv, "We are already working on it, so we can't grab it" );
+
$job->completed;
}
@@ -9,43 +9,51 @@ require 't/lib/db-common.pl';
use TheSchwartz;
use Test::More tests => 12;
-run_tests(4, sub {
- my $client = test_client(dbs => ['ts1']);
+run_tests(
+ 4,
+ sub {
+ my $client = test_client( dbs => ['ts1'] );
+
+ my $n_jobs = 10;
+ for ( 1 .. $n_jobs ) {
+ $client->insert("Worker::Job1") or die;
+ $client->insert("Worker::Job2") or die;
+ }
+
+ my $db1 = DBI->connect( dsn_for("ts1"), $ENV{TS_DB_USER},
+ $ENV{TS_DB_PASS} );
+ die unless $db1;
+
+ my $jobs1 = $db1->selectrow_array(
+ "SELECT COUNT(*) FROM job WHERE funcid=1");
+ is( $jobs1, $n_jobs, "have $n_jobs funcid 1s" );
+ my $jobs2 = $db1->selectrow_array(
+ "SELECT COUNT(*) FROM job WHERE funcid=2");
+ is( $jobs2, $n_jobs, "have $n_jobs funcid 2s" );
+
+ my $do_jobs = int( $n_jobs / 2 );
+ $client->can_do("Worker::Job1");
+ $client->can_do("Worker::Job2");
+ for ( 1 .. ( $do_jobs * 2 ) ) {
+ $client->work_once
+ or die "Couldn't find job to do";
+ }
+
+ my $jobs1b = $db1->selectrow_array(
+ "SELECT COUNT(*) FROM job WHERE funcid=1");
+ is( $jobs1b, $n_jobs - $do_jobs, "have half funcid 1s" );
+ my $jobs2b = $db1->selectrow_array(
+ "SELECT COUNT(*) FROM job WHERE funcid=2");
+ is( $jobs2b, $n_jobs - $do_jobs, "have half funcid 2s" );
- my $n_jobs = 10;
- for (1..$n_jobs) {
- $client->insert("Worker::Job1") or die;
- $client->insert("Worker::Job2") or die;
}
-
- my $db1 = DBI->connect(dsn_for("ts1"), $ENV{TS_DB_USER}, $ENV{TS_DB_PASS});
- die unless $db1;
-
- my $jobs1 = $db1->selectrow_array("SELECT COUNT(*) FROM job WHERE funcid=1");
- is($jobs1, $n_jobs, "have $n_jobs funcid 1s");
- my $jobs2 = $db1->selectrow_array("SELECT COUNT(*) FROM job WHERE funcid=2");
- is($jobs2, $n_jobs, "have $n_jobs funcid 2s");
-
- my $do_jobs = int($n_jobs / 2);
- $client->can_do("Worker::Job1");
- $client->can_do("Worker::Job2");
- for (1..($do_jobs * 2)) {
- $client->work_once
- or die "Couldn't find job to do";
- }
-
- my $jobs1b = $db1->selectrow_array("SELECT COUNT(*) FROM job WHERE funcid=1");
- is($jobs1b, $n_jobs - $do_jobs, "have half funcid 1s");
- my $jobs2b = $db1->selectrow_array("SELECT COUNT(*) FROM job WHERE funcid=2");
- is($jobs2b, $n_jobs - $do_jobs, "have half funcid 2s");
-
-
-});
+);
package Worker::Job1;
use base 'TheSchwartz::Worker';
+
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
$job->completed;
}
@@ -6,101 +6,125 @@ use warnings;
require 't/lib/db-common.pl';
use TheSchwartz;
-use Test::More tests => 26*3;
-
-run_tests(26, sub {
- my $client = test_client(dbs => ['ts1']);
-
- # insert a job
- {
- my $handle = $client->insert("Worker::Addition", { numbers => [1, 2] });
- isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
- }
-
- # let's do some work. the tedious way, specifying which class should grab a job
- {
- my $job = Worker::Addition->grab_job($client);
- isa_ok $job, 'TheSchwartz::Job';
- my $args = $job->arg;
- is(ref $args, "HASH"); # thawed it for us
- is_deeply($args, { numbers => [1, 2] }, "got our args back");
-
- # insert a dummy job to test that next grab ignors it
- ok($client->insert("dummy", [1,2,3]));
-
- # verify no more jobs can be grabbed of this type, even though
- # we haven't done the first one
- my $job2 = Worker::Addition->grab_job($client);
- ok(!$job2, "no addition jobs to be grabbed");
-
- my $rv = eval { Worker::Addition->work($job); };
- # ....
- }
-
- # inserting and getting job w/ regular scalar arg
- foreach my $scalar ("short_arg",
- "long arg more than 11 bytes long",
- "\x05scalar that begins with the 5 byte",
- )
- {
- my $handle = $client->insert("Worker::Addition", $scalar);
- isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
-
- my $job = Worker::Addition->grab_job($client);
- isa_ok $job, 'TheSchwartz::Job';
- my $args = $job->arg;
- ok(!ref $args, "not a reference"); # not a reference
- is($args, $scalar, "got correct scalar arg back");
- }
-
- # insert some more jobs
- {
- ok($client->insert("Worker::MergeInternalDict", { foo => 'bar' }));
- ok($client->insert("Worker::MergeInternalDict", { bar => 'baz' }));
- ok($client->insert("Worker::MergeInternalDict", { baz => 'foo' }));
- }
-
- # work the easier way
- {
- Worker::MergeInternalDict->reset;
- $client->can_do("Worker::MergeInternalDict"); # single arg form: say we can do this job name, which is also its package
- $client->work_until_done; # blocks until all databases are empty
- is_deeply(Worker::MergeInternalDict->dict,
- {
- foo => "bar",
- bar => "baz",
- baz => "foo",
- }, "all jobs got completed");
- }
-
- # errors
- {
- $client->reset_abilities; # now it, as a worker, can't do anything
- $client->can_do("Worker::Division"); # now it can only do one thing
-
- my $handle = $client->insert("Worker::Division", { n => 5, d => 0 });
- ok($handle);
-
- my $job = Worker::Division->grab_job($client);
- isa_ok $job, 'TheSchwartz::Job';
-
- # wrapper around 'work' implemented in the base class which runs work in
- # eval and notes a failure (with backoff) if job died.
- Worker::Division->work_safely($job);
-
- is($handle->failures, 1, "job has failed once");
- like(join('', $handle->failure_log), qr/Illegal division by zero/, "noted that we divided by zero");
+use Test::More tests => 26 * 3;
+
+run_tests(
+ 26,
+ sub {
+ my $client = test_client( dbs => ['ts1'] );
+
+ # insert a job
+ {
+ my $handle = $client->insert( "Worker::Addition",
+ { numbers => [ 1, 2 ] } );
+ isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
+ }
+
+# let's do some work. the tedious way, specifying which class should grab a job
+ {
+ my $job = Worker::Addition->grab_job($client);
+ isa_ok $job, 'TheSchwartz::Job';
+ my $args = $job->arg;
+ is( ref $args, "HASH" ); # thawed it for us
+ is_deeply( $args, { numbers => [ 1, 2 ] }, "got our args back" );
+
+ # insert a dummy job to test that next grab ignors it
+ ok( $client->insert( "dummy", [ 1, 2, 3 ] ) );
+
+ # verify no more jobs can be grabbed of this type, even though
+ # we haven't done the first one
+ my $job2 = Worker::Addition->grab_job($client);
+ ok( !$job2, "no addition jobs to be grabbed" );
+
+ my $rv = eval { Worker::Addition->work($job); };
+
+ # ....
+ }
+
+ # inserting and getting job w/ regular scalar arg
+ foreach my $scalar (
+ "short_arg",
+ "long arg more than 11 bytes long",
+ "\x05scalar that begins with the 5 byte",
+ )
+ {
+ my $handle = $client->insert( "Worker::Addition", $scalar );
+ isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
+
+ my $job = Worker::Addition->grab_job($client);
+ isa_ok $job, 'TheSchwartz::Job';
+ my $args = $job->arg;
+ ok( !ref $args, "not a reference" ); # not a reference
+ is( $args, $scalar, "got correct scalar arg back" );
+ }
+
+ # insert some more jobs
+ {
+ ok( $client->insert(
+ "Worker::MergeInternalDict", { foo => 'bar' }
+ )
+ );
+ ok( $client->insert(
+ "Worker::MergeInternalDict", { bar => 'baz' }
+ )
+ );
+ ok( $client->insert(
+ "Worker::MergeInternalDict", { baz => 'foo' }
+ )
+ );
+ }
+
+ # work the easier way
+ {
+ Worker::MergeInternalDict->reset;
+ $client->can_do("Worker::MergeInternalDict")
+ ; # single arg form: say we can do this job name, which is also its package
+ $client->work_until_done; # blocks until all databases are empty
+ is_deeply(
+ Worker::MergeInternalDict->dict,
+ { foo => "bar",
+ bar => "baz",
+ baz => "foo",
+ },
+ "all jobs got completed"
+ );
+ }
+
+ # errors
+ {
+ $client->reset_abilities; # now it, as a worker, can't do anything
+ $client->can_do("Worker::Division")
+ ; # now it can only do one thing
+
+ my $handle
+ = $client->insert( "Worker::Division", { n => 5, d => 0 } );
+ ok($handle);
+
+ my $job = Worker::Division->grab_job($client);
+ isa_ok $job, 'TheSchwartz::Job';
+
+ # wrapper around 'work' implemented in the base class which runs work in
+ # eval and notes a failure (with backoff) if job died.
+ Worker::Division->work_safely($job);
+
+ is( $handle->failures, 1, "job has failed once" );
+ like(
+ join( '', $handle->failure_log ),
+ qr/Illegal division by zero/,
+ "noted that we divided by zero"
+ );
+ }
+
+ teardown_dbs('ts1');
}
-
- teardown_dbs('ts1');
-});
+);
############################################################################
package Worker::Addition;
use base 'TheSchwartz::Worker';
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
# ....
}
@@ -108,7 +132,7 @@ sub work {
# tell framework to set 'grabbed_until' to time() + 60. because if
# we can't add some numbers in 30 seconds, our process probably
# failed and work should be reassigned.
-sub grab_for { 30 }
+sub grab_for {30}
############################################################################
package Worker::MergeInternalDict;
@@ -120,33 +144,36 @@ sub reset { %internal_dict = (); }
sub dict { \%internal_dict }
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
my $args = $job->arg;
- %internal_dict = (%internal_dict, %$args);
+ %internal_dict = ( %internal_dict, %$args );
$job->completed;
}
-sub grab_for { 10 }
+sub grab_for {10}
############################################################################
package Worker::Division;
use base 'TheSchwartz::Worker';
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
my $args = $job->arg;
- my $ans = $args->{n} / $args->{d}; # throw it away, just here to die on d==0
+ my $ans
+ = $args->{n} / $args->{d}; # throw it away, just here to die on d==0
$job->set_exit_status(1);
$job->completed;
}
-sub keep_exit_status_for { 20 } # keep exit status for 20 seconds after on_complete
+sub keep_exit_status_for {
+ 20
+} # keep exit status for 20 seconds after on_complete
-sub grab_for { 10 }
+sub grab_for {10}
-sub max_retries { 1 }
+sub max_retries {1}
-sub retry_delay { my $class = shift; my $fails = shift; return 2 ** $fails; }
+sub retry_delay { my $class = shift; my $fails = shift; return 2**$fails; }
@@ -5,157 +5,173 @@ use File::Spec;
use Carp qw(croak);
sub run_tests {
- my ($n, $code) = @_;
+ my ( $n, $code ) = @_;
- run_tests_mysql($n, $code);
- run_tests_pgsql($n, $code);
- run_tests_sqlite($n, $code);
+ run_tests_mysql( $n, $code );
+ run_tests_pgsql( $n, $code );
+ run_tests_sqlite( $n, $code );
}
sub run_tests_innodb {
- my ($n, $code) = @_;
- run_tests_mysql($n, $code, 1);
+ my ( $n, $code ) = @_;
+ run_tests_mysql( $n, $code, 1 );
}
sub run_tests_mysql {
- my ($n, $code, $innodb) = @_;
- SKIP: {
- local $ENV{USE_MYSQL} = 1;
- local $ENV{TS_DB_USER} ||= 'root';
- my $dbh = eval { mysql_dbh() };
- skip "MySQL not accessible as root on localhost", $n if $@;
- skip "InnoDB not available on localhost's MySQL", $n if $innodb && ! has_innodb($dbh);
- $code->();
- }
+ my ( $n, $code, $innodb ) = @_;
+SKIP: {
+ local $ENV{USE_MYSQL} = 1;
+ local $ENV{TS_DB_USER} ||= 'root';
+ my $dbh = eval { mysql_dbh() };
+ skip "MySQL not accessible as root on localhost", $n if $@;
+ skip "InnoDB not available on localhost's MySQL", $n
+ if $innodb && !has_innodb($dbh);
+ $code->();
+ }
}
sub run_tests_pgsql {
- my ($n, $code) = @_;
- SKIP: {
- local $ENV{USE_PGSQL} = 1;
- local $ENV{TS_DB_USER} ||= 'postgres';
- my $dbh = eval { pgsql_dbh() };
- skip "PgSQL not accessible as root on localhost", $n if $@;
- $code->();
- }
+ my ( $n, $code ) = @_;
+SKIP: {
+ local $ENV{USE_PGSQL} = 1;
+ local $ENV{TS_DB_USER} ||= 'postgres';
+ my $dbh = eval { pgsql_dbh() };
+ skip "PgSQL not accessible as root on localhost", $n if $@;
+ $code->();
+ }
}
sub run_tests_sqlite {
- my ($n, $code) = @_;
+ my ( $n, $code ) = @_;
# SQLite
- SKIP: {
- my $rv = eval "use DBD::SQLite; 1";
- $rv = 0 if $ENV{SKIP_SQLITE};
- skip "SQLite not installed", $n if !$rv;
- $code->();
- }
+SKIP: {
+ my $rv = eval "use DBD::SQLite; 1";
+ $rv = 0 if $ENV{SKIP_SQLITE};
+ skip "SQLite not installed", $n if !$rv;
+ $code->();
+ }
}
sub test_client {
my %opts = @_;
- my $dbs = delete $opts{dbs};
- my $init = delete $opts{init};
- my $pfx = delete $opts{dbprefix};
+ my $dbs = delete $opts{dbs};
+ my $init = delete $opts{init};
+ my $pfx = delete $opts{dbprefix};
croak "'dbs' not an ARRAY" unless ref $dbs eq "ARRAY";
croak "unknown opts" if %opts;
$init = 1 unless defined $init;
if ($init) {
- setup_dbs({ prefix => $pfx }, $dbs);
+ setup_dbs( { prefix => $pfx }, $dbs );
}
- if ($ENV{USE_DBH_FOR_TEST}) {
+ if ( $ENV{USE_DBH_FOR_TEST} || $ENV{USE_GET_DBH_FOR_TEST} ) {
my @tmp;
- for (@$dbs) { eval {
- my $dsn = dsn_for($_);
- my $dbh = DBI->connect( $dsn, "root", "", {
- RaiseError => 1,
- PrintError => 0,
- AutoCommit => 1,
- } ) or die $DBI::errstr;
- my $driver = Data::ObjectDriver::Driver::DBI->new( dbh => $dbh);
- push @tmp, { driver => $driver, prefix => $pfx };
- } }
- return TheSchwartz->new(databases => [@tmp]);
- } else {
- return TheSchwartz->new(databases => [
- map { {
- dsn => dsn_for($_),
- user => $ENV{TS_DB_USER},
- pass => $ENV{TS_DB_PASS},
- prefix => $pfx,
- } } @$dbs
- ]);
+ for (@$dbs) {
+ eval {
+ my $dsn = dsn_for($_);
+ my $dbh = DBI->connect(
+ $dsn, "root", "",
+ { RaiseError => 1,
+ PrintError => 0,
+ AutoCommit => 1,
+ }
+ ) or die $DBI::errstr;
+ my $driver
+ = Data::ObjectDriver::Driver::DBI->new(
+ $ENV{USE_GET_DBH_FOR_TEST}
+ ? ( get_dbh => sub {$dbh} )
+ : ( dbh => $dbh ) );
+ push @tmp, { driver => $driver, prefix => $pfx };
+ };
+ }
+ return TheSchwartz->new( databases => [@tmp] );
+ }
+ else {
+ return TheSchwartz->new(
+ databases => [
+ map {
+ { dsn => dsn_for($_),
+ user => $ENV{TS_DB_USER},
+ pass => $ENV{TS_DB_PASS},
+ prefix => $pfx,
+ }
+ } @$dbs
+ ]
+ );
}
}
sub has_innodb {
- my $dbh = shift;
+ my $dbh = shift;
my $tmpname = "test_to_see_if_innoavail";
$dbh->do("CREATE TABLE IF NOT EXISTS $tmpname (i int) ENGINE=INNODB")
or return 0;
- my @row = $dbh->selectrow_array("SHOW CREATE TABLE $tmpname");
- my $row = join(' ', @row);
- my $has_it = ($row =~ /=InnoDB/i);
+ my @row = $dbh->selectrow_array("SHOW CREATE TABLE $tmpname");
+ my $row = join( ' ', @row );
+ my $has_it = ( $row =~ /=InnoDB/i );
$dbh->do("DROP TABLE $tmpname");
return $has_it;
}
sub schema_file {
- return "doc/schema.sql" if $ENV{USE_MYSQL};
+ return "doc/schema.sql" if $ENV{USE_MYSQL};
return "doc/schema-postgres.sql" if $ENV{USE_PGSQL};
return "t/schema-sqlite.sql";
}
sub db_filename {
- my($dbname) = @_;
+ my ($dbname) = @_;
return $dbname . '.db';
}
sub mysql_dbname {
- my($dbname) = @_;
+ my ($dbname) = @_;
return 't_sch_' . $dbname;
}
sub dsn_for {
my $dbname = shift;
- if ($ENV{USE_MYSQL}) {
+ if ( $ENV{USE_MYSQL} ) {
return 'dbi:mysql:' . mysql_dbname($dbname);
}
- elsif ($ENV{USE_PGSQL}) {
+ elsif ( $ENV{USE_PGSQL} ) {
return 'dbi:Pg:dbname=' . mysql_dbname($dbname);
- } else {
+ }
+ else {
return 'dbi:SQLite:dbname=' . db_filename($dbname);
}
}
sub setup_dbs {
- shift if $_[0] =~ /\.sql$/; # skip filenames (old)
+ shift if $_[0] =~ /\.sql$/; # skip filenames (old)
my $opts = ref $_[0] eq "HASH" ? shift : {};
my $pfx = delete $opts->{prefix} || "";
die "unknown opts" if %$opts;
- my(@dbs) = @_;
- my $dbs = ref $dbs[0] ? $dbs[0] : \@dbs; # support array or arrayref (old)
+ my (@dbs) = @_;
+ my $dbs = ref $dbs[0] ? $dbs[0] : \@dbs; # support array or arrayref (old)
my $schema = schema_file();
teardown_dbs(@$dbs);
for my $dbname (@$dbs) {
- if ($ENV{USE_MYSQL}) {
- create_mysql_db(mysql_dbname($dbname));
+ if ( $ENV{USE_MYSQL} ) {
+ create_mysql_db( mysql_dbname($dbname) );
}
- elsif ($ENV{USE_PGSQL}) {
- create_pgsql_db(mysql_dbname($dbname));
+ elsif ( $ENV{USE_PGSQL} ) {
+ create_pgsql_db( mysql_dbname($dbname) );
}
- my $dbh = DBI->connect(dsn_for($dbname),
- $ENV{TS_DB_USER}, $ENV{TS_DB_PASS}, { RaiseError => 1, PrintError => 0 })
+ my $dbh
+ = DBI->connect( dsn_for($dbname), $ENV{TS_DB_USER},
+ $ENV{TS_DB_PASS}, { RaiseError => 1, PrintError => 0 } )
or die "Couldn't connect: $!\n";
my @sql = load_sql($schema);
for my $sql (@sql) {
$sql =~ s!^\s*create\s+table\s+(\w+)!CREATE TABLE ${pfx}$1!mi;
- $sql =~ s!^\s*(create.*?index)\s+(\w+)\s+on\s+(\w+)!$1 $2 ON ${pfx}$3!i;
+ $sql
+ =~ s!^\s*(create.*?index)\s+(\w+)\s+on\s+(\w+)!$1 $2 ON ${pfx}$3!i;
$sql .= " ENGINE=INNODB\n" if $ENV{USE_MYSQL};
$dbh->do($sql);
}
@@ -164,17 +180,18 @@ sub setup_dbs {
}
sub mysql_dbh {
- return DBI->connect("DBI:mysql:mysql", "root", "", { RaiseError => 1 })
- or die "Couldn't connect to database";
+ return DBI->connect( "DBI:mysql:mysql", "root", "", { RaiseError => 1 } )
+ || die "Couldn't connect to database";
}
my $pg_dbh;
sub pgsql_dbh {
return $pg_dbh if $pg_dbh;
- $pg_dbh ||=
- DBI->connect("DBI:Pg:dbname=postgres", "postgres", "", { RaiseError => 1 })
- or die "Couldn't connect to database";
+ $pg_dbh
+ ||= DBI->connect( "DBI:Pg:dbname=postgres", "postgres", "",
+ { RaiseError => 1 } )
+ or die "Couldn't connect to database";
}
sub create_mysql_db {
@@ -199,13 +216,15 @@ sub drop_pgsql_db {
}
sub teardown_dbs {
- my(@dbs) = @_;
+ my (@dbs) = @_;
for my $db (@dbs) {
- if ($ENV{USE_MYSQL}) {
- drop_mysql_db(mysql_dbname($db));
- } elsif ($ENV{USE_PGSQL}) {
- drop_pgsql_db(mysql_dbname($db));
- } else {
+ if ( $ENV{USE_MYSQL} ) {
+ drop_mysql_db( mysql_dbname($db) );
+ }
+ elsif ( $ENV{USE_PGSQL} ) {
+ drop_pgsql_db( mysql_dbname($db) );
+ }
+ else {
my $file = db_filename($db);
next unless -e $file;
unlink $file or die "Can't teardown $db: $!";
@@ -214,7 +233,7 @@ sub teardown_dbs {
}
sub load_sql {
- my($file) = @_;
+ my ($file) = @_;
open my $fh, $file or die "Can't open $file: $!";
my $sql = do { local $/; <$fh> };
close $fh;
@@ -13,7 +13,7 @@ use Test::More tests => 2;
my $work_count = 0;
my $lost_race = 0;
$SIG{USR1} = sub { $work_count++; };
-$SIG{USR2} = sub { $lost_race ++; };
+$SIG{USR2} = sub { $lost_race++; };
# tell our parent when we lost a race
{
@@ -21,12 +21,13 @@ $SIG{USR2} = sub { $lost_race ++; };
$TheSchwartz::FIND_JOB_BATCH_SIZE = 2;
$TheSchwartz::T_LOST_RACE = sub {
- $lost_race = 1; # this one's in our child process.
+ $lost_race = 1; # this one's in our child process.
kill 'USR2', getppid();
};
$TheSchwartz::T_AFTER_GRAB_SELECT_BEFORE_UPDATE = sub {
- # force the race condition to happen, at least until we've triggered it
+
+ # force the race condition to happen, at least until we've triggered it
select undef, undef, undef, 0.25
unless $lost_race;
};
@@ -34,7 +35,8 @@ $SIG{USR2} = sub { $lost_race ++; };
}
# kill children on exit
-my %children; # pid -> 1
+my %children; # pid -> 1
+
END {
my @pids = keys %children;
kill -9, @pids if @pids;
@@ -42,48 +44,54 @@ END {
my $jobs = 40;
-run_tests_innodb(2, sub {
-
- # get one job into database, to see if children do it twice:
- {
- my $client = test_client(dbs => ['ts1']);
- for (1..$jobs) {
- $client->insert("Worker::Addition", { numbers => [1, 2] })
- or die;
+run_tests_innodb(
+ 2,
+ sub {
+
+ # get one job into database, to see if children do it twice:
+ {
+ my $client = test_client( dbs => ['ts1'] );
+ for ( 1 .. $jobs ) {
+ $client->insert( "Worker::Addition", { numbers => [ 1, 2 ] } )
+ or die;
+ }
}
- }
- # two children to race
- work();
- work();
+ # two children to race
+ work();
+ work();
- # hang out waiting for children to init/race/finish
- #
- while ($work_count < $jobs) {
- sleep 1;
- }
- my $now = time();
- while (time < $now + 2) {
- sleep 1;
- }
+ # hang out waiting for children to init/race/finish
+ #
+ while ( $work_count < $jobs ) {
+ sleep 1;
+ }
+ my $now = time();
+ while ( time < $now + 2 ) {
+ sleep 1;
+ }
- is($work_count, $jobs, "$jobs jobs done");
- ok($lost_race, "lost the race at least once");
- teardown_dbs('ts1');
-});
+ is( $work_count, $jobs, "$jobs jobs done" );
+ ok( $lost_race, "lost the race at least once" );
+ teardown_dbs('ts1');
+ }
+);
sub work {
+
# parent:
- if (my $childpid = fork()) {
+ if ( my $childpid = fork() ) {
$children{$childpid} = 1;
return;
}
- my $client = test_client(dbs => ['ts1'],
- init => 0);
+ my $client = test_client(
+ dbs => ['ts1'],
+ init => 0
+ );
# child:
- while (my $job = Worker::Addition->grab_job($client)) {
+ while ( my $job = Worker::Addition->grab_job($client) ) {
eval { Worker::Addition->work($job); };
}
exit 0;
@@ -94,7 +102,7 @@ package Worker::Addition;
use base 'TheSchwartz::Worker';
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
kill 'USR1', getppid();
$job->completed;
}
@@ -102,5 +110,5 @@ sub work {
# tell framework to set 'grabbed_until' to time() + 60. because if
# we can't add some numbers in 30 seconds, our process probably
# failed and work should be reassigned.
-sub grab_for { 5 }
+sub grab_for {5}
@@ -6,44 +6,117 @@ use warnings;
require 't/lib/db-common.pl';
use TheSchwartz;
-use Test::More tests => 31*3;
+use Test::More tests => ( ( 31 * 3 ) + ( 16 * 3 ) + ( 12 * 3 ) );
our $record_expected;
-
-run_tests(31, sub {
- my $client = test_client(dbs => ['ts1']);
-
- # Define that we want to use priority selection
- # limit batch size to 1 so we always process jobs in
- # priority order
- $client->set_prioritize(1);
- $TheSchwartz::FIND_JOB_BATCH_SIZE = 1;
-
- for (1..10) {
- my $job = TheSchwartz::Job->new(
- funcname => 'Worker::PriorityTest',
- arg => { num => $_ },
- ( $_ == 1 ? () : ( priority => $_ ) ),
- );
- my $h = $client->insert($job);
- ok($h, "inserted job (priority $_)");
- }
-
- $client->reset_abilities;
- $client->can_do("Worker::PriorityTest");
-
- Worker::PriorityTest->set_client($client);
-
- for (1..10) {
- $record_expected = 11 - $_ == 1 ? undef : 11 - $_;
+our $testnum = 0;
+our $floor = 3;
+
+$TheSchwartz::FIND_JOB_BATCH_SIZE = 1;
+
+run_tests(
+ 59,
+ sub {
+ my $client = test_client( dbs => ['ts1'] );
+
+ # Define that we want to use priority selection
+ # limit batch size to 1 so we always process jobs in
+ # priority order
+ $client->set_prioritize(1);
+
+ for ( 1 .. 10 ) {
+ my $job = TheSchwartz::Job->new(
+ funcname => 'Worker::PriorityTest',
+ arg => { num => $_ },
+ ( $_ == 1 ? () : ( priority => $_ ) ),
+ );
+ my $h = $client->insert($job);
+ ok( $h, "inserted job (priority $_)" );
+ }
+
+ $client->reset_abilities;
+ $client->can_do("Worker::PriorityTest");
+
+ Worker::PriorityTest->set_client($client);
+
+ for ( 1 .. 10 ) {
+ $record_expected = 11 - $_ == 1 ? undef : 11 - $_;
+ my $rv = eval { $client->work_once; };
+ ok( $rv, "did stuff" );
+ }
my $rv = eval { $client->work_once; };
- ok($rv, "did stuff");
+ ok( !$rv, "nothing to do now" );
+
+ teardown_dbs('ts1');
+
+ # test we get in jobid order for equal priority RT #99075
+ $testnum = 1;
+ my $client2 = test_client( dbs => ['ts2'] );
+
+ $client2->reset_abilities;
+ $client2->can_do("Worker::PriorityTest");
+
+ Worker::PriorityTest->set_client($client2);
+
+ # Define that we want to use priority selection
+ # limit batch size to 1 so we always process jobs in
+ # priority order
+ $client2->set_prioritize(1);
+
+ for ( 1 .. 5 ) {
+ my $job = TheSchwartz::Job->new(
+ funcname => 'Worker::PriorityTest',
+ arg => { num => $_ },
+ priority => 5,
+ );
+ my $h = $client2->insert($job);
+ ok( $h, "inserted job (priority $_)" );
+ }
+
+ for ( 1 .. 5 ) {
+ $record_expected = $_;
+ my $rv = eval { $client2->work_once; };
+ ok( $rv, "did stuff 1-5" );
+ }
+ $rv = eval { $client2->work_once; };
+ ok( !$rv, "nothing to do now 1-5" );
+
+ teardown_dbs('ts2');
+
+ # test floor RT #50842
+ $testnum = 2;
+
+ $client2 = test_client( dbs => ['ts3'] );
+ $client2->set_prioritize(1);
+ $client2->reset_abilities;
+ $client2->can_do("Worker::PriorityTest");
+
+ Worker::PriorityTest->set_client($client2);
+
+ $client2->set_floor($floor);
+
+ for ( 1 .. 5 ) {
+ my $job = TheSchwartz::Job->new(
+ funcname => 'Worker::PriorityTest',
+ arg => { num => $_ },
+ priority => $_,
+ );
+ my $h = $client2->insert($job);
+ ok( $h, "inserted job (priority $_)" );
+ }
+
+ for ( $floor .. 5 ) {
+ $record_expected = $_;
+ my $rv = eval { $client2->work_once; };
+ ok( $rv, "did stuff 3-5" );
+ }
+ $rv = eval { $client2->work_once; };
+ ok( !$rv, "sub-floor jobs remaining but you can't have them" );
+
+ teardown_dbs('ts3');
+ $testnum = 0;
}
- my $rv = eval { $client->work_once; };
- ok(!$rv, "nothing to do now");
-
- teardown_dbs('ts1');
-});
+);
############################################################################
package Worker::PriorityTest;
@@ -55,19 +128,34 @@ my $client;
sub set_client { $client = $_[1]; }
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
my $priority = $job->priority;
- ok((!defined($main::record_expected) && (!defined($priority)))
- || ($priority == $main::record_expected), "priority matches expected priority");
+ if ( $main::testnum == 1 ) {
+ ok( $job->jobid == $main::record_expected,
+ "order by ID for same priority"
+ );
+ }
+ elsif ( $main::testnum == 2 ) {
+ ok( $job->priority >= $floor, "check floor" );
+ }
+ else {
+ ok( ( !defined($main::record_expected) && ( !defined($priority) ) )
+ || ( $priority == $main::record_expected ),
+ "priority matches expected priority"
+ );
+ }
+
$job->completed;
}
-sub keep_exit_status_for { 20 } # keep exit status for 20 seconds after on_complete
+sub keep_exit_status_for {
+ 20;
+} # keep exit status for 20 seconds after on_complete
-sub grab_for { 10 }
+sub grab_for {10}
-sub max_retries { 1 }
+sub max_retries {1}
-sub retry_delay { my $class = shift; my $fails = shift; return 2 ** $fails; }
+sub retry_delay { my $class = shift; my $fails = shift; return 2**$fails; }
@@ -8,48 +8,53 @@ require 't/lib/db-common.pl';
use TheSchwartz;
use Test::More tests => 30;
-run_tests(10, sub {
- my $client = test_client(dbs => ['ts1']);
+run_tests(
+ 10,
+ sub {
+ my $client = test_client( dbs => ['ts1'] );
- my $handle = $client->insert("Worker::Foo", { cluster => 'all'});
- ok($handle);
+ my $handle = $client->insert( "Worker::Foo", { cluster => 'all' } );
+ ok($handle);
- my $job = Worker::Foo->grab_job($client);
- ok($job, "no addition jobs to be grabbed");
+ my $job = Worker::Foo->grab_job($client);
+ ok( $job, "no addition jobs to be grabbed" );
- Worker::Foo->work_safely($job);
+ Worker::Foo->work_safely($job);
- $client->can_do("Worker::Foo");
- $client->work_until_done; # should process 5 jobs.
+ $client->can_do("Worker::Foo");
+ $client->work_until_done; # should process 5 jobs.
- # finish a job by replacing it with nothing
- $handle = $client->insert("Worker::Foo", { cluster => 'gibberish'});
- ok($handle->is_pending, "job is still pending");
- $job = $handle->job;
- $job->replace_with();
- ok(! $handle->is_pending, "job no longer pending");
+ # finish a job by replacing it with nothing
+ $handle
+ = $client->insert( "Worker::Foo", { cluster => 'gibberish' } );
+ ok( $handle->is_pending, "job is still pending" );
+ $job = $handle->job;
+ $job->replace_with();
+ ok( !$handle->is_pending, "job no longer pending" );
- teardown_dbs('ts1');
-});
+ teardown_dbs('ts1');
+ }
+);
############################################################################
package Worker::Foo;
use base 'TheSchwartz::Worker';
-use Test::More; ## Import test methods.
+use Test::More; ## Import test methods.
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
my $args = $job->arg;
- if ($args->{cluster} eq "all") {
- ok(1, "got the expand job");
+ if ( $args->{cluster} eq "all" ) {
+ ok( 1, "got the expand job" );
my @jobs;
- for (1..5) {
- push @jobs, TheSchwartz::Job->new_from_array("Worker::Foo",
- { cluster => $_ }
- );
+ for ( 1 .. 5 ) {
+ push @jobs,
+ TheSchwartz::Job->new_from_array( "Worker::Foo",
+ { cluster => $_ } );
}
+
# which does a $job->completed iff all the @jobs, in one txn, insert
# on the same database that $job was on. and it should DIE if the
# transaction fails, just so txn flow doesn't proceed on accident.
@@ -58,8 +63,8 @@ sub work {
return;
}
- if ($args->{cluster} =~ /^\d+$/) {
- ok(1, "got job $args->{cluster}");
+ if ( $args->{cluster} =~ /^\d+$/ ) {
+ ok( 1, "got job $args->{cluster}" );
$job->completed;
return;
}
@@ -71,5 +76,5 @@ sub work {
# regular die.
}
-sub grab_for { 30 }
+sub grab_for {30}
@@ -9,62 +9,69 @@ require 't/lib/db-common.pl';
use TheSchwartz;
use Test::More tests => 24;
-run_tests(8, sub {
- my $client = test_client(dbs => ['ts1']);
+run_tests(
+ 8,
+ sub {
+ my $client = test_client( dbs => ['ts1'] );
- # insert a job which will fail, fail, then succeed.
- {
- my $handle = $client->insert("Worker::CompleteEventually");
- isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
+ # insert a job which will fail, fail, then succeed.
+ {
+ my $handle = $client->insert("Worker::CompleteEventually");
+ isa_ok $handle, 'TheSchwartz::JobHandle', "inserted job";
- $client->can_do("Worker::CompleteEventually");
- $client->work_until_done;
+ $client->can_do("Worker::CompleteEventually");
+ $client->work_until_done;
- is($handle->failures, 1, "job has failed once");
+ is( $handle->failures, 1, "job has failed once" );
- my $job = Worker::CompleteEventually->grab_job($client);
- ok(!$job, "a job isn't ready yet"); # hasn't been two seconds
- sleep 3; # 2 seconds plus 1 buffer second
+ my $job = Worker::CompleteEventually->grab_job($client);
+ ok( !$job, "a job isn't ready yet" ); # hasn't been two seconds
+ sleep 3; # 2 seconds plus 1 buffer second
- $job = Worker::CompleteEventually->grab_job($client);
- ok($job, "got a job, since time has gone by");
+ $job = Worker::CompleteEventually->grab_job($client);
+ ok( $job, "got a job, since time has gone by" );
- Worker::CompleteEventually->work_safely($job);
- is($handle->failures, 2, "job has failed twice");
+ Worker::CompleteEventually->work_safely($job);
+ is( $handle->failures, 2, "job has failed twice" );
- $job = Worker::CompleteEventually->grab_job($client);
- ok($job, "got the job back");
+ $job = Worker::CompleteEventually->grab_job($client);
+ ok( $job, "got the job back" );
- Worker::CompleteEventually->work_safely($job);
- ok(! $handle->is_pending, "job has exited");
- is($handle->exit_status, 0, "job succeeded");
- }
+ Worker::CompleteEventually->work_safely($job);
+ ok( !$handle->is_pending, "job has exited" );
+ is( $handle->exit_status, 0, "job succeeded" );
+ }
- teardown_dbs('ts1');
-});
+ teardown_dbs('ts1');
+ }
+);
############################################################################
package Worker::CompleteEventually;
use base 'TheSchwartz::Worker';
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
my $failures = $job->failures;
- if ($failures < 2) {
+ if ( $failures < 2 ) {
$job->failed;
- } else {
+ }
+ else {
$job->completed;
}
return;
}
-sub keep_exit_status_for { 20 } # keep exit status for 20 seconds after on_complete
+sub keep_exit_status_for {
+ 20
+} # keep exit status for 20 seconds after on_complete
-sub max_retries { 2 }
+sub max_retries {2}
sub retry_delay {
my $class = shift;
my $fails = shift;
- return [undef,2,0]->[$fails]; # fails 2 seconds first time, then immediately
+ return [ undef, 2, 0 ]->[$fails]
+ ; # fails 2 seconds first time, then immediately
}
@@ -10,73 +10,82 @@ use Test::More tests => 30;
use TheSchwartz;
use File::Spec qw();
use File::Temp qw(tempdir);
+
# create a tmp directory with a unique name. This stops
# us conflicting with any other runs of this process and means
# we tidy up after ourselves
my $tempdir = tempdir( CLEANUP => 1 );
-run_tests(10, sub {
- my $pfx = '';
- my $dbs = ['ts1'];
-
- setup_dbs({prefix => $pfx}, $dbs);
-
- my $client = TheSchwartz->new(scoreboard => $tempdir,
- databases => [
- map { {
- dsn => dsn_for($_),
- user => $ENV{TS_DB_USER},
- pass => $ENV{TS_DB_PASS},
- prefix => $pfx,
- } } @$dbs
- ]);
-
- my $sb_file = $client->scoreboard;
- {
- (undef, my ($sb_dir, $sb_name)) = File::Spec->splitpath($sb_file);
- ok(-e $sb_dir, "Looking for dir $sb_dir");
- }
+run_tests(
+ 10,
+ sub {
+ my $pfx = '';
+ my $dbs = ['ts1'];
+
+ setup_dbs( { prefix => $pfx }, $dbs );
+
+ my $client = TheSchwartz->new(
+ scoreboard => $tempdir,
+ databases => [
+ map {
+ { dsn => dsn_for($_),
+ user => $ENV{TS_DB_USER},
+ pass => $ENV{TS_DB_PASS},
+ prefix => $pfx,
+ }
+ } @$dbs
+ ]
+ );
+
+ my $sb_file = $client->scoreboard;
+ {
+ ( undef, my ( $sb_dir, $sb_name ) )
+ = File::Spec->splitpath($sb_file);
+ ok( -e $sb_dir, "Looking for dir $sb_dir" );
+ }
- {
- my $handle = $client->insert("Worker::Addition",
- {numbers => [1, 2]});
- my $job = Worker::Addition->grab_job($client);
+ {
+ my $handle = $client->insert( "Worker::Addition",
+ { numbers => [ 1, 2 ] } );
+ my $job = Worker::Addition->grab_job($client);
- my $rv = eval { Worker::Addition->work_safely($job); };
- ok(length($@) == 0, 'Finished job with out error')
- or diag($@);
+ my $rv = eval { Worker::Addition->work_safely($job); };
+ ok( length($@) == 0, 'Finished job with out error' )
+ or diag($@);
- unless (ok(-e $sb_file, "Scoreboard file exists")) {
- return;
- }
+ unless ( ok( -e $sb_file, "Scoreboard file exists" ) ) {
+ return;
+ }
- open(FH, $sb_file) or die "Can't open '$sb_file': $!\n";
+ open( FH, $sb_file ) or die "Can't open '$sb_file': $!\n";
- my %info = map { chomp; /^([^=]+)=(.*)$/ } <FH>;
- close(FH);
+ my %info = map { chomp; /^([^=]+)=(.*)$/ } <FH>;
+ close(FH);
- ok($info{pid} == $$, 'Has our PID');
- ok($info{funcname} eq 'Worker::Addition', 'Has our funcname');
- ok($info{started} =~ /\d+/, 'Started time is a number');
- ok($info{started} <= time, 'Started time is in the past');
- ok($info{arg} =~ /^numbers=ARRAY/, 'Has right args');
- ok($info{done} =~ /\d+/, 'Job has done time');
- }
+ ok( $info{pid} == $$, 'Has our PID' );
+ ok( $info{funcname} eq 'Worker::Addition', 'Has our funcname' );
+ ok( $info{started} =~ /\d+/, 'Started time is a number' );
+ ok( $info{started} <= time, 'Started time is in the past' );
+ ok( $info{arg} =~ /^numbers=ARRAY/, 'Has right args' );
+ ok( $info{done} =~ /\d+/, 'Job has done time' );
+ }
- {
- $client->DESTROY;
- ok(! -e $sb_file, 'Scoreboard file goes away when worker finishes');
- }
+ {
+ $client->DESTROY;
+ ok( !-e $sb_file,
+ 'Scoreboard file goes away when worker finishes' );
+ }
- teardown_dbs('ts1');
-});
+ teardown_dbs('ts1');
+ }
+);
############################################################################
package Worker::Addition;
use base 'TheSchwartz::Worker';
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
# ....
}
@@ -8,13 +8,17 @@ require 't/lib/db-common.pl';
use TheSchwartz;
use Test::More tests => 6;
-run_tests(2, sub {
- my $client = test_client(dbs => ['ts1']);
+run_tests(
+ 2,
+ sub {
+ my $client = test_client( dbs => ['ts1'] );
- my $driver = $client->driver_for( ($client->shuffled_databases)[0] );
- isa_ok $driver, 'Data::ObjectDriver::Driver::DBI';
+ my $driver
+ = $client->driver_for( ( $client->shuffled_databases )[0] );
+ isa_ok $driver, 'Data::ObjectDriver::Driver::DBI';
- cmp_ok $client->get_server_time($driver), '>', 0, 'got server time';
+ cmp_ok $client->get_server_time($driver), '>', 0, 'got server time';
- teardown_dbs('ts1');
-});
+ teardown_dbs('ts1');
+ }
+);
@@ -12,35 +12,38 @@ use Test::More tests => 18;
#use Data::ObjectDriver;
#$Data::ObjectDriver::DEBUG = 1;
-run_tests(6, sub {
- my $client = test_client(dbs => ['ts1']);
- my ($job, $handle);
-
- # insert a job with unique
- $job = TheSchwartz::Job->new(
- funcname => 'feed',
- uniqkey => "major",
- );
- ok($job, "made first feed major job");
- $handle = $client->insert($job);
- isa_ok $handle, 'TheSchwartz::JobHandle';
-
- # insert again (notably to same db) and see it fails
- $job = TheSchwartz::Job->new(
- funcname => 'feed',
- uniqkey => "major",
- );
- ok($job, "made another feed major job");
- $handle = $client->insert($job);
- ok(! $handle, 'no handle');
-
- # insert same uniqkey, but different func
- $job = TheSchwartz::Job->new(
- funcname => 'scratch',
- uniqkey => "major",
- );
- ok($job, "made scratch major job");
- $handle = $client->insert($job);
- isa_ok $handle, 'TheSchwartz::JobHandle';
-
-});
+run_tests(
+ 6,
+ sub {
+ my $client = test_client( dbs => ['ts1'] );
+ my ( $job, $handle );
+
+ # insert a job with unique
+ $job = TheSchwartz::Job->new(
+ funcname => 'feed',
+ uniqkey => "major",
+ );
+ ok( $job, "made first feed major job" );
+ $handle = $client->insert($job);
+ isa_ok $handle, 'TheSchwartz::JobHandle';
+
+ # insert again (notably to same db) and see it fails
+ $job = TheSchwartz::Job->new(
+ funcname => 'feed',
+ uniqkey => "major",
+ );
+ ok( $job, "made another feed major job" );
+ $handle = $client->insert($job);
+ ok( !$handle, 'no handle' );
+
+ # insert same uniqkey, but different func
+ $job = TheSchwartz::Job->new(
+ funcname => 'scratch',
+ uniqkey => "major",
+ );
+ ok( $job, "made scratch major job" );
+ $handle = $client->insert($job);
+ isa_ok $handle, 'TheSchwartz::JobHandle';
+
+ }
+);
@@ -9,51 +9,51 @@ require 't/lib/db-common.pl';
use TheSchwartz;
use Test::More tests => 6;
-run_tests(2, sub {
- my $client = test_client(dbs => ['ts1']);
+run_tests(
+ 2,
+ sub {
+ my $client = test_client( dbs => ['ts1'] );
- my $handle = $client->insert("Worker::Dummy");
- ok($handle, "inserted job");
+ my $handle = $client->insert("Worker::Dummy");
+ ok( $handle, "inserted job" );
- $client->can_do("Worker::Dummy");
- $client->can_do("Worker::Dummy2");
- $client->can_do("Worker::Dummy3");
- $client->work_until_done;
+ $client->can_do("Worker::Dummy");
+ $client->can_do("Worker::Dummy2");
+ $client->can_do("Worker::Dummy3");
+ $client->work_until_done;
- ok(! $handle->is_pending, "job is done");
+ ok( !$handle->is_pending, "job is done" );
- teardown_dbs('ts1');
-});
+ teardown_dbs('ts1');
+ }
+);
############################################################################
package Worker::Dummy;
use base 'TheSchwartz::Worker';
+
sub work {
- my ($class, $job) = @_;
- my $subjob = TheSchwartz::Job->new(
- funcname => 'Worker::Dummy2',
- );
+ my ( $class, $job ) = @_;
+ my $subjob = TheSchwartz::Job->new( funcname => 'Worker::Dummy2', );
$job->replace_with($subjob);
}
-sub max_retries { 2 }
-sub retry_delay { 5 }
-
-
+sub max_retries {2}
+sub retry_delay {5}
package Worker::Dummy2;
use base 'TheSchwartz::Worker';
+
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
$job->completed;
}
package Worker::Dummy3;
use base 'TheSchwartz::Worker';
+
sub work {
- my ($class, $job) = @_;
+ my ( $class, $job ) = @_;
$job->completed;
}
-
-
@@ -0,0 +1,20 @@
+#!perl
+
+use Test::More;
+eval "use Test::Perl::Critic";
+
+if ($@) {
+ Test::More::plan( skip_all =>
+ "Test::Perl::Critic required for testing PBP compliance" );
+}
+else {
+ Test::Perl::Critic->import(
+ -verbose => 8,
+ -severity => 5,
+ -exclude => [
+ 'ProhibitAccessOfPrivateData', # false positives
+ ]
+ );
+}
+
+Test::Perl::Critic::all_critic_ok();
@@ -2,20 +2,22 @@ use strict;
use Test::More;
eval "use Test::Pod::Coverage 1.08";
-plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage" if $@;
+plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage"
+ if $@;
## Eventually we would be able to test coverage for all modules with
## Test::Pod::all_pod_files(), but let's write the docs first.
my %modules = (
'TheSchwartz' => {
also_private => [
- map { qr{ \A $_ \z }xms } qw(
+ map {qr{ \A $_ \z }xms}
+ qw(
current_job debug driver_for funcid_to_name funcname_to_id
handle_from_string hash_databases insert_job_to_driver
is_database_dead mark_database_as_dead reset_abilities
restore_full_abilities set_current_job shuffled_databases
temporarily_remove_ability
- )
+ )
],
},
'TheSchwartz::Worker' => 1,
@@ -24,7 +26,7 @@ my %modules = (
plan tests => scalar keys %modules;
-while (my ($module, $params) = each %modules) {
- pod_coverage_ok($module, ref $params ? $params : ());
+while ( my ( $module, $params ) = each %modules ) {
+ pod_coverage_ok( $module, ref $params ? $params : () );
}
@@ -0,0 +1,13 @@
+use strict;
+use Test::More;
+
+eval "use Test::Spelling";
+if ($@) {
+ plan skip_all => "Test::Spelling required for testing POD spelling";
+}
+else {
+ add_stopwords(qw(DSN TheSchwartz btree schwartzmon lookup));
+}
+
+all_pod_files_spelling_ok();
+