cgi-bin/solpeople/admin/crash_test.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use CXGN::DB::Connection;
   5 use CXGN::Page;
   6 use CXGN::Login;
   7 use CXGN::Contact;
   8 use CXGN::People;
   9 use CatalystX::GlobalContext qw( $c );
  10
  11 my $page = CXGN::Page->new("crash_test.pl","john binns");
  12 my $dbh = CXGN::DB::Connection->new();
  13
  14 # We are NOT using get_encoded_arguments here because we want to
  15 # simulate scripts that have neglected this.
  16 my($test,$message) = $page->get_arguments('test','message');
  17 $message ||= 'crash_test';
  18
  19 my $is_production_server = $c->config->{'production_server'};
  20 my $logged_in_person_id = CXGN::Login->new($dbh)->verify_session();
  21 my $logged_in_user = CXGN::People::Person->new($dbh, $logged_in_person_id);
  22 my $logged_in_username = $logged_in_user->get_first_name()." ".$logged_in_user->get_last_name();
  23 my $logged_in_user_type=$logged_in_user->get_user_type();
  24
  25 if( !$is_production_server || $logged_in_user_type eq 'curator') {
  26   if ($test) {
  27     # Demonstrate the ugly double header problem, in case someone
  28     # tries to fix it sometime.
  29     $page->header('Crash tester');
  30     if ($test == 1) {
  31       $page->error_page($message,'message body','errorverbed','developer message');
  32     } elsif ($test == 2) {
  33       &rube_goldberg(); #unneccessary function to test stack backtrace
  34     } elsif ($test == 3) {
  35       eval {
  36         die("Well, don't REALLY die.");
  37       };
  38       if ($@) {
  39         print $@;
  40       } else {
  41         print"Code eval'd without errors.";
  42       }
  43     } elsif ($test == 4) {
  44       $page->message_page($message,'message body');
  45     } elsif ($test == 5) {
  46       $c->forward_to_mason_view('/test/error_test.mas');
  47     } elsif ($test == 6) {
  48       $c->render_mason('/test/error_test.mas');
  49     } else {
  50       $page->message_page('Deeerrrrrrrr....');
  51     }
  52     $page->footer();
  53   } else { #no arguments
  54     &plain_page($page, $message);
  55   }
  56 }
  57 else {
  58    $page->message_page('Sorry, but you are not authorized to run crash tests.');
  59 }
  60
  61 sub rube_goldberg {
  62     die 'big ugly terrible death';
  63 }
  64
  65 sub plain_page {
  66     my $page = shift;
  67     my $message = shift;
  68     $page->header();
  69     print <<EOF;
  70 <a href="?test=1&amp;message=$message">Test anticipated error</a>
  71 (Note: the notion of &quot;anticipated&quot; error is deprecated.
  72 Just call die().)
  73 <br /><br />
  74
  75 <a href="?test=2">Test unanticipated error</a>
  76 (Note: the notion of &quot;unanticipated&quot; error is deprecated.
  77 Just call die().)
  78 <br /><br />
  79
  80 <a href="?test=5">Test Mason-handled error 1</a>
  81 <br /><br />
  82 <a href="?test=6">Test Mason-handled error 2</a>
  83 <br /><br />
  84
  85 <a href="page_that_doesnt_compile.pl">Test compile-time error</a>
  86 (Actually, this page does compile, and the error has always been a
  87 run-time error.)
  88 <br /><br />
  89
  90 <a href="another_page_that_doesnt_compile.pl">
  91 Test an actual compile-time error</a>
  92 (Specifically, an execution error during compilation.)
  93 <br /><br />
  94
  95 <a href="page_with_syntax_error.pl">Test a syntax error</a>
  96 (Specifically a parse error, which Perl seems to handle differently
  97 than execution errors during compilation)
  98 <br /><br />
  99
 100 <a href="/page_that_doesnt_exist/">Test 404</a><br /><br />
 101
 102 <a href="image_404_test.pl">Test image 404 within a page</a><br /><br />
 103
 104 <a href="?test=4&amp;message=$message">Test message page</a><br /><br />
 105
 106 <a href="?test=3">Test eval (page should NOT generate error page, just a long message)</a><br /><br />
 107 EOF
 108
 109     $page->footer();
 110     exit(0);
 111 }