view release on metacpan or  search on metacpan

lib/Rose/HTML/Object/Messages.pm  view on Meta::CPAN

use Carp;

use base 'Rose::HTML::Object::Exporter';

our $VERSION = '0.618';

our $Debug = 0;

use Rose::Class::MakeMethods::Generic
(
  inheritable_scalar =>
  [
    '_message_names',
    'message_id_to_name_map',
    'message_name_to_id_map',
  ],
);

BEGIN
{
  __PACKAGE__->_message_names([]);
  __PACKAGE__->message_id_to_name_map({});
  __PACKAGE__->message_name_to_id_map({});
}

sub init_export_tags
{
  my($class) = shift;

  my $list = $class->message_names;

  $class->export_tags
  (
    all    => $list,
    field  => [ grep { /^FIELD_/ } @$list ],
    form   => [ grep { /^FORM_/ } @$list ],
    date   => [ grep { /^DATE_|_(?:YEAR|MONTH|DAY)$/ } @$list ],
    time   => [ grep { /^TIME_|_(?:HOUR|MINUTE|SECOND)$/ } @$list ],
    email  => [ grep { /^EMAIL_/ } @$list ],
    phone  => [ grep { /^PHONE_/ } @$list ],
    number => [ grep { /^NUM_/ } @$list ],
    set    => [ grep { /^SET_/ } @$list ],
    string => [ grep { /^STRING_/ } @$list ],
  );
}

sub import
{
  my($class) = shift;

  $class->use_private_messages;
  $class->init_export_tags;

  if($Rose::HTML::Object::Exporter::Target_Class)
  {
    $class->SUPER::import(@_);
  }
  else
  {
    local $Rose::HTML::Object::Exporter::Target_Class = (caller)[0];
    $class->SUPER::import(@_);
  }
}

our %Private;

sub use_private_messages
{
  my($class) = shift;

  unless($Private{$class})
  {
    $Private{$class} = 1;

    # Make private copies of inherited data structures 
    # (shallow copy is sufficient)
    $class->message_names([ $class->message_names ]);
    $class->message_id_to_name_map({ %{$class->message_id_to_name_map} });
    $class->message_name_to_id_map({ %{$class->message_name_to_id_map} });
  }
}

sub message_id_exists   { defined $_[0]->message_id_to_name_map->{$_[1]} }
sub message_name_exists { defined $_[0]->message_name_to_id_map->{$_[1]} }

sub message_names
{
  my($class) = shift;

  $class->_message_names(@_)  if(@_);

  wantarray ? @{$class->_message_names} :
              $class->_message_names;
}

sub get_message_id
{
  my($class, $symbol) = @_;
  no strict 'refs';
  my $const = "${class}::$symbol";
  return &$const  if(defined &$const);
  return undef;
}

sub message_ids
{
  my($class) = shift;
  my $map = $class->message_id_to_name_map;

  return wantarray ? 
    (sort { $a <=> $b } keys %$map) : 
    [ sort { $a <=> $b } keys %$map ];
}

sub get_message_name 
{
  no warnings 'uninitialized';
  return $_[0]->message_id_to_name_map->{$_[1]};
}