UML::Class::Simple - Render simple UML class diagrams, by loading the code

    use UML::Class::Simple;

    # produce a class diagram for Alias's PPI
    # which has already installed to your perl:

    @classes = classes_from_runtime("PPI", qr/^PPI::/);
    $painter = UML::Class::Simple->new(\@classes);
    $painter->as_png('ppi.png');

    # produce a class diagram for your CPAN module on the disk

    @classes = classes_from_files(['lib/Foo.pm', 'lib/Foo/Bar.pm']);
    $painter = UML::Class::Simple->new(\@classes);

    # we can explicitly specify the image size
    $painter->size(5, 3.6); # in inches

    # ...and change the default title background color:
    $painter->node_color('#ffffff'); # defaults to '#f1e1f4'

    # only show public methods and properties
    $painter->public_only(1);

    # hide all methods from parent classes
    $painter->inherited_methods(0);

    $painter->as_png('my_module.png');

    perl Makefile.PL
    make
    make test
    make install

package UML::Class::Simple;

use strict;
use warnings;
no warnings 'redefine';

our $VERSION = '0.18';

#use Smart::Comments;
use Carp qw(carp confess);
use Class::Inspector;
use Devel::Peek ();
use File::Spec;
use IPC::Run3;
use List::MoreUtils 'any';
use Template;
use XML::LibXML ();

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(
    classes_from_runtime classes_from_files
    exclude_by_paths grep_by_paths
);

my $tt = Template->new;
my $dot_template;

sub classes_from_runtime {
    my ($modules, $pattern) = @_;
    $modules = [$modules] if $modules and !ref $modules;
    $pattern = '' if !defined $pattern;
    for (@$modules) {
        eval "use $_;";
        if ($@) { carp $@; return (); }
    }
    grep { /$pattern/ } _runtime_packages();
}

sub _normalize_path ($) {
    my $path = shift;
    $path = File::Spec->rel2abs($path);
    if (File::Spec->case_tolerant()) {
        $path = lc($path);
    } else {
        $path;
    }
}

sub exclude_by_paths ($@) {
    my $rclasses = shift;
    my @paths = map { _normalize_path($_) } @_;
    my @res;
    #_extend_INC();
    for my $class (@$rclasses) {
        #warn $class;
        my $filename = Class::Inspector->resolved_filename($class);
        #warn "[0] ", $filename, "\n";
        if (!$filename && $INC{$class}) {
            $filename = Class::Inspector->loaded_filename($class);
        }
        if (!$filename) { next; }
        #warn "[1] ", $filename, "\n";
        $filename = _normalize_path($filename);
        #warn "[2] ", $filename, "\n";
        #my $value = $INC{$key};
        if (any { substr($filename, 0, length) eq $_ } @paths) {
            #warn "!!! ignoring $filename\n";
            next;
        }
        #warn "adding $filename <=> @paths\n";
        push @res, $class;
    }
    @res;
}

sub grep_by_paths ($@) {
    my $rclasses = shift;
    my @paths = map { _normalize_path($_) } @_;
    my @res;
    #_extend_INC();
    for my $class (@$rclasses) {
        my $filename = Class::Inspector->resolved_filename($class);
        if (!$filename && $INC{$class}) {
            $filename = Class::Inspector->loaded_filename($class);
        }
        if (!$filename) { next; }
        $filename = _normalize_path($filename);
        #my $value = $INC{$key};
        if (any { substr($filename, 0, length) eq $_ } @paths) {
            #warn "adding $filename <=> @paths\n";
            push @res, $class;
            next;
        }
        #warn "!!! ignoring $filename\n";
    }
    @res;
}

