libconfig-model-itself-perl 1.241-1 / usr / share / perl5 / Config / Model / Itself.pm

#
# This file is part of Config-Model-Itself
#
# This software is Copyright (c) 2014 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Itself ;
$Config::Model::Itself::VERSION = '1.241';
use Mouse ;
use Config::Model 2.055;
use 5.010;

use IO::File ;
use Log::Log4perl 1.11;
use Carp ;
use Data::Dumper ;
use File::Find ;
use File::Path ;
use File::Basename ;
use Data::Compare ;

my $logger = Log::Log4perl::get_logger("Backend::Itself");


# find all .pl file in model_dir and load them...

has model_object => (is =>'ro', isa =>'Config::Model::Node', required => 1) ;
has model_dir    => (is =>'ro', isa =>'Str', required => 1 ) ;
has force_write  => (is =>'ro', isa => 'Bool', default => 0) ;

has modifed_classes => (
    is =>'rw', 
    isa =>'HashRef[Bool]', 
    traits => ['Hash'],
    default => sub { {} } ,
    handles => {
        clear_classes => 'clear',
        set_class => 'set',
        class_was_changed => 'get' ,
        classes_to_write => 'keys' ,
    }
) ;

sub BUILD {
    my $self = shift;

    my $cb = sub {
        my %args = @_ ;
        my $p = $args{path} || '' ;
        return unless $p =~ /^class/ ;
        return if $self->class_was_changed($args{index}) ;
        $logger->info("class $args{index} was modified");
        
        $self->add_modified_class($args{index}) ;
    } ;
    $self->model_object->instance -> on_change_cb($cb) ;
    
}


sub add_modified_class {
    my $self = shift;
    $self->set_class(shift,1) ;
}


sub read_all {
    my $self = shift ;
    my %args = @_ ;

    my $model = delete $args{root_model} 
      || croak __PACKAGE__," read_all: undefined root_model";
    my $force_load = delete $args{force_load} || 0 ;
    my $legacy = delete $args{legacy} ;

    croak "read_all: unexpected parameters ",join(' ', keys %args) if %args ;

    my $dir = $self->model_dir ;
    unless (-d $dir ) {
        croak __PACKAGE__," read_all: unknown model dir $dir";
    }

    my $root_model_file = $model ;
    $root_model_file =~ s!::!/!g ;
    
    my @files ;
    my $wanted = sub { 
        my $n = $File::Find::name ;
        push @files, $n if (-f $_ and not /~$/ 
                            and $n !~ /CVS/
                            and $n !~ m!.(svn|orig|pod)$!
                            and $n =~ m!$dir/$root_model_file!
                           ) ;
    } ;
    find ($wanted, $dir ) ;

    my $i = $self->model_object->instance ;
    
    my %read_models ;
    my %pod_data ;
    my %class_file_map ;

    for my $file (@files) {
        $logger->info("loading config file $file");

        # now apply some translation to read model
        # - translate legacy warp parameters
        # - expand elements name
        my $tmp_model = Config::Model -> new( skip_include => 1, legacy => $legacy ) ;
        # @models order is important to write configuration class back in the same
        # order as the declaration
        my @models = $tmp_model -> load ( 'Tmp' , $file ) ;

        my $rel_file = $file ;
        $rel_file =~ s/^$dir\/?//;
        die "wrong reg_exp" if $file eq $rel_file ;
        $class_file_map{$rel_file} = \@models ;

        # - move experience, description and level status into parameter info.
        foreach my $model_name (@models) {
            # no need to dclone model as Config::Model object is temporary
            my $raw_model =  $tmp_model -> get_raw_model( $model_name ) ;
            my $new_model =  $tmp_model -> get_model( $model_name ) ;

            # some modifications may be done to cope with older model styles. If a modif
            # was done, mark the class as changed so it will be saved later
            $self->add_modified_class($model_name) unless Compare($raw_model, $new_model) ;

            foreach my $item (qw/description summary level experience status/) {
                foreach my $elt_name (keys %{$new_model->{element}}) {
                    my $moved_data = delete $new_model->{$item}{$elt_name}  ;
                    next unless defined $moved_data ;
                    $new_model->{element}{$elt_name}{$item} = $moved_data ; 
                }
                delete $new_model->{$item} ;
            }

            # Since accept specs and elements are stored in a ordered hash,
            # load_data expects a array ref instead of a hash ref.
            # Build this array ref taking the order into
            # account
            foreach my $what (qw/element accept/) {
                my $list  = delete $new_model -> {$what.'_list'} ;
                my $h     = delete $new_model -> {$what} ;
                $new_model -> {$what} = [] ;
                map { 
                    push @{$new_model->{$what}}, $_, $h->{$_} 
                } @$list ;
            }

            # remove hash key with undefined values
            map { delete $new_model->{$_} unless defined $new_model->{$_} 
                                          and $new_model->{$_} ne ''
              } keys %$new_model ;
            $read_models{$model_name} = $new_model ;
        }

    }

    # Create all classes listed in %read_models to avoid problems with
    # include statement while calling load_data
    my $model_obj = $self->model_object ;
    my $class_element = $model_obj->fetch_element('class') ;
    map { $class_element->fetch_with_id($_) } sort keys %read_models ;

    #require Tk::ObjScanner; Tk::ObjScanner::scan_object(\%read_models) ;

    $logger->info("loading all extracted data in Config::Model::Itself");
    # load with a array ref to avoid warnings about missing order
    $model_obj->load_data(
        data => {class => [ %read_models ] },
        check => $force_load ? 'no' : 'yes'
    ) ;

    # load annotations and comment header
    for my $file (@files) {
        $logger->info("loading annotations from file $file");
        my $fh = IO::File->new($file) || die "Can't open $file: $!" ;
        my @lines = $fh->getlines ;  
        $fh->close;
        $model_obj->load_pod_annotation(join('',@lines)) ;

        my @headers ;
        foreach my $l (@lines) {
            if ($l =~ /^\s*#/ or $l =~ /^\s*$/){
                push @headers, $l
            }
            else {
                last;
            }
        }
        my $rel_file = $file ;
        $rel_file =~ s/^$dir\/?//;
        $self->{header}{$rel_file} = \@headers;
    }

    return $self->{map} = \%class_file_map ;
}

