File Coverage

blib/lib/Getopt/CallingName.pm

Criterion	Covered	Total	%
statement	36	37	97.3
branch	5	6	83.3
condition	4	4	100.0
subroutine	9	9	100.0
pod	1	1	100.0
total	55	57	96.4

=head1 NAME

Getopt::CallingName - Script duties delegation based upon calling name

=head1 SYNOPSIS

 use Getopt::CallingName;
 call_name(
           name_prefix => 'tv_',
           args        => \@my_array,
           );

=head1 DESCRIPTION

Sometimes  you  can  have a script   that  can run   in two or  more  'modes' of
operation. Apart  from an option  to specify the mode,  the command line options
are the same/very similar. Much of the code used by the various modes is common.

As an application user interface  decision, it may  be more useful/helpful to be
able to call the script by two or more names - i.e. one for each mode. This cuts
out the command line option for specifying the mode.

In some cases it might be appropriate just to move all the code, or at least all
the common  code, into  a  module and have separate   wrapper perl scripts.  The
problem with this approach is either you end up  duplicating command line option
handling in each of  the wrapper scripts or you  end up moving the  command line
option handling  into a module  also.   The former  case introduces  maintenance
burden  [or perhaps an excuse  to  use TT2 to   generate your wrappers ;-)]. The
latter case can feel like a distortion/displacement of the code.

Getopt::CallingName provides another  alternative.  The idea  is that you create
symbolic links to  your actual script (which you   might want to give  a generic
name). Each symbolic link corresponds  to the name/mode with  which you call the
script.  Within your script, after  any  common setup/options handling you  call
subroutine call_name to call the appropriate script subroutine for the mode.

=head1 PUBLIC INTERFACE

=cut



package Getopt::CallingName;



# pragmata
use 5.006;
use base qw(Exporter);
use strict;
use warnings;

# Standard Perl Library and CPAN modules
use Carp qw(croak);
use English qw( -no_match_vars);


our @EXPORT = qw(call_name);
our $VERSION = '1.18';

#
# PUBLIC CLASS METHODS
#



=head2 Public Class Methods

=head3 call_name

 call_name(
            args          => $ra_args,
            name_prefix   => $name_prefix,
            method_prefix => $method_prefix,
            method_suffix => $method_suffix,
           )

call_name accepts the following optional arguments:

  method_prefix - string to prepend to the calculated method name

  method_suffix - string to append to the calculated method name

  name_prefix - string to chop off the front  of the script name when calculating
               the method  name.  Useful if all  your  modes have a common
               prefix (tv_record, tv_play ...)

  args         - reference to an array which should be passed to the called sub.

call_name returns whatever the called subroutine returns.

call_name checks the subroutine it is going to call to ensure it exists. If it
does not exist, call name throws an 'exception' using Carp::croak.

=cut

sub call_name {
	my(%args) = @_;
	my $name = _get_name(%args);
	my @args = ($args{args}) ? @{$args{args}} : ();

	croak "Unable to call subroutine corresponding to name, &main::$name does not exist" unless(defined &{"main::$name"});

	{
		package main;
		no strict 'refs';
		return $name->(@args);
	}

	1;
}


#
# PRIVATE CLASS METHODS
#



=head1 INTERNALS

=head2 Private Class Methods

=head3 _get_name

 _get_name(
            name_prefix   => $name_prefix,
            method_prefix => $method_prefix,
            method_suffix => $method_suffix,
           )

Returns the $PROGRAM_NAME after     removing any path, prefix  (optional)    and
extension. Adds and optional method prefix and/or suffix as specified.

=cut

sub _get_name {
	my(%args) = @_;

	my($name) =  $PROGRAM_NAME =~ m!^(?:(?:.*)/)?([^.]*)!;
	$name =~ s/^$args{name_prefix}// if(defined $args{name_prefix});

	$args{method_suffix} ||= '';
	$args{method_prefix} ||= '';

	$name  = $args{method_prefix} . $name . $args{method_suffix};

	return $name;
}

1;

=head1 INSTALLATION

To install this module type the following:

   perl Makefile.PL
   make
   make test
   make install

=head1 DEPENDENCIES

This  module works only  with  perl v5.6 and higher.  I   am more than happy  to
backport to an earlier perl 5.x if someone using an old  perl would like to make
use of  my module. Mail  me  and ask me to  do  the work  [or  even better do it
yourself and send in a patch! ;-)]

This module requires these other modules and libraries:

 Carp
 Test::More

The first is required for its operation. The second is for testing purposes

This module has these optional dependencies:

 File::Find::Rule
 Test::Pod (0.95 or higher)

These are both just requried for testing purposes.

=head1 POSSIBLE ENHANCEMENTS

=over 4

=item *

Add a more general method name translation hook

=back

=head1 BUGS

None known at time  of writing.  To report a  bug or request an enhancement  use
CPAN's excellent Request Tracker:

L

=head1 SOURCE AVAILABILITY

This source is part of a SourceForge project which always has the
latest sources in svn.

http://sourceforge.net/projects/sagar-r-shah/

=head1 AUTHOR

Sagar R. Shah

=head1 COPYRIGHT

Copyright 2003-2007, Sagar R. Shah, All rights reserved

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut