Commits

Toby Inkster committed 364d55b

release

  • Participants
  • Parent commits 59474ec

Comments (0)

Files changed (6)

 use lib "lib";
 use Moan qw[:standard is];
 
+Moan->fatally(':wibble');
+diag 'Moon', ':wibble';
+diag 'Sun', ':wobble';
+diag 'Mars', ':wibble';
+
 sub foobar
 {
 	affirm { 0 } undef;
 sub diag ($;$)
 {
 	my ($message, $key) = @_;
-	my $caller = [caller(0)];
+	my @caller = caller(0);
 
 	if (not defined $key)
 	{
 	
 	chomp $message;
 	push @{ $diags{$key} }, $message;
-	warn "$message\n" if IsLoud($key, $caller);
+	warn "$message\n" if is_loud($key, \@caller);
 }
 
-sub fail ($$$)
+sub _fail ($$$)
 {
 	my ($message, $key, $caller) = @_;
 	chomp $message;
 		$key = $caller->[0] . $key;
 	}
 	
-	if (IsFatal($key, $caller))
+	if (is_fatal($key, $caller))
 	{
-		if (IsLoud($key, $caller))
+		if (is_loud($key, $caller))
 		{
 			$message = _garnish($message, $key, 1);
 			die $message;
 	}
 	else
 	{
-		if (IsLoud($key, $caller))
+		if (is_loud($key, $caller))
 		{
 			$message = _garnish($message, $key, 0);
 		}
 	$rv;
 }
 
-sub IsFatal (;$$)
+sub is_fatal (;$$)
 {
 	my ($key, $_call) = @_;
 	my @caller = defined $_call ? @$_call : caller(0);
 	return _fatal_is_enabled($key);
 }
 
-sub IsQuiet (;$$)
+sub is_quiet (;$$)
 {
 	my ($key, $_call) = @_;
 	my @caller = defined $_call ? @$_call : caller(0);
 	return _quiet_is_enabled($key);
 }
 
-sub IsLoud (;$$)
+sub is_loud (;$$)
 {
 	my ($key, $_call) = @_;
 	my @caller = defined $_call ? @$_call : caller(0);
 {
 	my ($truthy, $message, $key) = @_;
 	my $caller = [caller(0)];
-	return TRUE if IsQuiet($key, $caller);
+	return TRUE if is_quiet($key, $caller);
 	
 	unless ($truthy)
 	{
-		fail(($message // 'not ok'), $key, $caller);
+		_fail(($message // 'not ok'), $key, $caller);
 		return FALSE;
 	}
 	
 	return TRUE;
 }
+
 sub is ($$;$$)
 {
 	my ($given, $expected, $message, $key) = @_;
 	my $caller = [caller(0)];
-	return TRUE if IsQuiet($key, $caller);
+	return TRUE if is_quiet($key, $caller);
 	my $pass   = TRUE;
 	my $diag;
 	
 	if (defined $message)
 	{
 		chomp $message;
-		fail "$message\n$diag          ", $key, $caller;
+		_fail "$message\n$diag          ", $key, $caller;
 	}
 	else
 	{
-		fail "$diag          ", $key, $caller;
+		_fail "$diag          ", $key, $caller;
 	}
 	return FALSE;
 }
-sub isnt
+
+sub isnt ($$;$$)
 {
-	die "Not implemented.";
+	my ($given, $expected, $message, $key) = @_;
+	my $caller = [caller(0)];
+	return TRUE if is_quiet($key, $caller);
+	my $pass   = TRUE;
+	my $diag;
+	
+	if (looks_like_number($expected) and $given == $expected)
+	{
+		$diag = <<DIAG;
+    given: $given
+DIAG
+		$pass = FALSE;
+	}
+
+	elsif (!looks_like_number($expected) and $given eq $expected)
+	{
+		$diag = <<DIAG;
+    given: '$given'
+DIAG
+		$pass = FALSE;
+	}
+	
+	return $pass if $pass;
+	
+	if (defined $message)
+	{
+		chomp $message;
+		_fail "$message\n$diag          ", $key, $caller;
+	}
+	else
+	{
+		_fail "$diag          ", $key, $caller;
+	}
+	return FALSE;
 }
-sub like
+
+sub like ($$;$$)
 {
-	die "Not implemented.";
+	my ($given, $expected, $message, $key) = @_;
+	my $caller = [caller(0)];
+	return TRUE if is_quiet($key, $caller);
+	my $pass   = TRUE;
+	my $diag;
+	
+	if ($given !~ $expected)
+	{
+		$diag = <<DIAG;
+    given: $given
+ expected: $expected
+DIAG
+		$pass = FALSE;
+	}
+
+	return $pass if $pass;
+	
+	if (defined $message)
+	{
+		chomp $message;
+		_fail "$message\n$diag          ", $key, $caller;
+	}
+	else
+	{
+		_fail "$diag          ", $key, $caller;
+	}
+	return FALSE;
 }
-sub unlike
+
+sub unlike ($$;$$)
 {
-	die "Not implemented.";
+	my ($given, $expected, $message, $key) = @_;
+	my $caller = [caller(0)];
+	return TRUE if is_quiet($key, $caller);
+	my $pass   = TRUE;
+	my $diag;
+	
+	if ($given =~ $expected)
+	{
+		$diag = <<DIAG;
+    given: $given
+ expected: $expected
+DIAG
+		$pass = FALSE;
+	}
+
+	return $pass if $pass;
+	
+	if (defined $message)
+	{
+		chomp $message;
+		_fail "$message\n$diag          ", $key, $caller;
+	}
+	else
+	{
+		_fail "$diag          ", $key, $caller;
+	}
+	return FALSE;
 }
+
 sub can_ok ($$;$$) 
 {
 	my ($value, $method, $message, $key) = @_;
 	my $caller = [caller(0)];
-	return TRUE if IsQuiet($key, $caller);
+	return TRUE if is_quiet($key, $caller);
 	
 	if (blessed $value)
 	{
 		unless ($value->can($method))
 		{
-			fail(($message // "object cannot $method"), $key, $caller);
+			_fail(($message // "object cannot $method"), $key, $caller);
 			return FALSE;
 		}
 	}
 	{
 		unless ($value->can($method))
 		{
-			fail(($message // "$value cannot $method"), $key, $caller);
+			_fail(($message // "$value cannot $method"), $key, $caller);
 			return FALSE;
 		}
 	}
 	else
 	{
-		fail(($message // "undef can't do anything"), $key, $caller);
+		_fail(($message // "undef can't do anything"), $key, $caller);
 		return FALSE;
 	}
 	
 	return TRUE;
 }
+
 sub does_ok ($$;$$) 
 {
 	my ($value, $role, $message, $key) = @_;
 	my $caller = [caller(0)];
-	return TRUE if IsQuiet($key, $caller);
+	return TRUE if is_quiet($key, $caller);
 	
 	if (blessed $value)
 	{
 		unless ($value->DOES($role))
 		{
-			fail(($message // "object doesn't do $role"), $key, $caller);
+			_fail(($message // "object doesn't do $role"), $key, $caller);
 			return FALSE;
 		}
 	}
 	{
 		unless ($value->DOES($role))
 		{
-			fail(($message // "$value doesn't do $role"), $key, $caller);
+			_fail(($message // "$value doesn't do $role"), $key, $caller);
 			return FALSE;
 		}
 	}
 	else
 	{
-		fail(($message // "undef doesn't do anything"), $key, $caller);
+		_fail(($message // "undef doesn't do anything"), $key, $caller);
 		return FALSE;
 	}
 	
 	return TRUE;
 }
+
 sub isa_ok ($$;$$)
 {
 	my ($value, $class, $message, $key) = @_;
 	my $caller = [caller(0)];
-	return TRUE if IsQuiet($key, $caller);
+	return TRUE if is_quiet($key, $caller);
 	
 	if (blessed $value)
 	{
 		unless ($value->isa($class))
 		{
-			fail(($message // "object is not a $class"), $key, $caller);
+			_fail(($message // "object is not a $class"), $key, $caller);
 			return FALSE;
 		}
 	}
 	{
 		unless ($value->isa($class))
 		{
-			fail(($message // "$value is not a $class"), $key, $caller);
+			_fail(($message // "$value is not a $class"), $key, $caller);
 			return FALSE;
 		}
 	}
 	else
 	{
-		fail(($message // "undef is not a $class"), $key, $caller);
+		_fail(($message // "undef is not a $class"), $key, $caller);
 		return FALSE;
 	}
 	
 	return TRUE;
 }
+
 sub blessed_ok ($;$$) 
 {
 	my ($value, $message, $key) = @_;
 	my $caller = [caller(0)];
-	return TRUE if IsQuiet($key, $caller);
+	return TRUE if is_quiet($key, $caller);
 	
 	unless (blessed $value)
 	{
-		fail(($message // 'value not blessed'), $key, $caller);
+		_fail(($message // 'value not blessed'), $key, $caller);
 		return FALSE;
 	}
 	
 	return TRUE;
 }
+
 sub defined_ok ($;$$)
 {
 	my ($value, $message, $key) = @_;
 	my $caller = [caller(0)];
-	return TRUE if IsQuiet($key, $caller);
+	return TRUE if is_quiet($key, $caller);
 	
 	unless (defined $value)
 	{
-		fail(($message // 'value undefined'), $key, $caller);
+		_fail(($message // 'value undefined'), $key, $caller);
 		return FALSE;
 	}
 	
 	return TRUE;
 }
+
 sub assert ($;$$)
 {
 	my ($truthy, $message, $key) = @_;
 	my $caller = [caller(0)];
-	return TRUE if IsQuiet($key, $caller);
+	return TRUE if is_quiet($key, $caller);
 	
 	unless ($truthy)
 	{
-		fail(($message // 'assertion failed'), $key, $caller);
+		_fail(($message // 'assertion failed'), $key, $caller);
 		return FALSE;
 	}
 	
 	return TRUE;
 }
+
 sub affirm (&;$$)
 {
 	my ($truthy, $message, $key) = @_;
 	my $caller = [caller(0)];
-	return TRUE if IsQuiet($key, $caller);
+	return TRUE if is_quiet($key, $caller);
 	
 	unless ($truthy->())
 	{
 				 $message = B::Deparse->new->coderef2text($truthy) . ' failed';
 			};
 		}
-		fail(($message // 'affirmation failed'), $key, $caller);
+		_fail(($message // 'affirmation failed'), $key, $caller);
 		return FALSE;
 	}
 	
 	return TRUE;
 }
-sub should
+
+sub should ($$;$$)
 {
-	die "Not implemented.";
+	my ($given, $expected, $message, $key) = @_;
+	my $caller = [caller(0)];
+	return TRUE if is_quiet($key, $caller);
+	my $pass   = TRUE;
+	my $diag;
+	
+	if (not $given ~~ $expected)
+	{
+		$diag = <<DIAG;
+    given: $given
+ expected: $expected
+DIAG
+		$pass = FALSE;
+	}
+
+	return $pass if $pass;
+	
+	if (defined $message)
+	{
+		chomp $message;
+		_fail "$message\n$diag          ", $key, $caller;
+	}
+	else
+	{
+		_fail "$diag          ", $key, $caller;
+	}
+	return FALSE;
 }
+
 sub shouldnt 
 {
-	die "Not implemented.";
+	my ($given, $expected, $message, $key) = @_;
+	my $caller = [caller(0)];
+	return TRUE if is_quiet($key, $caller);
+	my $pass   = TRUE;
+	my $diag;
+	
+	if ($given ~~ $expected)
+	{
+		$diag = <<DIAG;
+    given: $given
+ expected: $expected
+DIAG
+		$pass = FALSE;
+	}
+
+	return $pass if $pass;
+	
+	if (defined $message)
+	{
+		chomp $message;
+		_fail "$message\n$diag          ", $key, $caller;
+	}
+	else
+	{
+		_fail "$diag          ", $key, $caller;
+	}
+	return FALSE;
 }
 
 TRUE;
 The L</Assertion Consequences> section explains how to enable diagnostic
 messages on a per-tag basis.
 
+=item C<< no Moan >>
+
+=begin private
+
+=item C<< Moan->unimport >>
+
+=end private
+
+Disables moaning within a lexical block.
+
 =back
 
 =head3 Carp::Assert
 
 (C<Moan::loudly>, C<Moan::quietly> and C<Moan::fatally> also work.)
 
+The following functions are provided to check the behaviour of a tag:
+
+=over
+
+=item C<< Moan::is_loud($tag) >>
+
+=item C<< Moan::is_quiet($tag) >>
+
+=item C<< Moan::is_fatal($tag) >>
+
+=back
+
 =head2 Command-Line Options
 
 =over
 dist:project :release dist:v_0-001 .
 dist:v_0-001
 	a               :Version ;
-	dc:issued       "2011-10-31"^^xsd:date ;
+	dc:issued       "2011-11-05"^^xsd:date ;
 	:revision       "0.001"^^xsd:string ;
 	:file-release   <http://backpan.cpan.org/authors/id/T/TO/TOBYINK/Moan-0.001.tar.gz> ;
-	rdfs:label      "Initial release" .
+	rdfs:label      "Gunpowder, Treason & Plot" .
 
 	a               :Project ;
 	:programming-language "Perl" ;
 	:name           "Moan" ;
-	:shortdesc      "a module that does something-or-other" ;
+	:shortdesc      "yet another \"assert\" module" ;
 	:homepage       <https://metacpan.org/release/Moan> ;
 	:download-page  <https://metacpan.org/release/Moan> ;
 	:bug-database   <http://rt.cpan.org/Dist/Display.html?Queue=Moan> ;

meta/makefile.ttl

 	:perl_version_from _:main ;
 	:version_from _:main ;
 	:readme_from _:main ;
-	:test_requires "Test::More 0.61" ;
-	:requires "Scalar::Util" , "common::sense" .
+	:test_requires "Test::More 0.61"  , "Test::Warn";
+	:requires "Scalar::Util" , "Devel::StackTrace" , "Exporter" .
 
 _:main <http://www.semanticdesktop.org/ontologies/2007/03/22/nfo#fileName> "lib/Moan.pm" .
 
+use Test::More tests => 2;
+use Test::Warn;
+use Moan qw(assert);
+
+warning_like
+	{
+		assert(0, 'BUM');
+	}
+	qr/BUM/, 'assertions print warnings';
+
+warning_like
+	{
+		Moan::loudly(':wibble');
+		Moan::diag('BUM', ':wibble');
+	}
+	qr/BUM/, 'diag is visible when loud';