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