SL/Presenter/Tag.pm

   1 package SL::Presenter::Tag;
   2
   3 use strict;
   4
   5 use SL::HTML::Restrict;
   6 use SL::Presenter::EscapedText qw(escape);
   7 use Scalar::Util qw(blessed);
   8
   9 use Exporter qw(import);
  10 our @EXPORT_OK = qw(
  11   html_tag input_tag hidden_tag javascript man_days_tag name_to_id select_tag
  12   checkbox_tag button_tag submit_tag ajax_submit_tag input_number_tag
  13   stringify_attributes restricted_html textarea_tag link_tag date_tag
  14 );
  15 our %EXPORT_TAGS = (ALL => \@EXPORT_OK);
  16
  17 use Carp;
  18
  19 my %_valueless_attributes = map { $_ => 1 } qw(
  20   checked compact declare defer disabled ismap multiple noresize noshade nowrap
  21   readonly selected hidden
  22 );
  23
  24 my %_singleton_tags = map { $_ => 1 } qw(
  25   area base br col command embed hr img input keygen link meta param source
  26   track wbr
  27 );
  28
  29 sub _call_on {
  30   my ($object, $method, @params) = @_;
  31   return $object->$method(@params);
  32 }
  33
  34 { # This will give you an id for identifying html tags and such.
  35   # It's guaranteed to be unique unless you exceed 10 mio calls per request.
  36   # Do not use these id's to store information across requests.
  37 my $_id_sequence = int rand 1e7;
  38 sub _id {
  39   return ( $_id_sequence = ($_id_sequence + 1) % 1e7 );
  40 }
  41 }
  42
  43 sub _J {
  44   my $string = shift;
  45   $string    =~ s/(\"|\'|\\)/\\$1/g;
  46   return $string;
  47 }
  48
  49 sub stringify_attributes {
  50   my (%params) = @_;
  51
  52   my @result = ();
  53   while (my ($name, $value) = each %params) {
  54     next unless $name;
  55     next if $_valueless_attributes{$name} && !$value;
  56     $value = '' if !defined($value);
  57     push @result, $_valueless_attributes{$name} ? escape($name) : escape($name) . '="' . escape($value) . '"';
  58   }
  59
  60   return @result ? ' ' . join(' ', @result) : '';
  61 }
  62
  63 sub html_tag {
  64   my ($tag, $content, %params) = @_;
  65   my $attributes = stringify_attributes(%params);
  66
  67   return "<${tag}${attributes}>" if !defined($content) && $_singleton_tags{$tag};
  68   return "<${tag}${attributes}>${content}</${tag}>";
  69 }
  70
  71 sub input_tag {
  72   my ($name, $value, %attributes) = @_;
  73
  74   _set_id_attribute(\%attributes, $name);
  75   $attributes{type} ||= 'text';
  76
  77   html_tag('input', undef, %attributes, name => $name, value => $value);
  78 }
  79
  80 sub hidden_tag {
  81   my ($name, $value, %attributes) = @_;
  82   input_tag($name, $value, %attributes, type => 'hidden');
  83 }
  84
  85 sub man_days_tag {
  86   my ($name, $object, %attributes) = @_;
  87
  88   my $size           =  delete($attributes{size})   || 5;
  89   my $method         =  $name;
  90   $method            =~ s/^.*\.//;
  91
  92   my $time_selection = input_tag("${name}_as_man_days_string", _call_on($object, "${method}_as_man_days_string"), %attributes, size => $size);
  93   my $unit_selection = select_tag("${name}_as_man_days_unit",   [[ 'h', $::locale->text('h') ], [ 'man_day', $::locale->text('MD') ]],
  94                                           %attributes, default => _call_on($object, "${method}_as_man_days_unit"));
  95
  96   return $time_selection . $unit_selection;
  97 }
  98
  99 sub name_to_id {
 100   my ($name) = @_;
 101
 102   $name =~ s/\[\+?\]/ _id() /ge; # give constructs with [] or [+] unique ids
 103   $name =~ s/[^\w_]/_/g;
 104   $name =~ s/_+/_/g;
 105
 106   return $name;
 107 }
 108
 109 sub select_tag {
 110   my ($name, $collection, %attributes) = @_;
 111
 112   _set_id_attribute(\%attributes, $name);
 113
 114   my $value_key       = delete($attributes{value_key})   || 'id';
 115   my $title_key       = delete($attributes{title_key})   || $value_key;
 116   my $default_key     = delete($attributes{default_key}) || 'selected';
 117   my $default_val_key = delete($attributes{default_value_key});
 118   my $default_coll    = delete($attributes{default});
 119
 120   my $value_title_sub = delete($attributes{value_title_sub});
 121
 122   my $value_sub       = delete($attributes{value_sub});
 123   my $title_sub       = delete($attributes{title_sub});
 124   my $default_sub     = delete($attributes{default_sub});
 125
 126   my $with_empty      = delete($attributes{with_empty});
 127   my $empty_title     = delete($attributes{empty_title});
 128
 129   my $with_optgroups  = delete($attributes{with_optgroups});
 130
 131   undef $default_key if $default_sub || $default_val_key;
 132
 133   my $normalize_entry = sub {
 134     my ($type, $entry, $sub, $key) = @_;
 135
 136     return $sub->($entry) if $sub;
 137
 138     my $ref = ref($entry);
 139
 140     if ( !$ref ) {
 141       return $entry if $type eq 'value' || $type eq 'title';
 142       return 0;
 143     }
 144
 145     if ( $ref eq 'ARRAY' ) {
 146       return $entry->[ $type eq 'value' ? 0 : $type eq 'title' ? 1 : 2 ];
 147     }
 148
 149     return $entry->{$key} if $ref  eq 'HASH';
 150     return $entry->$key   if $type ne 'default' || $entry->can($key);
 151     return undef;
 152   };
 153
 154   my %selected;
 155   if (defined($default_coll) && !ref $default_coll) {
 156     %selected = ($default_coll => 1);
 157
 158   } elsif (ref($default_coll) eq 'HASH') {
 159     %selected = %{ $default_coll };
 160
 161   } elsif ($default_coll) {
 162     $default_coll = [ $default_coll ] unless 'ARRAY' eq ref $default_coll;
 163
 164     %selected = $default_val_key ? map({ ($normalize_entry->('value', $_, undef, $default_val_key) => 1) } @{ $default_coll })
 165               :                    map({ ($_                                                       => 1) } @{ $default_coll });
 166   }
 167
 168   my $list_to_code = sub {
 169     my ($sub_collection) = @_;
 170
 171     if ('ARRAY' ne ref $sub_collection) {
 172       $sub_collection = [ $sub_collection ];
 173     }
 174
 175     my @options;
 176     foreach my $entry ( @{ $sub_collection } ) {
 177       my $value;
 178       my $title;
 179
 180       if ( $value_title_sub ) {
 181         ($value, $title) = @{ $value_title_sub->($entry) };
 182       } else {
 183
 184         $value = $normalize_entry->('value', $entry, $value_sub, $value_key);
 185         $title = $normalize_entry->('title', $entry, $title_sub, $title_key);
 186       }
 187
 188       my $default = $default_key ? $normalize_entry->('default', $entry, $default_sub, $default_key) : 0;
 189
 190       push(@options, [$value, $title, $selected{$value} || $default]);
 191     }
 192
 193     return join '', map { html_tag('option', escape($_->[1]), value => $_->[0], selected => $_->[2]) } @options;
 194   };
 195
 196   my $code  = '';
 197   $code    .= html_tag('option', escape($empty_title || ''), value => '') if $with_empty;
 198
 199   if (!$with_optgroups) {
 200     $code .= $list_to_code->($collection);
 201
 202   } else {
 203     $code .= join '', map {
 204       my ($optgroup_title, $sub_collection) = @{ $_ };
 205       html_tag('optgroup', $list_to_code->($sub_collection), label => $optgroup_title)
 206     } @{ $collection };
 207   }
 208
 209   html_tag('select', $code, %attributes, name => $name);
 210 }
 211
 212 sub checkbox_tag {
 213   my ($name, %attributes) = @_;
 214
 215   _set_id_attribute(\%attributes, $name);
 216
 217   $attributes{value}   = 1 unless defined $attributes{value};
 218   my $label            = delete $attributes{label};
 219   my $checkall         = delete $attributes{checkall};
 220   my $for_submit       = delete $attributes{for_submit};
 221
 222   if ($attributes{checked}) {
 223     $attributes{checked} = 'checked';
 224   } else {
 225     delete $attributes{checked};
 226   }
 227
 228   my $code  = '';
 229   $code    .= hidden_tag($name, 0, %attributes, id => $attributes{id} . '_hidden') if $for_submit;
 230   $code    .= html_tag('input', undef,  %attributes, name => $name, type => 'checkbox');
 231   $code    .= html_tag('label', $label, for => $attributes{id}) if $label;
 232   $code    .= javascript(qq|\$('#$attributes{id}').checkall('$checkall');|) if $checkall;
 233
 234   return $code;
 235 }
 236
 237 sub button_tag {
 238   my ($onclick, $value, %attributes) = @_;
 239
 240   _set_id_attribute(\%attributes, $attributes{name}) if $attributes{name};
 241   $attributes{type} ||= 'button';
 242
 243   $onclick = 'if (!confirm("'. _J(delete($attributes{confirm})) .'")) return false; ' . $onclick if $attributes{confirm};
 244
 245   html_tag('input', undef, %attributes, value => $value, onclick => $onclick);
 246 }
 247
 248 sub submit_tag {
 249   my ($name, $value, %attributes) = @_;
 250
 251   _set_id_attribute(\%attributes, $attributes{name}) if $attributes{name};
 252
 253   if ( $attributes{confirm} ) {
 254     $attributes{onclick} = 'return confirm("'. _J(delete($attributes{confirm})) .'");';
 255   }
 256
 257   input_tag($name, $value, %attributes, type => 'submit', class => 'submit');
 258 }
 259
 260 sub ajax_submit_tag {
 261   my ($url, $form_selector, $text, %attributes) = @_;
 262
 263   $url           = _J($url);
 264   $form_selector = _J($form_selector);
 265   my $onclick    = qq|kivi.submit_ajax_form('${url}', '${form_selector}')|;
 266
 267   button_tag($onclick, $text, %attributes);
 268 }
 269
 270 sub input_number_tag {
 271   my ($name, $value, %params) = @_;
 272
 273   _set_id_attribute(\%params, $name);
 274   my @onchange = $params{onchange} ? (onChange => delete $params{onchange}) : ();
 275   my @classes  = ('numeric');
 276   push @classes, delete($params{class}) if $params{class};
 277   my %class    = @classes ? (class => join(' ', @classes)) : ();
 278
 279   $::request->layout->add_javascripts('kivi.Validator.js');
 280   $::request->presenter->need_reinit_widgets($params{id});
 281
 282   input_tag(
 283     $name, $::form->format_amount(\%::myconfig, $value, $params{precision}),
 284     "data-validate" => "number",
 285     %params,
 286     %class, @onchange,
 287   );
 288 }
 289
 290
 291 sub javascript {
 292   my ($data) = @_;
 293   html_tag('script', $data, type => 'text/javascript');
 294 }
 295
 296 sub _set_id_attribute {
 297   my ($attributes, $name, $unique) = @_;
 298
 299   if (!delete($attributes->{no_id}) && !$attributes->{id}) {
 300     $attributes->{id}  = name_to_id($name);
 301     $attributes->{id} .= '_' . $attributes->{value} if $unique;
 302   }
 303
 304   %{ $attributes };
 305 }
 306
 307 my $html_restricter;
 308
 309 sub restricted_html {
 310   my ($value) = @_;
 311
 312   $html_restricter ||= SL::HTML::Restrict->create;
 313   return $html_restricter->process($value);
 314 }
 315
 316 sub textarea_tag {
 317   my ($name, $content, %attributes) = @_;
 318
 319   _set_id_attribute(\%attributes, $name);
 320   $attributes{rows}  *= 1; # required by standard
 321   $attributes{cols}  *= 1; # required by standard
 322
 323   html_tag('textarea', $content, %attributes, name => $name);
 324 }
 325
 326 sub link_tag {
 327   my ($href, $content, %params) = @_;
 328
 329   $href ||= '#';
 330
 331   html_tag('a', $content, %params, href => $href);
 332 }
 333 # alias for compatibility
 334 sub link { goto &link_tag }
 335
 336 sub date_tag {
 337   my ($name, $value, %params) = @_;
 338
 339   _set_id_attribute(\%params, $name);
 340   my @onchange = $params{onchange} ? (onChange => delete $params{onchange}) : ();
 341   my @classes  = $params{no_cal} || $params{readonly} ? () : ('datepicker');
 342   push @classes, delete($params{class}) if $params{class};
 343   my %class    = @classes ? (class => join(' ', @classes)) : ();
 344
 345   $::request->layout->add_javascripts('kivi.Validator.js');
 346   $::request->presenter->need_reinit_widgets($params{id});
 347
 348   input_tag(
 349     $name, blessed($value) ? $value->to_lxoffice : $value,
 350     size   => 11,
 351     "data-validate" => "date",
 352     %params,
 353     %class, @onchange,
 354   );
 355 }
 356
 357 1;
 358 __END__
 359
 360 =pod
 361
 362 =encoding utf8
 363
 364 =head1 NAME
 365
 366 SL::Presenter::Tag - Layouting / tag generation
 367
 368 =head1 SYNOPSIS
 369
 370 Usage in a template:
 371
 372   [% USE P %]
 373
 374   [% P.select_tag('direction', [ [ 'left', 'To the left' ], [ 'right', 'To the right', 1 ] ]) %]
 375
 376   [% P.select_tag('direction', [ { direction => 'left',  display => 'To the left'  },
 377                                  { direction => 'right', display => 'To the right' } ],
 378                                value_key => 'direction', title_key => 'display', default => 'right') %]
 379
 380   [% P.select_tag('direction', [ { direction => 'left',  display => 'To the left'  },
 381                                  { direction => 'right', display => 'To the right', selected => 1 } ],
 382                                value_key => 'direction', title_key => 'display') %]
 383
 384   # Use an RDBO object and its n:m relationship as the default
 385   # values. For example, a user can be a member of many groups. "All
 386   # groups" is therefore the full collection and "$user->groups" is a
 387   # list of RDBO AuthGroup objects whose IDs must match the ones in
 388   # "All groups". This could look like the following:
 389   [% P.select_tag('user.groups[]', SELF.all_groups, multiple=1,
 390                   default=SELF.user.groups, default_value_key='id' ) %]
 391
 392 =head1 DESCRIPTION
 393
 394 A module modeled a bit after Rails' ActionView helpers. Several small
 395 functions that create HTML tags from various kinds of data sources.
 396
 397 The C<id> attribute is usually calculated automatically. This can be
 398 overridden by either specifying an C<id> attribute or by setting
 399 C<no_id> to trueish.
 400
 401 =head1 FUNCTIONS
 402
 403 =head2 LOW-LEVEL FUNCTIONS
 404
 405 =over 4
 406
 407 =item C<html_tag $tag_name, $content_string, %attributes>
 408
 409 Creates an opening and closing HTML tag for C<$tag_name> and puts
 410 C<$content_string> between the two. If C<$content_string> is undefined
 411 or empty then only a E<lt>tag/E<gt> tag will be created. Attributes
 412 are key/value pairs added to the opening tag.
 413
 414 C<$content_string> is not HTML escaped.
 415
 416 =item C<name_to_id $name>
 417
 418 Converts a name to a HTML id by replacing various characters.
 419
 420 =item C<stringify_attributes %items>
 421
 422 Creates a string from all elements in C<%items> suitable for usage as
 423 HTML tag attributes. Keys and values are HTML escaped even though keys
 424 must not contain non-ASCII characters for browsers to accept them.
 425
 426 =item C<restricted_html $html>
 427
 428 Returns HTML stripped of unknown tags. See L<SL::HTML::Restrict>.
 429
 430 =back
 431
 432 =head2 HIGH-LEVEL FUNCTIONS
 433
 434 =over 4
 435
 436 =item C<input_tag $name, $value, %attributes>
 437
 438 Creates a HTML 'input type=text' tag named C<$name> with the value
 439 C<$value> and with arbitrary HTML attributes from C<%attributes>. The
 440 tag's C<id> defaults to C<name_to_id($name)>.
 441
 442 =item C<submit_tag $name, $value, %attributes>
 443
 444 Creates a HTML 'input type=submit class=submit' tag named C<$name> with the
 445 value C<$value> and with arbitrary HTML attributes from C<%attributes>. The
 446 tag's C<id> defaults to C<name_to_id($name)>.
 447
 448 If C<$attributes{confirm}> is set then a JavaScript popup dialog will
 449 be added via the C<onclick> handler asking the question given with
 450 C<$attributes{confirm}>. The request is only submitted if the user
 451 clicks the dialog's ok/yes button.
 452
 453 =item C<ajax_submit_tag $url, $form_selector, $text, %attributes>
 454
 455 Creates a HTML 'input type="button"' tag with a very specific onclick
 456 handler that submits the form given by the jQuery selector
 457 C<$form_selector> to the URL C<$url> (the actual JavaScript function
 458 called for that is C<kivi.submit_ajax_form()> in
 459 C<js/client_js.js>). The button's label will be C<$text>.
 460
 461 =item C<button_tag $onclick, $text, %attributes>
 462
 463 Creates a HTML 'input type="button"' tag with an onclick handler
 464 C<$onclick> and a value of C<$text>. The button does not have a name
 465 nor an ID by default.
 466
 467 If C<$attributes{confirm}> is set then a JavaScript popup dialog will
 468 be prepended to the C<$onclick> handler asking the question given with
 469 C<$attributes{confirm}>. The request is only submitted if the user
 470 clicks the dialog's "ok/yes" button.
 471
 472 =item C<man_days_tag $name, $object, %attributes>
 473
 474 Creates two HTML inputs: a text input for entering a number and a drop
 475 down box for chosing the unit (either 'man days' or 'hours').
 476
 477 C<$object> must be a L<Rose::DB::Object> instance using the
 478 L<SL::DB::Helper::AttrDuration> helper.
 479
 480 C<$name> is supposed to be the name of the underlying column,
 481 e.g. C<time_estimation> for an instance of
 482 C<SL::DB::RequirementSpecItem>. If C<$name> has the form
 483 C<prefix.method> then the full C<$name> is used for the input's base
 484 names while the methods called on C<$object> are only the suffix. This
 485 makes it possible to write statements like e.g.
 486
 487   [% P.man_days_tag("requirement_spec_item.time_estimation", SELF.item) %]
 488
 489 The attribute C<size> can be used to set the text input's size. It
 490 defaults to 5.
 491
 492 =item C<hidden_tag $name, $value, %attributes>
 493
 494 Creates a HTML 'input type=hidden' tag named C<$name> with the value
 495 C<$value> and with arbitrary HTML attributes from C<%attributes>. The
 496 tag's C<id> defaults to C<name_to_id($name)>.
 497
 498 =item C<checkbox_tag $name, %attributes>
 499
 500 Creates a HTML 'input type=checkbox' tag named C<$name> with arbitrary
 501 HTML attributes from C<%attributes>. The tag's C<id> defaults to
 502 C<name_to_id($name)>. The tag's C<value> defaults to C<1>.
 503
 504 If C<%attributes> contains a key C<label> then a HTML 'label' tag is
 505 created with said C<label>. No attribute named C<label> is created in
 506 that case.
 507
 508 If C<%attributes> contains a key C<checkall> then the value is taken as a
 509 JQuery selector and clicking this checkbox will also toggle all checkboxes
 510 matching the selector.
 511
 512 =item C<select_tag $name, \@collection, %attributes>
 513
 514 Creates an HTML 'select' tag named C<$name> with the contents of one
 515 'E<lt>optionE<gt>' tag for each element in C<\@collection> and with arbitrary
 516 HTML attributes from C<%attributes>. The value
 517 to use and the title to display are extracted from the elements in
 518 C<\@collection>. Each element can be one of four things:
 519
 520 =over 12
 521
 522 =item 1. An array reference with at least two elements. The first element is
 523 the value, the second element is its title. The third element is optional and and should contain a boolean.
 524 If it is true, than the element will be used as default.
 525
 526 =item 2. A scalar. The scalar is both the value and the title.
 527
 528 =item 3. A hash reference. In this case C<%attributes> must contain
 529 I<value_key>, I<title_key> and may contain I<default_key> keys that name the keys in the element to use
 530 for the value, title and default respectively.
 531
 532 =item 4. A blessed reference. In this case C<%attributes> must contain
 533 I<value_key>, I<title_key> and may contain I<default_key> keys that name functions called on the blessed
 534 reference whose return values are used as the value, title and default
 535 respectively.
 536
 537 =back
 538
 539 For cases 3 and 4 C<$attributes{value_key}> defaults to C<id>,
 540 C<$attributes{title_key}> defaults to C<$attributes{value_key}> and
 541 C<$attributes{default_key}> defaults to C<selected>. Note that
 542 C<$attributes{default_key}> is set to C<undef> if
 543 C<$attributes{default_value_key}> is used as well (see below).
 544
 545 In addition to pure keys/method you can also provide coderefs as I<value_sub>
 546 and/or I<title_sub> and/or I<default_sub>. If present, these take precedence over keys or methods,
 547 and are called with the element as first argument. It must return the value, title or default.
 548
 549 Lastly a joint coderef I<value_title_sub> may be provided, which in turn takes
 550 precedence over the C<value_sub> and C<title_sub> subs. It will only be called once for each
 551 element and must return a list of value and title.
 552
 553 If the option C<with_empty> is set then an empty element (value
 554 C<undef>) will be used as the first element. The title to display for
 555 this element can be set with the option C<empty_title> and defaults to
 556 an empty string.
 557
 558 The tag's C<id> defaults to C<name_to_id($name)>.
 559
 560 The option C<default> can be quite a lot of things:
 561
 562 =over 4
 563
 564 =item 1. A scalar value. This is the value of the entry that's
 565 selected by default.
 566
 567 =item 2. A hash reference for C<multiple=1>. Whether or not an entry
 568 is selected by default is looked up in this hash.
 569
 570 =item 3. An array reference containing scalar values. Same as 1., just
 571 for the case of C<multiple=1>.
 572
 573 =item 4. If C<default_value_key> is given: an array reference of hash
 574 references. For each hash reference the value belonging to the key
 575 C<default_value_key> is treated as one value to select by
 576 default. Constructs a hash that's treated like 3.
 577
 578 =item 5. If C<default_value_key> is given: an array reference of
 579 blessed objects. For each object the value returne from calling the
 580 function named C<default_value_key> on the object is treated as one
 581 value to select by default. Constructs a hash that's treated like 3.
 582
 583 =back
 584
 585 5. also applies to single RDBO instances (due to 'wantarray'
 586 shenanigans assigning RDBO's relationships to a hash key will result
 587 in a single RDBO object being assigned instead of an array reference
 588 containing that single RDBO object).
 589
 590 If the option C<with_optgroups> is set then this function expects
 591 C<\@collection> to be one level deeper. The upper-most level is
 592 translated into an HTML C<optgroup> tag. So the structure becomes:
 593
 594 =over 4
 595
 596 =item 1. Array of array references. Each element in the
 597 C<\@collection> is converted into an optgroup.
 598
 599 =item 2. The optgroup's C<label> attribute will be set to the
 600 first element in the array element. The second array element is then
 601 converted to a list of C<option> tags as described above.
 602
 603 =back
 604
 605 Example for use of optgroups:
 606
 607   # First in a controller:
 608   my @collection = (
 609     [ t8("First optgroup with three items"),
 610       [ { id => 42, name => "item one" },
 611         { id => 54, name => "second item" },
 612         { id => 23, name => "and the third one" },
 613       ] ],
 614     [ t8("Another optgroup, with a lot of items from Rose"),
 615       SL::DB::Manager::Customer->get_all_sorted ],
 616   );
 617
 618   # Later in the template:
 619   [% L.select_tag('the_selection', COLLECTION, with_optgroups=1, title_key='name') %]
 620
 621 =back
 622
 623 =head1 BUGS
 624
 625 Nothing here yet.
 626
 627 =head1 AUTHOR
 628
 629 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
 630 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 631
 632 =cut