#!/usr/bin/perl
# --------------------------------------
#
#     Title: Perl sub Code Generator
#   Purpose: Create Perl sub's from usage statement.
# Copyright: Copyright 2006 by Mr. Shawn H. Corey.  All rights reserved.
#
#
#    Name: sub
#    File: sub
# Created: August 29, 2006
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
#

# --------------------------------------
# Pragmas
use strict;
use warnings;

# --------------------------------------
# Version
our $VERSION = '1.0.1';

# --------------------------------------
# Modules
use Data::Dumper;
use English qw( -no_match_vars ) ;  # Avoids regex performance penalty
use Getopt::Long;
use Pod::Usage;
use POSIX;

# --------------------------------------
# Configuration Parameters

my $User_template_file = glob( '~/.subrc' );
my $Template_file = '/etc/subrc';

# Regular expressions
my $RE_id         = qr{ [_[:alpha:]] [_[:alnum:]]* }mosx;
my $RE_scalar     = qr{ \A \$ ( $RE_id ) \z }mosx;
my $RE_array      = qr{ \A \@ ( $RE_id ) \z }mosx;
my $RE_hash       = qr{ \A \% ( $RE_id ) \z }mosx;
my $RE_scalar_ref = qr{ \A \\ \$ ( $RE_id ) \z }mosx;
my $RE_array_ref  = qr{ \A \\ \@ ( $RE_id ) \z }mosx;
my $RE_hash_ref   = qr{ \A \\ \% ( $RE_id ) \z }mosx;
my $RE_code_ref   = qr{ \A \\ \& ( $RE_id ) \z }mosx;
my $RE_typeglob   = qr{ \A \\? \* ( $RE_id ) \z }mosx;

$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Indent   = 1;
$Data::Dumper::Maxdepth = 0;

# --------------------------------------
# Globals Variables

# Documentation levels
my $DOC_USAGE = 0;
my $DOC_HELP  = 1;
my $DOC_MAN   = 2;

# Options variables
my $Command_line = 0;

my @Template = ();

# Scratch variables
my $Sub_name     = '';
my $Max_length   = 0;
my $Max_var_len  = 0;
my @Returns      = ();  # list of returned variables.
my %Returns      = ();  # list of returned variables by name.
my $Assign_value = '';  # default value assigned to single return parameter.
my @Parameters   = ();  # list of sub's parameters.
my %Parameters   = ();  # list of sub's parameters by name.
my $Object_name  = 0;   # the name of the object if the sub is actually a method.
my $Alt_returns  = '';  # alternate return variable.

# --------------------------------------
# Subroutines

# --------------------------------------
#      Usage: print_documentation( $documentation_level );
#    Purpose: Print the usage, help, or man documentation.
#    Returns: Does not return.
# Parameters: $documentation_level
#           :   0 == usage
#           :   1 == help
#           :   other == man
#
sub print_documentation {
  my $level = shift @_;

  # print the usage documentation
  if( $level == $DOC_USAGE ){
    pod2usage(
      -exitval => 2,
      -verbose => 99,
      -sections => 'USAGE',
    );
  }

  # print the help documentation
  if( $level == $DOC_HELP ){
    pod2usage(
      -exitval => 2,
      -verbose => 99,
      -sections => 'NAME|VERSION|USAGE|REQUIRED ARGUMENTS|OPTIONS',
    );
  }

  # print the man documentation
  pod2usage(
    -exitval => 2,
    -verbose => 2,
  );
}

# --------------------------------------
#      Usage: initialize_program();
#    Purpose: To do those tasks that can only be done at run time.
#    Returns: none
# Parameters: none
#
sub initialize_program {

  # Check command-line options
  unless( GetOptions(
    commandline => \$Command_line,
    usage => sub { print_documentation( $DOC_USAGE ); },
    help  => sub { print_documentation( $DOC_HELP  ); },
    man   => sub { print_documentation( $DOC_MAN   ); },
  )){
    print_documentation( $DOC_USAGE );
  }

}

