/usr/local/CPAN/QWizard/QWizard/Generator.pm
package QWizard::Generator;
use AutoLoader;
use POSIX qw(isprint);
use strict;
our $VERSION = '3.15';
use QWizard::Storage::Memory;
require Exporter;
use File::Temp qw(tempfile);
use IO::File;
@QWizard::Generator::ISA = qw(Exporter);
@QWizard::Generator::EXPORT = qw(qwdebug qwpref);
our $AUTOLOAD;
# just a base class.
#
# functions to implement:
# radio
# default do-nothing subroutines. These are optional in sub-generators.
sub do_question_end {}
sub start_questions {}
sub end_questions {}
sub do_pass {};
sub new {
die "should not be called directly\n";
}
sub init_default_storage {
my $self = shift;
$self->{'datastore'} = new QWizard::Storage::Memory();
$self->{'prefstore'} = new QWizard::Storage::Memory();
$self->{'tmpdir'} = "/tmp" if (!$self->{'tmpdir'});
}
# widgets that have fallbacks to more minimal widgets:
sub do_textbox {
my $self = shift;
$self->do_entry(@_);
}
sub do_paragraph {
my $self = shift;
$self->do_label(@_);
}
our $have_gd_graph = eval { require GD::Graph::lines; };
our $have_chart_graph = eval { require Chart::Lines; };
our $def_width = 400;
our $def_height = 400;
#
# returns a quantized X dataset from a sorted but non-linear x dataset
#
# INPUT points:
# [[X1, Y1],[X2, Y2]]
# OUTPUT quantized WIDTH number of buckets:
# [[min(X1), Y1], [min(X1)+(maxx-minx)/WIDTH, YJ]]
#
sub binize_x_data {
my ($self, $multidata, $q, $width) = @_;
my ($minx, $maxx);
my ($newdata, $x, $xlab);
if (!$q->{'multidata'}) {
$multidata = [$multidata];
}
# calculates min and max X values from the datasets
foreach my $data (@$multidata) {
if (!defined($minx) || $minx > $data->[0][0]) {
$minx = $data->[0][0];
}
if (!defined($maxx) || $maxx < $data->[$#$data][0]) {
$maxx = $data->[$#$data][0];
}
}
my $diff = $maxx - $minx;
if ($diff == 0) {
print STDERR "no data to graph (time diff = 0)!\n";
print STDERR "minx: $minx, maxx: $maxx\n";
return [[]];
}
my $addative = 0;
foreach my $data (@$multidata) {
my $numc = $#{$data->[0]};
foreach my $d (@$data) {
my $xval = int($width * (($d->[0] - $minx) / $diff));
if (!exists($newdata->[0][$xval])) {
$newdata->[0][$xval] = $d->[0];
}
for ($x = 1; $x <= $numc; $x++) {
$newdata->[$x + $addative][$xval] = $d->[$x];
}
}
if (!$addative) {
# first row contained the indexes
$addative = -1;
}
$addative += $numc+1;
}
for (my $i = 0; $i <= $#$newdata; $i++) {
for ($x = 1; $x <= $#{$newdata->[$i]}; $x++) {
if (!exists($newdata->[$i][$x])) {
$newdata->[$i][$x] = $newdata->[$i][$x-1];
}
}
}
return $newdata;
}
sub do_graph_data {
my ($self, $q, $wiz, $p, $data, $gopts) = @_;
my ($w, $h) = ($def_width, $def_height);
my @gopts = (
bgclr => 'white',
transparent => 0,
brush_size => 3,
max_x_ticks => 10,
);
push @gopts, @$gopts if ($gopts);
my %gopts = @gopts;
$gopts = \@gopts;
$w = $gopts{'-width'} if (exists($gopts{'-width'}));
$h = $gopts{'-height'} if (exists($gopts{'-height'}));
return if (!$have_chart_graph || !$have_gd_graph);
$data = $self->binize_x_data($data, $q, $w) if (!$q->{'already_in_bins'});
if ($have_chart_graph && !$q->{'use_gd_graph'}) {
my $charttype = "Lines";
$charttype = $gopts{'-charttype'} if (exists($gopts{'-charttype'}));
# create the graph
my $gph = eval("require Chart::$charttype; return Chart::" . $charttype . '->new($w, $h);');
# change various plotting conventions from GD::Graph to Chart::Lines
my %converts =
qw(
legend legend_labels
x_number_format f_x_tick
y_number_format f_y_tick
);
foreach my $k (keys(%converts)) {
if (exists($gopts{$k})) {
push @gopts, $converts{$k} => $gopts{$k};
}
}
# XXX: hack to get around a collision
push @gopts, 'legend', 'right';
# XXX: forced options
push @gopts, skip_x_ticks => ($w/6);
# set the options to the passed list
$gph->set(@$gopts) if (defined($gopts));
# plot everything to a file
my %hg = %gopts;
my ($fh, $fname) = $self->create_temp_fh(".png");
$gph->png($fh, $data);
# Ugh... we should be able to return either data or a file
# XXX: the sad thing is that later this is probably put into a file
$fh = new IO::File;
$fh->open("<$fname");
my ($fdata, $outdata);
while ($fh->read($fdata, 512)) {
$outdata .= $fdata;
}
return $outdata;
}
if ($have_gd_graph) {
my $gph = GD::Graph::lines->new($w, $h);
$gph->set(@$gopts) if (defined($gopts));
my %hg = %gopts;
$gph->set_legend(@{$hg{'legend'}}) if (exists($hg{'legend'}));
my $plot = $gph->plot($data);
if (!$plot) {
print STDERR "plot: " . $gph->error . "\n";
return;
}
return $plot->png ||
print STDERR "do_graph_data error: $gph->error\n";
}
}
# Default storage = variable space
sub qwparam {
my $self = shift;
return $self->{'datastore'}->access(@_);
}
sub backup_params {
my $self = shift;
if ($#{$self->{'backupvars'}} > ($self->{'maxbackups'} || 10)) {
pop @{$self->{'backupvars'}};
}
unshift @{$self->{'backupvars'}}, {%{$self->{'datastore'}->get_all}};
}
sub revert_params {
my $self = shift;
shift @{$self->{'backupvars'}};
if ($#{$self->{'backupvars'}} > -1) {
$self->{'datastore'}->set_all(shift @{$self->{'backupvars'}});
} else {
$self->{'datastore'}->set_all({});
}
}
#
# called by QWizard::pass_vars() to determine if we not be passing on
# particular variables.
#
sub skip_storage {
my ($self, $skiptok) = @_;
if (exists($self->{'delete_tokens'}) &&
exists($self->{'delete_tokens'}{$skiptok})) {
delete $self->{'delete_tokens'}{$skiptok};
return 1;
}
return 0;
}
#
# potentially called by post_answers primary code to forget about a
# particular variable and not pass it on to forward screens.
#
sub forget_param {
my $self = shift;
map { $self->{'datastore'}->set($_,'');
$self->{'delete_tokens'}{$_} = 1
} @_;
}
sub do_hidden {
my ($self, $wiz, $name, $val) = @_;
$self->{'datastore'}->set($name, $val);
}
sub clear_params {
my $self = shift;
$self->{'datastore'}->reset();
@{$self->{'backupvars'}} = ();
}
sub get_handler {
my ($self, $type, $q) = @_;
use Data::Dumper;
if (exists($self->{'typemap'}{$type})) {
return $self->{'typemap'}{$type};
}
}
sub add_handler {
my ($self, $type, $fn, $argdef) = @_;
$self->{'typemap'}{$type}{'function'} = $fn;
$self->{'typemap'}{$type}{'argdef'} = $argdef;
}
sub get_supported_tags {
my ($self) = @_;
return keys(%{$self->{'typemap'}});
}
sub print_handler_tags {
my ($self, $tokformat, $nameformat, $endtext) = @_;
$tokformat = " %-20s %-10s\n" if (!$tokformat);
$nameformat = "%s arguments:\n" if (!$nameformat);
foreach my $t (sort keys(%{$self->{'typemap'}})) {
printf($nameformat, $t);
foreach my $arg (@{$self->{'typemap'}{$t}{'argdef'}}) {
next if ($arg->[0] eq 'forced');
my @tagargs = @$arg;
if ($#tagargs == 0) {
push @tagargs, "single";
} else {
my $swapit = $tagargs[0];
$tagargs[0] = $tagargs[1];
$tagargs[1] = $swapit;
}
printf($tokformat, @tagargs);
}
print $endtext if ($endtext);
}
}
#
# argdef format:
# [
# [ TYPE, NAMEorSPECIAL, DEFAULT],
# ...
# ]
sub get_arguments {
my ($self, $wiz, $q, $argdef, $default) = @_;
my @args;
for (my $i = 0; $i <= $#$argdef; $i++) {
if (ref($argdef->[$i]) ne 'ARRAY') {
print STDERR "malformed argument definition: $argdef->[$i]\n";
push @args, undef;
next;
}
my $def = $argdef->[$i];
if ($def->[0] eq 'default') {
push @args, $default;
} elsif ($def->[0] eq 'forced') {
push @args, $def->[1];
} elsif ($def->[0] eq 'values,labels') {
push @args, $wiz->get_values_and_labels($q, $def->[1])
} elsif ($def->[0] eq 'multi') {
if (exists($q->{$def->[1]})) {
push @args, $wiz->get_values($q->{$def->[1]});
} else {
push @args, $def->[2];
}
} elsif ($def->[0] eq 'single') {
if (exists($q->{$def->[1]})) {
push @args, $wiz->get_value($q->{$def->[1]});
} else {
push @args, $def->[2];
}
} elsif ($def->[0] eq 'norecurse') {
if (exists($q->{$def->[1]})) {
push @args, $wiz->get_value($q->{$def->[1]}, 1);
} else {
push @args, $def->[2];
}
} elsif ($def->[0] eq 'norecursemulti') {
if (exists($q->{$def->[1]})) {
push @args, $wiz->get_values($q->{$def->[1]}, 1);
} else {
push @args, $def->[2];
}
} elsif ($def->[0] eq 'labels') {
if (exists($q->{$def->[1]})) {
push @args, $wiz->get_labels($q);
} else {
push @args, $def->[2];
}
} elsif ($def->[0] eq 'noexpand') {
if (exists($q->{$def->[1]})) {
push @args, $q->{$def->[1]};
} else {
push @args, $def->[2];
}
} else {
print STDERR "unknown argument type: $def->[0]\n";
}
}
return \@args;
}
# preferences
sub qwpref {
my $self = shift;
return $self->{'prefstore'}->access(@_);
}
# file uploads
sub qw_upload_fh {
my ($self) = shift;
my ($it);
my $ret;
if (ref($self) =~ /QWizard/) {
$it = shift;
} else {
$it = $self;
}
my $fh = new IO::File();
$fh->open("<" . $self->qwparam($it));
return $fh;
}
# this is overriden by the HTML handler to return a pointer to a temp file
sub qw_upload_file {
my ($self) = shift;
my ($it);
my $ret;
if (ref($self) =~ /QWizard/) {
$it = shift;
} else {
$it = $self;
}
return $self->qwparam($it);
}
######################################################################
## convenience functions
sub make_displayable {
my ($self, $str);
if ($#_ > 0) {
($self, $str) = @_;
} else {
($str) = @_;
}
if (defined($str) && $str ne '' && !isprint($str)) {
$str = "0x" . (unpack("H*", $str))[0];
}
return $str;
}
######################################################################
## temporary file handling
sub create_temp_fh {
my ($self, $sfx) = @_;
mkdir($self->{'tmpdir'}) if (! -d $self->{'tmpdir'});
my ($fh, $filename) = tempfile("qwHTMLXXXXXX", SUFFIX => $sfx,
DIR => $self->{'tmpdir'} || "/tmp/");
return ($fh, $filename);
}
## temporary file creation if needed by child classes
sub create_temp_file {
my ($self, $sfx, $data) = @_;
my ($fh, $filename) = $self->create_temp_fh($sfx);
if (ref($data) eq 'IO::File' || ref($data) eq 'Fh') {
while (<$data>) {
print $fh $_;
}
} else {
print $fh $data;
}
$fh->close();
return $filename;
}
######################################################################
# image path handling
#
sub find_image_path {
my ($self, $file) = @_;
# return it if it's already a fullyqualified path
# XXX: win32 issues
return if (!defined($file));
return $file if ($file eq '' || $file =~ /^\//);
# get a path list
my $paths = $self->{'imgpaths'};
$paths = [$paths] if (ref($paths) ne 'ARRAY');
# search the paths till we get a hit.
foreach my $path (@$paths) {
if (-f "$path/$file") {
return "$path/$file";
}
}
return;
}
######################################################################
# accelerator base functions
#
# removes at least the first _ from the label
sub remove_accelerator {
my $text = shift;
$text =~ s/_//;
return $text;
}
# erases memory of auto_accelerators already used
sub initialize_auto_accelerator {
my $self = shift;
$self->{'auto_accelerators'} =
# reserved set
{
N => 1, # Next
B => 1, # Back
R => 1, # Refresh
};
}
# Adds in an accelerator to a app if it doesn't exist
sub add_accelerator {
my ($self, $text) = @_;
return $text if ($self->{'no_auto_accelerators'});
return $text if ($text =~ s/^!//); # reserve ! as a don't-accelerate this
my $accelmap = $self->{'auto_accelerators'};
return $text if ($text =~ /(_)/ && exists($accelmap->{$1}));
my @lets = split(//,$text);
for (my $i = 0; $i <= $#lets; $i++) {
if ($lets[$i] =~ /[a-zA-Z]/ && !exists($accelmap->{lc($lets[$i])})) {
$accelmap->{lc($lets[$i])} = 1;
$lets[$i] = '_' . $lets[$i];
return join("",@lets);
}
}
return $text;
}
## dummy functions for overriding if needed by child classes
# called once in the very beginning
sub start_primaries {}
# called once at the very end
sub end_primaries {}
# called once before first primary
sub do_top_bar {}
# called once before first primary
sub do_left_side {}
# called once after last primary
sub do_right_side {}
# called once per primary per screen:
sub start_main_section {}
# called once per primary per screen:
sub end_main_section {}
# called once before first primary on screen:
sub start_center_section {}
# called once after last primary on screen:
sub end_center_section {}
# called once after qwizard is completely finished; should remove windows, etc.
sub finished {}
# called to display a progress window
sub set_progress {}
## All other missing functions are errors
sub AUTOLOAD {
my $sub = $AUTOLOAD;
my $mod = $AUTOLOAD;
$mod =~ s/::[^:]*$//;
$sub =~ s/.*:://;
die "FATAL PROBLEM: Your widget generator \"$mod\" doesn't support the \"$sub\" function";
}
1;
__END__