From: Moritz Bunkus <m.bunkus@linet-services.de>
Date: Wed, 24 Apr 2013 13:19:47 +0000 (+0200)
Subject: _hashify: verallgemeinert, getestet, nach SL::Util verschoben (und das dabei erfunden)
X-Git-Tag: release-3.1.0beta1~466
X-Git-Url: http://wagnertech.de/git?a=commitdiff_plain;h=5e9aaf1c3e83467ed4f6550627f8c7e6ec6fa811;p=kivitendo-erp.git

_hashify: verallgemeinert, getestet, nach SL::Util verschoben (und das dabei erfunden)
---

diff --git a/SL/Helper/DateTime.pm b/SL/Helper/DateTime.pm
index b72207f8a..639ed4531 100644
--- a/SL/Helper/DateTime.pm
+++ b/SL/Helper/DateTime.pm
@@ -2,6 +2,8 @@ package DateTime;
 
 use strict;
 
+use SL::Util qw(_hashify);
+
 sub now_local {
   return shift->now(time_zone => $::locale->get_local_time_zone);
 }
@@ -11,8 +13,7 @@ sub today_local {
 }
 
 sub to_kivitendo {
-  my $self   = shift;
-  my %params = (scalar(@_) == 1) && (ref($_[0]) eq 'HASH') ? %{ $_[0] } : @_;
+  my ($self, %params) = _hashify(1, @_);
   return $::locale->format_date_object($self, %params);
 }
 
diff --git a/SL/Template/Plugin/L.pm b/SL/Template/Plugin/L.pm
index 6db220296..fa1869215 100644
--- a/SL/Template/Plugin/L.pm
+++ b/SL/Template/Plugin/L.pm
@@ -7,6 +7,7 @@ use List::Util qw(max);
 use Scalar::Util qw(blessed);
 
 use SL::Presenter;
+use SL::Util qw(_hashify);
 
 use strict;
 
@@ -30,10 +31,6 @@ sub _J {
   return $string;
 }
 
