Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

think I'm done with ATOMIC, testing now

  • Loading branch information...
commit 2615be3b3a0f82b684da8823a3d0b2d7ed45aad6 1 parent 1b37a83
@apocalypse authored
View
1  Build.PL 100644 → 100755
@@ -23,6 +23,7 @@ my $build = Module::Build->new(
'POE' => 0,
# FIXME POE stuff that Test::Dependencies needs to see
+ 'POE::Session' => 0,
'POE::Filter::Line' => 0,
'POE::Filter::Reference' => 0,
'POE::Wheel::Run' => 0,
View
3  Changes
@@ -3,6 +3,9 @@ Revision history for Perl extension POE::Component::SimpleDBI.
* 1.23
Switched to Build.PL for the build system
+ Fixed the stupid test dependencies, thanks BiNGOs!
+ Added the new EXPERIMENTAL 'ATOMIC' support, please let me know if it's broken on your setup!
+ Added some more author tests
* 1.22
View
30 MANIFEST
@@ -5,15 +5,27 @@ MANIFEST.SKIP
README
lib/POE/Component/SimpleDBI.pm
lib/POE/Component/SimpleDBI/SubProcess.pm
-t/1_load.t
-t/a_kwalitee.t
-t/a_pod.t
-t/a_strict.t
-t/a_hasversion.t
-t/a_minimumversion.t
-t/a_podcoverage.t
-t/a_manifest.t
-t/a_distribution.t
META.yml Module meta-data (added by MakeMaker)
Changes
examples/db.pl
+
+t/1_load.t
+
+t/a_critic.t
+t/a_kwalitee.t
+t/a_pod.t
+t/a_pod_spelling.t
+t/a_pod_coverage.t
+t/a_strict.t
+t/a_hasversion.t
+t/a_minimumversion.t
+t/a_manifest.t
+t/a_distribution.t
+t/a_compile.t
+t/a_dependencies.t
+t/a_fixme.t
+t/a_prereq.t
+t/a_prereq_build.t
+t/a_dosnewline.t
+t/a_perlmetrics.t
+t/a_is_prereq_outdated.t
View
1  MANIFEST.SKIP
@@ -4,6 +4,7 @@
# Avoid version control files.
\B\.svn\b
+\B\.git\b
# Avoid Makemaker generated and utility files.
\bMANIFEST\.SKIP
View
0  META.yml
No changes.
View
0  Makefile.PL → Makefile.PL.old
File renamed without changes
View
0  README → README.old
File renamed without changes
View
3,551 lib/POE/Component/SimpleDBI.pm
1,865 additions, 1,686 deletions not shown
View
1,256 lib/POE/Component/SimpleDBI/SubProcess.pm
@@ -1,582 +1,678 @@
-# Declare our package
-package POE::Component::SimpleDBI::SubProcess;
-use strict; use warnings;
-
-# Initialize our version
+# Declare our package
+package POE::Component::SimpleDBI::SubProcess;
+use strict; use warnings;
+
+# Initialize our version
use vars qw( $VERSION );
-$VERSION = '12';
-
-# Use Error.pm's try/catch semantics
-use Error qw( :try );
-
-# We pass in data to POE::Filter::Reference
-use POE::Filter::Reference;
-
-# We run the actual DB connection here
-use DBI;
-
-# Our Filter object
-my $filter = POE::Filter::Reference->new();
-
-# Our DBI handle
-my $DB = undef;
-
-# Save the connect struct for future use
-my $CONN = undef;
-
-# Autoflush to avoid weirdness
-$|++;
-
-# Sysread error hits
-my $sysreaderr = 0;
-
-# Set the binmode stuff
-binmode( STDIN );
-binmode( STDOUT );
-
-# This is the subroutine that will get executed upon the fork() call by our parent
-sub main {
- # Okay, now we listen for commands from our parent :)
- while ( sysread( STDIN, my $buffer = '', 1024 ) ) {
- # Feed the line into the filter
- my $data = $filter->get( [ $buffer ] );
-
- # INPUT STRUCTURE IS:
- # $d->{'ACTION'} = SCALAR -> WHAT WE SHOULD DO
- # $d->{'SQL'} = SCALAR -> THE ACTUAL SQL
- # $d->{'PLACEHOLDERS'} = ARRAY -> PLACEHOLDERS WE WILL USE
- # $d->{'PREPARE_CACHED'}= BOOLEAN -> USE CACHED QUERIES?
- # $d->{'ID'} = SCALAR -> THE QUERY ID ( FOR PARENT TO KEEP TRACK OF WHAT IS WHAT )
-
- # $d->{'DSN'} = SCALAR -> DSN for CONNECT
- # $d->{'USERNAME'} = SCALAR -> USERNAME for CONNECT
- # $d->{'PASSWORD'} = SCALAR -> PASSWORD for CONNECT
-
- # Process each data structure
- foreach my $input ( @$data ) {
- # Now, we do the actual work depending on what kind of query it was
- if ( $input->{'ACTION'} eq 'CONNECT' ) {
- # Connect!
- DB_CONNECT( $input );
- } elsif ( $input->{'ACTION'} eq 'DISCONNECT' ) {
- # Disconnect!
- DB_DISCONNECT( $input );
- } elsif ( $input->{'ACTION'} eq 'DO' ) {
- # Fire off the SQL and return success/failure + rows affected
- DB_DO( $input );
- } elsif ( $input->{'ACTION'} eq 'SINGLE' ) {
- # Return a single result
- DB_SINGLE( $input );
- } elsif ( $input->{'ACTION'} eq 'MULTIPLE' ) {
- # Get many results, then return them all at the same time
- DB_MULTIPLE( $input );
- } elsif ( $input->{'ACTION'} eq 'QUOTE' ) {
- DB_QUOTE( $input );
- } elsif ( $input->{'ACTION'} eq 'EXIT' ) {
- # Cleanly disconnect from the DB
- if ( defined $DB ) {
- $DB->disconnect();
- undef $DB;
- }
-
- # EXIT!
- exit 0;
- } else {
- # Unrecognized action!
- output( Make_Error( $input->{'ID'}, 'Unknown action sent from parent' ) );
- }
- }
- }
-
- # Arrived here due to error in sysread/etc
- output( Make_Error( 'SYSREAD', $! ) );
-
- # If we got more than 5 sysread errors, abort!
- if ( ++$sysreaderr == 5 ) {
- if ( defined $DB ) { $DB->disconnect() }
- exit 0;
- } else {
- goto &main;
- }
-}
-
-# Connects to the DB
-sub DB_CONNECT {
- # Get the input structure
- my $data = shift;
-
- # Our output structure
- my $output = undef;
-
- # Are we reconnecting?
- my $reconn = shift;
-
- # Are we already connected?
- if ( defined $DB and $DB->ping() ) {
- # Output success
- $output = {
- 'ID' => $data->{'ID'},
- };
- } else {
- # Actually make the connection :)
- try {
- $DB = DBI->connect(
- # The DSN we just set up
- $data->{'DSN'},
-
- # Username
- $data->{'USERNAME'},
-
- # Password
- $data->{'PASSWORD'},
-
- # We set some configuration stuff here
- {
- # We do not want users seeing 'spam' on the commandline...
- 'PrintError' => 0,
-
- # Automatically raise errors so we can catch them with try/catch
- 'RaiseError' => 1,
-
- # Disable the DBI tracing
- 'TraceLevel' => 0,
- }
- );
-
- # Check for undefined-ness
- if ( ! defined $DB ) {
- die "Error Connecting: $DBI::errstr";
- } else {
- # Output success
- $output = {
- 'ID' => $data->{'ID'},
- };
-
- # Save this!
- $CONN = $data;
- }
- } catch Error with {
- # Get the error
- my $e = shift;
-
- # Declare it!
- $output = Make_Error( $data->{'ID'}, $e );
- };
- }
-
- # All done!
- if ( ! defined $reconn ) {
- output( $output );
- } else {
- # Reconnect attempt, was it successful?
- if ( ! exists $output->{'ERROR'} ) {
- return 1;
- } else {
- return undef;
- }
- }
-}
-
-# Disconnects from the DB
-sub DB_DISCONNECT {
- # Get the input structure
- my $data = shift;
-
- # Our output structure
- my $output = undef;
-
- # Are we already disconnected?
- if ( ! defined $DB ) {
- # Output success
- $output = {
- 'ID' => $data->{'ID'},
- };
- } else {
- # Disconnect from the DB
- try {
- $DB->disconnect();
- undef $DB;
-
- # Output success
- $output = {
- 'ID' => $data->{'ID'},
- };
- } catch Error with {
- # Get the error
- my $e = shift;
-
- # Declare it!
- $output = Make_Error( $data->{'ID'}, $e );
- };
- }
-
- # All done!
- output( $output );
-}
-
-# This subroutine does a DB QUOTE
-sub DB_QUOTE {
- # Get the input structure
- my $data = shift;
-
- # The result
- my $quoted = undef;
- my $output = undef;
-
- # Check if we are connected
- if ( ! defined $DB or ! $DB->ping() ) {
- # Automatically try to reconnect
- if ( ! DB_CONNECT( $CONN, 'RECONNECT' ) ) {
- output( Make_Error( 'GONE', 'Lost connection to the database server.' ) );
- return;
- }
- }
-
- # Quote it!
- try {
- $quoted = $DB->quote( $data->{'SQL'} );
- } catch Error with {
- # Get the error
- my $e = shift;
-
- $output = Make_Error( $data->{'ID'}, $e );
- };
-
- # Check for errors
- if ( ! defined $output ) {
- # Make output include the results
- $output = {};
- $output->{'DATA'} = $quoted;
- $output->{'ID'} = $data->{'ID'};
- }
-
- # All done!
- output( $output );
-}
-
-# This subroutine runs a 'SELECT' style query on the db
-sub DB_MULTIPLE {
- # Get the input structure
- my $data = shift;
-
- # Variables we use
- my $output = undef;
- my $sth = undef;
- my $result = [];
-
- # Check if we are connected
- if ( ! defined $DB or ! $DB->ping() ) {
- # Automatically try to reconnect
- if ( ! DB_CONNECT( $CONN, 'RECONNECT' ) ) {
- output( Make_Error( 'GONE', 'Lost connection to the database server.' ) );
- return;
- }
- }
-
- # Catch any errors :)
- try {
- # Make a new statement handler and prepare the query
- if ( $data->{'PREPARE_CACHED'} ) {
- $sth = $DB->prepare_cached( $data->{'SQL'} );
- } else {
- $sth = $DB->prepare( $data->{'SQL'} );
- }
-
- # Check for undef'ness
- if ( ! defined $sth ) {
- die "Did not get sth: $DBI::errstr";
- } else {
- # Execute the query
- try {
- # Put placeholders?
- if ( exists $data->{'PLACEHOLDERS'} ) {
- $sth->execute( @{ $data->{'PLACEHOLDERS'} } );
- } else {
- $sth->execute();
- }
- } catch Error with {
- die $sth->errstr;
- };
- }
-
- # The result hash
- my $newdata;
-
- # Bind the columns
- try {
- $sth->bind_columns( \( @$newdata{ @{ $sth->{'NAME_lc'} } } ) );
- } catch Error with {
- die $sth->errstr;
- };
-
- # Actually do the query!
- try {
- while ( $sth->fetch() ) {
- # Copy the data, and push it into the array
- push( @{ $result }, { %{ $newdata } } );
- }
- } catch Error with {
- die $sth->errstr;
- };
-
- # Check for any errors that might have terminated the loop early
- if ( $sth->err() ) {
- # Premature termination!
- die $sth->errstr;
- }
- } catch Error with {
- # Get the error
- my $e = shift;
-
- $output = Make_Error( $data->{'ID'}, $e );
- };
-
- # Check if we got any errors
- if ( ! defined $output ) {
- # Make output include the results
- $output = {};
- $output->{'DATA'} = $result;
- $output->{'ID'} = $data->{'ID'};
- }
-
- # Finally, we clean up this statement handle
- if ( defined $sth ) {
- $sth->finish();
-
- # Make sure the object is gone, thanks Sjors!
- undef $sth;
- }
-
- # Return the data structure
- output( $output );
-}
-
-# This subroutine runs a 'SELECT ... LIMIT 1' style query on the db
-sub DB_SINGLE {
- # Get the input structure
- my $data = shift;
-
- # Variables we use
- my $output = undef;
- my $sth = undef;
- my $result = undef;
-
- # Check if we are connected
- if ( ! defined $DB or ! $DB->ping() ) {
- # Automatically try to reconnect
- if ( ! DB_CONNECT( $CONN, 'RECONNECT' ) ) {
- output( Make_Error( 'GONE', 'Lost connection to the database server.' ) );
- return;
- }
- }
-
- # Catch any errors :)
- try {
- # Make a new statement handler and prepare the query
- if ( $data->{'PREPARE_CACHED'} ) {
- $sth = $DB->prepare_cached( $data->{'SQL'} );
- } else {
- $sth = $DB->prepare( $data->{'SQL'} );
- }
-
- # Check for undef'ness
- if ( ! defined $sth ) {
- die "Did not get sth: $DBI::errstr";
- } else {
- # Execute the query
- try {
- # Put placeholders?
- if ( exists $data->{'PLACEHOLDERS'} ) {
- $sth->execute( @{ $data->{'PLACEHOLDERS'} } );
- } else {
- $sth->execute();
- }
- } catch Error with {
- die $sth->errstr;
- };
- }
-
- # Actually do the query!
- try {
- $result = $sth->fetchrow_hashref();
- } catch Error with {
- die $sth->errstr;
- };
- } catch Error with {
- # Get the error
- my $e = shift;
-
- $output = Make_Error( $data->{'ID'}, $e );
- };
-
- # Check if we got any errors
- if ( ! defined $output ) {
- # Make output include the results
- $output = {};
- $output->{'DATA'} = $result;
- $output->{'ID'} = $data->{'ID'};
- }
-
- # Finally, we clean up this statement handle
- if ( defined $sth ) {
- $sth->finish();
-
- # Make sure the object is gone, thanks Sjors!
- undef $sth;
- }
-
- # Return the data structure
- output( $output );
-}
-
-# This subroutine runs a 'DO' style query on the db
-sub DB_DO {
- # Get the input structure
- my $data = shift;
-
- # Variables we use
- my $output = undef;
- my $sth = undef;
- my $rows_affected = undef;
- my $last_id = undef;
-
- # Check if we are connected
- if ( ! defined $DB or ! $DB->ping() ) {
- # Automatically try to reconnect
- if ( ! DB_CONNECT( $CONN, 'RECONNECT' ) ) {
- output( Make_Error( 'GONE', 'Lost connection to the database server.' ) );
- return;
- }
- }
-
- # Catch any errors :)
- try {
- # Make a new statement handler and prepare the query
- if ( $data->{'PREPARE_CACHED'} ) {
- $sth = $DB->prepare_cached( $data->{'SQL'} );
- } else {
- $sth = $DB->prepare( $data->{'SQL'} );
- }
-
- # Check for undef'ness
- if ( ! defined $sth ) {
- die "Did not get sth: $DBI::errstr";
- } else {
- # Execute the query
- try {
- # Put placeholders?
- if ( exists $data->{'PLACEHOLDERS'} ) {
- $rows_affected = $sth->execute( @{ $data->{'PLACEHOLDERS'} } );
- } else {
- $rows_affected = $sth->execute();
- }
-
- # Should we even attempt this?
- if ( $data->{'INSERT_ID'} ) {
- try {
- # Get the last insert id ( make this portable! )
- $last_id = $DB->last_insert_id( undef, undef, undef, undef );
- } catch Error with {
- # Ignore this error!
- };
- }
- } catch Error with {
- die $sth->errstr;
- };
- }
- } catch Error with {
- # Get the error
- my $e = shift;
-
- $output = Make_Error( $data->{'ID'}, $e );
- };
-
- # If rows_affected is not undef, that means we were successful
- if ( defined $rows_affected && ! defined $output ) {
- # Make the data structure
- $output = {};
- $output->{'DATA'} = $rows_affected;
- $output->{'ID'} = $data->{'ID'};
- $output->{'INSERTID'} = $last_id;
- } elsif ( ! defined $rows_affected && ! defined $output ) {
- # Internal error...
- die 'Internal Error in DB_DO';
- }
-
- # Finally, we clean up this statement handle
- if ( defined $sth ) {
- $sth->finish();
-
- # Make sure the object is gone, thanks Sjors!
- undef $sth;
- }
-
- # Return the data structure
- output( $output );
-}
-
-# This subroutine makes a generic error structure
-sub Make_Error {
- # Make the structure
- my $data = {};
- $data->{'ID'} = shift;
-
- # Get the error, and stringify it in case of Error::Simple objects
- my $error = shift;
-
- if ( ref $error and ref( $error ) eq 'Error::Simple' ) {
- $data->{'ERROR'} = $error->text;
- } else {
- $data->{'ERROR'} = $error;
- }
-
- # All done!
- return $data;
-}
-
-# Prints any output to STDOUT
-sub output {
- # Get the data
- my $data = shift;
-
- # Freeze it!
- my $output = $filter->put( [ $data ] );
-
- # Print it!
- print STDOUT @$output;
-}
-
-# End of module
-1;
-
-__END__
-
-=head1 NAME
-
-POE::Component::SimpleDBI::SubProcess - Backend of POE::Component::SimpleDBI
-
-=head1 ABSTRACT
-
-This module is responsible for implementing the guts of POE::Component::SimpleDBI.
-Namely, the fork/exec and the connection to the DBI.
-
-=head2 EXPORT
-
-Nothing.
-
-=head1 SEE ALSO
-
-L<POE::Component::SimpleDBI>
-
-=head1 AUTHOR
-
-Apocalypse E<lt>apocal@cpan.orgE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2008 by Apocalypse
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
+$VERSION = '12';
+
+# Use Error.pm's try/catch semantics
+use Error qw( :try );
+
+# We pass in data to POE::Filter::Reference
+use POE::Filter::Reference;
+
+# We run the actual DB connection here
+use DBI;
+
+# Our Filter object
+my $filter = POE::Filter::Reference->new();
+
+# Our DBI handle
+my $DB = undef;
+
+# Save the connect struct for future use
+my $CONN = undef;
+
+# Autoflush to avoid weirdness
+$|++;
+
+# Sysread error hits
+my $sysreaderr = 0;
+
+# Set the binmode stuff
+binmode( STDIN );
+binmode( STDOUT );
+
+# This is the subroutine that will get executed upon the fork() call by our parent
+sub main {
+ # Okay, now we listen for commands from our parent :)
+ while ( sysread( STDIN, my $buffer = '', 1024 ) ) {
+ # Feed the line into the filter
+ my $data = $filter->get( [ $buffer ] );
+
+ # INPUT STRUCTURE IS:
+ # $d->{'ACTION'} = SCALAR -> WHAT WE SHOULD DO
+ # $d->{'SQL'} = SCALAR -> THE ACTUAL SQL
+ # $d->{'SQL'} = ARRAY -> THE ACTUAL SQL ( in case of ATOMIC )
+ # $d->{'PLACEHOLDERS'} = ARRAY -> PLACEHOLDERS WE WILL USE
+ # $d->{'PREPARE_CACHED'}= BOOLEAN -> USE CACHED QUERIES?
+ # $d->{'ID'} = SCALAR -> THE QUERY ID ( FOR PARENT TO KEEP TRACK OF WHAT IS WHAT )
+
+ # $d->{'DSN'} = SCALAR -> DSN for CONNECT
+ # $d->{'USERNAME'} = SCALAR -> USERNAME for CONNECT
+ # $d->{'PASSWORD'} = SCALAR -> PASSWORD for CONNECT
+
+ # Process each data structure
+ foreach my $input ( @$data ) {
+ # Now, we do the actual work depending on what kind of query it was
+ if ( $input->{'ACTION'} eq 'CONNECT' ) {
+ # Connect!
+ DB_CONNECT( $input );
+ } elsif ( $input->{'ACTION'} eq 'DISCONNECT' ) {
+ # Disconnect!
+ DB_DISCONNECT( $input );
+ } elsif ( $input->{'ACTION'} eq 'DO' ) {
+ # Fire off the SQL and return success/failure + rows affected
+ DB_DO( $input );
+ } elsif ( $input->{'ACTION'} eq 'SINGLE' ) {
+ # Return a single result
+ DB_SINGLE( $input );
+ } elsif ( $input->{'ACTION'} eq 'MULTIPLE' ) {
+ # Get many results, then return them all at the same time
+ DB_MULTIPLE( $input );
+ } elsif ( $input->{'ACTION'} eq 'QUOTE' ) {
+ DB_QUOTE( $input );
+ } elsif ( $input->{'ACTION'} eq 'ATOMIC' ) {
+ DB_ATOMIC( $input );
+ } elsif ( $input->{'ACTION'} eq 'EXIT' ) {
+ # Cleanly disconnect from the DB
+ if ( defined $DB ) {
+ $DB->disconnect();
+ undef $DB;
+ }
+
+ # EXIT!
+ exit 0;
+ } else {
+ # Unrecognized action!
+ output( Make_Error( $input->{'ID'}, 'Unknown action sent from parent' ) );
+ }
+ }
+ }
+
+ # Arrived here due to error in sysread/etc
+ output( Make_Error( 'SYSREAD', $! ) );
+
+ # If we got more than 5 sysread errors, abort!
+ if ( ++$sysreaderr == 5 ) {
+ if ( defined $DB ) { $DB->disconnect() }
+ exit 0;
+ } else {
+ goto &main;
+ }
+}
+
+# Connects to the DB
+sub DB_CONNECT {
+ # Get the input structure
+ my $data = shift;
+
+ # Our output structure
+ my $output = undef;
+
+ # Are we reconnecting?
+ my $reconn = shift;
+
+ # Are we already connected?
+ if ( defined $DB and $DB->ping() ) {
+ # Output success
+ $output = {
+ 'ID' => $data->{'ID'},
+ };
+ } else {
+ # Actually make the connection :)
+ try {
+ $DB = DBI->connect(
+ # The DSN we just set up
+ $data->{'DSN'},
+
+ # Username
+ $data->{'USERNAME'},
+
+ # Password
+ $data->{'PASSWORD'},
+
+ # We set some configuration stuff here
+ {
+ # We do not want users seeing 'spam' on the commandline...
+ 'PrintError' => 0,
+
+ # Automatically raise errors so we can catch them with try/catch
+ 'RaiseError' => 1,
+
+ # Disable the DBI tracing
+ 'TraceLevel' => 0,
+ }
+ );
+
+ # Check for undefined-ness
+ if ( ! defined $DB ) {
+ die "Error Connecting: $DBI::errstr";
+ } else {
+ # Output success
+ $output = {
+ 'ID' => $data->{'ID'},
+ };
+
+ # Save this!
+ $CONN = $data;
+ }
+ } catch Error with {
+ # Get the error
+ my $e = shift;
+
+ # Declare it!
+ $output = Make_Error( $data->{'ID'}, $e );
+ };
+ }
+
+ # All done!
+ if ( ! defined $reconn ) {
+ output( $output );
+ } else {
+ # Reconnect attempt, was it successful?
+ if ( ! exists $output->{'ERROR'} ) {
+ return 1;
+ } else {
+ return;
+ }
+ }
+}
+
+# Disconnects from the DB
+sub DB_DISCONNECT {
+ # Get the input structure
+ my $data = shift;
+
+ # Our output structure
+ my $output = undef;
+
+ # Are we already disconnected?
+ if ( ! defined $DB ) {
+ # Output success
+ $output = {
+ 'ID' => $data->{'ID'},
+ };
+ } else {
+ # Disconnect from the DB
+ try {
+ $DB->disconnect();
+ undef $DB;
+
+ # Output success
+ $output = {
+ 'ID' => $data->{'ID'},
+ };
+ } catch Error with {
+ # Get the error
+ my $e = shift;
+
+ # Declare it!
+ $output = Make_Error( $data->{'ID'}, $e );
+ };
+ }
+
+ # All done!
+ output( $output );
+}
+
+# This subroutine does a DB QUOTE
+sub DB_QUOTE {
+ # Get the input structure
+ my $data = shift;
+
+ # The result
+ my $quoted = undef;
+ my $output = undef;
+
+ # Check if we are connected
+ if ( ! defined $DB or ! $DB->ping() ) {
+ # Automatically try to reconnect
+ if ( ! DB_CONNECT( $CONN, 'RECONNECT' ) ) {
+ output( Make_Error( 'GONE', 'Lost connection to the database server.' ) );
+ return;
+ }
+ }
+
+ # Quote it!
+ try {
+ $quoted = $DB->quote( $data->{'SQL'} );
+ } catch Error with {
+ # Get the error
+ my $e = shift;
+
+ $output = Make_Error( $data->{'ID'}, $e );
+ };
+
+ # Check for errors
+ if ( ! defined $output ) {
+ # Make output include the results
+ $output = {};
+ $output->{'DATA'} = $quoted;
+ $output->{'ID'} = $data->{'ID'};
+ }
+
+ # All done!
+ output( $output );
+}
+
+# This subroutine runs a 'SELECT' style query on the db
+sub DB_MULTIPLE {
+ # Get the input structure
+ my $data = shift;
+
+ # Variables we use
+ my $output = undef;
+ my $sth = undef;
+ my $result = [];
+
+ # Check if we are connected
+ if ( ! defined $DB or ! $DB->ping() ) {
+ # Automatically try to reconnect
+ if ( ! DB_CONNECT( $CONN, 'RECONNECT' ) ) {
+ output( Make_Error( 'GONE', 'Lost connection to the database server.' ) );
+ return;
+ }
+ }
+
+ # Catch any errors :)
+ try {
+ # Make a new statement handler and prepare the query
+ if ( $data->{'PREPARE_CACHED'} ) {
+ $sth = $DB->prepare_cached( $data->{'SQL'} );
+ } else {
+ $sth = $DB->prepare( $data->{'SQL'} );
+ }
+
+ # Check for undef'ness
+ if ( ! defined $sth ) {
+ die "Did not get sth: $DBI::errstr";
+ } else {
+ # Execute the query
+ try {
+ # Put placeholders?
+ if ( exists $data->{'PLACEHOLDERS'} ) {
+ $sth->execute( @{ $data->{'PLACEHOLDERS'} } );
+ } else {
+ $sth->execute();
+ }
+ } catch Error with {
+ die $sth->errstr;
+ };
+ }
+
+ # The result hash
+ my $newdata;
+
+ # Bind the columns
+ try {
+ $sth->bind_columns( \( @$newdata{ @{ $sth->{'NAME_lc'} } } ) );
+ } catch Error with {
+ die $sth->errstr;
+ };
+
+ # Actually do the query!
+ try {
+ while ( $sth->fetch() ) {
+ # Copy the data, and push it into the array
+ push( @{ $result }, { %{ $newdata } } );
+ }
+ } catch Error with {
+ die $sth->errstr;
+ };
+
+ # Check for any errors that might have terminated the loop early
+ if ( $sth->err() ) {
+ # Premature termination!
+ die $sth->errstr;
+ }
+ } catch Error with {
+ # Get the error
+ my $e = shift;
+
+ $output = Make_Error( $data->{'ID'}, $e );
+ };
+
+ # Check if we got any errors
+ if ( ! defined $output ) {
+ # Make output include the results
+ $output = {};
+ $output->{'DATA'} = $result;
+ $output->{'ID'} = $data->{'ID'};
+ }
+
+ # Finally, we clean up this statement handle
+ if ( defined $sth ) {
+ $sth->finish();
+
+ # Make sure the object is gone, thanks Sjors!
+ undef $sth;
+ }
+
+ # Return the data structure
+ output( $output );
+}
+
+# This subroutine runs a 'SELECT ... LIMIT 1' style query on the db
+sub DB_SINGLE {
+ # Get the input structure
+ my $data = shift;
+
+ # Variables we use
+ my $output = undef;
+ my $sth = undef;
+ my $result = undef;
+
+ # Check if we are connected
+ if ( ! defined $DB or ! $DB->ping() ) {
+ # Automatically try to reconnect
+ if ( ! DB_CONNECT( $CONN, 'RECONNECT' ) ) {
+ output( Make_Error( 'GONE', 'Lost connection to the database server.' ) );
+ return;
+ }
+ }
+
+ # Catch any errors :)
+ try {
+ # Make a new statement handler and prepare the query
+ if ( $data->{'PREPARE_CACHED'} ) {
+ $sth = $DB->prepare_cached( $data->{'SQL'} );
+ } else {
+ $sth = $DB->prepare( $data->{'SQL'} );
+ }
+
+ # Check for undef'ness
+ if ( ! defined $sth ) {
+ die "Did not get sth: $DBI::errstr";
+ } else {
+ # Execute the query
+ try {
+ # Put placeholders?
+ if ( exists $data->{'PLACEHOLDERS'} ) {
+ $sth->execute( @{ $data->{'PLACEHOLDERS'} } );
+ } else {
+ $sth->execute();
+ }
+ } catch Error with {
+ die $sth->errstr;
+ };
+ }
+
+ # Actually do the query!
+ try {
+ $result = $sth->fetchrow_hashref();
+ } catch Error with {
+ die $sth->errstr;
+ };
+ } catch Error with {
+ # Get the error
+ my $e = shift;
+
+ $output = Make_Error( $data->{'ID'}, $e );
+ };
+
+ # Check if we got any errors
+ if ( ! defined $output ) {
+ # Make output include the results
+ $output = {};
+ $output->{'DATA'} = $result;
+ $output->{'ID'} = $data->{'ID'};
+ }
+
+ # Finally, we clean up this statement handle
+ if ( defined $sth ) {
+ $sth->finish();
+
+ # Make sure the object is gone, thanks Sjors!
+ undef $sth;
+ }
+
+ # Return the data structure
+ output( $output );
+}
+
+# This subroutine runs a 'DO' style query on the db
+sub DB_DO {
+ # Get the input structure
+ my $data = shift;
+
+ # Variables we use
+ my $output = undef;
+ my $sth = undef;
+ my $rows_affected = undef;
+ my $last_id = undef;
+
+ # Check if we are connected
+ if ( ! defined $DB or ! $DB->ping() ) {
+ # Automatically try to reconnect
+ if ( ! DB_CONNECT( $CONN, 'RECONNECT' ) ) {
+ output( Make_Error( 'GONE', 'Lost connection to the database server.' ) );
+ return;
+ }
+ }
+
+ # Catch any errors :)
+ try {
+ # Make a new statement handler and prepare the query
+ if ( $data->{'PREPARE_CACHED'} ) {
+ $sth = $DB->prepare_cached( $data->{'SQL'} );
+ } else {
+ $sth = $DB->prepare( $data->{'SQL'} );
+ }
+
+ # Check for undef'ness
+ if ( ! defined $sth ) {
+ die "Did not get sth: $DBI::errstr";
+ } else {
+ # Execute the query
+ try {
+ # Put placeholders?
+ if ( exists $data->{'PLACEHOLDERS'} ) {
+ $rows_affected = $sth->execute( @{ $data->{'PLACEHOLDERS'} } );
+ } else {
+ $rows_affected = $sth->execute();
+ }
+
+ # Should we even attempt this?
+ if ( $data->{'INSERT_ID'} ) {
+ try {
+ # Get the last insert id ( make this portable! )
+ $last_id = $DB->last_insert_id( undef, undef, undef, undef );
+ } catch Error with {
+ # Ignore this error!
+ };
+ }
+ } catch Error with {
+ die $sth->errstr;
+ };
+ }
+ } catch Error with {
+ # Get the error
+ my $e = shift;
+
+ $output = Make_Error( $data->{'ID'}, $e );
+ };
+
+ # If rows_affected is not undef, that means we were successful
+ if ( defined $rows_affected && ! defined $output ) {
+ # Make the data structure
+ $output = {};
+ $output->{'DATA'} = $rows_affected;
+ $output->{'ID'} = $data->{'ID'};
+ $output->{'INSERTID'} = $last_id;
+ } elsif ( ! defined $rows_affected && ! defined $output ) {
+ # Internal error...
+ die 'Internal Error in DB_DO';
+ }
+
+ # Finally, we clean up this statement handle
+ if ( defined $sth ) {
+ $sth->finish();
+
+ # Make sure the object is gone, thanks Sjors!
+ undef $sth;
+ }
+
+ # Return the data structure
+ output( $output );
+}
+
+# This subroutine runs a 'DO' style query on the db in a transaction
+sub DB_ATOMIC {
+ # Get the input structure
+ my $data = shift;
+
+ # Variables we use
+ my $output = undef;
+ my $sth = undef;
+
+ # Check if we are connected
+ if ( ! defined $DB or ! $DB->ping() ) {
+ # Automatically try to reconnect
+ if ( ! DB_CONNECT( $CONN, 'RECONNECT' ) ) {
+ output( Make_Error( 'GONE', 'Lost connection to the database server.' ) );
+ return;
+ }
+ }
+
+ # Catch any errors :)
+ try {
+ # start the transaction
+ $DB->begin_work;
+
+ # process each query
+ for my $idx ( 0 .. scalar @{ $data->{'SQL'} } ) {
+ if ( $data->{'PREPARE_CACHED'} ) {
+ $sth = $DB->prepare_cached( $data->{'SQL'}->[ $idx ] );
+ } else {
+ $sth = $DB->prepare( $data->{'SQL'}->[ $idx ] );
+ }
+
+ # actually execute it!
+ try {
+ if ( defined $data->{'PLACEHOLDERS'}->[ $idx ] ) {
+ $sth->execute( $data->{'PLACEHOLDERS'}->[ $idx ] );
+ } else {
+ $sth->execute;
+ }
+ } catch Error with {
+ die $sth->errstr;
+ };
+
+ # Finally, we clean up this statement handle
+ $sth->finish();
+
+ # Make sure the object is gone, thanks Sjors!
+ undef $sth;
+ }
+
+ # done with transaction!
+ $DB->commit;
+ } catch Error with {
+ # Get the error
+ my $e = shift;
+
+ # rollback the changes!
+ try {
+ $DB->rollback;
+ } catch Error with {
+ # Get the error
+ my $error = shift;
+
+ $output = Make_Error( $data->{'ID'}, $e );
+ $output->{'DATA'} = 'ROLLBACK_FAILURE';
+ };
+
+ # did we rollback fine?
+ if ( ! defined $output ) {
+ $output = Make_Error( $data->{'ID'}, $e );
+ $output->{'DATA'} = 'COMMIT_FAILURE';
+ }
+ };
+
+ # Finally, we clean up this statement handle
+ if ( defined $sth ) {
+ $sth->finish();
+
+ # Make sure the object is gone, thanks Sjors!
+ undef $sth;
+ }
+
+ # If we got no output, we did it!
+ if ( ! defined $output ) {
+ # Make the data structure
+ $output = {};
+ $output->{'DATA'} = 'SUCCESS';
+ $output->{'ID'} = $data->{'ID'};
+ }
+
+ # Return the data structure
+ output( $output );
+}
+
+# This subroutine makes a generic error structure
+sub Make_Error {
+ # Make the structure
+ my $data = {};
+ $data->{'ID'} = shift;
+
+ # Get the error, and stringify it in case of Error::Simple objects
+ my $error = shift;
+
+ if ( ref $error and ref( $error ) eq 'Error::Simple' ) {
+ $data->{'ERROR'} = $error->text;
+ } else {
+ $data->{'ERROR'} = $error;
+ }
+
+ # All done!
+ return $data;
+}
+
+# Prints any output to STDOUT
+sub output {
+ # Get the data
+ my $data = shift;
+
+ # Freeze it!
+ my $output = $filter->put( [ $data ] );
+
+ # Print it!
+ print STDOUT @$output;
+}
+
+# End of module
+1;
+
+__END__
+
+=head1 NAME
+
+POE::Component::SimpleDBI::SubProcess - Backend of POE::Component::SimpleDBI
+
+=head1 ABSTRACT
+
+This module is responsible for implementing the guts of POE::Component::SimpleDBI.
+Namely, the fork/exec and the connection to the DBI.
+
+=head2 EXPORT
+
+Nothing.
+
+=head1 SEE ALSO
+
+L<POE::Component::SimpleDBI>
+
+=head1 AUTHOR
+
+Apocalypse E<lt>apocal@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2008 by Apocalypse
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
=cut
View
20 t/1_load.t
@@ -1,10 +1,10 @@
-#!/usr/bin/perl
-
-# Import the stuff
-# XXX no idea why this is broken for this particular dist!
-#use Test::UseAllModules;
-#BEGIN { all_uses_ok(); }
-
-use Test::More tests => 2;
-use_ok( 'POE::Component::SimpleDBI::SubProcess' );
-use_ok( 'POE::Component::SimpleDBI' );
+#!/usr/bin/perl
+
+# Import the stuff
+# XXX no idea why this is broken for this particular dist!
+#use Test::UseAllModules;
+#BEGIN { all_uses_ok(); }
+
+use Test::More tests => 2;
+use_ok( 'POE::Component::SimpleDBI::SubProcess' );
+use_ok( 'POE::Component::SimpleDBI' );
View
15 t/a_compile.t
@@ -0,0 +1,15 @@
+#!/usr/bin/perl
+
+use Test::More;
+
+# AUTHOR test
+if ( not $ENV{TEST_AUTHOR} ) {
+ plan skip_all => 'Author test. Sent $ENV{TEST_AUTHOR} to a true value to run.';
+} else {
+ eval "use Test::Compile";
+ if ( $@ ) {
+ plan skip_all => 'Test::Compile required for validating the perl files';
+ } else {
+ all_pm_files_ok();
+ }
+}
View
26 t/a_critic.t
@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+
+use Test::More;
+
+# AUTHOR test
+if ( not $ENV{TEST_AUTHOR} ) {
+ plan skip_all => 'Author test. Sent $ENV{TEST_AUTHOR} to a true value to run.';
+} else {
+ if ( not $ENV{PERL_TEST_CRITIC} ) {
+ plan skip_all => 'PerlCritic test. Sent $ENV{PERL_TEST_CRITIC} to a true value to run.';
+ } else {
+ # did we get a severity level?
+ if ( length $ENV{PERL_TEST_CRITIC} > 1 ) {
+ eval "use Test::Perl::Critic ( -severity => \"$ENV{PERL_TEST_CRITIC}\" );";
+ } else {
+ eval "use Test::Perl::Critic;";
+ #eval "use Test::Perl::Critic ( -severity => 'stern' );";
+ }
+
+ if ( $@ ) {
+ plan skip_all => 'Test::Perl::Critic required to criticise perl files';
+ } else {
+ all_critic_ok( 'lib/' );
+ }
+ }
+}
View
15 t/a_dependencies.t
@@ -0,0 +1,15 @@
+#!/usr/bin/perl
+
+use Test::More;
+
+# AUTHOR test
+if ( not $ENV{TEST_AUTHOR} ) {
+ plan skip_all => 'Author test. Sent $ENV{TEST_AUTHOR} to a true value to run.';
+} else {
+ eval "use Test::Dependencies exclude => [ qw/ POE::Component::SimpleDBI Module::Build / ], style => 'light';";
+ if ( $@ ) {
+ plan skip_all => 'Test::Dependencies required to test perl module deps';
+ } else {
+ ok_dependencies();
+ }
+}
View
35 t/a_dosnewline.t
@@ -0,0 +1,35 @@
+#!/usr/bin/perl
+
+use Test::More;
+
+# AUTHOR test
+if ( not $ENV{TEST_AUTHOR} ) {
+ plan skip_all => 'Author test. Sent $ENV{TEST_AUTHOR} to a true value to run.';
+} else {
+ eval "use File::Find::Rule";
+ if ( $@ ) {
+ plan skip_all => 'File::Find::Rule required for checking for presence of DOS newlines';
+ } else {
+ plan tests => 1;
+
+ # generate the file list
+ my $rule = File::Find::Rule->new;
+ $rule->grep( qr/\r\n/ );
+ my @files = $rule->in( qw( lib t examples ) );
+
+ # FIXME read in MANIFEST.SKIP and use it!
+ # for now, we skip SVN + git stuff
+ @files = grep { $_ !~ /(?:\/\.svn\/|\/\.git\/)/ } @files;
+
+ # do we have any?
+ if ( scalar @files ) {
+ fail( 'newline check' );
+ diag( 'DOS newlines found in these files:' );
+ foreach my $f ( @files ) {
+ diag( ' ' . $f );
+ }
+ } else {
+ pass( 'newline check' );
+ }
+ }
+}
View
18 t/a_fixme.t
@@ -0,0 +1,18 @@
+#!/usr/bin/perl
+
+use Test::More;
+
+# AUTHOR test
+if ( not $ENV{TEST_AUTHOR} ) {
+ plan skip_all => 'Author test. Sent $ENV{TEST_AUTHOR} to a true value to run.';
+} else {
+ eval "use Test::Fixme";
+ if ( $@ ) {
+ plan skip_all => 'Test::Fixme required for checking for presence of FIXMEs';
+ } else {
+ run_tests(
+ 'where' => 'lib',
+ 'match' => qr/FIXME|TODO/,
+ );
+ }
+}
View
128 t/a_is_prereq_outdated.t
@@ -0,0 +1,128 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Test::More;
+
+# AUTHOR test
+if ( not $ENV{TEST_AUTHOR} ) {
+ plan skip_all => 'Author test. Sent $ENV{TEST_AUTHOR} to a true value to run.';
+} else {
+ # can we load YAML?
+ eval "use YAML";
+ if ( $@ ) {
+ plan skip_all => 'YAML is necessary to check META.yml for prerequisites!';
+ }
+
+ # can we load CPANPLUS?
+ eval "use CPANPLUS::Backend";
+ if ( $@ ) {
+ plan skip_all => 'CPANPLUS is necessary to check module versions!';
+ }
+
+ # can we load version.pm?
+ eval "use version";
+ if ( $@ ) {
+ plan skip_all => 'version.pm is necessary to compare versions!';
+ }
+
+ # does META.yml exist?
+ if ( -e 'META.yml' and -f _ ) {
+ load_yml( 'META.yml' );
+ } else {
+ # maybe one directory up?
+ if ( -e '../META.yml' and -f _ ) {
+ load_yml( '../META.yml' );
+ } else {
+ plan skip_all => 'META.yml is missing, unable to process it!';
+ }
+ }
+}
+
+# main entry point
+sub load_yml {
+ # we'll load a file
+ my $file = shift;
+
+ # okay, proceed to load it!
+ my $data;
+ eval {
+ $data = YAML::LoadFile( $file );
+ };
+ if ( $@ ) {
+ plan skip_all => "Unable to load $file => $@";
+ } else {
+ note "Loaded $file, proceeding with analysis";
+ }
+
+ # massage the data
+ $data = $data->{'requires'};
+ delete $data->{'perl'} if exists $data->{'perl'};
+
+ # FIXME shut up warnings ( eval's fault, blame it! )
+ require version;
+
+ # init the backend ( and set some options )
+ my $cpanconfig = CPANPLUS::Configure->new;
+ $cpanconfig->set_conf( 'verbose' => 0 );
+ $cpanconfig->set_conf( 'no_update' => 1 );
+ my $cpanplus = CPANPLUS::Backend->new( $cpanconfig );
+
+ # silence CPANPLUS!
+ {
+ no warnings 'redefine';
+ eval "sub Log::Message::Handlers::cp_msg { return }";
+ eval "sub Log::Message::Handlers::cp_error { return }";
+ }
+
+ # Okay, how many prereqs do we have?
+ plan tests => scalar keys %$data;
+
+ # analyze every one of them!
+ foreach my $prereq ( keys %$data ) {
+ check_cpan( $cpanplus, $prereq, $data->{ $prereq } );
+ }
+}
+
+# checks a prereq against CPAN
+sub check_cpan {
+ my $backend = shift;
+ my $prereq = shift;
+ my $version = shift;
+
+ # check CPANPLUS
+ my $module = $backend->parse_module( 'module' => $prereq );
+ if ( defined $module ) {
+ # okay, for starters we check to see if it's version 0 then we skip it
+ if ( $version eq '0' ) {
+ ok( 1, "Skipping '$prereq' because it is specified as version 0" );
+ return;
+ }
+
+ # Does the prereq have funky characters that we're unable to process now?
+ if ( $version =~ /[<>=,!]+/ ) {
+ # FIXME simplistic style of parsing
+ my @versions = split( ',', $version );
+
+ # sort them by version, descending
+ @versions =
+ sort { $b <=> $a }
+ map { version->new( $_ ) }
+ map { $_ =~ s/[\s<>=!]+//; $_ }
+ @versions;
+
+ # pick the highest version to use as comparison
+ $version = $versions[0];
+ }
+
+ # convert both objects to version objects so we can compare
+ $version = version->new( $version ) if ! ref $version;
+ my $cpanversion = version->new( $module->version );
+
+ # check it!
+ is( $cpanversion, $version, "Comparing '$prereq' to CPAN version" );
+ } else {
+ ok( 0, "Warning: '$prereq' is not found on CPAN!" );
+ }
+
+ return;
+}
View
25 t/a_kwalitee.t
@@ -11,5 +11,30 @@ if ( not $ENV{TEST_AUTHOR} ) {
plan skip_all => 'Test::Kwalitee required for measuring the kwalitee';
} else {
Test::Kwalitee->import();
+
+ # That piece of crap dumps files all over :(
+ cleanup_debian_files();
+ }
+}
+
+# Module::CPANTS::Kwalitee::Distros suck!
+#t/a_manifest..............1/1
+## Failed test at t/a_manifest.t line 13.
+## got: 1
+## expected: 0
+## The following files are not named in the MANIFEST file: /home/apoc/workspace/VCS-perl-trunk/VCS-2.12.2/Debian_CPANTS.txt
+## Looks like you failed 1 test of 1.
+#t/a_manifest.............. Dubious, test returned 1 (wstat 256, 0x100)
+sub cleanup_debian_files {
+ foreach my $file ( qw( Debian_CPANTS.txt ../Debian_CPANTS.txt ) ) {
+ if ( -e $file and -f _ ) {
+ my $status = unlink( $file );
+ if ( ! $status ) {
+ warn "unable to unlink $file";
+ }
+ }
}
+
+ return;
}
+
View
2  t/a_manifest.t
@@ -11,7 +11,7 @@ if ( not $ENV{TEST_AUTHOR} ) {
plan skip_all => 'Test::CheckManifest required for validating the MANIFEST';
} else {
ok_manifest( {
- 'filter' => [ qr/\.svn/, qr/\.tar\.gz$/ ],
+ 'filter' => [ qr/\.svn/, qr/\.git/, qr/\.tar\.gz$/ ],
} );
}
}
View
2  t/a_minimumversion.t
@@ -10,6 +10,6 @@ if ( not $ENV{TEST_AUTHOR} ) {
if ( $@ ) {
plan skip_all => 'Test::MinimumVersion required to test minimum perl version';
} else {
- all_minimum_version_ok('5.008');
+ all_minimum_version_from_metayml_ok();
}
}
View
63 t/a_perlmetrics.t
@@ -0,0 +1,63 @@
+#!/usr/bin/perl
+
+use Test::More;
+
+# AUTHOR test
+if ( not $ENV{TEST_AUTHOR} ) {
+ plan skip_all => 'Author test. Sent $ENV{TEST_AUTHOR} to a true value to run.';
+} else {
+ eval "use Perl::Metrics::Simple";
+ if ( $@ ) {
+ plan skip_all => 'Perl::Metrics::Simple required to analyze code metrics';
+ } else {
+ # do it!
+ plan tests => 1;
+ my $analzyer = Perl::Metrics::Simple->new;
+ my $analysis = $analzyer->analyze_files( 'lib/' );
+
+ if ( ok( $analysis->file_count(), 'analyzed at least one file' ) ) {
+ # only print extra stuff if necessary
+ if ( $ENV{TEST_VERBOSE} ) {
+ diag( '-- Perl Metrics Summary ( countperl ) --' );
+ diag( ' File Count: ' . $analysis->file_count );
+ diag( ' Package Count: ' . $analysis->package_count );
+ diag( ' Subroutine Count: ' . $analysis->sub_count );
+ diag( ' Total Code Lines: ' . $analysis->lines );
+ diag( ' Non-Sub Lines: ' . $analysis->main_stats->{'lines'} );
+
+ diag( '-- Subrotuine Metrics Summary --' );
+ my $summary_stats = $analysis->summary_stats;
+ diag( ' Min: lines(' . $summary_stats->{sub_length}->{min} . ') McCabe(' . $summary_stats->{sub_complexity}->{min} . ')' );
+ diag( ' Max: lines(' . $summary_stats->{sub_length}->{max} . ') McCabe(' . $summary_stats->{sub_complexity}->{max} . ')' );
+ diag( ' Mean: lines(' . $summary_stats->{sub_length}->{mean} . ') McCabe(' . $summary_stats->{sub_complexity}->{mean} . ')' );
+ diag( ' Standard Deviation: lines(' . $summary_stats->{sub_length}->{standard_deviation} . ') McCabe(' . $summary_stats->{sub_complexity}->{standard_deviation} . ')' );
+ diag( ' Median: lines(' . $summary_stats->{sub_length}->{median} . ') McCabe(' . $summary_stats->{sub_complexity}->{median} . ')' );
+
+ # set number of subs to display
+ my $num = 10;
+
+ diag( "-- Top$num subroutines by McCabe Complexity --" );
+ my @sorted_subs = sort { $b->{'mccabe_complexity'} <=> $a->{'mccabe_complexity'} } @{ $analysis->subs };
+ foreach my $i ( 0 .. ( $num - 1 ) ) {
+ diag( ' ' . $sorted_subs[$i]->{'path'} . ':' . $sorted_subs[$i]->{'name'} . ' ->' .
+ ' McCabe(' . $sorted_subs[$i]->{'mccabe_complexity'} . ')' .
+ ' lines(' . $sorted_subs[$i]->{'lines'} . ')'
+ );
+ }
+
+ diag( "-- Top$num subroutines by lines --" );
+ @sorted_subs = sort { $b->{'lines'} <=> $a->{'lines'} } @sorted_subs;
+ foreach my $i ( 0 .. ( $num - 1 ) ) {
+ diag( ' ' . $sorted_subs[$i]->{'path'} . ':' . $sorted_subs[$i]->{'name'} . ' ->' .
+ ' lines(' . $sorted_subs[$i]->{'lines'} . ')' .
+ ' McCabe(' . $sorted_subs[$i]->{'mccabe_complexity'} . ')'
+ );
+ }
+
+ #require Data::Dumper;
+ #diag( 'Summary Stats: ' . Data::Dumper::Dumper( $analysis->summary_stats ) );
+ #diag( 'File Stats: ' . Data::Dumper::Dumper( $analysis->file_stats ) );
+ }
+ }
+ }
+}
View
12 t/a_pod.t
@@ -6,10 +6,14 @@ use Test::More;
if ( not $ENV{TEST_AUTHOR} ) {
plan skip_all => 'Author test. Sent $ENV{TEST_AUTHOR} to a true value to run.';
} else {
- eval "use Test::Pod";
- if ( $@ ) {
- plan skip_all => 'Test::Pod required for testing POD';
+ if ( not $ENV{PERL_TEST_POD} ) {
+ plan skip_all => 'POD test. Sent $ENV{PERL_TEST_POD} to a true value to run.';
} else {
- all_pod_files_ok();
+ eval "use Test::Pod";
+ if ( $@ ) {
+ plan skip_all => 'Test::Pod required for testing POD';
+ } else {
+ all_pod_files_ok();
+ }
}
}
View
21 t/a_pod_coverage.t
@@ -0,0 +1,21 @@
+#!/usr/bin/perl
+
+use Test::More;
+
+# AUTHOR test
+if ( not $ENV{TEST_AUTHOR} ) {
+ plan skip_all => 'Author test. Sent $ENV{TEST_AUTHOR} to a true value to run.';
+} else {
+ if ( not $ENV{PERL_TEST_POD} ) {
+ plan skip_all => 'POD test. Sent $ENV{PERL_TEST_POD} to a true value to run.';
+ } else {
+ eval "use Test::Pod::Coverage";
+ if ( $@ ) {
+ plan skip_all => "Test::Pod::Coverage required for testing POD coverage";
+ } else {
+ # FIXME not used now
+ #all_pod_coverage_ok( 'lib/');
+ plan skip_all => 'not done yet';
+ }
+ }
+}
View
20 t/a_pod_spelling.t
@@ -0,0 +1,20 @@
+#!/usr/bin/perl
+
+use Test::More;
+
+# AUTHOR test
+if ( not $ENV{TEST_AUTHOR} ) {
+ plan skip_all => 'Author test. Sent $ENV{TEST_AUTHOR} to a true value to run.';
+} else {
+ if ( not $ENV{PERL_TEST_POD} ) {
+ plan skip_all => 'POD test. Sent $ENV{PERL_TEST_POD} to a true value to run.';
+ } else {
+ eval "use Test::Spelling";
+ if ( $@ ) {
+ plan skip_all => 'Test::Spelling required to test POD for spelling errors';
+ } else {
+ #all_pod_files_spelling_ok();
+ plan skip_all => 'need to figure out how to add custom vocabulary to dictionary';
+ }
+ }
+}
View
17 t/a_podcoverage.t
@@ -1,17 +0,0 @@
-#!/usr/bin/perl
-
-use Test::More;
-
-# AUTHOR test
-if ( not $ENV{TEST_AUTHOR} ) {
- plan skip_all => 'Author test. Sent $ENV{TEST_AUTHOR} to a true value to run.';
-} else {
- eval "use Test::Pod::Coverage";
- if ( $@ ) {
- plan skip_all => "Test::Pod::Coverage required for testing POD coverage";
- } else {
- # XXX not used now
- #all_pod_coverage_ok( 'lib/');
- plan skip_all => 'not done yet';
- }
-}
View
19 t/a_prereq.t
@@ -0,0 +1,19 @@
+#!/usr/bin/perl
+
+use Test::More;
+
+# AUTHOR test
+if ( not $ENV{TEST_AUTHOR} ) {
+ plan skip_all => 'Author test. Sent $ENV{TEST_AUTHOR} to a true value to run.';
+} else {
+ if ( not $ENV{PERL_TEST_PREREQ} ) {
+ plan skip_all => 'PREREQ test ( warning: LONG! ) Sent $ENV{PERL_TEST_PREREQ} to a true value to run.';
+ } else {
+ eval "use Test::Prereq";
+ if ( $@ ) {
+ plan skip_all => 'Test::Prereq required to test perl module deps';
+ } else {
+ prereq_ok();
+ }
+ }
+}
View
19 t/a_prereq_build.t
@@ -0,0 +1,19 @@
+#!/usr/bin/perl
+
+use Test::More;
+
+# AUTHOR test
+if ( not $ENV{TEST_AUTHOR} ) {
+ plan skip_all => 'Author test. Sent $ENV{TEST_AUTHOR} to a true value to run.';
+} else {
+ if ( not $ENV{PERL_TEST_PREREQ} ) {
+ plan skip_all => 'PREREQ test ( warning: LONG! ) Sent $ENV{PERL_TEST_PREREQ} to a true value to run.';
+ } else {
+ eval "use Test::Prereq::Build";
+ if ( $@ ) {
+ plan skip_all => 'Test::Prereq required to test perl module deps';
+ } else {
+ prereq_ok();
+ }
+ }
+}

0 comments on commit 2615be3

Please sign in to comment.
Something went wrong with that request. Please try again.