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 use SL::Request qw(flatten);
  11 use SL::MoreCommon qw(uri_encode);
  12 use SL::Presenter;
  13
  14 use Rose::Object::MakeMethods::Generic
  15 (
  16   scalar => [ qw(action_name) ],
  17 );
  18
  19 #
  20 # public/helper functions
  21 #
  22
  23 sub url_for {
  24   my $self = shift;
  25
  26   return $_[0] if (scalar(@_) == 1) && !ref($_[0]);
  27
  28   my %params      = ref($_[0]) eq 'HASH' ? %{ $_[0] } : @_;
  29   my $controller  = delete($params{controller}) || $self->controller_name;
  30   my $action      = $params{action}             || 'dispatch';
  31
  32   my $script;
  33   if ($controller =~ m/\.pl$/) {
  34     # Old-style controller
  35     $script = $controller;
  36   } else {
  37     $params{action} = "${controller}/${action}";
  38     $script         = "controller.pl";
  39   }
  40
  41   my $query       = join '&', map { uri_encode($_->[0]) . '=' . uri_encode($_->[1]) } @{ flatten(\%params) };
  42
  43   return "${script}?${query}";
  44 }
  45
  46 sub redirect_to {
  47   my $self = shift;
  48   my $url  = $self->url_for(@_);
  49
  50   if ($self->delay_flash_on_redirect) {
  51     require SL::Helper::Flash;
  52     SL::Helper::Flash::delay_flash();
  53   }
  54
  55   return $self->render(SL::ClientJS->new->redirect_to($self->url_for(@_))) if $::request->is_ajax;
  56
  57   print $::request->{cgi}->redirect($url);
  58 }
  59
  60 sub render {
  61   my $self               = shift;
  62   my $template           = shift;
  63   my ($options, %locals) = (@_ && ref($_[0])) ? @_ : ({ }, @_);
  64
  65   # Special handling/shortcut for an instance of SL::ClientJS:
  66   return $self->render(\$template->to_json, { type => 'json' }) if ref($template) eq 'SL::ClientJS';
  67
  68   # Set defaults for all available options.
  69   my %defaults = (
  70     type       => 'html',
  71     output     => 1,
  72     header     => 1,
  73     layout     => 1,
  74     process    => 1,
  75   );
  76   $options->{$_} //= $defaults{$_} for keys %defaults;
  77   $options->{type} = lc $options->{type};
  78
  79   # Check supplied options for validity.
  80   foreach (keys %{ $options }) {
  81     croak "Unsupported option: $_" unless $defaults{$_};
  82   }
  83
  84   # Only certain types are supported.
  85   croak "Unsupported type: " . $options->{type} unless $options->{type} =~ m/^(?:html|js|json|text)$/;
  86
  87   # The "template" argument must be a string or a reference to one.
  88   $template = ${ $template }                                       if ((ref($template) || '') eq 'REF') && (ref(${ $template }) eq 'SL::Presenter::EscapedText');
  89   croak "Unsupported 'template' reference type: " . ref($template) if ref($template) && (ref($template) !~ m/^(?:SCALAR|SL::Presenter::EscapedText)$/);
  90
  91   # If all output is turned off then don't output the header either.
  92   if (!$options->{output}) {
  93     $options->{header} = 0;
  94     $options->{layout} = 0;
  95
  96   } else {
  97     # Layout only makes sense if we're outputting HTML.
  98     $options->{layout} = 0 if $options->{type} ne 'html';
  99   }
 100
 101   if ($options->{header}) {
 102     # Output the HTTP response and the layout in case of HTML output.
 103
 104     if ($options->{layout}) {
 105       $::form->{title} = $locals{title} if $locals{title};
 106       $::form->header;
 107
 108     } else {
 109       # No layout: just the standard HTTP response. Also notify
 110       # $::form that the header has already been output so that
 111       # $::form->header() won't output it again.
 112       $::form->{header} = 1;
 113       my $content_type  = $options->{type} eq 'html' ? 'text/html'
 114                         : $options->{type} eq 'js'   ? 'text/javascript'
 115                         : $options->{type} eq 'text' ? 'text/plain'
 116                         :                              'application/json';
 117
 118       print $::form->create_http_response(content_type => $content_type,
 119                                           charset      => 'UTF-8');
 120     }
 121   }
 122
 123   # Let the presenter do the rest of the work.
 124   my $output = $self->presenter->render(
 125     $template,
 126     { type => $options->{type}, process => $options->{process} },
 127     %locals,
 128     SELF => $self,
 129   );
 130
 131   # Print the output if wanted.
 132   print $output if $options->{output};
 133
 134   return $output;
 135 }
 136
 137 sub send_file {
 138   my ($self, $file_name, %params) = @_;
 139
 140   my $file            = IO::File->new($file_name, 'r') || croak("Cannot open file '${file_name}'");
 141   my $content_type    =  $params{type} || 'application/octet_stream';
 142   my $attachment_name =  $params{name} || $file_name;
 143   $attachment_name    =~ s:.*//::g;
 144
 145   print $::form->create_http_response(content_type        => $content_type,
 146                                       content_disposition => 'attachment; filename="' . $attachment_name . '"',
 147                                       content_length      => -s $file);
 148
 149   $::locale->with_raw_io(\*STDOUT, sub { print while <$file> });
 150   $file->close;
 151 }
 152
 153 sub presenter {
 154   return SL::Presenter->get;
 155 }
 156
 157 sub controller_name {
 158   my $class = ref($_[0]) || $_[0];
 159   $class    =~ s/^SL::Controller:://;
 160   return $class;
 161 }
 162
 163 #
 164 # Before/after run hooks
 165 #
 166
 167 sub run_before {
 168   _add_hook('before', @_);
 169 }
 170
 171 sub run_after {
 172   _add_hook('after', @_);
 173 }
 174
 175 my %hooks;
 176
 177 sub _add_hook {
 178   my ($when, $class, $sub, %params) = @_;
 179
 180   foreach my $key (qw(only except)) {
 181     $params{$key} = { map { ( $_ => 1 ) } @{ $params{$key} } } if $params{$key};
 182   }
 183
 184   my $idx = "${when}/${class}";
 185   $hooks{$idx} ||= [ ];
 186   push @{ $hooks{$idx} }, { %params, code => $sub };
 187 }
 188
 189 sub _run_hooks {
 190   my ($self, $when, $action) = @_;
 191
 192   my $idx = "${when}/" . ref($self);
 193
 194   foreach my $hook (@{ $hooks{$idx} || [] }) {
 195     next if ($hook->{only  } && !$hook->{only  }->{$action})
 196          || ($hook->{except} &&  $hook->{except}->{$action});
 197
 198     if (ref($hook->{code}) eq 'CODE') {
 199       $hook->{code}->($self, $action);
 200     } else {
 201       my $sub = $hook->{code};
 202       $self->$sub($action);
 203     }
 204   }
 205 }
 206
 207 #
 208 #  behaviour. override these
 209 #
 210
 211 sub delay_flash_on_redirect {
 212   0;
 213 }
 214
 215 sub get_auth_level {
 216   # Ignore the 'action' parameter.
 217   return 'user';
 218 }
 219
 220 sub keep_auth_vars_in_form {
 221   return 0;
 222 }
 223
 224 #
 225 # private functions -- for use in Base only
 226 #
 227
 228 sub _run_action {
 229   my $self   = shift;
 230   my $action = shift;
 231   my $sub    = "action_${action}";
 232
 233   return $self->_dispatch(@_) if $action eq 'dispatch';
 234
 235   $::form->error("Invalid action '${action}' for controller " . ref($self)) if !$self->can($sub);
 236
 237   $self->action_name($action);
 238   $self->_run_hooks('before', $action);
 239   $self->$sub(@_);
 240   $self->_run_hooks('after', $action);
 241 }
 242
 243 sub _dispatch {
 244   my $self    = shift;
 245
 246   no strict 'refs';
 247   my @actions = map { s/^action_//; $_ } grep { m/^action_/ } keys %{ ref($self) . "::" };
 248   my $action  = first { $::form->{"action_${_}"} } @actions;
 249   my $sub     = "action_${action}";
 250
 251   if ($self->can($sub)) {
 252     $self->action_name($action);
 253     $self->_run_hooks('before', $action);
 254     $self->$sub(@_);
 255     $self->_run_hooks('after', $action);
 256   } else {
 257     $::form->error($::locale->text('Oops. No valid action found to dispatch. Please report this case to the kivitendo team.'));
 258   }
 259 }
 260
 261 1;
 262
 263 __END__
 264
 265 =head1 NAME
 266
 267 SL::Controller::Base - base class for all action controllers
 268
 269 =head1 SYNOPSIS
 270
 271 =head2 OVERVIEW
 272
 273 This is a base class for all action controllers. Action controllers
 274 provide subs that are callable by special URLs.
 275
 276 For each request made to the web server an instance of the controller
 277 will be created. After the request has been served that instance will
 278 handed over to garbage collection.
 279
 280 This base class is derived from L<Rose::Object>.
 281
 282 =head2 CONVENTIONS
 283
 284 The URLs have the following properties:
 285
 286 =over 2
 287
 288 =item *
 289
 290 The script part of the URL must be C<controller.pl>.
 291
 292 =item *
 293
 294 There must be a GET or POST parameter named C<action> containing the
 295 name of the controller and the sub to call separated by C</>,
 296 e.g. C<Message/list>.
 297
 298 =item *
 299
 300 The controller name is the package's name without the
 301 C<SL::Controller::> prefix. At the moment only packages in the
 302 C<SL::Controller> namespace are valid; sub-namespaces are not
 303 allowed. The package name must start with an upper-case letter.
 304
 305 =item *
 306
 307 The sub part of the C<action> parameter is the name of the sub to
 308 call. However, the sub's name is automatically prefixed with
 309 C<action_>. Therefore for the example C<Message/list> the sub
 310 C<SL::DB::Message::action_list> would be called. This in turn means
 311 that subs whose name does not start with C<action_> cannot be invoked
 312 directly via the URL.
 313
 314 =back
 315
 316 =head2 INDIRECT DISPATCHING
 317
 318 In the case that there are several submit buttons on a page it is
 319 often impractical to have a single C<action> parameter match up
 320 properly. For such a case a special dispatcher method is available. In
 321 that case the C<action> parameter of the URL must be
 322 C<Controller/dispatch>.
 323
 324 The C<SL::Controller::Base::_dispatch> method will iterate over all
 325 subs in the controller package whose names start with C<action_>. The
 326 first one for which there's a GET or POST parameter with the same name
 327 and that's trueish is called.
 328
 329 Usage from a template usually looks like this:
 330
 331   <form method="POST" action="controller.pl">
 332     ...
 333     <input type="hidden" name="action" value="Message/dispatch">
 334     <input type="submit" name="action_mark_as_read" value="Mark messages as read">
 335     <input type="submit" name="action_delete" value="Delete messages">
 336   </form>
 337
 338 The dispatching is handled by the function L</_dispatch>.
 339
 340 =head2 HOOKS
 341
 342 Hooks are functions that are called before or after the controller's
 343 action is called. The controller package defines the hooks, and those
 344 hooks themselves are run as instance methods.
 345
 346 Hooks are run in the order they're added.
 347
 348 The hooks receive a single parameter: the name of the action that is
 349 about to be called (for C<before> hooks) / was called (for C<after>
 350 hooks).
 351
 352 The return value of the hooks is discarded.
 353
 354 Hooks can be defined to run for all actions, for only specific actions
 355 or for all actions except a list of actions. Each entry is the action
 356 name, not the sub's name. Therefore in order to run a hook before one
 357 of the subs C<action_edit> or C<action_save> is called the following
 358 code can be used:
 359
 360   __PACKAGE__->run_before('things_to_do_before_edit_and_save', only => [ 'edit', 'save' ]);
 361
 362 =head1 FUNCTIONS
 363
 364 =head2 PUBLIC HELPER FUNCTIONS
 365
 366 These functions are supposed to be called by sub-classed controllers.
 367
 368 =over 4
 369
 370 =item C<render $template, [ $options, ] %locals>
 371
 372 Renders the template C<$template>. Provides other variables than
 373 C<Form::parse_html_template> does.
 374
 375 C<$options>, if present, must be a hash reference. All remaining
 376 parameters are slurped into C<%locals>.
 377
 378 What is rendered and how C<$template> is interpreted is determined
 379 both by C<$template>'s reference type and by the supplied options. The
 380 actual rendering is handled by L<SL::Presenter/render>.
 381
 382 If C<$template> is a normal scalar (not a reference) then it is meant
 383 to be a template file name relative to the C<templates/webpages>
 384 directory. The file name to use is determined by the C<type> option.
 385
 386 If C<$template> is a reference to a scalar then the referenced
 387 scalar's content is used as the content to process. The C<type> option
 388 is not considered in this case.
 389
 390 C<$template> can also be an instance of L<SL::Presenter::EscapedText>
 391 or a reference to such an instance. Both of these cases are handled
 392 the same way as if C<$template> were a reference to a scalar: its
 393 content is processed, and C<type> is not considered.
 394
 395 Other reference types, unknown options and unknown arguments to the
 396 C<type> option cause the function to L<croak>.
 397
 398 The following options are available (defaults: C<type> = 'html',
 399 C<process> = 1, C<output> = 1, C<header> = 1, C<layout> = 1):
 400
 401 =over 2
 402
 403 =item C<type>
 404
 405 The template type. Can be C<html> (the default), C<js> for JavaScript,
 406 C<json> for JSON and C<text> for plain text content. Affects the
 407 extension that's added to the file name given with a non-reference
 408 C<$template> argument, the content type HTTP header that is output and
 409 whether or not the layout will be output as well (see description of
 410 C<layout> below).
 411
 412 =item C<process>
 413
 414 If trueish (which is also the default) it causes the template/content
 415 to be processed by the Template toolkit. Otherwise the
 416 template/content is output as-is.
 417
 418 =item C<output>
 419
 420 If trueish (the default) then the generated output will be sent to the
 421 browser in addition to being returned. If falsish then the options
 422 C<header> and C<layout> are set to 0 as well.
 423
 424 =item C<header>
 425
 426 Determines whether or not to output the HTTP response
 427 headers. Defaults to the same value that C<output> is set to. If set
 428 to falsish then the layout is not output either.
 429
 430 =item C<layout>
 431
 432 Determines whether or not the basic HTML layout structure should be
 433 output (HTML header, common JavaScript and stylesheet inclusions, menu
 434 etc.). Defaults to 0 if C<type> is not C<html> and to the same value
 435 C<header> is set to otherwise.
 436
 437 =back
 438
 439 The template itself has access to several variables. These are listed
 440 in the documentation to L<SL::Presenter/render>.
 441
 442 The function will always return the output.
 443
 444 Example: Render a HTML template with a certain title and a few locals
 445
 446   $self->render('todo/list',
 447                 title      => 'List TODO items',
 448                 TODO_ITEMS => SL::DB::Manager::Todo->get_all_sorted);
 449
 450 Example: Render a string and return its content for further processing
 451 by the calling function. No header is generated due to C<output>.
 452
 453   my $content = $self->render(\'[% USE JavaScript %][% JavaScript.replace_with("#someid", "js/something") %]',
 454                               { output => 0 });
 455
 456 Example: Render a JavaScript template
 457 "templates/webpages/todo/single_item.js" and send it to the
 458 browser. Typical use for actions called via AJAX:
 459
 460   $self->render('todo/single_item', { type => 'js' },
 461                 item => $employee->most_important_todo_item);
 462
 463 =item C<send_file $file_name, [%params]>
 464
 465 Sends the file C<$file_name> to the browser including appropriate HTTP
 466 headers for a download. C<%params> can include the following:
 467
 468 =over 2
 469
 470 =item * C<type> -- the file's content type; defaults to
 471 'application/octet_stream'
 472
 473 =item * C<name> -- the name presented to the browser; defaults to
 474 C<$file_name>
 475
 476 =back
 477
 478 =item C<url_for $url>
 479
 480 =item C<url_for $params>
 481
 482 =item C<url_for %params>
 483
 484 Creates an URL for the given parameters suitable for calling an action
 485 controller. If there's only one scalar parameter then it is returned
 486 verbatim.
 487
 488 Otherwise the parameters are given either as a single hash ref
 489 parameter or as a normal hash.
 490
 491 The controller to call is given by C<$params{controller}>. It defaults
 492 to the current controller as returned by
 493 L</controller_name>.
 494
 495 The action to call is given by C<$params{action}>. It defaults to
 496 C<dispatch>.
 497
 498 All other key/value pairs in C<%params> are appended as GET parameters
 499 to the URL.
 500
 501 Usage from a template might look like this:
 502
 503   <a href="[% SELF.url_for(controller => 'Message', action => 'new', recipient_id => 42) %]">create new message</a>
 504
 505 =item C<redirect_to %url_params>
 506
 507 Redirects the browser to a new URL. The URL is generated by calling
 508 L</url_for> with C<%url_params>.
 509
 510 This function implements the redirection depending on whether or not
 511 the current request is an AJAX request as determined by
 512 L<SL::Request/is_ajax>. If it is a normal request then it outputs a
 513 standard HTTP redirect header (HTTP code 302). If it is an AJAX
 514 request then it outputs an AJAX response suitable for the
 515 C<kivi.eval_json_result> function from the L<SL::ClientJS> module.
 516
 517 =item C<run_before $sub, %params>
 518
 519 =item C<run_after $sub, %params>
 520
 521 Adds a hook to run before or after certain actions are run for the
 522 current package. The code to run is C<$sub> which is either the name
 523 of an instance method or a code reference. If it's the latter then the
 524 first parameter will be C<$self>.
 525
 526 C<%params> can contain two possible values that restrict the code to
 527 be run only for certain actions:
 528
 529 =over 2
 530
 531 =item C<< only => \@list >>
 532
 533 Only run the code for actions given in C<@list>. The entries are the
 534 action names, not the names of the sub (so it's C<list> instead of
 535 C<action_list>).
 536
 537 =item C<< except => \@list >>
 538
 539 Run the code for all actions but for those given in C<@list>. The
 540 entries are the action names, not the names of the sub (so it's
 541 C<list> instead of C<action_list>).
 542
 543 =back
 544
 545 If neither restriction is used then the code will be run for any
 546 action.
 547
 548 The hook's return values are discarded.
 549
 550 =item C<delay_flash_on_redirect>
 551
 552 May be overridden by a controller. If this method returns true, redirect_to
 553 will delay all flash messages for the current request. Defaults to false for
 554 compatibility reasons.
 555
 556 =item C<get_auth_level $action>
 557
 558 May be overridden by a controller. Determines what kind of
 559 authentication is required for a particular action. Must return either
 560 C<admin> (which means that authentication as an admin is required),
 561 C<user> (authentication as a normal user suffices) with a possible
 562 future value C<none> (which would require no authentication but is not
 563 yet implemented).
 564
 565 =item C<keep_auth_vars_in_form %params>
 566
 567 May be overridden by a controller. If falsish (the default) all form
 568 variables whose name starts with C<{AUTH}> are removed before the
 569 request is routed. Only controllers that handle login requests
 570 themselves should return trueish for this function.
 571
 572 C<$params{action}> contains the action name that the request will be
 573 dispatched to.
 574
 575 =item C<controller_name>
 576
 577 Returns the name of the curernt controller package without the
 578 C<SL::Controller::> prefix. This method can be called both as a class
 579 method and an instance method.
 580
 581 =item C<action_name>
 582
 583 Returns the name of the currently executing action. If the dispatcher
 584 mechanism was used then this is not C<dispatch> but the actual method
 585 name the dispatching resolved to.
 586
 587 =item C<presenter>
 588
 589 Returns the global presenter object by calling
 590 L<SL::Presenter/get>.
 591
 592 =back
 593
 594 =head2 PRIVATE FUNCTIONS
 595
 596 These functions are supposed to be used from this base class only.
 597
 598 =over 4
 599
 600 =item C<_dispatch>
 601
 602 Implements the method lookup for indirect dispatching mentioned in the
 603 section L</INDIRECT DISPATCHING>.
 604
 605 =item C<_run_action $action>
 606
 607 Executes a sub based on the value of C<$action>. C<$action> is the sub
 608 name part of the C<action> GET or POST parameter as described in
 609 L</CONVENTIONS>.
 610
 611 If C<$action> equals C<dispatch> then the sub L</_dispatch> in this
 612 base class is called for L</INDIRECT DISPATCHING>. Otherwise
 613 C<$action> is prefixed with C<action_>, and that sub is called on the
 614 current controller instance.
 615
 616 =back
 617
 618 =head1 AUTHOR
 619
 620 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 621
 622 =cut