# internal
sub get_perl_data_model{
    my $self = shift ;
    my %args = @_ ;
    my $model_obj = $self->{model_object};
    my $class_name = $args{class_name}
      || croak __PACKAGE__," read: undefined class name";

    my $class_element = $model_obj->fetch_element('class') ; 

    # skip if class was deleted during edition
    return unless $class_element->defined($class_name) ;
    
    my $class_elt = $class_element -> fetch_with_id($class_name) ;

    my $model = $class_elt->dump_as_data ;

    # now apply some translation to read model
    # - Do NOT translate legacy warp parameters
    # - Do not compact elements name

    # don't forget to add name
    $model->{name} = $class_name if keys %$model;

    return $model ;
}


sub write_all {
    my $self = shift ;
    my %args = @_ ;
    my $model_obj = $self->model_object ;
    my $dir = $self->model_dir ;

    croak "write_all: unexpected parameters ",join(' ', keys %args) if %args ;

    my $map = $self->{map} ;

    unless (-d $dir ) {
        mkpath($dir,0, 0755) || die "Can't mkpath $dir:$!";
    }

    # get list of all classes loaded by the editor
    my %loaded_classes 
      = map { ($_ => 1); } 
        $model_obj->fetch_element('class')->fetch_all_indexes ;

    # remove classes that are listed in map
    foreach my $file (keys %$map) {
        foreach my $class_name (@{$map->{$file}}) {
            delete $loaded_classes{$class_name} ;
        }
    }

    # add remaining classes in map
    my %new_map =  map { 
        my $f = $_; 
        $f =~ s!::!/!g; 
        ("$f.pl" => [ $_ ]) ;
    } keys %loaded_classes ;

    my %map_to_write = (%$map,%new_map) ;

    foreach my $file (keys %map_to_write) {
        $logger->info("checking model file $file");

        my @data ;
        my @notes ;
        my $file_needs_write = 0;
        
        # check if any a class of a file was modified
        foreach my $class_name (@{$map_to_write{$file}}) {
            $file_needs_write++ if $self->force_write or $self->class_was_changed($class_name) ;
            $logger->info("file $file class $class_name needs write ",$file_needs_write);
        }
        
        next unless $file_needs_write ;    

        foreach my $class_name (@{$map_to_write{$file}}) {
            $logger->info("writing class $class_name");
            my $model 
              = $self-> get_perl_data_model(class_name => $class_name) ;
            push @data, $model if defined $model and keys %$model;
            
            my $node = $self->{model_object}->grab("class:".$class_name) ;
            push @notes, $node->dump_annotations_as_pod ;
            # remove class name from above list
            delete $loaded_classes{$class_name} ;
        }

        next unless @data ; # don't write empty model

        write_model_file ("$dir/$file", $self->{header}{$file}, \@notes, \@data);
    }
    
    $self->model_object->instance->clear_changes ;
}

