htetc/handler.pl

   1 #!/usr/bin/perl
   2
   3 package HTML::Mason;
   4
   5 use strict;
   6 use vars qw($r);
   7 use File::Slurp qw( slurp );
   8 use HTML::Mason 1.27; #http://www.masonhq.com/?ApacheModPerl2Redirect
   9 use HTML::Mason::Interp;
  10 use HTML::Mason::Compiler::ToObject;
  11
  12 # Bring in ApacheHandler, necessary for mod_perl integration.
  13 # Uncomment the second line (and comment the first) to use
  14 # Apache::Request instead of CGI.pm to parse arguments.
  15 use HTML::Mason::ApacheHandler;
  16 # use HTML::Mason::ApacheHandler (args_method=>'mod_perl');
  17
  18 ###use Module::Refresh;###
  19
  20 # List of modules that you want to use from components (see Admin
  21 # manual for details)
  22 #{  package HTML::Mason::Commands;
  23 #   use CGI;
  24 #}
  25
  26 if ( %%%RT_ENABLED%%% ) {
  27  eval '
  28    use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
  29    use RT;
  30    use vars qw($Nobody $SystemUser);
  31    RT::LoadConfig();
  32  ';
  33  die $@ if $@;
  34 }
  35
  36 # Some hooks supporting strange legacy ways people have added stuff on
  37
  38 my @addl_comp_root = ();
  39 my $addl_comp_root_file = '%%%FREESIDE_CONF%%%/addl_comp_root.pl';
  40 if ( -e $addl_comp_root_file ) {
  41   my $text = slurp( $addl_comp_root_file );
  42   my @addl = eval $text;
  43   if ( @addl && ! $@ ) {
  44     @addl_comp_root = @addl;
  45   } elsif ($@) {
  46     warn "error parsing $addl_comp_root_file: $@\n";
  47   }
  48 }
  49
  50 $FS::Mason::addl_handler_use = '';
  51 my $addl_handler_use_file = '%%%FREESIDE_CONF%%%/addl_handler_use.pl';
  52 if ( -e $addl_handler_use_file ) {
  53   $FS::Mason::addl_handler_use = slurp( $addl_handler_use_file );
  54 }
  55
  56 # Create Mason objects
  57
  58 my %interp = (
  59   request_class        => 'HTML::Mason::Request::ApacheHandler',
  60   data_dir             => '%%%MASONDATA%%%',
  61   error_mode           => 'output',
  62   error_format         => 'html',
  63   ignore_warnings_expr => '.',
  64   comp_root            => [
  65                             [ 'freeside' => '%%%FREESIDE_DOCUMENT_ROOT%%%'    ],
  66                             [ 'rt'       => '%%%FREESIDE_DOCUMENT_ROOT%%%/rt' ],
  67                             @addl_comp_root,
  68                           ],
  69 );
  70
  71 my $fs_interp = new HTML::Mason::Interp (
  72   %interp,
  73   escape_flags => { 'js_string' => sub {
  74                       #${$_[0]} =~ s/(['\\\n])/'\\'.($1 eq "\n" ? 'n' : $1)/ge;
  75                       ${$_[0]} =~ s/(['\\])/\\$1/g;
  76                       ${$_[0]} =~ s/\n/\\n/g;
  77                       ${$_[0]} = "'". ${$_[0]}. "'";
  78                     }
  79                   },
  80 );
  81
  82 my $rt_interp = new HTML::Mason::Interp (
  83   %interp,
  84   escape_flags => { 'h' => \&RT::Interface::Web::EscapeUTF8 },
  85   compiler     => HTML::Mason::Compiler::ToObject->new(
  86                     default_escape_flags => 'h',
  87                     allow_globals        => [qw(%session)],
  88                   ),
  89 );
  90
  91 my $ah = new HTML::Mason::ApacheHandler (
  92   interp      => $fs_interp,
  93   args_method => 'CGI', #(and FS too)
  94 );
  95
  96 # Activate the following if running httpd as root (the normal case).
  97 # Resets ownership of all files created by Mason at startup.
  98 #
  99 #chown (Apache->server->uid, Apache->server->gid, $interp->files_written);
 100
 101 sub handler
 102 {
 103     ($r) = @_;
 104
 105     # If you plan to intermix images in the same directory as
 106     # components, activate the following to prevent Mason from
 107     # evaluating image files as components.
 108     #
 109     #return -1 if $r->content_type && $r->content_type !~ m|^text/|i;
 110
 111     #rar
 112     { package HTML::Mason::Commands;
 113       use strict;
 114       use vars qw( $cgi $p $fsurl);
 115       use vars qw( %session );
 116       use CGI 3.29 qw(-private_tempfiles); #3.29 to fix RT attachment problems
 117
 118       #breaks quick payment entry
 119       #http://rt.cpan.org/Public/Bug/Display.html?id=37365
 120       die "CGI.pm v3.38 is broken, use any other version >= 3.29".
 121           " (Debian 5.0?  aptitude remove libcgi-pm-perl)"
 122         if $CGI::VERSION == 3.38;
 123
 124       #use CGI::Carp qw(fatalsToBrowser);
 125       use List::Util qw( max min );
 126       use Date::Format;
 127       use Date::Parse;
 128       use Time::Local;
 129       use Time::Duration;
 130       use DateTime;
 131       use DateTime::Format::Strptime;
 132       use Lingua::EN::Inflect qw(PL);
 133       use Tie::IxHash;
 134       use URI::URL;
 135       use URI::Escape;
 136       use HTML::Entities;
 137       use HTML::TreeBuilder;
 138       use HTML::FormatText;
 139       use JSON;
 140       use IO::Handle;
 141       use IO::File;
 142       use IO::Scalar;
 143       use Net::Whois::Raw qw(whois);
 144       if ( $] < 5.006 ) {
 145         eval "use Net::Whois::Raw 0.32 qw(whois)";
 146         die $@ if $@;
 147       }
 148       use Text::CSV_XS;
 149       use Spreadsheet::WriteExcel;
 150       use Business::CreditCard 0.30; #for mask-aware cardtype()
 151       use NetAddr::IP;
 152       use String::Approx qw(amatch);
 153       use Chart::LinesPoints;
 154       use Chart::Mountain;
 155       use Color::Scheme;
 156       use HTML::Widgets::SelectLayers 0.07;
 157       use Locale::Country;
 158       use FS;
 159       use FS::UID qw( adminsuidsetup cgisuidsetup getotaker
 160                       dbh datasrc driver_name
 161                     );
 162       use FS::Record qw( qsearch qsearchs fields dbdef
 163                         str2time_sql str2time_sql_closing
 164                        );
 165       use FS::Conf;
 166       use FS::CGI qw(header menubar popurl rooturl table itable ntable idiot
 167                      eidiot myexit http_header);
 168       use FS::UI::Web qw(svc_url);
 169       use FS::UI::Web::small_custview qw(small_custview);
 170       use FS::UI::bytecount;
 171       use FS::Msgcat qw(gettext geterror);
 172       use FS::Misc qw( send_email send_fax states_hash counties state_label );
 173       use FS::Report::Table::Monthly;
 174       use FS::TicketSystem;
 175
 176       use FS::agent;
 177       use FS::agent_type;
 178       use FS::domain_record;
 179       use FS::cust_bill;
 180       use FS::cust_bill_pay;
 181       use FS::cust_credit;
 182       use FS::cust_credit_bill;
 183       use FS::cust_main qw(smart_search);
 184       use FS::cust_main_county;
 185       use FS::part_pkg_taxclass;
 186       use FS::cust_pay;
 187       use FS::cust_pkg;
 188       use FS::cust_pkg_reason;
 189       use FS::cust_refund;
 190       use FS::cust_credit_refund;
 191       use FS::cust_pay_refund;
 192       use FS::cust_svc;
 193       use FS::nas;
 194       use FS::part_bill_event;
 195       use FS::part_pkg;
 196       use FS::part_referral;
 197       use FS::part_svc;
 198       use FS::part_svc_router;
 199       use FS::part_virtual_field;
 200       use FS::pay_batch;
 201       use FS::pkg_svc;
 202       use FS::port;
 203       use FS::queue qw(joblisting);
 204       use FS::raddb;
 205       use FS::session;
 206       use FS::svc_acct;
 207       use FS::svc_acct_pop qw(popselector);
 208       use FS::svc_domain;
 209       use FS::svc_forward;
 210       use FS::svc_www;
 211       use FS::router;
 212       use FS::addr_block;
 213       use FS::svc_broadband;
 214       use FS::svc_external;
 215       use FS::type_pkgs;
 216       use FS::part_export;
 217       use FS::part_export_option;
 218       use FS::export_svc;
 219       use FS::msgcat;
 220       use FS::rate;
 221       use FS::rate_region;
 222       use FS::rate_prefix;
 223       use FS::payment_gateway;
 224       use FS::agent_payment_gateway;
 225       use FS::XMLRPC;
 226       use FS::payby;
 227       use FS::cdr;
 228       use FS::inventory_class;
 229       use FS::inventory_item;
 230       use FS::pkg_class;
 231       use FS::access_user;
 232       use FS::access_group;
 233       use FS::access_usergroup;
 234       use FS::access_groupagent;
 235       use FS::access_right;
 236       use FS::AccessRight;
 237       use FS::svc_phone;
 238       use FS::reason_type;
 239       use FS::reason;
 240       use FS::cust_main_note;
 241
 242       if ( $FS::Mason::addl_handler_use ) {
 243         eval $FS::Mason::addl_handler_use;
 244         die $@ if $@;
 245       }
 246
 247       if ( %%%RT_ENABLED%%% ) {
 248         eval '
 249           use RT::Tickets;
 250           use RT::Transactions;
 251           use RT::Users;
 252           use RT::CurrentUser;
 253           use RT::Templates;
 254           use RT::Queues;
 255           use RT::ScripActions;
 256           use RT::ScripConditions;
 257           use RT::Scrips;
 258           use RT::Groups;
 259           use RT::GroupMembers;
 260           use RT::CustomFields;
 261           use RT::CustomFieldValues;
 262           use RT::ObjectCustomFieldValues;
 263
 264           use RT::Interface::Web;
 265           use MIME::Entity;
 266           use Text::Wrapper;
 267           use CGI::Cookie;
 268           use Time::ParseDate;
 269           use HTML::Scrubber;
 270           #use Text::Quoted; #slow, unreliable, segfaults and is optional
 271           use Time::HiRes;
 272         ';
 273         die $@ if $@;
 274       }
 275
 276       *CGI::redirect = sub {
 277         my( $self, $location ) = @_;
 278         use vars qw($m);
 279
 280         # false laziness w/below
 281         if ( defined(@DBIx::Profile::ISA) ) { #profiling redirect
 282
 283           my $page =
 284             qq!<HTML><BODY>Redirect to <A HREF="$location">$location</A>!.
 285             '<BR><BR><PRE>'.
 286               ( UNIVERSAL::can(dbh, 'sprintProfile')
 287                   ? encode_entities(dbh->sprintProfile())
 288                   : 'DBIx::Profile missing sprintProfile method;'.
 289                     'unpatched or too old?'                        ).
 290             #"\n\n". &sprintAutoProfile().  '</PRE>'.
 291             "\n\n".                         '</PRE>'.
 292             '</BODY></HTML>';
 293           dbh->{'private_profile'} = {};
 294           return $page;
 295
 296         } else { #normal redirect
 297
 298           $m->redirect($location);
 299           '';
 300
 301         }
 302
 303       };
 304
 305       if ( $HTML::Mason::r->filename !~ /\/rt\/.*NoAuth/ ) { #not RT images/JS
 306
 307         $cgi = new CGI;
 308         &cgisuidsetup($cgi);
 309         #&cgisuidsetup($r);
 310         $p = popurl(2);
 311         $fsurl = rooturl();
 312
 313       } elsif ( $HTML::Mason::r->filename =~ /\/rt\/REST\/.*NoAuth/ ) {
 314
 315         #need to log somebody in for the mail gw
 316
 317         ##old installs w/fs_selfs or selfserv??
 318         #&adminsuidsetup('fs_selfservice');
 319
 320         &adminsuidsetup('fs_queue');
 321
 322       }
 323
 324       sub include {
 325         use vars qw($m);
 326         $m->scomp(@_);
 327       }
 328
 329       sub errorpage {
 330         use vars qw($m);
 331         $m->comp('/elements/errorpage.html', @_);
 332       }
 333
 334       sub redirect {
 335         my( $location ) = @_;
 336         use vars qw($m);
 337         $m->clear_buffer;
 338         #false laziness w/above
 339         if ( defined(@DBIx::Profile::ISA) ) { #profiling redirect
 340
 341           $m->print(
 342             qq!<HTML><BODY>Redirect to <A HREF="$location">$location</A>!.
 343             '<BR><BR><PRE>'.
 344               ( UNIVERSAL::can(dbh, 'sprintProfile')
 345                   ? encode_entities(dbh->sprintProfile())
 346                   : 'DBIx::Profile missing sprintProfile method;'.
 347                     'unpatched or too old?'                        ).
 348             #"\n\n". &sprintAutoProfile().  '</PRE>'.
 349             "\n\n".                         '</PRE>'.
 350             '</BODY></HTML>'
 351           );
 352           dbh->{'private_profile'} = {};
 353
 354           #whew.  removing this is all that's needed to fix the annoying
 355           #blank-page-instead-of-profiling-redirect-when-called-from-an-include
 356           #bug triggered by mason 1.32
 357           #my $rv = $m->abort(200);
 358
 359         } else { #normal redirect
 360
 361           $m->redirect($location);
 362
 363         }
 364
 365       }
 366
 367     } # end package HTML::Mason::Commands;
 368
 369     ###Module::Refresh->refresh;###
 370
 371     #$r->content_type('text/html; charset=utf-8');
 372     $r->content_type('text/html; charset=iso-8859-1');
 373     #eorar
 374
 375     my $headers = $r->headers_out;
 376     $headers->{'Cache-control'} = 'no-cache';
 377     #$r->no_cache(1);
 378     $headers->{'Expires'} = '0';
 379
 380 #    $r->send_http_header;
 381
 382     if ( $r->filename =~ /\/rt\// ) { #RT
 383
 384       $ah->interp($rt_interp);
 385
 386       local $SIG{__WARN__};
 387       local $SIG{__DIE__};
 388
 389       RT::Init();
 390
 391       # We don't need to handle non-text, non-xml items
 392       return -1 if defined( $r->content_type )
 393                 && $r->content_type !~ m!(^text/|\bxml\b)!io;
 394
 395     } else {
 396
 397       $ah->interp($fs_interp);
 398
 399     }
 400
 401     my %session;
 402     my $status;
 403     eval { $status = $ah->handle_request($r); };
 404 #!!
 405 #    if ( $@ ) {
 406 #       $RT::Logger->crit($@);
 407 #    }
 408     warn $@ if $@;
 409
 410     undef %session;
 411
 412 #!!
 413 #    if ($RT::Handle->TransactionDepth) {
 414 #       $RT::Handle->ForceRollback;
 415 #       $RT::Logger->crit(
 416 #"Transaction not committed. Usually indicates a software fault. Data loss may have occurred"
 417 #       );
 418 #    }
 419
 420     $status;
 421 }
 422
 423 1;