cvsuser 03/01/07 08:34:44
Added: Devel-Metadata Changes MANIFEST Makefile.PL README TODO
Devel-Metadata/lib/Devel Metadata.pm
Devel-Metadata/t 01.reference.t 02.distributions.t
03.modules.t 04.module.t
Log:
new file
Revision Changes Path
1.1 p5ee/Devel-Metadata/Changes
<<Binary file>>
1.1 p5ee/Devel-Metadata/MANIFEST
Index: MANIFEST
===================================================================
MANIFEST
Makefile.PL
README
Changes
TODO
lib/Devel/Metadata.pm
t/01.reference.t
t/02.distributions.t
t/03.modules.t
t/04.module.t
1.1 p5ee/Devel-Metadata/Makefile.PL
Index: Makefile.PL
===================================================================
######################################################################
## File: $Id: Makefile.PL,v 1.1 2003/01/07 16:34:44 spadkins Exp $
######################################################################
use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
%opts = (
#'INSTALLDIRS' => 'perl',
'NAME' => 'Devel-Metadata',
'DISTNAME' => 'Devel-Metadata',
'VERSION' => '0.50',
'PREREQ_PM' => { # I haven't yet determined what the minimum versions should be
#'Aspect' => 0, # used for debugging
#'Class::MethodMaker' => 0, # [prereq for Aspect]
auto-generate methods
#'Compress::Zlib' => 0, # for compressed
serialization and browser responses
#'Data::Dumper' => 0, # used for debugging
#'Date::Parse' => 0, # date support
#'Date::Format' => 0, # date support
#'Storable' => 0, # used for serialization
everywhere
},
#'linkext' => { LINKTYPE=>'' }, # no link needed
'dist' => {'COMPRESS'=>'gzip -9f', 'SUFFIX' => 'gz',
'ZIP'=>'/usr/bin/zip','ZIPFLAGS'=>'-rl'},
);
######################################################################
# PREFIX
######################################################################
# I like setting the PREFIX variable in the environment,
# so I write my Makefile.PL to use it as a valid alternative
# to specifying it on the command line with
# "perl Makefile.PL PREFIX=/usr/foo".
if ($ENV{PREFIX}) {
$PREFIX = $ENV{PREFIX};
$opts{PREFIX} = $PREFIX;
}
else {
$PREFIX = "/usr/local";
}
######################################################################
# MAKE THE MAKEFILE
######################################################################
WriteMakefile(%opts);
1.1 p5ee/Devel-Metadata/README
Index: README
===================================================================
The Devel::Metadata module serves as an aggregator and cache for
Perl metadata information gathered from a number sources by way
of other modules.
The following modules are used to collect metadata.
Module::Info - Information about Perl modules
http://search.cpan.org/author/MSCHWERN/Module-Info-0.12/lib/Module/Info.pm
Devel::ModInfo - metadata about a module's methods, properties, and arguments
http://search.cpan.org/author/JTILLMAN/Devel-ModInfo-0.05/ModInfo.pm
CPANPLUS::Backend - Object-oriented interface for CPAN++
http://search.cpan.org/author/KANE/CPANPLUS-0.036/lib/CPANPLUS/Backend.pm
Devel::Symdump - load module and examine symbol table
Useful for Devel::Doc
DocSet -
Pod::Html
Module::Dependency::Grapher - creates visual dependency charts and accessible
text versions
http://search.cpan.org/author/PKENT/Module-Dependency-1.11/lib/Module/Dependency/Grapher.pm
The following is the first part of the POD doc turned into text.
NAME
Devel::Metadata - programmatic access to metadata for Perl code
(Distributions, Modules, Classes, Methods, etc.)
SYNOPSIS
use Devel::Metadata;
# public usage (perl metadata)
$dmd = Devel::Metadata->new();
@distributions = $dmd->distributions(); # get all installed distributions
@modules = $dmd->modules(); # get all installed modules
@modules = $dmd->modules("SOAP-Lite"); # get modules for a distribution
$modules_def = $dmd->module_def("CGI"); # get module metadata (hashref)
@packages = $dmd->packages("CGI"); # get packages defined in a module
$package_def = $dmd->package_def("CGI",); # get package metadata (hashref)
@functions = $dmd->functions("CGI"); # get functions/methods in a package
$function_def = $dmd->function_def("CGI","param"); # function metadata
(hashref)
@signatures = $dmd->signatures("CGI","param"); # signatures for a
function/method
# protected usage
print $dmd->dump(), "\n"; # use Data::Dumper to spit out the Perl
representation
$dmd->print(); # same as above
$value = $dmd->get($property_name);
$branch = $dmd->get_branch($branch_name,$create_flag); # get hashref
$dmd->set($property_name, $value);
DESCRIPTION
Devel::Metadata allows you to access metadata about the perl modules
(.pm) and perl libraries (.pl) you have installed on your system.
Since there is no simple way to discern this information, a variety of
techniques are used. Scanning/parsing the source code allows for
metadata to be gleaned without actually loading the code. However, it is
imperfect because standard coding idioms may not be used. Another method
involves actually loading the code to examine its effects on symbol
tables. However, this is not perfect because some routines may be
created on demand using autoloading or other special perl features.
Ultimately, this metadata may be entered explicitly and authoritatively
by the developer into the POD documentation using special documentation
tags recognized by Devel::Metadata. Thus, the determination of metadata
in perl code and the documentation system are interwoven. This is why
there are a handful of documentation features in a module about
metadata.
Because some of these operations might be resource-intensive,
Devel::Metadata can pretermine these metadata attributes and save them
to a cache area so that the information can be accessed at runtime in a
reasonably efficient manner.
METADATA DEFINITIONS
The following are definitions in Perl metadata.
Perl Site
- an entire perl site, defined by a list of directories to be
searched in order for perl modules. The default perl site is defined
by the set of directories in @INC, displayed with the following
command (in between square brackets): [perl -e 'print "@INC\n";'].
Distribution
- a group of files such as would be downloaded from CPAN which are
tested and installed together. Each Distribution has a "name",
"version", "modules" list, "libraries" list, "files" list of all
files in the distribution, and special file lists of
"autoload_files", "shlib_files", and "man_files".
Library
- a file ending in ".pl" ([p]erl [l]ibrary) which can be loaded with
the [requre "libraryname.pl";] statement. (This is mainly a feature
from Perl 4. Perl Libraries are generally replaced with Perl Modules
in Perl 5.)
Module
- a file ending in ".pm" ([p]erl [m]odule) which can be loaded with
the [use ModuleName;] statement. (See "man perlmod" for more on perl
modules.) Each Module is in a single Distribution. If that
Distribution is not known, it is assigned to the "unknown"
Distribution. A Module may be documented in its own ".pm" file or
(additionally) in an accompanying ".pod" file. Most Modules defined
functions (and perhaps variables) in a single Package and often
implement Classes, but this is not necessary.
Package
- a perl symbol namespace which is often unique to a particular
Module. (see the "package" keyword in the "perlfunc" man page.)
Sometimes a single Module will load Functions for multiple Packages.
It is possible (but rare) that a Package may have Functions defined
for it from multiple Modules.
Function
- a function is technically in a Package, not a Module. However, it
is most often defined in that Package as the result of loading a
Module. Each Function in perl can have many Signatures.
Signature
- a Signature for a Function is a set of Parameters that define a
manner in which the Function may be called. There are always one or
more Signatures for each Function.
Parameter
- a Parameter to a Function has a name, a type, and a description,
and an indicator whether it is readonly ("in"), whether it or its
referenced contents are simply to be returned ("out"), or whether it
or its referenced contents may be examined and then modified
("in/out").
Class
- a special kind of Package which has been written to facilitate
object-oriented programming. (See perlboot, perltoot, perltootc,
perlobj, perlbot.) In order for a Module to be a Class, it must have
a constructor, and its functions must be callable with the first
argument used in the special way which make them "Methods".
Method
- a special kind of Function which has been written to facilitate
object-oriented programming. If the first argument is expected to be
the class name (package name), the method is usually referred to as
a Class Method (or Static Method) to differentiate it from the usual
usage of "Method" as an Instance Method. If the first argument is
expected to be an instance of the class, it is usually referred
simply as a Method (but sometimes by the more verbose Instance
Method, Object Method, or Dynamic Method).
METADATA DICTIONARY
The metadata to be gleaned from the source code is as follows.
# Distribution Files
$self->{distfile}{$distfile}{distribution}
# Distributions
$self->{distribution}{$distribution}
$self->{distribution}{$distribution}{version}
$self->{distribution}{$distribution}{modules}
$self->{distribution}{$distribution}{libraries}
$self->{distribution}{$distribution}{files}
$self->{distribution}{$distribution}{autoload_files}
$self->{distribution}{$distribution}{shlib_files}
$self->{distribution}{$distribution}{man_files}
# Modules
$self->{module}{$module}
$self->{module}{$module}{distribution}
$self->{module}{$module}{pmfile}
$self->{module}{$module}{podfile}
$self->{module}{$module}{modulegroup}
$self->{module}{$module}{name}
$self->{module}{$module}{synopsis}
$self->{module}{$module}{description}
$self->{module}{$module}{throws}
$self->{module}{$module}{since}
$self->{module}{$module}{deprecated_since}
$self->{module}{$module}{deprecated_discontinue}
$self->{module}{$module}{authors}
$self->{module}{$module}{author}{$author}{email}
$self->{module}{$module}{license}
$self->{module}{$module}{see_also}
# Modules (object-oriented)
$self->{module}{$module}{class}
$self->{module}{$module}{parent}
$self->{module}{$module}{parents}
$self->{module}{$module}{children}
# Functions (Methods)
$self->{module}{$module}{function}{$function}
$self->{module}{$module}{function}{$function}{doc}
$self->{module}{$module}{function}{$function}{visibility}
$self->{module}{$module}{function}{$function}{signatures}
$self->{module}{$module}{function}{$function}{param}{$param}
$self->{module}{$module}{function}{$function}{param}{$param}{type}
$self->{module}{$module}{function}{$function}{param}{$param}{inout}
$self->{module}{$module}{function}{$function}{return}{$return}
$self->{module}{$module}{function}{$function}{return}{$return}{type}
$self->{module}{$module}{function}{$function}{throws}
$self->{module}{$module}{function}{$function}{since}
$self->{module}{$module}{function}{$function}{deprecated_since}
$self->{module}{$module}{function}{$function}{deprecated_discontinue}
$self->{modulegroup}{$modulegroup}
$self->{modulegroup}{$modulegroup}{modules}
1.1 p5ee/Devel-Metadata/TODO
<<Binary file>>
1.1 p5ee/Devel-Metadata/lib/Devel/Metadata.pm
Index: Metadata.pm
===================================================================
#############################################################################
## $Id: Metadata.pm,v 1.1 2003/01/07 16:34:44 spadkins Exp $
#############################################################################
package Devel::Metadata;
$VERSION = do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r};
use strict;
=head1 NAME
Devel::Metadata - programmatic access to metadata for Perl code (Distributions,
Modules, Classes, Methods, etc.)
=head1 SYNOPSIS
use Devel::Metadata;
# public usage (perl metadata)
$dmd = Devel::Metadata->new();
@distributions = $dmd->distributions(); # get all installed distributions
@modules = $dmd->modules(); # get all installed modules
@modules = $dmd->modules("SOAP-Lite"); # get modules for a distribution
$modules_def = $dmd->module_def("CGI"); # get module metadata (hashref)
@packages = $dmd->packages("CGI"); # get packages defined in a module
$package_def = $dmd->package_def("CGI",); # get package metadata (hashref)
@subroutines = $dmd->subroutines("CGI"); # get subroutines/methods in a package
$subroutine_def = $dmd->subroutine_def("CGI","param"); # subroutine metadata
(hashref)
@signatures = $dmd->signatures("CGI","param"); # signatures for a
subroutine/method
# protected usage
print $dmd->dump(), "\n"; # use Data::Dumper to spit out the Perl representation
$dmd->print(); # same as above
$value = $dmd->get($property_name);
$branch = $dmd->get_branch($branch_name,$create_flag); # get hashref
$dmd->set($property_name, $value);
=head1 DESCRIPTION
Devel::Metadata allows you to access metadata about the perl modules (.pm)
and perl libraries (.pl) you have installed on your system.
This module was created to support the needs of the Devel::Perldocs
code documentation generator. However, the task of retrieving the
metadata (Devel::Metadata) is separated from the presentation of this
metadata (Devel::Perldocs) in order that the metadata may be used in
other circumstances. These might include runtime parameter checking,
runtime checking of the existence of required modules,
or other uses of metadata at runtime or during code analysis.
Because metadata may be coded in POD documentation within a module,
Devel::Metadata also helps you create and maintain this special
POD documentation. Thus, even without Devel::Perldocs, Devel::Metadata
plays a valuable role in documentation.
=head1 BACKGROUND
=head2 REQUIREMENTS
The module must drop into an existing Perl installation (Perl 5.5.3/5.005_03 or
later)
and be able to report accurately on the distributions and modules/libraries/classes
(along with their subroutines/methods and corresponding signatures) that are
installed on the system.
The module must be fast enough to make it reasonable to query metadata at program
runtime, not just offline during code analysis for tasks such as documentation
generation.
The module must allow that supplementary metadata may be supplied inside the
code (specially tagged comments and specially tagged POD sections) and outside
the code (external metadata files). This is because the Perl language is so
flexible that the metadata about method/subroutine signatures may be difficult
or impossible to discern without an extensive analysis of the code.
The module must help the developer create and maintain the POD documentation
within his code.
=head2 USE CASES
1. For the site (as defined by a particular @INC path, perhaps as supplemented by
PERL5LIB or PERLLIB), tell me:
* What are the distributions (i.e. from CPAN) installed on the system?
2. For each distribution,
* Which other distributions does each distribution depend on?
* What attributes can be known about distributions? (version? date installed?
author?)
* What are the files (.pl, .pm, .pod, .xs/.al) within each distribution?
3. For each module/library,
* What attributes can be known about each module/library? (version? is class?
author?)
* What are the subroutines are imported automatically? possibly?
* What are the subroutines/methods in a library/module?
* What are the parent (inherited) classes/modules of each class/module?
* What are the child (derived) classes/modules of each class/module?
* Which modules use which other modules? requiring which version numbers?
* Are exceptions thrown? Which ones?
4. For each subroutine/method,
* What are the possible signatures of each subroutine/method?
* What attributes can be known about a subroutine? (version introduced?)
* Are exceptions thrown? Which ones?
5. The above analysis of code must also be possible on a single directory of
modules under examination (as opposed to *all* modules installed in the
system).
6. The code analysis may also span any subset of distributions found in the
current installation.
7. After analyzing some module(s), report on any discrepancies detected
between the metadata as determined by any of the various methods.
8. After analyzing some module(s), add correctly formatted POD documentation
to those modules. This allows a developer who has quickly created some
code to put all of the easily determined POD documentation sections into
the code. He can then examine it, add to it, and modify it.
This also allows for reasonably advanced documentation to be created
using the developer's own pod2xxx tools (not necessarily Devel::Perldocs).
9. After analyzing some module(s), update correctly formatted POD documentation
to those modules. This allows a developer who has modified some code to
check to see if any of the documentation sections is out of date and helps
to keep it accurate.
=head2 PRIOR WORK
A variety of modules exist which have tackled various parts of this problem
or related problems.
1. Modinfo
http://sourceforge.net/projects/modinfo
ModInfo provides a simple means of documenting your Perl module interfaces,
and an easy way of using that documentation at runtime or design time.
The information provided is modelled after BeanInfo for Java Beans.
ModInfo requires the use of numerous "# MODINFO" comments within the code.
It is not able to report on code which has not been prepared in this way.
It may (?) allow for external metadata files to supplement the metadata
which is embedded in the code (via the special comments).
It caches this metatdata so that it is suitable for runtime use.
2. Module::Info
http://search.cpan.org/author/MBARBON/Module-Info/lib/Module/Info.pm
Module::Info is the most extensive analyzer of metadata for raw perl code
which has had no specially tagged comments added. It can report a few
elements of metadata about a module without loading it. However, most of
the interesting information (subroutines and inheritance) can only be
determined after the module is loaded. The modules get loaded in a
separate process, which is good for keeping your perl program unpolluted
but bad for runtime performance.
Module::Info requires Perl 5.6.1 and has no ability to determine
subroutine/method signatures. However, in many ways it is more reliable
than source scanning because it actually examines the Perl symbol table.
It also provides no means of determining what are the installed distributions
(from CPAN) or what the modules are that are in those distributions.
3. Attribute::Signature
http://search.cpan.org/author/JDUNCAN/Attribute-Signature/lib/Attribute/Signature.pm
This module allows for a module author to specify the signature of a
subroutine explicitly so that it is enforced by the Perl interpreter.
It requires Perl 5.6.1. It does not provide any way for an external
program to determine what that signature is (such as for documentation).
=head2 DESIGN
The Devel::Metadata module should have the following design.
* collect metadata from a variety of sources
* report on conflicts or agreement
* save metadata in a cache
* report metadata from cache when requested (for performance)
* metadata sources include:
* raw source, scanned as a first approximation
* specially tagged POD documentation supplements metadata for new code
* specially tagged comments also supplement metadata for new code
* external metadata files supplement metadata for legacy code
* Module::Info can be used to cross-check any of the other sources
* CPAN or CVS (perhaps to derive version-related or author-related information)
=head2 METADATA DEFINITIONS
The following are definitions with regard to Perl metadata.
=over 4
=item Perl Site
- an entire perl site, defined by a list of directories to be searched
in order for perl modules. The default perl site is defined by the set
of directories in @INC, displayed with the following command (in
between square brackets): [perl -e 'print "@INC\n";']. This search
path is potentially supplemented by the PERL5LIB and PERLLIB
environment variables.
Note that there may be multiple (possibly overlapping) Perl Sites on
any given machine. This might happen if the standard perl modules
are installed in "/usr/local/lib/perl5" but various versions of
application perl modules exist in other directories such as
"/usr/app/devel/lib", "/usr/app/1.0.3/lib", "/usr/app/2.0.0/lib", etc.
=item Perl Subsite
- within an entire perl site, there may be a subset of those directories
which are the target for code analysis. This is called a Perl Subsite.
Only distributions from the Subsite are returned by the
$dmd->distributions() method. This is useful when you wish to
analyze only a limited set of modules or distributions (Subsite)
within the context of the greater Site.
=item Distribution
- a group of files such as would be downloaded from CPAN which are
tested and installed together. Each Distribution has a "name",
"version", "modules" list, "libraries" list, "files" list of all
files in the distribution, and special file lists of
"autoload_files", "shlib_files", and "man_files".
=item Library
- a file ending in ".pl" ([p]erl [l]ibrary) which can be loaded with
the [require "libraryname.pl";] statement. (This is mainly a
feature from Perl 4. Perl Libraries are generally replaced with
Perl Modules in Perl 5.)
=item Module
- a file ending in ".pm" ([p]erl [m]odule) which can be loaded with
the [use ModuleName;] statement. (See "man perlmod" for more on
perl modules.)
Each Module is in a single Distribution. If that
Distribution is not known, it is assigned to the "unknown" Distribution.
A Module may be documented in its own ".pm" file or (additionally)
in an accompanying ".pod" file.
Most Modules defined subroutines (and perhaps variables) in a single
Package and often implement Classes, but this is not necessary.
=item Module Group
- some distributions are large and contain many modules which are
logically separated into different groups. These groups are
inferred by the directory structure within the distribution.
Each directory represents a Module Group. If a Module exists
with the same name as a directory, it belongs in the same
Module Group. (i.e. CPAN and CPAN::Admin are in the same Module Group.)
=item Package
- a perl symbol namespace which is often unique to a particular Module.
(see the "package" keyword in the "perlfunc" man page.)
Sometimes a single Module will load Subroutines for multiple Packages.
It is possible (but rare) that a Package may have Subroutines defined
for it from multiple Modules.
=item Subroutine
- a subroutine is technically in a Package, not a Module.
However, it is most often defined in that Package as the result
of loading a Module.
Each Subroutine in perl can have many Signatures.
=item Signature
- a Signature for a Subroutine is a set of Parameters that define
a manner in which the Subroutine may be called. There are always
one or more Signatures for each Subroutine.
=item Parameter
- a Parameter to a Subroutine has a name, a type, and a description,
and an indicator whether it is readonly ("in"), whether it
or its referenced contents are simply to be returned ("out"),
or whether it or its referenced contents may be examined and
then modified ("in/out").
=item Class
- a special kind of Package which has been written to facilitate
object-oriented programming.
(See perlboot, perltoot, perltootc, perlobj, perlbot.)
In order for a
Module to be a Class, it must have a constructor, and its subroutines
must be callable with the first argument used in the special way
which make them "Methods".
=item Method
- a special kind of Subroutine which has been written to facilitate
object-oriented programming. If the first argument is expected
to be the class name (package name), the method is usually referred
to as a Class Method (or Static Method) to differentiate it from
the usual usage of "Method" as an Instance Method.
If the first argument is
expected to be an instance of the class, it is usually referred
simply as a Method (but sometimes by the more verbose
Instance Method, Object Method, or Dynamic Method).
=back 4
=head1 METADATA DICTIONARY
The metadata to be gleaned from the source code is as follows.
# Distribution Files
$self->{distfile}{$distfile}{distribution}
# Distributions
$self->{distribution}{$distribution}
$self->{distribution}{$distribution}{version}
$self->{distribution}{$distribution}{modules}
$self->{distribution}{$distribution}{libraries}
$self->{distribution}{$distribution}{files}
$self->{distribution}{$distribution}{autoload_files}
$self->{distribution}{$distribution}{shlib_files}
$self->{distribution}{$distribution}{man_files}
# Modules
$self->{module}{$module}
$self->{module}{$module}{distribution}
$self->{module}{$module}{pmfile}
$self->{module}{$module}{podfile}
$self->{module}{$module}{modulegroup}
$self->{module}{$module}{name}
$self->{module}{$module}{synopsis}
$self->{module}{$module}{description}
$self->{module}{$module}{throws}
$self->{module}{$module}{since}
$self->{module}{$module}{deprecated_since}
$self->{module}{$module}{deprecated_discontinue}
$self->{module}{$module}{authors}
$self->{module}{$module}{author}{$author}{email}
$self->{module}{$module}{license}
$self->{module}{$module}{see_also}
# Modules (object-oriented)
$self->{module}{$module}{class}
$self->{module}{$module}{parent}
$self->{module}{$module}{parents}
$self->{module}{$module}{children}
# Subroutines (Methods)
$self->{module}{$module}{subroutine}{$subroutine}
$self->{module}{$module}{subroutine}{$subroutine}{doc}
$self->{module}{$module}{subroutine}{$subroutine}{visibility}
$self->{module}{$module}{subroutine}{$subroutine}{signatures}
$self->{module}{$module}{subroutine}{$subroutine}{param}{$param}
$self->{module}{$module}{subroutine}{$subroutine}{param}{$param}{type}
$self->{module}{$module}{subroutine}{$subroutine}{param}{$param}{inout}
$self->{module}{$module}{subroutine}{$subroutine}{return}{$return}
$self->{module}{$module}{subroutine}{$subroutine}{return}{$return}{type}
$self->{module}{$module}{subroutine}{$subroutine}{throws}
$self->{module}{$module}{subroutine}{$subroutine}{since}
$self->{module}{$module}{subroutine}{$subroutine}{deprecated_since}
$self->{module}{$module}{subroutine}{$subroutine}{deprecated_discontinue}
$self->{modulegroup}{$modulegroup}
$self->{modulegroup}{$modulegroup}{modules}
=cut
#############################################################################
# CONSTRUCTOR METHODS
#############################################################################
=head1 Constructor Methods:
=cut
#############################################################################
# new()
#############################################################################
=head2 new()
This constructor is used to create Reference objects.
Customized behavior for a particular type of Reference
is achieved by overriding the init() method.
* Signature: $dmd = Devel::Metadata->new($array_ref)
* Signature: $dmd = Devel::Metadata->new($hash_ref)
* Signature: $dmd = Devel::Metadata->new("array",@args)
* Signature: $dmd = Devel::Metadata->new(%named)
* Param: $array_ref []
* Param: $hash_ref {}
* Return: $dmd Devel::Metadata
* Throws: <none>
* Since: 0.01
Sample Usage:
use "Devel::Metadata";
$dmd = Devel::Metadata->new("array", "x", 1, -5.4, { pi => 3.1416 });
$dmd = Devel::Metadata->new( [ "x", 1, -5.4 ] );
$dmd = Devel::Metadata->new(
arg1 => 'value1',
arg2 => 'value2',
);
=cut
sub new {
my $this = shift;
my ($class, $self);
$class = ref($this) || $this;
if ($#_ == 0 && ref($_[0]) eq "HASH") {
$self = { %{$_[0]} };
}
elsif ($#_ >= 1 && $#_ % 2 == 1) {
$self = { @_ };
}
else {
$self = {};
}
bless $self, $class;
return $self;
}
#############################################################################
# PUBLIC METHODS
#############################################################################
=head1 Public Methods:
=cut
#############################################################################
# distributions()
#############################################################################
=head2 distributions()
* Signature: @distributions = $dmd->distributions();
* Param: void
* Return: @distributions @
* Throws: <none>
* Since: 0.01
Sample Usage:
@distributions = $dmd->distributions();
print join("\n", sort @distributions), "\n";
=cut
sub distributions {
my ($self) = @_;
$self->_scan_site() if (!$self->{site_scanned});
my @distributions = ();
if ($self->{distribution}) {
@distributions = (keys %{$self->{distribution}});
}
return @distributions;
}
#############################################################################
# modules()
#############################################################################
=head2 modules()
* Signature: @modules = $dmd->modules();
* Param: void
* Return: @modules @
* Throws: <none>
* Since: 0.01
Sample Usage:
@modules = $dmd->modules();
print join("\n", sort @modules), "\n";
=cut
sub modules {
my ($self, $distribution) = @_;
$self->_scan_site() if (!$self->{site_scanned});
$distribution = "all" if (!$distribution);
my @modules = ();
if ($self->{distribution}{$distribution}{modules}) {
@modules = @{$self->{distribution}{$distribution}{modules}};
}
return @modules;
}
#############################################################################
# module_def()
#############################################################################
=head2 module_def()
* Signature: $module_def = $dmd->module_def($module);
* Param: $module string
* Return: $module_def {}
* Throws: <none>
* Since: 0.01
Sample Usage:
$module_def = $dmd->module_def($module);
print "$module ", join(",", %$module_def), "\n";
=cut
sub module_def {
my ($self, $module) = @_;
$self->_scan_site() if (!$self->{site_scanned});
return({}) if (!$module || !defined $self->{module}{$module});
my ($pmfile, $podfile);
$pmfile = $self->{module}{$module}{pmfile};
if ($pmfile && !$self->{file}{$pmfile}{scanned}) {
$self->_scan_file($pmfile);
$self->{file}{$pmfile}{scanned} = 1;
}
$podfile = $self->{module}{$module}{podfile};
if ($podfile && !$self->{file}{$podfile}{scanned}) {
$self->_scan_file($podfile);
$self->{file}{$podfile}{scanned} = 1;
}
return ($self->{module}{$module});
}
#############################################################################
# write_module_ext_pod()
#############################################################################
=head2 write_module_ext_pod()
* Signature: $dmd->write_module_ext_pod($module, $filename);
* Param: $module string
* Param: $filename string
* Return: void
* Throws: <none>
* Since: 0.01
Sample Usage:
$dmd->write_module_ext_pod($module, "$module.pod");
=cut
sub write_module_ext_pod {
my ($self, $module, $dstfile) = @_;
$self->write_module_pod($module,$dstfile);
}
#############################################################################
# write_module_pod()
#############################################################################
=head2 write_module_pod()
* Signature: $dmd->write_module_pod($module, $filename);
* Param: $module string
* Param: $filename string
* Return: void
* Throws: <none>
* Since: 0.01
Sample Usage:
$dmd->write_module_pod($module, "$module.pod");
=cut
sub write_module_pod {
my ($self, $module, $dstfile) = @_;
$self->_scan_site() if (!$self->{site_scanned});
my ($srcfile, $module_def, $src_age, $dst_age, @stat);
$srcfile = $self->{module}{$module}{podfile};
$srcfile = $self->{module}{$module}{pmfile} if (!$srcfile);
if (!$srcfile) {
$module_def = $self->module_def($module);
$srcfile = $module_def->{podfile};
$srcfile = $module_def->{pmfile} if (!$srcfile);
}
if ($srcfile && -f $srcfile) {
if (-f $dstfile) {
@stat = stat($srcfile);
$src_age = $stat[9];
@stat = stat($dstfile);
$dst_age = $stat[9];
}
if (! -f $dstfile || $dst_age < $src_age) {
system("cp -f $srcfile $dstfile");
printf "Module %-60s - pod written\n", $module;
#printf " [$src_age] $srcfile\n";
#printf " [$dst_age] $dstfile\n";
}
else {
#printf "Module %-60s - pod current\n", $module;
}
}
else {
printf "Module %-60s - no source file found\n", $module;
}
#local(*main::FILE);
#if (open(main::FILE, "> $dstfile")) {
# close(main::FILE);
#}
#else {
# print "Unable to open file [$dstfile]: $!\n";
#}
}
#############################################################################
# PROTECTED METHODS
#############################################################################
=head1 Protected Methods:
The following methods are intended to be called only by this class and
other classes intimately related to this class.
=cut
#############################################################################
# get()
#############################################################################
=head2 get()
* Signature: $property_value = $dmd->get($property_name);
* Param: $property_name string
* Return: $property_value string
* Throws: <none>
* Since: 0.01
Sample Usage:
$dbi = $dmd->get("module.Devel::Metadata.dbi");
$dbuser = $dmd->get("module.Devel::Metadata.dbuser");
$dbpass = $dmd->get("module.Devel::Metadata.dbpass");
=cut
sub get {
print "get(@_)\n" if ($Devel::Metadata::DEBUG);
my ($self, $property_name, $dmd) = @_;
$dmd = $self if (!defined $dmd);
if ($property_name =~ /^(.*)([\.\{\[])([^\.\[\]\{\}]+)([\]\}]?)$/) {
my ($branch_name, $attrib, $type, $branch);
$branch_name = $1;
$type = $2;
$attrib = $3;
$branch = ref($dmd) eq "ARRAY" ? undef : $dmd->{_branch}{$branch_name};
$branch = $self->get_branch($1,0,$dmd) if (!defined $branch);
return undef if (!defined $branch || ref($branch) eq "");
return $branch->[$attrib] if (ref($branch) eq "ARRAY");
return $branch->{$attrib};
}
else {
return $self->{$property_name};
}
}
#############################################################################
# get_branch()
#############################################################################
=head2 get_branch()
* Signature: $branch = $dmd->get_branch($branch_name);
* Param: $branch_name string
* Return: $branch {}
* Throws: <none>
* Since: 0.01
Sample Usage:
$branch_name = "module.Devel::Metadata";
$branch = $dmd->get_branch($branch_name);
foreach $key (keys %$branch) {
$property = "${branch_name}.${key}";
print $property, "=", $branch->{$key}, "\n";
}
$dbi = $branch->{dbi};
$dbuser = $branch->{dbuser};
$dbpass = $branch->{dbpass};
=cut
sub get_branch {
print "get_branch(@_)\n" if ($Devel::Metadata::DEBUG);
my ($self, $branch_name, $create, $dmd) = @_;
my ($sub_branch_name, $branch_piece, $attrib, $type, $branch, $cache_ok);
$dmd = $self if (!defined $dmd);
# check the cache quickly and return the branch if found
$cache_ok = (ref($dmd) ne "ARRAY" && $dmd eq $self); # only cache from $self
$branch = $dmd->{_branch}{$branch_name} if ($cache_ok);
return ($branch) if (defined $branch);
# not found, so we need to parse the $branch_name and walk the $dmd tree
$branch = $dmd;
$sub_branch_name = "";
# these: "{field1}" "[3]" "field2." are all valid branch pieces
while ($branch_name =~ s/^([\{\[]?)([^\.\[\]\{\}]+)([\.\]\}]?)//) {
$branch_piece = $2;
$type = $3;
$sub_branch_name .= ($3 eq ".") ? "$1$2" : "$1$2$3";
if (ref($branch) eq "ARRAY") {
if (! defined $branch->[$branch_piece]) {
if ($create) {
$branch->[$branch_piece] = ($type eq "]") ? [] : {};
$branch = $branch->[$branch_piece];
$dmd->{_branch}{$sub_branch_name} = $branch if ($cache_ok);
}
else {
return(undef);
}
}
else {
$branch = $branch->[$branch_piece];
$sub_branch_name .= "$1$2$3"; # accumulate the $sub_branch_name
}
}
else {
if (! defined $branch->{$branch_piece}) {
if ($create) {
$branch->{$branch_piece} = ($type eq "]") ? [] : {};
$branch = $branch->{$branch_piece};
$dmd->{_branch}{$sub_branch_name} = $branch if ($cache_ok);
}
else {
return(undef);
}
}
else {
$branch = $branch->{$branch_piece};
}
}
$sub_branch_name .= $type if ($type eq ".");
}
return $branch;
}
#############################################################################
# set()
#############################################################################
=head2 set()
* Signature: $dmd->get($property_name, $property_value);
* Param: $property_name string
* Param: $property_value string
* Throws: <none>
* Since: 0.01
Sample Usage:
$dbi = $dmd->get("module.Devel::Metadata.dbi");
$dbuser = $dmd->get("module{Devel::Metadata}{dbuser}");
$dbpass = $dmd->get("module.Devel::Metadata{dbpass}");
=cut
sub set {
print "set(@_)\n" if ($Devel::Metadata::DEBUG);
my ($self, $property_name, $property_value, $dmd) = @_;
$dmd = $self if (!defined $dmd);
my ($branch_name, $attrib, $type, $branch, $cache_ok);
if ($property_name =~ /^(.*)([\.\{\[])([^\.\[\]\{\}]+)([\]\}]?)$/) {
$branch_name = $1;
$type = $2;
$attrib = $3;
$cache_ok = (ref($dmd) ne "ARRAY" && $dmd eq $self);
$branch = $dmd->{_branch}{$branch_name} if ($cache_ok);
$branch = $self->get_branch($1,1,$dmd) if (!defined $branch);
}
else {
$branch = $dmd;
$attrib = $property_name;
}
if (ref($branch) eq "ARRAY") {
$branch->[$attrib] = $property_value;
}
else {
$branch->{$attrib} = $property_value;
}
}
#############################################################################
# dump()
#############################################################################
=head2 dump()
* Signature: $perl = $dmd->dump();
* Param: void
* Return: $perl text
* Throws: <none>
* Since: 0.01
Sample Usage:
$dmd = $context->config();
print $dmd->dump(), "\n";
=cut
use Data::Dumper;
sub dump {
my ($self) = @_;
my $d = Data::Dumper->new([ $self ], [ "conf" ]);
$d->Indent(1);
return $d->Dump();
}
#############################################################################
# print()
#############################################################################
=head2 print()
* Signature: $dmd->print();
* Param: void
* Return: void
* Throws: <none>
* Since: 0.01
Sample Usage:
$context->print();
=cut
sub print {
my $self = shift;
print $self->dump();
}
#############################################################################
# PRIVATE METHODS
#############################################################################
=head1 Private Methods:
The following methods are intended to be called only within this class.
=cut
#############################################################################
# _scan_site()
#############################################################################
=head2 _scan_site()
* Signature: $dmd->_scan_site();
* Param: void
* Return: void
* Throws: <none>
* Since: 0.01
Sample Usage:
$dmd->_scan_site();
=cut
sub _scan_site {
my ($self) = @_;
my (@inc, $inc, $dist, $dist_def, $distfile_def, $module, $file);
@inc = @INC;
if ($ENV{PATH} =~ m/(.*)/) {
$ENV{PATH} = $1;
}
foreach $inc (@INC) {
next if (! -d $inc);
# TODO: replace this with the Perl version of "find" someday
my (@distfiles, $distfile, $tmpdir);
open (FIND, "find $inc -name '.packlist' -print |") || die "Unable to get
file list: $!\n";
@distfiles = <FIND>;
close(FIND);
chomp(@distfiles);
# Search through each distribution file
foreach $distfile (@distfiles) {
next if (defined $self->{distfile}{$distfile});
$distfile_def = {};
$self->{distfile}{$distfile} = $distfile_def;
$dist = $self->distfile2dist($distfile);
next if (!$dist); # not a distribution file!
next if (defined $self->{distribution}{$dist});
$dist_def = {};
$self->{distribution}{$dist} = $dist_def;
$dist_def->{files} = [];
$dist_def->{modules} = [];
foreach $file (split(/\n/,$self->_read_file($distfile))) {
if ($file =~ /\.pm$/) {
next if ($file =~ m!$inc/site_perl!);
next if ($file =~ m!$inc.*/5\.[0-9\.]{3,}/!);
next if ($file =~ m!$inc/[a-z][^/]+-[^/]+/!);
next if ($file =~ m!$inc/\.perldocs!);
$module = $self->file2module($file, $inc);
next if ($module !~
/^([A-Z][A-Za-z0-9_]*::)*[A-Za-z][A-Za-z0-9_]*$/);
if (! defined $self->{module}{$module}{pmfile}) {
$self->{module}{$module}{pmfile} = $file;
}
if (! defined $self->{module}{$module}{distribution}) {
$self->{module}{$module}{distribution} = $dist;
}
if (!$dist_def->{module}{$module}) {
$dist_def->{module}{$module} = 1;
push(@{$dist_def->{modules}}, $module);
}
if (!$self->{distribution}{all}{module}{$module}) {
$self->{distribution}{all}{module}{$module} = 1;
push(@{$self->{distribution}{all}{modules}}, $module);
}
if (!$dist_def->{file}{$file}) {
$dist_def->{file}{$file} = 1;
push(@{$dist_def->{files}}, $file);
$self->{file}{$file}{module} = $module;
}
if (!$self->{distribution}{all}{pmfile}{$file}) {
$self->{distribution}{all}{pmfile}{$file} = 1;
push(@{$self->{distribution}{all}{files}}, $file);
}
}
elsif ($file =~ /\.pod$/) {
}
elsif ($file =~ /\.al$/) {
}
elsif ($file =~ /\/man[1-9]\//) {
}
}
}
# replace this with the Perl version of "find" someday
my (@podfiles, $podfile);
open (FIND, "find $inc -name '*.pod' -print |") || die "Unable to get file
list: $!\n";
@podfiles = <FIND>;
close(FIND);
chomp(@podfiles);
# Search through each POD file
foreach $podfile (@podfiles) {
next if ($podfile =~ m!$inc/site_perl!);
next if ($podfile =~ m!$inc.*/5\.[0-9\.]{3,}/!);
next if ($podfile =~ m!$inc/[a-z][^/]+-[^/]+/!);
next if ($podfile =~ m!$inc/\.perldocs!);
$module = $self->file2module($podfile, $inc);
next if ($module !~ /^(?:[A-Z][A-Za-z0-9_]*::)*[A-Za-z][A-Za-z0-9_]*$/x);
if (! defined $self->{file}{$podfile}) {
$self->{file}{$podfile} = {};
}
if (! defined $self->{module}{$module}{podfile}) {
$self->{module}{$module}{podfile} = $podfile;
}
if (! defined $self->{module}{$module}{distribution}) {
$self->{module}{$module}{distribution} = "unknown";
}
if (!$self->{distribution}{all}{module}{$module}) {
$self->{distribution}{all}{module}{$module} = 1;
push(@{$self->{distribution}{all}{modules}}, $module);
$self->{distribution}{unknown}{module}{$module} = 1;
push(@{$self->{distribution}{unknown}{modules}}, $module);
}
if (!$self->{distribution}{all}{file}{$podfile}) {
$self->{distribution}{all}{file}{$podfile} = 1;
push(@{$self->{distribution}{all}{files}}, $podfile);
$self->{distribution}{unknown}{file}{$podfile} = 1;
push(@{$self->{distribution}{unknown}{files}}, $podfile);
}
}
# replace this with the Perl version of "find" someday
my (@pmfiles, $pmfile);
open (FIND, "find $inc -name '*.pm' -print |") || die "Unable to get file
list: $!\n";
@pmfiles = <FIND>;
close(FIND);
chomp(@pmfiles);
# Search through each PM file
foreach $pmfile (@pmfiles) {
next if ($pmfile =~ m!$inc/site_perl!);
next if ($pmfile =~ m!$inc.*/5\.[0-9\.]{3,}/!);
next if ($pmfile =~ m!$inc/[a-z][^/]+-[^/]+/!);
next if ($pmfile =~ m!$inc/\.perldocs!);
$module = $self->file2module($pmfile, $inc);
next if ($module !~ /^(?:[A-Z][A-Za-z0-9_]*::)*[A-Za-z][A-Za-z0-9_]*$/x);
if (! defined $self->{file}{$pmfile}) {
$self->{file}{$pmfile} = {};
}
if (! defined $self->{module}{$module}{pmfile}) {
$self->{module}{$module}{pmfile} = $pmfile;
}
if (! defined $self->{module}{$module}{distribution}) {
$self->{module}{$module}{distribution} = "unknown";
}
if (!$self->{distribution}{all}{module}{$module}) {
$self->{distribution}{all}{module}{$module} = 1;
push(@{$self->{distribution}{all}{modules}}, $module);
$self->{distribution}{unknown}{module}{$module} = 1;
push(@{$self->{distribution}{unknown}{modules}}, $module);
}
if (!$self->{distribution}{all}{file}{$pmfile}) {
$self->{distribution}{all}{file}{$pmfile} = 1;
push(@{$self->{distribution}{all}{files}}, $pmfile);
$self->{distribution}{unknown}{file}{$pmfile} = 1;
push(@{$self->{distribution}{unknown}{files}}, $pmfile);
}
}
}
$self->{site_scanned} = 1;
}
#############################################################################
# _scan_file()
#############################################################################
=head2 _scan_file()
* Signature: $dmd->_scan_file($file);
* Signature: $dmd->_scan_file($file, $module);
* Param: $file string
* Param: $module string
* Return: void
* Throws: <none>
* Since: 0.01
Sample Usage:
$dmd->_scan_file($file);
=cut
sub _scan_file {
my ($self, $file, $module) = @_;
#print "_scan_file($file, $module): entry\n";
$module = $self->file2module($file) if (!$module);
my ($source, @source);
@source = $self->_read_file($file);
$source = \@source;
$self->_scan_source_for_packages($file, $module, $source);
$self->_scan_source_for_isa($file, $module, $source);
#$self->_scan_source_for_subs($file, $module, $source);
#$self->_scan_source_for_pod($file, $module, $source);
$self->{file}{$file}{scanned} = 1;
#print "_scan_file(): exit\n";
}
sub _scan_source_for_packages {
my ($self, $file, $module, $source) = @_;
my ($lineidx, $lineno, $line, $package, @packages, %package_lines, $inpod);
$package = "main";
@packages = ();
%package_lines = ();
$inpod = 0;
for ($lineidx = 0; $lineidx <= $#$source; $lineidx++) {
$line = $source->[$lineidx];
$lineno = $lineidx + 1;
if ($inpod) {
if ($line =~ /^=cut/) {
$inpod = 0;
}
next;
}
else {
if ($line =~ /^=/) {
$inpod = 1;
next;
}
}
last if ($line =~ /^__/); # i.e. __END__ or __DATA__
if ($line =~ /^ *package +([A-Za-z0-9:_]+)/) {
$package = $1;
push(@packages, $package) if (!$package_lines{$package});
}
$package_lines{$package}++ if ($line !~ /^\s*$/ && $line !~ /^\s*#/);
}
if ($#packages == -1) {
@packages = ("main");
}
$self->{module}{$module}{packages} = \@packages;
$self->{module}{$module}{package_lines} = \%package_lines;
}
sub _scan_source_for_xyz { # standard template
my ($self, $file, $module, $source) = @_;
my ($lineidx, $lineno, $line, $package, $inpod);
$package = "main";
$inpod = 0;
for ($lineidx = 0; $lineidx <= $#$source; $lineidx++) {
$line = $source->[$lineidx];
$lineno = $lineidx + 1;
if ($inpod) {
if ($line =~ /^=cut/) {
$inpod = 0;
}
next;
}
else {
if ($line =~ /^=/) {
$inpod = 1;
next;
}
}
last if ($line =~ /^__/); # i.e. __END__ or __DATA__
if ($line =~ /^ *package +([A-Za-z0-9:_]+)/) {
$package = $1;
}
}
}
sub _scan_source_for_isa {
my ($self, $file, $module, $source) = @_;
my ($lineidx, $lineno, $line, $package, $inpod);
my ($parents, $parent, @parents, $isa_package);
$package = "main";
$inpod = 0;
for ($lineidx = 0; $lineidx <= $#$source; $lineidx++) {
$line = $source->[$lineidx];
$lineno = $lineidx + 1;
if ($inpod) {
if ($line =~ /^=cut/) {
$inpod = 0;
}
next;
}
else {
if ($line =~ /^=/) {
$inpod = 1;
next;
}
}
last if ($line =~ /^__/); # i.e. __END__ or __DATA__
if ($line =~ /^ *package +([A-Za-z0-9:_]+)/) {
$package = $1;
}
if ($line =~ /\bISA\b/) { # should be able to get inheritance here
$isa_package = $package;
if ($line =~ /([A-Za-z_:]+)::ISA/) {
$isa_package = $1;
}
if ($line =~ /\bISA *= *([^;]+)/) {
$parents = $1;
@parents = ();
if ($parents =~ /^qw *\(([^\)]+)\)/) {
$parents = $1;
$parents =~ s/^ +//;
$parents =~ s/ +$//;
foreach $parent (split(/ +/, $parents)) {
push(@parents, $parent) if ($parent =~ /^[A-Za-z0-9:_]+$/);
}
}
elsif ($parents =~ /^\(([^\)]+)\)/) {
$parents = $1;
$parents =~ s/^[ '"]+//;
$parents =~ s/[ '",]+$//;
$parents =~ s/[ '",]+/ /g;
foreach $parent (split(/ +/, $parents)) {
push(@parents, $parent) if ($parent =~ /^[A-Za-z0-9:_]+$/);
}
}
elsif ($parents =~ /^["']([A-Za-z0-9_:]+)["']/) {
$parents = $1;
@parents = ( $parents );
}
if ($#parents > -1) {
$self->{package}{$isa_package}{parent} = $parents[0];
$self->{package}{$isa_package}{parents} = \@parents;
foreach my $parent (@parents) {
if (! defined $self->{package}{$parent}{children}) {
$self->{package}{$parent}{children} = []
}
push(@{$self->{package}{$parent}{children}}, $isa_package);
}
}
}
}
}
}
sub _scan_source_for_subs {
my ($self, $file, $module, $source) = @_;
}
sub _scan_source_for_pod {
my ($self, $file, $module, $source) = @_;
}
sub file2shortfile {
my ($self, $shortfile, $incdir) = @_;
$shortfile =~ s!^$incdir!! if ($incdir); # remove leading dir known not to be
part of module name
$shortfile =~ s!site_perl/!!; # remove site_perl
$shortfile =~ s!.*/5\.[0-9\.]{3,}/!!; # remove perl version
$shortfile =~ s!^/!!; # remove leading "/"
$shortfile =~ s!^[a-z][^/]+-[^/]+/!!; # remove architecture string
return $shortfile;
}
sub file2module {
my ($self, $module, $incdir) = @_;
$module =~ s!^$incdir!! if ($incdir); # remove leading dir known not to be part
of module name
$module =~ s!site_perl/!!; # remove site_perl
$module =~ s!.*/5\.[0-9\.]{3,}/!!; # remove perl version
$module =~ s!^/!!; # remove leading "/"
$module =~ s!^[a-z][^/]+-[^/]+/!!; # remove architecture string
$module =~ s!^(?:[a-z]+/)+!!x; # remove "lib", "blib", "pod", etc.
$module =~ s!\.pm$!!; # remove .pm suffix
$module =~ s!\.pod$!!; # remove .pod suffix
$module =~ s!/!::!g; # change dir separators to "::"
return $module;
}
sub distfile2dist {
my ($self, $dist, $incdir) = @_;
return "" if ($dist !~ m!/auto/!); # .packlist files should always have
"/auto/" in the path
$dist =~ s!.*/auto/!!;
$dist =~ s!/\.packlist$!!;
$dist =~ s!/!-!g;
return $dist;
}
sub _read_file {
my ($self, $file) = @_;
local(*FILE);
my ($data, @data);
#print "Reading [$file] ...\n";
if (open(FILE, "< $file")) {
@data = <FILE>;
close(FILE);
return (@data) if (wantarray);
$data = join("", @data);
return ($data);
}
else {
print "Failed to open file for reading [$file]: $!\n";
}
return("");
}
sub _write_file {
my ($self, $file, $data) = @_;
local(*FILE);
if (open(FILE, "> $file")) {
print FILE $data;
close(FILE);
#print "Writing [$file] ...\n";
}
else {
print "Failed to open file for writing [$file]: $!\n";
}
}
=head1 ACKNOWLEDGEMENTS
* Author: Stephen Adkins <[EMAIL PROTECTED]>
* License: This is free software. It is licensed under the same terms as Perl
itself.
=head1 SEE ALSO
none
=cut
1;
__END__
my (@package_frags, $pf, $package, $pfrag);
my (@head_frags, $hf, $headlevel, $headtext, $hfrag);
my (@sub_frags, $sf, $sub, $sfrag);
my ($dist_name, $class_list, $class_group, $class, $description, $capability,
$method);
# search each package
@package_frags = split(/(\npackage .*\n)/, $source);
unshift(@package_frags, "package $module;");
for ($pf = 0; $pf <= $#package_frags; $pf += 2) {
if ($package_frags[$pf] =~ /^ *package +([A-Za-z0-9:_]+);/) {
$package = $1;
&docwarn("mfiup", $file, $package) if ($module ne $package);
$pfrag = $package_frags[$pf+1];
#print "package=[$package] pfrag=[$pfrag]\n";
# save info about where this class (package) was detected
$metadata->{classgroup}{all}{classes} = []
if (! defined $metadata->{classgroup}{all}{classes});
if (! defined $metadata->{classgroup}{all}{class}{$package}) {
push(@{$metadata->{classgroup}{all}{classes}}, $package);
$metadata->{classgroup}{all}{class}{$package} = {};
}
# take not of the module that POD for the package is in
if ($pfrag =~ /\n=head1 /s) {
$metadata->{class}{$package}{podclass} = $module;
}
# Scan the ISA list to get the inheritance tree
if ($pfrag =~ /\@ISA *= *([^;#]*)/) {
$class_list = $1;
while ($class_list =~ /([A-Z][A-Za-z0-9_:]+)/g) {
$class = $1;
$metadata->{class}{$package}{parent} = $class
if (!defined $metadata->{class}{$package}{parent});
if (!defined $metadata->{class}{$package}{parents}) {
$metadata->{class}{$package}{parents} = []
}
else {
push(@{$metadata->{class}{$package}{parents}}, $class);
}
$metadata->{class}{$class}{children} = []
if (!defined $metadata->{class}{$class}{children});
push(@{$metadata->{class}{$class}{children}}, $package);
}
}
# search each =head POD directive
@head_frags = split(/(\n=head[12] .*\n)/, $pfrag);
for ($hf = 1; $hf <= $#head_frags; $hf += 2) {
if ($head_frags[$hf] =~ /=head([12]) +(.*)/) {
$headlevel = $1;
$headtext = $2;
$hfrag = $head_frags[$hf+1];
if ($headtext =~ /NAME/) {
}
elsif ($headtext =~ /SYNOPSIS/) {
}
elsif ($headtext =~ /DESCRIPTION/) {
}
elsif ($headtext =~ /ACKNOWLEDGEMENTS/) {
}
elsif ($headtext =~ /SEE ALSO/) {
}
elsif ($headtext =~ /Attributes, Constants, Global Variables,
Class Variables/) {
}
elsif ($headtext =~ /Distribution: *(.*)/) {
$dist_name = $1;
}
elsif ($headtext =~ /Class Groups/) {
while ($hfrag =~ / \* Class Group: *([^-\n]+)( *\n *-
*([^\n]+))?/sg) {
$class_group = $1;
$description = $3;
$class_group =~ s/[\|>].*//;
$class_group =~ s/.*<//;
$metadata->{classgroup}{$class_group}{description} =
$description;
}
}
elsif ($headtext =~ /Class Group Requirements/) {
}
elsif ($headtext =~ /Class Group Design/) {
}
elsif ($headtext =~ /Class Group: *(.*)/) {
$class_group = $1;
$class_group =~ s/[\|>].*//;
$class_group =~ s/.*<//;
$metadata->{classgroup}{$class_group}{podclass} = $module;
while ($hfrag =~ / \* (Class|Document): *([^\n]+)/sg) {
$class = $2;
$class =~ s/[\|>].*//;
$class =~ s/.*<//;
$metadata->{classgroup}{$class_group}{classes} = []
if (! defined
$metadata->{classgroup}{$class_group}{classes});
if (! defined
$metadata->{classgroup}{$class_group}{class}{$class}) {
push(@{$metadata->{classgroup}{$class_group}{classes}}, $class);
$metadata->{classgroup}{$class_group}{class}{$class}
= {};
}
$metadata->{classgroup}{all}{classes} = []
if (! defined $metadata->{classgroup}{all}{classes});
if (! defined
$metadata->{classgroup}{all}{class}{$class}) {
push(@{$metadata->{classgroup}{all}{classes}},
$class);
$metadata->{classgroup}{all}{class}{$class} = {};
}
}
}
elsif ($headtext =~ /Class: *(.*)/) {
$class = $1;
}
elsif ($headtext =~ /Class Capabilities/) {
}
elsif ($headtext =~ /Class Requirements/) {
}
elsif ($headtext =~ /Class Design/) {
}
elsif ($headtext =~ /Constructor Methods: *(.*)/) {
$capability = $1;
}
elsif ($headtext =~ /Public Methods: *(.*)/) {
$capability = $1;
}
elsif ($headtext =~ /Public Methods: *(.*)/) {
$capability = $1;
}
elsif ($headtext =~ /Public Methods: *(.*)/) {
$capability = $1;
}
elsif ($headtext =~ / *(.+)\(\)/) {
$method = $1;
&docwarn("mdnh2", $file, $method) if ($headlevel != 2);
$hfrag =~ s/\nsub .*//s;
$metadata->{class}{$package}{method}{$method}{doc} = $hfrag;
}
else {
}
#print "headlevel=[$headlevel] headtext=[$headtext]
hfrag=[$hfrag]\n";
}
}
# search each subroutine/method definition
@sub_frags = split(/(\nsub .*\n)/, $source);
for ($sf = 1; $sf <= $#sub_frags; $sf += 2) {
if ($sub_frags[$sf] =~ /sub +([A-Za-z0-9_]+)/) {
$method = $1;
$sfrag = $sub_frags[$sf+1]; # { {
$sfrag =~ s/\n}.*/}/s;
$metadata->{class}{$package}{method}{$method}{code} = $sfrag;
if (! defined
$metadata->{class}{$package}{method}{$method}{doc}) {
&docwarn("mwnd", $file, $method);
}
#print "method=[$method] sfrag=[$sfrag]\n";
}
}
}
}
1.1 p5ee/Devel-Metadata/t/01.reference.t
Index: 01.reference.t
===================================================================
#!/usr/local/bin/perl -wT
use Test::More qw(no_plan);
use lib "./lib";
use lib "../lib";
BEGIN {
use_ok("Devel::Metadata");
}
use strict;
#$Devel::Metadata::DEBUG = 0;
my ($dmd, $branch);
$dmd = Devel::Metadata->new();
ok(defined $dmd, "constructor ok");
isa_ok($dmd, "Devel::Metadata", "right class");
$dmd->set("x.y.z.pi", 3.1416);
is($dmd->get("x.y.z.pi"), 3.1416, "get x.y.z.pi");
$branch = $dmd->get_branch("x.y.z");
is($branch->{pi}, 3.1416, "get_branch()");
$branch = $dmd->get_branch("zeta.alpha");
ok(! defined $branch, "non-existent branch");
$branch = $dmd->get_branch("zeta.alpha", 1);
ok(defined $branch, "newly existent branch");
exit 0;
1.1 p5ee/Devel-Metadata/t/02.distributions.t
Index: 02.distributions.t
===================================================================
#!/usr/local/bin/perl -w
use Test::More qw(no_plan);
use lib "./lib";
use lib "../lib";
BEGIN {
use_ok("Devel::Metadata");
}
my ($dmd, @distributions);
$dmd = Devel::Metadata->new();
@distributions = $dmd->distributions();
print join("\n", sort @distributions), "\n";
exit 0;
1.1 p5ee/Devel-Metadata/t/03.modules.t
Index: 03.modules.t
===================================================================
#!/usr/local/bin/perl -w
use Test::More qw(no_plan);
use lib "./lib";
use lib "../lib";
BEGIN {
use_ok("Devel::Metadata");
}
use strict;
my ($dmd, @modules, $module, $module_def, $value);
$dmd = Devel::Metadata->new();
@modules = $dmd->modules();
#print "[all]\n", join("\n", sort @modules), "\n";
foreach $module (@modules) {
$module_def = $dmd->module_def($module);
print "$module";
foreach (sort keys %$module_def) {
$value = $module_def->{$_};
next if (!defined $value);
if (ref($value) eq "ARRAY") {
print " $_=[", join(",",@$value), "]";
}
elsif (ref($value) eq "HASH") {
print " $_={", join(",",%$value), "}";
}
else {
print " $_=$value";
}
}
print "\n";
}
@modules = $dmd->modules("CPAN");
print "[CPAN]\n", join("\n", sort @modules), "\n";
exit 0;
1.1 p5ee/Devel-Metadata/t/04.module.t
Index: 04.module.t
===================================================================
#!/usr/local/bin/perl -w
use Test::More qw(no_plan);
use lib "./lib";
use lib "../lib";
BEGIN {
use_ok("Devel::Metadata");
}
#use strict;
my ($dmd, @distributions);
$dmd = Devel::Metadata->new();
@modules = $dmd->modules();
print "[all]\n", join("\n", sort @modules), "\n";
@modules = $dmd->modules("CPAN");
print "[CPAN]\n", join("\n", sort @modules), "\n";
exit 0;
