view release on metacpan or  search on metacpan

lib/Object/Simple.pm  view on Meta::CPAN

use warnings;
use Scalar::Util ();

no warnings 'redefine';

use Carp ();

sub import {
  my $class = shift;
  
  return unless @_;

  # Caller
  my $caller = caller;
  
  # No export syntax
  my $no_export_syntax;
  unless (grep { $_[0] eq $_ } qw/new attr class_attr dual_attr/) {
    $no_export_syntax = 1;
  }
  
  # Inheritance
  if ($no_export_syntax) {
    my $arg1 = shift;
    my $arg2 = shift;
    
    my $base_class;
    if (defined $arg1) {
      # Option
      if ($arg1 =~ /^-/) {
        if ($arg1 eq '-base') {
          if (defined $arg2) {
            $base_class = $arg2;
          }
        }
        else {
          Carp::croak "'$arg1' is invalid option(Object::Simple::import())";
        }
      }
      # Base class
      else {
        $base_class = $arg1;
      }
    }
    
    # Export has function
    no strict 'refs';
    no warnings 'redefine';
    *{"${caller}::has"} = sub { attr($caller, @_) };
    
    # Inheritance
    if ($base_class) {
      my $base_class_path = $base_class;
      $base_class_path =~ s/::|'/\//g;
      require "$base_class_path.pm";
      @{"${caller}::ISA"} = ($base_class);
    }
    else { @{"${caller}::ISA"} = ($class) }
    
    # strict!
    strict->import;
    warnings->import;
  }
  
  # Export methods
  else {
    my @methods = @_;
  
    # Exports
    my %exports = map { $_ => 1 } qw/new attr class_attr dual_attr/;
    
    # Export methods
    for my $method (@methods) {

      # Can be Exported?
      Carp::croak("Cannot export '$method'.")
        unless $exports{$method};

      warn "function exporting of $method is DEPRECATED(Object::Simple)";
      
      # Export
      no strict 'refs';
      *{"${caller}::$method"} = \&{"$method"};
    }
  }
}

sub new {
  my $class = shift;
  bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class;
}

sub attr {
  my ($self, @args) = @_;
  
  my $class = ref $self || $self;
  
  # Fix argument
  unshift @args, (shift @args, undef) if @args % 2;
  
  for (my $i = 0; $i < @args; $i += 2) {
    
    if ($i == 2) {
      warn "The syntax of multiple key-value arguments is DEPRECATED(Object::Simple::has or Object::Simple::attr)";
    }
    
    # Attribute name
    my $attrs = $args[$i];
    $attrs = [$attrs] unless ref $attrs eq 'ARRAY';
    
    # Default
    my $default = $args[$i + 1];
    
    for my $attr (@$attrs) {

      Carp::croak qq{Attribute "$attr" invalid} unless $attr =~ /^[a-zA-Z_]\w*$/;

      # Header (check arguments)
      my $code = "*{\"${class}::$attr\"} = sub {\n  if (\@_ == 1) {\n";

      # No default value (return value)