#!/usr/bin/perl
#----------------------------------------------------------------------
# Copyright (C) 2006 John "Frotz" Fa'atuai <frotz@acm.org>
# 
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
=pod

=head1 NAME:

	xmi_reverse.pl	-- Partially reverse-engineer Perl modules into XMI.

=head1 SYNOPSIS:

	perl xmi_reverse.pl /usr/lib/perl5

=head1 DESCRIPTION:

	This script will scan the specified perl modules and attempt
	to generate an XMI model.  Attempts are made to deal with the
	world's Perl coding style, but this is incomplete.

        Scanning the entire Perl directory provides you with a
        "reversed.xmi" file that contains a model of your entire
        installed perl5 module set.  Dragging classes onto a class
        hierarchy allows your XMI-modeling tool to automatically
        present the class hierarchy relationships derived during the
        scan.

        As an example, review the always excellent work by Graham Barr
        under Net::.  Drag in the various classes and packages (and
        include Exporter and IO::Socket::INET) in order to understand
        the full model.

=head2 AUTHOR:

	frotz@acm.org

=head2 PARSING:

	This script is currently capable of reverse engineering the
	Perl object oriented structure by detecting @ISA values.
	Comments are pulled out and made XML safe.  Method visibility
	(public / private) is determined by the practice of prefixing
	"_" for private methods.  Parameters are assumed to be one per
	line (this is an area for improvement).  Class variables are
	detected via "our".  No "local" or "my" variables are treated
	as class variables.

=head2 WARNING:

	While this script is useful for use in refactoring work, it
    	CANNOT be used to perform a complete round-trip as no code is
    	picked up with the design structure.  Still, it is quite
    	useful in enabling a directed manual refactoring pass.

=cut

package main;

&main( @ARGV );			## Keep the top-level very simple.
exit( 0 );





#----------------------------------------------------------------------
=pod 

USAGE:
	&main( @files );
	exit( 0 );

DESCRIPTION:
	Scan all @files passed on the command line, then generate an
	XMI file that Umbrello can use to model.  Since we don't want
	to deal with the nasty layout tasks, we just do the package,
	class, method, parameter and possibly POD containment reverse
	engineering and let the designer use Umbrello to build the
	diagram.

=cut

sub	main
{
    my( @files )	= @_;
    my( $cfg )		= {};
    my( $file );

    &inject_defaults( $cfg, @files );

    print "--[Scanning]---------------------------------------------------------\n";
    foreach $file (@files)
    {
	&scan( $cfg, $file );
    }
    print "--[Modeling]---------------------------------------------------------\n";
    &emit_model( $cfg );
}





#----------------------------------------------------------------------
=pod

USAGE:
	&inject_defaults( $cfg );

DESCRIPTION:
	Inject some default stereotypes (including all of the Gang-of-Four)
	Design Patterns.  Also inject language datatypes and the 
	default Perl package main.

=cut

sub	inject_defaults
{
    my( $cfg )	= shift;

    $cfg->{xmi_id}		= 1;
    $cfg->{generalizations}	= {};

    #
    # Now inject the language specific data types.
    #
    &process_datatype( $cfg, '$' );
    &process_datatype( $cfg, '%' );
    &process_datatype( $cfg, '@' );

    #
    # Now inject the default package.
    #
    &process_package_hierarchy( $cfg, "main" );

    #
    # Now inject the Gang of Four Design Patterns
    # in such a way that there is reminder documentation
    # about the pattern so that modelers can copy the
    # specific pattern and use it.
    #
    &inject_gof_creational( $cfg );
    &inject_gof_structural( $cfg );
    &inject_gof_behavioral( $cfg );

    #
    # Now inject the Martin Fowler's Enterprise Architecture Design
    # Patterns in such a way that there is reminder documentation
    # about the pattern so that modelers can copy the specific pattern
    # and use it.
    #
    &inject_fowler_enterprise_domainlogic( $cfg );
    &inject_fowler_enterprise_datasource( $cfg );
    &inject_fowler_enterprise_objectrelationalbehavioral( $cfg );
    &inject_fowler_enterprise_objectrelationalstructural( $cfg );
    &inject_fowler_enterprise_objectrelationalmetadatamapping( $cfg );
    &inject_fowler_enterprise_webpresentation( $cfg );
    &inject_fowler_enterprise_distribution( $cfg );
    &inject_fowler_enterprise_sessionstate( $cfg );
    &inject_fowler_enterprise_base( $cfg );
}





#----------------------------------------------------------------------
=pod

USAGE:
	&inject_gof_creational( $cfg );

DESCRIPTION:
	Inject arbitrary class templates so that designers can review
	the Gang of Four Creational Design Patterns.

=cut