sub _runtime_packages {
    no strict 'refs';
    my $pkg_name = shift || '::';
    my $cache = shift || {};
    return if $cache->{$pkg_name};
    $cache->{$pkg_name} = 1;
    for my $entry (keys %$pkg_name) {
        next if $entry !~ /\:\:$/ or $entry eq 'main::';
        my $subpkg_name = $pkg_name.$entry;
        #warn $subpkg_name;
        _runtime_packages($subpkg_name, $cache);
        $cache->{$subpkg_name} = 1;
    }
    map { s/^::|::$//g; $_ } keys %$cache;
}

sub classes_from_files {
    require PPI;
    my ($list, $pattern, $read_only) = @_;
    $list = [$list] if $list and !ref $list;
    $pattern = '' if !defined $pattern;
    my @classes;
    my $cache = {};
    for my $file (@$list) {
        _gen_paths($file, $cache);
        my $doc = PPI::Document->new( $file );
        if (!$doc) {
            carp "warning: Can't parse $file: ", PPI::Document->errstr;
            next;
        }
        my $res = $doc->find('PPI::Statement::Package');
        next if !$res;
        push @classes, map { $_->namespace } @$res;
        _load_file($file) if !$read_only;
    }
    @classes = grep { /$pattern/ } @classes;
    #@classes = sort @classes;
    wantarray ? @classes : \@classes;
}

sub _gen_paths {
    my ($file, $cache) = @_;
    $file =~ s{\\+}{/}g;
    my $dir;
    while ($file =~ m{(?x) \G .+? /+ }gc) {
        $dir .= $&;
        next if $cache->{$dir};
        $cache->{$dir} = 1;
        #warn "pushing ~~~ $dir\n";
        unshift @INC, $dir;
    }
}

sub new {
    my $class = ref $_[0] ? ref shift : shift;
    my $rclasses = shift || [];
    my $self = bless {
        class_names => $rclasses,
        node_color  => '#f1e1f4',
    }, $class;
    $self->{inherited_methods} = 1;
    my $options = shift;
    if (ref($options) eq 'HASH') {
        $self->{inherited_methods} = $options->{inherited_methods};
        if (defined $options->{xmi_model}) {
            $self->_xmi_load_model($options->{xmi_model});
        }
    }
    #$self->_build_dom;
    $self;
}

sub size {
    my $self = shift;
    if (@_) {
        my ($width, $height) = @_;
        if (!$width || !$height || ($width . $height) !~ /^[\.\d]+$/) {
            carp "invalid width and height";
            return undef;
        } else {
            $self->{width}  = $width;
            $self->{height} = $height;
            return 1;
        }
    } else {
        return ($self->{width}, $self->{height});
    }
}

sub node_color {
    my $self = shift;
    if (@_) {
        $self->{node_color} = shift;
    } else {
        $self->{node_color};
    }
}

sub dot_prog {
    my $self = shift;
    if (@_) {
        my $cmd = shift;
        can_run($cmd) or die "ERROR: The dot program ($cmd) cannot be found or be run.\n";
        $self->{dot_prog} = $cmd;
    } else {
        $self->{dot_prog} || 'dot';
    }
}

# copied from IPC::Cmd. Copyright by IPC::Cmd's author.
sub can_run {
    my $command = shift;

    # a lot of VMS executables have a symbol defined
    # check those first
    if ( $^O eq 'VMS' ) {
        require VMS::DCLsym;
        my $syms = VMS::DCLsym->new;
        return $command if scalar $syms->getsym( uc $command );
    }

    require Config;
    require File::Spec;
    require ExtUtils::MakeMaker;

    if( File::Spec->file_name_is_absolute($command) ) {
        return MM->maybe_command($command);

    } else {
        for my $dir (
            (split /\Q$Config::Config{path_sep}\E/, $ENV{PATH}),
            File::Spec->curdir
        ) {
            my $abs = File::Spec->catfile($dir, $command);
            return $abs if $abs = MM->maybe_command($abs);
        }
    }
}

sub _property {
    my $self = shift;
    my $property_name = shift;
    if (@_) {
        $self->{$property_name} = shift;
        $self->_build_dom(1);
    } else {
        $self->{$property_name};

    }
}

sub public_only {
    my $self = shift;
    $self->_property('public_only', @_);
}

sub inherited_methods {
    my $self = shift;
    $self->_property('inherited_methods', @_);
}

sub as_png {
    my $self = shift;
    $self->_as_image('png', @_);
}

sub as_gif {
    my $self = shift;
    $self->_as_image('gif', @_);
}

sub _as_image {
    my ($self, $type, $fname) = @_;
    my $dot = $self->as_dot;
    #if ($fname eq 'fast00.png') {
        #warn "==== $fname\n";
        #warn $dot;
        #use YAML::Syck;
        #$self->_build_dom(1);
        #warn Dump($self->as_dom);
    #}
    my @cmd = ($self->dot_prog(), '-T', $type);
    #my @cmd = ('dot', '-T', $type);
    if ($fname) {
        push @cmd, '-o', $fname;
    }
    my ($img_data, $stderr);
    my $success = run3 \@cmd, \$dot, \$img_data, \$stderr;
    if ($stderr) {
        if ($? == 0) {
            carp $stderr;
        } else {
            Carp::croak $stderr;
        }
    }
    if (!$fname) {
        return $img_data;
    }
}

sub as_dom {
    my $self = shift;
    $self->_build_dom;
    { classes => $self->{classes} };
}

sub set_dom ($$) {
    my $self = shift;
    $self->{classes} = shift->{classes};
    1;
}

sub _build_dom {
    my ($self, $force) = @_;
    # avoid unnecessary evaluation:
    return if $self->{classes} && !$force || !$self->{class_names};
    #warn "HERE";
    my @pkg = @{ $self->{class_names} };
    my @classes;
    $self->{classes} = \@classes;
    my $public_only = $self->{public_only};
    my %visited; # used to eliminate potential repetitions
    for my $pkg (@pkg) {
        #warn $pkg;
        $pkg =~ s/::::/::/g;
        if ($visited{$pkg}) { next; }
        $visited{$pkg} = 1;

        if (!Class::Inspector->loaded($pkg)) {
            #my $pmfile = Class::Inspector->filename($pkg);
            #warn $pmfile;
            #if ($pmfile) {
            #    if (! _load_file($pmfile)) {
            #        next;
            #    }
            #} else { next }
            next;
        }
        push @classes, {
            name => $pkg, methods => [],
            properties => [], subclasses => [],
        };
        my $from_class_accessor =
            $pkg->isa('Class::Accessor') ||
            $pkg->isa('Class::Accessor::Fast') ||
            $pkg->isa('Class::Accessor::Grouped');
        #accessor_name_for

        # If you want to gather only the functions defined in
        #  the current class only (w/o those inherited from ancestors),
        #  set inherited_methods property to false (default value is true).
        my $methods = Class::Inspector->methods($pkg, 'expanded');
        if ($methods and ref($methods) eq 'ARRAY') {
            if ($from_class_accessor) {
                my $i = 0;
                my %functions = map { $_->[2] => $i++ } @$methods; # create hash from array
                ### %functions
                #my @accessors = map { /^_(.*)_accessor$/; $1 } keys %functions;
                ### @accessors
                my $use_best_practice = delete $functions{'accessor_name_for'} && delete $functions{'mutator_name_for'};
                my %accessors;
                foreach my $meth (keys %functions) {
                    next unless $meth;
                    if ($meth =~ /^_(.*)_accessor$/) {
                        my $accessor = $1;
                        if (exists $functions{$accessor}) {
                            if ($self->{inherited_methods} or
                                $methods->[$functions{$accessor}]->[1] eq $pkg) {
                                push @{ $classes[-1]->{properties} }, $accessor;
                            }
                            delete $functions{$accessor};
                            delete $functions{"_${accessor}_accessor"};
                            #push @{ $classes[-1]->{properties} }, $accessor;
                        }
                        next;
                    }
                    if ($use_best_practice) {
                        if ($meth =~ /^(?:get|set)_(.+)/) {
                            my $accessor = $1;
                            delete $functions{$meth};
                            if (!$accessors{$accessor}) {
                                #push @{ $classes[-1]->{properties} }, $accessor;
                                if ($self->{inherited_methods} or
                                    $methods->[$functions{$accessor}]->[1] eq $pkg) {
                                     push @{ $classes[-1]->{properties} }, $accessor;
                                }
                                $accessors{$accessor} = 1;
                            }
                        }
                    }
                }
                @$methods = grep { exists $functions{$_->[2]} } @$methods;
            }
            @{ $classes[-1]->{properties} } = sort @{ $classes[-1]->{properties} };

            foreach my $method (@$methods) {
                next if $method->[1] ne $pkg;
                if (! $self->{inherited_methods}) {
                    my $source_name =  Devel::Peek::CvGV($method->[3]);
                    $source_name =~ s/^\*//;
                    next if $method->[0] ne $source_name;
                }
                $method = $method->[2];
                next if $public_only && $method =~ /^_/o;
                push @{$classes[-1]->{methods}}, $method;
            }
        }




        my $subclasses = Class::Inspector->subclasses($pkg);
        if ($subclasses) {
            no strict 'refs';
            my @child = grep {
                #warn "!!!! ", join ' ', @{"${_}::ISA"};
                any { $_ eq $pkg } @{"${_}::ISA"};
            } @$subclasses;
            if (@child) {
                $classes[-1]->{subclasses} = \@child;
            }
        }
    }
    #warn "@classes";
}

sub _load_file ($) {
    my $file = shift;
    my $path = _normalize_path($file);
    #warn "!!! >>>> $path\n";
    if ( any {
                #warn "<<<<< ", _normalize_path($_), "\n";
                $path eq _normalize_path($_);
             } values %INC ) {
        #carp "!!! Caught duplicate module files: $file ($path)";
        return 1;
    }
    #my @a = values %INC;
    #warn "\n@a\n";
    #warn "!!! Loading $path...\n";
    eval {
        require $path;
    };
    carp $@ if $@;
    !$@;
}

sub _xmi_get_new_id {
    my $self = shift;
    return 'xmi.' . $self->{_xmi}->{_id_counter}++;
}

sub _xmi_create_inheritance {
    my ($self, $class, $subclass_name) = @_;
    my $child_id = $self->{_xmi}->{_name2id}->{$subclass_name};
    my $id = $self->_xmi_get_new_id();

    my $element = XML::LibXML::Element->new('UML:Generalization');
    $self->{_xmi}->{_classes_root}->appendChild($element);
    $self->_xmi_set_default_attribute($element, 'isSpecification', 'false');
    $element->setAttribute('xmi.id', $id);

    my $child = XML::LibXML::Element->new('UML:Generalization.child');
    $element->appendChild($child);
    my $child_xml_class = XML::LibXML::Element->new('UML:Class');
    $child->appendChild($child_xml_class);
    $child_xml_class->setAttribute('xmi.idref', $child_id);

    my $parent = XML::LibXML::Element->new('UML:Generalization.parent');
    $element->appendChild($parent);
    $child_xml_class = XML::LibXML::Element->new('UML:Class');
    $parent->appendChild($child_xml_class);
    $child_xml_class->setAttribute('xmi.idref', $class->{xmi_id});

    my $xml_class = $self->{_xmi}->{_classes_hash}->{$subclass_name};
    return unless defined $xml_class;
    my $generalization = XML::LibXML::Element->new('UML:Generalization');
    $generalization->setAttribute('xmi.idref', $id);
    my $generalizableElement = XML::LibXML::Element->new('UML:GeneralizableElement.generalization');
    $generalizableElement->appendChild($generalization);
    $xml_class->appendChild($generalizableElement);
}

sub _xmi_write_method {
    my ($self, $parent_node, $class, $method) = @_;

    my $id = $self->_xmi_get_new_id();
    my $visibility = 'public';
    $visibility = 'private' if substr($method, 0, 1) eq '_';
    my $ownerScope = 'instance';
    $ownerScope = 'classifier' if $method =~ /^[A-Z]/o;

    my $xml_method = $self->_xmi_add_element($parent_node, 'UML:Operation', $method);

    $xml_method->setAttribute('xmi.id', $id);
    $xml_method->setAttribute('visibility', $visibility);
    $xml_method->setAttribute('ownerScope', $ownerScope);
    $self->_xmi_set_default_attribute($xml_method, 'concurrency', 'sequential');
    $self->_xmi_set_default_attribute($xml_method, $_, 'false') foreach qw(isSpecification isQuery isRoot isLeaf isAbstract);
}

sub _xmi_write_class {
    my ($self, $class) = @_;

    my $xml_class = $self->_xmi_add_element($self->{_xmi}->{_classes_root}, 'UML:Class', $class->{name});
    $self->{_xmi}->{_classes_hash}->{$class->{name}} = $xml_class;
    $xml_class->setAttribute('xmi.id', $class->{xmi_id});
    $xml_class->setAttribute('visibility', 'public');
    $self->_xmi_set_default_attribute($xml_class, $_, 'false') foreach qw(isSpecification isRoot isLeaf isAbstract isActive);

    my $uml_classifier =  XML::LibXML::Element->new('UML:Classifier.feature');
    $xml_class->appendChild($uml_classifier);

    $self->_xmi_write_method($uml_classifier, $class, $_) foreach @{$class->{methods}};
    $self->_xmi_create_inheritance($class, $_) foreach @{$class->{subclasses}};
}

sub _xmi_set_id {
    my ($self, $class) = @_;
    $class->{xmi_id} = $self->_xmi_get_new_id();
    $self->{_xmi}->{_name2id}->{$class->{name}} = $class->{xmi_id};
}

sub _xmi_add_element {
    my ($self, $parent, $class, $name) = @_;
    my $node;
    if (defined $name) {
        foreach $node ($parent->getElementsByTagName($class)) {
            if ($node->getAttribute('name') eq $name) {
                return $node;
            }
        }
    }
    $node = $self->{_xmi}->{_document}->createElement($class);
    $node->setAttribute('name', $name);
    $parent->appendChild($node);
    return $node;
}

sub _xmi_set_default_attribute {
    my ($self, $node, $name, $value) = @_;
    return if defined $node->getAttribute($name);
    $node->setAttribute($name, $value);
}

sub _xmi_load_model {
    my ($self, $fname) = @_;
    $self->{_xmi}->{_document} = XML::LibXML->new()->parse_file($fname);
}

sub _xmi_init_xml {
    my ($self, $fname) = @_;
    unless (defined $self->{_xmi}->{_document}) {
        $self->{_xmi}->{_document} = XML::LibXML::Document->new('1.0', 'UTF-8');
    }
    my $doc = $self->{_xmi}->{_document};

    my $xmi_root = $doc->createElement('XMI');
    $xmi_root->setAttribute('xmi.version', '1.2');
    $xmi_root->setAttribute('xmlns:UML', 'org.omg.xmi.namespace.UML');
    my $generate_time = POSIX::asctime(localtime(time()));
    chomp($generate_time);
    $xmi_root->setAttribute('timestamp', $generate_time);
    $doc->setDocumentElement($xmi_root);

    my $xmi_content = $doc->createElement('XMI.content');
    $xmi_root->appendChild($xmi_content);

    my $uml_model = $self->_xmi_add_element($xmi_content, 'UML:Model', $fname || '');
    $uml_model->setAttribute('xmi.id', $self->_xmi_get_new_id());
    $self->_xmi_set_default_attribute($uml_model, $_, 'false') foreach qw(isSpecification isRoot isLeaf isAbstract);

    $self->{_xmi}->{_classes_root} = $doc->createElement('UML:Namespace.ownedElement');
    $uml_model->appendChild($self->{_xmi}->{_classes_root});

    return $doc;
}

sub as_xmi {
    my ($self, $fname) = @_;
    $self->_build_dom;
    $self->{_xmi} ||= {};
    $self->{_xmi}->{_id_counter} = 1;
    $self->{_xmi}->{_name2id} = {};
    $self->_xmi_set_id($_) foreach @{$self->{classes}};
    my $doc = $self->_xmi_init_xml($fname);
    $self->_xmi_write_class($_) foreach @{$self->{classes}};
    if ($fname) {
        $doc->toFile($fname, 2);
    } else {
        return $doc;
    }
}

sub as_dot {
    my ($self, $fname) = @_;
    $self->_build_dom;
    if ($fname) {
        $tt->process(\$dot_template, $self, $fname)
            || carp $tt->error();
    } else {
        my $dot;
        $tt->process(\$dot_template, $self, \$dot)
            || carp $tt->error();
        $dot;
    }
}

sub set_dot ($$) {
    my $self = shift;
    $self->{dot} = shift;
}

$dot_template = <<'_EOC_';
digraph uml_class_diagram {
  [%- IF width && height %]
    size="[% width %],[% height %]";
  [%- END %]
    node [shape=record, style="filled"];
    edge [color=red, dir=none];

[%- name2id = {} %]
[%- id = 1 %]
[%- FOREACH class = classes %]
    [%- name = class.name %]
    [%- name2id.$name = id %]
    class_[% id %] [shape=plaintext, style="", label=<
<table BORDER="0" CELLBORDER="1" CELLSPACING="0" CELLPADDING="4">
  <tr><td port="title" bgcolor="[% node_color %]">[% name %]</td></tr>
  <tr>
    <td>
    <table border="0" cellborder="0" cellspacing="0" cellpadding="1">
      <tr>
    <td>[% IF class.properties.size > 0 %]<font color="red">
    [%- FOREACH property = class.properties %]
      [%- property.match("^_") ? "-" : "+" %]<br align="left"/>

    [%- END %]</font>[% END %]</td>
    <td port="properties" bgcolor="white" align="left">
    [%- FOREACH property = class.properties %]
      [%- property %]<br align="left"/>

    [%- END %]</td>
      </tr>
    </table>
    </td>
  </tr>
  <tr>
    <td port="methods" >
    <table border="0" cellborder="0" cellspacing="0" cellpadding="0">
      <tr>
    <td>[% IF class.methods.size > 0 %]<font color="red">
    [%- FOREACH method = class.methods %]
      [%- method.match("^_") ? "-" : "+" %]<br align="left"/>

    [%- END %]</font>[% END %]</td>
    <td bgcolor="white" align="left">
    [%- FOREACH method = class.methods %]
      [%- method %]<br align="left"/>

    [%- END %]</td>
      </tr>
    </table>
    </td>
  </tr>
</table>>];
  [%- id = id + 1 %]
[% END %]
[%- class_id = id %]

[%- first = 1 %]
[%- id = 0 %]
[%- FOREACH class = classes %]
  [%- id = id + 1 %]
  [%- super = class.name %]
  [%- NEXT IF !class.subclasses.size -%]

  [%- IF first -%]
     node [shape="triangle", fillcolor=yellow, height=0.3, width=0.3];
     [%- first = 0 %]
  [%- END -%]

     angle_[% id %] [label=""];


  [%- super_id = name2id.$super %]
     class_[% super_id %]:methods -> angle_[% id %]
  [%- FOREACH child = class.subclasses %]
    [%- child_id = name2id.$child %]
    [%- IF !child_id %]
     class_[% class_id %] [shape=record, label="[% child %]" fillcolor="#f1e1f4", style="filled"];
     angle_[% id %] -> class_[% class_id %]
        [%- class_id = class_id + 1 %]
      [%- ELSE %]
     angle_[% id %] -> class_[% child_id %]:title
    [%- END %]
  [%- END %]
[%- END %]

}
_EOC_

1;
__END__