view release on metacpan or  search on metacpan

lib/TUI/toolkit/UO/Antlers.pm  view on Meta::CPAN

package TUI::toolkit::UO::Antlers;
# ABSTRACT: Moose-like sugar for the UNIVERSAL::Object based class

use strict;
use warnings;

our $VERSION   = '0.08';
our $AUTHORITY = 'cpan:BRICKPOOL';

use Carp              ();
use Scalar::Util      ();
use UNIVERSAL::Object ();

BEGIN { $] >= 5.010 ? require mro : require MRO::Compat }
BEGIN { 
  *CAN_HAZ_XS = ( !exists $ENV{PERL_ONLY} && !$ENV{PERL_ONLY} &&
                do { eval q[ use Class::XSAccessor ]; !$@ } )
              ? sub() { !!1 }
              : sub() { !!0 }
}

# ----------------------------------------------------------------------
# Export keywords
# ----------------------------------------------------------------------

use Importer ();

our @EXPORT = qw(
  has
  extends
  blessed
  confess
);

# ----------------------------------------------------------------------
# import/unimport for setting up the class and exporting the symbols
# ----------------------------------------------------------------------

sub import {
  my ( $class, @imports ) = @_;
  my $caller = caller(0);

  # Prevent double init per compilation unit
  return if $^H{ __PACKAGE__ . "/$caller" };
  $^H{ __PACKAGE__ . "/$caller" } = 1;

  # Turn on strict/warnings for caller
  strict->import;
  warnings->import;

  # When exporting 'extends', we assume that a class hierarchy exists and 
  # inject the base class if the class in the hierarchy has no parent
  my $exports = Importer->get( $class, @imports );
  if ( $exports->{extends} ) {
    require TUI::toolkit::UO::Base;
    no strict 'refs';
    unshift( @{"${caller}::ISA"}, 'TUI::toolkit::UO::Base' ) 
      unless ( @{"${caller}::ISA"} );
  }

  Importer->import_into( $class, $caller, @imports );
} #/ sub import

sub unimport {
  my ( $class, @imports ) = @_;
  my $caller = caller();

  # TODO: 'unimport' only takes effect one time, 
  # but at least it's consistent with 'import'
  return unless $^H{ __PACKAGE__ . "/$caller" };
  $^H{ __PACKAGE__ . "/$caller" } = 0;

  my $exports = Importer->get( $class, @imports );
  Importer->unimport_from( $caller, keys %$exports );
}

# ----------------------------------------------------------------------
# Public API functions for class setup and field management
# ----------------------------------------------------------------------

sub has {
  my $class = caller( 0 );
  Carp::croak( "has() requires at least one attribute name" )
    unless @_;

  # Case 1: has 'x'
  if ( @_ == 1 ) {
    my ( $name ) = @_;
    Carp::croak( "Attribute name must be a plain string" )
      unless defined $name && !ref $name;

    add_fields( $class, $name => undef );
    add_accessor( $class, $name => 'rw' );
    return;
  }

  # Case 2: has x => ( key => value, ... )
  my ( $name, @rest ) = @_;

  Carp::croak( "has($name) options must be key/value pairs" )
    unless @rest % 2 == 0;

  my %opts = @rest;

  # Check for unknown options and missing values. 
  my %allowed = map { $_ => 1 } qw(is default);
  for my $key ( keys %opts ) {
    Carp::croak("Unknown option '$key' for has($name)")