sub	inject_gof_creational
{
    my( $cfg )		= shift;
    &process_class( $cfg,
		    "Patterns::GangOfFour::CREATIONAL::AbstractFactory",
		    join( " ",
			  "Provide an interface for creating families",
			  "of related or dependent objects without ",
			  "specifying their concrete class.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::CREATIONAL::Builder",
		    join( " ",
			  "Separate the construction of a complex object from",
			  "its representation so that the same construction",
			  "process can create different representations.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::CREATIONAL::FactoryMethod",
		    join( " ",
			  "Define an interface for creating an object,",
			  "but let subclasses decide which class to instantiate.",
			  "Factory Method lets a class defer instantiation to ",
			  "subclasses.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::CREATIONAL::Prototype",
		    join( " ",
			  "Specify the kinds of objects to create using",
			  "a prototypical instance, and create new objects by",
			  "copying this prototype.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::CREATIONAL::Singleton",
		    join( " ",
			  "Ensure a class only has one instance, and",
			  "provide a global point of access to it.",
			  )
		    );
}





#----------------------------------------------------------------------
=pod

USAGE:
	&inject_gof_structural( $cfg );

DESCRIPTION:
	Inject arbitrary class templates so that designers can review
	the Gang of Four Structural Design Patterns.

=cut

sub	inject_gof_structural
{
    my( $cfg )		= shift;
    &process_class( $cfg,
		    "Patterns::GangOfFour::STRUCTURAL::Adapter",
		    join( " ",
			  "Convert the interface of a class into another",
			  "interface clients expect.  Adapter lets classes",
			  "work together that couldn't otherwise because of",
			  "incompatible interfaces.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::STRUCTURAL::Bridge",
		    join( " ",
			  "Decouple an abstraction from its implementation",
			  "so that the two can vary independently.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::STRUCTURAL::Composite",
		    join( " ",
			  "Compose objects into tree structures to represent",
			  "part-whole hierarchies.  Composite lets clients",
			  "treat individual objects and compositions of objects",
			  "uniformly.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::STRUCTURAL::Decorator",
		    join( " ",
			  "Attach additional responsibilities to an object",
			  "dynamically.  Decorators provide a flexible alternative",
			  "to subclassing for extending functionality.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::STRUCTURAL::Facade",
		    join( " ",
			  "Provide a uniform interface to a set of",
			  "interfaces in a subsystem.  Facade defines a higher-level",
			  "interface that makes the subsystem easier to use.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::STRUCTURAL::Flyweight",
		    join( " ",
			  "Use sharing to support large numbers of ",
			  "fine-grained objects efficiently.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::STRUCTURAL::Proxy",
		    join( " ",
			  "Provide a surrogate or placeholder for",
			  "another object to control access to it.",
			  )
		    );
}





#----------------------------------------------------------------------
=pod

USAGE:
	&inject_gof_behavioral( $cfg );

DESCRIPTION:
	Inject arbitrary class templates so that designers can review
	the Gang of Four Behavioral Design Patterns.

=cut

sub	inject_gof_behavioral
{
    my( $cfg )		= shift;
    &process_class( $cfg,
		    "Patterns::GangOfFour::BEHAVIORAL::ChainOfResponsibility",
		    join( " ",
			  "Avoid coupling the sender of a request to its receiver",
			  "by giving more than one object a chance to handle the",
			  "request.  Chain the receiving objects and pass the",
			  "request along the chain until an object handles it.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::BEHAVIORAL::Command",
		    join( " ",
			  "Encapsulate a request as an object, thereby letting",
			  "you parameterize clients with different requests,",
			  "queue or log requests, and support undoable",
			  "operations.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::BEHAVIORAL::Interpreter",
		    join( " ",
			  "Given a language, define a representation",
			  "for its grammar along with an interpreter that uses",
			  "the representation to interpret sentences in the language.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::BEHAVIORAL::Iterator",
		    join( " ",
			  "Provide a way to access the elements of",
			  "an aggregate object sequentially without exposing its",
			  "underlying representation.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::BEHAVIORAL::Mediator",
		    join( " ",
			  "Define an object that encapsulates how a",
			  "set of objects interact.  Mediator promotes loose",
			  "coupling by keeping objects from referring to each",
			  "other explicitly, and it lets you vary their interaction",
			  "independently.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::BEHAVIORAL::Memento",
		    join( " ",
			  "Without violating encapsulation, capture",
			  "and externalize an object's internal state so that the",
			  "object can be restored to this state later.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::BEHAVIORAL::Observer",
		    join( " ",
			  "Define a one-to-many dependency between",
			  "objects so that when one object changes state, all",
			  "its dependents are notified and updated automatically.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::BEHAVIORAL::State",
		    join( " ",
			  "Allow an object to alter its behavior when",
			  "its internal state changes.  The object will appear to",
			  "change its class.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::BEHAVIORAL::Strategy",
		    join( " ",
			  "Define a family of algorithms, encapsulate",
			  "each one, and make them interchangable.  Strategy lets",
			  "the algorithm vary independently from clients that use it.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::BEHAVIORAL::TemplateMethod",
		    join( " ",
			  "Define the skeleton of an algorithm in",
			  "an operation, deferring some steps to subclasses.",
			  "Template Method lets subclasses redefine certain steps",
			  "of an algorithm without changing the algorithm's structure.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::GangOfFour::BEHAVIORAL::Visitor",
		    join( " ",
			  "Represent an operation to be performed on",
			  "the elements of an object structure.  Visitor lets you",
			  "define a new operation without changing the classes of",
			  "the elements on which it operates.",
			  )
		    );
}





#----------------------------------------------------------------------
=pod

USAGE:
	&inject_fowler_enterprise_domainlogic( $cfg );

DESCRIPTION:
	Inject Martin Fowler's Enterprise Architecture Domain Logic
	Design Patterns.

=cut

sub	inject_fowler_enterprise_domainlogic
{
    my( $cfg )		= shift;
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::DomainLogic::TransactionScript",
		    join( " ",
			  "Organizes business logic by procedures where each",
			  "procedure handles a single request from the presentation.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::DomainLogic::DomainModel",
		    join( " ",
			  "An object model of the domain that incorporates both ",
			  "behavior and data.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::DomainLogic::TableModel",
		    join( " ",
			  "A single instance that handles the business logic for",
			  "all rows in a database table or view.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::DomainLogic::ServiceLayer",
		    join( " ",
			  "Defines an application's boundary with a layer of services",
			  "that establishes a set of available operations and",
			  "coordinates the application's response in each operation.",
			  )
		    );
}





#----------------------------------------------------------------------
=pod

USAGE:
	&inject_fowler_enterprise_datasource( $cfg );

DESCRIPTION:
	Inject Martin Fowler's Enterprise Architecture Data Source
	Design Patterns.

=cut

sub	inject_fowler_enterprise_datasource
{
    my( $cfg )		= shift;
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::DataSource::TableDataGateway",
		    join( " ",
			  "An object that acts as a Gateway to a database table.",
			  "One instance handles all the rows in the table.",
			  )
		    );

    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::DataSource::RowDataGateway",
		    join( " ",
			  "An object that acts as a Gateway to a single record in a data source.",
			  "There is one instance per row.",
			  )
		    );

    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::DataSource::ActiveRecord",
		    join( " ",
			  "An object that wraps a row in a database table or view,",
			  "encapsulates the database access, and adds domain logic",
			  "on that data.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::DataSource::DataMapper",
		    join( " ",
			  "A layer of Mappers that moves data between objects and a",
			  "database while keeping them independent of each other and",
			  "the mapper itself.",
			  )
		    );
}




#----------------------------------------------------------------------
=pod

USAGE:
	&inject_fowler_enterprise_objectrelationalbehavioral( $cfg );

DESCRIPTION:
	Inject Martin Fowler's Enterprise Architecture Object-Relational
	Behavioral Design Patterns.

=cut

sub	inject_fowler_enterprise_objectrelationalbehavioral
{
    my( $cfg )		= shift;
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalBehavioral::UnitOfWork",
		    join( " ",
			  "Maintains a list of objects affected by a business",
			  "transaction and coordinates the writing out of",
			  "changes and the resolution of concurrency problems.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalBehavioral::IdentityMap",
		    join( " ",
			  "Ensures that each object gets loaded only once by",
			  "keeping every loaded object in a map.  Looks up",
			  "objects using the map when referring to them.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalBehavioral::LazyLoad",
		    join( " ",
			  "An object that doesn't contain all of the data you need but knows how to get it."
			  )
		    );
}




#----------------------------------------------------------------------
=pod

USAGE:
	&inject_fowler_enterprise_objectrelationalstructural( $cfg );

DESCRIPTION:
	Inject Martin Fowler's Enterprise Architecture Object-Relational
	Structural Design Patterns.

=cut

sub	inject_fowler_enterprise_objectrelationalstructural
{
    my( $cfg )		= shift;
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalStructural::IdentityField",
		    join( " ",
			  "Saves a database ID field in an object to maintain",
			  "identity between an in-memory object and a database row."
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalStructural::ForiegnKeyMapping",
		    join( " ",
			  "Maps an association between objects to a foriegn",
			  "key reference between tables."
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalStructural::AssociationTableMapping",
		    join( " ",
			  "Saves an association as a table with foriegn keys",
			  "to the tables that are linked by the association."
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalStructural::DependentMapping",
		    join( " ",
			  "Has one class perform the database mapping for a child class."
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalStructural::EmbeddedValue",
		    join( " ",
			  "Maps an object into several fields of another object's table."
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalStructural::SerializedLOB",
		    join( " ",
			  "Saves a graph of objects by serializing them into a single",
			  "large object (LOB), which it sotres in a database field."
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalStructural::SingleTableInheritence",
		    join( " ",
			  "Represents an inheritence hierarchy of classes as a",
			  "single table that has columns for all the fields of",
			  "the various classes.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalStructural::ClassTableInheritence",
		    join( " ",
			  "Represents an inheritence hierarchy of classes with",
			  "one table for each class.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalStructural::ConcreteTableInheritence",
		    join( " ",
			  "Represents an inheritence hierarchy of classes with",
			  "one table per concrete class in the hierarchy.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalStructural::InheritenceMappers",
		    join( " ",
			  "A structure to organize database mappers that handle",
			  "inheritence hierarchies.",
			  )
		    );
}




#----------------------------------------------------------------------
=pod

USAGE:
	&inject_fowler_enterprise_objectrelationalmetadatamapping( $cfg );

DESCRIPTION:
	Inject Martin Fowler's Enterprise Architecture Object-Relational
	Metadata Mapping Design Patterns.

=cut

sub	inject_fowler_enterprise_objectrelationalmetadatamapping
{
    my( $cfg )		= shift;
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalMetadataMapping::MetadataMapping",
		    join( " ",
			  "Holds details of object-relational mappings in metadata.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalMetadataMapping::QueryObject",
		    join( " ",
			  "An object that represents a database query.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::ObjectRelationalMetadataMapping::Repository",
		    join( " ",
			  "Mediates between the domain and data mapping layers",
			  "using a collection-like interface for accessing",
			  "domain objects.",
			  )
		    );
}




#----------------------------------------------------------------------
=pod

USAGE:
	&inject_fowler_enterprise_webpresentation( $cfg );

DESCRIPTION:
	Inject Martin Fowler's Enterprise Architecture Web Presentation
	Design Patterns.

=cut

sub	inject_fowler_enterprise_webpresentation
{
    my( $cfg )		= shift;
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::WebPresentation::ModelViewController",
		    join( " ",
			  "Splits user interface interaction into",
			  "three distinct roles.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::WebPresentation::PageController",
		    join( " ",
			  "An object that handles a request for a",
			  "specific page or action on a web site.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::WebPresentation::FrontController",
		    join( " ",
			  "A controller that handles all requests for a web site.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::WebPresentation::TemplateView",
		    join( " ",
			  "Renders information into HTML by embedding markers",
			  "in an HTML page.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::WebPresentation::TransformView",
		    join( " ",
			  "A view that processes domain data element by element",
			  "and transforms it into HTML.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::WebPresentation::TwoStepView",
		    join( " ",
			  "Turns domain data into HTML in two steps: ",
			  "first by forming some kind of logical page,",
			  "then by rendering the logical page into HTML.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::WebPresentation::ApplicationController",
		    join( " ",
			  "A centralized point for handling screen navigation",
			  "and the flow of the application.",
			  )
		    );
}




#----------------------------------------------------------------------
=pod

USAGE:
	&inject_fowler_enterprise_distribution( $cfg );

DESCRIPTION:
	Inject Martin Fowler's Enterprise Architecture Distribution
	Design Patterns.

=cut

sub	inject_fowler_enterprise_distribution
{
    my( $cfg )		= shift;
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::Distribution::RemoteFacade",
		    join( " ",
			  "Provides a coarse-grained facade on fine-grained",
			  "objects to improve efficiency over a network.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::Distribution::DataTransferObject",
		    join( " ",
			  "An object that carries data between processes in",
			  "order to reduce the number of method calls.",
			  )
		    );
}




#----------------------------------------------------------------------
=pod

USAGE:
    	&inject_fowler_enterprise_offlineconcurrency( $cfg );

DESCRIPTION:
	Inject Martin Fowler's Enterprise Architecture Offline Concurrency
	Design Patterns.

=cut

sub	inject_fowler_enterprise_offlineconcurrency
{
    my( $cfg )		= shift;
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::OfflineConcurrency::OptimisticOfflineLock",
		    join( " ",
			  "Prevents conflicts between concurrent business",
			  "transactions by detecting a conflict and rolling",
			  "back the transaction.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::OfflineConcurrency::PessimisticOfflineLock",
		    join( " ",
			  "Prevents conflicts between concurrent business",
			  "transactions by allowing only one business",
			  "transaction at a time to access data.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::OfflineConcurrency::CoarseGrainedLock",
		    join( " ",
			  "Locks a set of related objects with a single lock.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::OfflineConcurrency::ImplicitLock",
		    join( " ",
			  "Allows framework or layer supertype code to",
			  "acquire offline locks.",
			  )
		    );
}




#----------------------------------------------------------------------
=pod

USAGE:
	&inject_fowler_enterprise_sessionstate( $cfg );

DESCRIPTION:
	Inject Martin Fowler's Enterprise Architecture Session State
	Design Patterns.

=cut

sub	inject_fowler_enterprise_sessionstate
{
    my( $cfg )		= shift;
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::SessionState::ClientSessionState",
		    join( " ",
			  "Stores session state on the client",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::SessionState::ServerSessionState",
		    join( " ",
			  "Keeps the session state on a server",
			  "system in a serialized form.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::SessionState::DatabaseSessionState",
		    join( " ",
			  "Stores session data as committed data in the database.",
			  )
		    );
}




#----------------------------------------------------------------------
=pod

USAGE:
	&inject_fowler_enterprise_base( $cfg );

DESCRIPTION:
	Inject Martin Fowler's Enterprise Architecture Base
	Design Patterns.

=cut

sub	inject_fowler_enterprise_base
{
    my( $cfg )		= shift;
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::Base::Gateway",
		    join( " ",
			  "An object that encapsulates access to an external",
			  "system or resource.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::Base::Mapper",
		    join( " ",
			  "An object that sets up communication between two",
			  "independent objects.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::Base::LayerSupertype",
		    join( " ",
			  "A type that acts as the supertype for all types",
			  "in its layer.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::Base::SeparatedInterface",
		    join( " ",
			  "Defines an interface in a separate package from",
			  "its implementation.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::Base::Registry",
		    join( " ",
			  "A well-known object that other objects can use to",
			  "find common objects and services.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::Base::ValueObject",
		    join( " ",
			  "A small simple object, like money or a date range, whose",
			  "equality isn't based on identity.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::Base::Money",
		    join( " ",
			  "Represents a monetary value.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::Base::SpecialCase",
		    join( " ",
			  "A subclass that provides special behavior for particular cases.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::Base::Plugin",
		    join( " ",
			  "Links classes during configuration rather than compilation.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::Base::ServiceStub",
		    join( " ",
			  "Removes dependencies upon problematic services during testing.",
			  )
		    );
    &process_class( $cfg,
		    "Patterns::Fowler::EnterpriseArchitecture::Base::RecordSet",
		    join( " ",
			  "An in-memory representation of tabular data.",
			  )
		    );
}




#----------------------------------------------------------------------
=pod

USAGE:
	&scan( $cfg, $path );

DESCRIPTION:
	Build up the context ($cfg) from all files under $path.  This
	is where the fanciful task of code style recognition takes
	place.  This should really be a full lexical parser, but we'll
	see how far down the road simple regexen gets us.

=cut

sub	scan
{
    my( $cfg )	= shift;
    my( $path ) = shift;

    if  (-d $path)
    {
	opendir( DIRP, $path );
	my( @entries ) = sort( readdir( DIRP ) );
	closedir( DIRP );
	my( $entry );
	foreach $entry (@entries)
	{
	    if  ($entry eq "." ||
		 $entry eq ".." ||
		 $entry eq "Folder Settings")
	    {
	    }
	    else
	    {
		&scan( $cfg, "$path/$entry" );
	    }
	}
    }
    elsif  ($path =~ /\.(pl|pm)$/)
    {
	if (open( PERL, $path ))
	{
	    my( @lines ) = <PERL>;
	    close( PERL );
	    print "Read [$path] - ", ($#lines+1), " lines.\n";
	    my( $line );

	    my( $in_comment )	= 0;
	    my( $in_pod )	= 0;
	    my( $package_seen )	= 0;
	    my( $method_seen )	= 0;
	    my( $in_method )	= 0;
	    my( $comment )	= "";
	    my( $methods )	= 0; 
	    foreach $line (@lines)
	    {
		if  ($line eq "\n")
		{
		    unless( defined( $package_seen ) )
		    {
			$package_seen = 1;
			#
			# We always start in package main.  Any
			# documentation we find before the first blank
			# line is file-level, therefore implicitly
			# package main.
			#
			# We can only hope that a package statement was
			# cuddled up to its documentation.
			#
			&process_class( $cfg, $cfg, "main", $comment );
			$comment	= "";
		    }
		}
		if  ($line =~ /^=pod/)
		{
		    $in_pod 	= 1;
		    $comment	= $line;
		}
		elsif( $in_pod )
		{
		    $comment	.= $line;
		    $in_comment	= 0	if ($line =~ /^=cut/);
		}
		elsif ($line =~ /^(\#.*)$/)
		{
		    my( $comment_line )	= $1;
		    $comment		.= "$1\n"	unless( $comment_line =~ /\#\#\#\#|\-\-\-\-|\=\=\=\=/ );
		}
		else
		{
		    chomp( $line );
		    if  ($line =~ /^\s*package\s+(\S+);/)
		    {
			$package_seen	= 1;
			$method_seen	= 0;
			&process_class( $cfg, $1, $comment );
			$comment	= "";
		    }
		    elsif ($line =~ /^\s*sub\s+([_a-zA-Z0-9]+)/)
		    {
			$method_seen	= 1;
			&process_method( $cfg, $1, $comment );
			$comment	= "";
		    }
		    elsif ($line =~ /=.*shift|=\s*\@_;|=\s*\$_\[/)
		    {
			if ($line =~ /([\$\@\%])([a-zA-Z_][_0-9a-zA-Z]+)/)
			{
			    &process_parameter( $cfg, $1, $2 );
			}
			elsif ($line =~ /([\@])(\S+?)/)
			{
			    &process_parameter( $cfg, $1, $2 );
			}
		    }
		    elsif ($method_seen == 0)
		    {
			if ($line =~ /^\s*our\s+(\S+)\s*=/)
			{
			&process_attribute( $cfg, $1, $comment );
			    $comment	= "";
			}
			elsif ($line =~ /^\s*our\s*\((.+)\)/)
			{
			    my( $vars )	= $1;
			    my( @vars )	= split( /[,\s]/, $vars );
			    my( $var );
			    foreach $var (@vars)
			    {
				if  ($var ne "")
				{
				    &process_attribute( $cfg, $var, $comment );
				    $comment	= "";
				}
			    }
			}
			elsif ($line =~ /^\@ISA\s*=.+?\((.+)\)/)
			{
			    my( $inheritence ) = $1;
			    $inheritence =~ s/\'//g;
			    $inheritence =~ s/\"//g;
			    my( $me )	= $cfg->{last_class};
			    my( @classes )	= split( /\s+/, $inheritence );
			    my( $class );
			    foreach $class (@classes)
			    {
				&process_class( $cfg, $class, "" );
				&process_generalization( $cfg, $cfg->{last_class}, $me );
			    }
			    $cfg->{last_class}	 = $me;
			    &process_attribute( $cfg, "\@ISA", $comment );
			    $comment	= "";
			}
		    }
		}
	    }
	}
	else
	{
	    print "Unable to open [$path]: $!\n";
	}
    }
}





#----------------------------------------------------------------------
=pod

USAGE:
	&process_package_hierarchy( $cfg, @packages );

DESCRIPTION:
	Process the list of @packages and add them in containing
	order.  e.g. A::B::C::D will come in as (A, B, C, D).
	The containment should follow.

=cut

sub	process_package_hierarchy
{
    my( $cfg )		= shift;
    my( $parent )	= $cfg;
    my( @packages )	= @_;
    my( $pkg );
    foreach $pkg (@packages)
    {
	$parent = &process_package( $cfg, $parent, $pkg );
    }
    return( $parent );
}





#----------------------------------------------------------------------
=pod

USAGE:
	&process_package( $cfg, $parent, $pkg );

DESCRIPTION:
	Create the new $pkg underneath the pre-existing $parent.

CAVEATS:
	For top-level packages, use $cfg as the $parent.

=cut

sub	process_package
{
    my( $cfg )		= shift;
    my( $parent )	= shift;
    my( $pkg )		= shift;

    if  ($pkg =~ /[\$\@\%\{\}]/)
    {
####	print "IGNORING package [$pkg]	-- Obvious perl-based meta-programming creates a difficult reverse model problem.\n";
    }
    else
    {
	unless( defined( $parent->{$pkg} ) )
	{
	    $parent->{$pkg}			= {};
	    $parent->{$pkg}->{xmi_id}		= $cfg->{xmi_id}++;
	    $parent->{$pkg}->{type}		= "Package";
	    $parent->{$pkg}->{visibility}	= "public";
	    $parent->{$pkg}->{name}		= $pkg;
	}
	if  ($pkg =~ /^_/)
	{
	    $parent->{$pkg}->{visibility}	= "private";
	}
	$parent = $parent->{$pkg};
    }
    return( $parent );
}





#----------------------------------------------------------------------
=pod

USAGE:
	&process_class( $cfg, $pkg_name );

DESCRIPTION:
	Deal with the funky OOPerl rules for package/class to OO
	translations.

=cut

sub	process_class
{
    my( $cfg )		= shift;
    my( $pkg_name )	= shift;
    my( $comment )	= &xmlsafe( shift );
    my( $parent )	= $cfg;

    my( @packages )	= split( "::", $pkg_name );
    my( $class )	= pop( @packages );
    $parent		= &process_package_hierarchy( $cfg, @packages );

    if  ($class =~ /[\$\@\%\{\}]/)
    {
####	print "IGNORING class [$class]	-- Obvious perl-based meta-programming creates a difficult reverse model problem.\n";
    }
    else
    {
	unless( defined( $parent->{$class} ) )
	{
	    $parent->{$class}			= {};
	    $parent->{$class}->{xmi_id}		= $cfg->{xmi_id}++;
	    $parent->{$class}->{type}		= "Class";
	    $parent->{$class}->{name}		= $class;
	    $parent->{$class}->{comment}	= $comment;
#	    print "\nPACKAGE=[$parent->{name}]\n";
#	    print "CLASS=[$parent->{$class}->{name}]\n";
	}
	unless( $parent->{$class}->{comment} eq "" )
	{
	    $parent->{$class}->{comment} = $comment;
	}
	$cfg->{last_class}	= $parent->{$class};
####	&process_datatype( $cfg, $parent->{$class} );		## Appears to be problematic.
    }
}




#----------------------------------------------------------------------
=pod

USAGE:
	&process_attribute( $cfg, $attribute, $comment );

DESCRIPTION:
	Process the current $attribute and $comment.

=cut

sub	process_attribute
{
    my( $cfg )		= shift;
    my( $attribute )	= shift;
    my( $comment )	= &xmlsafe( shift );

    my( $parent )	= $cfg->{last_class};
    unless( defined( $parent->{$attribute} ) )
    {
	$parent->{arg}				= 0;
	$parent->{$attribute}			= {};
	$parent->{$attribute}->{xmi_id}		= $cfg->{xmi_id}++;
	$parent->{$attribute}->{type}		= "Attribute";
	$parent->{$attribute}->{name}		= $attribute;
	$parent->{$attribute}->{visibility}	= "public";
	$parent->{$attribute}->{comment}	= $comment;
    }
    if  ($attribute =~ /^_/)
    {
	$parent->{$attribute}->{visibility}	= "private";
    }
####    print "\nATTRIBUTE=[$attribute]\n";
}




#----------------------------------------------------------------------
=pod

USAGE:
	&process_method( $cfg, $method );

DESCRIPTION:
	Process the current $method name.

=cut

sub	process_method
{
    my( $cfg )		= shift;
    my( $method )	= shift;
    my( $comment )	= &xmlsafe( shift );

    if  ($method =~ /[\$\@\%\{\}]/)
    {
####	print "IGNORING method [$method]	-- Obvious perl-based meta-programming creates a difficult reverse model problem.\n";
    }
    else
    {
	my( $parent ) 			= $cfg->{last_class};
	unless( defined( $parent->{$method} ) )
	{
	    $parent->{arg}			= 0;
	    $parent->{$method}			= {};
	    $parent->{$method}->{xmi_id}	= $cfg->{xmi_id}++;
	    $parent->{$method}->{type}		= "Operation";
	    $parent->{$method}->{name}		= $method;
	    $parent->{$method}->{visibility}	= "public";
	    $parent->{$method}->{comment}	= $comment;
	}
	$cfg->{last_method}			= $parent->{$method};
	if  ($method =~ /^_/)
	{
	    $parent->{$method}->{visibility}	= "private";
	}
####	print "\nMETHOD=[$method]\n";
    }
}




#----------------------------------------------------------------------
=pod

USAGE:
	&process_parameter( $cfg, $type, $parameter );

DESCRIPTION:
	Process the current $parameter and its $type.

=cut

sub	process_parameter
{
    my( $cfg )		= shift;
    my( $type )		= shift;
    my( $parameter )	= shift;
    my( $parent ) 	= $cfg->{last_method};
    my( $arg )		= $parent->{arg}++;
    my( $param )	= "param${arg}";

    $parent->{$param}			= {};
    $parent->{$param}->{xmi_id}		= $cfg->{xmi_id}++;
    $parent->{$param}->{type}		= "Parameter";
    $parent->{$param}->{datatype}	= $type;
    $parent->{$param}->{name}		= $parameter;
####    print "PARAMETER=[$type][$parameter]\n";
}



#----------------------------------------------------------------------
=pod
USAGE:
	&process_datatype( $cfg, $datatype );

DESCRIPTION:
	Add a global datatype.

=cut

sub	process_datatype
{
    my( $cfg )		= shift;
    my( $datatype )	= shift;
    my( $name )		= $datatype->{name};

    unless( defined( $cfg->{datatypes}->{$name} ) )
    {
	$cfg->{datatypes}->{$name}		= {};
	$cfg->{datatypes}->{$name}->{visbility}	= "public";
	$cfg->{datatypes}->{$name}->{name}	= $name;
	$cfg->{datatypes}->{$name}->{xmi_id}	= $cfg->{arg}++;
    }
    if  ($name =~ /^_/)
    {
	$cfg->{datatypes}->{$name}->{visbility}	= "private";
    }
}



#----------------------------------------------------------------------
=pod
USAGE:
	&process_generalization( $cfg, $parent, $child );

DESCRIPTION:
	Add a implementation / generalization link.

=cut

sub	process_generalization
{
    my( $cfg )		= shift;
    my( $parent )	= shift;
    my( $child )	= shift;
    my( $id )		= $cfg->{xmi_id}++;

    unless( defined( $cfg->{generalizations}->{$id} ) )
    {
	$cfg->{generalizations}->{$id}			= {};
	$cfg->{generalizations}->{$id}->{visbility}	= "public";
	$cfg->{generalizations}->{$id}->{parent}	= $parent;
	$cfg->{generalizations}->{$id}->{child}		= $child;
    }
}



#----------------------------------------------------------------------
=pod
USAGE:
	&emit_model( $cfg );

DESCRIPTION:
	Emit the XMI model file.  The current target modeler is Umbrello.

=cut

sub	emit_model
{
    my( $cfg )	= shift;
####    use Data::Dumper;
####    print Dumper( $cfg );
    if (open( XMI, ">reversed.xmi" ))
    {
	print "File=reversed.xmi\n";
	print XMI join( "\n",
			'<?xml version="1.0" encoding="UTF-8"?>',
			'<XMI xmlns:UML="org.omg/standards/UML" verified="false" timestamp="" xmi.version="1.2" >',
			'<XMI.content>',
			' <UML:Model>',
			&emit_datatypes( $cfg ),
			&emit_packages( $cfg, $cfg, 2 ),
			&emit_generalizations( $cfg, 2 ),
			' </UML:Model>',
			'</XMI.content>',
			'</XMI>',
			'',
			);
	close( XMI );
	chmod( 0644, "reversed.xmi" );
    }
    else
    {
	print "Unable to create [reversed.xmi]: $!\n";
    }
}




#----------------------------------------------------------------------
=pod

USAGE:
	&emit_datatypes( $cfg );

DESCRIPTION:
	Emit datatypes.

=cut

sub	emit_datatypes
{
    my( $cfg )		= shift;
    my( @retval )	= ();
    my( $datatype );
    foreach $datatype (sort keys %{$cfg->{datatypes}})
    {
	my( $type )	= $cfg->{datatypes}->{$datatype};
	if  (defined( $type->{name} ))
	{
	    my( $id )		= $type->{xmi_id};
	    my( $scope )	= $type->{visibility};
	    my( $name )		= $type->{name};
	    push( @retval, "  <UML:DataType visibility=\"$scope\" xmi.id=\"$id\" name=\"$name\" />" );
	}
    }
    return( @retval );
}





#----------------------------------------------------------------------
=pod

USAGE:
	&emit_packages( $cfg, $parent, $level );

DESCRIPTION:
	Emit all packages, classes, attributes, methods and parameters
	in proper containment.

=cut

sub	emit_packages
{
    my( $cfg )		= shift;
    my( $parent )	= shift;
    my( $level )	= shift;
    my( $indent )	= ' ' x $level;
    my( @retval )	= ();

####    print "cfg=[$cfg] =?= parent=[$parent]\n"; 
    my( $key );
    foreach $key (sort keys %{$parent})
    {
	if  ($key =~ /last_class|last_method/)
	{
	}
	elsif  (defined( $parent->{$key}->{type} ))
	{
	    my( $child )	= $parent->{$key};
	    my( $type )		= "$child->{type}";
	    my( $id )		= "$child->{xmi_id}";
	    my( $name )		= "$child->{name}";
	    my( $scope )	= "$child->{visibility}";
	    my( $comment )	= "$child->{comment}";
####	    print "[$type] - [$name] - [$id] [$comment]\n"	if ($comment ne "");
	    if  (defined( $child->{xmi_id} ))
	    {
		my( @record )	= ( "$indent<UML:$type" );
		push( @record, "visibility=\"$scope\"" )	if  ($scope ne "");
		push( @record, "xmi.id=\"$id\"" )		if  ($id ne "");
		push( @record, "name=\"$name\"" )		if  ($name ne "");
		push( @record, "comment=\"$comment\"" )		if  ($comment ne "");
		push( @record, ">" );
		my( $record )	= join( " ", @record );
		push( @retval, $record, &emit_packages( $cfg, $child, $level+1 ), "$indent</UML:$type>", );
	    }
	    else
	    {
		my( @record )	= ( "$indent<UML:$type" );
		push( @record, "visibility=\"$scope\"" )	if  ($scope ne "");
		push( @record, "xmi.id=\"$id\"" )		if  ($id ne "");
		push( @record, "name=\"$name\"" )		if  ($name ne "");
		push( @record, "comment=\"$comment\"" )		if  ($comment ne "");
		push( @record, "/>" );
		my( $record )	= join( " ", @record );
		push( @retval, $record );
	    }
	}
    }
    return( @retval );
}



#----------------------------------------------------------------------
=pod

USAGE:
	&emit_generalizations( $cfg );

DESCRIPTION:
	Emit generalizations.

=cut

sub	emit_generalizations
{
    my( $cfg )		= shift;
    my( @retval )	= ();

    my( $id );
    foreach $id (sort {$a <=> $b} keys %{$cfg->{generalizations}})
    {
	my( $node )	= $cfg->{generalizations}->{$id};
	my( $scope )	= $node->{visibility};
	my( $parent )	= $node->{parent}->{xmi_id};
	my( $child )	= $node->{child}->{xmi_id};

	push( @retval, "  <UML:Generalization child=\"$child\" visibility=\"$scope\" xmi.id=\"$id\" parent=\"$parent\" />" );
    }
    return( @retval );
}





#----------------------------------------------------------------------
=pod

USAGE:

	$string = &xmlsafe( $string );

DESCRIPTION:
	Ensure that the string is XML-safe given UTF-8 encoding rules.

=cut

sub	xmlsafe
{
    my( $string )	= shift || "";
    my( $raw )		= $string;
    if ($raw ne "")
    {
	$string =~ s/\&/\&amp;/g;			## Fixup code like: & => &amp;
	$string =~ s/\(\&\)/\(\&amp;\)/g;		## Fixup code like: & => &amp;
	$string =~ s/\"/&quot;/g;			## Fixup contained double quotes: " => &quot;
	$string =~ s/\</&lt;/g;				## Fixup XML/HTML tags: => < => &lt;
	$string = &nice_string( $string );		## Fixup unicode characters: (unicodechar) => &#1234;
####	print "COMMENT=[$string]\n\n";
    }
    return( $string );
}





#----------------------------------------------------------------------
=pod

USAGE:
	$string = &nice_string( $string );

DESCRIPTION:
	Ensure that comments from the scanned code are XML validatable.
    	
ATTRIBUTION:
	The unicode translation code was taken from perluniintro and
        expanded into simpler form for maintenance reasons.  Thank you.

=cut

sub	nice_string
{
    my( $string )	= shift;
    my( @chars )	= unpack( "U*", $string );
    my( @fixed )	= ();
    my( $char );
    foreach $char (@chars)
    {
	if  ($char > 255)
	{
	    push( @fixed, sprintf( "&#%04X;", $char ) );
	}
	else
	{
	    push( @fixed, chr( $char ) );
	}
    }
    $string = join( "", @fixed );
    return( $string );
}