=head1 Name

Fehler


=head1 Ziel

Testen der Fehlerbehandlungsroutinen im Modul Fehler.pm.


=head1 Testfälle

Es wird getestet:


=head2 warnung

Korrekte Funktion, inkl. Rückgabewert, Ignorieren von Warnungen


=head2 problem

Korrekte Funktion, inkl. Rückgabewert (undef)


=head2 fehler

Korrekte Funktion, inkl. Aufruf des fehler:/testfehler:-Labels


=head2 ffehler

Korrekte Funktion, inkl. Propagieren eines Fehlers


=head2 warnungen{}, probleme{}

Korrekte Funktion, Beachten des Rückgabewerts


=head1 nicht-Testfälle

Folgende Dinge sind noch nicht im Test:

=over 4

=item *

Die report_*-Funktionen

=item *

Melden von Problemen bei Programmende

=back


=cut


package Test::Fehler;
use utf8;
use warnings;
use strict; use warnings;
BEGIN { unshift(@INC,($ENV{'POPHOME'}||'@POPHOME@').'/lib')
			unless $ENV{'KUNDE_NO_PERLPATH'};
      }


use Test::More tests => 53; $|=1;
BEGIN { $ENV{'DbLocalCf'}=1; }
use Dbase::Test;
use Fehler qw(warnung problem fehler warnungen probleme ohne_warnung ffehler hat_warnung hat_problem add_to_fehler);
use Fehler qw(@fehler); ### TEMP

sub Warnung() {
	warnung("WaR","nUnG");
}

sub Problem() {
	problem("PrObLeM","","");
}

sub Fehler() {
	fehler("FeHlEr!");
}