sub write_model_snippet {
    my $self = shift ;
    my %args = @_ ;
    my $snippet_dir = delete $args{snippet_dir} 
      || croak __PACKAGE__," write_model_snippet: undefined snippet_dir";
    my $model_file = delete $args{model_file} 
      || croak __PACKAGE__," write_model_snippet: undefined model_file";
    croak "write_model_snippet: unexpected parameters ",join(' ', keys %args) if %args ;

    my $model = $self->model_object->dump_as_data ;
    # print (Dumper( $model)) ;

    my @raw_data = @{$model->{class}} ;
    while (@raw_data) {
        my ( $class , $data ) = splice @raw_data,0,2 ;
        $data ->{name} = $class ;
 
        # does not distinguish between notes from underlying model or snipper notes ...
        my @notes = $self->model_object->grab("class:$class")->dump_annotations_as_pod ;
        my $class_dir = $class.'.d';
        $class_dir =~ s!::!/!g;
        write_model_file ("$snippet_dir/$class_dir/$model_file", [], \@notes, [ $data ]);
    }

    $self->model_object->instance->clear_changes ;
}

sub read_model_snippet {
    my $self = shift ;
    my %args = @_ ;
    my $snippet_dir = delete $args{snippet_dir} 
      || croak __PACKAGE__," write_model_snippet: undefined snippet_dir";
    my $model_file = delete $args{model_file} 
      || croak __PACKAGE__," read_model_snippet: undefined model_file";

    croak "read_model_snippet: unexpected parameters ",join(' ', keys %args) if %args ;

    my @files ;
    my $wanted = sub { 
        my $n = $File::Find::name ;
        push @files, $n if (-f $_ and not /~$/ 
                            and $n !~ /CVS/
                            and $n !~ m!.(svn|orig|pod)$!
                            and $n =~ m!\.d/$model_file!
                           ) ;
    } ;
    find ($wanted, $snippet_dir ) ;

    my $class_element = $self->model_object->fetch_element('class') ;

    foreach my $load_file (@files) {
        $logger->info("trying to read snippet $load_file");
    
        my $snippet = do $load_file ;

        unless ($snippet) {
            if ($@) {die "couldn't parse $load_file: $@"; }
            elsif (not defined $snippet) {die  "couldn't do $load_file: $!"}
            else { die  "couldn't run $load_file" ;}
        }

        # there should be only only class in each snippet file
        foreach my $model (@$snippet) {
            my $class_name = delete $model->{name} ;
            # load with a array ref to avoid warnings about missing order
            $class_element->fetch_with_id($class_name)->load_data( $model ) ;
        }

        # load annotations
        $logger->info("loading annotations from snippet file $load_file");
        my $fh = IO::File->new($load_file) || die "Can't open $load_file: $!" ;
        my @lines = $fh->getlines ;  
        $fh->close;
        $self->model_object->load_pod_annotation(join('',@lines)) ;
    }
}


#
# New subroutine "write_model_file" extracted - Mon Mar 12 13:38:29 2012.
#
sub write_model_file {
    my $wr_file  = shift;
    my $comments = shift ;
    my $notes    = shift;
    my $data     = shift;

    my $wr_dir = dirname($wr_file);
    unless ( -d $wr_dir ) {
        mkpath( $wr_dir, 0, 0755 ) || die "Can't mkpath $wr_dir:$!";
    }

    my $wr = IO::File->new( $wr_file, '>' )
      || croak "Cannot open file $wr_file:$!" ;
    $logger->info("in $wr_file");

    my $dumper = Data::Dumper->new( [ \@$data ] );
    $dumper->Indent(1);    # avoid too deep indentation
    $dumper->Terse(1);     # allow unnamed variables in dump
    $dumper->Sortkeys(1);     # sort keys in hash

    my $dump = $dumper->Dump;

    # munge pod text embedded in values to avoid spurious pod formatting
    $dump =~ s/\n=/\n'.'=/g;

    $wr->print(@$comments) ;
    $wr->print( $dump, ";\n\n" );

    $wr->print( join( "\n", @$notes ) );

    $wr->close;

}



