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