File Coverage

blib/lib/CLI/Application.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package CLI::Application;

use strict;
use warnings;


use Carp;

use Text::Table;

use Attribute::Handlers;

use Module::Pluggable;
use Module::Load;


our $VERSION = '0.03';

our %ACTION;
our $FALLBACK;
our $AUTOLOAD;


sub new {
	my ($class, %rc) = @_;
	return bless \%rc, $class;
}


# Take a list of command line arguments and prepare the application for
# execution by parsing options, detecting the action to perform, loading
# plugins and so on.
sub prepare {
	my ($self, @argv) = @_;

	my $wanted = $self->{options} || [];
	my @rest;
	my %option;
	my $class = ref $self;

	# Get list of available plugins.
	my %plugin = map { $_ => 0 } $self->plugins;

	$self->{plugged} = {};

	# Load plugins.
	if($self->{plugins}) {
		while(my ($plugin, $param) = each %{$self->{plugins}}) {
			my $package = $class . '::Plugin';

			# Allow leaving 'CLI::Application::Plugin::' away.
			if($plugin !~ /^$package/) {
				$plugin = $class . '::Plugin::' . $plugin;
			}

			die "Plugin $plugin not found.\n" unless exists($plugin{$plugin});

			load $plugin;

			my $instance = $plugin->new(%$param);

			# Assign the instance of the plugin to each exported method.
			$self->{plugged}->{$_} = $instance for($plugin->export);
		}
	}


	# Parse options from command line arguments.
	while(my $arg = shift(@argv)) {

		# Save non-option arguments.
		if($arg =~ /^[^-]/) {
			push @rest, $arg;
		}

		# Save everything after '--'.
		elsif($arg eq '--') {
			push @rest, @argv;
			last;
		}

		# Get long options.
		elsif($arg =~ /^--(.+?)(?:=(.*))?$/) {
			my ($key, $value) = ($1, $2);
			my $option = $self->_option($key);

			if($option->[2]) {
				$value = shift @argv unless defined $value;

				die $self->usage("Missing argument for option --$key.")
					unless defined $value;

				if(!$self->_validate_option($option->[2], $value)) {
					my $error = "Wrong argument for option --$key.";
					$error .= ' ' . $option->[3] if($option->[3]);
					die $self->usage($error);
				}

				$option{$_} = $value for(@{$option->[0]});
			}
			else {
				$option{$_} = !0 for(@{$option->[0]});
			}
		}

		# Get short options.
		elsif($arg =~ /^-([^-].*)$/) {
			my $all = $1;

			while($all) {
				$all =~ s/^(.)//;
				my $key = $1;

				my $option = $self->_option($key);

				if($option->[2]) {
					if($all) {
						$option{$_} = $all for(@{$option->[0]});
						last;
					}
					else {
						my $value = shift @argv;

						die $self->usage("Missing argument for option -$key.")
							unless(defined $value);

						if(!$self->_validate_option($option->[2], $value)) {
							my $error = "Wrong argument for option -$key.";
							$error .= ' ' . $option->[3] if($option->[3]);
							die $self->usage($error);
						}

						$option{$_} = $value for(@{$option->[0]});
					}
				}
				else {
					$option{$_} = !0 for(@{$option->[0]});
				}
			}
		}

		else {
			die "Don't know what to do with '$arg'.\n";
		}
	}

	$self->{parsed} = \%option;
	$self->{rest} = \@rest;

	delete $self->{action};
}


# Take an error message and print it together with our usage information.
sub usage {
	my ($self, @message) = @_;

	my $usage = $self->_usage;

	local $" = ' ';
	$usage = "@message\n\n$usage" if @message;

	return $usage . "\n";
}


# Return (and set) the action we're going to dispatch to.
sub action {
	my ($self, $action) = @_;

	if(defined $action and !$ACTION{$action}) {
		die "Unknown action '$action'.\n";
	}

	if(defined $action) {
		$self->{action} = $action;
	}
	elsif(!$self->{action}) {
		# Get command from remaining arguments or take default action.
		my $command = (shift @{$self->{rest}}) || $FALLBACK;

		die $self->usage("No action.") unless $command;

		if($ACTION{$command}) {
			$self->{action} = $command;
		}
		else {
			die $self->usage("No such command.");
		}
	}

	return $self->{action};
}


# Return (and set) the value of an option.
sub option {
	my ($self, $option, $argument) = @_;

	if(@_ == 3) {
		$self->{parsed}->{$option} = $argument;
	}

	return $self->{parsed}->{$option};
}


# Dispatch to the given action or the action parsed from command line
# arguments.
sub dispatch {
	my ($self, $action) = @_;

	$action ||= $self->action || $FALLBACK;

	my $code = $ACTION{$action}->{code};

	return &{$code}($self) if($code);

	die "Nothing to do.\n";
}


# Return the applications name.
sub name { $_[0]->{name} }


# Return anything from the command line that's left after parsing options and
# commands.
sub arguments { return @{$_[0]->{rest}} }


# Generate a help message with all valid commands and options and return it.
sub _usage {
	my ($self) = @_;

	my $usage = "Usage: $0 [options] \n";

	if(%ACTION) {
		my $table = new Text::Table;

		while(my ($name, $hash) = each %ACTION) {
			$table->add("\t" . $name, '-- ' . $hash->{text});
		}

		$usage .= "\nACTIONS\n" . $table->table . "\n";
	}

	my $options = $self->_option_usage;
	$usage .= "\nOPTIONS\n$options\n" if($options);

	return $usage;
}


# Return a formatted table of valid options using Text::Table.
sub _option_usage {
	my ($self) = @_;

	if($self->{options} and @{$self->{options}}) {
		my $table = new Text::Table;

		for my $option (@{$self->{options}}) {
			my ($flags, $description, $validate) = @{$option};

			my @aliases;

			for my $flag (@{$flags}) {
				push @aliases, (length($flag) < 2 ? '-' : '--') . $flag;
			}

			$flags = join(' | ', @aliases);

			if($validate) {
				if(ref($validate)) {
					if(ref($validate) eq 'ARRAY') {
						$validate = '[' . join(' | ', @{$validate}) . ']';
					}
					else {
						$validate = '<...>';
					}
				}

				$flags .= ' ' . $validate;
			}

			$description ||= "Don't know what this option is good for.";

			$table->add(
				$flags,
				' -- ' . $description,
			);
		}

		return $table->table;
	}

	return '';
}


# Searches the options array for an option matching the given string and
# returns the first option that has a matching option flag.
sub _option {
	my ($self, $needle) = @_;

	my $list = $self->{options} || [];

	for my $option (@$list) {
		return $option if grep { $_ eq $needle } @{$option->[0]};
	}

	die $self->usage("Unknown option '$needle'.\n");
}


# Take an option from the arguments hash and a value from the command line,
# check if the value is vaid for the option.
sub _validate_option {
	my ($self, $validate, $value) = @_;

	if(ref($validate)) {
		my $type = uc ref $validate;

		if($type eq 'ARRAY') {
			return grep { $_ eq $value } @{$validate};
		}

		elsif($type eq 'REGEXP' or $type eq 'SCALAR') {
			$validate = qr/${$validate}/ if($type eq 'SCALAR');

			return $value =~ $validate;
		}

		elsif($type eq 'HASH') {
			# Don't know what to do with hashes yet.
		}

		elsif($type eq 'CODE') {
			return &{$validate}($value);
		}
	}

	return !0;
}


# Attribute to mark functions as commands.
sub UNIVERSAL::Command : ATTR(CODE) {
	my ($package, $symbol, $code, $attribute, $data, $phase) = @_;

	$ACTION{*{$symbol}{NAME}} = {
		code => $code,
		text => ref($data)
			? $data->[0]
			: 'I have no idea what this action does.',
	};
}


# Attribute to mark a default command.
sub UNIVERSAL::Fallback : ATTR(CODE) {
	my ($package, $symbol, $code, $attribute, $data, $phase) = @_;

	$FALLBACK = *{$symbol}{NAME};
}


# AUTOLOAD method to call plugin methods.
sub AUTOLOAD {
	my $self = shift;

	my ($method) = (split /::/, $AUTOLOAD)[-1];
	my $module = $self->{plugged}->{$method};

	croak "Unknown method '$method' in ", ref($self) unless $module;

	return $module->$method($self, @_);
}


sub DESTROY {
	my ($self) = @_;

	delete $self->{plugged};
}


!0;

__END__