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