SL/Controller/Base.pm

   1 package SL::Controller::Base;
   2
   3 use strict;
   4
   5 use parent qw(Rose::Object);
   6
   7 use Carp;
   8 use IO::File;
   9 use List::Util qw(first);
  10
  11 #
  12 # public/helper functions
  13 #
  14
  15 sub url_for {
  16   my $self = shift;
  17
  18   return $_[0] if (scalar(@_) == 1) && !ref($_[0]);
  19
  20   my %params      = ref($_[0]) eq 'HASH' ? %{ $_[0] } : @_;
  21   my $controller  = delete($params{controller}) || $self->_controller_name;
  22   my $action      = delete($params{action})     || 'dispatch';
  23   $params{action} = "${controller}/${action}";
  24   my $query       = join('&', map { $::form->escape($_) . '=' . $::form->escape($params{$_}) } keys %params);
  25
  26   return "controller.pl?${query}";
  27 }
  28
  29 sub redirect_to {
  30   my $self = shift;
  31   my $url  = $self->url_for(@_);
  32
  33   print $::cgi->redirect($url);
  34 }
  35
  36 sub render {
  37   my $self               = shift;
  38   my $template           = shift;
  39   my ($options, %locals) = (@_ && ref($_[0])) ? @_ : ({ }, @_);
  40
  41   $options->{type}       = lc($options->{type} || 'html');
  42   $options->{no_layout}  = 1 if $options->{type} eq 'js';
  43
  44   my $source;
  45   if ($options->{inline}) {
  46     $source = \$template;
  47
  48   } else {
  49     $source = "templates/webpages/${template}." . $options->{type};
  50     croak "Template file ${source} not found" unless -f $source;
  51   }
  52
  53   if (!$options->{partial} && !$options->{inline} && !$::form->{header}) {
  54     if ($options->{no_layout}) {
  55       $::form->{header} = 1;
  56       my $content_type  = $options->{type} eq 'js' ? 'text/javascript' : 'text/html';
  57
  58       print $::form->create_http_response(content_type => $content_type,
  59                                           charset      => $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET());
  60
  61     } else {
  62       $::form->{title} = $locals{title} if $locals{title};
  63       $::form->header;
  64     }
  65   }
  66
  67   my %params = ( %locals,
  68                  AUTH     => $::auth,
  69                  FLASH    => $::form->{FLASH},
  70                  FORM     => $::form,
  71                  LOCALE   => $::locale,
  72                  LXCONFIG => \%::lx_office_conf,
  73                  LXDEBUG  => $::lxdebug,
  74                  MYCONFIG => \%::myconfig,
  75                  SELF     => $self,
  76                );
  77
  78   my $output;
  79   my $parser = $self->_template_obj;
  80   $parser->process($source, \%params, \$output) || croak $parser->error;
  81
  82   print $output unless $options->{inline} || $options->{no_output};
  83
  84   return $output;
  85 }
  86
  87 sub send_file {
  88   my ($self, $file_name, %params) = @_;
  89
  90   my $file            = IO::File->new($file_name, 'r') || croak("Cannot open file '${file_name}'");
  91   my $content_type    =  $params{type} || 'application/octet_stream';
  92   my $attachment_name =  $params{name} || $file_name;
  93   $attachment_name    =~ s:.*//::g;
  94
  95   print $::form->create_http_response(content_type        => $content_type,
  96                                       content_disposition => 'attachment; filename="' . $attachment_name . '"',
  97                                       content_length      => -s $file);
  98
  99   $::locale->with_raw_io(\*STDOUT, sub { print while <$file> });
 100   $file->close;
 101 }
 102
 103 #
 104 # Before/after run hooks
 105 #
 106
 107 sub run_before {
 108   _add_hook('before', @_);
 109 }
 110
 111 sub run_after {
 112   _add_hook('after', @_);
 113 }
 114
 115 my %hooks;
 116
 117 sub _add_hook {
 118   my ($when, $class, $sub, %params) = @_;
 119
 120   foreach my $key (qw(only except)) {
 121     $params{$key} = { map { ( $_ => 1 ) } @{ $params{$key} } } if $params{$key};
 122   }
 123
 124   my $idx = "${when}/${class}";
 125   $hooks{$idx} ||= [ ];
 126   push @{ $hooks{$idx} }, { %params, code => $sub };
 127 }
 128
 129 sub _run_hooks {
 130   my ($self, $when, $action) = @_;
 131
 132   my $idx = "${when}/" . ref($self);
 133
 134   foreach my $hook (@{ $hooks{$idx} || [] }) {
 135     next if ($hook->{only  } && !$hook->{only  }->{$action})
 136          || ($hook->{except} &&  $hook->{except}->{$action});
 137
 138     if (ref($hook->{code}) eq 'CODE') {
 139       $hook->{code}->($self);
 140     } else {
 141       my $sub = $hook->{code};
 142       $self->$sub;
 143     }
 144   }
 145 }
 146
 147 #
 148 # private functions -- for use in Base only
 149 #
 150
 151 sub _run_action {
 152   my $self   = shift;
 153   my $action = shift;
 154   my $sub    = "action_${action}";
 155
 156   return $self->_dispatch(@_) if $action eq 'dispatch';
 157
 158   $::form->error("Invalid action '${action}' for controller " . ref($self)) if !$self->can($sub);
 159
 160   $self->_run_hooks('before', $action);
 161   $self->$sub(@_);
 162   $self->_run_hooks('after', $action);
 163 }
 164
 165 sub _controller_name {
 166   return (split(/::/, ref($_[0])))[-1];
 167 }
 168
 169 sub _dispatch {
 170   my $self    = shift;
 171
 172   no strict 'refs';
 173   my @actions = map { s/^action_//; $_ } grep { m/^action_/ } keys %{ ref($self) . "::" };
 174   my $action  = first { $::form->{"action_${_}"} } @actions;
 175   my $sub     = "action_${action}";
 176
 177   $self->_run_hooks('before', $action);
 178   $self->$sub(@_);
 179   $self->_run_hooks('after', $action);
 180 }
 181
 182 sub _template_obj {
 183   my ($self) = @_;
 184
 185   $self->{__basepriv_template_obj} ||=
 186     Template->new({ INTERPOLATE  => 0,
 187                     EVAL_PERL    => 0,
 188                     ABSOLUTE     => 1,
 189                     CACHE_SIZE   => 0,
 190                     PLUGIN_BASE  => 'SL::Template::Plugin',
 191                     INCLUDE_PATH => '.:templates/webpages',
 192                     COMPILE_EXT  => '.tcc',
 193                     COMPILE_DIR  => $::lx_office_conf{paths}->{userspath} . '/templates-cache',
 194                   }) || croak;
 195
 196   return $self->{__basepriv_template_obj};
 197 }
 198
 199 1;
 200
 201 __END__
 202
 203 =head1 NAME
 204
 205 SL::Controller::Base - base class for all action controllers
 206
 207 =head1 SYNOPSIS
 208
 209 =head2 OVERVIEW
 210
 211 This is a base class for all action controllers. Action controllers
 212 provide subs that are callable by special URLs.
 213
 214 For each request made to the web server an instance of the controller
 215 will be created. After the request has been served that instance will
 216 handed over to garbage collection.
 217
 218 This base class is derived from L<Rose::Object>.
 219
 220 =head2 CONVENTIONS
 221
 222 The URLs have the following properties:
 223
 224 =over 2
 225
 226 =item *
 227
 228 The script part of the URL must be C<controller.pl>.
 229
 230 =item *
 231
 232 There must be a GET or POST parameter named C<action> containing the
 233 name of the controller and the sub to call separated by C</>,
 234 e.g. C<Message/list>.
 235
 236 =item *
 237
 238 The controller name is the package's name without the
 239 C<SL::Controller::> prefix. At the moment only packages in the
 240 C<SL::Controller> namespace are valid; sub-namespaces are not
 241 allowed. The package name must start with an upper-case letter.
 242
 243 =item *
 244
 245 The sub part of the C<action> parameter is the name of the sub to
 246 call. However, the sub's name is automatically prefixed with
 247 C<action_>. Therefore for the example C<Message/list> the sub
 248 C<SL::DB::Message::action_list> would be called. This in turn means
 249 that subs whose name does not start with C<action_> cannot be invoked
 250 directly via the URL.
 251
 252 =back
 253
 254 =head2 INDIRECT DISPATCHING
 255
 256 In the case that there are several submit buttons on a page it is
 257 often impractical to have a single C<action> parameter match up
 258 properly. For such a case a special dispatcher method is available. In
 259 that case the C<action> parameter of the URL must be
 260 C<Controller/dispatch>.
 261
 262 The C<SL::Controller::Base::_dispatch> method will iterate over all
 263 subs in the controller package whose names start with C<action_>. The
 264 first one for which there's a GET or POST parameter with the same name
 265 and that's trueish is called.
 266
 267 Usage from a template usually looks like this:
 268
 269   <form method="POST" action="controller.pl">
 270     ...
 271     <input type="hidden" name="action" value="Message/dispatch">
 272     <input type="submit" name="action_mark_as_read" value="Mark messages as read">
 273     <input type="submit" name="action_delete" value="Delete messages">
 274   </form>
 275
 276 The dispatching is handled by the function L</_dispatch>.
 277
 278 =head2 HOOKS
 279
 280 Hooks are functions that are called before or after the controller's
 281 action is called. The controller package defines the hooks, and those
 282 hooks themselves are run as instance methods.
 283
 284 Hooks are run in the order they're added.
 285
 286 The return value of the hooks is discarded.
 287
 288 Hooks can be defined to run for all actions, for only specific actions
 289 or for all actions except a list of actions. Each entry is the action
 290 name, not the sub's name. Therefore in order to run a hook before one
 291 of the subs C<action_edit> or C<action_save> is called the following
 292 code can be used:
 293
 294   __PACKAGE__->run_before('things_to_do_before_edit_and_save', only => [ 'edit', 'save' ]);
 295
 296 =head1 FUNCTIONS
 297
 298 =head2 PUBLIC HELPER FUNCTIONS
 299
 300 These functions are supposed to be called by sub-classed controllers.
 301
 302 =over 4
 303
 304 =item C<render $template, [ $options, ] %locals>
 305
 306 Renders the template C<$template>. Provides other variables than
 307 C<Form::parse_html_template> does.
 308
 309 C<$options>, if present, must be a hash reference. All remaining
 310 parameters are slurped into C<%locals>.
 311
 312 What is rendered and how C<$template> is interpreted is determined by
 313 the options I<type>, I<inline>, I<partial> and I<no_layout>.
 314
 315 If C<< $options->{inline} >> is trueish then C<$template> is a string
 316 containing the template code to interprete. Additionally the output
 317 will not be sent to the browser. Instead it is only returned to the
 318 caller.
 319
 320 If C<< $options->{inline} >> is falsish then C<$template> is
 321 interpreted as the name of a template file. It is prefixed with
 322 "templates/webpages/" and postfixed with a file extension based on
 323 C<< $options->{type} >>. C<< $options->{type} >> can be either C<html>
 324 or C<js> and defaults to C<html>. An exception will be thrown if that
 325 file does not exist.
 326
 327 If C<< $options->{partial} >> or C<< $options->{inline} >> is trueish
 328 then neither the HTTP response header nor the standard HTML header is
 329 generated.
 330
 331 Otherwise at least the HTTP response header will be generated based on
 332 the template type (C<< $options->{type} >>).
 333
 334 If the template type is C<html> then the standard HTML header will be
 335 output via C<< $::form->header >> with C<< $::form->{title} >> set to
 336 C<$locals{title}> (the latter only if C<$locals{title}> is
 337 trueish). Setting C<< $options->{no_layout} >> to trueish will prevent
 338 this.
 339
 340 The template itself has access to the following variables:
 341
 342 =over 2
 343
 344 =item * C<AUTH> -- C<$::auth>
 345
 346 =item * C<FORM> -- C<$::form>
 347
 348 =item * C<LOCALE> -- C<$::locale>
 349
 350 =item * C<LXCONFIG> -- all parameters from C<config/lx_office.conf>
 351 with the same name they appear in the file (first level is the
 352 section, second the actual variable, e.g. C<system.dbcharset>,
 353 C<features.webdav> etc)
 354
 355 =item * C<LXDEBUG> -- C<$::lxdebug>
 356
 357 =item * C<MYCONFIG> -- C<%::myconfig>
 358
 359 =item * C<SELF> -- the controller instance
 360
 361 =item * All items from C<%locals>
 362
 363 =back
 364
 365 Unless C<< $options->{inline} >> is trueish the function will send the
 366 output to the browser.
 367
 368 The function will always return the output.
 369
 370 Example: Render a HTML template with a certain title and a few locals
 371
 372   $self->render('todo/list',
 373                 title      => 'List TODO items',
 374                 TODO_ITEMS => SL::DB::Manager::Todo->get_all_sorted);
 375
 376 Example: Render a string and return its content for further processing
 377 by the calling function. No header is generated due to C<inline>.
 378
 379   my $content = $self->render('[% USE JavaScript %][% JavaScript.replace_with("#someid", "js/something") %]',
 380                               { type => 'js', inline => 1 });
 381
 382 Example: Render a JavaScript template and send it to the
 383 browser. Typical use for actions called via AJAX:
 384
 385   $self->render('todo/single_item', { type => 'js' },
 386                 item => $employee->most_important_todo_item);
 387
 388 =item C<send_file $file_name, [%params]>
 389
 390 Sends the file C<$file_name> to the browser including appropriate HTTP
 391 headers for a download. C<%params> can include the following:
 392
 393 =over 2
 394
 395 =item * C<type> -- the file's content type; defaults to
 396 'application/octet_stream'
 397
 398 =item * C<name> -- the name presented to the browser; defaults to
 399 C<$file_name>
 400
 401 =back
 402
 403 =item C<url_for $url>
 404
 405 =item C<url_for $params>
 406
 407 =item C<url_for %params>
 408
 409 Creates an URL for the given parameters suitable for calling an action
 410 controller. If there's only one scalar parameter then it is returned
 411 verbatim.
 412
 413 Otherwise the parameters are given either as a single hash ref
 414 parameter or as a normal hash.
 415
 416 The controller to call is given by C<$params{controller}>. It defaults
 417 to the current controller as returned by
 418 L</_controller_name>.
 419
 420 The action to call is given by C<$params{action}>. It defaults to
 421 C<dispatch>.
 422
 423 All other key/value pairs in C<%params> are appended as GET parameters
 424 to the URL.
 425
 426 Usage from a template might look like this:
 427
 428   <a href="[% SELF.url_for(controller => 'Message', action => 'new', recipient_id => 42) %]">create new message</a>
 429
 430 =item C<redirect_to %url_params>
 431
 432 Redirects the browser to a new URL by outputting a HTTP redirect
 433 header. The URL is generated by calling L</url_for> with
 434 C<%url_params>.
 435
 436 =item C<run_before $sub, %params>
 437
 438 =item C<run_after $sub, %params>
 439
 440 Adds a hook to run before or after certain actions are run for the
 441 current package. The code to run is C<$sub> which is either the name
 442 of an instance method or a code reference. If it's the latter then the
 443 first parameter will be C<$self>.
 444
 445 C<%params> can contain two possible values that restrict the code to
 446 be run only for certain actions:
 447
 448 =over 2
 449
 450 =item C<< only => \@list >>
 451
 452 Only run the code for actions given in C<@list>. The entries are the
 453 action names, not the names of the sub (so it's C<list> instead of
 454 C<action_list>).
 455
 456 =item C<< except => \@list >>
 457
 458 Run the code for all actions but for those given in C<@list>. The
 459 entries are the action names, not the names of the sub (so it's
 460 C<list> instead of C<action_list>).
 461
 462 =back
 463
 464 If neither restriction is used then the code will be run for any
 465 action.
 466
 467 The hook's return values are discarded.
 468
 469 =back
 470
 471 =head2 PRIVATE FUNCTIONS
 472
 473 These functions are supposed to be used from this base class only.
 474
 475 =over 4
 476
 477 =item C<_controller_name>
 478
 479 Returns the name of the curernt controller package without the
 480 C<SL::Controller::> prefix.
 481
 482 =item C<_dispatch>
 483
 484 Implements the method lookup for indirect dispatching mentioned in the
 485 section L</INDIRECT DISPATCHING>.
 486
 487 =item C<_run_action $action>
 488
 489 Executes a sub based on the value of C<$action>. C<$action> is the sub
 490 name part of the C<action> GET or POST parameter as described in
 491 L</CONVENTIONS>.
 492
 493 If C<$action> equals C<dispatch> then the sub L</_dispatch> in this
 494 base class is called for L</INDIRECT DISPATCHING>. Otherwise
 495 C<$action> is prefixed with C<action_>, and that sub is called on the
 496 current controller instance.
 497
 498 =back
 499
 500 =head1 AUTHOR
 501
 502 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 503
 504 =cut