lib/CXGN/Page.pm

   1 package CXGN::Page;
   2
   3 =head1 NAME
   4
   5 CXGN::Page
   6
   7 =head1 DESCRIPTION
   8
   9 This entire module is deprecated.  Do not use in new code.
  10
  11 Page object which handles headers, footers, simple message pages, and
  12 simple error pages. Can also retrieve page arguments and handle
  13 redirects.  This is now a subclass of CXGN::Scrap, which handles all
  14 of the argument-retrieval.
  15
  16 =cut
  17
  18 use base qw/ CXGN::Scrap /;
  19 use strict;
  20 use warnings;
  21 use HTML::Entities qw/encode_entities/;
  22 use URI::Escape;
  23 use Carp;
  24 use CGI qw/ -compile :html4/;
  25 use CXGN::Page::FormattingHelpers qw(blue_section_html newlines_to_brs);
  26 use CXGN::Apache::Error;
  27 use CXGN::DB::Connection;
  28 use CXGN::Login;
  29 use CXGN::Page::VHost::SGN;
  30 use CXGN::Tools::File;
  31
  32
  33 use Data::Dumper;
  34 $Data::Dumper::Varname = 'VAR_DUMP';
  35
  36 use CatalystX::GlobalContext '$c';
  37
  38 ## STDERR Capture for the Logger, by Developer Preference ####
  39 our $STDERR_BUFFER  = '';
  40 our $STDERR_CAPTURE = 0;
  41
  42 =head1 OBJECT METHODS
  43
  44 =head2 new
  45
  46 Creates a new page object. This will try to be smart and give you the correct type of header for your virtual host, based on the apache request.  All arguments are optional, but they are ordered.
  47
  48         #Example
  49         my $page=CXGN::Page->new( $page_name, $author,
  50                 {jslib => ['CXGN.MyModule','MochiKit.Logging', 'Prototype', 'Scriptaculous.DragDrop']});
  51
  52 The jslib in the final optional hashref is equivalent to using jsan_use() on the page.
  53
  54 =cut
  55
  56 sub new {
  57     my $class = shift;
  58
  59     my $self = $class->SUPER::new();
  60
  61     $self->{mk_log_messages} = [];
  62     my ( $name, $author, $other ) = @_;
  63     if ( $other and my $js = $other->{jslib} ) {
  64         my @libs = ref $js ? @$js : ($js);
  65         $self->jsan_use(@libs);
  66     }
  67     $self->{context} = $c;
  68     $self->{project_name} = 'SGN';
  69
  70     $self->{page_object} = CXGN::Page::VHost::SGN->new($self->get_dbh());
  71     $self->{page_object}->{page} = $self;
  72
  73     $name   ||= '';
  74     $author ||= '';
  75     $self->{name}         = $name;
  76     $self->{author}       = $author;
  77     $self->{embedded_css} = "";
  78
  79     return $self;
  80 }
  81
  82 =head2 add_style
  83
  84    Add CSS to the page. Should be called before header() so the style can be output in the <HEAD>.
  85    (XHTML 1.0 requires that embedded stylesheets be in the <HEAD>.)
  86
  87    #Example
  88         $page->add_style(text => "some css text", file => "stylesheet.css");
  89
  90
  91 =cut
  92
  93 sub add_style {
  94     my ( $self, %params ) = @_;
  95     if ( exists $params{text} ) {
  96         $self->{embedded_css} .=
  97           "<style type=\"text/css\">\n$params{text}\n</style>\n";
  98     }
  99     if ( exists $params{file} ) {
 100         $self->{embedded_css} .=
 101 "<link rel=\"stylesheet\" type=\"text/css\" href=\"$params{file}\" />\n";
 102     }
 103 }
 104
 105 sub get_header {
 106     my $self           = shift;
 107
 108     return $self->{context}->render_mason(
 109         '/site/header.mas',
 110         page_title => $self->{page_title},
 111         extra_headers => $self->jsan_render_includes
 112                          . ( $self->{embedded_css}     || '' )
 113                          . ( $self->{extra_head_stuff} || '' ),
 114        );
 115 }
 116
 117 sub get_footer {
 118     my $self = shift;
 119     return $self->{context}->render_mason('/site/footer.mas');
 120 }
 121
 122 sub simple_footer {
 123     my $self=shift;
 124  #
 125     carp "simple_footer() deprecated, please replace this with mason code";
 126
 127     print <<END_HEREDOC;
 128 </td></tr>
 129 <tr><td><hr></td></tr>
 130 <tr><td id= "pagecontent_footer"><font color="gray" size="1">Copyright &copy; <a href="http://sgn.cornell.edu/" class="footer" >Sol Genomics Network</a> and <a class="footer" href="http://bti.cornell.edu/">the Boyce Thompson Institute</a>.<br />Development of this software was supported by the <a class="footer" href="http://www.nsf.gov/">U.S. National Science Foundation</a>.</td></tr>
 131 </table>
 132 </div>
 133 </body>
 134 </html>
 135 END_HEREDOC
 136
 137 }
 138
 139 =head2 header_html
 140
 141 returns standard header html string. $page_title is optional. Without it, the $page_name sent in with CXGN::Page->new() will be used. $content_title is optional. If you include it, you will get a standard "<h3>Page title</h3>" under our standard header.
 142
 143         #Example
 144         print $page->header_html($page_title,$content_title);
 145
 146 =cut
 147
 148 sub header_html {
 149     my $self = shift;
 150     ( $self->{page_title}, $self->{content_title}, $self->{extra_head_stuff} ) =
 151       @_;
 152     unless ( $self->{page_title} ) {
 153         $self->{page_title} = $self->{name};
 154     }
 155     my $html = $self->get_header();
 156     if ( $self->{content_title} ) {
 157         $html .= CXGN::Page::FormattingHelpers::page_title_html(
 158             $self->{content_title} );
 159     }
 160     return $html;
 161 }
 162
 163
 164 =head2 header
 165
 166 Prints $self->header_html(@_), along with a text/html content-type header.
 167
 168 =cut
 169
 170 sub header
 171 {
 172     my $self=shift;
 173     $self->send_content_type_header();
 174     print $self->header_html(@_);
 175 }
 176
 177 =head2 function simple_header()
 178
 179   Args: An optional header string
 180   Desc: Print an SGN simple header without the toolbars
 181   Ret:  Nothing
 182   Side Effects: prints a header to STDOUT
 183
 184 =cut
 185
 186 sub simple_header {
 187     my $self          = shift;
 188     my $header_string = shift;
 189     my $head          = $self->{page_object}->html_head( $header_string,
 190                                                          $self->jsan_render_includes
 191                                                          . ( $self->{embedded_css} || '' )
 192                                                          . ( $self->{extra_head_stuff} || '' ),
 193                                                        );
 194     $self->send_content_type_header();
 195     print "\n"; #< just in case we printed some plain headers
 196     print <<END_HTML;
 197 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 198 <html>
 199 $head
 200
 201 <body>
 202 <div id="outercontainer">
 203   <a name="top"></a>
 204
 205   <table summary="" width="800" cellpadding="0" cellspacing="0" border="0">
 206   <tr>
 207   <td width="35"><a href="/"><img src="/documents/img/sgn_logo_icon.png" border="0" width="30" height="30" /></a></td>
 208   <td style="color: gray; font-size:12px; font-weight: bold; vertical-align: middle">$header_string</td></tr>
 209   </table>
 210   <table summary="" width="800" cellpadding="0" cellspacing="0" border="0">
 211   <tr><td>
 212   <hr />
 213 END_HTML
 214
 215     carp "simple_header() deprecated, please replace this with mason code";
 216 }
 217
 218 =head2 footer
 219
 220 Prints a standard footer.
 221
 222         #Example
 223         $page->footer();
 224
 225 =cut
 226
 227 sub footer {
 228     my $self = shift;
 229     print $self->get_footer();
 230 }
 231
 232 =head2 client_redirect
 233
 234 Sends client to another location.
 235
 236         #Example
 237         $page->client_redirect("http://sgn.cornell.edu");
 238
 239 =cut
 240
 241 sub client_redirect {
 242     my ( $self, $url ) = @_;
 243     print CGI->new->redirect( -uri => $url, -status => 302 );
 244     exit;
 245 }
 246
 247
 248 =head2 message_page
 249
 250 deprecated. do not use in new code.
 251
 252 =cut
 253
 254 sub message_page {
 255     my ( $self, $message_header, $message_body ) = @_;
 256
 257     unless( defined $message_body ) {
 258         $message_body = $message_header;
 259         $message_header = undef;
 260     }
 261
 262     $c->throw( title    => $message_header,
 263                message  => $message_body,
 264                is_error => 0,
 265               );
 266
 267 }
 268
 269 =head2 error_page
 270
 271 deprecated, do not use in new code.
 272
 273 =cut
 274
 275 sub error_page {
 276     my $self = shift;
 277     my ( $message_header, $message_body, $error_verb, $developer_message ) = @_;
 278
 279     unless( length $message_body ) {
 280         $message_body = $message_header;
 281         $message_header = undef;
 282     }
 283
 284     $c->throw( message => $message_body,
 285                developer_message => $developer_message,
 286                title => $message_header,
 287               );
 288 }
 289
 290 =head1 OTHER METHODS
 291
 292 All other methods are either deprecated or for internal use only.
 293
 294 =head2 comments_html
 295
 296 UNDOCUMENTED, PLEASE FIX
 297
 298 =cut
 299
 300 sub comments_html {
 301
 302     my ( $self, $thingtype, $thingid, $passed_referer ) = @_;
 303
 304     # thingtype would be something like "marker" or "bac"
 305     # thingid would be the marker_id or the clone_id
 306
 307     my $placeholder = blue_section_html(
 308         "User Comments",
 309         qq{<!-- check for comments only shows up when AJAX is not enabled
 310      (old browsers, buggy ajax) -->
 311 Please wait, checking for comments.  (If comments do not show up, access them <a href="/forum/return_comments.pl?type=$thingtype&amp;id=$thingid">here</a>)}
 312     );
 313
 314     my $referer = $self->URLEncode($passed_referer);
 315
 316     my $html = <<EOHTML;
 317 <span class="noshow" id="referer">$referer</span>
 318 <span class="noshow" id="commentstype">$thingtype</span>
 319 <span class="noshow" id="commentsid">$thingid</span>
 320 <div id="commentsarea">
 321 $placeholder
 322 </div>
 323
 324 EOHTML
 325
 326 }
 327
 328 #######################################
 329 ## DEPRECATED DO NOT USE ##############
 330 #######################################
 331
 332 # # Utility function for generating random filenames for tempfiles. When
 333 # # used this way we depend on low probability of collision rather than
 334 # # guarantees of unique filenames; ALSO, we usually don't actually want
 335 # # a unique filename most of the time, but a deterministic one (eg,
 336 # # marker1234.png)
 337
 338 # #
 339 # # Note: Do not use this. Use File::Temp instead.
 340 # #
 341 # # a way of coming up with temporary file names
 342 use IO::File;
 343 our $dev_urandom = new IO::File "</dev/urandom"
 344   or print STDERR "Can't open /dev/urandom for an entropy source.";
 345
 346 sub tempname {
 347     my $rand_string = "";
 348     $dev_urandom->read( $rand_string, 16 );
 349     my @bytes = unpack( "C16", $rand_string );
 350     $rand_string = "";
 351     foreach (@bytes) {
 352         $_ %= 62;
 353         if ( $_ < 26 ) {
 354             $rand_string .= chr( 65 + $_ );
 355         }
 356         elsif ( $_ < 52 ) {
 357             $rand_string .= chr( 97 + ( $_ - 26 ) );
 358         }
 359         else {
 360             $rand_string .= chr( 48 + ( $_ - 52 ) );
 361         }
 362     }
 363     return $rand_string;
 364 }
 365
 366 sub URLEncode {
 367     my $self   = shift;
 368     my $theURL = $_[0];
 369     $theURL =~ s/([\W])/"%" . uc(sprintf("%2.2x",ord($1)))/eg;
 370     return $theURL;
 371 }
 372
 373 =head2 log
 374
 375  Usage: $page->log("MochiKit Log Message", "debug");
 376           or
 377                 $page->log($object_ref, 2);
 378  Desc: Will append a log message to the MochiKit logger.
 379  Args: message, type (optional).
 380        Type can be: debug, error, fatal, or warning
 381               or
 382            obj/hash/array-ref, levels_of_recursion (optional integer)
 383              Does a Data::Dumper on your ref, to the logger.
 384
 385 =cut
 386
 387 sub log {
 388     my $self    = shift;
 389     my $message = shift;
 390     my $type    = shift;
 391     if ( !defined($message) ) {
 392         my $mes = "Log message undefined.";
 393         if ( $type =~ /^\d+$/ )
 394         {   #Very likely that a bad reference was passed, if recursion level set
 395             $mes = "Undefined. Passed reference was probably never created.\n";
 396         }
 397         $self->log( $mes, "error" );
 398     }
 399
 400     if ( ref($message) ) {
 401         $type = 0 unless ( $type =~ /^\d+$/ );
 402         $Data::Dumper::Maxdepth = $type;
 403         my $dump = Dumper($message);
 404         $Data::Dumper::Maxdepth = 0;
 405         my $extra = "";
 406         if ( $type > 0 ) {
 407             $extra .= " - Depth: $type";
 408         }
 409         $message = ref($message) . "$extra\n" . $dump;
 410         $type    = "";
 411     }
 412
 413     $type ||= "";
 414     $type = "" if ( lc($type) eq "info" );
 415     my @valid = qw| error debug fatal warning |;
 416     my %valid = ();
 417     $valid{$_} = 1 foreach @valid;
 418     unless ( !$type || $valid{ lc($type) } ) {
 419         $self->log(
 420 "Invalid type '$type' provided to \$page->log() in perl script, using 'ERROR' instead (next message)",
 421             "Fatal"
 422         );
 423         $type = "ERROR";
 424     }
 425
 426     push( @{ $self->{mk_log_messages} }, $message, $type );
 427
 428     #print STDERR "LOG " . uc($type) . ": $message\n";
 429 }
 430
 431 sub log_error {
 432     my ( $self, $mesg ) = @_;
 433     $self->log( $mesg, "error" );
 434 }
 435
 436 sub log_fatal {
 437     my ( $self, $mesg ) = @_;
 438     $self->log( $mesg, "fatal" );
 439 }
 440
 441 sub log_debug {
 442     my ( $self, $mesg ) = @_;
 443     $self->log( $mesg, "debug" );
 444 }
 445
 446 sub mk_render_log_insert {
 447     my $self    = shift;
 448     my $content = "";
 449     my @m       = @{ $self->{mk_log_messages} };
 450     while (@m) {
 451         my $message = shift(@m);
 452         $message =~ s/\\/\\\\/g;
 453         $message =~ s/"/\\"/g;
 454         $message =~ s/\n/\\n/g;
 455         my $type = shift(@m);
 456         $type = ucfirst( lc($type) );
 457         $content .= "MochiKit.Logging.log$type(\"$message\");\n";
 458     }
 459     return
 460 "<!--MochiKit Log Insertion-->\n<script type=\"text/javascript\">\n$content\n</script>\n";
 461 }
 462
 463 sub mk_write_log {
 464     my $self    = shift;
 465     my $content = $self->mk_render_log_insert();
 466     $self->{mk_log_messages} = [];    #clear the log
 467     return $content;
 468 }
 469
 470 sub login {
 471     die "CXGN::Page login: This function is deprecated.";
 472      my $self = shift;
 473      my $cxgn_login = CXGN::Login->new( { NO_REDIRECT => 1 } );
 474      return if $cxgn_login->has_session();
 475      my ( $uname, $pass ) =
 476        $self->get_arguments( 'CXGN_LOGIN_USERNAME', 'CXGN_LOGIN_PASSWORD' );
 477     my $info = $cxgn_login->login_user( $uname, $pass );
 478     return $info;
 479 }
 480
 481 sub logout {
 482     die "CXGN::Page::logout: This function is deprecated.";
 483     my $cxgn_login = CXGN::Login->new( { NO_REDIRECT => 1 } );
 484     $cxgn_login->logout_user();
 485 }
 486
 487 sub login_form {
 488     return <<HTML
 489         <form name="CXGN_LOGIN" method="POST" style="margin:0px;padding0px">
 490         <table>
 491         <td>
 492         Username:</td><td><input type="text" id="CXGN_LOGIN_USERNAME" name="CXGN_LOGIN_USERNAME" /></td></tr>
 493         <tr><td>
 494         Password:</td><td><input type="password" id="CXGN_LOGIN_PASSWORD" name="CXGN_LOGIN_PASSWORD" /></td></tr>
 495         <tr><td>
 496         <input type="submit" value="Login" />
 497         </td>
 498         <td>
 499         </td>
 500         </tr>
 501         </table>
 502         </form>
 503 HTML
 504 }
 505
 506 =head2 accessors get_dbh(), set_dbh()
 507
 508  Usage:
 509  Desc:
 510  Property
 511  Side Effects:
 512  Example:
 513
 514 =cut
 515
 516 sub get_dbh {
 517     $c->dbc->dbh
 518 }
 519
 520 sub set_dbh {
 521     confess "don't set me.";
 522 }
 523
 524
 525 =head1 AUTHOR
 526
 527 john binns - John Binns <zombieite@gmail.com>
 528 Robert Buels - rmb32@cornell.edu
 529 Chris Carpita - csc32@cornell.edu (logging, developer toolbar)
 530
 531 =cut
 532
 533 ####
 534 1;    # do not remove
 535 ####