sub list_class_element {
    my $self = shift ;
    my $pad  =  shift || '' ;

    my $res = '';
    my $meta_class = $self->{model_object}->fetch_element('class') ;
    foreach my $class_name ($meta_class->fetch_all_indexes ) {
        $res .= $self->list_one_class_element($class_name) ;
    }
    return $res ;
}

sub list_one_class_element {
    my $self = shift ;
    my $class_name = shift || return '' ;
    my $pad  =  shift || '' ;

    my $res = $pad."Class: $class_name\n";
    my $meta_class = $self->{model_object}->fetch_element('class')
       -> fetch_with_id($class_name) ;

    my @elts = $meta_class->fetch_element('element')->fetch_all_indexes ;

    my @include = $meta_class->fetch_element('include')->fetch_all_values ;
    my $inc_after = $meta_class->grab_value('include_after') ;

    if (@include and not defined $inc_after) {
        map { $res .= $self->list_one_class_element($_,$pad.'  ') ;} @include ;
    }

    return $res unless @elts ;

    foreach my $elt_name ( @elts) {
        my $type = $meta_class->grab_value("element:$elt_name type") ;

        $res .= $pad."  - $elt_name ($type)\n";
        if (@include and defined $inc_after and $inc_after eq $elt_name) {
            map { $res .=$self->list_one_class_element($_,$pad.'  ') ;} @include ;
        }
    }
    return $res ;
}


sub get_dot_diagram {
    my $self = shift ;
    my $dot = "digraph model {\n" ;

    my $meta_class = $self->{model_object}->fetch_element('class') ;
    foreach my $class_name ($meta_class->fetch_all_indexes ) {
        my $d_class = $class_name ;
        $d_class =~ s/::/__/g;

        my $elt_list = '';
        my $use = '';

        my $class_obj =  $self->{model_object}->grab(qq!class:"$class_name"!);
        my @elts =  $class_obj ->grab(qq!element!) ->fetch_all_indexes ;
        foreach my $elt_name ( @elts ) {
            my $of = '';
            my $elt_obj = $class_obj->grab(qq!element:"$elt_name"!) ;
            my $type = $elt_obj->grab_value("type") ;
            if ($type =~ /^list|hash$/) {
                my $cargo = $elt_obj->grab("cargo");
                my $ct = $cargo->grab_value("type") ;
                $of = " of $ct" ;
                $use .= $self->scan_used_class($d_class,$elt_name,$cargo);
            }
            else {
                $use .= $self->scan_used_class($d_class,$elt_name,$elt_obj);
            }
            $elt_list .= "- $elt_name ($type$of)\\n";
        }

        $dot .= $d_class 
             .  qq! [shape=box label="$class_name\\n$elt_list"];\n!
             .  $use . "\n";

        $dot .= $self->scan_includes($class_name, $class_obj) ;
    }

    $dot .="}\n";

    return $dot ;
}

sub scan_includes {
    my ($self,$class_name, $class_obj) = @_ ;
    my $d_class = $class_name ;
    $d_class =~ s/::/__/g;

    my @includes = $class_obj->grab('include')->fetch_all_values ;
    my $dot = '';
    foreach my $c (@includes) {
        say "$class_name includes $c";
        my $t = $c;
        $t =~ s/::/__/g;
        $dot.= qq!$d_class -> $t ;\n!;
    }
    return $dot;
}

sub scan_used_class {
    my ($self,$d_class,$elt_name, $elt_obj) = @_ ;

    # define leaf call back
    my $disp_leaf = sub {
        my ($scanner, $data_ref, $node,$element_name,$index, $leaf_object) = @_ ;
        return unless $element_name eq 'config_class_name';
        my $v =  $leaf_object->fetch;
        return unless $v;
        $v =~ s/::/__/g;
        $$data_ref .= qq!$d_class -> $v !
            . qq![ style=dashed, label="$elt_name" ];\n!;
    } ;

    # simple scanner, (print all values)
    my $scan = Config::Model::ObjTreeScanner-> new (
        leaf_cb => $disp_leaf, # only mandatory parameter
    ) ;

    my $result = '' ;
    $scan->scan_node(\$result, $elt_obj) ;
    return $result ;
}

