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 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 {
 327   my ($href, $content, %params) = @_;
 328
 329   $href ||= '#';
 330
 331   html_tag('a', $content, %params, href => $href);
 332 }
 333
 334 sub date_tag {
 335   my ($name, $value, %params) = @_;
 336
 337   _set_id_attribute(\%params, $name);
 338   my @onchange = $params{onchange} ? (onChange => delete $params{onchange}) : ();
 339   my @classes  = $params{no_cal} || $params{readonly} ? () : ('datepicker');
 340   push @classes, delete($params{class}) if $params{class};
 341   my %class    = @classes ? (class => join(' ', @classes)) : ();
 342
 343   $::request->layout->add_javascripts('kivi.Validator.js');
 344   $::request->presenter->need_reinit_widgets($params{id});
 345
 346   input_tag(
 347     $name, blessed($value) ? $value->to_lxoffice : $value,
 348     size   => 11,
 349     "data-validate" => "date",
 350     %params,
 351     %class, @onchange,
 352   );
 353 }
 354
 355 1;
 356 __END__
 357
 358 =pod
 359
 360 =encoding utf8
 361
 362 =head1 NAME
 363
 364 SL::Presenter::Tag - Layouting / tag generation
 365
 366 =head1 SYNOPSIS
 367
 368 Usage in a template:
 369
 370   [% USE P %]
 371
 372   [% P.select_tag('direction', [ [ 'left', 'To the left' ], [ 'right', 'To the right', 1 ] ]) %]
 373
 374   [% P.select_tag('direction', [ { direction => 'left',  display => 'To the left'  },
 375                                  { direction => 'right', display => 'To the right' } ],
 376                                value_key => 'direction', title_key => 'display', default => 'right') %]
 377
 378   [% P.select_tag('direction', [ { direction => 'left',  display => 'To the left'  },
 379                                  { direction => 'right', display => 'To the right', selected => 1 } ],
 380                                value_key => 'direction', title_key => 'display') %]
 381
 382   # Use an RDBO object and its n:m relationship as the default
 383   # values. For example, a user can be a member of many groups. "All
 384   # groups" is therefore the full collection and "$user->groups" is a
 385   # list of RDBO AuthGroup objects whose IDs must match the ones in
 386   # "All groups". This could look like the following:
 387   [% P.select_tag('user.groups[]', SELF.all_groups, multiple=1,
 388                   default=SELF.user.groups, default_value_key='id' ) %]
 389
 390 =head1 DESCRIPTION
 391
 392 A module modeled a bit after Rails' ActionView helpers. Several small
 393 functions that create HTML tags from various kinds of data sources.
 394
 395 The C<id> attribute is usually calculated automatically. This can be
 396 overridden by either specifying an C<id> attribute or by setting
 397 C<no_id> to trueish.
 398
 399 =head1 FUNCTIONS
 400
 401 =head2 LOW-LEVEL FUNCTIONS
 402
 403 =over 4
 404
 405 =item C<html_tag $tag_name, $content_string, %attributes>
 406
 407 Creates an opening and closing HTML tag for C<$tag_name> and puts
 408 C<$content_string> between the two. If C<$content_string> is undefined
 409 or empty then only a E<lt>tag/E<gt> tag will be created. Attributes
 410 are key/value pairs added to the opening tag.
 411
 412 C<$content_string> is not HTML escaped.
 413
 414 =item C<name_to_id $name>
 415
 416 Converts a name to a HTML id by replacing various characters.
 417
 418 =item C<stringify_attributes %items>
 419
 420 Creates a string from all elements in C<%items> suitable for usage as
 421 HTML tag attributes. Keys and values are HTML escaped even though keys
 422 must not contain non-ASCII characters for browsers to accept them.
 423
 424 =item C<restricted_html $html>
 425
 426 Returns HTML stripped of unknown tags. See L<SL::HTML::Restrict>.
 427
 428 =back
 429
 430 =head2 HIGH-LEVEL FUNCTIONS
 431
 432 =over 4
 433
 434 =item C<input_tag $name, $value, %attributes>
 435
 436 Creates a HTML 'input type=text' tag named C<$name> with the value
 437 C<$value> and with arbitrary HTML attributes from C<%attributes>. The
 438 tag's C<id> defaults to C<name_to_id($name)>.
 439
 440 =item C<submit_tag $name, $value, %attributes>
 441
 442 Creates a HTML 'input type=submit class=submit' tag named C<$name> with the
 443 value C<$value> and with arbitrary HTML attributes from C<%attributes>. The
 444 tag's C<id> defaults to C<name_to_id($name)>.
 445
 446 If C<$attributes{confirm}> is set then a JavaScript popup dialog will
 447 be added via the C<onclick> handler asking the question given with
 448 C<$attributes{confirm}>. The request is only submitted if the user
 449 clicks the dialog's ok/yes button.
 450
 451 =item C<ajax_submit_tag $url, $form_selector, $text, %attributes>
 452
 453 Creates a HTML 'input type="button"' tag with a very specific onclick
 454 handler that submits the form given by the jQuery selector
 455 C<$form_selector> to the URL C<$url> (the actual JavaScript function
 456 called for that is C<kivi.submit_ajax_form()> in
 457 C<js/client_js.js>). The button's label will be C<$text>.
 458
 459 =item C<button_tag $onclick, $text, %attributes>
 460
 461 Creates a HTML 'input type="button"' tag with an onclick handler
 462 C<$onclick> and a value of C<$text>. The button does not have a name
 463 nor an ID by default.
 464
 465 If C<$attributes{confirm}> is set then a JavaScript popup dialog will
 466 be prepended to the C<$onclick> handler asking the question given with
 467 C<$attributes{confirm}>. The request is only submitted if the user
 468 clicks the dialog's "ok/yes" button.
 469
 470 =item C<man_days_tag $name, $object, %attributes>
 471
 472 Creates two HTML inputs: a text input for entering a number and a drop
 473 down box for chosing the unit (either 'man days' or 'hours').
 474
 475 C<$object> must be a L<Rose::DB::Object> instance using the
 476 L<SL::DB::Helper::AttrDuration> helper.
 477
 478 C<$name> is supposed to be the name of the underlying column,
 479 e.g. C<time_estimation> for an instance of
 480 C<SL::DB::RequirementSpecItem>. If C<$name> has the form
 481 C<prefix.method> then the full C<$name> is used for the input's base
 482 names while the methods called on C<$object> are only the suffix. This
 483 makes it possible to write statements like e.g.
 484
 485   [% P.man_days_tag("requirement_spec_item.time_estimation", SELF.item) %]
 486
 487 The attribute C<size> can be used to set the text input's size. It
 488 defaults to 5.
 489
 490 =item C<hidden_tag $name, $value, %attributes>
 491
 492 Creates a HTML 'input type=hidden' tag named C<$name> with the value
 493 C<$value> and with arbitrary HTML attributes from C<%attributes>. The
 494 tag's C<id> defaults to C<name_to_id($name)>.
 495
 496 =item C<checkbox_tag $name, %attributes>
 497
 498 Creates a HTML 'input type=checkbox' tag named C<$name> with arbitrary
 499 HTML attributes from C<%attributes>. The tag's C<id> defaults to
 500 C<name_to_id($name)>. The tag's C<value> defaults to C<1>.
 501
 502 If C<%attributes> contains a key C<label> then a HTML 'label' tag is
 503 created with said C<label>. No attribute named C<label> is created in
 504 that case.
 505
 506 If C<%attributes> contains a key C<checkall> then the value is taken as a
 507 JQuery selector and clicking this checkbox will also toggle all checkboxes
 508 matching the selector.
 509
 510 =item C<select_tag $name, \@collection, %attributes>
 511
 512 Creates an HTML 'select' tag named C<$name> with the contents of one
 513 'E<lt>optionE<gt>' tag for each element in C<\@collection> and with arbitrary
 514 HTML attributes from C<%attributes>. The value
 515 to use and the title to display are extracted from the elements in
 516 C<\@collection>. Each element can be one of four things:
 517
 518 =over 12
 519
 520 =item 1. An array reference with at least two elements. The first element is
 521 the value, the second element is its title. The third element is optional and and should contain a boolean.
 522 If it is true, than the element will be used as default.
 523
 524 =item 2. A scalar. The scalar is both the value and the title.
 525
 526 =item 3. A hash reference. In this case C<%attributes> must contain
 527 I<value_key>, I<title_key> and may contain I<default_key> keys that name the keys in the element to use
 528 for the value, title and default respectively.
 529
 530 =item 4. A blessed reference. In this case C<%attributes> must contain
 531 I<value_key>, I<title_key> and may contain I<default_key> keys that name functions called on the blessed
 532 reference whose return values are used as the value, title and default
 533 respectively.
 534
 535 =back
 536
 537 For cases 3 and 4 C<$attributes{value_key}> defaults to C<id>,
 538 C<$attributes{title_key}> defaults to C<$attributes{value_key}> and
 539 C<$attributes{default_key}> defaults to C<selected>. Note that
 540 C<$attributes{default_key}> is set to C<undef> if
 541 C<$attributes{default_value_key}> is used as well (see below).
 542
 543 In addition to pure keys/method you can also provide coderefs as I<value_sub>
 544 and/or I<title_sub> and/or I<default_sub>. If present, these take precedence over keys or methods,
 545 and are called with the element as first argument. It must return the value, title or default.
 546
 547 Lastly a joint coderef I<value_title_sub> may be provided, which in turn takes
 548 precedence over the C<value_sub> and C<title_sub> subs. It will only be called once for each
 549 element and must return a list of value and title.
 550
 551 If the option C<with_empty> is set then an empty element (value
 552 C<undef>) will be used as the first element. The title to display for
 553 this element can be set with the option C<empty_title> and defaults to
 554 an empty string.
 555
 556 The tag's C<id> defaults to C<name_to_id($name)>.
 557
 558 The option C<default> can be quite a lot of things:
 559
 560 =over 4
 561
 562 =item 1. A scalar value. This is the value of the entry that's
 563 selected by default.
 564
 565 =item 2. A hash reference for C<multiple=1>. Whether or not an entry
 566 is selected by default is looked up in this hash.
 567
 568 =item 3. An array reference containing scalar values. Same as 1., just
 569 for the case of C<multiple=1>.
 570
 571 =item 4. If C<default_value_key> is given: an array reference of hash
 572 references. For each hash reference the value belonging to the key
 573 C<default_value_key> is treated as one value to select by
 574 default. Constructs a hash that's treated like 3.
 575
 576 =item 5. If C<default_value_key> is given: an array reference of
 577 blessed objects. For each object the value returne from calling the
 578 function named C<default_value_key> on the object is treated as one
 579 value to select by default. Constructs a hash that's treated like 3.
 580
 581 =back
 582
 583 5. also applies to single RDBO instances (due to 'wantarray'
 584 shenanigans assigning RDBO's relationships to a hash key will result
 585 in a single RDBO object being assigned instead of an array reference
 586 containing that single RDBO object).
 587
 588 If the option C<with_optgroups> is set then this function expects
 589 C<\@collection> to be one level deeper. The upper-most level is
 590 translated into an HTML C<optgroup> tag. So the structure becomes:
 591
 592 =over 4
 593
 594 =item 1. Array of array references. Each element in the
 595 C<\@collection> is converted into an optgroup.
 596
 597 =item 2. The optgroup's C<label> attribute will be set to the
 598 first element in the array element. The second array element is then
 599 converted to a list of C<option> tags as described above.
 600
 601 =back
 602
 603 Example for use of optgroups:
 604
 605   # First in a controller:
 606   my @collection = (
 607     [ t8("First optgroup with three items"),
 608       [ { id => 42, name => "item one" },
 609         { id => 54, name => "second item" },
 610         { id => 23, name => "and the third one" },
 611       ] ],
 612     [ t8("Another optgroup, with a lot of items from Rose"),
 613       SL::DB::Manager::Customer->get_all_sorted ],
 614   );
 615
 616   # Later in the template:
 617   [% L.select_tag('the_selection', COLLECTION, with_optgroups=1, title_key='name') %]
 618
 619 =back
 620
 621 =head1 BUGS
 622
 623 Nothing here yet.
 624
 625 =head1 AUTHOR
 626
 627 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
 628 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 629
 630 =cut