in reply to I'm stuck adding more named parameters to a subroutine since the new named parameters might have the same name as the current ones.

As I understand your question, you want to be able for table to output certain rows with an initial header (i.e. whead) and certain without (i.e. data), but you don't want the current limitation where all the whead rows must be at the end of the table. Is that correct?

If so, as a first step, I'd replace table's data and whead options with a single rows option which takes a single arrayref. This arrayref would contain a list of type/row pairs, where the type is a string "data" or "whead" and the row is an arrayref:

sub table {
  my ($tab,$opt) = @_;

  my @attributes;
  push @attributes, qq(id="$opt->{id}")       if $opt->{id};
  push @attributes, qq(class="$opt->{class}") if $opt->{class};
  push @attributes, qq(style="$opt->{style}") if $opt->{style};

  my $format = @attributes > 0 ? ' '.join(' ',@attributes) : '';
  my $tag = 'table'.$format;

  line($tab,qq(<$tag>));
  line($tab + 1,qq(<caption>$opt->{caption}</caption>)) if $opt->{capt
+ion};

  row($tab + 1,'header',$opt->{headings}) if $opt->{headings};

  my $next_needs_head;
  for (@{$opt->{rows} || []}) {
    if (!ref and /^whead$/) {
      $next_needs_head = 1;
      next;
    }
    elsif (!ref) {
      $next_needs_head = 0;
      next;
    }
    row($tab + 1, $next_needs_head?"whead":"data", $_);
    $next_needs_head = 0;
  }

  line($tab,q(</table>));
}

table(1, {
    id       => 't1',
    headings => [qw/NAME STRENGTH COMMENT/],
    rows     => [
        whead => [qw/1    2        no/],
        data  => [qw/2    3        yes/],
        whead => [qw/10   20       another/],
        data  => [qw/100  200      comment/],
    ],
});

[download]

As a next step, I'd abandon the type/row pairs idea, and use blessing so each row "knows" what type it is:

sub table {
  my ($tab,$opt) = @_;

  my @attributes;
  push @attributes, qq(id="$opt->{id}")       if $opt->{id};
  push @attributes, qq(class="$opt->{class}") if $opt->{class};
  push @attributes, qq(style="$opt->{style}") if $opt->{style};

  my $format = @attributes > 0 ? ' '.join(' ',@attributes) : '';
  my $tag = 'table'.$format;

  line($tab,qq(<$tag>));
  line($tab + 1,qq(<caption>$opt->{caption}</caption>)) if $opt->{capt
+ion};

  row($tab + 1,'header',$opt->{headings}) if $opt->{headings};

  for (@{$opt->{rows} || []}) {
    row($tab + 1, $_->isa("MyRow::WithHead")?"whead":"data", $_);
  }

  line($tab,q(</table>));
}

sub data  { bless \@_, "MyRow" }
sub whead { bless \@_, "MyRow::WithHead" }

table(1, {
    id       => 't1',
    headings => [qw/NAME STRENGTH COMMENT/],
    rows     => [
        whead(qw/1    2        no/),
        data( qw/2    3        yes/),
        whead(qw/10   20       another/),
        data( qw/100  200      comment/),
    ],
});

[download]

Then I'd start pushing the logic for outputting data into the MyRow classes, and indeed into some MyCell classes:

sub table {
  my ($tab,$opt) = @_;

  my @attributes;
  push @attributes, qq(id="$opt->{id}")       if $opt->{id};
  push @attributes, qq(class="$opt->{class}") if $opt->{class};
  push @attributes, qq(style="$opt->{style}") if $opt->{style};

  my $format = @attributes > 0 ? ' '.join(' ',@attributes) : '';
  my $tag = 'table'.$format;

  line($tab,qq(<$tag>));
  line($tab + 1,qq(<caption>$opt->{caption}</caption>)) if $opt->{capt
+ion};

  row($tab + 1,'header',$opt->{headings}) if $opt->{headings};

  $_->output($tab+1) for @{$opt->{rows} || []};

  line($tab,q(</table>));
}

{
    package MyCell;
    sub output {
        my $self  = shift;
        my ($tab) = @_;
        ::line($tab, qq(<td>@$self</td>));
    }
}

{
    package MyCell::Header;
    use base "MyCell";
    sub output {
        my $self  = shift;
        my ($tab) = @_;
        ::line($tab, qq(<th>@$self</th>));
    }
}

{
    package MyRow;
    sub cells {
        my $self = shift;
        return map { bless [$_], "MyCell" } @$self;
    }
    sub output {
        my $self  = shift;
        my ($tab) = @_;
        ::line($tab,qq(<tr>));
        $_->output($tab + 1) for $self->cells;
        ::line($tab,qq(</tr>));
    }
}

{
    package MyRow::WithHead;
    use base "MyRow";
    sub cells {
        my $self  = shift;
        my @cells = $self->SUPER::cells;
        bless $cells[0], "MyCell::Header";
        return @cells;
    }
}

sub data  { bless \@_, "MyRow" }
sub whead { bless \@_, "MyRow::WithHead" }

table(1, {
    id       => 't1',
    headings => [qw/NAME STRENGTH COMMENT/],
    rows     => [
        whead(qw/1    2        no/),
        data( qw/2    3        yes/),
        whead(qw/10   20       another/),
        data( qw/100  200      comment/),
    ],
});

[download]

The next step is to go fully OO:

use strict;
use warnings;

{
    package MyElem;
    sub _line {
        shift;
        my $t = shift;
        print(("\t" x $t), @_, "\n");
    }
}

{
    package MyCell;
    use base "MyElem";
    sub output {
        my $self  = shift;
        my ($tab) = @_;
        $self->_line($tab, qq(<td>@$self</td>));
    }
}

{
    package MyCell::Header;
    use base "MyCell";
    sub output {
        my $self  = shift;
        my ($tab) = @_;
        $self->_line($tab, qq(<th>@$self</th>));
    }
}

{
    package MyRow;
    use base "MyElem";
    sub cells {
        my $self = shift;
        return map { bless [$_], "MyCell" } @$self;
    }
    sub output {
        my $self  = shift;
        my ($tab) = @_;
        $self->_line($tab,qq(<tr>));
        $_->output($tab + 1) for $self->cells;
        $self->_line($tab,qq(</tr>));
    }
}

{
    package MyRow::WithHead;
    use base "MyRow";
    sub cells {
        my $self  = shift;
        my @cells = $self->SUPER::cells;
        bless $cells[0], "MyCell::Header";
        return @cells;
    }
}

{
    package MyRow::AllHeads;
    use base "MyRow";
    sub cells {
        my $self = shift;
        return map { bless [$_], "MyCell::Header" } @$self;
    }
}

{
    package MyTable;
    use base "MyElem";
    sub output {
        my $self = shift;
        my ($tab) = @_;
        
        my @attributes;
        push @attributes, qq(id="$self->{id}")       if $self->{id};
        push @attributes, qq(class="$self->{class}") if $self->{class}
+;
        push @attributes, qq(style="$self->{style}") if $self->{style}
+;
        
        my $format = @attributes > 0 ? ' '.join(' ',@attributes) : '';
        my $tag = 'table'.$format;
        
        $self->_line($tab, qq(<$tag>));
        $self->_line($tab + 1,qq(<caption>$self->{caption}</caption>))
+ if $self->{caption};
        $self->{headings}->output($tab+1) if $self->{headings};
        $_->output($tab+1) for @{$self->{rows} || []};
        $self->_line($tab,q(</table>));
    }
}

sub data     { bless \@_,  "MyRow" }
sub whead    { bless \@_,  "MyRow::WithHead" }
sub headings { bless \@_,  "MyRow::AllHeads" }
sub table    { bless {@_}, "MyTable" }

my $table = table(
    id       => 't1',
    headings => headings(qw/NAME STRENGTH COMMENT/),
    rows     => [
        whead(qw/1    2        no/),
        data (qw/2    3        yes/),
        whead(qw/10   20       another/),
        data (qw/100  200      comment/),
    ],
);

$table->output(1);

[download]

Each piece of data "knows" what it is (it's a "MyRow" or a "MyTable" or whatever). And because each class has an output method, each piece of data "knows" how to output itself.

You'll notice that MyTable itself does very little output of its own; instead delegating the job of output to each row. (And each row delegates the job of output to each cell.)

This means that if you need a particular special type of row, you can create a new subclass of MyRow, overriding the output method, then slip one of your spangly new rows into a table, and the table itself doesn't need to know any different. As far as the table is concerned, it's just another row.

There's still a few ways it could be improved; it's a bit inconsistent about where and when data gets blessed into the various classes. I don't have time for any further improvements right now, but I may come back to this post this evening.

Update: here's the final OO stage. The job of constructing the objects is moved to a new method within the classes. And the job of making sure the internals of each object are in order (e.g. making sure that the internals of a row objects are cell objects) is moved to _init.

Additionally, attribute processing and building start and end tags for an HTML element are defined in the MyElem class.

use strict;
use warnings;

{
    package MyElem;
    sub new {
        my $class = shift;
        my %opts  = @_;
        my $self  = bless \%opts, $class;
        $self->_init;
        return $self;
    }
    sub _init {
        my $self = shift;
    }
    sub _tagname {
        shift;
        return "span";
    }
    sub id    { shift->{id} }
    sub class { shift->{class} }
    sub style { shift->{style} }
    sub title { shift->{title} }
    sub _start_tag {
        my $self = shift;
        my $tag  =
            join " ", $self->_tagname,
            map  { sprintf '%s="%s"', $_, $self->$_ }
            grep { defined $self->$_ }
            qw(id class style title);
        return "<$tag>";
    }
    sub _end_tag {
        my $self = shift;
        my $tag  = $self->_tagname;
        return "</$tag>";
    }
    sub output {
        my $self = shift;
        my ($tab) = @_;
        $self->_line($tab, $self->_start_tag, $self->value, $self->_en
+d_tag);
    }
    sub _line {
        shift;
        my $t = shift;
        print(("\t" x $t), @_, "\n");
    }
}

{
    package MyCell;
    use base "MyElem";
    sub value {
        shift->{value};
    }
    sub _tagname {
        return "td";
    }
    sub output {
        my $self  = shift;
        my ($tab) = @_;
        $self->_line($tab, $self->_start_tag, $self->value, $self->_en
+d_tag);
    }
}

{
    package MyCell::Header;
    use base "MyCell";
    sub _tagname {
        return "th";
    }
}

{
    package MyRow;
    use base "MyElem";
    use Scalar::Util qw(blessed);
    sub _init {
        my $self = shift;
        @{$self->{cells}} = map {
            blessed($_) ? $_ : "MyCell"->new(value => $_)
        } @{$self->{cells}||[]};
        $self->SUPER::_init;
    }
    sub cells {
        @{shift->{cells}};
    }
    sub _tagname {
        return "tr";
    }
    sub output {
        my $self  = shift;
        my ($tab) = @_;
        $self->_line($tab, $self->_start_tag);
        $_->output($tab + 1) for $self->cells;
        $self->_line($tab, $self->_end_tag);
    }
}

{
    package MyRow::WithHead;
    use base "MyRow";
    use Scalar::Util qw(blessed);
    sub _init {
        my $self = shift;
        $self->{cells}[0] = "MyCell::Header"->new(value => $self->{cel
+ls}[0])
            unless blessed($self->{cells}[0]);
        $self->SUPER::_init;
    }
}

{
    package MyRow::AllHeads;
    use base "MyRow";
    use Scalar::Util qw(blessed);
    sub _init {
        my $self = shift;
        @{$self->{cells}} = map {
            blessed($_) ? $_ : "MyCell::Header"->new(value => $_)
        } @{$self->{cells}||[]};
        $self->SUPER::_init;
    }
}

{
    package MyTable;
    use base "MyElem";
    use Scalar::Util qw(blessed);
    sub _init {
        my $self = shift;
        @{$self->{rows}} = map {
            blessed($_) ? $_ : "MyRow"->new(cells => $_)
        } @{$self->{rows}||[]};
        $self->SUPER::_init;
    }
    sub rows {
        @{shift->{rows}};
    }
    sub _tagname {
        return "table";
    }
    sub output {
        my $self = shift;
        my ($tab) = @_;
        
        $self->_line($tab, $self->_start_tag);
        $self->_line($tab + 1,qq(<caption>$self->{caption}</caption>))
+ if $self->{caption};
        $_->output($tab+1) for $self->rows;
        $self->_line($tab, $self->_end_tag);
    }
}

sub data     { my @args = @_; "MyRow"->new(cells => \@args) }
sub whead    { my @args = @_; "MyRow::WithHead"->new(cells => \@args) 
+}
sub headings { my @args = @_; "MyRow::AllHeads"->new(cells => \@args) 
+}

my $table = "MyTable"->new(
    id       => 't1',
    rows     => [
        headings (qw/NAME STRENGTH COMMENT/),
        whead    (qw/1    2        no/),
        data     (qw/2    3        yes/),
        whead    (qw/10   20       another/),
        data     (qw/100  200      comment/),
        data     (1000, "MyCell"->new(value => 2000, style=>"color:red
+"), "again"),
    ],
);

$table->output(1);

[download]
package Cow { use Moo; has name => (is => 'lazy', default => sub { 'Mooington' }) } say Cow->new->name
  • Comment on Re: I'm stuck adding more named parameters to a subroutine since the new named parameters might have the same name as the current ones.
  • Select or Download Code

Replies are listed 'Best First'.
Re^2: I'm stuck adding more named parameters to a subroutine since the new named parameters might have the same name as the current ones.
by Lady_Aleena (Priest) on Mar 25, 2013 at 22:08 UTC

    tobyink, headings are rows just like data and whead so modifying your example of usage ...

    table(1, {
    id       => 't1',
    rows     => [
        headings => [qw/NAME STRENGTH COMMENT/],
        whead => [ # multiple rows with the first cell being a header.
            [1,   [2,   { style => 'text-align: right' }], 'no'],
            [2,   [3,   { style => 'text-align: right' }], 'yes'],
            [10,  [20,  { style => 'text-align: right' }], 'another'],
            [100, [200, { style => 'text-align: right' }], 'comment'],
        ],
        headings => [['List to go with the whead' { colspan => 3 }]],
        data  => [['list', { class => 'info', colspan => 3, list => [$
+list, { class => 'two_cols' }] }]],
    ],
});

    [download]

    I can understand why you would want to pass individual rows, however, you are not taking into consideration a table with hundreds or even thousands of rows. I have one table with over 2,000 rows, so I would prefer a way to pass them through with an arrayref. In my modified example, I put headings inside of rows. I can not have two headings currently and can not set the order in which the row groups are displayed.

    Oh, line comes from another module, so if possible, is there a way to use it as is? I use line in every script I write where I am printing lines.

    choroba suggested I build the @attributes separately, and I agree. I will be looking at what he did and see how I can modify it to my exact needs then adding it to the module.

    Also, the last time I tried figuring out OO, I was told I did it all wrong. OO and I have not become friends yet. So, right now I do not know what to ask on how to change what you wrote to suit my desires. Give me a lot of time to understand what you wrote, please?

    Update: It looks like you dropped the attributes from all the elements except table. Every HTML tag can have its own attributes. Since I am generating the HTML with perl, I could go really crazy and give every element its own id, but I will refrain.

    Have a cookie and a very nice day!
    Lady Aleena
[reply]
[d/l]
[select]

      "Oh, line comes from another module, so if possible, is there a way to use it as is? I use line in every script I write where I am printing lines."

      Sure. I left it out in the interests of self-containedness. But it should just be a case of (in package MyElem):

          sub _line {
        shift;
        my $tab = shift;
        require The::Other::Module;
        The::Other::Module::line($tab, join " ", @_);
    }

      [download]
      e

      "choroba suggested I build the @attributes separately, and I agree. I will be looking at what he did and see how I can modify it to my exact needs then adding it to the module."

      Yes, in my final update I did this.

      "Also, the last time I tried figuring out OO, I was told I did it all wrong."

      Yes, I recall. That's why I took it in stages, so you can see how one style of coding translates to another. If I'd just posted the final version, it might be a bit mysterious how the things in your code corresponds to mine.

      Seeing the different steps makes it clearer that I didn't really add or remove much; just structured it into smaller parcels; replaced arrayrefs and hashrefs with objects; and replaced function calls with method calls.

      The main thing this buys you is polymorphism: a table object can call the output method on one of the row objects it contains, and it doesn't need to care about what type of row it is.

      Polymorphism is the main reason why people bang on about about OO all the time. It's a really great way of maintaining separation of concerns (i.e, so the MyCell package knows all about how to output cells, but the MyRow package needs to know nothing about how to output cells), and providing extensibility. An example of extensibility might be that you could define a new cell class:

      {
  package MyCell::Important;
  use base "MyCell";
  sub _init {
    my $self = shift;
    no warnings "uninitialized";
    $self->{style} = "color:red;font-weight:bold;$self->{style}";
  }
}

      [download]

      And you can use your MyCell::Important class in tables without needing to make any changes to the MyRow or MyTable classes at all!

      package Cow { use Moo; has name => (is => 'lazy', default => sub { 'Mooington' }) } say Cow->new->name
[reply]
[d/l]
[select]

        tobyink, you did a lot of appears to be great work but went way too fast. I now need to know how to pass data collected outside of the objects to pass to the objects, so let's get some external data.

        #!/usr/bin/perl
use strict;
use warnings FATAL => qw( all );

use CGI::Carp qw(fatalsToBrowser);
use List::Util qw(sum min max);
use URI::Encode qw(uri_encode);

use lib 'files/lib';
use Base::HTML::Elements qw(table);
# I would add this in, however, it is just too big.
# print_menu was taken out for this example.
# link_color applies color styles to links based on file extension.
# I included link_color below.
use Base::Menu qw(print_menu link_color);
# Gets root data for my site. You can get rid of this.
use Base::Roots qw(get_root);
# Adds commas and rounds numbers.
use Base::Number qw(pretty_number);
use Base::Nifty qw(line);

print "content-type: text/html \n\n";

# change this to the path of whatever directory you want.
my $root_path = get_root('path'); 

my %extensions;
my %file_sizes;
my $file_sizes_sum;
sub file_list {
  my $directory = shift;
  opendir(my $dir,$directory) or die "Can't open $directory $!";
  my @temp = grep {/^\w/} readdir($dir);
  for (@temp) { 
    if (-f "$directory/$_") {
      my $key = (split(/\./,$_))[-1];
      ++$extensions{$key};
      my $file_size = -s "$directory/$_";
      my $file = "$directory/$_";
         $file =~ s/$root_path\///;
      $file_sizes{$file}{bytes} = $file_size;
      $file_sizes{$file}{kilobytes} = $file_size/1024;
      $file_sizes{$file}{megabytes} = ($file_size/1024)/1024;
      $file_sizes_sum += $file_size;
    }
    if (-d "$directory/$_") {
      file_list("$directory/$_");
    }
  }
}

file_list("$root_path");

my $extensions_sum = sum(values %extensions);
my $extensions_types = keys %extensions;
my $file_sizes_total = keys %file_sizes;

        [download]

        Now, I have all kinds of wonderful data to pass to the table object, if only I know what was needed to get the other objects to work. So, let's start with %extensions and the cells which will go in the more than a dozen rows of the table; then we can go onto %file_sizes.

        my @ext_rows;
for my $key (sort keys %extensions) {
  my $value = $extensions{$key};
  my $color = link_color($key);

  # As you can see, the two cells in the rows each have $opt fields.
  # The first cell in the row gets a custom color for its text.
  # The second cell is part of a CSS class which is right aligned.
  push @ext_rows, [[$key, { style=> "$color" }],[$value, { class => 'r
+ight' }]];
}

# Here are the final two rows in the extensions table. Later they will
+ be plugged in
# under whead.
# The first cells in these two rows are headers which get no other spe
+cial formatting.
# The second cells in these two rows get right aligned with a CSS clas
+s.
my @ext_end_rows;
push @ext_end_rows, ['Total files',[$extensions_sum, { class => 'right
+' }]];
push @ext_end_rows, ['Total types',[$extensions_types, { class => 'rig
+ht' }]]; 


# The table with file paths and file sizes is much much larger.
# In the root directory I use, there are over 2,000 files meaning over
+ 2,000 rows.

my @size_rows;
for my $key (sort { $file_sizes{$b}{bytes} <=> $file_sizes{$a}{bytes} 
+|| $a cmp $b } keys %file_sizes) {
  my $bytes = $file_sizes{$key}{bytes};
  my $kbytes = $file_sizes{$key}{kilobytes};
  my $mbytes = $file_sizes{$key}{megabytes};
  my $color = link_color($key);
  my $link = uri_encode($key);
     $key =~ s!&!&amp;!g;

  # Again, what do I store here?
  # The first cell is a link to the file.
  # The second through fourth are numbers which I mapped to be 
  # pretty and be right aligned with a CSS class.
  push @size_rows, [qq(<a href="$link" style="$color">$key</a>),
               map { [pretty_number(5,$_), { class => 'right' }] } ($b
+ytes,$kbytes,$mbytes)
              ];
}

my $sum_bytes = $file_sizes_sum;
my $sum_kbytes = $file_sizes_sum/1024;
my $sum_mbytes = ($file_sizes_sum/1024)/1024;

my $avg_bytes = $file_sizes_sum/$file_sizes_total;
my $avg_kbytes = ($file_sizes_sum/$file_sizes_total)/1024;
my $avg_mbytes = (($file_sizes_sum/$file_sizes_total)/1024)/1024;

# Now these two rows are being stored with the other rows in the sizes
+ table
# with the same formatting.
push @size_rows, ['Totals',map { [pretty_number(5,$_), { class => 'rig
+ht' }] } ($sum_bytes,$sum_kbytes,$sum_mbytes)];
push @size_rows, ['Averages',map { [pretty_number(5,$_), { class => 'r
+ight' }] } ($avg_bytes,$avg_kbytes,$avg_mbytes)];

# With the way the data was gathered above, I was able to plug in the 
+data
# into the tables in a one liner (though they wrapped here). I did not
+ store
# the headings, since they did not require any real munging.
table(3, { style => 'float:right', headings => ['Ext','Count'], data =
+> [@ext_rows], whead => [@ext_end_rows] });
table(3, { headings => [qw(File bytes kilobytes megabytes)], whead => 
+[@size_rows] });

        [download]

        So, what do I need to store in arrayrefs for each row for each cell in the row?

        link_color

        sub link_color {
  my ($file,$style) = @_;
  my $color = "000";

  my %colors;
  $colors{pl}    = "f00";
  $colors{pm}    = "900";
  $colors{html}  = "00f";
  $colors{shtml} = "009";
  $colors{svg}   = "003";
  $colors{css}   = "060";
  $colors{csv}   = "0f0";
  $colors{txt}   = "090";
  $colors{zip}   = "990";
  $colors{js}    = "099";
  $colors{pdf}   = "c33";
  $colors{wav}   = "939";
  $colors{xls}   = "696";
  $colors{doc}   = "669";
  $colors{pub}   = "699";
  $colors{$_}    = "909" for (qw(gif ico jpg png bmp));

  my ($extension,$name) = reverse split(/\./,$file);
  $color = $colors{$extension} ? $colors{$extension} : $color;

  return $style ? qq( style="color:#$color") : qq(color:#$color);
}

        [download]
        Have a cookie and a very nice day!
        Lady Aleena
[reply]
[d/l]
[select]

In Section Seekers of Perl Wisdom