view release on metacpan or  search on metacpan

lib/Sub/Starter.pm  view on Meta::CPAN

  }elsif( $var =~ $RE_scalar_ref ){
    $name = $1; # . '_sref';
    $attr{-type} = 'scalar_ref';
    $attr{-variable} = '$' . $name;
  }elsif( $var =~ $RE_array_ref ){
    $name = $1; # . '_aref';
    $attr{-type} = 'array_ref';
    $attr{-variable} = '$' . $name;
  }elsif( $var =~ $RE_hash_ref ){
    $name = $1; # . '_href';
    $attr{-type} = 'hash_ref';
    $attr{-variable} = '$' . $name;
  }elsif( $var =~ $RE_code_ref ){
    $name = $1; # . '_cref';
    $attr{-type} = 'code_ref';
    $attr{-variable} = '$' . $name;
  }elsif( $var =~ $RE_typeglob ){
    $name = $1; # . '_gref';
    $attr{-type} = 'typeglob';
    $attr{-variable} = '$' . $name;
  }else{
    croak "unknown variable type: $var";
  }

  my $length = length( $name ) + 1;
  $parsed->{-max_variable} = $length if $parsed->{-max_variable} < $length;
  return %attr;
}

# --------------------------------------
#       Name: _parse_returns
#      Usage: _parse_returns( $parsed, $returns_part );
#    Purpose: Parse the sub's return variables
# Parameters:       $parsed -- storage hash
#             $returns_part -- part of the usage statement before the assignment
#    Returns: none
#
sub _parse_returns {
  my $parsed  = shift @_;
  my $returns = shift @_;
  my $list_var = 0;
  my %seen = ();

  return unless length $returns;

  if( $returns =~ s{ \+\= \z }{}msx ){
    $parsed->{-assignment} = 0;
  }else{
    $returns =~ s{ \= \z }{}msx;
  }

  if( $returns =~ m{ \A ( ([^\|]*) \| )? \( (.*?) \) \z }msx ){
    $parsed->{-returns_alternate} = $2;
    my $list = $3;

    if( $parsed->{-returns_alternate} ){
      $parsed->{-returns_alternate} = { _parse_variable( $parsed, $parsed->{-returns_alternate} ) };
      croak "alternative return variable is not a scalar" if $parsed->{-returns_alternate}{-type} ne 'scalar';
    }

    for my $var ( split m{ \, }msx, $list ){
      if( $seen{$var} ++ ){
        croak "Return parameter $var repeated";
      }
      my %attr = _parse_variable( $parsed, $var );
      push @{ $parsed->{-returns} }, { %attr };
      if( $attr{-type} eq 'array' or $attr{-type} eq 'hash' ){
        croak "array or hash may only occur at end of returns list" if $list_var ++;
      }
    }
  }elsif( $returns =~ m{ \A ([^\|]*) \| (.*?) \z }msx ){
    $parsed->{-returns_alternate} = $1;
    my $var = $2;

    $parsed->{-returns_alternate} = { _parse_variable( $parsed, $parsed->{-returns_alternate} ) };
    croak "alternative return variable is not a scalar" if $parsed->{-returns_alternate}{-type} ne 'scalar';
    if( $seen{$var} ++ ){
      croak "Return parameter $var repeated";
    }
    my %attr = _parse_variable( $parsed, $var );
    push @{ $parsed->{-returns} }, { %attr };
  }else{
    if( $seen{$returns} ++ ){
      croak "Return parameter $returns repeated";
    }
    my %attr = _parse_variable( $parsed, $returns );
    push @{ $parsed->{-returns} }, { %attr };
  }
  return;
}

# --------------------------------------
#       Name: _parse_parameters
#      Usage: _parse_parameters( $parsed, $param_part );
#    Purpose: Break the parameters into variables and store them.
# Parameters:     $parsed -- storage hash
#             $param_part -- part of the usage statement including optional parameters
#    Returns: none
#
sub _parse_parameters {
  my $parsed     = shift @_;
  my $param_part = shift @_;
  my $opt_params = '';
  my $list_var = 0;
  my %seen = ();

  if( $param_part =~ m{ \A ([^;]*) \; (.*) }msx ){
    $param_part = $1;
    $opt_params = $2;
  }

  for my $param ( split m{ \, }msx, $param_part ){
    if( $seen{$param} ++ ){
      die "Parameter $param repeated\n";
    }
    my %attr = _parse_variable( $parsed, $param );
    push @{ $parsed->{-parameters} }, { %attr };
    if( $attr{-type} eq 'array' or $attr{-type} eq 'hash' ){
      die "array or hash may only occur at end of parameter list" if $list_var ++;
    }
  }

  for my $param ( split m{ \, }msx, $opt_params ){
    if( $seen{$param} ++ ){
      die "Parameter $param repeated\n";
    }
    my %attr = _parse_variable( $parsed, $param );
    push @{ $parsed->{-parameters} }, { optional=>1, %attr };
    if( $attr{-type} eq 'array' or $attr{-type} eq 'hash' ){
      die "array or hash may only occur at end of parameter list" if $list_var ++;
    }
  }

  return;
}