{
	my $num=0;

	pass("Start");
	is(warnungen { $num++; }, 0,"keine Warnungen am Anfang");
	is(probleme { $num++; }, 0,"keine Probleme am Anfang");
	is($num,0,"... und kein Aufruf der Prozeduren");

	Warnung(); Warnung();
	$num = 0;
	is(hat_warnung,2,"Zahl der Warnungen");
	is(warnungen {
		is(2,@_,"Warnung: Len \@_");
		is("@_","WaR nUnG","Warnung: Text @_");
		#$fehler[1].="g";
		$num++;
	}, 1,"1 Warnung abgearbeitet");
	is(hat_warnung,1,"eine Warnung übrig");
	is(warnungen {
		is(2,@_,"Warnung: @_");
		#is("@_","WaR nUnGg","Warnung: @_"); ## is nich mehr
		is("@_","WaR nUnG","Warnung: @_");
		$num++;
	}, 1,"1 weitere Warnung abgearbeitet");
	is(hat_warnung,0,"keine Warnung übrig");
	is($num, 3,"nicht 2 Warnungen (eine zweimal)");

	is(probleme { 1; }, 0,"Problem nach Warnung");

	warnungen { fail("nicht alle Warnungen sind weg"); 1; };
	Warnung(); Warnung(); $num = 0;
	is(warnungen { pass("Warn 1a"); $num++; }, 1,"Warnung 1a");
	is($num, 2,"Num 1");
	is(warnungen { pass("Warn 1b"); $num++; }, 1,"Warnung 1b");
	is($num, 3,"Num 2");
	is(probleme { 1; }, 0,"Problem nach Warnung");


	is(Problem(),undef,"problem() ist undef");
	ohne_warnung {
		is(Problem(),undef,"problem() ist undef");
		Warnung();
	};
	$num = 0;

	ok(Warnung(),"es wird gewarnt");
	ohne_warnung { ok(!Warnung(),"es wird nicht gewarnt"); };
	is(warnungen { 1; }, 1, "eine Warnung");

	is(hat_problem,2,"Zahl probleme");
	is(probleme {
		is(@_,3,"3 Fehler-Args");
		is("@_","PrObLeM  ","3 Args 2");
		$num++; 1;
	}, 2,"Fehlertest");
	is($num, 2,"nicht 2 Probleme");
	is(warnungen { 1; }, 0,"Warnung '@_' nach Problem");

	ffehler {
		Fehler();
		fail("Fehlertest");
		pass();pass();pass(); # 3 skip, im Fehler-Fall
	} sub {
		pass("im Fehler-Handler");
		ok(@_ >= 1,"Fehler gefunden");
		isnt($_[0],undef, "FeHlEr! 1");
		isnt($_[0],"", "FeHlEr! 2");
	};

## und jetzt dasselbe, aber verschachtelt
## das geht nur mit zusätzlicher Prozedur, wegen der doppelten Labels
## zusätzlich testen wir hier das Anspringen des testfehler:-Labels,
## das geht auch nur im Sub, weil sonst alle anderen Fehler-GOTOs
## auch da hinspringen würden :-(

	sub subcall(&) { my($sub) = @_; goto &$sub; }

	ffehler {
		{
			subcall {
				ffehler {
					Fehler();

					fail("Fehlertest innen: nach Fehler");
					pass(); # 1 skip, im Fehler-Fall
					goto fx;

				} sub {
					fail("Fehlertest innen: Sprung nach 'fehler:'");
					pass(); # 1 skip, im Fehler:-Fall
					goto fx;
				};

			testfehler:
				pass("Fehlertest innen: OK");
				my @f = grep { not /^$/ and not /^at test\/10_Fehler line \d+$/ } @fehler;
				#is(@f, 10,"Zahl Args Fehler:'".join("|",@f)."'");
				pass(); # dieser Test ist zu unzuverlässig
				goto fx;
			};
			fail("Skip 2");
			fx:
			pass("in Fehlertest fx");
			add_to_fehler("Bla");
			fehler();
			fail("der Fehler wird nicht nochmal geworfen");
		}
		fail("Skip 1");
		return 0; ## der folgende Code wird hoffentlich nicht wegoptimiert
		          ## mit if(0) würde das passieren...
	} sub {
		is($_[0],"Bla", "Test add_to_fehler");

		my @f = grep { not /^$/ and not /^at test\/10_Fehler line \d+$/ } @_;
		if(%{*Devel::DollarAt::}) {
			pass("Error string block: @_");
		} else {
			ok(@f > 5,"Args 3:".(0+@f).":'".join("|",@f)."'");
		}
	};

	warnungen { fail("Warnung '@_' bei Ende"); 1; };
	probleme { fail("Problem '@_' bei Ende"); 1; };

	my $x = 0;
	ffehler {
		$x += 1; # now 1
		$x += ffehler {
			$x += 2; # now 2
			fehler("Die!");
			16;
		} sub {
			$x += 4; # now 3
			fehler("Propagate the problem");
			32;
		};
		fail("Dieser Code darf nicht ausgeführt werden");
	} sub {
		$x += 8;
	};
	is($x,1+2+4+8,"Handler nicht betreten");;

### derselbe Test, aber diesmal raus aus der Schleife
	$x = 0;
	ffehler {
		$x += 1; # now 1
		$x += ffehler {
			$x += 2; # now 2
			fehler("Die!");
			64;
		} sub {
			$x += 4; # now 3
			32;
		};
		$x += 8;
		return;
	fehler:
		$x += 64;
	} sub {
		$x += 16;
	};
	is($x,1+2+4+8+32,"Handler betreten 1"); # 47
	## 67=64+2+1

### derselbe Test, aber diesmal ohne Fehler
	$x = 0;
	ffehler {
		$x += 1; # now 1
		$x += ffehler {
			$x += 2; # now 2
			64;
			
		} sub {
			$x += 4; # now 3
			32;
		};
		$x += 8;
		$x += 16;
	} sub {
		$x += 128;
	};
	is($x,8+16+1+2+64,"Handler betreten 2");;

### verschachtelte ffehler(): ein fehler() in der inneren Fehlerroutine
#   geht nach außen
	$x=0;
	ffehler {
		$x += 1;
		ffehler {
			$x += 2;
			fehler("Bla");
			$x += 4;
		} sub  {
			$x += 8;
			fehler("Fasel");
			$x += 16;
		};
		$x += 32;
	} sub {
		$x += 64;
	};
	is($x,1+2+8+64,"verschachtelte Handler");

### APR::Error-Test
	use APR::Error;

	ffehler {
		die APR::Error->new(rc=>42, func=>"foo",file=>"bar",line=>999);
	} sub {
		if(%{*Devel::DollarAt::}) {
			pass("Sigh.");
		} else {
			is(0+$_[0],42);
		}
	};

	pass("Ende");
	exit 0;
};


