Data-Validate-Email-0.04000700 004200 000024 00000000000 10535112337 015420 5ustar00sonnenstaff000000 000000 Data-Validate-Email-0.04/t000700 004200 000024 00000000000 10535112337 015663 5ustar00sonnenstaff000000 000000 Data-Validate-Email-0.04/META.yml000644 004200 000024 00000000575 10535112337 016771 0ustar00sonnenstaff000000 000000 # http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Data-Validate-Email version: 0.04 version_from: Email.pm installdirs: site requires: Data::Validate::Domain: 0.04 Email::Address: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.23 Data-Validate-Email-0.04/Changes000644 004200 000024 00000001135 10535111201 016771 0ustar00sonnenstaff000000 000000 Revision history for Perl extension Data::Validate::Email. 0.04 20061204 - added second argument to is_email and is_domain, passing both through to Data::Validate::Domain 0.03 20050708 - changed is_email to use is_username and is_domain to do its work they previously had different behaviors when it came to underscores in a domain name. Thanks to Doran for the bug report. - changed is_domain to be a passthrough to Neil Neely's Data::Validate::Domain module 0.02 20050420 - fixed error in the POD examples. Thanks to Philip McCarthy for the bug report. 0.01 20041214 - original version Data-Validate-Email-0.04/MANIFEST000644 004200 000024 00000000327 10160327530 016641 0ustar00sonnenstaff000000 000000 Changes Makefile.PL MANIFEST INSTALL README Email.pm t/ExtUtils/TBone.pm t/is_email.t t/is_email_rfc822.t t/is_domain.t t/is_username.t META.yml Module meta-data (added by MakeMaker) Data-Validate-Email-0.04/Email.pm000644 004200 000024 00000017357 10535111623 017110 0ustar00sonnenstaff000000 000000 package Data::Validate::Email; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); require Exporter; use AutoLoader 'AUTOLOAD'; use Email::Address; use Data::Validate::Domain; @ISA = qw(Exporter); # no functions are exported by default. See EXPORT_OK @EXPORT = qw(); @EXPORT_OK = qw( is_email is_email_rfc822 is_domain is_username ); %EXPORT_TAGS = (); $VERSION = '0.04'; # No preloads 1; __END__ =head1 NAME Data::Validate::Email - common email validation methods =head1 SYNOPSIS use Data::Validate::Email qw(is_email is_email_rfc822); if(is_email($suspect)){ print "Looks like an email address\n"; } elsif(is_email_rfc822($suspect)){ print "Doesn't much look like an email address, but passes rfc822\n"; } else { print "Not an email address\n"; } # or as an object my $v = Data::Validate::Email->new(); die "not an email" unless ($v->is_email('foo')); =head1 DESCRIPTION This module collects common email validation routines to make input validation, and untainting easier and more readable. All functions return an untainted value if the test passes, and undef if it fails. This means that you should always check for a defined status explicitly. Don't assume the return will be true. (e.g. is_username('0')) The value to test is always the first (and often only) argument. =head1 FUNCTIONS =over 4 =cut # ------------------------------------------------------------------------------- =pod =item B - constructor for OO usage new([\%opts]); =over 4 =item I Returns a Data::Validator::Email object. This lets you access all the validator function calls as methods without importing them into your namespace or using the clumsy Data::Validate::Email::function_name() format. =item I An optional hash reference is retained and passed on to other function calls in the Data::Validate module series. This module does not utilize the extra data, but some child calls do. See Data::Validate::Domain for an example. =item I Returns a Data::Validate::Email object =back =cut sub new{ my $class = shift; my %self = @_; return bless \%self, ref($class) || $class; } # ------------------------------------------------------------------------------- =pod =item B - is the value a well-formed email address? is_email($value); =over 4 =item I Returns the untainted address if the test value appears to be a well-formed email address. This method tries to match real-world addresses, rather than trying to support everything that rfc822 allows. (see is_email_rfc822 if you want the more permissive behavior.) In short, it pretty much looks for something@something.tld. It does not understand real names ("bob smith" ), or other comments. It will not accept partially-qualified addresses ('bob', or 'bob@machine') =item I =over 4 =item $value The potential address to test. =back =item I Returns the untainted address on success, undef on failure. =item I This function does not make any attempt to check whether an address is genuinely deliverable. It only looks to see that the format is email-like. The function accepts an optional hash reference as a second argument to change the validation behavior. It is passed on unchanged to Neil Neely's Data::Validate::Domain::is_domain() function. See that module's documentation for legal values. =back =cut sub is_email{ my $self = shift if ref($_[0]); my $value = shift; return unless defined($value); my $opt = (defined $self) ? $self : (shift); my @parts = split(/\@/, $value); return unless scalar(@parts) == 2; my($user) = is_username($parts[0], $opt); return unless defined($user); return unless $user eq $parts[0]; my $domain = is_domain($parts[1], $opt); return unless defined($domain); return unless $domain eq $parts[1]; return $user . '@' . $domain; } # ------------------------------------------------------------------------------- =pod =item B - does the value look like an RFC 822 address? is_email_rfc822($value); =over 4 =item I Returns the untainted address if the test value appears to be a well-formed email address according to RFC822. Note that the standard allows for a wide variety of address formats, including ones with real names and comments. In most cases you probably want to use is_email() instead. This one will accept things that you probably aren't expecting ('foo@bar', for example.) =item I =over 4 =item $value The potential address to test. =back =item I Returns the untainted address on success, undef on failure. =item I This check uses Casey West's Email::Address module to do its validation. The function does not make any attempt to check whether an address is genuinely deliverable. It only looks to see that the format is email-like. =back =cut sub is_email_rfc822{ my $self = shift if ref($_[0]); my $value = shift; return unless defined($value); #warn $Email::Address::mailbox; my $address; if($value =~ /^$Email::Address::mailbox$/){ #warn $&; $address = $&; } return $address; } # ------------------------------------------------------------------------------- =pod =item B - does the value look like a domain name? is_domain($value); =over 4 =item I Returns the untainted domain if the test value appears to be a well-formed domain name. This test uses the same logic as is_email(), rather than the somewhat more permissive pattern specified by RFC822. =item I =over 4 =item $value The potential domain to test. =back =item I Returns the untainted domain on success, undef on failure. =item I The function does not make any attempt to check whether a domain is actually exists. It only looks to see that the format is appropriate. As of version 0.03, this is a direct pass-through to Neil Neely's Data::Validate::Domain::is_domain() function. The function accepts an optional hash reference as a second argument to change the validation behavior. It is passed on unchanged to Neil Neely's Data::Validate::Domain::is_domain() function. See that module's documentation for legal values. =back =cut sub is_domain{ my $self = shift if ref($_[0]); my $value = shift; return unless defined($value); my $opt = (defined $self) ? $self : (shift); return Data::Validate::Domain::is_domain($value, $opt); } # ------------------------------------------------------------------------------- =pod =item B - does the value look like a username? is_username($value); =over 4 =item I Returns the untainted username if the test value appears to be a well-formed username. More specifically, it tests to see if the value is legal as the username component of an email address as defined by is_email(). Note that this definition is more restrictive than the one in RFC822. =item I =over 4 =item $value The potential username to test. =back =item I Returns the untainted username on success, undef on failure. =item I The function does not make any attempt to check whether a username actually exists on your system. It only looks to see that the format is appropriate. =back =cut sub is_username{ my $self = shift if ref($_[0]); my $value = shift; return unless defined($value); my($username) = $value =~ /^([a-z0-9_\-\.]+)$/i; return $username; } =pod =back =head1 AUTHOR Richard Sonnen >. =head1 COPYRIGHT Copyright (c) 2004 Richard Sonnen. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Data-Validate-Email-0.04/INSTALL000644 004200 000024 00000000411 10157700351 016535 0ustar00sonnenstaff000000 000000 INSTALLATION ============ First unpack the kit, if you have not already done so: tar -xzvf Data-Validate-Email-x.xx.tar.gz cd Data-Validate-Email-x.xx Data::Validate::Email can be installed with: perl Makefile.PL make make test make install Data-Validate-Email-0.04/Makefile.PL000644 004200 000024 00000001145 10535111065 017461 0ustar00sonnenstaff000000 000000 use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Data::Validate::Email', 'VERSION_FROM' => 'Email.pm', # finds $VERSION 'DISTNAME' => 'Data-Validate-Email', 'AUTHOR' => 'Richard Sonnen (sonnen@richardsonnen.com)', 'PREREQ_PM' => { 'Email::Address' => 0, 'Data::Validate::Domain' => 0.04, }, 'dist' => { 'COMPRESS' => 'gzip -9f', 'SUFFIX' => 'gz', 'ZIP' => '/usr/bin/zip', 'ZIPFLAGS' => '-rl', }, ); Data-Validate-Email-0.04/README000644 004200 000024 00000014501 10535112270 016366 0ustar00sonnenstaff000000 000000 NAME Data::Validate::Email - common email validation methods SYNOPSIS use Data::Validate::Email qw(is_email is_email_rfc822); if(is_email($suspect)){ print "Looks like an email address\n"; } elsif(is_email_rfc822($suspect)){ print "Doesn't much look like an email address, but passes rfc822\n"; } else { print "Not an email address\n"; } # or as an object my $v = Data::Validate::Email->new(); die "not an email" unless ($v->is_email('foo')); DESCRIPTION This module collects common email validation routines to make input validation, and untainting easier and more readable. All functions return an untainted value if the test passes, and undef if it fails. This means that you should always check for a defined status explicitly. Don't assume the return will be true. (e.g. is_username('0')) The value to test is always the first (and often only) argument. FUNCTIONS new - constructor for OO usage new([\%opts]); *Description* Returns a Data::Validator::Email object. This lets you access all the validator function calls as methods without importing them into your namespace or using the clumsy Data::Validate::Email::function_name() format. *Arguments* An optional hash reference is retained and passed on to other function calls in the Data::Validate module series. This module does not utilize the extra data, but some child calls do. See Data::Validate::Domain for an example. *Returns* Returns a Data::Validate::Email object is_email - is the value a well-formed email address? is_email($value); *Description* Returns the untainted address if the test value appears to be a well-formed email address. This method tries to match real-world addresses, rather than trying to support everything that rfc822 allows. (see is_email_rfc822 if you want the more permissive behavior.) In short, it pretty much looks for something@something.tld. It does not understand real names ("bob smith" ), or other comments. It will not accept partially-qualified addresses ('bob', or 'bob@machine') *Arguments* $value The potential address to test. *Returns* Returns the untainted address on success, undef on failure. *Notes, Exceptions, & Bugs* This function does not make any attempt to check whether an address is genuinely deliverable. It only looks to see that the format is email-like. The function accepts an optional hash reference as a second argument to change the validation behavior. It is passed on unchanged to Neil Neely's Data::Validate::Domain::is_domain() function. See that module's documentation for legal values. is_email_rfc822 - does the value look like an RFC 822 address? is_email_rfc822($value); *Description* Returns the untainted address if the test value appears to be a well-formed email address according to RFC822. Note that the standard allows for a wide variety of address formats, including ones with real names and comments. In most cases you probably want to use is_email() instead. This one will accept things that you probably aren't expecting ('foo@bar', for example.) *Arguments* $value The potential address to test. *Returns* Returns the untainted address on success, undef on failure. *Notes, Exceptions, & Bugs* This check uses Casey West's Email::Address module to do its validation. The function does not make any attempt to check whether an address is genuinely deliverable. It only looks to see that the format is email-like. is_domain - does the value look like a domain name? is_domain($value); *Description* Returns the untainted domain if the test value appears to be a well-formed domain name. This test uses the same logic as is_email(), rather than the somewhat more permissive pattern specified by RFC822. *Arguments* $value The potential domain to test. *Returns* Returns the untainted domain on success, undef on failure. *Notes, Exceptions, & Bugs* The function does not make any attempt to check whether a domain is actually exists. It only looks to see that the format is appropriate. As of version 0.03, this is a direct pass-through to Neil Neely's Data::Validate::Domain::is_domain() function. The function accepts an optional hash reference as a second argument to change the validation behavior. It is passed on unchanged to Neil Neely's Data::Validate::Domain::is_domain() function. See that module's documentation for legal values. is_username - does the value look like a username? is_username($value); *Description* Returns the untainted username if the test value appears to be a well-formed username. More specifically, it tests to see if the value is legal as the username component of an email address as defined by is_email(). Note that this definition is more restrictive than the one in RFC822. *Arguments* $value The potential username to test. *Returns* Returns the untainted username on success, undef on failure. *Notes, Exceptions, & Bugs* The function does not make any attempt to check whether a username actually exists on your system. It only looks to see that the format is appropriate. AUTHOR Richard Sonnen . COPYRIGHT Copyright (c) 2004 Richard Sonnen. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Data-Validate-Email-0.04/t/is_email_rfc822.t000644 004200 000024 00000003430 10160154240 021002 0ustar00sonnenstaff000000 000000 #!/usr/bin/perl # ------------------------------------------------------------------------------- # test harness for Data::Validate::is_email_rfc822 # # Author: Richard Sonnen (http://www.richardsonnen.com/) # ------------------------------------------------------------------------------- use lib './t'; use ExtUtils::TBone; use lib './blib'; use Data::Validate::Email qw(is_email_rfc822); my $t = ExtUtils::TBone->typical(); $t->begin(15); $t->msg("testing is_email_rfc822..."); # valid $t->ok(defined(is_email_rfc822('bob@test.com')), 'bob@test.com'); $t->ok(defined(is_email_rfc822('bob@test.com.au')), 'bob@test.com.au'); $t->ok(defined(is_email_rfc822('foo.bob@test.com.au')), 'foo.bob@test.com.au'); $t->ok(defined(is_email_rfc822('foo-bob@test-com.au')), 'foo-bob@test-com.au'); $t->ok(defined(is_email_rfc822('foo-bob@test.uk')), 'foo-bob@test.uk'); $t->ok(defined(is_email_rfc822('Richard Sonnen ')), 'Richard Sonnen '); $t->ok(defined(is_email_rfc822('')), ''); $t->ok(defined(is_email_rfc822('"Richard Sonnen" ')), '"Richard Sonnen" '); $t->ok(defined(is_email_rfc822('"Richard Sonnen" (comments)')), '"Richard Sonnen" (comments)'); # invalid $t->ok(!defined(is_email_rfc822('')), "bad: ''"); $t->ok(!defined(is_email_rfc822('foo')), 'bad: foo'); $t->ok(!defined(is_email_rfc822('foo bar@bar.com')), 'bad: foo bar@bar.com'); $t->ok(!defined(is_email_rfc822('@bar.com')), 'bad: "@bar.com'); # as an object my $v = Data::Validate::Email->new(); $t->ok(defined($v->is_email_rfc822('bob@test.com')), 'bob@test.com (object)'); $t->ok(!defined($v->is_email_rfc822('foo bar@bar.com')), 'bad: foo bar@bar.com (object)'); # we're done $t->end(); Data-Validate-Email-0.04/t/is_domain.t000644 004200 000024 00000002612 10535112202 020073 0ustar00sonnenstaff000000 000000 #!/usr/bin/perl # ------------------------------------------------------------------------------- # test harness for Data::Validate::is_domain # # Author: Richard Sonnen (http://www.richardsonnen.com/) # ------------------------------------------------------------------------------- use lib './t'; use ExtUtils::TBone; use lib './blib'; use Data::Validate::Email qw(is_domain); my $t = ExtUtils::TBone->typical(); $t->begin(12); $t->msg("testing is_domain..."); # valid $t->ok(defined(is_domain('test.com')), 'test.com'); $t->ok(defined(is_domain('sub.test.com')), 'sub.test.com'); $t->ok(defined(is_domain('sub-test.com')), 'sub-test.com'); $t->ok(defined(is_domain('sub-test.com.au')), 'sub-test.com.au'); # invalid $t->ok(!defined(is_domain('')), "bad: ''"); $t->ok(!defined(is_domain('host')), "bad: host"); $t->ok(!defined(is_domain('sonnen@frii.com')), 'bad: sonnen@frii.com'); $t->ok(!defined(is_domain('test dot.com')), "bad: test dot.com"); # test passthrough to Data::Validate::Domain $t->ok(defined(is_domain('com', {domain_allow_single_label => 1})), 'single-label test'); $t->ok(defined(is_domain('bob.foo', {domain_private_tld => {foo => 1}})), 'private TLD test'); # as an object my $v = Data::Validate::Email->new(); $t->ok(defined($v->is_domain('test.com')), 'test.com (object)'); $t->ok(!defined($v->is_domain('foobar@bar.com')), 'bad: foobar@bar.com (object)'); # we're done $t->end(); Data-Validate-Email-0.04/t/is_email.t000644 004200 000024 00000002747 10535112131 017725 0ustar00sonnenstaff000000 000000 #!/usr/bin/perl # ------------------------------------------------------------------------------- # test harness for Data::Validate::is_email # # Author: Richard Sonnen (http://www.richardsonnen.com/) # ------------------------------------------------------------------------------- use lib './t'; use ExtUtils::TBone; use lib './blib'; use Data::Validate::Email qw(is_email); my $t = ExtUtils::TBone->typical(); $t->begin(13); $t->msg("testing is_email..."); # valid $t->ok(defined(is_email('bob@test.com')), 'bob@test.com'); $t->ok(defined(is_email('bob@test.com.au')), 'bob@test.com.au'); $t->ok(defined(is_email('foo.bob@test.com.au')), 'foo.bob@test.com.au'); $t->ok(defined(is_email('foo-bob@test-com.au')), 'foo-bob@test-com.au'); $t->ok(defined(is_email('foo-bob@test.uk')), 'foo-bob@test.uk'); # invalid $t->ok(!defined(is_email('')), "bad: ''"); $t->ok(!defined(is_email('foo')), 'bad: foo'); $t->ok(!defined(is_email('foo@bar')), 'bad: foo@bar'); $t->ok(!defined(is_email('foo bar@bar.com')), 'bad: foo bar@bar.com'); # test passthrough to Data::Validate::Domain $t->ok(defined(is_email('test@com', {domain_allow_single_label => 1})), 'single-label test'); $t->ok(defined(is_email('test@bob.foo', {domain_private_tld => {foo => 1}})), 'private TLD test'); # as an object my $v = Data::Validate::Email->new(); $t->ok(defined($v->is_email('bob@test.com')), 'bob@test.com (object)'); $t->ok(!defined($v->is_email('foo bar@bar.com')), 'bad: foo bar@bar.com (object)'); # we're done $t->end(); Data-Validate-Email-0.04/t/ExtUtils000700 004200 000024 00000000000 10535112337 017444 5ustar00sonnenstaff000000 000000 Data-Validate-Email-0.04/t/is_username.t000644 004200 000024 00000002217 10160324326 020452 0ustar00sonnenstaff000000 000000 #!/usr/bin/perl # ------------------------------------------------------------------------------- # test harness for Data::Validate::is_username # # Author: Richard Sonnen (http://www.richardsonnen.com/) # ------------------------------------------------------------------------------- use lib './t'; use ExtUtils::TBone; use lib './blib'; use Data::Validate::Email qw(is_username); my $t = ExtUtils::TBone->typical(); $t->begin(10); $t->msg("testing is_username..."); # valid $t->ok(defined(is_username('sonnen')), 'sonnen'); $t->ok(defined(is_username('bob.smith')), 'bob.smith'); $t->ok(defined(is_username('bob-smith')), 'bob-smith'); $t->ok(defined(is_username('a')), 'a'); # invalid $t->ok(!defined(is_username('')), "bad: ''"); $t->ok(!defined(is_username('bob@test.com')), 'bad: bob@test.com'); $t->ok(!defined(is_username('bob smith')), "bad: bob smith"); $t->ok(!defined(is_username('bob*smith')), "bad: bob*smith"); # as an object my $v = Data::Validate::Email->new(); $t->ok(defined($v->is_username('sonnen')), 'sonnen (object)'); $t->ok(!defined($v->is_username('foobar@bar.com')), 'bad: foobar@bar.com (object)'); # we're done $t->end(); Data-Validate-Email-0.04/t/ExtUtils/TBone.pm000444 004200 000024 00000030444 10155426114 021104 0ustar00sonnenstaff000000 000000 package ExtUtils::TBone; =head1 NAME ExtUtils::TBone - a "skeleton" for writing "t/*.t" test files. =head1 SYNOPSIS Include a copy of this module in your t directory (as t/ExtUtils/TBone.pm), and then write your t/*.t files like this: use lib "./t"; # to pick up a ExtUtils::TBone use ExtUtils::TBone; # Make a tester... here are 3 different alternatives: my $T = typical ExtUtils::TBone; # standard log my $T = new ExtUtils::TBone; # no log my $T = new ExtUtils::TBone "testout/Foo.tlog"; # explicit log # Begin testing, and expect 3 tests in all: $T->begin(3); # expect 3 tests $T->msg("Something for the log file"); # message for the log # Run some tests: $T->ok($this); # test 1: no real info logged $T->ok($that, # test 2: logs a comment "Is that ok, or isn't it?"); $T->ok(($this eq $that), # test 3: logs comment + vars "Do they match?", This => $this, That => $that); # That last one could have also been written... $T->ok_eq($this, $that); # does 'eq' and logs operands $T->ok_eqnum($this, $that); # does '==' and logs operands # End testing: $T->end; =head1 DESCRIPTION This module is intended for folks who release CPAN modules with "t/*.t" tests. It makes it easy for you to output syntactically correct test-output while at the same time logging all test activity to a log file. Hopefully, bug reports which include the contents of this file will be easier for you to investigate. =head1 OUTPUT =head2 Standard output Pretty much as described by C, with a special "# END" comment placed at the very end: 1..3 ok 1 not ok 2 ok 3 # END =head1 Log file A typical log file output by this module looks like this: 1..3 ** A message logged with msg(). ** Another one. 1: My first test, using test(): how'd I do? 1: ok 1 ** Yet another message. 2: My second test, using test_eq()... 2: A: The first string 2: B: The second string 2: not ok 2 3: My third test. 3: ok 3 # END Each test() is logged with the test name and results, and the test-number prefixes each line. This allows you to scan a large file easily with "grep" (or, ahem, "perl"). A blank line follows each test's record, for clarity. =head1 PUBLIC INTERFACE =cut # Globals: use strict; use vars qw($VERSION); use FileHandle; use File::Basename; # The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = substr q$Revision: 1.124 $, 10; #------------------------------ =head2 Construction =over 4 =cut #------------------------------ =item new [ARGS...] I Create a new tester. Any arguments are sent to log_open(). =cut sub new { my $self = bless { OUT =>\*STDOUT, Begin=>0, End =>0, Count=>0, }, shift; $self->log_open(@_) if @_; $self; } #------------------------------ =item typical I Create a typical tester. Use this instead of new() for most applicaitons. The directory "testout" is created for you automatically, to hold the output log file, and log_warnings() is invoked. =cut sub typical { my $class = shift; my ($tfile) = basename $0; unless (-d "testout") { mkdir "testout", 0755 or die "Couldn't create a 'testout' subdirectory: $!\n"; ### warn "$class: created 'testout' directory\n"; } my $self = $class->new($class->catfile('.', 'testout', "${tfile}log")); $self->log_warnings; $self; } #------------------------------ # DESTROY #------------------------------ # Class method, destructor. # Automatically closes the log. # sub DESTROY { $_[0]->log_close; } #------------------------------ =back =head2 Doing tests =over 4 =cut #------------------------------ =item begin NUMTESTS I Start testing. This outputs the 1..NUMTESTS line to the standard output. =cut sub begin { my ($self, $n) = @_; return if $self->{Begin}++; $self->l_print("1..$n\n\n"); print {$self->{OUT}} "1..$n\n"; } #------------------------------ =item end I Indicate the end of testing. This outputs a "# END" line to the standard output. =cut sub end { my ($self) = @_; return if $self->{End}++; $self->l_print("# END\n"); print {$self->{OUT}} "# END\n"; } #------------------------------ =item ok BOOL, [TESTNAME], [PARAMHASH...] I Do a test, and log some information connected with it. This outputs the test result lines to the standard output: ok 12 not ok 13 Use it like this: $T->ok(-e $dotforward); Or better yet, like this: $T->ok((-e $dotforward), "Does the user have a .forward file?"); Or even better, like this: $T->ok((-e $dotforward), "Does the user have a .forward file?", User => $ENV{USER}, Path => $dotforward, Fwd => $ENV{FWD}); That last one, if it were test #3, would be logged as: 3: Does the user have a .forward file? 3: User: "alice" 3: Path: "/home/alice/.forward" 3: Fwd: undef 3: ok You get the idea. Note that defined quantities are logged with delimiters and with all nongraphical characters suitably escaped, so you can see evidence of unexpected whitespace and other badnasties. Had "Fwd" been the string "this\nand\nthat", you'd have seen: 3: Fwd: "this\nand\nthat" And unblessed array refs like ["this", "and", "that"] are treated as multiple values: 3: Fwd: "this" 3: Fwd: "and" 3: Fwd: "that" =cut sub ok { my ($self, $ok, $test, @ps) = @_; ++($self->{Count}); # next test # Report to harness: my $status = ($ok ? "ok " : "not ok ") . $self->{Count}; print {$self->{OUT}} $status, "\n"; # Log: $self->ln_print($test, "\n") if $test; while (@ps) { my ($k, $v) = (shift @ps, shift @ps); my @vs = ((ref($v) and (ref($v) eq 'ARRAY'))? @$v : ($v)); foreach (@vs) { if (!defined($_)) { # value not defined: output keyword $self->ln_print(qq{ $k: undef\n}); } else { # value defined: output quoted, encoded form s{([\n\t\x00-\x1F\x7F-\xFF\\\"])} {'\\'.sprintf("%02X",ord($1)) }exg; s{\\0A}{\\n}g; $self->ln_print(qq{ $k: "$_"\n}); } } } $self->ln_print($status, "\n"); $self->l_print("\n"); 1; } #------------------------------ =item ok_eq ASTRING, BSTRING, [TESTNAME], [PARAMHASH...] I Convenience front end to ok(): test whether C, and logs the operands as 'A' and 'B'. =cut sub ok_eq { my ($self, $this, $that, $test, @ps) = @_; $self->ok(($this eq $that), ($test || "(Is 'A' string-equal to 'B'?)"), A => $this, B => $that, @ps); } #------------------------------ =item ok_eqnum ANUM, BNUM, [TESTNAME], [PARAMHASH...] I Convenience front end to ok(): test whether C, and logs the operands as 'A' and 'B'. =cut sub ok_eqnum { my ($self, $this, $that, $test, @ps) = @_; $self->ok(($this == $that), ($test || "(Is 'A' numerically-equal to 'B'?)"), A => $this, B => $that, @ps); } #------------------------------ =back =head2 Logging messages =over 4 =cut #------------------------------ =item log_open PATH I Open a log file for messages to be output to. This is invoked for you automatically by C and C. =cut sub log_open { my ($self, $path) = @_; $self->{LogPath} = $path; $self->{LOG} = FileHandle->new(">$path") || die "open $path: $!"; $self; } #------------------------------ =item log_close I Close the log file and stop logging. You shouldn't need to invoke this directly; the destructor does it. =cut sub log_close { my $self = shift; close(delete $self->{LOG}) if $self->{LOG}; } #------------------------------ =item log_warnings I Invoking this redefines $SIG{__WARN__} to log to STDERR and to the tester's log. This is automatically invoked when using the C constructor. =cut sub log_warnings { my ($self) = @_; $SIG{__WARN__} = sub { print STDERR $_[0]; $self->log("warning: ", $_[0]); }; } #------------------------------ =item log MESSAGE... I Log a message to the log file. No alterations are made on the text of the message. See msg() for an alternative. =cut sub log { my $self = shift; print {$self->{LOG}} @_ if $self->{LOG}; } #------------------------------ =item msg MESSAGE... I Log a message to the log file. Lines are prefixed with "** " for clarity, and a terminating newline is forced. =cut sub msg { my $self = shift; my $text = join '', @_; chomp $text; $text =~ s{^}{** }gm; $self->l_print($text, "\n"); } #------------------------------ # # l_print MESSAGE... # # Instance method, private. # Print to the log file if there is one. # sub l_print { my $self = shift; print { $self->{LOG} } @_ if $self->{LOG}; } #------------------------------ # # ln_print MESSAGE... # # Instance method, private. # Print to the log file, prefixed by message number. # sub ln_print { my $self = shift; foreach (split /\n/, join('', @_)) { $self->l_print("$self->{Count}: $_\n"); } } #------------------------------ =back =head2 Utilities =over 4 =cut #------------------------------ =item catdir DIR, ..., DIR I Concatenate several directories into a path ending in a directory. Lightweight version of the one in C; this method dates back to a more-innocent time when File::Spec was younger and less ubiquitous. Paths are assumed to be absolute. To signify a relative path, the first DIR must be ".", which is processed specially. On Mac, the path I end in a ':'. On Unix, the path I end in a '/'. =cut sub catdir { my $self = shift; my $relative = shift @_ if ($_[0] eq '.'); if ($^O eq 'Mac') { return ($relative ? ':' : '') . (join ':', @_) . ':'; } else { return ($relative ? './' : '/') . join '/', @_; } } #------------------------------ =item catfile DIR, ..., DIR, FILE I Like catdir(), but last element is assumed to be a file. Note that, at a minimum, you must supply at least a single DIR. =cut sub catfile { my $self = shift; my $file = pop; if ($^O eq 'Mac') { return $self->catdir(@_) . $file; } else { return $self->catdir(@_) . "/$file"; } } #------------------------------ =back =head1 VERSION $Id: TBone.pm,v 1.124 2001/08/20 20:30:07 eryq Exp $ =head1 CHANGE LOG =over 4 =item Version 1.124 (2001/08/20) The terms-of-use have been placed in the distribution file "COPYING". Also, small documentation tweaks were made. =item Version 1.122 (2001/08/20) Changed output of C<"END"> to C<"# END">; apparently, "END" is not a directive. Maybe it never was. I The storyteller need not say "the end" aloud; Silence is enough. Automatically invoke C when constructing via C. =item Version 1.120 (2001/08/17) Added log_warnings() to support the logging of SIG{__WARN__} messages to the log file (if any). =item Version 1.116 (2000/03/23) Cosmetic improvements only. =item Version 1.112 (1999/05/12) Added lightweight catdir() and catfile() (a la File::Spec) to enhance portability to Mac environment. =item Version 1.111 (1999/04/18) Now uses File::Basename to create "typical" logfile name, for portability. =item Version 1.110 (1999/04/17) Fixed bug in constructor that surfaced if no log was being used. =back Created: Friday-the-13th of February, 1998. =head1 AUTHOR Eryq (F). President, ZeeGee Software Inc. (F). Go to F for the latest downloads and on-line documentation for this module. Enjoy. Yell if it breaks. =cut #------------------------------ 1; __END__ my $T = new ExtUtils::TBone "testout/foo.tlog"; $T->begin(3); $T->msg("before 1\nor 2"); $T->ok(1, "one"); $T->ok(2, "Two"); $T->ok(3, "Three", Roman=>'III', Arabic=>[3, '03'], Misc=>"3\nor 3"); $T->end; 1;