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