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