# --------------------------------------
#       Name: load_template
#      Usage: load_template();
#    Purpose: Loads the sub tamplate from file or <DATA>
# Parameters: none
#    Returns: none
#
sub load_template {

  if( -r $User_template_file ){

    local $INPUT_RECORD_SEPARATOR;
    open my $template_fh, '<', $User_template_file or die "could not open $User_template_file: $!\n";
    @Template = <$template_fh>;
    close $template_fh or die "could not close $User_template_file: $!\n";

  }elsif( -r $Template_file ){

    local $INPUT_RECORD_SEPARATOR;
    open my $template_fh, '<', $Template_file or die "could not open $Template_file: $!\n";
    @Template = <$template_fh>;
    close $template_fh or die "could not close $Template_file: $!\n";

  }else{

    # skip POD
    while( <DATA> ){
      last if m{ \A __DATA__ }msx;
    }

    # Read sub template
    while( <DATA> ){
      last if m{ \A __DATA__ }msx;
      push @Template, $_;
    }
  }

  return;
}

# --------------------------------------
#        Usage: %attributes = parse_variable( $variable );
#      Purpose: Find the attributes of a variable.
#      Returns: %attributes
#   Parameters: $variable
#
sub parse_variable {
  my $var = shift @_;
  my %attr = ();

  $attr{usage} = $var;
  $Max_length = length $var if $Max_length < length $var;

  if( $var =~ $RE_scalar ){
    $attr{name} = $1;
    $attr{type} = 'scalar';
    $attr{return_id} = $attr{usage};
  }elsif( $var =~ $RE_array ){
    $attr{name} = $1;
    $attr{type} = 'array';
    $attr{return_id} = $attr{usage};
  }elsif( $var =~ $RE_hash ){
    $attr{name} = $1;
    $attr{type} = 'hash';
    $attr{return_id} = $attr{usage};
  }elsif( $var =~ $RE_scalar_ref ){
    $attr{name} = $1; # . '_sref';
    $attr{type} = 'scalar_ref';
    $attr{return_id} = '$' . $attr{name};
  }elsif( $var =~ $RE_array_ref ){
    $attr{name} = $1; # . '_aref';
    $attr{type} = 'array_ref';
    $attr{return_id} = '$' . $attr{name};
  }elsif( $var =~ $RE_hash_ref ){
    $attr{name} = $1; # . '_href';
    $attr{type} = 'hash_ref';
    $attr{return_id} = '$' . $attr{name};
  }elsif( $var =~ $RE_code_ref ){
    $attr{name} = $1; # . '_cref';
    $attr{type} = 'code_ref';
    $attr{return_id} = '$' . $attr{name};
  }elsif( $var =~ $RE_typeglob ){
    $attr{name} = $1; # . '_gref';
    $attr{type} = 'typeglob';
    $attr{return_id} = '$' . $attr{name};
  }else{
    die "unknown variable type: $var\n";
  }

  $Max_var_len = length( $attr{name} ) + 1 if $Max_var_len < length( $attr{name} ) + 1;
  return %attr;
}

# --------------------------------------
#        Usage: parse_returns( $returns );
#      Purpose: Break the returns into variables and store them.
#      Returns: none
#   Parameters: $returns -- returned variables.
#
sub parse_returns {
  my $returns = shift @_;
  my $list_var = 0;

  return unless length $returns;

  if( $returns =~ s{ \+\= \z }{}msx ){
    $Assign_value = 0;
  }else{
    $returns =~ s{ \= \z }{}msx;
  }

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

    if( $Alt_returns ){
      $Alt_returns = { parse_variable( $Alt_returns ) };
      die "alternative return variable is not a scalar\n" if $Alt_returns->{type} ne 'scalar';
    }

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

    $Alt_returns = { parse_variable( $Alt_returns ) };
    die "alternative return variable is not a scalar\n" if $Alt_returns->{type} ne 'scalar';
    if( $Returns{$var} ++ ){
      die "Return parameter $var repeated\n";
    }
    my %attr = parse_variable( $var );
    push @Returns, { %attr };
  }else{
    if( $Returns{$returns} ++ ){
      die "Return parameter $returns repeated\n";
    }
    my %attr = parse_variable( $returns );
    push @Returns, { %attr };
  }

}

# --------------------------------------
#        Usage: parse_parameters( $params );
#      Purpose: Break the returns into variables and store them.
#      Returns: none
#   Parameters: $params -- list of variables.
#
sub parse_parameters {
  my $params = shift @_;
  my $opt_params = '';
  my $list_var = 0;

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

  for my $param ( split m{ \, }msx, $params ){
    if( $Parameters{$param} ++ ){
      die "Parameter $param repeated\n";
    }
    my %attr = parse_variable( $param );
    push @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( $Parameters{$param} ++ ){
      die "Parameter $param repeated\n";
    }
    my %attr = parse_variable( $param );
    push @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 ++;
    }
  }

}

