view release on metacpan or  search on metacpan

lib/Class/MethodMaker/Engine.pm  view on Meta::CPAN

=cut

sub parse_options {
  my $class = shift;
  my ($target_class, $args, $options, $renames) = @_;

  print STDERR ("Parsing Options: ",
                Data::Dumper->Dump([$args, $options, $renames],
                                   [qw( args options renames )]))
    if DEBUG;

  my (%options, %renames);

  # It is important that components are created in the specified order, so
  # that e.g., forwarding works as expected (lest the forward method applies
  # to the wrong component).

  for (my $i = 0; $i < @$args; $i++) {
    if ( ! ref $args->[$i] ) {
      my $type = $args->[$i];

      if ( substr($type, 0, 1) eq '-' ) {
        my $option = substr($type, 1);
        if ( $option eq 'target_class' ) {
          croak "No argument found for -target_class\n"
            if $i == $#$args;
          $target_class = $args->[++$i];
          croak "-target_class takes a simple scalar argument\n"
            if ref $target_class;
        } else {
          croak "Unrecognized option: $type\n";
        }
      } else {
        # Reset options, renames to input global settings
        %options = defined $options ? %$options : ();
        %renames = defined $renames ? %$renames : ();
        my $created = 0;
        croak("No arguments found for $type while creating methods for ",
              $target_class, "\n")
          if $i == $#$args;
        my $opts = $args->[++$i];
        if ( UNIVERSAL::isa($opts, 'SCALAR') ) {
          $class->create_methods ($target_class, $type, $opts,
                                  \%options, \%renames);
          $created = 1;
        } elsif ( UNIVERSAL::isa($opts, 'ARRAY') ) {
          for (@$opts) {
            if ( ! ref $_ ) {
              if ( $_ =~ /^[A-Za-z_][0-9A-Za-z_]*$/ ) {
                $class->create_methods ($target_class, $type, $_,
                                        \%options, \%renames);
                $created = 1;
              } elsif ( $_ =~ /^([-!])([0-9A-Za-z_]+)$/ ) {
                $options{$2} = ($1 eq '!' ? 0 : 1);
              } else {
                croak "Argument $_ for type $type not understood\n";
              }
            } elsif ( UNIVERSAL::isa($_, 'HASH') ) {
              while ( my ($k, $v) = each %$_ ) {
                if ( index($k, '*') > $[-1 ) {
                  $renames{$k} = $v;
                } else {
                  $k =~ s/^-//;
                  $options{$k} = $v;
                }
              }
            } elsif ( UNIVERSAL::isa($_, 'ARRAY') ) {
              $class->parse_options($target_class, [$type, $_],
                                    \%options, \%renames);
            } else {
              croak("Argument type " . ref($_) .
                    " to type $type not handled\n");
            }
          }
        } else {
          $class->create_methods ($target_class, $type, $opts,
                                  $options, $renames);
          $created = 1;
        }

        warnif("No attributes found for type $type\n")
          unless $created;
      }
    } else {
      croak "Argument not handled: ", $args->[$i], "\n";
    }
  }

  return;
}

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

# V1 compatibility is purposely not documented.

sub parse_v1_options {
  my $class = shift;
  my ($target_class, $args) = @_;

  print STDERR "V1 Parser (1) : ", Data::Dumper->Dump([$args],
                                                          [qw( args )])
    if DEBUG;

  while (my ($v1type, $names) = splice @$args, 0, 2 ) {
    my %options = (v1_compat => 1);

    croak("No argument found for $v1type while creating methods for ",
          $target_class, "\n")
      unless defined $names;

    my $v2type = $v1type;

    my ($rename, $opt_handler, $rephrase);
    if ( exists V1COMPAT->{$v1type} ) {
      my $v1compat = V1COMPAT->{$v1type};
      $v2type = $v1compat->{v2name}
        if exists $v1compat->{v2name};
      ($rename, $opt_handler, $rephrase) =
        @{$v1compat}{qw(rename option rephrase)};
      print STDERR "V1 Parser (2) : ",