This file is indexed.

/usr/share/perl5/Test/ClassAPI.pm is in libtest-classapi-perl 1.07-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
package Test::ClassAPI; # git description: 7ff3c00
# ABSTRACT: Provides basic first-pass API testing for large class trees

# Allows us to test class APIs in a simplified manner.
# Implemented as a wrapper around Test::More, Class::Inspector and Config::Tiny.

use 5.006;
use strict;
use File::Spec       0.83 ();
use Test::More       0.47 ();
use Config::Tiny     2.00 ();
use Class::Inspector 1.12 ();
use Params::Util     1.00 '_INSTANCE';

our $VERSION = '1.07';

use vars qw{$CONFIG $SCHEDULE $EXECUTED %IGNORE *DATA};
BEGIN {
	# Config starts empty
	$CONFIG   = undef;
	$SCHEDULE = undef;

	# We only execute once
	$EXECUTED = '';

	# When looking for method that arn't described in the class
	# description, we ignore anything from UNIVERSAL.
	%IGNORE = map { $_, 1 } qw{isa can};
}

# Get the super path ( not including UNIVERSAL )
# Rather than using Class::ISA, we'll use an inlined version
# that implements the same basic algorithm, but faster.
sub _super_path($) {
	my $class = shift;
	my @path  = ();
	my @queue = ( $class );
	my %seen  = ( $class => 1 );
	while ( my $cl = shift @queue ) {
		no strict 'refs';
		push @path, $cl;
		unshift @queue, grep { ! $seen{$_}++ }
			map { s/^::/main::/; s/\'/::/g; $_ }
			( @{"${cl}::ISA"} );
	}

	@path;
}





#####################################################################
# Main Methods

# Initialise the Configuration
sub init {
	my $class = shift;

	# Use the script's DATA handle or one passed
	*DATA = ref($_[0]) eq 'GLOB' ? shift : *main::DATA;
 
	# Read in all the data, and create the config object
	local $/ = undef;
	$CONFIG = Config::Tiny->read_string( <DATA> )
		or die 'Failed to load test configuration: '
			. Config::Tiny->errstr;
	$SCHEDULE = delete $CONFIG->{_}
		or die 'Config does not have a schedule defined';

	# Add implied schedule entries
	foreach my $tclass ( keys %$CONFIG ) {
		$SCHEDULE->{$tclass} ||= 'class';
		foreach my $test ( keys %{$CONFIG->{$tclass}} ) {
			next unless $CONFIG->{$tclass}->{$test} eq 'implements';
			$SCHEDULE->{$test} ||= 'interface';
		}
	}
	

	# Check the schedule information
	foreach my $tclass ( keys %$SCHEDULE ) {
		my $value = $SCHEDULE->{$tclass};
		unless ( $value =~ /^(?:class|abstract|interface)$/ ) {
			die "Invalid schedule option '$value' for class '$tclass'";
		}
		unless ( $CONFIG->{$tclass} ) {
			die "No section '[$tclass]' defined for schedule class";
		}
	}

	1;
}

# Find and execute the tests
sub execute {
	my $class = shift;
	if ( $EXECUTED ) {
		die 'You can only execute once, use another test script';
	}
	$class->init unless $CONFIG;

	# Handle options
	my @options = map { lc $_ } @_;
	my $CHECK_UNKNOWN_METHODS     = !! grep { $_ eq 'complete'   } @options;
	my $CHECK_FUNCTION_COLLISIONS = !! grep { $_ eq 'collisions' } @options;

	# Set the plan of no plan if we don't have a plan
	unless ( Test::More->builder->has_plan ) {
		Test::More::plan( 'no_plan' );
	}

	# Determine the list of classes to test
	my @classes = sort keys %$SCHEDULE;
	@classes = grep { $SCHEDULE->{$_} ne 'interface' } @classes;

	# Check that all the classes/abstracts are loaded
	foreach my $class ( @classes ) {
		Test::More::ok( Class::Inspector->loaded( $class ), "Class '$class' is loaded" );
	}

	# Check that all the full classes match all the required interfaces
	@classes = grep { $SCHEDULE->{$_} eq 'class' } @classes;
	foreach my $class ( @classes ) {
		# Find all testable parents
		my @path = grep { $SCHEDULE->{$_} } _super_path($class);

		# Iterate over the testable entries
		my %known_methods = ();
		my @implements = ();
		foreach my $parent ( @path ) {
			foreach my $test ( sort keys %{$CONFIG->{$parent}} ) {
				my $type = $CONFIG->{$parent}->{$test};

				# Does the class have a named method
				if ( $type eq 'method' ) {
					$known_methods{$test}++;
					Test::More::can_ok( $class, $test );
					next;
				}

				# Does the class inherit from a named parent
				if ( $type eq 'isa' ) {
					Test::More::ok( $class->isa($test), "$class isa $test" );
					next;
				}

				unless ( $type eq 'implements' ) {
					print "# Warning: Unknown test type '$type'";
					next;
				}
				
				# When we 'implement' a class or interface,
				# we need to check the 'method' tests within
				# it, but not anything else. So we will add
				# the class name to a seperate queue to be
				# processed afterwards, ONLY if it is not
				# already in the normal @path, or already
				# on the seperate queue.
				next if grep { $_ eq $test } @path;
				next if grep { $_ eq $test } @implements;
				push @implements, $test;
			}
		}

		# Now, if it had any, go through and check the classes added
		# because of any 'implements' tests
		foreach my $parent ( @implements ) {
			foreach my $test ( keys %{$CONFIG->{$parent}} ) {
				my $type = $CONFIG->{$parent}->{$test};
				if ( $type eq 'method' ) {
					# Does the class have a method
					$known_methods{$test}++;
					Test::More::can_ok( $class, $test );
				}
			}
		}

		if ( $CHECK_UNKNOWN_METHODS ) {
			# Check for unknown public methods
			my $methods = Class::Inspector->methods( $class, 'public', 'expanded' )
				or die "Failed to find public methods for class '$class'";
			@$methods = grep { $_->[2] !~ /^[A-Z_]+$/ } # Internals stuff
				grep { $_->[1] ne 'Exporter' } # Ignore Exporter methods we don't overload
				grep { ! ($known_methods{$_->[2]} or $IGNORE{$_->[2]}) } @$methods;
			if ( @$methods ) {
				print STDERR join '', map { "# Found undocumented method '$_->[2]' defined at '$_->[0]'\n" } @$methods;
			}
			Test::More::is( scalar(@$methods), 0, "No unknown public methods in '$class'" );
		}

		if ( $CHECK_FUNCTION_COLLISIONS ) {
			# Check for methods collisions.
			# A method collision is where
			#
			#     Foo::Bar->method
			#
			# is actually interpreted as
			#
			#     &Foo::Bar()->method
			#
			no strict 'refs';
			my @collisions = ();
			foreach my $symbol ( sort keys %{"${class}::"} ) {
				next unless $symbol =~ s/::$//;
				next unless defined *{"${class}::${symbol}"}{CODE};
				print STDERR "Found function collision: ${class}->${symbol} clashes with ${class}::${symbol}\n";
				push @collisions, $symbol;
			}
			Test::More::is( scalar(@collisions), 0, "No function/class collisions in '$class'" );
		}
	}

	1;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::ClassAPI - Provides basic first-pass API testing for large class trees

=head1 VERSION

version 1.07

=head1 DESCRIPTION

For many APIs with large numbers of classes, it can be very useful to be able
to do a quick once-over to make sure that classes, methods, and inheritance
is correct, before doing more comprehensive testing. This module aims to
provide such a capability.

=head2 Using Test::ClassAPI

Test::ClassAPI is used with a fairly standard looking test script, with the
API description contained in a __DATA__ section at the end of the script.

  #!/usr/bin/perl
  
  # Test the API for Foo::Bar
  use strict;
  use Test::More 'tests' => 123; # Optional
  use Test::ClassAPI;
  
  # Load the API to test
  use Foo::Bar;
  
  # Execute the tests
  Test::ClassAPI->execute;
  
  __DATA__
  
  Foo::Bar::Thing=interface
  Foo::Bar::Object=abstract
  Foo::Bar::Planet=class
  
  [Foo::Bar::Thing]
  foo=method
  
  [Foo::Bar::Object]
  bar=method
  whatsit=method
  
  [Foo::Bar::Planet]
  Foo::Bar::Object=isa
  Foo::Bar::Thing=isa
  blow_up=method
  freeze=method
  thaw=method

Looking at the test script, the code itself is fairly simple. We first load
Test::More and Test::ClassAPI. The loading and specification of a test plan
is optional, Test::ClassAPI will provide a plan automatically if needed.

This is followed by a compulsory __DATA__ section, containing the API
description. This description is in provided in the general form of a Windows
style .ini file and is structured as follows.

=head2 Class Manifest

At the beginning of the file, in the root section of the config file, is a
list of entries where the key represents a class name, and the value is one
of either 'class', 'abstract', or 'interface'.

The 'class' entry indicates a fully fledged class. That is, the class is
tested to ensure it has been loaded, and the existance of every method listed
in the section ( and its superclasses ) is tested for.

The 'abstract' entry indicates an abstract class, one which is part of our
class tree, and needs to exist, but is never instantiated directly, and thus
does not have to itself implement all of the methods listed for it. Generally,
many individual 'class' entries will inherit from an 'abstract', and thus a
method listed in the abstract's section will be tested for in all the 
subclasses of it.

The 'interface' entry indicates an external interface that is not part of
our class tree, but is inherited from by one or more of our classes, and thus
the methods listed in the interface's section are tested for in all the 
classes that inherit from it. For example, if a class inherits from, and
implements, the File::Handle interface, a C<File::Handle=interface> entry
could be added, with the C<[File::Handle]> section listing all the methods
in File::Handle that our class tree actually cares about. No tests, for class
or method existance, are done on the interface itself.

=head2 Class Sections

Every class listed in the class manifest B<MUST> have an individual section,
indicated by C<[Class::Name]> and containing a set of entries where the key
is the name of something to test, and the value is the type of test for it.

The 'isa' test checks inheritance, to make sure that the class the section is
for is (by some path) a sub-class of something else. This does not have to be
an immediate sub-class. Any class refered to (recursively) in a 'isa' test
will have its 'method' test entries applied to the class as well.

The 'method' test is a simple method existance test, using C<UNIVERSAL::can>
to make sure that the method exists in the class.

=head1 METHODS

=head2 execute

The C<Test::ClassAPI> has a single method, C<execute> which is used to start
the testing process. It accepts a single option argument, 'complete', which
indicates to the testing process that the API listed should be considered a
complete list of the entire API. This enables an additional test for each
class to ensure that B<every> public method in the class is detailed in the
API description, and that nothing has been "missed".

=head1 SUPPORT

Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Test-ClassAPI>
(or L<bug-Test-ClassAPI@rt.cpan.org|mailto:bug-Test-ClassAPI@rt.cpan.org>).

=head1 AUTHOR

Adam Kennedy <adamk@cpan.org>

=head1 CONTRIBUTORS

=for stopwords Adam Kennedy Karen Etheridge

=over 4

=item *

Adam Kennedy <adam@ali.as>

=item *

Karen Etheridge <ether@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2003 by Adam Kennedy.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut