File Coverage

blib/lib/App/Getconf/View.pm

Criterion	Covered	Total	%
statement	39	91	42.8
branch	10	52	19.2
condition	4	16	25.0
subroutine	9	14	64.2
pod	8	8	100.0
total	70	181	38.6

#!/usr/bin/perl

=head1 NAME

App::Getconf::View - specific view of options set in App::Getconf

=head1 SYNOPSIS

  use App::Getconf;

  App::Getconf->schema(...);
  App::Getconf->cmdline(\@ARGV);

  my $view = App::Getconf->getopt;

  if ($view->help) {
    print "this is --help message\n";
    exit 0;
  }

  print "starting the program\n" if $view->verbose;

  for my $i (0 .. $view->get("bottles.number")) {
    printf "%d bottles of beer on the wall, %d bottles of beer.\n" .
           "Take one down and pass it around, %d bottles of beer on the wall.\n\n",
           99 - $i, 99 - $i, 99 - $i - 1;
  }

=cut

package App::Getconf::View;

#-----------------------------------------------------------------------------

use warnings;
use strict;

use Carp;

our @CARP_NOT = qw{App::Getconf};

#-----------------------------------------------------------------------------

=head1 METHODS

Following methods are available:

=over

=cut

#-----------------------------------------------------------------------------

=item C

Constructor. Typically you won't be calling this on your own, so don't be
excited.

Following options are honoured:

=over

=item C

Longest prefix for options ("." is a separator). All other prefixes that will
be tried in lookup have last component chopped off, compared to previous
prefix.

=item C

Hashref containing all the L objects.

=back

=cut

sub new {
  my ($class, %opts) = @_;

  my $self = bless {
    prefixes => undef,
    options  => $opts{options},
  }, $class;

  my @parts = split /\./, $opts{prefix};
  my $prefix = $parts[0];
  for my $i (1 .. $#parts) {
    $prefix = $parts[$i] = "$prefix.$parts[$i]";
  }
  $self->{prefixes} = [reverse @parts];

  return $self;
}

#-----------------------------------------------------------------------------

=item C

List of prefixes searched by this view.

Prefixes are composed from C option passed to the constructor.

=cut

sub prefixes {
  my ($self) = @_;

  return @{ $self->{prefixes} };
}

#-----------------------------------------------------------------------------
# find an appropriate key

=begin Internal

=pod _lookup() {{{

=item C<_lookup($option_name, $type, $storage)>

Find an option called C<$option_name> looking under prefixes.

If C<$type> was specified, option will need to have this type.

If C<$storage> was specified, option will need to have this storage type.

Returned value is full option name (C if nothing was found).

=cut

sub _lookup {
  my ($self, $optname, $type, $storage) = @_;

  for my $p ($self->prefixes) {
    my $o = "$p.$optname";

    # no node in schema => can't have a value
    next if not $self->{options}{$o};
    # type filter was requested, but current node's type doesn't match
    next if defined $type    && $self->{options}{$o}->type    ne $type;
    # storage filter was requested, but current node's storage doesn't match
    next if defined $storage && $self->{options}{$o}->storage ne $storage;

    if (exists $self->{options}{$o}) {
      return $o;
    }
  }

  return undef if not $self->{options}{$optname};
  return undef if defined $type    && $self->{options}{$optname}->type    ne $type;
  return undef if defined $storage && $self->{options}{$optname}->storage ne $storage;

  return $optname;
}

=end Internal

=pod }}}

=cut

#-----------------------------------------------------------------------------

=item C

Retrieve value of option C<$option_name>. Method performs lookup, consequently
prepending each of prefixes (see C method).

=cut

sub get {
  my ($self, $optname) = @_;

  my $key = $self->_lookup($optname);
  return $key ? $self->top($key) : ();
}

=item C

Retrieve value of option C<$option_name>. Method I lookup.
You'll get the option which you asked for.

=cut

sub top {
  my ($self, $optname) = @_;

  if (exists $self->{options}{$optname}) {
    return $self->{options}{$optname}->get;
  }

  return;
}

#-----------------------------------------------------------------------------
# top_*()

=begin Test::Pod::Coverage

=item C

Retrieve value of option C<$name> (no lookup), expecting type C<$type>. Method
does not discriminate between different storage types, it just checks the
type. It's a helper for C methods.

Method returns C<($value, App::Getconf::Node)>.

=end Test::Pod::Coverage

=cut

sub top_allinwonder {
  my ($self, $optname, $type) = @_;

  my $opt = $self->{options}{$optname};

  if (not $opt) {
    croak "Option not found: $optname";
  }

  if ($opt->type ne $type) {
    croak "Type mismatch for $optname: expected $type, got @{[$opt->type]}";
  }

  return ($opt->get, $opt);
}

