view release on metacpan or  search on metacpan

QWizard.pm  view on Meta::CPAN

package QWizard;

our $VERSION = '3.15';
require Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw(qwdebug qwisdebugon qwparam qwparams qwpref
		 qw_upload_fh qw_upload_file
		 qw_required_field qw_integer qw_optional_integer
		 qw_check_int_ranges qw_check_length_ranges
                 qw_hex qw_optional_hex qw_check_hex_and_length);

use Data::Dumper;
our $qwdebug = 0;
our $qwdebug_indent = 0;
our $qwvar;
our $qwcurrent;

our %states = ( ASKING => 1,
		CONFIRMING => 2,
		ACTING => 3,
		FINISHED => 4,
		CANCELED => 5,
	      );

our $PRIM_NOTDONE  = 0;
our $PRIM_DONE     = 1;
our $PRIM_ANSWERED = 2;

use strict;

sub new {
    my $type = shift;
    $qwdebug_indent = 0;
    my ($class) = ref($type) || $type;
    my $self;
    %$self = @_;
    map { $self->{'primaries'}{$_}{'module_name'} = $_ } 
      keys(%{$self->{'primaries'}});
    if (!$self->{'generator'}) {
	eval { require QWizard::Generator::Best; };
	$self->{'generator'} =
	  new QWizard::Generator::Best(@{$self->{'generator_args'}});
	die "Can't create a suitable QWizard generator"
	  if (!defined($self->{'generator'}));
    }

    bless($self, $class);

    $self->qwsetdebug();

    #
    # Get the URI preference option and set our preferences.
    #
    my $npprefs = $self->{'npprefs'} || "";
    $npprefs =~ s/&np-prefs=//;
    parseprefs($self,$npprefs);

    # remember ourselves for later usage
    $qwcurrent = $self;

    return $self;
}

#
# $wiz->run_hooks(NAME, HOOK_ARGS)
#   runs all hooks bound to NAME with a passed reference to QWIZARD,
#   earlier passed MAGIC_ARGS (see below) and a copied ARGS in an array 
#   reference, which is passed in from the calling args.  The result is:
#
#     CODE->($wiz, MAGIC_ARGS, [HOOK_ARGS])
#
sub run_hooks {
    my $self = shift;
    my $hookname = shift;
    my @args = @_;
    qwdebug("checking for hooks on $hookname");
    if (exists($self->{'hooks'}{$hookname})) {
	foreach my $hook (@{$self->{'hooks'}{$hookname}}) {
	    qwdebug("running a hook for $hookname");
	    $hook->{'code'}($self, @{$hook->{'args'}}, \@args);
	}
    }
}

#
# $wiz->add_hooks(NAME, SUB_REF, MAGIC_ARGS)
#   Adds a SUB_REF code block to the NAME set of hooks.  Optionally, a
#   set of MAGIC_ARGS may be passed as well.  For portability ease, it is
#   suggested that MAGIC_ARGS be a single argument of an array reference
#   of any arguments that need passing.
#
sub add_hook {
    my $self = shift;
    my $hookname = shift;
    my $coderef = shift;
    my @magic_args = @_;
    my $hook_definition = {'code' => $coderef};
    push @{$self->{'hooks'}{$hookname}}, $hook_definition;
    if ($#magic_args > -1) {
	$hook_definition->{'args'} = \@magic_args;
    }
}

########################################################################
# parseprefs()
#
# Valid preferences and their values:
#	pref_debug      0, 1
#	pref_history    dont, sidebar, frame
#	pref_intro      0, 1
#
sub parseprefs {
    my $self = shift;			# Me.
    my $prefs = shift;			# Preference argument from URI.
    my @preflist;			# List of preferences.
    my $pcnt;				# Number of preferences.
    my $prefstr;			# Preference string.

    #
    # Break the URI preference argument up into individual preferences.
    #
    @preflist = split(',',$prefs);
    $pcnt = @preflist;

    #
    # Examine each preference individually, ensuring the name and value
    # are both valid.
    #
    for(my $ind=0;$ind<$pcnt;$ind++)
    {
	my @pieces;			# Preference pieces.
	my $prefname;			# Name of preference.
	my $prefval;			# Value of preference.

	@pieces = split('=',$preflist[$ind]);
	$prefname = "pref_" . $pieces[0];
	$prefval  = $pieces[1];

	#
	# Check the validity of the preference name and value.
	#
	if($prefname eq "pref_debug")
	{
		if(($prefval != 0) && ($prefval != 1))
		{
			warn "QW:parseprefs:  invalid value \"$prefval\" for preference \"$prefname\"\n";
			next;
		}
	}
	elsif($prefname eq "pref_history")
	{
		if(($prefval ne "dont") && ($prefval ne "frame") &&
		   ($prefval ne "sidebar"))
		{
			warn "QW:parseprefs:  invalid value \"$prefval\" for preference \"$prefname\"\n";
			next;
		}
	}
	elsif($prefname eq "pref_intro")
	{
		if(($prefval != 0) && ($prefval != 1))
		{
			warn "QW:parseprefs:  invalid value \"$prefval\" for preference \"$prefname\"\n";
			next;
		}
	}
	else
	{
		warn "QW:parseprefs:  unknown preference \"$prefname\"\n";
		next;
	}

	#
	# Set the preference value.
	#
# warn "QW:parseprefs:  setting \"$prefname\" to $prefval\n\n";
	$self->qwpref($prefname,$prefval);
	$self->qwparam($prefname,$prefval);
    }

}

#
# Primary manipulation routines
#
sub get_primary {
    my ($self, $namefull) = @_;

    my $name = drop_remap_prefix($namefull);
    if ($self->{'primaries'}{$name}) {
	return $self->{'primaries'}{$name}
    }
}

sub add_primary {
    my $self = shift;
    my $name = shift;
    my %primary = @_;

    $self->{'primaries'}{$name} = \%primary;
    $self->{'primaries'}{$name}{'name'} = $name
      if (!$self->{'primaries'}{$name}{'name'});
    return \%primary;
}

sub merge_primaries {
    my $self = shift;
    my $primaries = shift;
    foreach my $i (keys(%$primaries)) {
	$self->{'primaries'}{$i} = $primaries->{$i};
	$self->{'primaries'}{$i}{'name'} = $i
	  if (!$self->{'primaries'}{$i}{'name'});
    }
}


#
# Functions that actually do the work
#
sub magic {
  my $self = shift;

  $self->{'last_screen'} = 0;

  $self->run_hooks('start_magic');
  do {
      qwdebug("------------------------------------------------------------------");
      qwdebug("incoming: " . ref($self->{'generator'}) . " :" 
	      . ($self->qwparam('pass_vars') || ""));
      qwdebug("incoming variables: " . ($self->qwparam('pass_vars') || ""));
      qwdebug("incoming stack: " . ($self->qwparam('qwizard_tree') || ""));
      if ($self->qwparam('disp_help_p')) {
	  $self->display_help();
      } elsif (!$self->qwparam('qw_cancel') && $self->qwparam('pass_vars')) {
	  qwdebug("called with an existing todo list, continuing to work.");
	  $self->keep_working(@_);