1use strict; 2use warnings; 3 4BEGIN { no warnings 'once'; $main::cleanup1 = bless {}, 'My::Cleanup' } 5 6use Test2::API qw/context/; 7 8my ($LOADED, $INIT); 9BEGIN { 10 $INIT = Test2::API::test2_init_done; 11 $LOADED = Test2::API::test2_load_done; 12}; 13 14use Test2::IPC; 15use Test2::Tools::Tiny; 16use Test2::Util qw/get_tid/; 17my $CLASS = 'Test2::API'; 18 19# Ensure we do not break backcompat later by removing anything 20ok(Test2::API->can($_), "$_ method is present") for qw{ 21 context_do 22 no_context 23 24 test2_init_done 25 test2_load_done 26 27 test2_pid 28 test2_tid 29 test2_stack 30 test2_no_wait 31 test2_is_testing_done 32 33 test2_add_callback_context_init 34 test2_add_callback_context_release 35 test2_add_callback_exit 36 test2_add_callback_post_load 37 test2_list_context_init_callbacks 38 test2_list_context_release_callbacks 39 test2_list_exit_callbacks 40 test2_list_post_load_callbacks 41 42 test2_ipc 43 test2_ipc_disable 44 test2_ipc_disabled 45 test2_ipc_drivers 46 test2_ipc_add_driver 47 test2_ipc_polling 48 test2_ipc_disable_polling 49 test2_ipc_enable_polling 50 51 test2_formatter 52 test2_formatters 53 test2_formatter_add 54 test2_formatter_set 55}; 56 57ok(!$LOADED, "Was not load_done right away"); 58ok(!$INIT, "Init was not done right away"); 59ok(Test2::API::test2_load_done, "We loaded it"); 60 61# Note: This is a check that stuff happens in an END block. 62{ 63 { 64 package FOLLOW; 65 66 sub DESTROY { 67 return if $_[0]->{fixed}; 68 print "not ok - Did not run end ($_[0]->{name})!"; 69 $? = 255; 70 exit 255; 71 } 72 } 73 74 our $kill1 = bless {fixed => 0, name => "Custom Hook"}, 'FOLLOW'; 75 Test2::API::test2_add_callback_exit( 76 sub { 77 print "# Running END hook\n"; 78 $kill1->{fixed} = 1; 79 } 80 ); 81 82 our $kill2 = bless {fixed => 0, name => "set exit"}, 'FOLLOW'; 83 my $old = Test2::API::Instance->can('set_exit'); 84 no warnings 'redefine'; 85 *Test2::API::Instance::set_exit = sub { 86 $kill2->{fixed} = 1; 87 print "# Running set_exit\n"; 88 $old->(@_); 89 }; 90} 91 92ok($CLASS->can('test2_init_done')->(), "init is done."); 93ok($CLASS->can('test2_load_done')->(), "Test2 is finished loading"); 94 95is($CLASS->can('test2_pid')->(), $$, "got pid"); 96is($CLASS->can('test2_tid')->(), get_tid(), "got tid"); 97 98ok($CLASS->can('test2_stack')->(), 'got stack'); 99is($CLASS->can('test2_stack')->(), $CLASS->can('test2_stack')->(), "always get the same stack"); 100 101ok($CLASS->can('test2_ipc')->(), 'got ipc'); 102is($CLASS->can('test2_ipc')->(), $CLASS->can('test2_ipc')->(), "always get the same IPC"); 103 104is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/Test2::IPC::Driver::Files/], "Got driver list"); 105 106# Verify it reports to the correct file/line, there was some trouble with this... 107my $file = __FILE__; 108my $line = __LINE__ + 1; 109my $warnings = warnings { $CLASS->can('test2_ipc_add_driver')->('fake') }; 110my $sub1 = sub { 111like( 112 $warnings->[0], 113 qr{^IPC driver fake loaded too late to be used as the global ipc driver at \Q$file\E line $line}, 114 "got warning about adding driver too late" 115); 116}; 117if ($] le "5.006002") { 118 todo("TODO known to fail on $]", $sub1); 119} else { 120 $sub1->(); 121} 122 123is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/fake Test2::IPC::Driver::Files/], "Got updated list"); 124 125ok($CLASS->can('test2_ipc_polling')->(), "Polling is on"); 126$CLASS->can('test2_ipc_disable_polling')->(); 127ok(!$CLASS->can('test2_ipc_polling')->(), "Polling is off"); 128$CLASS->can('test2_ipc_enable_polling')->(); 129ok($CLASS->can('test2_ipc_polling')->(), "Polling is on"); 130 131ok($CLASS->can('test2_formatter')->(), "Got a formatter"); 132is($CLASS->can('test2_formatter')->(), $CLASS->can('test2_formatter')->(), "always get the same Formatter (class name)"); 133 134my $ran = 0; 135$CLASS->can('test2_add_callback_post_load')->(sub { $ran++ }); 136is($ran, 1, "ran the post-load"); 137 138like( 139 exception { $CLASS->can('test2_formatter_set')->() }, 140 qr/No formatter specified/, 141 "formatter_set requires an argument" 142); 143 144like( 145 exception { $CLASS->can('test2_formatter_set')->('fake') }, 146 qr/Global Formatter already set/, 147 "formatter_set doesn't work after initialization", 148); 149 150ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set"); 151$CLASS->can('test2_no_wait')->(1); 152ok($CLASS->can('test2_no_wait')->(), "no_wait is set"); 153$CLASS->can('test2_no_wait')->(undef); 154ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set"); 155 156ok($CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting enabled"); 157$CLASS->can('test2_ipc_wait_disable')->(); 158ok(!$CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting disabled"); 159$CLASS->can('test2_ipc_wait_enable')->(); 160ok($CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting enabled"); 161 162my $pctx; 163sub tool_a($;$) { 164 Test2::API::context_do { 165 my $ctx = shift; 166 my ($bool, $name) = @_; 167 $pctx = wantarray; 168 die "xyz" unless $bool; 169 $ctx->ok($bool, $name); 170 return unless defined $pctx; 171 return (1, 2) if $pctx; 172 return 'a'; 173 } @_; 174} 175 176$pctx = 'x'; 177tool_a(1, "void context test"); 178ok(!defined($pctx), "void context"); 179 180my $x = tool_a(1, "scalar context test"); 181ok(defined($pctx) && $pctx == 0, "scalar context"); 182is($x, 'a', "got scalar return"); 183 184my @x = tool_a(1, "array context test"); 185ok($pctx, "array context"); 186is_deeply(\@x, [1, 2], "Got array return"); 187 188like( 189 exception { tool_a(0) }, 190 qr/^xyz/, 191 "got exception" 192); 193 194sub { 195 my $outer = context(); 196 sub { 197 my $middle = context(); 198 is($outer->trace, $middle->trace, "got the same context before calling no_context"); 199 200 Test2::API::no_context { 201 my $inner = context(); 202 ok($inner->trace != $outer->trace, "Got a different context inside of no_context()"); 203 $inner->release; 204 }; 205 206 $middle->release; 207 }->(); 208 209 $outer->release; 210}->(); 211 212sub { 213 my $outer = context(); 214 sub { 215 my $middle = context(); 216 is($outer->trace, $middle->trace, "got the same context before calling no_context"); 217 218 Test2::API::no_context { 219 my $inner = context(); 220 ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)"); 221 $inner->release; 222 } $outer->hub->hid; 223 224 $middle->release; 225 }->(); 226 227 $outer->release; 228}->(); 229 230sub { 231 my @warnings; 232 my $outer = context(); 233 sub { 234 my $middle = context(); 235 is($outer->trace, $middle->trace, "got the same context before calling no_context"); 236 237 local $SIG{__WARN__} = sub { push @warnings => @_ }; 238 Test2::API::no_context { 239 my $inner = context(); 240 ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)"); 241 } $outer->hub->hid; 242 243 $middle->release; 244 }->(); 245 246 $outer->release; 247 248 is(@warnings, 1, "1 warning"); 249 like( 250 $warnings[0], 251 qr/A context appears to have been destroyed without first calling release/, 252 "Got warning about unreleased context" 253 ); 254}->(); 255 256 257sub { 258 my $hub = Test2::Hub->new(); 259 my $ctx = context(hub => $hub); 260 is($ctx->hub,$hub, 'got the hub of context() argument'); 261 $ctx->release; 262}->(); 263 264 265my $sub = sub { }; 266 267Test2::API::test2_add_callback_context_acquire($sub); 268Test2::API::test2_add_callback_context_init($sub); 269Test2::API::test2_add_callback_context_release($sub); 270Test2::API::test2_add_callback_exit($sub); 271Test2::API::test2_add_callback_post_load($sub); 272 273is((grep { $_ == $sub } Test2::API::test2_list_context_acquire_callbacks()), 1, "got the one instance of the hook"); 274is((grep { $_ == $sub } Test2::API::test2_list_context_init_callbacks()), 1, "got the one instance of the hook"); 275is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 1, "got the one instance of the hook"); 276is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()), 1, "got the one instance of the hook"); 277is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()), 1, "got the one instance of the hook"); 278 279Test2::API::test2_add_callback_context_acquire($sub); 280Test2::API::test2_add_callback_context_init($sub); 281Test2::API::test2_add_callback_context_release($sub); 282Test2::API::test2_add_callback_exit($sub); 283Test2::API::test2_add_callback_post_load($sub); 284 285is((grep { $_ == $sub } Test2::API::test2_list_context_acquire_callbacks()), 2, "got the two instances of the hook"); 286is((grep { $_ == $sub } Test2::API::test2_list_context_init_callbacks()), 2, "got the two instances of the hook"); 287is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 2, "got the two instances of the hook"); 288is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()), 2, "got the two instances of the hook"); 289is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()), 2, "got the two instances of the hook"); 290 291ok(!Test2::API::test2_is_testing_done(), "Testing is not done"); 292 293done_testing; 294 295die "Testing should be done, but it is not!" unless Test2::API::test2_is_testing_done(); 296 297{ 298 package My::Cleanup; 299 300 sub DESTROY { 301 return if Test2::API::test2_is_testing_done(); 302 print "not ok - Testing should be done, but it is not!\n"; 303 warn "Testing should be done, but it is not!"; 304 eval "END { $? = 255 }; 1" or die $@; 305 exit 255; 306 } 307} 308 309# This should destroy the thing 310END { no warnings 'once'; $main::cleanup2 = bless {}, 'My::Cleanup' } 311