lib/CXGN/Scrap.pm

   1 package CXGN::Scrap;
   2
   3 =head1 NAME
   4
   5  CXGN::Scrap
   6
   7 =head1 DESCRIPTION
   8
   9  Simplified page object, now a superclass of CXGN::Page.  Also changed
  10  to be a singleton class.  Provides the apache_request bindings for
  11  argument retrieval, but doesn't do much else.  The motivation for this
  12  module was to create a subclass of a simple page object for AJAX
  13  requests.
  14
  15 =cut
  16
  17
  18 use strict;
  19 use warnings;
  20 use Clone;
  21 use Apache2::RequestUtil ();
  22 use Apache2::Request;
  23 use Apache2::Upload;
  24 use HTML::Entities;
  25 use Carp;
  26 use CGI;
  27
  28 use File::Path ();
  29
  30 use JSAN::ServerSide;
  31 use SGN::Context;
  32
  33 =head1 OBJECT METHODS
  34
  35 =head2 new
  36
  37 Creates returns the singleton page-scrap object.
  38
  39 #Example
  40 my $scrap=CXGN::Scrap->new();
  41
  42 =cut
  43
  44 sub new {
  45   my $class=shift;
  46   my $self = bless {},$class;
  47   $self->{request} ||= Apache2::RequestUtil->request();
  48   $self->{apache_request} ||= Apache2::Request->new($self->{request});
  49   $self->{content_type} = 'text/html';
  50   $self->{vhost} = SGN::Context->instance;
  51   return $self;
  52 }
  53
  54 =head2 get_encoded_arguments
  55
  56 Gets arguments which are being sent in via GET or POST (doesn't matter which). Encodes the HTML entities in those arguments to keep clients from being able to submit evil HTML, javascript, etc. to be printed on our pages.
  57
  58         #Example
  59         my($id,$name)=$scrap->get_encoded_arguments("id","name");
  60
  61 =cut
  62
  63 # use this one for all alphanumeric arguments, unless for some reason you don't
  64 # want to filter out possibly evil characters (see below)
  65 sub get_encoded_arguments {
  66   my($self,@items)=@_;
  67
  68   return map {HTML::Entities::encode_entities($_,"<>&'\"")} $self->get_arguments(@items);
  69   # encoding does not appear to work for foreign characters with
  70   # umlauts, etc. so we're using this restricted version of the command
  71 }
  72
  73
  74 =head2 get_all_encoded_arguments
  75
  76 Args: none
  77 Ret : hash of ( argument name => HTML-encoded value of that argument )
  78
  79 WARNING: this method does not work for POSTs of type multipart/form-data, particularly with file uploads.  This method only works with GET and other POST requests.
  80
  81 =cut
  82
  83 sub get_all_encoded_arguments {
  84   my ($self) = @_;
  85   my $r = $self->{apache_request};
  86   my @paramnames = $r->param;
  87   return map {
  88     my $p = $self->get_arguments($_);
  89     $_ => HTML::Entities::encode_entities($p,"<>&'\";");
  90   } @paramnames;
  91 }
  92
  93
  94 =head2 get_upload
  95
  96 Get the L<Apache2::Upload> object for the currently uploaded file, if any.
  97
  98 =cut
  99
 100 sub get_upload {
 101   my $self = shift;
 102   my @upload_names = $self->{apache_request}->upload();
 103   if( wantarray ) {
 104       return map $self->{apache_request}->upload($_), @upload_names;
 105   } else {
 106       return $self->{apache_request}->upload( $upload_names[0] );
 107   }
 108 }
 109
 110 =head2 get_arguments
 111
 112 Gets arguments which are being sent in via GET or POST (doesn't matter which). DOES NOT encode the HTML entities in those arguments, so be careful because it IS possible for clients to submit evil HTML, javascript, etc.
 113
 114         #Example
 115         my($fasta_file)=$scrap->get_arguments("fasta_file");
 116
 117 =cut
 118
 119 # only use this method if you need unfiltered arguments with weird characters
 120 # in them, like passwords and fasta file data. be aware that the user's agent
 121 # (browser) could be capable of sending ALMOST ANYTHING to you as parameters.
 122 # --john
 123 sub get_arguments {
 124         my($self,@items)=@_;
 125         my $apr = $self->{apache_request};
 126         my @args = map {
 127           my @p = $apr->param($_);
 128           if(@p > 1) {
 129             carp "WARNING: multiple parameters returned for argument '$_'";
 130             \@p
 131           }
 132           else {
 133             no warnings 'uninitialized';
 134             length $p[0] ? $p[0] : undef
 135           }
 136         } @items;
 137         return @args if wantarray;
 138         return $args[0];
 139 }
 140
 141 =head2 jsan_use
 142
 143   Usage: $scrap->jsan_use('MyModule.Name');
 144   Desc : add a javascript module (and its dependent javascript
 145          modules) to the list of js modules needed by this page scrap
 146   Args : list of module names in My.Module.Name form
 147   Ret  : nothing meaningful
 148
 149 =cut
 150
 151 sub jsan_use {
 152   my ($self,@uses) = @_;
 153   $self->_jsan->add(my $a = $_) foreach @uses;
 154 }
 155
 156 =head2 jsan_render_includes
 157
 158   Usage: my $str = $scrap->jsan_render_includes
 159   Desc : render HTML script-tag includes for javascript
 160          modules required with jsan_use(), plus the globally-used
 161          javascript modules defined herein, currently:
 162
 163            CXGN.Effects
 164            CXGN.Page.FormattingHelpers
 165            CXGN.Page.Toolbar
 166            CXGN.UserPrefs
 167
 168   Args : none
 169   Ret  : a string containing zero or more newline-separated
 170          include statements
 171   Side Effects: none
 172
 173 =cut
 174
 175 my @global_js = qw(
 176                    CXGN.Effects
 177                    CXGN.Page.FormattingHelpers
 178                    CXGN.UserPrefs
 179                   );
 180
 181 sub jsan_render_includes {
 182         my ($self) = @_;
 183
 184         # add in our global JS, which is used for every page
 185         # JSAN::ServerSide is pretty badly written.  cannot use $_ to
 186         # pass the name to add()
 187         foreach my $js (@global_js) {
 188             $self->_jsan->add($js);
 189         }
 190
 191         return join "\n",
 192                map qq|<script language="JavaScript" src="$_" type="text/javascript"></script>|,
 193                $self->_jsan->uris;
 194 }
 195
 196 sub _jsan {
 197         my ($self) = @_;
 198
 199         return $self->{jsan_serverside} ||= JSAN::ServerSide->new( %{ $self->{context}->_jsan_params } );
 200 }
 201
 202 =head2 cgi_params
 203
 204 Wrapper for CGI->new()->Vars(). Used when you have many arguments with the same name.
 205
 206         #Example
 207         my %params=$scrap->params();
 208
 209 =cut
 210
 211 # if you have lists of same-named parameters you will probably want to
 212 # handle that yourself using this function which returns a hash (not
 213 # hash reference)
 214 sub cgi_params {
 215         return CGI->new()->Vars();
 216 }
 217
 218 =head2 get_hostname
 219
 220   Usage: my $hostname = $page->hostname();
 221   Desc : get the hostname in the current page request (from
 222          Apache::Request::hostname())
 223   Args : none
 224   Ret  : hostname string
 225   Side Effects: none
 226
 227 =cut
 228
 229 sub get_hostname {
 230   shift->{request}->hostname();
 231 }
 232
 233 =head2 get_request
 234
 235   Usage: my $req = $page->get_request();
 236   Desc : get the Apache->request() object for the current page
 237          request
 238   Args : none
 239   Ret  : an Apache object
 240   Side Effects: none
 241
 242 =cut
 243
 244 sub get_request {
 245   shift->{request};
 246 }
 247
 248
 249 =head2 get_apache_request
 250
 251   Usage: my $areq = $page->apache_request();
 252   Desc : get the Apache::Request for this request, equivalent to
 253          Apache::Request->instance( $page->request() )
 254   Args : none
 255   Ret  : an L<Apache::Request> object
 256   Side Effects: none
 257
 258 =cut
 259
 260 sub get_apache_request {
 261   shift->{apache_request}
 262 }
 263
 264
 265 =head2 is_bot_request
 266
 267   Usage: print "it's a bot" if $page->is_bot_request;
 268   Desc : return true if this page request is probably coming from a
 269          web-crawling robot
 270   Args : none
 271   Ret  : boolean
 272   Side Effects: none
 273
 274 =cut
 275
 276 sub is_bot_request {
 277   my $user_agent = shift->get_request->headers_in->{'User-Agent'};
 278
 279   return 1 if
 280     ( $user_agent =~ m|bot/\d|i #< will get google, msn
 281       || $user_agent =~ /Yahoo!?\s+Slurp/i #< will get yahoo
 282     );
 283
 284   return;
 285 }
 286
 287
 288 =head2 send_content_type_header
 289
 290   Usage: $page->send_content_type_header()
 291   Desc : set an http content-type header
 292   Args : optional string content type to send,
 293          defaults to 'text/html'
 294   Ret  : nothing meaningful
 295   Side Effects: dies on error
 296
 297 =cut
 298
 299
 300 sub send_content_type_header {
 301     my ( $self, $type ) = @_;
 302     $self->{request}->content_type( $type || $self->{content_type} || 'text/html');
 303 }
 304
 305
 306 =head2 path_to
 307
 308   Usage: $page->path_to('/something/somewhere.txt');
 309   Desc : get the full path to a file relative to the
 310          base path of the web server
 311   Args : file path relative to the site root
 312   Ret  : absolute file path
 313   Side Effects: dies on error
 314
 315 =cut
 316
 317 sub path_to {
 318     shift->{vhost}->path_to(@_)
 319 }
 320
 321
 322 =head2 tempfiles_subdir
 323
 324   Usage: my $dir = $page->tempfiles_subdir('some','dir');
 325   Desc : get the path to this site's web-server-accessible tempfiles directory.
 326   Args : (optional) one or more directory names to append onto the tempdir root
 327   Ret  : full filesystem pathname to the relevant dir
 328   Side Effects: dies on error
 329
 330 =cut
 331
 332 sub tempfiles_subdir {
 333     shift->{vhost}->tempfiles_subdir(@_);
 334 }
 335
 336
 337 =head2 get_conf
 338
 339   convenience method, forwards to to CXGN::VHost::get_conf();
 340
 341   equivalent to doing CXGN::VHost->new->get_conf(@_);
 342
 343 =cut
 344
 345 sub get_conf {
 346   my $self = shift;
 347   return $self->{vhost}->get_conf(@_);
 348 }
 349
 350
 351 =head1 AUTHORS
 352
 353 John Binns - John Binns <zombieite@gmail.com>  (methods)
 354
 355 Christopher Carpita  <csc32@cornell.edu> (constructor/org)
 356
 357 =cut
 358
 359 ####
 360 1; # do not remove
 361 ####