initial commit of file from CVS for e-smith-formmagick on Wed 12 Jul 08:54:49 BST 2023
This commit is contained in:
Brian Read
995
root/usr/share/perl5/vendor_perl/esmith/FormMagick.pm
Normal file
995
root/usr/share/perl5/vendor_perl/esmith/FormMagick.pm
Normal file
@@ -0,0 +1,995 @@
|
||||
#----------------------------------------------------------------------
|
||||
# Copyright 1999-2003 Mitel Networks Corporation
|
||||
# This program is free software; you can redistribute it and/or
|
||||
# modify it under the same terms as Perl itself.
|
||||
#
|
||||
# $Id: FormMagick.pm,v 1.69 2005/09/06 05:22:42 apc Exp $
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
package esmith::FormMagick;
|
||||
|
||||
our $VERSION = sprintf '%d.%03d', q$Revision: 1.69 $ =~ /: (\d+).(\d+)/;
|
||||
|
||||
use CGI::FormMagick;
|
||||
use Exporter;
|
||||
use strict;
|
||||
use esmith::util;
|
||||
use Carp;
|
||||
use File::Basename;
|
||||
use vars qw( @ISA @EXPORT);
|
||||
use esmith::I18N;
|
||||
use POSIX qw(strftime);
|
||||
# use I18N::LangTags qw(super_languages);
|
||||
use esmith::ConfigDB;
|
||||
|
||||
@ISA = qw(CGI::FormMagick Exporter);
|
||||
|
||||
@EXPORT = qw(
|
||||
turn_off_buttons
|
||||
print_button
|
||||
print_status_message
|
||||
set_status_message
|
||||
validate_password
|
||||
validate_description
|
||||
nopipes
|
||||
gen_locale_date_string
|
||||
_filename
|
||||
_lexicon_filename_list
|
||||
_scriptname_from_filename
|
||||
_read_lexicons
|
||||
);
|
||||
|
||||
our $configdb = esmith::ConfigDB->open_ro();
|
||||
|
||||
=begin _private
|
||||
|
||||
The import method is doing some tricky stuff to make sure that when
|
||||
esmith::FormMagick is subclassed and the subclass is used, the exported
|
||||
functions for both esmith::FormMagick *and* its subclass are available.
|
||||
|
||||
=end _private
|
||||
|
||||
=cut
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
__PACKAGE__->export_to_level(1, undef, @_);
|
||||
$class->export_to_level(1, undef, @_) unless __PACKAGE__ eq $class;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::FormMagick - esmith wrapper for CGI::FormMagick
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::FormMagick;
|
||||
|
||||
my $f = new esmith::FormMagick();
|
||||
$f->display();
|
||||
|
||||
my $f = new esmith::FormMagick( filename=>'/some/path/to/script' );
|
||||
$f->display();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
esmith::FormMagick is a wrapper for CGI::FormMagick which automatically
|
||||
does all the things that we always want to do for the SMEServer manager.
|
||||
These include:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Turning off unwanted buttons (previous, reset)
|
||||
|
||||
=item *
|
||||
|
||||
Automatically clearing %ENV for taint-friendliness
|
||||
|
||||
=item *
|
||||
|
||||
Disabling uploads through CGI.pm and setting the MAX_POST size to 100KB.
|
||||
|
||||
=item *
|
||||
|
||||
Reading in FormMagick XML from the __DATA__ section of the script
|
||||
|
||||
=back
|
||||
|
||||
This last point is the most important one. In order to avoid having
|
||||
XML files littering the filesystem, we have chosen to include them along
|
||||
with the script which parses them. Your script will therefore look like
|
||||
this:
|
||||
|
||||
my $fm = esmith::FormMagick->new();
|
||||
$fm->display();
|
||||
|
||||
# miscellaneous subroutines, etc
|
||||
|
||||
__DATA__
|
||||
<form ...>
|
||||
<page ...>
|
||||
<field ...> ... </field>
|
||||
<field ...> ... </field>
|
||||
<field ...> ... </field>
|
||||
</page>
|
||||
<page ...>
|
||||
<field ...> ... </field>
|
||||
<field ...> ... </field>
|
||||
<field ...> ... </field>
|
||||
</page>
|
||||
</form>
|
||||
|
||||
|
||||
esmith::FormMagick also provides certain convenience functions to assist
|
||||
in writing FormMagick web panels.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new()
|
||||
|
||||
Creates a new esmith::FormMagick object. Takes an optional hash of
|
||||
arguments, including:
|
||||
|
||||
more_lexicons a list of additional lexicon files to use
|
||||
charset the character set encoding of the lexicon files
|
||||
(default is UTF-8).
|
||||
|
||||
Notes on lexicon files:
|
||||
|
||||
By default, lexicons are read in from
|
||||
F</etc/e-smith/locale/*/FormMagick> (general FormMagick-internal phrases)
|
||||
and F</etc/e-smith/locale/*/$scriptpath> (where $scriptpath is
|
||||
something like F<etc/e-smith/web/functions/useraccounts>. NB: any symlinks
|
||||
will be traced to their source). You can append
|
||||
items to this list using the more_lexicons argument. Later lexfiles
|
||||
override earlier ones.
|
||||
|
||||
For debugging purposes, $fm->{lexfiles} will tell you which files were
|
||||
read in, and $fm->{original_xml} will show you the XML that was
|
||||
generated by smushing those files together.
|
||||
|
||||
The script will also be parsed to look for the following special coments,
|
||||
which are used to generate the navigation bar:
|
||||
|
||||
# heading : Security
|
||||
# description : Remote access
|
||||
# navigation : 1000 1200
|
||||
|
||||
Note on character set encodings:
|
||||
|
||||
Valid character sets are "ISO-8859-1", "US-ASCII", "UTF-8" and "UTF-16".
|
||||
|
||||
=begin testing
|
||||
|
||||
my $out = `$^X -cw $Original_File 2>&1`;
|
||||
is( $?, 0, 'compiles' );
|
||||
is( $out, "$Original_File syntax OK\n", 'no warnings' );
|
||||
|
||||
use_ok('CGI::FormMagick');
|
||||
use_ok('esmith::FormMagick');
|
||||
use vars qw($fm);
|
||||
|
||||
$ENV{ESMITH_LEXPATH} = "20e-smith-formmagick/locale";
|
||||
ok(open (DATA, "20e-smith-formmagick/data.xml"), "opened data file for input");
|
||||
ok(esmith::FormMagick->can('new'), "We can call new");
|
||||
ok($fm = esmith::FormMagick->new(more_lexicons => [ 'test' ]), "create e::fm object");
|
||||
isa_ok($fm, 'esmith::FormMagick');
|
||||
is($ENV{PATH}, '/bin:/usr/bin:/usr/local/bin', 'Set $ENV{PATH}');
|
||||
is($CGI::POST_MAX, 1024 * 100, "Set CGI::POST_MAX");
|
||||
is($CGI::DISABLE_UPLOADS, 1, "Set CGI::DISABLE_UPLOADS");
|
||||
is($<, $>, "Set real to effective UID");
|
||||
is($(, $), "Set real to effective UID");
|
||||
|
||||
$ENV{HTTP_ACCEPT_LANGUAGE} = "fr";
|
||||
$fm->parse_xml(); # suck in lexicons without displaying
|
||||
is($fm->localise("YES"), "Oui", "Localisation works");
|
||||
is($fm->localise("TEST"), "Essayer", "more_lexicons works");
|
||||
|
||||
# warning avoidance; better ways to do this gratefully accepted
|
||||
my ($foo, $bar) = ($CGI::POST_MAX, $CGI::DISABLE_UPLOADS);
|
||||
close DATA;
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
BEGIN: {
|
||||
$ENV{'PATH'} = '/usr/sbin:/usr/bin:/usr/local/bin';
|
||||
$ENV{'SHELL'} = '/bin/bash';
|
||||
$ENV{'HOME'} = '/root';
|
||||
delete $ENV{'ENV'};
|
||||
esmith::util::setRealToEffective();
|
||||
}
|
||||
|
||||
|
||||
sub new {
|
||||
my $self = shift;
|
||||
my $class = ref($self) || $self;
|
||||
|
||||
my %args = @_;
|
||||
|
||||
my $data;
|
||||
{
|
||||
local $/ = undef;
|
||||
no warnings;
|
||||
$data = <main::DATA>;
|
||||
}
|
||||
|
||||
my $csrfdelay = $args{csrfdelay} || $configdb->get('httpd-admin')->prop('csrfTimeout') || '180';
|
||||
$csrfdelay = ($csrfdelay =~ /\D/ )? 180 : $csrfdelay;
|
||||
$csrfdelay = ( $csrfdelay > 500) ? 500 : $csrfdelay;
|
||||
my $sessiondir = "/var/cache/e-smith/formmagick/sessions";
|
||||
my $charset = $args{charset} || 'UTF-8';
|
||||
|
||||
$self = CGI::FormMagick::new($class,
|
||||
type => 'string',
|
||||
source => $data,
|
||||
charset => $charset,
|
||||
sessiondir => $sessiondir,
|
||||
debug => $args{debug},
|
||||
csrf => 1,
|
||||
csrfdelay => $csrfdelay
|
||||
);
|
||||
|
||||
my $fallback = "en-us";
|
||||
|
||||
$self->{fallback_language} = $fallback;
|
||||
|
||||
my @lexfiles = $self->_lexicon_filename_list(%args);
|
||||
my $lextext = _read_lexicons(@lexfiles);
|
||||
|
||||
$self->{source} =~ s!</form>!$lextext\n</form>!;
|
||||
|
||||
if ($self->{debug}) {
|
||||
$self->{lexfiles} = \@lexfiles;
|
||||
$self->{original_xml} = $data;
|
||||
}
|
||||
$self->{calling_package} = (caller)[0];
|
||||
|
||||
$self->previousbutton(0);
|
||||
$self->startoverlink(0);
|
||||
$self->resetbutton(0);
|
||||
$self->fallback_language($fallback);
|
||||
|
||||
$self->_navigation_setup(%args);
|
||||
|
||||
$CGI::POST_MAX=1024 * 100; # max 100K posts
|
||||
$CGI::DISABLE_UPLOADS = 1; # no uploads
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
=head2 get_languages
|
||||
|
||||
Override for CGI::FormMagick::get_languages to only return languages which are
|
||||
installed on this server
|
||||
|
||||
=cut
|
||||
|
||||
sub get_languages
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my @languages;
|
||||
|
||||
my @missing_languages;
|
||||
|
||||
my $lexdir = $ENV{ESMITH_LEXPATH} || "/etc/e-smith/locale";
|
||||
|
||||
foreach my $lang ($self->SUPER::get_languages(),$self->fallback_language())
|
||||
{
|
||||
if (-d "$lexdir/$lang")
|
||||
{
|
||||
push @languages, $lang;
|
||||
next;
|
||||
}
|
||||
|
||||
push @missing_languages, $lang;
|
||||
}
|
||||
|
||||
warn "get_languages: " .
|
||||
"Browser asked for missing languages @missing_languages\n"
|
||||
if (scalar @missing_languages);
|
||||
|
||||
return @languages;
|
||||
}
|
||||
|
||||
=head2 page_pre_event
|
||||
|
||||
This method overrides the same method in CGI::FormMagick. It adds some
|
||||
functionality that is not specific to general CGI::FormMagick use,
|
||||
specifically the big-red error message whenever there are errors in the page.
|
||||
|
||||
=cut
|
||||
|
||||
sub page_pre_event
|
||||
{
|
||||
my $self = shift;
|
||||
$self->debug_msg("This is the page pre-event in esmith::FormMagick.");
|
||||
if (my $pre_page_routine = $self->page->{'pre-event'}) {
|
||||
$self->debug_msg("The pre-routine is $pre_page_routine");
|
||||
$self->do_external_routine($pre_page_routine);
|
||||
}
|
||||
# If any errors occurred, draw the big error box.
|
||||
if ($self->errors())
|
||||
{
|
||||
my $msg = $self->localise('ERROR_BELOW');
|
||||
$self->{cgi}->param(-name => 'status_message',
|
||||
-value => $msg);
|
||||
$self->{cgi}->param(-name => 'status_type',
|
||||
-value => 'error');
|
||||
$self->do_external_routine('print_status_message');
|
||||
}
|
||||
}
|
||||
|
||||
=head2 _filename
|
||||
|
||||
Figures out the filename of the script being run, either from the
|
||||
arguments or by looking at the perl special variable $0.
|
||||
|
||||
=for testing
|
||||
is(_filename(filename => 'foo'), 'foo', "Pick up filename from args");
|
||||
is(_filename(), $0, "Pick up filename from \$0");
|
||||
|
||||
=cut
|
||||
|
||||
sub _filename {
|
||||
my (%args) = @_;
|
||||
return exists $args{filename} ? $args{filename} : $0;
|
||||
}
|
||||
|
||||
=head2 _scriptname_from_filename
|
||||
|
||||
Given a filename such as that found in $0, follows symlinks and figures
|
||||
out the actual original filename. This is mostly used to turn
|
||||
F</etc/e-smith/web/panels/manager/cgi-bin/whatever> into
|
||||
F</etc/e-smith/web/functions/whatever>.
|
||||
|
||||
=for testing
|
||||
# bloody hard to test anywhere other than on a server; not sure how to
|
||||
# do it. -- Skud
|
||||
can_ok('main', '_scriptname_from_filename');
|
||||
|
||||
=cut
|
||||
|
||||
sub _scriptname_from_filename {
|
||||
my ($filename) = my ($scriptname) = @_;
|
||||
while (-l $scriptname) {
|
||||
$scriptname = readlink $scriptname;
|
||||
}
|
||||
|
||||
if ( $scriptname =~ m:^\.\./\.\./\.\./functions: and
|
||||
$filename =~ m:^/etc/e-smith/web/panels/manager/(cgi-bin|html):)
|
||||
{
|
||||
$scriptname = "/etc/e-smith/web/functions/" . basename $filename;
|
||||
}
|
||||
return $scriptname;
|
||||
}
|
||||
|
||||
=head2 _lexicon_filename_list
|
||||
|
||||
Figures out the full filenames of all required i18n/l10n lexicons, and
|
||||
returns them as a list.
|
||||
|
||||
=begin testing
|
||||
|
||||
$ENV{ESMITH_LEXPATH} = "20e-smith-formmagick/locale";
|
||||
my @expected_lexfiles = qw(
|
||||
20e-smith-formmagick/locale/en/FormMagick/general
|
||||
20e-smith-formmagick/locale/fr/FormMagick/general
|
||||
20e-smith-formmagick/locale/en/test
|
||||
20e-smith-formmagick/locale/fr/test
|
||||
);
|
||||
|
||||
my @lexfiles = _lexicon_filename_list(more_lexicons => [ 'test' ]);
|
||||
is_deeply(\@expected_lexfiles, \@lexfiles, "Found the right localisation lexicons");
|
||||
|
||||
=end testing
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub _lexicon_filename_list {
|
||||
my $self = shift;
|
||||
my (%args) = @_;
|
||||
|
||||
my $filename = _filename(%args);
|
||||
my $scriptname = _scriptname_from_filename($filename);
|
||||
|
||||
my $lexdir = $ENV{ESMITH_LEXPATH} || "/etc/e-smith/locale";
|
||||
|
||||
my ($pref_lang) = $self->get_languages();
|
||||
|
||||
my @lexfiles = ();
|
||||
foreach my $pref_lang ($self->get_languages())
|
||||
{
|
||||
if (-e "$lexdir/$pref_lang/FormMagick/builtins")
|
||||
{
|
||||
push @lexfiles, "$lexdir/$pref_lang/FormMagick/builtins";
|
||||
last;
|
||||
}
|
||||
}
|
||||
foreach my $pref_lang ($self->get_languages())
|
||||
{
|
||||
if (-e "$lexdir/$pref_lang/FormMagick/general")
|
||||
{
|
||||
push @lexfiles, "$lexdir/$pref_lang/FormMagick/general";
|
||||
last;
|
||||
}
|
||||
}
|
||||
foreach my $pref_lang ($self->get_languages())
|
||||
{
|
||||
if (-e "$lexdir/$pref_lang/$scriptname")
|
||||
{
|
||||
push @lexfiles, "$lexdir/$pref_lang/$scriptname";
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
foreach (@{$args{more_lexicons}}) {
|
||||
push @lexfiles, "$lexdir/$pref_lang/$_";
|
||||
}
|
||||
return @lexfiles;
|
||||
}
|
||||
|
||||
=head2 _read_lexicons
|
||||
|
||||
Given a list of lexicon filenames, reads each of them in and returns
|
||||
them as a concatenated string.
|
||||
|
||||
=for testing
|
||||
can_ok('main', '_read_lexicons');
|
||||
like(_read_lexicons('20e-smith-formmagick/locale/fr/test'), qr'Essayer', "_read_lexicons");
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub _read_lexicons {
|
||||
my $lextext = "";
|
||||
foreach (@_) {
|
||||
local $/ = undef;
|
||||
unless (open (LEXIN, $_))
|
||||
{
|
||||
warn "Can't open lexicon file $_: $!";
|
||||
next;
|
||||
}
|
||||
$lextext .= <LEXIN>;
|
||||
}
|
||||
return $lextext;
|
||||
}
|
||||
|
||||
|
||||
=head2 $fm->_navigation_setup(%args)
|
||||
|
||||
Sets up various properties related to the navigation menu, such as
|
||||
heading/description/etc. You need to pass it the same args as were
|
||||
passed to new(). It doesn't return anything.
|
||||
|
||||
=for testing
|
||||
my $nav = esmith::FormMagick->new(filename=>"20e-smith-formmagick/navigation");
|
||||
can_ok($nav, '_navigation_setup');
|
||||
$nav->_navigation_setup(filename=>"20e-smith-formmagick/navigation");
|
||||
is($nav->heading, 'Test heading', "Picked up navigation heading");
|
||||
|
||||
=cut
|
||||
|
||||
sub _navigation_setup {
|
||||
my ($self, %args) = @_;
|
||||
$self->{heading} = undef;
|
||||
$self->{description} = undef;
|
||||
$self->{heading_weight} = undef;
|
||||
$self->{description_weight} = undef;
|
||||
if (open SCRIPT, _filename(%args))
|
||||
{
|
||||
while ( <SCRIPT> )
|
||||
{
|
||||
$self->{heading} = $1 if (/^\s*#\s*heading\s*:\s*(.+?)\s*$/);
|
||||
|
||||
$self->{description} = $1
|
||||
if (/^\s*#\s*description\s*:\s*(.+?)\s*$/);
|
||||
|
||||
($self->{heading_weight}, $self->{description_weight}) = ($1, $2)
|
||||
if (/^\s*#\s*navigation\s*:\s*(\d+?)\s+(\d+?)\s*$/);
|
||||
|
||||
last if (defined $self->{heading} and
|
||||
defined $self->{description} and
|
||||
defined $self->{heading_weight} and
|
||||
defined $self->{description_weight});
|
||||
}
|
||||
}
|
||||
close SCRIPT;
|
||||
}
|
||||
|
||||
=head2 $fm->get_validation_attribute
|
||||
|
||||
This method overrides the one in CGI::FormMagick::Validator to forcibly
|
||||
add "nopipes" to the list of validations performed. Note that if the
|
||||
validation string contains "permitpipes", it will be removed, and "nopipes"
|
||||
will _not_ be added.
|
||||
|
||||
=begin testing
|
||||
my $fm = esmith::FormMagick->new(filename=>"20e-smith-formmagick/nopipes");
|
||||
can_ok($fm, "get_validation_attribute");
|
||||
is($fm->get_validation_attribute({validation => "foo"}), "foo, nopipes", "nopipes added to existing validation");
|
||||
is($fm->get_validation_attribute({validation => undef}), "nopipes", "nopipes added to empty validation");
|
||||
|
||||
#$fm->parse_xml();
|
||||
my $badcgi = CGI->new( { testfield => '|' } );
|
||||
$fm->{cgi} = $badcgi;
|
||||
|
||||
my $field = {
|
||||
validation => '',
|
||||
id => 'testfield',
|
||||
label => 'Test Field',
|
||||
};
|
||||
|
||||
isnt(grep(/PIPE/,$fm->validate_field($field)), undef, "Test a field with a pipe in it");
|
||||
isnt($fm->validate_field($field), "OK", "Test a field with a pipe in it");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub get_validation_attribute {
|
||||
my ($fm, $field) = @_;
|
||||
my $vfield = $field->{validation};
|
||||
if ($vfield and ($vfield =~ s/(,\s)?permitpipes//))
|
||||
{
|
||||
$vfield =~ s/^\s*,//;
|
||||
return $vfield;
|
||||
}
|
||||
elsif ($vfield)
|
||||
{
|
||||
return "$vfield, nopipes";
|
||||
}
|
||||
else {
|
||||
return "nopipes";
|
||||
}
|
||||
}
|
||||
|
||||
=head2 $fm->props_to_query_string()
|
||||
|
||||
Given a hash of properties, turns them into a CGI query string. Useful
|
||||
for if you need to pre-populate a form based on data from the accounts
|
||||
or config database. See the table on the first page of the C<useraccounts>
|
||||
web function for an example.
|
||||
|
||||
=for testing
|
||||
my $test = {a => "b", c => "d"};
|
||||
is($fm->props_to_query_string($test), "a=b;c=d", "props_to_query_string");
|
||||
|
||||
=cut
|
||||
|
||||
sub props_to_query_string {
|
||||
my ($fm, $prophash) = @_;
|
||||
my $cgi = CGI->new($prophash);
|
||||
return $cgi->query_string();
|
||||
}
|
||||
|
||||
=head1 EXPORTED FUNCTIONS
|
||||
|
||||
The following exported functions may be used in your FormMagick scripts
|
||||
and XML, for instance as page pre-events, validation routines, etc.
|
||||
|
||||
=head2 turn_off_buttons()
|
||||
|
||||
Turns off *all* buttons. Useful if you want to replace the Next/Prev
|
||||
style of navigation with something else.
|
||||
|
||||
=for testing
|
||||
my $fm = esmith::FormMagick->new();
|
||||
turn_off_buttons($fm);
|
||||
foreach (qw(nextbutton previousbutton finishbutton resetbutton startoverlink)) {
|
||||
is($fm->$_, 0, "turn_off_buttons turns off $_");
|
||||
}
|
||||
|
||||
=cut
|
||||
|
||||
sub turn_off_buttons {
|
||||
my $fm = shift;
|
||||
$fm->nextbutton(0);
|
||||
$fm->previousbutton(0);
|
||||
$fm->finishbutton(0);
|
||||
$fm->resetbutton(0);
|
||||
$fm->startoverlink(0);
|
||||
}
|
||||
|
||||
=head2 print_button('STRING')
|
||||
|
||||
Given a string, prints a submit button with that string localised. For
|
||||
instance, print_button('SAVE') will localise SAVE and put it onto the
|
||||
button. This is used to replace the next/prev/etc buttons with custom
|
||||
buttons.
|
||||
|
||||
=cut
|
||||
|
||||
sub print_button {
|
||||
my ($fm, $word) = @_;
|
||||
$word = $fm->localise($word);
|
||||
print qq( </table>\n <table width=100%><tr><th class="sme-layout"><input type="submit" name="Next" value="$word"></th></tr></table>);
|
||||
return undef;
|
||||
}
|
||||
|
||||
=head2 set_status_message($message)
|
||||
|
||||
Sets the status message to be displayed at the top of the next page.
|
||||
|
||||
=for testing
|
||||
my $fm = esmith::FormMagick->new();
|
||||
$fm->{cgi} = CGI->new("");
|
||||
can_ok('main', 'set_status_message');
|
||||
set_status_message($fm, "Testing");
|
||||
is($fm->{cgi}->param("status_message"), "Testing", "Set status message");
|
||||
|
||||
=cut
|
||||
|
||||
sub set_status_message {
|
||||
my ($fm, $msg) = @_;
|
||||
$fm->{cgi}->param(-name => 'status_message', -value => $msg);
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head2 print_status_message()
|
||||
|
||||
Prints an status message on the first page, to give an indication of
|
||||
success/failure of the previous step. Resets the status message to
|
||||
blank and turns off all buttons as a side-effect.
|
||||
|
||||
=for testing
|
||||
my $fm = esmith::FormMagick->new();
|
||||
$fm->{cgi} = CGI->new("");
|
||||
set_status_message($fm, "test status message");
|
||||
$fm->nextbutton(1);
|
||||
print_status_message($fm);
|
||||
like($_STDOUT_, qr/test status message/, "Saw status message");
|
||||
is($fm->{cgi}->param("status_message"), "", "Reset status message to blank after printing");
|
||||
is($fm->nextbutton(), 0, "turn off buttons after status message");
|
||||
|
||||
=cut
|
||||
|
||||
sub print_status_message
|
||||
{
|
||||
my ($fm) = @_;
|
||||
|
||||
if ($fm->{cgi}->param("status_message"))
|
||||
{
|
||||
my $msg = qq(<h2>) . $fm->localise('OPERATION_STATUS_REPORT') .
|
||||
qq(</h2>);
|
||||
$msg .= $fm->localise($fm->{cgi}->param("status_message"));
|
||||
|
||||
my $div_class = $fm->{cgi}->param("status_type") || undef;
|
||||
|
||||
if (defined $div_class)
|
||||
{
|
||||
my $q = $fm->{cgi};
|
||||
|
||||
my $img_string;
|
||||
|
||||
if ($div_class eq "success")
|
||||
{
|
||||
$img_string =
|
||||
qq(src="/server-common/tickmark.jpg" ALT="SUCCESS");
|
||||
}
|
||||
else
|
||||
{
|
||||
$img_string =
|
||||
qq(src="/server-common/checkmark.jpg" ALT="ERROR");
|
||||
}
|
||||
|
||||
print $q->table({-class =>"sme-borders"},
|
||||
$q->Tr(
|
||||
$q->td( "<img $img_string>"),
|
||||
$q->td( $q->div( {-class=>$div_class}, $msg) )
|
||||
));
|
||||
}
|
||||
else
|
||||
{
|
||||
print $fm->{cgi}->div($msg);
|
||||
print $fm->{cgi}->hr({-class => "sectionbar"});
|
||||
}
|
||||
|
||||
$fm->{cgi}->param(-name => "status_message" => value => "");
|
||||
$fm->{cgi}->param(-name => "status_type" => value => "");
|
||||
}
|
||||
turn_off_buttons($fm);
|
||||
}
|
||||
|
||||
=head2 description
|
||||
|
||||
Return the description entry read from the script, or "Unknown"
|
||||
|
||||
=for testing
|
||||
my $fm = esmith::FormMagick->new(filename=>"20e-smith-formmagick/navigation");
|
||||
is($fm->description, "Test description", "Read description header");
|
||||
|
||||
=cut
|
||||
|
||||
sub description
|
||||
{
|
||||
my ($fm) = @_;
|
||||
|
||||
my $desc = defined $fm->{description} ? $fm->localise($fm->{description})
|
||||
: "Unknown";
|
||||
$desc =~ s/^\s*//;
|
||||
$desc =~ s/\s*$//;
|
||||
return $desc;
|
||||
}
|
||||
|
||||
=head2 heading
|
||||
|
||||
Return the heading entry read from the script, or "Unknown"
|
||||
|
||||
=for testing
|
||||
my $fm = esmith::FormMagick->new(filename=>"20e-smith-formmagick/navigation");
|
||||
is($fm->heading, "Test heading", "Read heading header");
|
||||
|
||||
=cut
|
||||
|
||||
sub heading
|
||||
{
|
||||
my ($fm) = @_;
|
||||
|
||||
my $head = defined $fm->{heading} ? $fm->localise($fm->{heading})
|
||||
: "Unknown";
|
||||
|
||||
$head =~ s/^\s*//;
|
||||
$head =~ s/\s*$//;
|
||||
return $head;
|
||||
}
|
||||
|
||||
|
||||
=head2 description_weight
|
||||
|
||||
Return the description weight entry read from the script, or zero
|
||||
|
||||
=for testing
|
||||
my $fm = esmith::FormMagick->new(filename=>"20e-smith-formmagick/navigation");
|
||||
is($fm->description_weight, 1200, "Read description weight");
|
||||
|
||||
=cut
|
||||
|
||||
sub description_weight
|
||||
{
|
||||
my ($fm) = @_;
|
||||
|
||||
return defined $fm->{description_weight} ? $fm->{description_weight} : 0;
|
||||
}
|
||||
|
||||
=head2 heading_weight
|
||||
|
||||
Return the heading weight entry read from the script, or zero
|
||||
|
||||
=for testing
|
||||
my $fm = esmith::FormMagick->new(filename=>"20e-smith-formmagick/navigation");
|
||||
is($fm->heading_weight, 1000, "Read heading weight");
|
||||
|
||||
=cut
|
||||
|
||||
sub heading_weight
|
||||
{
|
||||
my ($fm) = @_;
|
||||
|
||||
return defined $fm->{heading_weight} ? $fm->{heading_weight} : 0;
|
||||
}
|
||||
|
||||
=head2 validate_password ($strength, $password)
|
||||
|
||||
Checks the supplied password for security. Strength can be "strong", "normal"
|
||||
or "none". A "strong" password passes the cracklib tests. A "normal" password
|
||||
passes the tests in CGI::FormMagick::Validator::Network::password, and "none"
|
||||
will accept any password. An invalid argument for 'strength' is considered to
|
||||
be 'normal'.
|
||||
|
||||
=for testing
|
||||
my $fm = esmith::FormMagick->new();
|
||||
isnt($fm->validate_password('strong','f00'),'OK','validate_password strong');
|
||||
is($fm->validate_password('strong','f%nn*f2@'),'OK',' ..using strong password');
|
||||
isnt($fm->validate_password('normal','f00'),'OK','validate_password normal');
|
||||
is($fm->validate_password('normal','f%00B4r'),'OK',' ..using normal password');
|
||||
is($fm->validate_password('none','f00'),'OK','validate_password none');
|
||||
|
||||
=cut
|
||||
|
||||
sub validate_password
|
||||
{
|
||||
my ($fm,$strength,$pass) = @_;
|
||||
|
||||
use Crypt::Cracklib;
|
||||
|
||||
my $reason;
|
||||
|
||||
if ($strength eq "none") {
|
||||
return $fm->localise("Passwords must be at least 7 characters long") unless (length($pass) > 6);
|
||||
return "OK";
|
||||
}
|
||||
|
||||
$reason = $fm->call_fm_validation('password', $pass, undef);
|
||||
|
||||
return $reason unless ($reason eq "OK");
|
||||
return "OK" unless ($strength eq "strong");
|
||||
|
||||
if ( -f '/usr/lib64/cracklib_dict.pwd' ) {
|
||||
$reason = fascist_check($pass, '/usr/lib64/cracklib_dict');
|
||||
} else {
|
||||
$reason = fascist_check($pass, '/usr/lib/cracklib_dict');
|
||||
}
|
||||
$reason ||= "Software error: password check failed";
|
||||
|
||||
return "OK" if ($reason eq "ok");
|
||||
|
||||
return $fm->localise("Bad Password Choice") . ": "
|
||||
. $fm->localise("The password you have chosen is not a good choice, because")
|
||||
. " " . $fm->localise($reason) . ".";
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 validate_description ($description).
|
||||
Checks the supplied description. Period is allowed in description
|
||||
|
||||
=cut
|
||||
|
||||
sub validate_description
|
||||
{
|
||||
my ($fm, $description) = @_;
|
||||
if ( $description =~ /^([\-\'\w][\-\'\w\s\.]*)$/ ) {
|
||||
return ('OK');
|
||||
}
|
||||
else {
|
||||
return ("FM_ERR_UNEXPECTED_DESC");
|
||||
}
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 nopipes
|
||||
|
||||
Validation routine to ensure there are no pipe characters in a field.
|
||||
This is necessary because we don't want them to end up in the esmith configuration databases.
|
||||
|
||||
Note that this validation routine is automatically added to every field, so you do not have to call it explicitly.
|
||||
|
||||
=for testing
|
||||
can_ok('main', 'nopipes');
|
||||
is(nopipes(undef, 'nopipes in this string!'),'OK','nopipes in this string!');
|
||||
like(nopipes(undef, 'has|pipe'),qr/NO_PIPES/,' .. no pipes allowed');
|
||||
|
||||
=cut
|
||||
|
||||
sub nopipes
|
||||
{
|
||||
my ($fm, $data) = @_;
|
||||
if ($data =~ /\|/)
|
||||
{
|
||||
return "NO_PIPES_ALLOWED";
|
||||
}
|
||||
return "OK";
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 gen_locale_date_string
|
||||
|
||||
Generates a date string in the preferred format for the locale.
|
||||
|
||||
=for testing
|
||||
can_ok('main', 'gen_locale_date_string');
|
||||
|
||||
=cut
|
||||
|
||||
sub gen_locale_date_string
|
||||
{
|
||||
my $self = shift;
|
||||
my $i18n = esmith::I18N->new();
|
||||
$i18n->setLocale('formmagick', $i18n->preferredLanguage());
|
||||
return strftime "%c", localtime;
|
||||
}
|
||||
|
||||
=head2 success
|
||||
|
||||
This method takes a lexicon tag as argument, optionally with a page name as
|
||||
second argument (defaulting to 'First'), and sets the status message to the
|
||||
lexicon tag, and sets the next page. To make use of this, the page that the
|
||||
method is directing FormMagick to should have, as pre-event, the
|
||||
print_status_message method.
|
||||
|
||||
This method simply factor's all of the results of successful operations, and
|
||||
helps to ensure that all results end up in looping back to the start page.
|
||||
|
||||
=cut
|
||||
|
||||
sub success {
|
||||
my $self = shift;
|
||||
my $msg = shift || 'SUCCESS';
|
||||
my $page = shift || 'First';
|
||||
$self->debug_msg("success signalled: nextpage = $page, message = $msg");
|
||||
$self->wherenext($page);
|
||||
$self->{cgi}->param(-name => 'status_message',
|
||||
-value => $msg);
|
||||
$self->{cgi}->param(-name => 'status_type',
|
||||
-value => 'success');
|
||||
return undef;
|
||||
}
|
||||
|
||||
=head2 error
|
||||
|
||||
This method is much like the above 'success' method, except it is intended for
|
||||
display of error messages.
|
||||
|
||||
It is currently identical to success(), but can be altered to yield
|
||||
different results, like addition of red text, or logging of the error, etc.
|
||||
|
||||
=cut
|
||||
|
||||
sub error {
|
||||
my $self = shift;
|
||||
my $msg = shift || 'ERROR';
|
||||
my $page = shift || 'First';
|
||||
$self->debug_msg("error signalled: nextpage = $page, message = $msg");
|
||||
$self->wherenext($page);
|
||||
$self->{cgi}->param(-name => 'status_message',
|
||||
-value => $msg);
|
||||
$self->{cgi}->param(-name => 'status_type',
|
||||
-value => 'error');
|
||||
return undef;
|
||||
}
|
||||
|
||||
=head2 display_error
|
||||
|
||||
This method displays an error using the sme-error style. This should be
|
||||
used when displaying a page, and the error() method is not applicable.
|
||||
|
||||
=cut
|
||||
|
||||
sub display_error
|
||||
{
|
||||
my $self = shift;
|
||||
my $msg = shift;
|
||||
my $q = $self->{cgi};
|
||||
|
||||
print $q->Tr($q->td({ -colspan => 2 },
|
||||
$q->div({ -class => 'sme-error' },
|
||||
$self->localise($msg))));
|
||||
return undef;
|
||||
}
|
||||
|
||||
=head2 display_success
|
||||
|
||||
This method displays a success message using the success style. This should be
|
||||
used when displaying a page, and the success() method is not applicable.
|
||||
|
||||
=cut
|
||||
|
||||
sub display_success
|
||||
{
|
||||
my $self = shift;
|
||||
my $msg = shift;
|
||||
my $q = $self->{cgi};
|
||||
|
||||
print $q->Tr($q->td({ -colspan => 2 },
|
||||
$q->div({ -class => 'success' },
|
||||
$self->localise($msg))));
|
||||
return undef;
|
||||
}
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<CGI::FormMagick>
|
||||
|
||||
L<esmith::FormMagick::Tester>
|
||||
|
||||
L<esmith::FormMagick::LexTester>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Mitel Networks Corporation
|
||||
|
||||
See http://www.e-smith.org/ for more information
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
138
root/usr/share/perl5/vendor_perl/esmith/FormMagick/LexTester.pm
Normal file
138
root/usr/share/perl5/vendor_perl/esmith/FormMagick/LexTester.pm
Normal file
@@ -0,0 +1,138 @@
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# Copyright 1999-2003 Mitel Networks Corporation
|
||||
# This program is free software; you can redistribute it and/or
|
||||
# modify it under the same terms as Perl itself.
|
||||
#
|
||||
# $Id: LexTester.pm,v 1.1 2002/02/26 20:45:27 skud Exp $
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
package esmith::FormMagick::LexTester;
|
||||
|
||||
my $VERSION = $VERSION = "0.10";
|
||||
|
||||
use esmith::FormMagick;
|
||||
use strict;
|
||||
use Carp;
|
||||
|
||||
our @ISA = qw(esmith::FormMagick);
|
||||
|
||||
#
|
||||
# TODO
|
||||
#
|
||||
# 2002-02-18 Skud Check for twice-translated terms
|
||||
# 2002-02-18 Skud Check the option labels of select/radio fields
|
||||
#
|
||||
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::FormMagick::LexTester - test FormMagick lexicon completeness
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::FormMagick::LexTester;
|
||||
|
||||
my $lt = esmith::FormMagick::Lextester->new();
|
||||
|
||||
foreach my $lang (qw(en fr de)) {
|
||||
my $ok = $lt->lextest($lang);
|
||||
unless ($ok) {
|
||||
my @untranslated = @{$lt->{untranslated}};
|
||||
warn "Untranslated terms for $lang: @untranslated\n",
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
esmith::FormMagick::LexTester is a subclass of esmith::FormMagick whose
|
||||
speciality is checking the completeness of localisation lexicons.
|
||||
|
||||
=head2 new();
|
||||
|
||||
Exactly as for esmith::FormMagick
|
||||
|
||||
=begin testing
|
||||
|
||||
BEGIN: {
|
||||
use lib qw(lib/ ../formmagick/lib/);
|
||||
use_ok('esmith::FormMagick::LexTester');
|
||||
use vars qw($lt);
|
||||
}
|
||||
|
||||
ok(esmith::FormMagick::LexTester->can('new'), "We can call new");
|
||||
|
||||
ok($lt= esmith::FormMagick::LexTester->new(), "Create lt object");
|
||||
isa_ok($lt, 'esmith::FormMagick::LexTester');
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
shift;
|
||||
$ENV{HTTP_ACCEPT_LANGUAGE} = "test value";
|
||||
my $self = esmith::FormMagick->new();
|
||||
$self->{calling_package} = (caller)[0];
|
||||
$self->{untranslated} = [];
|
||||
bless $self;
|
||||
return $self;
|
||||
}
|
||||
|
||||
=head2 $lt->lextest($lang)
|
||||
|
||||
Given a two-letter language code, checks the completeness of the lexicon
|
||||
for that language. Returns true on success, false on failure. If it
|
||||
fails, it sets $lt->{untranslated}, which is an arrayref containing a
|
||||
list of strings to be translated.
|
||||
|
||||
=cut
|
||||
|
||||
sub lextest {
|
||||
my ($self, $lang) = @_;
|
||||
$ENV{HTTP_ACCEPT_LANGUAGE} = $lang;
|
||||
|
||||
# we parse the XML a second time, even though it's wasteful... have to
|
||||
# do it to reset the lexicon to the language we want now.
|
||||
$self->parse_xml();
|
||||
|
||||
$self->localise($self->{xml}->{title});
|
||||
|
||||
foreach my $p (@{$self->{xml}->{pages}}) {
|
||||
$self->localise($p->{title});
|
||||
$self->localise($p->{description});
|
||||
foreach my $f (@{$p->{fields}}) {
|
||||
$self->localise($f->{label})
|
||||
}
|
||||
}
|
||||
|
||||
open 0 or die "Can't open perl script for grepping: $!";
|
||||
LINE: while (my $line = <0>) {
|
||||
last LINE if $line =~ /^__DATA__/;
|
||||
while ($line =~ m/([A-Z_]{3,})/g) {
|
||||
$self->localise($1);
|
||||
}
|
||||
}
|
||||
close 0;
|
||||
|
||||
if (@{$self->{untranslated}}) {
|
||||
return 0;
|
||||
} else {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub localise {
|
||||
my ($self, $string) = @_;
|
||||
my $result = $self->SUPER::localise($string);
|
||||
if ($string && $result eq $string) {
|
||||
$self->{untranslated} = [ @{$self->{untranslated}}, $string ];
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
156
root/usr/share/perl5/vendor_perl/esmith/FormMagick/Tester.pm
Normal file
156
root/usr/share/perl5/vendor_perl/esmith/FormMagick/Tester.pm
Normal file
@@ -0,0 +1,156 @@
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# Copyright 1999-2003 Mitel Networks Corporation
|
||||
# This program is free software; you can redistribute it and/or
|
||||
# modify it under the same terms as Perl itself.
|
||||
#
|
||||
# $Id: Tester.pm,v 1.1 2002/02/26 20:45:27 skud Exp $
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
package esmith::FormMagick::Tester;
|
||||
|
||||
my $VERSION = $VERSION = "0.10";
|
||||
|
||||
use WWW::Automate;
|
||||
use strict;
|
||||
use Carp;
|
||||
|
||||
our @ISA = qw(WWW::Automate Exporter);
|
||||
our @EXPORT = qw( mode );
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
esmith::FormMagick::Tester - test esmith FormMagick applications
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use esmith::FormMagick::Tester;
|
||||
|
||||
my $agent = esmith::FormMagick::Tester->new(
|
||||
password => $admin_password,
|
||||
host => $hostname_or_ip,
|
||||
);
|
||||
|
||||
$agent->get_panel($panel); # eg 'useraccounts'
|
||||
|
||||
$agent->set_language('en');
|
||||
$agent->set_language(['fr', 'en']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
esmith::FormMagick::Tester is a subclass of WWW::Automate, which is in
|
||||
turn a subclass of LWP::UserAgent. Read the documentation for
|
||||
WWW::Automate to get a better idea of how to use it effectively.
|
||||
|
||||
=head2 new($admin_password)
|
||||
|
||||
Create a new agent for testing esmith FormMagick applications
|
||||
(specifically, the web manager). It takes a hash of arguments, which
|
||||
include:
|
||||
|
||||
password administrative password for the manager
|
||||
(defaults to "default")
|
||||
host hostname or IP to test against
|
||||
(defaults to localhost)
|
||||
|
||||
=begin testing
|
||||
BEGIN: {
|
||||
use_ok('WWW::Automate');
|
||||
use_ok('esmith::FormMagick::Tester');
|
||||
use vars qw($agent);
|
||||
}
|
||||
|
||||
ok(esmith::FormMagick::Tester->can('new'), "We can call new");
|
||||
|
||||
ok($agent = esmith::FormMagick::Tester->new(), "create agent object");
|
||||
isa_ok($agent, 'esmith::FormMagick::Tester');
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
shift;
|
||||
my %args = @_;
|
||||
my $self = \%args;
|
||||
|
||||
$self->{password} ||= "default";
|
||||
$self->{host} ||= "127.0.0.1";
|
||||
|
||||
bless $self;
|
||||
return $self;
|
||||
}
|
||||
|
||||
=head2 $agent->get_panel($panel)
|
||||
|
||||
Gets a panel from the web manager, calling WWW::Automate::get with a URL
|
||||
built from $agent->{host} and the name of the panel you supply.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_panel {
|
||||
my ($self, $panel) = @_;
|
||||
$self->get("http://$self->{host}/server-manager/cgi-bin/$panel");
|
||||
}
|
||||
|
||||
=head2 $agent->set_language($lang)
|
||||
|
||||
Sets the language to use. This sets an the HTTP_ACCEPT_LANGUAGE header
|
||||
sent by the client to the server manager. You may provide it with a
|
||||
single language, eg. "en", or with a reference to a list of languages,
|
||||
eg. [ qw(en de fr) ]
|
||||
|
||||
Sets $agent->{language} as a side effect, in case you want it for
|
||||
anything later.
|
||||
|
||||
=begin testing
|
||||
|
||||
$agent->set_language("en");
|
||||
is($WWW::Automate::headers{"Accept-Language"}, "en", "Set lang header in hash");
|
||||
$agent->get("http://google.com");
|
||||
is($agent->{req}->header("Accept-Language"), "en", "Set language header");
|
||||
|
||||
=end testing
|
||||
|
||||
=cut
|
||||
|
||||
sub set_language {
|
||||
my ($self, $language) = @_;
|
||||
$self->{language} = $language;
|
||||
$self->add_header("Accept-Language" => $language);
|
||||
}
|
||||
|
||||
=head2 mode($script)
|
||||
|
||||
This convenience function is exported for use in testing scripts. For
|
||||
instance:
|
||||
|
||||
use esmith::FormMagick::Tester;
|
||||
is(mode('useraccounts', 4755, "Setuid and executable");
|
||||
|
||||
=cut
|
||||
|
||||
sub mode {
|
||||
return sprintf("%04o", (stat($_[0]))[2] & 07777);
|
||||
}
|
||||
|
||||
|
||||
=head1 INTERNAL METHODS
|
||||
|
||||
The following methods are used internally by this module.
|
||||
|
||||
=head2 get_basic_credentials()
|
||||
|
||||
Returns the administrative login/password for the esmith manager.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_basic_credentials {
|
||||
my $self = shift;
|
||||
return ("admin", $self->{password});
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user