-sub _hashify {
-  return (@_ && (ref($_[0]) eq 'HASH')) ? %{ $_[0] } : @_;
-}
-
 sub new {
   my ($class, $context, @args) = @_;
 
@@ -75,8 +72,7 @@ sub _set_id_attribute {
 }
 
 sub img_tag {
-  my ($self, @slurp) = @_;
-  my %options = _hashify(@slurp);
+  my ($self, %options) = _hashify(1, @_);
 
   $options{alt} ||= '';
 
@@ -84,8 +80,7 @@ sub img_tag {
 }
 
 sub textarea_tag {
-  my ($self, $name, $content, @slurp) = @_;
-  my %attributes      = _hashify(@slurp);
+  my ($self, $name, $content, %attributes) = _hashify(3, @_);
 
   _set_id_attribute(\%attributes, $name);
   $attributes{rows}  *= 1; # required by standard
@@ -96,8 +91,7 @@ sub textarea_tag {
 }
 
 sub checkbox_tag {
-  my ($self, $name, @slurp) = @_;
-  my %attributes       = _hashify(@slurp);
+  my ($self, $name, %attributes) = _hashify(2, @_);
 
   _set_id_attribute(\%attributes, $name);
   $attributes{value}   = 1 unless defined $attributes{value};
@@ -118,9 +112,7 @@ sub checkbox_tag {
 }
 
 sub radio_button_tag {
-  my $self             = shift;
-  my $name             = shift;
-  my %attributes       = _hashify(@_);
+  my ($self, $name, %attributes) = _hashify(2, @_);
 
   _set_id_attribute(\%attributes, $name);
   $attributes{value}   = 1 unless defined $attributes{value};
@@ -139,8 +131,8 @@ sub radio_button_tag {
 }
 
 sub hidden_tag {
-  my ($self, $name, $value, @slurp) = @_;
-  return $self->input_tag($name, $value, _hashify(@slurp), type => 'hidden');
+  my ($self, $name, $value, %attributes) = _hashify(3, @_);
+  return $self->input_tag($name, $value, %attributes, type => 'hidden');
 }
 
 sub div_tag {
@@ -159,8 +151,7 @@ sub li_tag {
 }
 
 sub link {
-  my ($self, $href, $content, @slurp) = @_;
-  my %params = _hashify(@slurp);
+  my ($self, $href, $content, %params) = _hashify(3, @_);
 
   $href ||= '#';
 
@@ -168,8 +159,7 @@ sub link {
 }
 
 sub submit_tag {
-  my ($self, $name, $value, @slurp) = @_;
-  my %attributes = _hashify(@slurp);
+  my ($self, $name, $value, %attributes) = _hashify(3, @_);
 
   if ( $attributes{confirm} ) {
     $attributes{onclick} = 'return confirm("'. _J(delete($attributes{confirm})) .'");';
@@ -179,8 +169,7 @@ sub submit_tag {
 }
 
 sub button_tag {
-  my ($self, $onclick, $value, @slurp) = @_;
-  my %attributes = _hashify(@slurp);
+  my ($self, $onclick, $value, %attributes) = _hashify(3, @_);
 
   _set_id_attribute(\%attributes, $attributes{name}) if $attributes{name};
   $attributes{type} ||= 'button';
@@ -201,8 +190,7 @@ sub ajax_submit_tag {
 }
 
 sub yes_no_tag {
-  my ($self, $name, $value) = splice @_, 0, 3;
-  my %attributes            = _hashify(@_);
+  my ($self, $name, $value, %attributes) = _hashify(3, @_);
 
   return $self->select_tag($name, [ [ 1 => $::locale->text('Yes') ], [ 0 => $::locale->text('No') ] ], default => $value ? 1 : 0, %attributes);
 }
@@ -228,9 +216,8 @@ sub stylesheet_tag {
 
 my $date_tag_id_idx = 0;
 sub date_tag {
-  my ($self, $name, $value, @slurp) = @_;
+  my ($self, $name, $value, %params) = _hashify(3, @_);
 
-  my %params   = _hashify(@slurp);
   _set_id_attribute(\%params, $name);
   my @onchange = $params{onchange} ? (onChange => delete $params{onchange}) : ();
   my @class    = $params{no_cal} || $params{readonly} ? () : (class => 'datepicker');
@@ -299,8 +286,7 @@ sub javascript_tag {
 }
 
 sub tabbed {
-  my ($self, $tabs, @slurp) = @_;
-  my %params   = _hashify(@slurp);
+  my ($self, $tabs, %params) = _hashify(2, @_);
   my $id       = $params{id} || 'tab_' . _tag_id();
 
   $params{selected} *= 1;
@@ -326,8 +312,7 @@ sub tabbed {
 }
 
 sub tab {
-  my ($self, $name, $src, @slurp) = @_;
-  my %params = _hashify(@slurp);
+  my ($self, $name, $src, %params) = _hashify(3, @_);
 
   $params{method} ||= 'process';
 
@@ -348,8 +333,7 @@ sub tab {
 }
 
 sub areainput_tag {
-  my ($self, $name, $value, @slurp) = @_;
-  my %attributes      = _hashify(@slurp);
+  my ($self, $name, $value, %attributes) = _hashify(3, @_);
 
   my ($rows, $cols);
   my $min  = delete $attributes{min_rows} || 1;
@@ -367,8 +351,7 @@ sub areainput_tag {
 }
 
 sub multiselect2side {
-  my ($self, $id, @slurp) = @_;
-  my %params              = _hashify(@slurp);
+  my ($self, $id, %params) = _hashify(2, @_);
 
   $params{labelsx}        = "\"" . _J($params{labelsx} || $::locale->text('Available')) . "\"";
   $params{labeldx}        = "\"" . _J($params{labeldx} || $::locale->text('Selected'))  . "\"";
@@ -387,8 +370,7 @@ EOCODE
 }
 
 sub sortable_element {
-  my ($self, $selector, @slurp) = @_;
-  my %params                    = _hashify(@slurp);
+  my ($self, $selector, %params) = _hashify(2, @_);
 
   my %attributes = ( distance => 5,
                      helper   => <<'JAVASCRIPT' );
@@ -445,8 +427,7 @@ JAVASCRIPT
 }
 
 sub online_help_tag {
-  my ($self, $tag, @slurp) = @_;
-  my %params               = _hashify(@slurp);
+  my ($self, $tag, %params) = _hashify(2, @_);
   my $cc                   = $::myconfig{countrycode};
   my $file                 = "doc/online/$cc/$tag.html";
   my $text                 = $params{text} || $::locale->text('Help');
@@ -463,8 +444,7 @@ sub dump {
 }
 
 sub sortable_table_header {
-  my ($self, $by, @slurp) = @_;
-  my %params              = _hashify(@slurp);
+  my ($self, $by, %params) = _hashify(2, @_);
 
   my $controller          = $self->{CONTEXT}->stash->get('SELF');
   my $sort_spec           = $controller->get_sort_spec;
@@ -495,7 +475,7 @@ sub paginate_controls {
   my %template_params = (
     pages             => \%paginate_params,
     url_maker         => sub {
-      my %url_params                                    = _hashify(@_);
+      my %url_params                                    = _hashify(0, @_);
       $url_params{ $paginate_spec->{FORM_PARAMS}->[0] } = delete $url_params{page};
       $url_params{ $paginate_spec->{FORM_PARAMS}->[1] } = delete $url_params{per_page} if exists $url_params{per_page};
 
diff --git a/SL/Util.pm b/SL/Util.pm
new file mode 100644
index 000000000..fdcc080cf
--- /dev/null
+++ b/SL/Util.pm
@@ -0,0 +1,74 @@
+package SL::Util;
+
+use strict;
+
+use parent qw(Exporter);
+
+use Carp;
+
+our @EXPORT_OK = qw(_hashify);
+
+sub _hashify {
+  my $keep = shift;
+
+  croak "Invalid number of entries to keep" if 0 > $keep;
+
+  return @_[0..scalar(@_) - 1] if $keep >= scalar(@_);
+  return ($keep ? @_[0..$keep - 1] : (),
+          ((1 + $keep) == scalar(@_)) && ((ref($_[$keep]) || '') eq 'HASH') ? %{ $_[$keep] } : @_[$keep..scalar(@_) - 1]);
+}
+
+1;
+__END__
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+SL::Util - Assorted utility functions
+
+=head1 OVERVIEW
+
+Most important things first:
+
+DO NOT USE C<@EXPORT> HERE! Only C<@EXPORT_OK> is allowed!
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<_hashify $num, @args>
+
+Hashifies the very last argument. Returns a list consisting of two
+parts:
+
+The first part are the first C<$num> elements of C<@args>.
+
+The second part depends on the remaining arguments. If exactly one
+argument remains and is a hash reference then its dereferenced
+elements will be used. Otherwise the remaining elements of C<@args>
+will be returned as-is.
+
+Useful if you want to write code that can be called from Perl code and
+Template code both. Example:
+
+  use SL::Util qw(_hashify);
+
+  sub do_stuff {
+    my ($self, %params) = _hashify(1, @_);
+    # Now do stuff, obviously!
+  }
+
+=back
+
+=head1 BUGS
+
+Nothing here yet.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
diff --git a/t/helper/hashify.t b/t/helper/hashify.t
new file mode 100644
index 000000000..cf45ef558
--- /dev/null
+++ b/t/helper/hashify.t
@@ -0,0 +1,84 @@
+use Test::More tests => 52;
+
+use strict;
+
+use lib 't';
+
+use_ok 'SL::Util';
+
+sub numtest {
+  my @result = SL::Util::_hashify(@_);
+  return scalar(@result);
+}
+
+sub memtest {
+  my $key    = shift;
+  my $keep   = $_[0];
+  my @result = SL::Util::_hashify(@_);
+  splice @result, 0, $keep;
+
+  return '<empty>'     if !@result;
+  return '<odd-sized>' if scalar(@result) % 2;
+
+  my %hash = @result;
+  return $hash{$key};
+}
+
+my $href = { 42 => 54, unicorn => 'charlie' };
+my %hash = ( 23 => 13, chunky  => 'bacon'   );
+
+is(numtest(0, $href), 4, 'case A1');
+is(numtest(0, %hash), 4, 'case A2');
+is(numtest(1, $href), 1, 'case A3');
+is(numtest(1, %hash), 4, 'case A4');
+is(numtest(2, $href), 1, 'case A5');
+is(numtest(2, %hash), 4, 'case A6');
+is(numtest(3, $href), 1, 'case A7');
+is(numtest(3, %hash), 4, 'case A8');
+is(numtest(4, $href), 1, 'case A9');
+is(numtest(4, %hash), 4, 'case A10');
+is(numtest(5, $href), 1, 'case A11');
+is(numtest(5, %hash), 4, 'case A12');
+
+is(numtest(0, 'dummy1', $href), 2, 'case B1');
+is(numtest(0, 'dummy1', %hash), 5, 'case B2');
+is(numtest(1, 'dummy1', $href), 5, 'case B3');
+is(numtest(1, 'dummy1', %hash), 5, 'case B4');
+is(numtest(2, 'dummy1', $href), 2, 'case B5');
+is(numtest(2, 'dummy1', %hash), 5, 'case B6');
+is(numtest(3, 'dummy1', $href), 2, 'case B7');
+is(numtest(3, 'dummy1', %hash), 5, 'case B8');
+is(numtest(4, 'dummy1', $href), 2, 'case B9');
+is(numtest(4, 'dummy1', %hash), 5, 'case B10');
+is(numtest(5, 'dummy1', $href), 2, 'case B11');
+is(numtest(5, 'dummy1', %hash), 5, 'case B12');
+
+is(numtest(0, 'dummy1', 'dummy2', $href), 3, 'case C1');
+is(numtest(0, 'dummy1', 'dummy2', %hash), 6, 'case C2');
+is(numtest(1, 'dummy1', 'dummy2', $href), 3, 'case C3');
+is(numtest(1, 'dummy1', 'dummy2', %hash), 6, 'case C4');
+is(numtest(2, 'dummy1', 'dummy2', $href), 6, 'case C5');
+is(numtest(2, 'dummy1', 'dummy2', %hash), 6, 'case C6');
+is(numtest(3, 'dummy1', 'dummy2', $href), 3, 'case C7');
+is(numtest(3, 'dummy1', 'dummy2', %hash), 6, 'case C8');
+is(numtest(4, 'dummy1', 'dummy2', $href), 3, 'case C9');
+is(numtest(4, 'dummy1', 'dummy2', %hash), 6, 'case C10');
+is(numtest(5, 'dummy1', 'dummy2', $href), 3, 'case C11');
+is(numtest(5, 'dummy1', 'dummy2', %hash), 6, 'case C12');
+
+is(memtest(42,        0, $href), '54',          'case D1');
+is(memtest(23,        0, %hash), '13',          'case D2');
+is(memtest('unicorn', 0, $href), 'charlie',     'case D3');
+is(memtest('chunky',  0, %hash), 'bacon',       'case D4');
+is(memtest(42,        1, $href), '<empty>',     'case D5');
+is(memtest(23,        1, %hash), '<odd-sized>', 'case D6');
+
+is(memtest(42,        0, 'dummy1', $href), undef,         'case E1');
+is(memtest(23,        0, 'dummy1', %hash), '<odd-sized>', 'case E2');
+is(memtest('unicorn', 0, 'dummy1', $href), undef,         'case E3');
+is(memtest(42,        1, 'dummy1', $href), '54',          'case E4');
+is(memtest(23,        1, 'dummy1', %hash), '13',          'case E5');
+is(memtest('unicorn', 1, 'dymmy1', $href), 'charlie',     'case E6');
+is(memtest('chunky',  1, 'dummy1', %hash), 'bacon',       'case E7');
+is(memtest(42,        2, 'dummy1', $href), '<empty>',     'case E8');
+is(memtest(23,        2, 'dummy1', %hash), '<odd-sized>', 'case E9');