diff --git a/UnitTestContrib/lib/Unit/FoswikiTestRole.pm b/UnitTestContrib/lib/Unit/FoswikiTestRole.pm
index c437e31726..4442e859c9 100644
--- a/UnitTestContrib/lib/Unit/FoswikiTestRole.pm
+++ b/UnitTestContrib/lib/Unit/FoswikiTestRole.pm
@@ -15,6 +15,7 @@ use Assert;
use Try::Tiny;
use File::Spec;
use Scalar::Util qw(blessed);
+use Foswiki::Exception;
BEGIN {
if (Unit::TestRunner::CHECKLEAK) {
@@ -32,6 +33,13 @@ use Moo::Role;
our @mails;
+=begin TML
+---++ ObjectAttribute app
+
+Test case application object.
+
+=cut
+
has app => (
is => 'rw',
lazy => 1,
@@ -46,17 +54,41 @@ has app => (
},
handles => [qw(create)],
);
+
+=begin TML
+---++ ObjectAttribute test_web
+
+Default test web name.
+
+=cut
+
has test_web => (
is => 'rw',
lazy => 1,
clearer => 1,
default => sub { return $_[0]->testWebName; },
);
+
+=begin TML
+---++ ObjectAttribute test_topic
+
+Default test topic name.
+
+=cut
+
has test_topic => (
is => 'rw',
lazy => 1,
default => sub { return 'TestTopic' . $_[0]->testSuite; },
);
+
+=begin TML
+---++ ObjectAttribute test_topic
+
+Default users web for test.
+
+=cut
+
has users_web => (
is => 'rw',
lazy => 1,
@@ -64,6 +96,8 @@ has users_web => (
);
has _holderStack => ( is => 'rw', lazy => 1, default => sub { [] }, );
+
+# List of webs created with populateNewWeb method.
has _testWebs => (
is => 'rw',
lazy => 1,
@@ -422,7 +456,12 @@ sub setupDirs {
foreach my $subdir (qw(tmp registration_approvals work_areas requestTmp)) {
my $newDir =
File::Spec->catfile( $this->app->cfg->data->{WorkingDir}, $subdir );
- ASSERT( mkdir($newDir), "mkdir($newDir) : $!" );
+ unless ( -d $newDir || mkdir($newDir) ) {
+ Foswiki::Exception::FileOp->throw(
+ file => $newDir,
+ op => "mkdir",
+ );
+ }
}
# Note this does not do much, except for some tests that use it directly.
@@ -445,6 +484,7 @@ sub setupDirs {
=begin TML
+#setupAdminUser
---++ ObjectMethod setupAdminUser(%userData)
Sets this test administrator user data. The =%userData= hash may have the
diff --git a/UnitTestContrib/lib/Unit/PlackTestCase.pm b/UnitTestContrib/lib/Unit/PlackTestCase.pm
index 77c382bb45..cd039b976e 100644
--- a/UnitTestContrib/lib/Unit/PlackTestCase.pm
+++ b/UnitTestContrib/lib/Unit/PlackTestCase.pm
@@ -1,15 +1,107 @@
# See bottom of file for license and copyright information
+package Unit::PlackTestCase;
+use v5.14;
+
=begin TML
---+ package Unit::PlackTestCase
-Base class for all =Plack::Test= based tests.
+Testing %WIKITOOLNAME% with =Plack::Test=.
-=cut
+---++ Concepts
-package Unit::PlackTestCase;
-use v5.14;
+This class providing framework for testing %WIKITOOLNAME% with
+=[[CPAN:Plack::Test][Plack::Test]]=. It must be subclassed to create a test
+case. In turn, it subclasses _Unit::TestCase_ and as such inherits most of its
+functionality.
+
+---+++ List of tests
+
+A test within test case can be defined in two ways. The first one is similar to
+=Unit::TestCase= behaviour of looking for functions with =test= prefix. Except
+that a Plack test case function must be prefixed with =client=. The different
+prefix is here to avoid messing up with =Unit::TestCase= because this
+framework's tests are called with different parameters.
+
+The other way is to override method
+=[[#PrepareTestClientList][prepareTestClientList()]]= and define your own list
+of tests. Each test in the list is defined by a hash of its properties. See
+=[[#testClientList][testClientList]]= object attribute description to read about
+them.
+
+#InitDeinit
+---+++ Initialization/deinitialization of tests
+
+In addition to =Unit::TestCase= =set_up()= and =tear_down()= methods this
+framework provide additional layers of initialization/deinitialization. Those
+are =initTest/shutdownTest= and =initRequest/shutdownRequest=. Their use is
+preferred because they provide better per-test support.
+
+The reason for separate init/deinit methods lies in the fact =Plack::Test= actually
+create a new application instance for each request being executed. This means different
+run time environments for the test code and the application code processing the request.
+
+=initTest/shutdownTest= are executed right before and after the client (test) function is called.
+
+=initRequest= is executed as early as possible in =Foswiki::App= object
+construction stage. Practically it means it's initiated using =postConfig=
+callback which is raised right after LSC is being read (or bootstrapped) but
+before any other =Foswiki::App= subsystem is initialized. This allows us to
+patch the config in a way we require and have the effect we desire in simpliest
+way possible.
+
+=shutdownRequest= is executed right after the request has been processed and
+before response is been returned.
+
+Note that this approach let us have all temporary artefacts being shared across
+both test and application environments creating semi-permanent sandbox which
+simulates a real-life case of a session in action.
+
+For each of the four init/deinit stages there is a key in test profile hash with
+the same name. The key must be a code ref allowing easy adjustments being made
+on a per-test level. In other words, instead of writing somethingl like this:
+
+
+around initRequest => sub {
+ my $orig = shift;
+ my $this = shift;
+ my %args = @_;
+
+ $orig->($this, @_);
+
+ if ($args{testParams}{name} eq 'Test1') {
+ ...; # Do something specific for Test1
+ }
+};
+
+
+we can have it this way:
+
+
+around prepareTestClientList => sub {
+ my $orig = shift;
+ my $this = shift;
+
+ my $tests = $orig->($this, @_);
+
+ push @$tests, (
+ {
+ name => 'Test1',
+ client => \&_test1, # Actual test code
+ initRequest => sub {
+ ...; # Do something specific for this test
+ },
+ },
+ );
+ return $tests;
+};
+
+This way it is much easier to control all test-specific details.
+
+
+
+=cut
use Plack::Test;
use File::Spec;
@@ -24,20 +116,94 @@ with qw(Foswiki::Aux::Localize Unit::FoswikiTestRole);
=begin TML
+#testClientList
---++ ObjectAttribute testClientList : arrayref
-List of hashrefs with test parameters.
+List of hashrefs with test parameters. Each hash ref may have the following keys:
Keys:
- * =app=
- * =appClass=
- * =appParams=
- * =client= - required, client sub
- * =init= – additional init sub for test
- * =adminUser= - hashref, {wikiname=>'AdminUserWikiName', login => 'admin', group => 'AdminGroup',}; see =Unit::FoswikiTestRole= =setupAdminUser= method.
- * =testWebs= – hash of test webs to be created for the test where each key is a hashref to topicName => "topic text",
- * =testUsers= - array of users to be registered for testing purposes. Each element is a hashref with keys =login=, =forename=, =surname=, =email=, =group=; see =Unit::FosdwikiTestRole= =registerUser()= method.
+|*Key*|*Attributes*|*Description*|*Default*|
+| =name= | _required_ | Test name. Must be a valid Perl identifier. | |
+| =client= | _required_ | Reference to the test sub. | |
+| =appClass= | | Defines class of application object. | =Unit::TestApp= |
+| =appParams= | | Hash of application constructor parameters. See the application class documentation. | ={}= |
+| =initTest= | | Coderef to test-specific init sub | |
+| =shutdownTest= | | Coderef to test-specific deinitialize sub | |
+| =initRequest= | | Coderef to test-specific request init sub | |
+| =shutdownRequest= | | Coderef to test-specific request deinitialize sub | |
+| =adminUser= | | Default admin user defined by a hashref of =wikiname=, =login=, =group= keys. | See =Unit::FoswikiTestRole= =setupAdminUser()= method. |
+| =testWebs= | | Hash of webs to create for this test. Keys define web names. Values are hashes of ='TopicName' => "Topic Text"= pairs. | |
+| =testUsers= | | List of users to create for this test. Elements are hashes with keys =login=, =forename=, =surname=, =email=, =group= describing each user. | |
+
+*Example*
+
+
+around prepareTestClientList => sub {
+ my $orig = shift;
+ my $this = shift;
+ my $tests = $orig->( $this, @_ );
+
+ my $sameplTestWeb = $this->testWebName('SampleTest');
+ push @$tests, (
+ {
+ name => sample_test,
+ client => \&_sample_test,
+ appParams => {
+ requestParams => {
+ initializer => '',
+ },
+ engineParams => {
+ user => $this->app->cfg->{AdminUserLogin},
+ method => 'GET',
+ path => "/$sampleTestWeb/" . "SampleTestTopic1",
+ },
+ },
+ initRequest => sub {
+ my $this = shift;
+ $this->app->cfg->data->{DisableAllPlugins} = 1;
+ },
+ adminUser => {
+ wikiname => 'SampleAdmin',
+ login => 'sadmin',
+ group => 'SampleAdminGroup',
+ },
+ testWebs => {
+ $sampleTestWeb => {
+ SampleTestTopic1 => "This is test topic 1.",
+ SampleTestTopic2 => "This is test topic 2.",
+ },
+ ThisWebNameIsNotGood => {
+ # This web name is not recommended for tests.
+ UselessTopic => "Text doesn't matter.",
+ },
+ $this->testWebName("PreferableUse") => {
+ # This is how web names should be formed.
+ AnotherTopic => "This is a topic from web with recommended name",
+ },
+ },
+ testUsers => [
+ {
+ login => 'user1',
+ forename => 'User1',
+ surname => 'SurUser1',
+ email => 'user1@example.com',
+ group => 'TestGroup',
+ },
+ {
+ login => 'user2',
+ forename => 'User2',
+ surname => 'SurUser2',
+ email => 'user2@example.com',
+ group => 'TestGroup',
+ },
+ ],
+ },
+ );
+
+ return $tests;
+};
+
=cut
@@ -47,6 +213,18 @@ has testClientList => (
isa => Foswiki::Object::isaARRAY( 'testList', noUndef => 1, ),
builder => 'prepareTestClientList',
);
+
+=begin TML
+---++ ObjectAttribute defaultAppClass
+
+Default name of the class to instantiate the application object.
+
+*Important note* Because a lot of this class' functionality depends upon
+=Unit::TestApp= provided services the replacement class must either subclass it
+or mimic the behaviour.
+
+=cut
+
has defaultAppClass => (
is => 'rw',
default => 'Unit::TestApp',
@@ -84,6 +262,20 @@ sub _execPerTestStageCode {
}
}
+=begin TML
+
+---++ ObjectMethod initTest(%args)
+
+This methods gets called right before every individual test is been run.
+
+=%args= contains following keys:
+
+| *Key* | *Description* |
+| =testParams= | Hash of parameters of the next test to be run. See =testClientList= attribute description. |
+| =plackTestObj= | A instance of =Plack::Test= class. |
+
+=cut
+
sub initTest {
my $this = shift;
my %args = @_;
@@ -153,6 +345,15 @@ sub initTest {
$this->_execPerTestStageCode( 'initTest', @_ );
}
+=begin TML
+
+---++ ObjectMethod shutdownTest(%args)
+
+This method is been called right after each individual test finishes. =%args=
+keys are the same as in =initTest()=.
+
+=cut
+
sub shutdownTest {
my $this = shift;
@@ -163,18 +364,66 @@ sub shutdownTest {
$this->restoreEnvironment;
}
+=begin TML
+
+---++ ObjectMethod initRquest( %args )
+
+This method is called in server context upon every request. See the section
+about [[#InitDeinit][initialization/deinitialization]].
+
+=%args= contains following keys:
+
+| *Key* | *Description* |
+| =data= | Callback user supplied data. Because callbacks are registered using =Unit::TestApp= =registerCallbacks()= method this would be a hash with the only key =app= pointing to the server application object. |
+| =params= | Callback caller suplpied parameters. =postConfig= doesn't provide any so this is gonna be undef but it may change is the future. |
+| =serverApp= | Points to server application object. It duplicates data's =app= key but is here to code readability. |
+| =testParams= | Hash of parameters of the next test to be run. See =testClientList= attribute description. |
+
+Note that this method is called on the test case object and =$this->app= points
+to test case's application instance which is different from =serverApp= key.
+
+=cut
+
sub initRequest {
my $this = shift;
+ my %args = @_;
+
+ my $params = $args{testParams};
+
+ $this->setupPlugins;
+ $this->setupDirs;
+ $this->setupUserRegistration;
+ $this->setupAdminUser( %{ $params->{adminUser} // {} } );
$this->_execPerTestStageCode( 'initRequest', @_ );
}
+=begin TML
+
+---++ ObjectMethod shutdownRequest( %args )
+
+This methods is called when request processing is finished right before sending
+back a response.
+
+=%args= is the same as for =initRequest()= method.
+
+=cut
+
sub shutdownRequest {
my $this = shift;
$this->_execPerTestStageCode( 'shutdownRequest', @_ );
}
+=begin TML
+
+---++ ObjectMethod list_tests() => @tests
+
+Completely overrides =list_tests()= from =Unit::TestCase=. Prepares tests using
+=testClientList= attribute.
+
+=cut
+
around list_tests => sub {
my $orig = shift;
my $this = shift;
@@ -184,8 +433,11 @@ around list_tests => sub {
my $suite = $this->testSuite;
foreach my $clientHash ( @{ $this->testClientList } ) {
+ # SMELL name must be checked to be a valid Perl identifier too.
$this->assert_not_null( $clientHash->{name},
- "client test name undefined" );
+ "client test name is undefined" );
+ $this->assert_not_null( $clientHash->{client},
+ "client $clientHash->{name} code is undefined" );
unless ( defined $clientHash->{appSub} ) {
$clientHash->{appSub} = $this->_genDefaultAppSub($clientHash);
@@ -196,14 +448,17 @@ around list_tests => sub {
*{"$suite\:\:$testSubName"} = sub {
my $test = Plack::Test->create( $clientHash->{appSub} );
$this->initTest(
- testParams => $clientHash,
- testObject => $test
+ testParams => $clientHash,
+ plackTestObj => $test
+ );
+ $clientHash->{client}->(
+ $this,
+ testParams => $clientHash,
+ plackTestObj => $test,
);
- $clientHash->{client}
- ->( $this, testParams => $clientHash, testObject => $test, );
$this->shutdownTest(
- testParams => $clientHash,
- testObject => $test
+ testParams => $clientHash,
+ plackTestObj => $test
);
};
use strict 'refs';
@@ -214,6 +469,18 @@ around list_tests => sub {
return @tests;
};
+=begin TML
+
+#PrepareTestClientList
+---++ ObjectMethod prepareTestClientList() => @testList
+
+=testClientList= object attribute initializer.
+
+Reads all subs with names prefixed by 'client' and builds a list of these tests.
+For a test case to build a manual list of tests this methods must be overriden.
+
+=cut
+
sub prepareTestClientList {
my $this = shift;
my @tests;
@@ -221,7 +488,7 @@ sub prepareTestClientList {
my $clz = new Devel::Symdump($suite);
foreach my $method ( $clz->functions ) {
- next unless $method =~ /^$suite\:\:(client_(.+))$/;
+ next unless $method =~ /^$suite\:\:(client(.+))$/;
my $subName = $1;
my $shortName = $2;
push @tests, { name => $shortName, client => $suite->can($subName), };
@@ -235,9 +502,7 @@ sub _cbPostConfig {
my $clientHash = shift;
my %args = @_;
- $this->saveState;
- $this->app($app);
- $this->initRequest( %args, testParams => $clientHash );
+ $this->initRequest( %args, testParams => $clientHash, serverApp => $app, );
}
sub _cbPostHandleRequest {
@@ -246,8 +511,11 @@ sub _cbPostHandleRequest {
my $clientHash = shift;
my %args = @_;
- $this->shutdownRequest( %args, testParams => $clientHash, );
- $this->restoreState;
+ $this->shutdownRequest(
+ %args,
+ testParams => $clientHash,
+ serverApp => $app,
+ );
}
sub _genDefaultAppSub {
@@ -256,8 +524,6 @@ sub _genDefaultAppSub {
my %runArgs = %{ $clientHash->{appParams} // {} };
- my $appClass = $clientHash->{appClass} // $this->defaultAppClass;
-
# Users must not use this callback.
$runArgs{callbacks}{postConfig} = sub {
my $app = shift;
@@ -273,12 +539,25 @@ sub _genDefaultAppSub {
$runArgs{env} = { ( %$env, %{ $clientHash->{appParams}{env} // {} } ) };
+ my $appClass = $clientHash->{appClass} // $this->defaultAppClass;
+
my $rc = $appClass->run(%runArgs);
return $rc;
};
}
+=begin TML
+
+---++ ObjectMethod writeTopic( $web, $topic, $text ) => $topicObject
+
+Simple shortcut for creating a topic defined by =$web= and =$topic= using
+=$text=.
+
+Returns initialized =Foswiki::Meta= object.
+
+=cut
+
sub writeTopic {
my $this = shift;
my ( $web, $topic, $text ) = @_;
@@ -291,13 +570,88 @@ sub writeTopic {
}
=begin TML
-
+
+---++ ObjectMethod findHTMLTag( $html, %criteria ) => $matchedEntity
+
+Simple search for a particular tag in HTML page in =$html= parameter.
+=%criteria= hash must contain mandatory key =tag= which defines HTML entity to
+look for ('a', 'input', 'form', etc.). Optionally it may have =text= key which
+defines what text must exists between opening and closing tags of the entity.
+All other keys are considered tag attributes.
+
+Values of the criteria hash could be either simple text values or regexps defined
+with =qr//= quote.
+
+Text must not be a single entity and not split by any HTML tags. For example, if
+we're looking for a word 'Attach' then the following example will fail to match:
+
+
+Attach
+
+
+When criteria hash doesn't have the =text= key the first matching entity will be
+returned. Otherwise the one directly enclosing the text is returned.
+
+Return a hash ref describing the matched entity. The hash contains keys =tag=, =attrs=
+(entity attributes), =text=.
+
+*Examples*
+
+|*HTML*| |
+
+---++++ Simple tag search
+
+
$this->findHTMLTag(
- tag => 'a',
- class => qr//,
- text => 'Attach',
+ $html,
+ tag => 'div',
);
+
+Returns:
+{
+ tag => 'div',
+ attrs => { class => 'class1' },
+}
+
+
+---++++ Search with text
+
+
+$this->findHTMLTag(
+ $html,
+ tag => 'div',
+ text => qr/Test\s/,
+);
+
+
+Returns:
+{
+ tag => 'div',
+ attrs => { class => 'class2' },
+ text => 'Test text',
+}
+
+
+---++++ Attribute search with text
+
+
+$this->findHTMLTag(
+ $html,
+ tag => qr/./,
+ class => 'class1',
+ text => qr/Test\s/,
+);
+
+
+Returns:
+{
+ tag => 'form',
+ attrs => { class => 'class1', id => "formID", },
+ text => 'Test text',
+}
+
+
=cut
sub _smartMatch {
@@ -371,6 +725,7 @@ sub findHTMLTag {
&& ( !$textPat || $this->_smartMatch( $text, $textPat ) ) )
{
$matchedEntity = $lastCandidate;
+ $matchedEntity->{text} = $text;
$p->eof;
return;
}
@@ -385,6 +740,7 @@ sub findHTMLTag {
$parser->parse($html);
+ delete $matchedEntity->{matched};
return $matchedEntity;
}
@@ -401,6 +757,16 @@ sub setLocalizableAttributes {
return qw(app);
}
+=begin TML
+
+---++ See Also
+
+=Foswiki::Aux::Localize=, =Unit::FoswikiTestRole=, =Plack::Test=,
+=[[CPAN:HTTP::Request::Common][HTTP::Request::Common]]=.
+
+
+=cut
+
1;
__END__
Foswiki - The Free and Open Source Wiki, http://foswiki.org/
diff --git a/UnitTestContrib/lib/Unit/TestCase.pm b/UnitTestContrib/lib/Unit/TestCase.pm
index 660a270eb7..b307a5c58c 100644
--- a/UnitTestContrib/lib/Unit/TestCase.pm
+++ b/UnitTestContrib/lib/Unit/TestCase.pm
@@ -169,7 +169,7 @@ sub fixture_groups {
=begin TML
----++ ObjectMethod list_tests() -> $list
+---++ ObjectMethod list_tests() -> @list
Returns a list of the names of test functions defined by the testcase.
This method can be overridden to give an alternative list of tests.
diff --git a/UnitTestContrib/test/unit/PlackPostTests.pm b/UnitTestContrib/test/unit/PlackPostTests.pm
index d43b7feb23..e7211e978b 100644
--- a/UnitTestContrib/test/unit/PlackPostTests.pm
+++ b/UnitTestContrib/test/unit/PlackPostTests.pm
@@ -47,8 +47,10 @@ around prepareTestClientList => sub {
],
initRequest => sub {
my $this = shift;
- $this->app->cfg->data->{Validation}{Method} = 'none';
- $this->app->cfg->data->{DisableAllPlugins} = 1;
+ my %args = @_;
+ my $app = $args{serverApp};
+ $app->cfg->data->{Validation}{Method} = 'none';
+ $app->cfg->data->{DisableAllPlugins} = 1;
},
},
);
@@ -60,7 +62,7 @@ sub _test_attach_simple {
my %args = @_;
my $app = $this->app;
- my $test = $args{testObject};
+ my $test = $args{plackTestObj};
my $web = ( keys %{ $args{testParams}{testWebs} } )[0];
my $topic = ( keys %{ $args{testParams}{testWebs}{$web} } )[0];
diff --git a/UnitTestContrib/test/unit/PlackViewTests.pm b/UnitTestContrib/test/unit/PlackViewTests.pm
index 9ef2c52e7b..798ed870cd 100644
--- a/UnitTestContrib/test/unit/PlackViewTests.pm
+++ b/UnitTestContrib/test/unit/PlackViewTests.pm
@@ -18,12 +18,15 @@ around prepareTestClientList => sub {
push @$tests, (
{
- client => \&client_simple,
- name => 'probe',
- init => sub {
+ # This is intentional use of client-prefixed function to demonstrate
+ # both methods of defining a test. What makes these tests different
+ # is initRequest key.
+ client => \&clientSimple,
+ name => 'probe',
+ initRequest => sub {
my $this = shift;
my %args = @_;
- my $app = $args{data}{app};
+ my $app = $args{serverApp};
$app->cfg->data->{UsersWebName} = 'Sandbox';
},
@@ -33,11 +36,11 @@ around prepareTestClientList => sub {
return $tests;
};
-sub client_simple {
+sub clientSimple {
my $this = shift;
my %args = @_;
- my $test = $args{testObject};
+ my $test = $args{plackTestObj};
my $expected =
' Welcome to the Main web
diff --git a/core/lib/Foswiki/Exception.pm b/core/lib/Foswiki/Exception.pm
index 7387780ef2..acf805854a 100644
--- a/core/lib/Foswiki/Exception.pm
+++ b/core/lib/Foswiki/Exception.pm
@@ -404,7 +404,7 @@ extends qw(Foswiki::Exception);
sub BUILD {
my $this = shift;
- say STDERR $this->stacktrace;
+ say STDERR $this->stringify, $this->stacktrace;
}
# To cover perl/system errors.
diff --git a/core/lib/Foswiki/IncludeHandlers/doc.pm b/core/lib/Foswiki/IncludeHandlers/doc.pm
index a8dd124f38..9aa12b77d9 100644
--- a/core/lib/Foswiki/IncludeHandlers/doc.pm
+++ b/core/lib/Foswiki/IncludeHandlers/doc.pm
@@ -11,11 +11,13 @@ method INCLUDE which generates perl documentation for a Foswiki class.
=cut
package Foswiki::IncludeHandlers::doc;
+use v5.14;
use strict;
use warnings;
-use Foswiki ();
+use File::Spec ();
+use Foswiki ();
BEGIN {
if ( $Foswiki::cfg{UseLocale} ) {
@@ -50,16 +52,9 @@ sub INCLUDE {
my $visibility = exists $publicPackages{$class} ? 'public' : 'internal';
_setNavigation( $app, $class, $publicOnly, \%publicPackages );
$app->prefs->setSessionPreferences( 'DOC_TITLE',
- "---++ !! =$visibility package= " . _renderTitle($class) );
+ "---++ !! =$visibility package= " . _renderTitle( $app, $class ) );
- my $pmfile;
- $class =~ s#::#/#g;
- foreach my $inc (@INC) {
- if ( -f "$inc/$class.pm" ) {
- $pmfile = "$inc/$class.pm";
- last;
- }
- }
+ my $pmfile = _getPmFile( $app, $class );
return '' unless $pmfile;
my $PMFILE;
@@ -73,9 +68,11 @@ sub INCLUDE {
my $isa;
my $inSuppressedMethod;
- if ( $perl =~ m/our\s+\@ISA\s*=\s*\(\s*['"](.*?)['"]\s*\)/ ) {
+ if ( $perl =~ m/our\s+\@ISA\s*=\s*\(\s*['"](.*?)['"]\s*\)/
+ || $perl =~ m/extends\s+(?:qw\(|'|")(.+?)(?:\)|'|");/ )
+ {
$isa = " ==is a== $1";
- $isa =~ s#\s(Foswiki(?:::[A-Z]\w+)+)#' ' . _doclink($1)#ge;
+ $isa =~ s#\s(\w+?(?:::[A-Z]\w+)+)#' ' . _doclink($app, $1)#ge;
}
$perl = Foswiki::takeOutBlocks( $perl, 'verbatim', \%removedblocks );
foreach my $line ( split( /\r?\n/, $perl ) ) {
@@ -96,9 +93,13 @@ sub INCLUDE {
s/^---\+(?:!!)?\s+package\s*(.*)/---+ =$visibility package= $1/;
}
else {
- $line =~ s#\b(Foswiki(?:::[A-Z]\w+)+)#_doclink($1)#ge;
+ # Check for module names not prefixed with colon or left square
+ # bracket.
+ $line =~
+ s#(?\s+/ → /;
if ( $publicOnly && $line =~ m/Method=\s+_/ ) {
$inSuppressedMethod = 1;
@@ -149,6 +150,25 @@ s/^---\+(?:!!)?\s+package\s*(.*)/---+ =$visibility package= $1/;
return $pod;
}
+sub _getPmFile {
+ my ( $app, $class ) = @_;
+ state %cachedPMs;
+ state $fwPath;
+
+ unless ( defined $fwPath ) {
+ $fwPath = ( File::Spec->splitpath( $INC{'Foswiki.pm'} ) )[1];
+ }
+
+ return $cachedPMs{$class} if $cachedPMs{$class};
+
+ my $pmfile = '';
+ ( my $classFile = $class ) =~ s#::#/#g;
+ $classFile = File::Spec->catfile( $fwPath, "$classFile.pm" );
+ $pmfile = $classFile if ( -f $classFile );
+ $cachedPMs{$class} = $pmfile;
+ return $pmfile;
+}
+
# set DOC_CHILDREN preference value to a list of sub-packages.
sub _setNavigation {
my ( $app, $class, $publicOnly, $publicPackages ) = @_;
@@ -158,7 +178,7 @@ sub _setNavigation {
# my $classParent = $class;
# $classParent =~ s/::[^:]+$//;
-# $app->prefs->setSessionPreferences( 'DOC_PARENT', _doclink($classParent) );
+# $app->prefs->setSessionPreferences( 'DOC_PARENT', _doclink($app, $classParent) );
$class =~ s#::#/#g;
foreach my $inc (@INC) {
@@ -186,7 +206,7 @@ sub _setNavigation {
foreach my $child (@children) {
my $desc =
$childrenDesc{$child} ? ' - ' . $childrenDesc{$child} : '';
- $children .= '' . _doclink($child) . "$desc\n";
+ $children .= '' . _doclink( $app, $child ) . "$desc\n";
}
}
$children .= '';
@@ -257,22 +277,37 @@ sub _loadPublishedAPI {
# Make each intermediate package into a doc link.
sub _renderTitle {
- my $pack = $_[0];
+ my $app = shift;
+ my $pack = $_[0];
my @packComps = split '::', $pack;
my @packLinks =
- map { _doclink( ( join '::', @packComps[ 0 .. $_ ] ), $packComps[$_] ) }
- 0 .. $#packComps - 1;
+ map {
+ _doclink( $app, ( join '::', @packComps[ 0 .. $_ ] ), $packComps[$_] )
+ } 0 .. $#packComps - 1;
my $packageTitle = join '::', @packLinks, $packComps[$#packComps];
return $packageTitle;
}
sub _doclink ($) {
+ my $app = shift;
my $module = $_[0];
+ $module =~ s/^_(.+)(_)$/$1/;
+ my $formatChar = $2 // '';
my $title = $_[1] || $module;
+ my $pmfile = _getPmFile( $app, $module );
+
# SMELL relying on TML to set publicOnly
- return
-"[[%SCRIPTURL{view}%/%SYSTEMWEB%/PerlDoc?module=$module%IF{\"\$publicOnly = 'on'\" then=\";publicOnly=on\"}%][$title]]";
+ return $formatChar
+ . (
+ $pmfile
+ ? ( "[[%SCRIPTURL{view}%/%SYSTEMWEB%/PerlDoc?module="
+ . $module
+ . "%IF{\"\$publicOnly = 'on'\" then=\";publicOnly=on\"}%]["
+ . $title
+ . "]]" )
+ : "[[CPAN:$module][$title]]"
+ ) . $formatChar;
}
1;
diff --git a/core/lib/Foswiki/Macros.pm b/core/lib/Foswiki/Macros.pm
index c496672700..8a3e26b726 100644
--- a/core/lib/Foswiki/Macros.pm
+++ b/core/lib/Foswiki/Macros.pm
@@ -6,10 +6,8 @@ use v5.14;
use Foswiki qw(%regex expandStandardEscapes);
use Foswiki::Attrs ();
-use Moo;
-use namespace::clean;
+use Foswiki::Class qw(app);
extends qw(Foswiki::Object);
-with qw(Foswiki::AppObject);
use Assert;
@@ -473,10 +471,6 @@ sub _processMacros {
$stackTop .=
$this->_processMacros( $e, $tagf, $topicObject,
$depth - 1 );
- ASSERT(
- $stackTop !~ /Foswiki::Macr/,
- "Foswiki::Macros for $tag"
- );
}
else {