replace the old, buggy label.t with the new, slow critic_labels.t. Add Perl::Critic and Test::Perl::Critic as optional requirements to sbin/testEnvironment.pl
This commit is contained in:
Colin Kuskie
parent
614b37e31d
commit
9a9e94a0de
5 changed files with 107 additions and 213 deletions
35
t/i18n/critic_labels.t
Normal file
35
t/i18n/critic_labels.t
Normal file
|
|
@ -0,0 +1,35 @@
|
|||
# vim:syntax=perl
|
||||
#-------------------------------------------------------------------
|
||||
# WebGUI is Copyright 2001-2008 Plain Black Corporation.
|
||||
#-------------------------------------------------------------------
|
||||
# Please read the legal notices (docs/legal.txt) and the license
|
||||
# (docs/license.txt) that came with this distribution before using
|
||||
# this software.
|
||||
#------------------------------------------------------------------
|
||||
# http://www.plainblack.com info@plainblack.com
|
||||
#------------------------------------------------------------------
|
||||
|
||||
# Write a little about what this script tests.
|
||||
#
|
||||
#
|
||||
|
||||
use Path::Class;
|
||||
use FindBin;
|
||||
use strict;
|
||||
use lib "$FindBin::Bin/../lib";
|
||||
use Test::More;
|
||||
plan skip_all => 'set CODE_COP to enable this test' unless $ENV{CODE_COP};
|
||||
|
||||
use WebGUI::Test; # Must use this before any other WebGUI modules
|
||||
use WebGUI::Session;
|
||||
|
||||
##Delay this so that the skip_all can work the way it should
|
||||
eval { require Test::Perl::Critic; };
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Init
|
||||
my $session = WebGUI::Test->session;
|
||||
|
||||
my $label_profile = Path::Class::File->new( WebGUI::Test->root , 't', 'i18n', 'perlcriticrc');
|
||||
Test::Perl::Critic->import(-profile => $label_profile->stringify);
|
||||
all_critic_ok(WebGUI::Test->lib);
|
||||
147
t/i18n/label.t
147
t/i18n/label.t
|
|
@ -1,147 +0,0 @@
|
|||
#-------------------------------------------------------------------
|
||||
# WebGUI is Copyright 2001-2008 Plain Black Corporation.
|
||||
#-------------------------------------------------------------------
|
||||
# Please read the legal notices (docs/legal.txt) and the license
|
||||
# (docs/license.txt) that came with this distribution before using
|
||||
# this software.
|
||||
#-------------------------------------------------------------------
|
||||
# http://www.plainblack.com info@plainblack.com
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
use FindBin;
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib "$FindBin::Bin/../lib"; ##t/lib
|
||||
|
||||
use WebGUI::Test;
|
||||
use WebGUI::Operation::Help;
|
||||
use WebGUI::International;
|
||||
use WebGUI::Session;
|
||||
use Text::Balanced qw(extract_codeblock);
|
||||
use File::Find;
|
||||
use Data::Dumper;
|
||||
|
||||
#The goal of this test is to locate all of the international labels that it
|
||||
#can and verify that they exist in all loaded language models
|
||||
|
||||
use Test::More; # increment this value for each test you create
|
||||
my $numTests = 0;
|
||||
plan skip_all => 'set CODE_COP to enable this test' unless $ENV{CODE_COP};
|
||||
|
||||
my $session = WebGUI::Test->session;
|
||||
my $lib = WebGUI::Test->lib;
|
||||
|
||||
# put your tests here
|
||||
|
||||
my $digits = qr/(\d+)/;
|
||||
my $bareword = qr/(\w+)/;
|
||||
#my $quotelike = qr/((['"])([^'"\s$]+\s*)+(['"]))/;
|
||||
my $quotelike = qr/((['"])([^'"\s\$]+\s*)+(['"]))/;
|
||||
my $sub_args = qr/(($quotelike|$digits)(,\s*)?)+/;
|
||||
my $sess_arg = qr/(?:\$session|\$self->session)/;
|
||||
my $subroutine = qr/
|
||||
WebGUI::International::get
|
||||
\( ##Opening paren for optional arguments
|
||||
($sub_args)
|
||||
\) ##Closing paren
|
||||
/x;
|
||||
|
||||
|
||||
my %helpTable;
|
||||
|
||||
my @helpFileSet = WebGUI::Operation::Help::_getHelpFilesList($session);
|
||||
|
||||
foreach my $helpSet (@helpFileSet) {
|
||||
my $helpName = $helpSet->[1];
|
||||
my $help = WebGUI::Operation::Help::_load($session, $helpName);
|
||||
$helpTable{ $helpName } = $help;
|
||||
}
|
||||
|
||||
##Scan #1, find all labels in the help system. body, title, @fields
|
||||
|
||||
## Array of hashes
|
||||
## each hash will have:
|
||||
## topic -> which help file it is from
|
||||
## entry -> which entry in the help file
|
||||
## tag -> which tag in the entry in the help file
|
||||
## namespace -> which help file it is form
|
||||
## label -> which help file it is form
|
||||
|
||||
my @libLabels;
|
||||
my @objLabels;
|
||||
|
||||
find(\&label_finder_pm, $lib);
|
||||
|
||||
find(\&obj_finder_pm, $lib);
|
||||
|
||||
$numTests = scalar(@libLabels)
|
||||
+ scalar(@objLabels)
|
||||
;
|
||||
|
||||
plan tests => $numTests;
|
||||
|
||||
my $i18n = WebGUI::International->new($session);
|
||||
|
||||
foreach my $label ( @libLabels ) {
|
||||
ok(0,
|
||||
sprintf "sub label: %s->%s inside %s", @{ $label }{'namespace', 'label', 'file', });
|
||||
}
|
||||
|
||||
foreach my $label ( @objLabels ) {
|
||||
ok($i18n->get(@{ $label }{qw(label namespace )} ),
|
||||
sprintf "obj label: %s->%s inside %s", @{ $label }{'namespace', 'label', 'file', });
|
||||
}
|
||||
|
||||
sub label_finder_pm {
|
||||
return unless /\.pm$/;
|
||||
open my $pmf, $_
|
||||
or die "unable to open file $File::Find::name: $!\n";
|
||||
my $libFile = '';
|
||||
{
|
||||
local $/;
|
||||
$libFile = <$pmf>;
|
||||
}
|
||||
close $pmf;
|
||||
while ($libFile =~ m/$subroutine/gc) {
|
||||
my ($label, $namespace) = split /,\s*/, $1;
|
||||
push @libLabels, {
|
||||
file=>$File::Find::name,
|
||||
label=>$label,
|
||||
namespace=>$namespace || 'WebGUI',
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
sub obj_finder_pm {
|
||||
return unless /\.pm$/;
|
||||
if ($File::Find::name =~ m#/(?:Help|i18n)/?$#) {
|
||||
diag "Pruned $File::Find::name\n";
|
||||
$File::Find::prune=1;
|
||||
return;
|
||||
}
|
||||
open my $pmf, $_
|
||||
or die "unable to open file $File::Find::name: $!\n";
|
||||
my $libFile = '';
|
||||
{
|
||||
local $/;
|
||||
$libFile = <$pmf>;
|
||||
}
|
||||
close $pmf;
|
||||
##Advance pos to first subroutine
|
||||
while ( my $subBody = extract_codeblock($libFile, '{}', qr/(?ms).*?^sub (\w+)\s*/) ) {
|
||||
while ( $subBody =~ /(\w+)\s*=\s*WebGUI::International->new\($sess_arg(?:,\s*($quotelike))?\)/msgc) {
|
||||
my $objBody = $subBody;
|
||||
my ($obj, $namespace) = ($1,$2);
|
||||
while ( $objBody =~ /$obj\->get\(($sub_args)\)/msgc ) {
|
||||
my ($label, $local_name) = split /,\s*/, $1;
|
||||
push @objLabels, {
|
||||
file=>$File::Find::name,
|
||||
label=>$label,
|
||||
namespace=>$local_name || $namespace || 'WebGUI',
|
||||
};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
2
t/i18n/perlcriticrc
Normal file
2
t/i18n/perlcriticrc
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
only = 1
|
||||
include = NoIllegalI18NLabels
|
||||
|
|
@ -13,18 +13,19 @@ use base 'Perl::Critic::Policy';
|
|||
|
||||
=head1 Perl::Critic::Policy::WebGUI::NoIllegalI18NLabels
|
||||
|
||||
Scan WebGUI modules for i18n calls and make sure that each
|
||||
call has a corresponding i18n table entry.
|
||||
Scan WebGUI modules for i18n calls and make sure that each call has a
|
||||
corresponding i18n table entry. It will not check i18n calls that have
|
||||
variables for either the namespace or the label to look up.
|
||||
|
||||
Running this policy requires setting up some environmental
|
||||
variables to that it can get a proper WebGUI session, and access
|
||||
the test library.
|
||||
Running this policy from the command line requires setting up some
|
||||
environmental variables to that it can get a proper WebGUI session,
|
||||
and access the test library.
|
||||
|
||||
env WEBGUI_CONFIG=/data/WebGUI/etc/my.conf PERL5LIB=/data/WebGUI/t/lib perlcritic -single-policy NoIllegalI18N
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '0.1';
|
||||
our $VERSION = '0.2';
|
||||
|
||||
Readonly::Scalar my $DESC => q{i18n calls that do not have corresponding i18n table entries};
|
||||
|
||||
|
|
@ -78,6 +79,7 @@ sub violates {
|
|||
return unless ref $arg_list eq 'PPI::Structure::List';
|
||||
my @arguments = _get_args($arg_list);
|
||||
my $namespace = $arguments[1]->[0];
|
||||
return unless $namespace; ##This can be a namespace in a variable.
|
||||
$namespace = $namespace->string || 'WebGUI';
|
||||
$self->{_i18n_objects}->{$symbol_name} = $namespace;
|
||||
return;
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue