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