=begin Test::Pod::Coverage

=item C

Retrieve value of option C<$name> (no lookup), expecting type C<$type> and the
option storage being a simple scalar.

Method returns value stored for the option.

=end Test::Pod::Coverage

=cut

sub top_type_scalar {
  my ($self, $optname, $type) = @_;

  my ($value, $opt) = $self->top_allinwonder($optname, $type);

  if ($opt->storage ne 'scalar') { # other possibilities: array, hash
    croak "Scalar option $optname requested, got @{[$opt->storage]}";
  }

  # convert bool to 1/0
  return ($value ? 1 : 0) if $type eq 'bool';

  # other types don't require special treatment
  return $value;
}

=begin Test::Pod::Coverage

=item C

Retrieve value of option C<$name> (no lookup), expecting type C<$type> and the
option storage being an array.

Method returns plain list (possibly empty) of values stored for the option.

=end Test::Pod::Coverage

=cut

sub top_type_array {
  my ($self, $optname, $type) = @_;

  my ($value, $opt) = $self->top_allinwonder($optname, $type);

  if ($opt->storage ne 'array') { # other possibilities: "", HASH
    my $type = $opt->storage;
    croak "Array option $optname requested, got $type";
  }

  return @{ $value || [] };
}

=begin Test::Pod::Coverage

=item C

Retrieve value of option C<$name> (no lookup), expecting type C<$type> and the
option storage being a hash.

In list context method returns list of pairs (key => value) of data stored for
the option. In scalar context method returns hashref of the data.

=end Test::Pod::Coverage

=cut

sub top_type_hash {
  my ($self, $optname, $type) = @_;

  my ($value, $opt) = $self->top_allinwonder($optname, $type);

  if ($opt->storage ne 'hash') { # other possibilities: scalar, array
    my $type = $opt->storage;
    croak "Hash option $optname requested, got $type";
  }

  # in list context (assignment to hash?) return all the key/value pairs
  # in scalar context (also: dereference) return hashref
  if (wantarray) {
    return %{ $value || {} };
  } else {
    return $value;
  }
}

#-----------------------------------------------------------------------------

=item C

=item C

=item C

=item C

=item C

=item C

Methods similar to C and C, but they also check if the result is
of matching type (C don't stop on non-matching options). Option
storage is also checked: it should be, respectively, a scalar, an array or
a hash.

Methods C when no matching option was found. If the option was found
but it had not been set, methods return C or empty list, whichever is
appropriate.

Methods C<*_array()> return a list of elements, which in scalar context turns
out to be a number.

Methods C<*_hash()> return a hashref (or C) in scalar context and list
of key/value pairs in list context.

=item C<< ${option_name}() >>

For convenience, options may be retrieved by calling method named after the
option. For example, following two are equivalent:
C<< $view->get('verbose') >> and C<< $view->verbose >>.

Note that this syntax performs lookup, just like C method.

Names starting with C, C and C are reserved. Use explicit
C method call to retrieve them.

=cut

our $AUTOLOAD;
sub AUTOLOAD {
  my ($self) = @_;

  my $optname = (split /::/, $AUTOLOAD)[-1];

  # unified support for top_flag(), top_bool(), top_int() and so on
  if ($optname =~ /^(get|top)_(flag|bool|int|float|string)(_(array|hash))?$/) {
    my $lookup = $1;
    my $type = $2;
    my $storage = $4 || "scalar";
    my $name = $_[1];

    if ($lookup eq 'get') {
      my $real_name = $self->_lookup($name, $type, $storage);
      if (not $real_name) {
        $storage ||= "scalar";
        croak "Option not found: $name ($type, $storage)";
      }
      $name = $real_name;
    }

    if (not $storage) {
      return $self->top_type_scalar($name, $type);
    } elsif ($storage eq 'array') {
      return $self->top_type_array($name, $type);
    } elsif ($storage eq 'hash') {
      return $self->top_type_hash($name, $type);
    }
  }

  if ($optname =~ /^(set|get|top)_/) {
    croak "Invalid option name for shorthand syntax: $optname";
  }

  return $self->get($optname);
}

#-----------------------------------------------------------------------------

sub DESTROY {
  my ($self) = @_;

  # nuffin();
}

#-----------------------------------------------------------------------------

=back

=cut

#-----------------------------------------------------------------------------

=head1 AUTHOR

Stanislaw Klekot, C<<  >>

=head1 LICENSE AND COPYRIGHT

Copyright 2012 Stanislaw Klekot.

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.

=head1 SEE ALSO

L

=cut

#-----------------------------------------------------------------------------
1;
# vim:ft=perl:foldmethod=marker