/usr/share/perl5/Class/Adapter/Clear.pm is in libclass-adapter-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 | package Class::Adapter::Clear;
=pod
=head1 NAME
Class::Adapter::Clear - A handy base Adapter class that makes no changes
=head1 SYNOPSIS
B<Hello World with CGI.pm the normal way>
# Load and create the CGI
use CGI;
$q = new CGI;
# Create the page
print $q->header, # HTTP Header
$q->start_html('hello world'), # Start the page
$q->h1('hello world'), # Hello World!
$q->end_html; # End the page
B<Hello World with CGI.pm the Adapter'ed way>
# Load and create the CGI
use CGI;
$q = new CGI;
# Convert to an Adapter
use Class::Adapter::Clear;
$q = new Class::Adapter::Clear( $q );
# Create the page
print $q->header, # HTTP Header
$q->start_html('hello world'), # Start the page
$q->h1('hello world'), # Hello World!
$q->end_html; # End the page
B<Creating a CGI Adapter class using Class::Adapter::Clear>
package My::CGI;
use base 'Class::Adapter::Clear';
# Optional - Create the thing we are decorating auto-magically
sub new {
my $class = shift;
# Create the object we are decorating
my $query = CGI->new(@_);
# Wrap it in the Adapter
$class->SUPER::new($query);
}
# Decorate the h1 method to change what is created
sub h1 {
my $self = shift;
my $str = shift;
# Do something before the real method call
if ( defined $str and $str eq 'hello world' ) {
$str = 'Hello World!';
}
$self->_OBJECT_->($str, @_);
}
=head1 DESCRIPTION
C<Class::Adapter::Clear> provides the base class for creating one common
type of L<Class::Adapter> classes. For more power, move up to
L<Class::Adapter::Builder>.
On it's own C<Class::Adapter::Clear> passes all methods through to the same
method in the parent object with the same parameters, responds to
C<-E<gt>isa> like the parent object, and responds to C<-E<gt>can> like
the parent object.
It looks like a C<Duck>, and it quacks like a C<Duck>.
On this base, you simple implement whatever method you want to do
something special to.
# Different method, same parameters
sub method1 {
my $self = shift;
$self->_OBJECT_->method2(@_); # Call a different method
}
# Same method, different parameters
sub method1 {
my $self = shift;
$self->_OBJECT_->method1( lc($_[0]) ); # Lowercase the param
}
# Same method, same parameters, tweak the result
sub method1 {
my $self = shift;
my $rv = $self->_OBJECT_->method1(@_);
$rv =~ s/\n/<br>\n/g; # Add line-break HTML tags at each newline
return $rv;
}
As you can see, the advantage of this full-scale I<Adapter> approach,
compared to inheritance, or function wrapping (see L<Class::Hook>), is
that you have complete and utter freedom to do anything you might need
to do, without stressing the Perl inheritance model or doing anything
unusual or tricky with C<CODE> references.
You may never need this much power. But when you need it, you B<really>
need it.
As an aside, Class::Adapter::Clear is implemented with the following
L<Class::Adapter::Builder> formula.
use Class::Adapter::Builder
ISA => '_OBJECT_',
AUTOLOAD => 1;
=head1 METHODS
=head2 new $object
As does the base L<Class::Adapter> class, the default C<new> constructor
takes a single object as argument and creates a new object which holds the
passed object.
Returns a new C<Class::Adapter::Clear> object, or C<undef> if you do not pass
in an object.
=cut
use 5.005;
use strict;
use Class::Adapter::Builder
ISA => '_OBJECT_',
AUTOLOAD => 1;
use vars qw{$VERSION};
BEGIN {
$VERSION = '1.07';
}
1;
=pod
=head1 SUPPORT
Bugs should be reported via the CPAN bug tracker at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Class-Adapter>
For other issues, contact the author.
=head1 AUTHOR
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
=head1 SEE ALSO
L<Class::Adapter>, L<Class::Adapter::Builder>
=head1 COPYRIGHT
Copyright 2005 - 2010 Adam Kennedy.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this module.
=cut
|