File Coverage

blib/lib/Decl/Util.pm

Criterion	Covered	Total	%
statement	53	57	92.9
branch	24	26	92.3
condition			n/a
subroutine	13	14	92.8
pod	9	9	100.0
total	99	106	93.4

package Decl::Util;

use warnings;
use strict;
use base qw(Exporter);
use vars qw(@EXPORT);

@EXPORT = qw(car cdr popcar splitcar lazyiter escapequote hh_set hh_get);

=head1 NAME

Decl::Util - some utility functions for the declarative framework - automatically included for generated code.

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';


=head1 SYNOPSIS

This class is a lightweight set of utilities to make things easier throughout C.  I'm not yet sure what will end up here, but my
rule of thumb is that it's extensions I'd like to be able to use in code generators as well.

=head2 Lazy Lispy lists: car(), cdr(), popcar(), splitcar()

I like Higher-Order Perl, really I do - but his head/tail streams are really just car and cdr, so I'm hereby defining car and cdr as lazy-evaluated streams
throughout the language.  Nodes are arrayrefs.  Clean and simple, no object orientation required.

=cut

sub car ($) { return undef unless ref $_[0] eq 'ARRAY'; $_[0]->[0] }
sub cdr ($) {
   my ($s) = @_;
   return undef unless ref $s eq 'ARRAY';
   $s->[1] = $s->[1]->() if ref $s->[1] eq 'CODE';
   $s->[1];
}
sub popcar ($) {
   my $p = car($_[0]);
   $_[0] = cdr($_[0]);
   return $p;
}
sub splitcar ($) { @{$_[0]}; }

=head2 lazyiter($iterator)

Takes any coderef (but especially an L) and builds a stream out of it.  Invokes the coderef once to get the
first value in the stream.

=cut

sub lazyiter {
   my $i = shift;
   my $value = $i->();
   return unless defined $value;
   [$value, sub { lazyiter ($i); }]
}

=head2 escapequote($string, $quote)

Returns a new string with C<$quote> escaped (by default, '"' is escaped) by means of a backslash.

=cut

sub escapequote {
   my ($string, $quote) = @_;
   $quote = '"' unless $quote;
   $string =~ s/($quote)/\\$1/g;
   $string
}

=head2 Hierarchical values a la CSS: hh_set(hash, name, value), hh_get (hash, name), and prepare_hierarchical_value as a helper

You know how CSS lets you specify something like C as well as something more like C?  These functions give
you something similar using hierarchically nested hashrefs.  They allow you to mix types of addressing:

   hh_set($h, 'border-left', 'my value');
   hh_set($h, 'border', 'right: val1; top: val2');

   # { 'border' => {'left'  => 'my value',
   #                'right' => 'val1',
   #                'top'   => 'val2'
   #               }
   # }

Clear?  Then you can use C to retrieve 'border' or 'border-left' by digging down into the hashref hierarchy.

Separators for names can be anything in -./

=cut

sub prepare_hierarchical_value {
   my ($hash, $name) = @_;
   $hash->{$name} = {} unless defined $hash->{$name};
   if (not ref $hash->{$name}) {
      my $newhash = {'*' => $hash->{$name}};
      $hash->{$name} = $newhash;
   }
   return $hash->{$name};
}

sub hh_set {
   my ($hash, $name, $value) = @_;

   unless (ref $name) {
      my @s = split /[.\-\/]/, $name;
      $name = \@s;
   }

   my ($first, @rest) = @$name;
   if (@rest) {
      hh_set (prepare_hierarchical_value ($hash, $first), \@rest, $value);
   } else {
      if ($value =~ /:/) {
         foreach (split / *; */, $value) {
            hh_set (prepare_hierarchical_value ($hash, $first), split / *: */);
         }
      } elsif (ref $hash->{$first}) {
         $hash->{$first}->{'*'} = $value;
      } else {
         $hash->{$first} = $value;
      }
   }
}

sub hh_get {
   my ($hash, $name) = @_;

   unless (ref $name) {
      my @s = split /[.\-\/]/, $name;
      $name = \@s;
   }
   my ($first, @rest) = @$name;
   return $hash->{$first} unless @rest;
   hh_get ($hash->{$first}, \@rest);
}


=head1 AUTHOR

Michael Roberts, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 LICENSE AND COPYRIGHT

Copyright 2010 Michael Roberts.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut

1; # End of Decl::Util