# --------------------------------------
#        Usage: parse_usage_statement( $usage_statement );
#      Purpose: Break the usage statment into parts and store them in the
#               scratch variables.
#      Returns: none
#   Parameters: $usage_statement -- What to break into parts.
#
sub parse_usage_statement {
  my $usage_statement = shift @_;
  my $usage = $usage_statement; # working copy

  # Clear the scratch variables.
  $Sub_name     = '';
  $Max_length   = 0;
  $Max_var_len  = 0;
  @Returns      = ();
  %Returns      = ();
  $Assign_value = q{''};
  @Parameters   = ();
  %Parameters   = ();
  $Object_name  = '';
  $Alt_returns  = '';

  # Ignore whitespace
  $usage =~ s{ \s }{}gmsx;
  $usage =~ s{ \; \z }{}msx;

  my $returns_part = '';
  my $func_part = $usage;
  if( $usage =~ m{ \A ( [^=]* \= ) (.*) }msx ){
    $returns_part = $1;
    $func_part = $2;
  }
  if( $func_part =~ m{ = }msx ){
    die "Multiple assignments in usage statment\n";
  }

  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 ){
    $Object_name =  $1;
    $Max_var_len = 5 if $Max_var_len < 5;
  }
  $name_part =~ s{ \A \& }{}msx;

  parse_returns( $returns_part );
  parse_parameters( $param_part );

  $Sub_name = $name_part;
}

