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