# --------------------------------------
#       Name: parse_usage
#      Usage: $sub_starter->parse_usage( $usage_statement );
#    Purpose: Parse a usage statement and store its contents.
# Parameters: $usage_statement -- See POD for details
#    Returns: none
#
sub parse_usage {
  my $self            = shift @_;
  my $usage_statement = shift @_;
  my $usage = $usage_statement;

  # create a scratch pad
  my $parsed = dclone( \%Default_attributes );

  # clean up for easier processing
  $usage =~ s{ \s+ }{}gmsx;
  $usage =~ s{ \)? \;? \z }{}msx;

  # find returns via an assignment symbol
  my $returns_part = '';
  my $func_part = $usage;
  if( $usage =~ m{ \A ( [^=]* \= ) (.*) }msx ){
    $returns_part = $1;
    $func_part = $2;
  }
  if( $func_part =~ m{ = }msx ){
    croak "Multiple assignments in usage statement";
  }

  # get the name and possible object
  my $name_part = $func_part;
  my $param_part = '';
  if( $name_part =~ m{ \A ( [^()]* ) \( ( .*? ) \)? \z }msx ){
    $name_part = $1;
    $param_part = $2;
  }
  if( $name_part =~ s{ \A (.*?) \-\> }{}msx ){
    $parsed->{-object} =  $1;
    $parsed->{-max_variable} = 5;
  }
  $name_part =~ s{ \A \& }{}msx;
  $parsed->{-name} = $name_part;

  # parse the rest
  _parse_returns( $parsed, $returns_part );
  _parse_parameters( $parsed, $param_part );

lib/Sub/Starter.pm  view on Meta::CPAN

      $value = '@_';
    }
    if( $format =~ m{ \* }msx ){
      push @$text, sprintf( $format, $self->{-max_variable}, $item->{-variable}, $value );
    }else{
      push @$text, sprintf( $format, $item->{-variable}, $value );
    }
  }

  # do returns
  @list = ();
  if( $self->{-returns_alternate} ){
    push @list, $self->{-returns_alternate};
  }
  push @list, @{ $self->{-returns} };

  # print 'returns @list ', Dumper \@list;
  for my $item ( @list ){
    next if $seen{$item->{-variable}} ++;
    my $value = $self->{-assignment};
    if( $item->{-type} eq 'scalar' ){
      # value already set
    }elsif( $item->{-type} eq 'array' || $item->{-type} eq 'hash' ){
      $value = '()';
    }elsif( $item->{-type} eq 'array_ref' ){
      $value = '[]';
    }elsif( $item->{-type} eq 'hash_ref' ){
      $value = '{}';
    }else{
      $value = 'undef';
    }
    if( $format =~ m{ \* }msx ){
      push @$text, sprintf( $format, $self->{-max_variable}, $item->{-variable}, $value );
    }else{
      push @$text, sprintf( $format, $item->{-variable}, $value );
    }
  }

  return $text;
}

# --------------------------------------
#       Name: fill_out
#      Usage: $text = $sub_starter->fill_out( \@template );
#    Purpose: Fill out the template with the current parameters
# Parameters: \@template -- List of lines with replacements
#    Returns:      $text -- resulting text
#
sub fill_out {
  my $self     = shift @_;
  my $template = shift @_;
  my $text     = '';

  for my $template_line ( @$template ){
    my $line = $template_line;  # copy to modify

    if( $line =~ m{ \A (.*?) \e\[1m \( ([^\)]*) \) \e\[0?m (.*) }msx ){
      my $front = $1;
      my $item = $2;
      my $back = $3;
      my ( $directive, @arguments ) = split m{ \s+ }msx, $item;

      my $expansion; # array reference
      if( exists $Expand{$directive} ){
        $expansion = &{ $Expand{$directive} }( $self, @arguments );
      }else{
        carp "no expansion for '$directive'";
        next;
      }

      for my $expanded ( @$expansion ){
        $text .= $front . $expanded . $back;
      }

    }else{
      $text .= $line;
    }
  }

  return $text;
}

1;
__DATA__
__END__

=head1 NAME

Sub::Starter - Creates a skeletal framework for Perl sub's.

=head1 VERSION

This document refers to Sub::Starter version v1.0.6

=head1 SYNOPSIS

  use Sub::Starter;

=head1 DESCRIPTION

This module is for providing a simple and consist way of
creating sub's.  It provides methods for loading the
interface to a sub and, using a template, output its
skeleton.  This skeleton can then be populate with code.

=head2 Usage Statements

A usage statement shows how a sub will be used.  It is used
by the C<parse_usage()> method.  It is not valid Perl.  It
uses the make-a-reference-to notation for references.  This
is to give a clear indication of what the references is to.

The following variables can be used for the parameters,
including the optional ones, and the returns;

=over 4

=item $scalar -- a scalar variable

=item @array -- an array variable or list