# --------------------------------------
#      Usage: write_sub_usage( $front_part, $back_part );
#    Purpose: Write out the usage statment.
#    Returns: none
# Parameters: $front_part -- Front part of line.
#             $back_part  -- Back part of line.
#
sub write_sub_usage {
  my $front_part = shift @_;
  my $back_part  = shift @_;
  my $usage = $Sub_name;
  my $returns = '';

  if( $Object_name ){
    $usage = qq{$Object_name->$Sub_name};
  }

  if( @Parameters ){
    my @params = ();
    for my $param ( @Parameters ){
      unless( $param->{optional} ){
        push @params, $param->{usage};
      }
    }
    my @opt_params = ();
    for my $param ( @Parameters ){
      if( $param->{optional} ){
        push @opt_params, $param->{usage};
      }
    }
    $usage .= '( ' . join( ", ", @params );
    if( @opt_params ){
      $usage .= '; '. join( ", ", @opt_params );
    }
    $usage .= ' )';
  }else{
    $usage .= '()';
  }

  if( @Returns > 1 ){
    $returns = '( ' . join( ", ", map { $_->{usage} } @Returns ) . ' ) = ';
  }elsif( @Returns ){
    $returns = $Returns[0]{usage} . ' = ';
  }

  $usage .= ';';

  if( $Alt_returns ){
    # print $front_part, $Alt_returns->{usage}, ' | ', $returns, $usage, $back_part;
    print $front_part, $Alt_returns->{usage}, ' = ', $usage, $back_part;
    $front_part =~ s{ [^#] }{ }gmsx;
    $back_part =~ s{ [^\n] }{ }gmsx;
  }
  print $front_part, $returns, $usage, $back_part;

}

# --------------------------------------
#      Usage: write_returns_comment( $front_part, $back_part );
#    Purpose: Write each variable returned as a comment.
#    Returns: none
# Parameters: $front_part -- Front part of line.
#             $back_part  -- Back part of line.
#
sub write_returns_comment {
  my $front_part = shift @_;
  my $back_part  = shift @_;

  if( not @Returns ){
    printf "%s%s%s", $front_part, 'none', $back_part;
    return;
  }

  my @list = @Returns;
  if( $Alt_returns && $Alt_returns->{usage} ne $list[0]{usage} ){
    unshift @list, $Alt_returns;
  }
  for my $var_ref ( @list ){
    # next if $Parameters{$var_ref->{usage}};
    printf "%s%*s -- TBD%s", $front_part, $Max_length, $var_ref->{usage}, $back_part;
    $front_part =~ s{ [^#] }{ }gmsx;
    $back_part =~ s{ [^\n] }{ }gmsx;
  }
}

# --------------------------------------
#      Usage: write_params_comment( $front_part, $back_part );
#    Purpose: Write each variable returned as a comment.
#    Returns: none
# Parameters: $front_part -- Front part of line.
#             $back_part  -- Back part of line.
#
sub write_params_comment {
  my $front_part = shift @_;
  my $back_part  = shift @_;

  if( not @Parameters ){
    printf "%s%s%s", $front_part, 'none', $back_part;
    return;
  }

  for my $var_ref ( @Parameters ){
    printf "%s%*s -- TBD%s", $front_part, $Max_length, $var_ref->{usage}, $back_part;
    $front_part =~ s{ [^#] }{ }gmsx;
    $back_part =~ s{ [^\n] }{ }gmsx;
  }
}

# --------------------------------------
#      Usage: write_parameters( $front_part, $back_part );
#    Purpose: Write out the parameters, one per line.
#    Returns: none
# Parameters: $front-part -- front part of the line.
#              $back-part -- back part of the line.
#
sub write_parameters {
  my $front_part = shift @_;
  my $back_part  = shift @_;

  if( $Object_name ){
    printf "%smy %-*s = %s%s", $front_part, $Max_var_len, '$self', 'shift @_;', $back_part;
  }

  for my $var_ref ( @Parameters ){
    if( $var_ref->{type} eq 'array' ){
      my $assigned = '@_;';
      printf "%smy %-*s = %s%s", $front_part, $Max_var_len, '@' . $var_ref->{name}, $assigned, $back_part;
    }elsif( $var_ref->{type} eq 'hash' ){
      my $assigned = '@_;';
      printf "%smy %-*s = %s%s", $front_part, $Max_var_len, '%' . $var_ref->{name}, $assigned, $back_part;
    }elsif( $var_ref->{type} eq 'typeglob' ){
      printf "%s%-*s = %s%s", $front_part, $Max_var_len, 'local( *' . $var_ref->{name} . ' )', 'undef;', $back_part;
    }else{
      my $assigned = 'shift @_;';
      if( $var_ref->{optional} ){
        $assigned = 'shift @_ || \'\';';
      }
      printf "%smy %-*s = %s%s", $front_part, $Max_var_len, '$' . $var_ref->{name}, $assigned, $back_part;
    }
  }
}

# --------------------------------------
#      Usage: write_returns( $front_part, $back_part );
#    Purpose: Write out the returns, one per line.
#    Returns: none
# Parameters: $front-part -- front part of the line.
#              $back-part -- back part of the line.
#
sub write_returns {
  my $front_part = shift @_;
  my $back_part  = shift @_;

  my @list = @Returns;
  if( $Alt_returns && $Alt_returns->{usage} ne $list[0]{usage} ){
    unshift @list, $Alt_returns;
  }
  for my $var_ref ( @list ){
    next unless ref( $var_ref ) eq 'HASH';
    next if $Parameters{$var_ref->{usage}};
    if( $var_ref->{type} eq 'array' ){
      printf "%smy %-*s = %s%s", $front_part, $Max_var_len, '@' . $var_ref->{name}, '();', $back_part;
    }elsif( $var_ref->{type} eq 'hash' ){
      printf "%smy %-*s = %s%s", $front_part, $Max_var_len, '%' . $var_ref->{name}, '();', $back_part;
    }elsif( $var_ref->{type} eq 'scalar_ref' ){
      printf "%smy %-*s = %s%s", $front_part, $Max_var_len, '$' . $var_ref->{name}, 'undef;', $back_part;
    }elsif( $var_ref->{type} eq 'array_ref' ){
      printf "%smy %-*s = %s%s", $front_part, $Max_var_len, '$' . $var_ref->{name}, '[];', $back_part;
    }elsif( $var_ref->{type} eq 'hash_ref' ){
      printf "%smy %-*s = %s%s", $front_part, $Max_var_len, '$' . $var_ref->{name}, '{};', $back_part;
    }elsif( $var_ref->{type} eq 'code_ref' ){
      printf "%smy %-*s = %s%s", $front_part, $Max_var_len, '$' . $var_ref->{name}, 'sub {};', $back_part;
    }elsif( $var_ref->{type} eq 'typeglob' ){
      printf "%slocal( %-*s = %s%s", $front_part, $Max_var_len, '*' . $var_ref->{name} . ' )', 'undef;', $back_part;
    }else{
      printf "%smy %-*s = %s;%s", $front_part, $Max_var_len, '$' . $var_ref->{name}, $Assign_value, $back_part;
    }
  }
}

# --------------------------------------
#      Usage: write_return_statement( $front_part, $back_part );
#    Purpose: Write the returns.
#    Returns: none
# Parameters: $front-part -- front part of the line.
#              $back-part -- back part of the line.
#
sub write_return_statement {
  my $front_part = shift @_;
  my $back_part  = shift @_;

  if( $Alt_returns ){
    if( @Returns == 1 && $Returns[0]{type} eq 'array' ){
      print $front_part, 'return wantarray ? ', $Returns[0]{return_id}, ' : ', $Alt_returns->{return_id}, ';', $back_part;
    }else{
      my $returns = $Alt_returns->{return_id};
      my @returns = ();
      for my $return ( @Returns ){
        push @returns, $return->{return_id};
      }
      print $front_part, 'return wantarray ? ( ', join( ", ", @returns ), ' ) : ', $returns, ';', $back_part;
    }
  }elsif( @Returns > 1 ){
    print $front_part, 'return ( ', join( ", ", map { $_->{return_id} } @Returns ), ' );', $back_part;
  }elsif( @Returns ){
    print $front_part, 'return ', $Returns[0]{return_id}, ';', $back_part;
  }else{
    print $front_part, 'return;', $back_part;
  }
}

# --------------------------------------
#      Usage: write_sub()
#    Purpose: Write the sub template.
#    Returns: none
# Parameters: none
#
sub write_sub {

  for my $line ( @Template ){
    if( $line =~ m{ (.*?) \e\[1m \( ($RE_id) \) \e\[0?m (.*) \z }msx ){
      my $front_part = $1;
      my $id = $2;
      my $back_part = $3;
      if( $id eq 'sub_name' ){
        print $front_part, $Sub_name, $back_part;
      }elsif( $id eq 'usage' ){
        write_sub_usage( $front_part, $back_part );
      }elsif( $id eq 'returns_comment' ){
        write_returns_comment( $front_part, $back_part );
      }elsif( $id eq 'parameters_comment' ){
        write_params_comment( $front_part, $back_part );
      }elsif( $id eq 'parameters' ){
        write_parameters( $front_part, $back_part );
      }elsif( $id eq 'returns' ){
        write_returns( $front_part, $back_part );
      }elsif( $id eq 'return_statement' ){
        write_return_statement( $front_part, $back_part );
      }else{
        die "unknown template keyword: $id";
      }
    }else{
      print $line;
    }
  }
}

# --------------------------------------
#      Usage: process_usage_statement( $usage_statement );
#    Purpose: To parse and validate the usage statment and create the skeleton of the sub.
#    Returns: none
# Parameters: $usage_statement -- the text containing the usage statment.
#
sub process_usage_statement {
  my $usage_statement = shift @_;

  eval { parse_usage_statement( $usage_statement ) };
  if( $@ ){
    chomp $usage_statement;
    print STDERR "$usage_statement: $@\n";
    return;
  }

  write_sub();
}

# --------------------------------------
# Main

initialize_program();
load_template();

if( $Command_line ){
  for ( @ARGV ){
    process_usage_statement( $_ );
  }
}else{
  while( <> ){
    next if m{ \A \s* \z }msx;
    next if m{ \A \s* \# }msx;
    process_usage_statement( $_ );
  }
}

__END__

=head1 NAME

sub - Perl sub Code Generator

=head1 VERSION

This document refers to sub, version 1.0.1

=head1 USAGE

  sub [<file>] ...
  sub --commandline <usage_statement> ...
  sub --usage|help|man

=head1 REQUIRED ARGUMENTS

none

=head1 OPTIONS

=over 4

=item --commandline

The usage statements are the command-line arguments, one per argument. These
should be escaped from the shell.

=item --usage

Print a brief usage message.

=item --help

Print usage, required arguments, and options.

=item --man

Print the manual page.

=back

=head1 DESCRIPTION

This utility creates Perl sub from a usage statement via a
template.  The template file is C<~/.subrc> if present, else
C</etc/subrc> if present, else and internal tamplate is
used.  If this file is not present, an internal template is
used.  This internal template is stored at the end of the
source file.  The code generated includes reminders for
documentation.

A Usage Statement is B<not valid> Perl code.  This is
because it is difficult to distinguish a scalar and a
reference.  Instead, parameters and returns are written with
the take-a-reference-to notation.  For example, a reference
to an array is written as C<\@array>.  See L<EXAMPLES>.

Parameters and returns that are references have an extension
added to indicate this.  Do not name any of your variables
with these extensions or you may get confused.

  Reference    Variable
  ----------   -----------
  \$scalar     $scalar_s
  \@array      $array_a
  \%hash       $hash_h
  \&code       $code_c
  \*typeglob   $typeglob_g

=head1 EXAMPLES

=head2 Example of a Simple Usage Statement

=over 4

=item Usage Statement:

  $a = foo( $x );

=item Code generated:

  # --------------------------------------
  #      Usage: $a = foo( $x );
  #    Purpose: TBD
  #    Returns: $a -- TBD
  # Parameters: $x -- TBD
  #
  sub foo {
    my $x = shift @_;
    my $a = '';

    return $a;
  }

=back

=head2 Example of Lists of Returns and Optional Parameters

=over 4

=item Usage Statement:

  ( $a, $b, @c ) = foo( $x, $y; $z, %w );

=item Code generated:

  # --------------------------------------
  #      Usage: ( $a, $b, @c ) = foo( $x, $y; $z, %w );
  #    Purpose: TBD
  #    Returns: $a -- TBD
  #             $b -- TBD
  #             @c -- TBD
  # Parameters: $x -- TBD
  #             $y -- TBD
  #             $z -- TBD
  #             %w -- TBD
  #
  sub foo {
    my $x = shift @_;
    my $y = shift @_;
    my $z = shift @_ || '';
    my %w = @_;
    my $a = '';
    my $b = '';
    my @c = ();

    return ( $a, $b, @c );
  }

=back

=head2 Examples of C<wantarray> Returns and References

=over 4

=item Usage Statement:

  $a | ( $a, \@b, \%c, %d ) = foo( \@x, \%y, @z );

=item Code generated:

  # --------------------------------------
  #      Usage: ( $a, \@b, \%c, %d ) = foo( \@x, \%y, @z );
  #             $a = foo( \@x, \%y, @z );
  #    Purpose: TBD
  #    Returns:  $a -- TBD
  #             \@b -- TBD
  #             \%c -- TBD
  #              %d -- TBD
  # Parameters: \@x -- TBD
  #             \%y -- TBD
  #              @z -- TBD
  #
  sub foo {
    my $x_a = shift @_;
    my $y_h = shift @_;
    my @z   = @_;
    my $a   = '';
    my $b_a = [];
    my $c_h = {};
    my %d   = ();

    return wantarray ? ( $a, $b_a, $c_h, %d ) : $a;
  }

=item Usage Statement:

  $text | @text = trim( @text );

=item Code generated:

  # --------------------------------------
  #      Usage: @text = trim( @text );
  #             $text = trim( @text );
  #    Purpose: TBD
  #    Returns: $text -- TBD
  # Parameters: @text -- TBD
  #
  sub trim {
    my @text = @_;
    my $text = '';

    return wantarray ? @text : $text;
  }

=item Usage Statement:

  \%options = $object->get_options( ; @option_names );

=item Code generated:

  # --------------------------------------
  #       Name: get_options
  #      Usage: \%options = $object->get_options( ; @option_names );
  #    Purpose: TBD
  # Parameters: @option_names -- TBD
  #    Returns:     \%options -- TBD
  #
  sub get_options {
    my $self         = shift @_;
    my @option_names = @_;
    my $options      = {};

    return $options;
  }

=back

=head1 DEPENDENCIES

Perl 5.8

=head1 ORIGINAL AUTHOR

Mr. Shawn H. Corey

=head2 Contributing Authors

(Insert your name here if you modified this program or its documentation.)

=head1 COPYRIGHT & LICENCES

Copyright 2006 by Mr. Shawn H. Corey.  All rights reserved.

=head2 Software Licence

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

=head2 Document Licence

Permission is granted to copy, distribute and/or modify this document under the
terms of the GNU Free Documentation License, Version 1.2 or any later version
published by the Free Software Foundation; with the Invariant Sections being
ORIGINAL AUTHOR, COPYRIGHT & LICENCES, Software Licence, and Document Licence.

You should have received a copy of the GNU Free Documentation Licence
along with this document; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

=head1 HISTORY

  $Log: sub,v $
  Revision 1.1.1.1  2008/06/30 14:28:06  shawnhcorey
  initial version


=cut

__DATA__
# --------------------------------------
#       Name: (sub_name)
#      Usage: (usage)
#    Purpose: TBD
# Parameters: (parameters_comment)
#    Returns: (returns_comment)
#
sub (sub_name) {
  (parameters)
  (returns)

  (return_statement)
}