__PACKAGE__->meta->make_immutable;

1;


# ABSTRACT: Model editor for Config::Model

__END__

=pod

=encoding UTF-8

=head1 NAME

Config::Model::Itself - Model editor for Config::Model

=head1 VERSION

version 1.241

=head1 SYNOPSIS

 my $meta_model = Config::Model -> new ( ) ;

 # load Config::Model model
 my $meta_inst = $model->instance (
    root_class_name => 'Itself::Model' ,
    instance_name   => 'meta_model' ,
 );

 my $meta_root = $meta_inst -> config_root ;

 # Itself constructor returns an object to read or write the data
 # structure containing the model to be edited
 my $rw_obj = Config::Model::Itself -> new(
    model_object => $meta_root,
    model_dir => '/path/to/model_files' ,
 ) ;

 # now load the model to be edited
 $rw_obj -> read_all( ) ;

 # For Curses UI prepare a call-back to write model
 my $wr_back = sub { $rw_obj->write_all();

 # create Curses user interface
 my $dialog = Config::Model::CursesUI-> new
      (
       store => $wr_back,
      ) ;

 # start Curses dialog to edit the mode
 $dialog->start( $meta_model )  ;

 # that's it. When user quits curses interface, Curses will call
 # $wr_back sub ref to write the modified model.

=head1 DESCRIPTION

Config::Itself module and its model files provide a model of Config:Model
(hence the Itself name).

Let's step back a little to explain. Any configuration data is, in
essence, structured data. This data could be stored in an XML file. A
configuration model is a way to describe the structure and relation of
all items of a configuration data set.

This configuration model is also expressed as structured data. This
structure data is structured and follow a set of rules which are
described for humans in L<Config::Model>.

The structure and rules documented in L<Config::Model> are also
expressed in a model in the files provided with
C<Config::Model::Itself>.

Hence the possibity to verify, modify configuration data provided by
Config::Model can also be applied on configuration models. Using the
same user interface.

From a Perl point of view, Config::Model::Itself provides a class
dedicated to read and write a set of model files.

=head1 Constructor

=head2 new ( model_object => ... , model_dir => ... )

Creates a new read/write handler. This handler is dedicated to the
C<model_object> passed with the constructor. This parameter must be a
L<Config::Model::Node> class.

=head2 Methods

=head1 read_all (  root_model => ... , [ force_load => 1 ] )

Load all the model files contained in C<model_dir> and all its
subdirectories. C<root_model> is used to filter the classes read. 

Use C<force_load> if you are trying to load a model containing errors.

C<read_all> returns a hash ref containing ( class_name => file_name , ...)

=head2 write_all

Will write back configuration model in the specified directory. The
structure of the read directory is respected.

=head2 write_model_snippet( snippet_dir => foo, model_file => bar.pl )

Write snippet models in separate C<.d> directory. E.g. a snippet for class
C<Foo::Bar> will be written in C<Foo/Bar.d/bar.pl> file. This file is to be used
by L<augment_config_class|Config::Model/"augment_config_class (name => '...', class_data )">

=head2 read_model_snippet( snippet_dir => foo, model_file => bar.pl )

To read model snippets, this methid will search recursively C<$snippet_dir> and load
all C<bar.pl> files found in there.

=head2 list_class_element

Returns a string listing all the class and elements. Useful for
debugging your configuration model.

=head2 get_dot_diagram

Returns a graphviz dot file that represents the strcuture of the
configuration model:

=over

=item *

C<include> are represented by solid lines

=item *

Class usage (i.e. C<config_class_name> parameter) is represented by
dashed lines. The name of the element is attached to the dashed line.

=back

=head1 SEE ALSO

L<Config::Model>, L<Config::Model::Node>,

=head1 AUTHOR

Dominique Dumont

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2014 by Dominique Dumont.

This is free software, licensed under:

  The GNU Lesser General Public License, Version 2.1, February 1999

=cut