/usr/local/CPAN/YATT/YATT/Util/VarExporter.pm

• package YATT::Util::VarExporter
  • import
  • new
  • register_into
  • instance
  • export_to
  • find_vars
  • build_scope_for
  • as_html
  • varname
  • value
• EOF

package YATT::Util::VarExporter;
use strict;
use warnings FATAL => qw(all);

use base qw(YATT::Class::Configurable);
use YATT::Fields qw(pages);

use YATT::Util::Symbol;

sub import {
  my $pack = shift;
  my $callpack = caller;
  my $self = $pack->new(@_);
  $self->register_into($callpack);
  # $callpack に cache を作り、かつ、 import を作る
}

sub new {
  my MY $self = shift->SUPER::new;
  while (my ($page, $vars) = splice @_, 0, 2) {
    $self->{pages}{$page} = $vars;
  }
  $self
}

sub register_into {
  (my MY $self, my $pkg) = @_;
  MY->add_isa($pkg, MY);
  *{globref($pkg, '_CACHE')} = \ $self;
  *{globref($pkg, 'find_vars')} = sub {
    shift->instance->find_vars(@_);
  };
  *{globref($pkg, 'import')} = sub {
    my $callpack = caller;
    my MY $self = shift->instance;
    $self->export_to($callpack, @_);
  };
}

sub instance {
  my ($mypkg) = @_;
  ${*{globref($mypkg, '_CACHE')}{SCALAR}};;
}

sub export_to {
  (my MY $self, my ($destpkg, $page, $failok)) = @_;
  my $vars = $self->find_vars($page ||= $self->page_name)
    or $failok or die "No such page: $page";

  foreach my $name (keys %$vars) {
    my $value = $vars->{$name};
    if ($failok and ref $value and UNIVERSAL::can($value, 'varname')
	and UNIVERSAL::can($value, 'value')) {
      # For $failok case (== from yatt)
      my $glob = globref($destpkg, $value->varname($name));
      (*$glob) = map {ref $_ ? $_ : \ $_} $value->value;
    } else {
      my $glob = globref($destpkg, $name);
      *$glob = do {
	if (not ref $value or ref $value eq 'ARRAY' or ref $value eq 'HASH') {
	  \ $value
	} else {
	  $value;
	}
      };
      # 関数の場合は、関数だけでなく、スカラ変数にも入れておく。
      *$glob = \ $value if ref $value eq 'CODE';
    }
  }
}

sub find_vars {
  my MY $self = ref $_[0] ? shift : shift->instance();
  my ($page, $varname) = @_;
  my $page_vars = $self->{pages}{$page}
    or return;
  unless (defined $varname) {
    $page_vars;
  } else {
    $page_vars->{$varname};
  }
}

# YATT 固有で良いよね。

sub build_scope_for {
  my ($mypkg, $gen, $page) = @_;
  my MY $self = $mypkg->instance;
  my $vars = $self->find_vars($page);
  my %scope;
  foreach my $name (keys %$vars) {
    my $value = $vars->{$name};
    my $type = do {
      unless (ref $value) {
	$gen->t_text;
      } elsif (ref $value eq 'ARRAY') {
	$gen->t_list
      } elsif (ref $value eq 'CODE') {
	$gen->t_code
      } elsif (UNIVERSAL::can($value, 'varname')
	       and UNIVERSAL::can($value, 'value')) {
	$gen->t_html;
      } else {
	$gen->t_scalar;
      }
    };
    $scope{$name} = $type->new(varname => $name);
  }
  \%scope;
}

sub as_html {
  my ($text) = @_;
  bless \ $text, 'YATT::Util::VarExporter::html';
}

package
YATT::Util::VarExporter::html;
use overload '""' => 'value';
sub varname {shift; 'html_'. shift}
sub value {${shift()}}

1;