pax_global_header00006660000000000000000000000064147742025460014525gustar00rootroot0000000000000052 comment=139e272bbf19a8cbb6952b6c5539dfdcc01b5baa libconfig-model-itself-perl-2.025/000077500000000000000000000000001477420254600170135ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/.gitignore000066400000000000000000000006621477420254600210070ustar00rootroot00000000000000Config-Model-Itself* lib/Config/Model/models/Itself/Class.pod lib/Config/Model/models/Itself/CommonElement/Assert.pod lib/Config/Model/models/Itself/CommonElement/WarnIfMatch.pod lib/Config/Model/models/Itself/ConfigAccept.pod lib/Config/Model/models/Itself/ConfigReadWrite.pod lib/Config/Model/models/Itself/Element.pod lib/Config/Model/models/Itself/ConfigReadWrite/DefaultLayer.pod lib/Config/Model/models/Itself/WarpValue.pod wr_*libconfig-model-itself-perl-2.025/.travis.yml000066400000000000000000000004311477420254600211220ustar00rootroot00000000000000language: perl perl: - "5.24" - "5.22" - "5.20" - "5.18" - "5.16" - "5.14" install: - cpanm --quiet --notest Dist::Zilla - "dzil authordeps --missing | cpanm --notest " - "dzil listdeps --missing | cpanm --notest " script: - dzil smoke --release --author libconfig-model-itself-perl-2.025/Build.PL000066400000000000000000000037601477420254600203150ustar00rootroot00000000000000# Copyright (c) 2009-2013 Dominique Dumont. # # This file is part of Config-Model-Itself. # # Config-Model is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser Public License as # published by the Free Software Foundation; either version 2.1 of # the License, or (at your option) any later version. # # Config-Model 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 # Lesser Public License for more details. # # You should have received a copy of the GNU Lesser Public License # along with Config-Model; if not, write to the Free Software # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA # 02110-1301 USA use Module::Build; use warnings FATAL => qw(all) ; use strict ; require 5.010; # my %appli_files = map { ( $_, $_ ) } glob("lib/Config/Model/*.d/*"); # check that pod docs are up-to-date this is redundant with work done by # dzil. But this enable to re-build the docs downstream. # Use $^X in there as requested in # https://rt.cpan.org/Public/Bug/Display.html?id=74891 my $class = Module::Build->subclass( class => "Module::Build::Custom", code => <<'SUBCLASS' ); sub ACTION_build { my $self = shift; # below requires Config::Model 2.028 system ($^X, '-MConfig::Model::Utils::GenClassPod', '-e','gen_class_pod();') == 0 or die "gen-class-pod failed: $?"; $self->SUPER::ACTION_build; } SUBCLASS my $build = $class->new ( module_name => 'Config::Model::Itself', license => 'lgpl', dist_author => "Dominique Dumont (ddumont at cpan dot org)", dist_abstract => "Graphical editor of configuration models", # model_files => \%model_files , ##{ $plugin->get_prereqs ##} add_to_cleanup => [qw/wr_test wr_root/] , ); $build->add_build_element('pl'); # $build->add_build_element('appli'); $build->create_build_script; libconfig-model-itself-perl-2.025/CONTRIBUTING.md000066400000000000000000000057271477420254600212570ustar00rootroot00000000000000# How to contribute # ## Ask questions ## Yes, asking a question is a form of contribution that helps the author to improve documentation. Feel free to ask questions by sending a mail to [config-model-user mailing list](mailto:ddumont@cpan.org) ## Log a bug ## Please report issue on https://github.com/dod38fr/config-model-itself/issues ## To modify Itself model All Itself model files are located in [lib/Config/Model/models/Itself](https://github.com/dod38fr/config-model-itself/tree/master/lib/Config/Model/models/Itself). To understand the relations between the classes, please install [grapvhviz](http://graphviz.org/) and run the following commands: * `cme meta gen-dot` * `dot -Tps model.dot > model.ps` and visualize the ps file with your favorite postscript viewer (may be `okular` or `gs`): * each box contains a configuration class with its attributes * arrows represent 'include' relations * dotted arrows represent usage relations (i.e. the class is used in a node (a Config::Model::Node object) or in a warped node (a Config::Model::WarpedNode object) You can also view the models files using `cme meta edit`. But please do not save the meta configuration with this tool: this will lead to a huge diff. Note that the author is reluctant to use `cme meta edit` to edit Itself model files for fear of sawing the branch he's sitting on. ## Edit source code from github ## If you have a github account, you can clone a repo and prepare a pull-request. You can: * run `git clone https://github.com/dod38fr/config-model-itself/` * edit files * run `prove -l t` to run non-regression tests There's no need to worry about `dzil`, `Dist::Zilla` or `dist.ini` files. These are useful to prepare a new release, but not to fix bugs. ## Edit source code from Debian source package ## You can also prepare a patch using Debian source package: For instance: * download and unpack `apt-get source libconfig-model-itself-perl` * jump in `cd libconfig-model-itself-perl-2.004` * useful to create a patch later: `git init` * commit all files: `git add -A ; git commit -m"committed all"` * edit files * run `prove -l t` to run non-regression tests * run `git diff` and send the output on [config-model-user mailing list](mailto:ddumont@cpan.org) ## Edit source code from Debian source package or CPAN tarball ## Non Debian users can also prepare a patch using CPAN tarball: * Download tar file from http://search.cpan.org * unpack tar file with something like `tar axvf Config-Model-Itself-2.004.tar.gz` * jump in `cd Config-Model-Itself-2.004` * useful to create a patch later: `git init` * commit all files: `git add -A ; git commit -m"committed all"` * edit files * run `prove -l t` to run non-regression tests * run `git diff` and send the output on [config-model-user mailing list](mailto:ddumont@cpan.org) ## Provide feedback ## Feedback is important. Please take a moment to rate, comment or add stars to this project: * [config-model-itself github](https://github.com/dod38fr/config-model-itself) libconfig-model-itself-perl-2.025/Changes000066400000000000000000000504571477420254600203210ustar00rootroot00000000000000{{$NEXT}} 2.025 2025-04-05 Misc: * require Path::Tiny 0.125 2.024 2025-04-04 Bug fix: * avoid warnings related to utf-8 * fix calls to Path::Tiny mkpath (Closes Debian #1101994) Misc: * docs: remove links to cpanratings * tests: check stderr and error of test_app results * bump version dep on Tk 1.378 * use YAML::PP instead of YAML::XS * do not ship test files in wr_root 2.023 2022-01-07 Model update: * add use_backend_argument_as_config_file parameter in Application Bug fix: * delete files of deleted models Misc: * itself test requires Config::Model 2.142 2.022 2021-01-21 Model update: * feature (Class model): add IniFile quote_value parameter (require Config::Model 2.141) 2.021 2021-01-13 A new 2.021 release for 2021 :-) Bug fix: * fix error message when attaching Config class to unknown Perl class * update rw_config file documentation in model * remove files of deleted application when writing back a model 2.020 2019-12-29 Dependencies: * requires perl 5.014 2.019 2019-12-27 Test fixes: * Fix tests when using system libraries (Debian #935453) * fix tests broken by Config::Model 2.137 (Debian #946730) Dependencies: * Tests now require Config::Model 2.138 2.018 2019-05-27 Bug fix: * Fix usage of Config::Model::TkUI. This fixes the non-regression tests that break with new TkUI. (require Config::Model::TkUI 1.370) 2.017 2019-05-26 Improve the way models files are written: * use YAML::XS instead of YAML::Tiny * write "use strict;" abd "use warnings;" in model files Deprecation update: * use get_model_clone instead of get_model (require Config::Model 2.134) Test changes: * setup perlcritic tests (require Perl 5.012) Doc updates: * add cme meta dump-yaml example in pod doc * Fix typo in model doc (Tx gregoa) * add credit section 2.016 2018-12-17 Test fixes: * use IniFile backend instead of Yaml 2.015 2018-12-15 Model updates: * integer value can use warn_if warn_unless assert * model doc: help on value now accepts patterns (requires Config::Model 2.127) Bug fixes: * better handle application parameter (i.e. fix "cme meta plugin" command) * test: copy models from "use" location (this makes Debian "autopkgtest" patch obsolete) 2.014 2018-07-15 * backend function parameter is deprecated * improve inline doc on refer_to parameter * add gist in ConfigRead and ConfigWrite * remove deprecated read_config and write_config backend parameters 2.013 2017-11-19 New feature: * add Node gist parameter (req Config::Model 2.114) 2.012 2017-09-24 The release deals with the modifications done with backend parameter done starting from Config::Model 2.109: * read_config is deprecated for rw_config * migrate old backend spec to new rw_config * allow warn_if_match and similar for enum * require Config::Model 2.111 * custom backend is deprecated Other modification done for older deprecations: * remove obsolete allow_empty parameter * remove obsolete "syntax" backend parameter 2.011 2017-06-10 New features: * application model: add backend_argument Bug fixes: * meta cmd: add -dev option which was removed from the global options of cme * Fix a bug in model plugin write that was revealed by a bug fix in Config::Model 2.104 * improve doc of "choice" and "computed_refer_to" parameters * fix "yaml_class" parameter so that it shows up in GUI when backend is set to "yaml" 2.010 2017-05-14 New features: * add yaml_class parameter to yaml backend Model bug fixes: * app category is mandatory Bug fixes to avoid relying on '.' in @INC: * Itself.pm: call model->load with absolute path * use Path::Tiny in test * fix itself.t and itself-editor.t tests 2.009 2017-04-29 New features: * add assign_char and assign_with parameter * add support for hash write_empty_value option Build: * requires Config::Model >= 2.101 2.008 2017-03-11 New features: * add support_info in application model. Used by Comfig::Model 2.100 to inform user how to report a bug when a parameter is missing from a model 2.007 2017-03-05 New features: * add file_mode parameter to backend model * Allow plugin injection in other class (depends on Config::Model 2.098) * add synopsis and link_to_doc parameter to the model class that represent application Build: * update © years * requires Path::Tiny >= 0.062 Bug fixes: * cme meta: don't read plugin when loading model.. * remove obsolete config-model-edit command Doc updates: * show all commands in meta's description * update compute value doc in model * mention &index in backend file parameter * update INI comment_delimiter doc 2.006 2016-09-14 Bug fix following removal of '.' from @INC * fix load of model snippet when '.' is not in @INC (Closes Debian #837682) * requires Config::Model 2.091 2.005 2016-07-03 Made change to fix tests brought by the changes done in Config::Model::WarpedNode parameters: * depends on Config::Model 2.087 * fix deprecated warped_node params in Itself model * fix model for new WarpedNode Other changes: * removed long deprecated 'experience' parameter * added CONTRIBUTING.md file 2.004 2016-04-21 New features: * added auto_delete parameter for read/write backend this requires Config::Model 2.083 Doc updates in model: * updated Class doc * added help for value_type Bug fixes: * detect backend in local dev environment. 2.003 2016-01-27 New features: * added config_dir parameter to application * Replace ini_file backend with IniFile * Added split/join checklist param to ini backend (requires Config::Model 2.076) Improved usability: * simplified creation of Itself object. * Build.PL: avoid dependency on cme to generate doc Bug fixes: * Config classes created with 'cme meta edit' are now saved * meta: warn if save failed in test_and_quit mode * Avoid a crash creating a config class * fix test failure under debian ci (helps with Debian #809294 and fix github #1) 2.002 2015-12-02 Test enhancements: * Skip cme-meta tests involing Tk when a display is not available. 2.001 2015-11-29 Major feature enhancement: This modules provides a new sub command for cme: the "meta" sub command. By default "cme meta edit" opens a graphical editor and loads the model found in current directory. "cme meta" also provides sub commands to check a model or to create a dot diagram showing a model structure. "cme meta" comes with bash completion. See App::Cme::Command::meta for more details. Other changes: + new App::Cmd dependency * requires Config::Model 2.075 * config-model-edit is now deprecated in favor of "cme meta edit" * updated README in changed it to README.md * "cme edit" now support app files (e.g. files in lib/Config/Model/*.d ) 1.245 2015-07-19 Bug fixes in config-model-edit: * fix saving of model done before launching test from menu * fix creation of model directory done when starting a model from scratch Doc fix: * small synopsis fix in doc of Config::Model::Itself 1.244 2015-05-23 A minor new feature: * Class model: added include_backend parameter (for Xorg...) 1.243 2015-01-11 A small change for this release: * Version 1.242 added the possibility to override the Perl class implementing a configuration node by adding a class parameter in a place that is confusing. This release fix this bug: this optional override class is now declared at the top of a configuration class. * Depends on Config::Model 2.064 1.242 2014-11-29 New feature: * Allow 'class' parameter for node, hash and list. This parameter can be used to override the Perl class used to implement node, hash or list element. Use with care. Bug fix: * replaced dep declaration YAML::any with YAML::Tiny 1.241 2014-10-22 * config-model-edit: + added system option to read a model from system files * fix yaml and load_yaml options * fix dump and dumptype options * fixed dot diagram generator (i.e. -dot-diagram option) * dependency change: use YAML::Tiny instead of YAML::Any * leaf value model: + added file and dir and warn_if properties 1.240 2014-05-22 Main change is the deprecation of the experience attribute. config-model-edit can be used to clean up experience parameter from existing model. Dependency changes: * removed usage of AnyEvent (requires C::M 2.055) * removed use namespace::autoclean * config-model-edit: use Path::Tiny instead of Path::Class Other changes: * min and max parameters accept number. * removed obsolete permission attribute from test models (which broke test with C::M >= 2.056) * preserve header comments when reading/writing model files * config-model-edit begins with "#!/usr/bin/env perl" 2013-08-27 - 1.239 * Itself writer: ensure that hash data in models snippets have a predictable order (fix tests for perl 5.18) 2013-08-25 - 1.238 * Added default_layer backend parameter with DefaultLayer class. This enable user to create a model with a global system configuration file à la /etc/ssh/ssh_config. This requires Config::Model 2.039 1.237 2013-04-19 * Replaced Any::Moose with Mouse * backend detector: do not list twice the same backend * Removed augeas from model and tests. Augeas meta-model is now delivered with Config::Model::Backend::Augeas 1.236 2013-03-23 * Itself: use named parameters with load_data to avoid warnings * Depends on Config::Model >= 2.030 * delegate Tk init to AnyEvent to avoid blocking at program exit + Depends on AnyEvent 1.235 2012-11-27 * Fix quit bug in model test widget * integrate model pod generation at build time * Added memory cycle tests where possible * Bump dependency on Config::Model 2.028 to generate properly the documentation for Itself model (which may be should be called C::M::MyOwnDogFood... ) 1.234 2012-06-19 * Fix test that relied on Dpkg model (which used to be provided by Config::Model) 1.232 2012-06-19 * model Itself::Class: added accept_after (requires Config::Model 2.020) * config-model-edit: make sure that loading models are not recorded as changed data 1.231 2012-05-22 * added migrate_values_from (requires Config::Model 2.015) * migrate_keys_from cannot be warped (too complicated to mix warp and migration) 1.230 2012-05-04 * Itself reader/writer: added force_write attribute 1.229 2012-04-14 + new runtime dependency: Data::Compare, Path::Class + new test dependency: File::Copy::Recursive * Depends on Config::Model 2.009 * config-model-edit: + new option -plugin-file option. This option can be used to create model plugins: small modification of an existing model that can be distributed in a separate file or package. * removed capacity to read models from systems files if the model is not found locally. This behavior does not work well with model plugins. This command can no longer read from one dir and write to another for the same reason. - removed obsolete option (-verbose -debug). These are now replaced by the Log::Log4Perl framework * replaced '_' by '-' in options names. Old options are still accepted but are not documented * Itself model: added use_as_upstream_default parameter * Itself backend: do not write empty model file 1.228 2011-11-29 * Requires Config::Model >= 1.263 * Meta model changes: * Itself/CommonElement: enable convert for hash indexes. * Itself/Class, added in ini backend a lot of paramaters to cope with various conventions: + force_lc_* parameters. + write_boolean_as parameter + join_list_value parameter + store_class_in_hash section_map split_list_value * Itself/CommonElement: max_index can be used in lists * Itself/NonWarpableElement: + added write_as parameter (for booleans) 1.227 2011-09-15 * MigratedValue.pl: replaced value can be a string, not only a uniline * CommonElement.pl: added assert and warn_unless parameters (requires Config::Model 1.258) 1.226 2011-09-02 * WarpableElement.pl: added duplicates parameter * Depends on Config::Model 1.252 1.225 2011-06-07 * Itself.pm: munge pod text embedded in description to avoid spurious pod formatting in model files * WarpableElement.pl: allow default_with_init for list (like hash) * MigratedValue.pl: updated undef_is doc: use '' to have an empty string * CommonElement.pl: warn parameter is a string and not a uniline - Class.pl: name_match parameter is deprecated. 1.224 2011-04-04 * Class.pl: added full_dump parameter for YAML and Perl backend 1.223 2011-04-01 * dump and load annotations in pod doc in config class file * Class.pl: added copyright, author, license elements * Search backend in all @INC directories (useful for dev) * Reduced indentation of generated Perl files. * NonWarpableElement: added replace_follow parameter * Build depend on Test::Differences * Requires Config::Model 1.236 1.222 2011-01-20 * added migrate_keys_from, undef_is parameters * Above require Config::Model 1.230 1.221 2011-01-09 * Remove unwanted test package file (oops) 1.220 2011-01-09 * config-model-edit: use same log4perl config files as config-edit * CommonElement: added warn* parameters (require Config::Model 1.228) * Fix class deletion issue * Adapted model and test to new style of accept specification 1.219 2010-10-15 * removed obsolete push/pop_no_value_check calls * requires Config::Model 1.212 1.218 2010-09-16 * Fixed missing dependencies in Build.PL (Building from hg requires Dist::Zilla and Dist-Zilla-Plugins-CJM >= 3.01) 1.217 2010-09-14 * Added allow_keys_matching parameter in ItselfWarpableElement.pl (requires Config::Model 1.207) * config-model-edit :doc fix * Itself.pm: display hash or list cargo type in dot diagram" * BackendDetector.pm: Fixed to handle backend names with embedded :: (e.g. Debian::Dep5) 1.216 2010-08-13 * Added accept parameter in Itself/Class.pl (requires Config::Model 1.206) * Build.PL: added dependency on Tk to avoid CPAN smoke test failure 1.215 2010-04-06 * t/itself.t: Fix skip part to avoid failures when X is not available. 1.214 2010-03-31 * config-model-edit (): ensure that model modified by loading data or YAML is saved later on by the GUI. 1.213 2010-03-25 * lib/Config/Model/Itself/BackendDetector.pm (): New class derived from Config::Model::Value so config-model-edit can detect available read/write plugin backend and propose relevant choice for 'backend' model specification. * Build.PL: Added dedendency on Pod::POM, depends on Config::Model 1.001 * lib/Config/Model/models/Itself/CommonElement.pl: add match parameter from Config::Model 1.001 * config-model-edit (): can use -force_load when loading data or yaml data. * Build.PL: depends on YAML::Any 1.212 2010-02-26 * Build.PL: depends on Config::Model 0.643 * config-model-edit: added load_yaml option to load model from a YAML file. * config-model-edit: added dump_yaml option to dump models as YAML file. * config-model-edit: added -dump -dump_type -load options. Non options args are now interpreted as model modifications * lib/Config/Model/models/Itself/CommonElement.pl: warp out min and max 1.211 2009-06-24 * Build.PL: depend on Config::Model 0.637 and C::M::TkUI 1.210 * lib/Config/Model/models/Itself/*.pl: Changed built_in parameter to upstream_default and built_in_list to upstream_default_list * config-model-edit: added -save option. * lib/Config/Model/models/Itself/Class.pl: Changed config_file parameter to file (Req by Config::Model 0.636) 1.210 2009-04-20 * config-model-edit: Fixed Log::Log4perl default configuration * lib/Config/Model/models/Itself/Class.pl: Added auto_create and file parameter to read/write spec (Req by Config::Model 0.635). Parameter allow_empty is deprecated and will be replaced by auto_create when you run config-edit-model * config-model-edit: new -dot_diagram option to get a dot file to reprensent the structure of the configuration model * lib/Config/Model/Iself.pm (get_dot_diagram): New method to draw a diagram of the configuration class with "include" and usage (e.g. with "config_class_name" parameter). * lib/Config/Model/models/Itself/Element.pl: index_type is now mandatory for hash types * lib/Config/Model/models/Itself/Element.pl: Added summary model parameter (Config::Model 0.635) * lib/Config/Model/models/Itself/CommonElement.pl: 'choice' is also available for 'reference' values 1.209 2009-03-10 * t/*.t: Backported mkpath calls to File::Path delivered by perl 5.8.8 * lib/Config/Model/models/Itself/WarpableElement.pl: changed auto_create in auto_create_keys and auto_create_ids (required by Config::Model 0.634) 1.208 2009-01-09 * lib/Config/Model/models/Itself/Class.pl: Added allow_empty parameter. Minor corrections related to Augeas integration. 1.207 2008-10-14 * lib/Config/Model/models/Itself/CommonElement.pl: Added ordered parameter to checklist. Ordered checklist feature is required by Ssh model for Ciphers list (see Config::Model::OpenSsh). * Build.PL: Extract version from Config/Model/Itself.pm (hence the bump to v 1.207) so that the pm file versions matches the .tgz distribution version. 0.206 2008-09-23 * lib/Config/Model/models/Itself/Class.pl: Added seq_with_lens parameter for Augeas backend. * lib/Config/Model/models/Itself/Class.pl: Bug fix on Augeas parameters 0.205 2008-07-25 * lib/Config/Model/models/Itself/Class.pl: Fixed specification of Augeas parameters 0.204 2008-07-25 * lib/Config/Model/models/Itself/*.pl: All the changes described below will be handled by the upgrade facility of Config::Model. I.e. to upgrade your configuration model, load your model in config-model-edit, save it, and you're done. Changes: - Changed auto read and auto write meta-model (needed by Config::Model 0.624). - autoread autowrite 'syntax' parameter is replaced by 'backend'. - Added auto-read/write 'augeas' backend. - Added migrate_from in Class so that your own model will be able to smoothly upgrade configuration data (See upgrade doc in Config::Model::Value) - Added use_eval for more complex string computation when the power of Perl is needed (See Config::Model::ComputedValue documentation) 0.203 2008-05-21 * config-model-edit: Fixed bug that prevented testing of the configuration editor when starting from scratch. 0.202 2008-05-18 * lib/Config/Model/models/Itself/CommonElement.pl: Added support for built in default list for check_list elements * config-model-edit: Will now always launch Tk interface which has a menu to test the configuration editor from the model under edition. (some tests still to be written) * lib/Config/Model/Itself.pm (list_class_element): new method to help model debug * lib/Config/Model/Itself.pm (read_all): Reworked model to fit with new cargo arguments. * tests: suppress legacy warnings 0.201 2008-04-03 * lib/Config/Model/models/Itself/Element.pl: Fixed element and cargo models. * lib/Config/Model/models/Itself/WarpableElement.pl: added description for 'replace' element * lib/Config/Model/models/Itself/WarpableElement.pl: removed enum_integer type * config-model-edit: Clarified where models are read and written. 0.102 2008-03-18 * config-model-edit: Now use Config::Model::TkUI instead of Config::Model::TkUi * lib/Config/Model/Itself.pm (read_all): Skip svn directory when reading model files * lib/Config/Model/Itself.pm (write_all): can now write configuration class created with the editor. Each class created will be saved in its own file. I.e. configuration class Foo::Bar will be saved in Foo/Bar.pl * config-model-edit: added possibity to use Tk interface. * lib/Config/Model/models/Itself/WarpableElement.pl: added 'replace' parameter 0.101 2007-10-16 * All: first version libconfig-model-itself-perl-2.025/MANIFEST.SKIP000066400000000000000000000012701477420254600207110ustar00rootroot00000000000000# Avoid version control files. \bRCS\b \bCVS\b ,v$ \B\.svn\b \B\.cvsignore$ # Avoid Makemaker generated and utility files. \bMakefile$ \bblib \bMakeMaker-\d \bpm_to_blib$ \bblibdirs$ ^MANIFEST\.SKIP$ # Avoid Module::Build generated and utility files. \bBuild$ \bBuild.bat$ \b_build # Avoid Devel::Cover generated files \bcover_db # Avoid temp and backup files. ~$ \.tmp$ \.old$ \.bak$ \#$ \.# \.rej$ \.orig$ # Avoid OS-specific files/dirs # Mac OSX metadata \B\.DS_Store # Mac OSX SMB mount metadata files \B\._ # Avoid archives of this distribution \bConfig-Model-Itself-[\d\.\_]+ ^MYMETA.yml$ # avoid debian packages ^debian dist.ini libconfig* # avoid tests results wr_test wr_root libconfig-model-itself-perl-2.025/README-build-from-git.md000066400000000000000000000032121477420254600231070ustar00rootroot00000000000000# How to build Config::Model::Itself from git repository `Config::Model::Itself` is build with [Dist::Zilla](http://dzil.org/). This page details how to install the tools and dependencies required to build this module. ## Install tools and dependencies ### Debian, Ubuntu and derivatives Run $ sudo apt install libdist-zilla-perl libdist-zilla-app-command-authordebs-perl $ dzil authordebs --install $ sudo apt build-dep libconfig-model-itself-perl The [libdist-zilla-app-command-authordebs-perl package](https://tracker.debian.org/pkg/libdist-zilla-app-command-authordebs-perl) is quite recent (uploaded on Dec 2016 in Debian/unstable) and may not be available yet on your favorite distribution. ### Other systems Run $ cpamn Dist::Zilla $ dzil authordeps -missing | cpanm --notest $ dzil listdeps --missing | cpanm --notest NB: The author would welcome pull requests that explains how to install these tools and dependencies using native package of other distributions. ## Build Config::Model::Itself Run dzil build or dzil test `dzil` may complain about missing `EmailNotify` or `Twitter` plugin. You may ignore this or edit [dist.ini](dist.ini) to comment out the last 2 sections. These are useful only to the author when releasing a new version. `dzil` may also return an error like `Cannot determine local time zone`. In this case, you should specify explicitely your timezone in a `TZ` environement variable. E.g run `dzil` this way: TZ="Europe/Paris" dzil test The list of possible timezones is provided by [DateTime::TimeZone::Catalog](https://metacpan.org/pod/DateTime::TimeZone::Catalog) documentation. libconfig-model-itself-perl-2.025/README.md000066400000000000000000000054421477420254600202770ustar00rootroot00000000000000 [![](https://travis-ci.org/dod38fr/config-model-itself.svg?branch=master)](https://travis-ci.org/dod38fr/config-model-itself) ## What is Config::Model::Itself ## Config::Model::Itself provides a graphical editor to edit configuration model for Config::Model. This modules also provides a model for Config::Model (hence the Itself name, you can also think of it as a meta-model). The editor will use this meta-model to construct the graphical interface so you can edit the configuration model for *your* application. [ This module is the "eat your own dog food" principle applied to Config::Model ;-) ] 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 Config::Model. The structure and rules documented in Config::Model are also expressed in a model in the files provided with 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. ## How to run the editor ## The model editor is launched by `cme meta edit` Since the model editor and the configuration data editor are based on the same graphical module, you will use similar UIs to edit configuration data (for instance [OpenSsh](http://search.cpan.org/dist/Config-Model-OpenSsh/) configuration data from sshd_config) and OpenSsh model (if you need to add new parameters in OpenSsh model) Once this module is installed, you can run `cme meta edit` in an empty directory to create you own model. You can also start from an existing model. Clone from github a model (like [config-model-openssh](https://github.com/dod38fr/config-model-openssh)), jump in the cloned directory and run `cme meta edit` You can also peek in an installed model. For instance, if you have installed Config::Model::OpenSsh, you can run cme meta edit sshd -system Note that "save" menu will save the model in current directory. For more details, see: * [cme](http://search.cpan.org/dist/App-Cme/bin/cme) * [App::Cme::Command::meta](http://search.cpan.org/dist/Config-Model-Itself/lib/App/Command/Cme/meta.pod) * [model creation](http://search.cpan.org/dist/Config-Model/lib/Config/Model/Manual/ModelCreationIntroduction.pod) ## Installation On debian/ubuntu: apt-get install cme libconfig-model-itself-perl libconfig-model-tkui-perl Otherwise: cpanm Config::Model::Itself cpanm App::Cme cpanm Config::Model::TkUI ## Build from git See [build from git instructions](README-build-from-git.md) libconfig-model-itself-perl-2.025/contrib/000077500000000000000000000000001477420254600204535ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/contrib/bash_completion.cme_meta000066400000000000000000000023341477420254600253170ustar00rootroot00000000000000# cme(1) completion -*- shell-script -*- # # # This file is part of Config::Model::Itself # # This software is Copyright (c) 2015 by Dominique Dumont # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # _cme_cmd_meta() { local cur COMPREPLY=() _get_comp_words_by_ref -n : cur prev global_options='-dev -force-load -create -backend -trace -quiet -file' if [[ $COMP_CWORD -eq 2 ]] ; then COMPREPLY=( $( compgen -W 'edit check save plugin dump dump-yaml gen-dot' -- $cur ) ) elif [[ $COMP_CWORD -eq 3 ]] ; then MODELS=$(/usr/bin/perl -MConfig::Model::Lister -e'print Config::Model::Lister::applications(1);') COMPREPLY=( $( compgen -W "$MODELS" -- $cur ) ) elif [[ $COMP_CWORD -eq 4 ]] ; then OPTIONS='-dir -dumptype -open-item -plugin-file -load-yaml -load -system' COMPREPLY=( $( compgen -W "$OPTIONS" -- $cur ) ) else case $prev in -dir|-open-item|-plugin-file|-load-yaml|-load) _filedir -d ;; -dumptype) COMPREPLY=( $( compgen -W 'full preset custom' -- $cur ) ) ;; *) esac fi true; } libconfig-model-itself-perl-2.025/data/000077500000000000000000000000001477420254600177245ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/data/application.d/000077500000000000000000000000001477420254600224515ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/data/application.d/goner000066400000000000000000000000631477420254600235050ustar00rootroot00000000000000model = MasterModel allow_config_file_override = 1 libconfig-model-itself-perl-2.025/data/application.d/master000066400000000000000000000000631477420254600236660ustar00rootroot00000000000000model = MasterModel allow_config_file_override = 1 libconfig-model-itself-perl-2.025/data/models/000077500000000000000000000000001477420254600212075ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/data/models/MasterModel.pl000066400000000000000000000322721477420254600237660ustar00rootroot00000000000000# -*- cperl -*- # this file is used by test script use strict; use warnings; return [ [ name => 'MasterModel::SubSlave2', element => [ [qw/aa2 ab2 ac2 ad2 Z/] => { type => 'leaf', value_type => 'string' } ] ], [ name => 'MasterModel::SubSlave', element => [ [qw/aa ab ac ad/] => { type => 'leaf', value_type => 'string' }, sub_slave => { type => 'node', config_class_name => 'MasterModel::SubSlave2', } ] ], [ name => 'MasterModel::SlaveZ', element => [ [qw/Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, [qw/DX/] => { type => 'leaf', value_type => 'enum', default => 'Dv', choice => [qw/Av Bv Cv Dv/] }, ], include => 'MasterModel::X_base_class', ], [ name => 'MasterModel::SlaveY', element => [ std_id => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'MasterModel::SlaveZ', }, sub_slave => { type => 'node', config_class_name => 'MasterModel::SubSlave', }, warp2 => { type => 'warped_node', config_class_name => 'MasterModel::SubSlave', morph => 1, warp => { follow => '! tree_macro', rules => [ mXY => { config_class_name => 'MasterModel::SubSlave2' }, XZ => { config_class_name => 'MasterModel::SubSlave2' } ] } }, Y => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ], include => 'MasterModel::X_base_class', ], [ name => 'MasterModel::TolerantNode', accept => [ 'list.*' => { type => 'list', cargo => { type => 'leaf', value_type => 'string', }, }, 'str.*' => { type => 'leaf', value_type => 'uniline' }, #TODO: Some advanced structures, hashes, etc. ], element => [ id => { type => 'leaf', value_type => 'uniline', }, ] ], [ name => 'MasterModel', class_description => "Master description", level => [ [qw/hash_a tree_macro int_v/] => 'important' ], read_config => { backend => 'cds_file', config_dir => 'conf_data', auto_create => 1, }, write_config => [{ backend => 'cds_file', config_dir => 'conf_data', file => 'mymaster.cds', }], element => [ std_id => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'MasterModel::SlaveZ', }, integer_with_warn_if => { type => 'leaf', value_type => 'integer', warn_if => { warn_test => { code => 'defined $_ && $_ < 9;', msg => 'should be greater than 9', fix => '$_ = 10;' } }, }, [qw/lista listb/] => { type => 'list', cargo_type => 'leaf', cargo_args => { value_type => 'string' }, }, [qw/ac_list/] => { type => 'list', cargo_type => 'leaf', auto_create_ids => 3, cargo_args => { value_type => 'string' }, }, "list_XLeds" => { type => 'list', cargo_type => 'leaf', cargo_args => { value_type => 'integer', min => 1, max => 3 }, }, [qw/hash_a hash_b/] => { type => 'hash', index_type => 'string', cargo_type => 'leaf', cargo_args => { value_type => 'string' }, }, olist => { type => 'list', cargo_type => 'node', config_class_name => 'MasterModel::SlaveZ', }, tree_macro => { type => 'leaf', value_type => 'enum', choice => [qw/XY XZ mXY/], summary => 'macro parameter for tree', help => { XY => 'XY help', XZ => 'XZ help', mXY => 'mXY help', } }, warp_el => { type => 'warped_node', config_class_name => 'MasterModel::SlaveY', morph => 1, warp => { follow => '! tree_macro', rules => [ #XY => { config_class_name => 'MasterModel::SlaveY'}, mXY => { config_class_name => 'MasterModel::SlaveY' }, XZ => { config_class_name => 'MasterModel::SlaveZ' } ] } }, 'tolerant_node' => { type => 'node', config_class_name => 'MasterModel::TolerantNode', }, 'slave_y' => { type => 'node', config_class_name => 'MasterModel::SlaveY', }, string_with_def => { type => 'leaf', value_type => 'string', default => 'yada yada' }, a_string => { type => 'leaf', mandatory => 1, value_type => 'string' }, int_v => { type => 'leaf', value_type => 'integer', default => '10', min => 5, max => 15 }, my_check_list => { type => 'check_list', refer_to => '- hash_a + ! hash_b', }, 'ordered_checklist' => { type => 'check_list', choice => [ 'A' .. 'Z' ], ordered => 1, help => { A => 'A help', E => 'E help' }, }, my_reference => { type => 'leaf', value_type => 'reference', refer_to => '- hash_a + ! hash_b', }, lot_of_checklist => { type => 'node', config_class_name => 'MasterModel::CheckListExamples', }, warped_values => { type => 'node', config_class_name => 'MasterModel::WarpedValues', }, warped_id => { type => 'node', config_class_name => 'MasterModel::WarpedId', }, hash_id_of_values => { type => 'node', config_class_name => 'MasterModel::HashIdOfValues', }, 'deprecated_p' => { type => 'leaf', value_type => 'enum', choice => [qw/cds perl ini custom/], status => 'deprecated', description => 'deprecated_p is replaced by new_from_deprecated', }, 'new_from_deprecated' => { type => 'leaf', value_type => 'enum', choice => [qw/cds_file perl_file ini_file custom/], migrate_from => { formula => '$replace{$old}', variables => { old => '- deprecated_p' }, replace => { perl => 'perl_file', ini => 'ini_file', cds => 'cds_file', }, }, }, 'old_url' => { type => 'leaf', value_type => 'uniline', status => 'deprecated', }, 'host' => { type => 'leaf', value_type => 'uniline', migrate_from => { formula => '$old =~ m!http://([\w\.]+)!; $1 ;', variables => { old => '- old_url' }, use_eval => 1, }, }, 'reference_stuff' => { type => 'node', config_class_name => 'MasterModel::References', }, match => { type => 'leaf', value_type => 'string', match => '^foo\d{2}$', }, prd_match => { type => 'leaf', value_type => 'string', grammar => q!token (oper token)(s?) oper: 'and' | 'or' token: 'Apache' | 'CC-BY' | 'Perl' !, }, warn_if => { type => 'leaf', value_type => 'string', warn_if_match => { 'foo' => { fix => '$_ = uc;' } }, }, warn_unless => { type => 'leaf', value_type => 'string', warn_unless_match => { foo => { msg => '', fix => '$_ = "foo".$_;' } }, }, list_with_migrate_values_from => { type => 'list', cargo => { type => 'leaf', value_type => 'string' }, migrate_values_from => '- lista', }, hash_with_migrate_keys_from => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string' }, migrate_keys_from => '- hash_a', }, assert_leaf => { type => 'leaf', value_type => 'string', assert => { assert_test => { code => 'defined $_ and /\w/', msg => 'must not be empty', fix => '$_ = "foobar";' } }, }, leaf_with_warn_unless => { type => 'leaf', value_type => 'string', warn_unless => { warn_test => { code => 'defined $_ and /\w/', msg => 'should not be empty', fix => '$_ = "foobar";' } }, }, 'Source' => { 'value_type' => 'string', 'migrate_from' => { 'use_eval' => '1', 'formula' => '$old || $older ;', undef_is => "''", 'variables' => { 'older' => '- Original-Source-Location', 'old' => '- Upstream-Source' } }, 'type' => 'leaf', }, [qw/Upstream-Source Original-Source-Location/] => { 'value_type' => 'string', 'status' => 'deprecated', 'type' => 'leaf' }, ( map { ( "list_with_" . $_ . "_duplicates" => { type => 'list', duplicates => $_, cargo => { type => 'leaf', value_type => 'string' } }, ); } qw/warn allow forbid suppress/ ), ], description => [ tree_macro => 'controls behavior of other elements' ], author => "dod\@foo.com", copyright => "2011 dod", license => "LGPL", ], ]; # do not put 1; at the end or Model-> load will not work libconfig-model-itself-perl-2.025/data/models/MasterModel/000077500000000000000000000000001477420254600234235ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/data/models/MasterModel/CheckListExamples.pl000066400000000000000000000045061477420254600273350ustar00rootroot00000000000000use strict; use warnings; return [ [ name => "MasterModel::CheckListExamples", element => [ [qw/my_hash my_hash2 my_hash3/] => { type => 'hash', index_type => 'string', cargo_type => 'leaf', cargo_args => { value_type => 'string' }, }, choice_list => { type => 'check_list', choice => [ 'A' .. 'Z' ], help => { A => 'A help', E => 'E help' }, }, choice_list_with_default => { type => 'check_list', choice => [ 'A' .. 'Z' ], default_list => [ 'A', 'D' ], help => { A => 'A help', E => 'E help' }, }, choice_list_with_upstream_default_list => { type => 'check_list', choice => [ 'A' .. 'Z' ], upstream_default_list => [ 'A', 'D' ], help => { A => 'A help', E => 'E help' }, }, macro => { type => 'leaf', value_type => 'enum', choice => [qw/AD AH/], }, 'warped_choice_list' => { type => 'check_list', warp => { follow => '- macro', rules => { AD => { choice => [ 'A' .. 'D' ], default_list => [ 'A', 'B' ] }, AH => { choice => [ 'A' .. 'H' ] }, } } }, refer_to_list => { type => 'check_list', refer_to => '- my_hash' }, refer_to_2_list => { type => 'check_list', refer_to => '- my_hash + - my_hash2 + - my_hash3' }, refer_to_check_list_and_choice => { type => 'check_list', refer_to => [ '- refer_to_2_list + - $var', var => '- indirection ', ], choice => [qw/A1 A2 A3/], }, indirection => { type => 'leaf', value_type => 'string' }, ] ] ]; libconfig-model-itself-perl-2.025/data/models/MasterModel/HashIdOfValues.pl000066400000000000000000000042711477420254600265710ustar00rootroot00000000000000use strict; use warnings; my @element = ( # Value constructor args are passed in their specific array ref cargo_type => 'leaf', cargo_args => { value_type => 'string' }, ); return [ [ name => "MasterModel::HashIdOfValues", element => [ plain_hash => { type => 'hash', # hash_class constructor args are all keys of this hash # except type and class index_type => 'integer', @element }, hash_with_auto_created_id => { type => 'hash', index_type => 'string', auto_create => 'yada', @element }, hash_with_several_auto_created_id => { type => 'hash', index_type => 'string', auto_create => [qw/x y z/], @element }, [qw/hash_with_default_id hash_with_default_id_2/] => { type => 'hash', index_type => 'string', default => 'yada', @element }, hash_with_several_default_keys => { type => 'hash', index_type => 'string', default => [qw/x y z/], @element }, hash_follower => { type => 'hash', index_type => 'string', @element, follow_keys_from => '- hash_with_several_auto_created_id', }, hash_with_allow => { type => 'hash', index_type => 'string', @element, allow_keys => [qw/foo bar baz/], }, hash_with_allow_from => { type => 'hash', index_type => 'string', @element, allow_keys_from => '- hash_with_several_auto_created_id', }, ordered_hash => { type => 'hash', index_type => 'string', @element, ordered => 1, }, ], ] ]; libconfig-model-itself-perl-2.025/data/models/MasterModel/References.pl000066400000000000000000000055611477420254600260500ustar00rootroot00000000000000use strict; use warnings; return [ [ name => 'MasterModel::References::Host', 'element' => [ if => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'MasterModel::References::If', }, trap => { type => 'leaf', value_type => 'string' } ] ], [ name => 'MasterModel::References::If', element => [ ip => { type => 'leaf', value_type => 'string' } ] ], [ name => 'MasterModel::References::Lan', element => [ node => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'MasterModel::References::Node', }, ] ], [ name => 'MasterModel::References::Node', element => [ host => { type => 'leaf', value_type => 'reference', refer_to => '- host' }, if => { type => 'leaf', value_type => 'reference', refer_to => [ ' - host:$h if ', h => '- host' ] }, ip => { type => 'leaf', value_type => 'string', compute => [ '$ip', ip => '- host:$h if:$card ip', h => '- host', card => '- if' ] } ] ], [ name => 'MasterModel::References', element => [ host => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'MasterModel::References::Host' }, lan => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'MasterModel::References::Lan' }, host_and_choice => { type => 'leaf', value_type => 'reference', refer_to => ['- host '], choice => [qw/foo bar/] }, dumb_list => { type => 'list', cargo_type => 'leaf', cargo_args => { value_type => 'string' } }, refer_to_list_enum => { type => 'leaf', value_type => 'reference', refer_to => '- dumb_list', }, ] ] ]; libconfig-model-itself-perl-2.025/data/models/MasterModel/ToTrash.pl000066400000000000000000000006221477420254600253440ustar00rootroot00000000000000use strict; use warnings; # This class is trashed during tests return [ [ name => "MasterModel::ToTrash", element => [ [qw/my_hash my_hash2 my_hash3/] => { type => 'hash', index_type => 'string', cargo_type => 'leaf', cargo_args => { value_type => 'string' }, }, ] ] ]; libconfig-model-itself-perl-2.025/data/models/MasterModel/WarpedId.pl000066400000000000000000000062571477420254600254710ustar00rootroot00000000000000use strict; use warnings; return [ [ name => 'MasterModel::WarpedIdSlave', element => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/], } ] ], [ name => 'MasterModel::WarpedId', 'element' => [ macro => { type => 'leaf', value_type => 'enum', choice => [qw/A B C/], }, version => { type => 'leaf', value_type => 'integer', default => 1 }, warped_hash => { type => 'hash', index_type => 'integer', max_nb => 3, warp => { follow => '- macro', rules => { A => { max_nb => 1 }, B => { max_nb => 2 } } }, cargo_type => 'node', config_class_name => 'MasterModel::WarpedIdSlave' }, 'multi_warp' => { type => 'hash', index_type => 'integer', min_index => 0, max_index => 3, default => [ 0 .. 3 ], warp => { follow => [ '- version', '- macro' ], 'rules' => [ [ '2', 'C' ] => { max => 7, default => [ 0 .. 7 ] }, [ '2', 'A' ] => { max => 7, default => [ 0 .. 7 ] } ] }, cargo_type => 'node', config_class_name => 'MasterModel::WarpedIdSlave' }, 'hash_with_warped_value' => { type => 'hash', index_type => 'string', cargo_type => 'leaf', level => 'hidden', warp => { follow => '- macro', 'rules' => { 'A' => { level => 'normal', }, } }, cargo_args => { value_type => 'string', warp => { follow => '- macro', 'rules' => { 'A' => { default => 'dumb string' }, } } } }, 'multi_auto_create' => { type => 'hash', index_type => 'integer', min_index => 0, max_index => 3, auto_create => [ 0 .. 3 ], 'warp' => { follow => [ '- version', '- macro' ], 'rules' => [ [ '2', 'C' ] => { max => 7, auto_create_keys => [ 0 .. 7 ] }, [ '2', 'A' ] => { max => 7, auto_create_keys => [ 0 .. 7 ] } ], }, cargo_type => 'node', config_class_name => 'MasterModel::WarpedIdSlave' } ] ] ]; libconfig-model-itself-perl-2.025/data/models/MasterModel/WarpedValues.pl000066400000000000000000000175031477420254600263700ustar00rootroot00000000000000use strict; use warnings; return [ [ name => "MasterModel::RSlave", element => [ recursive_slave => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'MasterModel::RSlave', }, big_compute => { type => 'hash', index_type => 'string', cargo_type => 'leaf', cargo_args => { value_type => 'string', compute => [ 'macro is $m, my idx: &index, ' . 'my element &element, ' . 'upper element &element($up), ' . 'up idx &index($up)', 'm' => '! macro', up => '-' ] }, }, big_replace => { type => 'leaf', value_type => 'string', compute => [ 'trad idx $replace{&index($up)}', up => '-', replace => { l1 => 'level1', l2 => 'level2' } ] }, macro_replace => { type => 'hash', index_type => 'string', cargo_type => 'leaf', cargo_args => { value_type => 'string', compute => [ 'trad macro is $macro{$m}', 'm' => '! macro', macro => { A => 'macroA', B => 'macroB', C => 'macroC' } ] }, } ], ], [ name => "MasterModel::Slave", element => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/], warp => { follow => '- - macro', rules => { A => { default => 'Av' }, B => { default => 'Bv' } } } }, 'recursive_slave' => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'MasterModel::RSlave', }, W => { type => 'leaf', value_type => 'enum', level => 'hidden', warp => { follow => '- - macro', 'rules' => { A => { default => 'Av', level => 'normal', choice => [qw/Av Bv Cv/], }, B => { default => 'Bv', level => 'normal', choice => [qw/Av Bv Cv/] } } }, }, Comp => { type => 'leaf', value_type => 'string', compute => [ 'macro is $m', 'm' => '- - macro' ], }, ], ], [ name => "MasterModel::WarpedValues", element => [ get_element => { type => 'leaf', value_type => 'enum', choice => [qw/m_value_element compute_element/] }, where_is_element => { type => 'leaf', value_type => 'enum', choice => [qw/get_element/] }, macro => { type => 'leaf', value_type => 'enum', choice => [qw/A B C D/] }, macro2 => { type => 'leaf', value_type => 'enum', level => 'hidden', warp => { follow => '- macro', 'rules' => [ "B" => { choice => [qw/A B C D/], level => 'normal' }, ] } }, 'm_value' => { type => 'leaf', value_type => 'enum', 'warp' => { follow => { m => '- macro' }, 'rules' => [ '$m eq "A" or $m eq "D"' => { choice => [qw/Av Bv/], help => { Av => 'Av help' }, }, '$m eq "B"' => { choice => [qw/Bv Cv/], help => { Bv => 'Bv help' }, }, '$m eq "C"' => { choice => [qw/Cv/], help => { Cv => 'Cv help' }, } ] } }, 'm_value_old' => { type => 'leaf', value_type => 'enum', 'warp' => { follow => '- macro', 'rules' => [ [qw/A D/] => { choice => [qw/Av Bv/], help => { Av => 'Av help' }, }, B => { choice => [qw/Bv Cv/], help => { Bv => 'Bv help' }, }, C => { choice => [qw/Cv/], help => { Cv => 'Cv help' }, } ] } }, 'compute' => { type => 'leaf', value_type => 'string', compute => [ 'macro is $m, my element is &element', 'm' => '- macro' ] }, 'var_path' => { type => 'leaf', value_type => 'string', mandatory => 1, # will croak if value cannot be computed compute => [ 'get_element is $element_table{$s}, indirect value is \'$v\'', 's' => '- $where', where => '- where_is_element', v => '- $element_table{$s}', element_table => { qw/m_value_element m_value compute_element compute/ } ] }, 'class' => { type => 'hash', index_type => 'string', cargo_type => 'leaf', cargo_args => { value_type => 'string' }, }, 'warped_out_ref' => { type => 'leaf', value_type => 'reference', refer_to => '- class', level => 'hidden', warp => { follow => { m => '- macro', m2 => '- macro2' }, rules => [ '$m eq "A" or $m2 eq "A"' => { level => 'normal', }, ] } }, [qw/bar foo foo2/] => { type => 'node', config_class_name => 'MasterModel::Slave' } ], ] ]; libconfig-model-itself-perl-2.025/data/models/MasterModel/X_base_class.pl000066400000000000000000000011021477420254600263400ustar00rootroot00000000000000# -*- cperl -*- # this file is used by test script use strict; use warnings; return [ [ name => 'MasterModel::X_base_class2', element => [ X => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ], class_description => 'rather dummy class to check include', ], [ name => 'MasterModel::X_base_class', include => 'MasterModel::X_base_class2', ], ]; # do not put 1; at the end or Model-> load will not work libconfig-model-itself-perl-2.025/dist.ini000066400000000000000000000040371477420254600204630ustar00rootroot00000000000000name = Config-Model-Itself author = Dominique Dumont license = LGPL_2_1 copyright_holder = Dominique Dumont copyright_year = 2007-2019 [MetaResources] homepage = https://github.com/dod38fr/config-model/wiki bugtracker.mailto = ddumont at cpan.org bugtracker.web = https://github.com/dod38fr/config-model-itself/issues repository.url = git://github.com/dod38fr/config-model-itself.git repository.web = http://github.com/dod38fr/config-model-itself repository.type = git [Prereqs] perl = 5.014 [NextRelease] format = %v%T %{yyyy-MM-dd}d ; use 'V=2.234 dzil release' to override version number [Git::NextVersion] [Git::Check] allow_dirty = dist.ini allow_dirty = Changes [Git::Commit] [Git::Tag] signed = 1 [Git::Push] [MetaJSON] [AutoPrereqs] skip = ExtUtils::testlib skip = Exporter [Prereqs / BuildRequires] ; to generate doc App::Cme = 1.002 ; not detected by dzil authordep. ; See Dist::Zilla::App::Command::authordeps man page ; authordep Pod::Weaver::Section::Support ; authordep Pod::Elemental::Transformer::List ; authordep App::Cme [Prereqs / RuntimeRequires] ; avoid failures on CPAN smoke testsq Tk = 0 [@Filter] -bundle = @Basic -remove = Readme -remove = MakeMaker [ModuleBuild::Custom] mb_version = 0.34 ; avoid messing with generated pod files. Otherwise pod re-generated ; at packaging time (Debian) are different (because Dist::Zilla is not ; used at that time) See ; http://blogs.perl.org/users/polettix/2011/11/distzilla-podweaver-and-bin.html ; for details on this configuration magic [FileFinder::ByName / OnlyPmFiles] dir = lib match = \.pm$ [FileFinder::ByName / noModelFiles] dir = lib skip = /models/ match = \.p(m|od)$ skip = TkEditUI [PkgVersion] finder = OnlyPmFiles use_package = 1 [Test::Perl::Critic] [PodWeaver] finder = :ExecFiles finder = noModelFiles [Prepender] copyright=1 [Run::BeforeBuild] ;-- Generate pod doc from model, extra parameters requires Config::Model 2.029 run = cme gen-class-pod Itself::Class [Run::BeforeRelease] run = cme gen-class-pod Itself::Class [Signature] libconfig-model-itself-perl-2.025/lib/000077500000000000000000000000001477420254600175615ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/lib/App/000077500000000000000000000000001477420254600203015ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/lib/App/Cme/000077500000000000000000000000001477420254600210055ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/lib/App/Cme/Command/000077500000000000000000000000001477420254600223635ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/lib/App/Cme/Command/meta.pm000066400000000000000000000377161477420254600236650ustar00rootroot00000000000000# ABSTRACT: Work on the configuration model of an application package App::Cme::Command::meta ; use strict ; use warnings ; use 5.10.1; use App::Cme -command ; use base qw/App::Cme::Common/; use Config::Model 2.075; use Config::Model::Itself ; use YAML::PP qw/Load Dump/; use Tk ; use Config::Model::TkUI ; use Config::Model::Itself::TkEditUI ; use Path::Tiny 0.125; # for mkdir binmode STDOUT, ':encoding(UTF-8)'; my %meta_cmd = ( check => \&check, dump => \&dump_cds, 'dump-yaml' => \&dump_yaml, 'gen-dot' => \&gen_dot, edit => \&edit, save => \&save, plugin => \&plugin, ); sub validate_args { my ($self, $opt, $args) = @_; my $mc = $opt->{'_meta_command'} = shift @$args || die "please specify meta sub command\n"; if (not $meta_cmd{$mc}) { die "Unexpected meta sub command: '$mc'. Expected ".join(' ', sort keys %meta_cmd)."\n"; } my ( $categories, $appli_info, $appli_map ) = Config::Model::Lister::available_models; my $application = shift @$args; if ($mc eq 'plugin') { unless ($application) { die "Missing application name after 'plugin' command"; } $opt->{_root_model} = $appli_map->{$application} || die "Unknown application $application"; } elsif ($application) { $opt->{_root_model} = $appli_map->{$application} || $application; } Config::Model::Exception::Any->Trace(1) if $opt->{trace}; $opt->{_application} = $application ; } sub opt_spec { my ( $class, $app ) = @_; return ( [ "dir=s" => "directory where to read and write a model", {default => 'lib/Config/Model'} ], [ "dumptype=s" => "dump every values (full), only preset values " . "or only customized values (default)", {callbacks => { 'expected values' => sub { $_[0] =~ m/^full|preset|custom$/ ; }}} ], [ "dev!" => 'use model in ./lib to create a plugin'], [ "open-item=s" => "force the UI to open the specified node"], [ "plugin-file=s" => "create a model plugin in this file" ], [ "load-yaml=s" => "load model from YAML file" ], [ "load=s" => "load model from cds file (Config::Model serialisation file)"], [ "system!" => "read model from system files" ], [ "test-and-quit=s" => "Used for tests" ], $class->cme_global_options() ); } sub usage_desc { my ($self) = @_; my $desc = $self->SUPER::usage_desc; # "%c COMMAND %o" return "$desc [ ".join(' | ', sort keys %meta_cmd)." ] your_model_class "; } sub description { my ($self) = @_; return $self->get_documentation; } sub read_data { my $load_file = shift ; my @data ; if ( $load_file eq '-' ) { @data = ; } else { open my $load, '<', $load_file || die "cannot open load file $load_file:$!"; @data = <$load> ; close $load; } return wantarray ? @data : join('',@data); } sub load_optional_data { my ($self, $args, $opt, $root_model, $meta_root) = @_; if (defined $opt->{load}) { my $data = read_data($opt->{load}) ; $data = qq(class:"$root_model" ).$data unless $data =~ /^\s*class:/ ; $meta_root->load($data); } if (defined $opt->{'load-yaml'}) { my $yaml = read_data($opt->{'load-yaml'}) ; my $pdata = Load($yaml) ; $meta_root->load_data($pdata) ; } } sub load_meta_model { my ($self, $opt, $args) = @_; my $root_model = $opt->{_root_model}; my $cm_lib_dir = path(split m!/!, $opt->{dir}) ; # replace with cm_lib_dir ??? if (! $cm_lib_dir->is_dir) { $cm_lib_dir->mkdir(); } my $meta_model = $self->{meta_model} = Config::Model -> new(); my $meta_inst = $meta_model->instance( root_class_name => 'Itself::Model', instance_name => 'meta', check => $opt->{'force-load'} ? 'no' : 'yes', ); my $meta_root = $meta_inst -> config_root ; my $system_cm_lib_dir = $INC{'Config/Model.pm'} ; $system_cm_lib_dir =~ s/\.pm//; return ($meta_inst, $meta_root, $cm_lib_dir, path($system_cm_lib_dir)); } sub load_meta_root { my ($self, $opt, $args) = @_; my ($meta_inst, $meta_root, $cm_lib_dir, $system_cm_lib_dir) = $self->load_meta_model($opt,$args); my $root_model = $opt->{_root_model}; say "Reading model from $system_cm_lib_dir" if $opt->system(); # now load model my $rw_obj = Config::Model::Itself -> new( model_object => $meta_root, cm_lib_dir => $cm_lib_dir->canonpath ); $meta_inst->initial_load_start ; my @read_args = ( force_load => $opt->{'force-load'}, root_model => $root_model, # legacy => 'ignore', ); if ($opt->system()) { push @read_args, application => $opt->{_application}, read_from => $system_cm_lib_dir ; } $rw_obj->read_all(@read_args); $meta_inst->initial_load_stop ; $self->load_optional_data($args, $opt, $root_model, $meta_root) ; my $write_sub = sub { my $wr_dir = shift || $cm_lib_dir ; $rw_obj->write_all( ); } ; return ($rw_obj, $cm_lib_dir, $meta_root, $write_sub); } sub load_meta_plugin { my ($self, $opt, $args) = @_; my ($meta_inst, $meta_root, $cm_lib_dir, $system_cm_lib_dir) = $self->load_meta_model($opt, $args); my $root_model = $opt->{_root_model}; my $meta_cm_lib_dir = $opt->dev ? $cm_lib_dir : $system_cm_lib_dir ; my $plugin_name = shift @$args or die "missing plugin file name after application name."; if ($plugin_name =~ s/\.pl$//) { warn "removed '.pl' deprecated suffix from plugin name\n"; } say "Preparing plugin $plugin_name for model $root_model found in $meta_cm_lib_dir"; say "Use -dev option to create a plugin for a local model (i.e. in $cm_lib_dir)" unless $opt->dev; # now load model my $rw_obj = Config::Model::Itself -> new( model_object => $meta_root, cm_lib_dir => $meta_cm_lib_dir->canonpath, ) ; $meta_inst->initial_load_start ; $meta_inst->layered_start; $rw_obj->read_all( force_load => $opt->{'force-load'}, root_model => $root_model, # legacy => 'ignore', ); $meta_inst->layered_stop; # load any existing plugin file $rw_obj->read_model_plugin( plugin_dir => $cm_lib_dir.'/models/', plugin_name => $plugin_name ) ; $meta_inst->initial_load_stop ; $self->load_optional_data($args, $opt, $root_model, $meta_root) ; my $root_model_dir = $root_model ; $root_model_dir =~ s!::!/!g; my $write_sub = sub { $rw_obj->write_model_plugin( plugin_dir => "$cm_lib_dir/models/$root_model_dir.d", plugin_name => $plugin_name ); } ; return ($rw_obj, $cm_lib_dir, $meta_root, $write_sub); } sub execute { my ($self, $opt, $args) = @_; # how to specify root-model when starting from scratch ? # ask question and fill application file ? my $cmd_sub = $meta_cmd{$opt->{_meta_command}}; $self->$cmd_sub($opt, $args); } sub save { my ($self, $opt, $args) = @_; my ($rw_obj, $cm_lib_dir, $meta_root, $write_sub) = $self->load_meta_root($opt, $args) ; say "Saving ",$rw_obj->root_model. ' model'. ($opt->dir ? ' in '.$opt->dir : ''); &$write_sub; } sub gen_dot { my ($self, $opt, $args) = @_; my ($rw_obj, $cm_lib_dir, $meta_root, $write_sub) = $self->load_meta_root($opt, $args) ; my $out = shift @$args || "model.dot"; say "Creating dot file $out"; path($out) -> spew( $rw_obj->get_dot_diagram ); } sub check { my ($self, $opt, $args) = @_; say "loading model" unless $opt->{quiet}; my ($rw_obj, $cm_lib_dir, $meta_root, $write_sub) = $self->load_meta_root($opt, $args) ; Config::Model::ObjTreeScanner->new( leaf_cb => sub { } )->scan_node( undef, $meta_root ); say "checking data" unless $opt->{quiet}; $meta_root->dump_tree( mode => 'full' ); say "check done" unless $opt->{quiet}; my $ouch = $meta_root->instance->has_warning; if ( $opt->{strict} and $ouch ) { die "Found $ouch warnings in strict mode\n"; } } sub dump_cds { my ($self, $opt, $args) = @_; my ($rw_obj, $cm_lib_dir, $meta_root, $write_sub) = $self->load_meta_root($opt, $args) ; my $dump_file = shift @$args || 'model.cds'; say "Dumping ".$rw_obj->root_model." in $dump_file"; my $dump_string = $meta_root->dump_tree( mode => $opt->{dumptype} || 'custom' ) ; path($dump_file)->spew_utf8($dump_string); } sub dump_yaml{ my ($self, $opt, $args) = @_; my ($rw_obj, $cm_lib_dir, $meta_root, $write_sub) = $self->load_meta_root($opt, $args) ; my $dump_file = shift @$args || 'model.yml'; say "Dumping ".$rw_obj->root_model." in $dump_file"; my $dump_string = Dump($meta_root->dump_as_data(ordered_hash_as_list => 0)) ; path($dump_file)->spew_utf8($dump_string); } sub plugin { my ($self, $opt, $args) = @_; my @info = $self->load_meta_plugin($opt, $args) ; $self->_edit($opt, $args, @info); } sub edit { my ($self, $opt, $args) = @_; my @info = $self->load_meta_root($opt, $args) ; $self->_edit($opt, $args, @info); } sub _edit { my ($self, $opt, $args, $rw_obj, $cm_lib_dir, $meta_root, $write_sub) = @_; my $root_model = $rw_obj->root_model; my $mw = MainWindow-> new; $mw->withdraw ; # Thanks to Jerome Quelin for the tip $mw->optionAdd('*BorderWidth' => 1); my $cmu = $mw->ConfigModelEditUI( -instance => $meta_root->instance, -store_sub => $write_sub, -model_name => $root_model, -cm_lib_dir => $cm_lib_dir ); my $open_item = $opt->{'open-item'}; if ($root_model and not $meta_root->fetch_element('class')->fetch_size) { $open_item ||= qq(class:"$root_model" ); } else { $open_item ||= 'class'; } my $obj = $meta_root->grab($open_item) ; $cmu->after(10, sub { $cmu->force_element_display($obj) }); if (my $taq = $opt->test_and_quit ) { my $bail_out = sub { warn "save failed: $_[0]\n" if @_; $cmu -> quit; } ; $cmu->after( 2000 , sub { if ($taq =~ /s/) { say "Test mode: save and quit"; $cmu->save( $bail_out ); } else { say "Test mode: quit only"; &$bail_out } }); } &MainLoop ; # Tk's say "Exited GUI"; } 1; __END__ =head1 SYNOPSIS # edit meta model cme meta [ options ] edit [ model_class ] # check meta model cme meta [ options ] check [ model_class ] # model plugin mode cme meta [options] plugin application plugin_name =head1 DESCRIPTION C provides a Perl/Tk graphical interface to create or edit configuration models that will be used by L. This tool enables you to create configuration checker or editor for configuration files of an application. =head1 USAGE C supports several sub commands like C or C. These sub commands are detailed below. =head2 edit C is the most useful sub command. It will read and write model file from C<./lib/Config/Model/models> directory. Only configuration models matching the optional 4th parameter will be loaded. I.e. cme meta edit Xorg will load models C (file C) and all other C like C (file C). Besides C, the following sub commands are available: =head2 check C reads the model files from C<./lib/Config/Model/models> directory and checks their validity. =head2 plugin This sub command is used to create model plugins. A model plugin is an addendum to an existing model. The resulting file is saved in a C<.d> directory besides the original file to be taken into account. For instance: $ cme meta plugin dpkg my-plugin # perform additions to Dpkg and Dpkg::Control and save $ find lib/Config/Model/models/Dpkg.d -type f lib/Config/Model/models/Debian/Dpkg.d/my-plugin/Dpkg.pl lib/Config/Model/models/Debian/Dpkg.d/my-plugin/Dpkg/Control.pl Use C<-dev> option if you need to add plugins to a model located in current directory. =head2 gen-dot [ file.dot ] Create a dot file that represent the structure of the configuration model. By default, the generated dot file is C $ cme meta gen-dot Itself itself.dot $ dot -T png itself.dot > itself.png C are represented by solid lines. Class usage (i.e. C parameter) is represented by dashed lines. The name of the element is attached to the dashed line. =head2 dump [ file.cds ] Dump configuration content in the specified file (or C) using Config::Model dump string syntax (hence the C file extension). See L for details on the syntax) By default, dump only custom values, i.e. different from application built-in values or model default values. See -dumptype option for other types of dump $ cme meta dump Itself =head2 dump-yaml [ file.yml ] Dump configuration content in the specified file (or C) in YAML format. For instance: $ cme meta dump-yaml Ssh::PortForward contrib/ssh-portforward.yml =head2 save Force a save of the model even if no edition was done. This option is useful to migrate a model when Config::Model model feature changes. =head1 Options =over =item -system Read model from system files, i.e. from installed files, not from C<./lib> directory. =item -trace Provides a full stack trace when exiting on error. =item -load | - Load model from cds file (using Config::Model serialisation format, typically done with -dump option). This option can be used with C to directly save a model loaded from the cds file or from STDIN. =item -load-yaml | - Load configuration data in model from YAML file. This option can be used with C to directly save a model loaded from a YAML file or from STDIN. =item -force-load Load file even if error are found in data. Bad data are loaded, but should be cleaned up before saving the model. See menu C<< File -> check >> in the GUI. =item -dumptype [ full | preset | custom ] Choose to dump every values (full), only preset values or only customized values (default) (only for C sub command) =item -open-item 'path' In graphical mode, force the UI to open the specified node. E.g. -open_item 'class:Fstab::FsLine element:fs_mntopts rules' =back =head1 LOGGING All Config::Model logging was moved from klunky debug and verbose prints to L. Logging can be configured in the following files: =over =item * ~/.log4config-model =item * /etc/log4config-model.conf =back Without these files, the following Log4perl config is used: log4perl.logger=WARN, Screen log4perl.appender.Screen = Log::Log4perl::Appender::Screen log4perl.appender.Screen.stderr = 0 log4perl.appender.Screen.layout = Log::Log4perl::Layout::PatternLayout log4perl.appender.Screen.layout.ConversionPattern = %d %m %n Log4Perl categories are shown in L =head1 Dogfooding The GUI shown by C is created from a configuration model that describes the structure and parameters of a configuration model. (which explains the "Itself" name. This module could also be named C). This explains why the GUI shown by C looks like the GUI shown by C: the same GUI generator is used. If you're new to L, I'd advise not to peek under C hood lest you loose your sanity. =head1 AUTHOR Dominique Dumont, ddumont at cpan dot org =head1 SEE ALSO =over =item * L =item * L, =item * L, =item * L, =item * L, =item * L, =item * L, =item * L, =item * L, =item * L =back =cut libconfig-model-itself-perl-2.025/lib/Config/000077500000000000000000000000001477420254600207665ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/lib/Config/Model/000077500000000000000000000000001477420254600220265ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/lib/Config/Model/Itself.pm000066400000000000000000000702341477420254600236200ustar00rootroot00000000000000package Config::Model::Itself ; use Mouse ; use Config::Model 2.141; use 5.014; # for the /r modifier use IO::File ; use Log::Log4perl 1.11; use Carp ; use Data::Dumper ; use Scalar::Util qw/weaken/; use File::Find ; use File::Path ; use File::Basename ; use Data::Compare ; use Path::Tiny 0.125; # for mkdir use Mouse::Util::TypeConstraints; my $logger = Log::Log4perl::get_logger("Backend::Itself"); subtype 'ModelPathTiny' => as 'Object' => where { $_->isa('Path::Tiny') }; coerce 'ModelPathTiny' => from 'Str' => via {path($_)} ; # find all .pl file in model_dir and load them... around BUILDARGS => sub { my $orig = shift; my $class = shift; my %args = @_; my $legacy = delete $args{model_object}; if ($legacy) { $args{config_model} = $legacy->instance->config_model; $args{meta_instance} = $legacy->instance; $args{meta_root} = $legacy; } return $class->$orig( %args ); }; has 'config_model' => ( is => 'ro', isa => 'Config::Model', lazy_build => 1, ) ; sub _build_config_model { my $self = shift; # don't trigger builders below if ($self->{meta_root}) { return $self->meta_root->instance->config_model; } elsif ($self->{meta_instance}) { return $self->meta_instance->config_model; } else { return Config::Model -> new ( ) ; } } has check => (is =>'ro', isa => 'Bool', default => 1) ; has 'meta_instance' => ( is =>'ro', isa =>'Config::Model::Instance', lazy_build => 1, ) ; sub _build_meta_instance { my $self = shift; # don't trigger builders below if ($self->{meta_root}) { return $self->meta_root->instance; } else { # load Config::Model model return $self->config_model->instance ( root_class_name => 'Itself::Model' , instance_name => 'meta_model' , check => $self->check, ); } } has meta_root => ( is =>'ro', isa =>'Config::Model::Node', lazy_build => 1, ) ; sub _build_meta_root { my $self = shift; return $self->meta_instance -> config_root ; } has cm_lib_dir => ( is =>'ro', isa => 'ModelPathTiny', lazy_build => 1, coerce => 1 ) ; sub _build_cm_lib_dir { my $self = shift; my $p = path('lib/Config/Model'); if (! $p->is_dir) { $p->mkdir(); } return $p; } has force_write => (is =>'ro', isa => 'Bool', default => 0) ; has root_model => (is =>'ro', isa => 'str'); has modified_classes => ( is =>'rw', isa =>'HashRef[Bool]', traits => ['Hash'], default => sub { {} } , handles => { clear_classes => 'clear', set_class => 'set', class_was_changed => 'get' , class_known => 'exists', } ) ; has model_dir => ( is => 'ro', isa => 'ModelPathTiny', lazy_build => 1, ); sub _build_model_dir { my $self = shift; my $md = $self->cm_lib_dir->child('models'); $md->mkdir; return $md; } sub BUILD { my $self = shift; # avoid memory cycle weaken($self); my $cb = sub { my %args = @_ ; my $p = $args{path} || '' ; return unless $p =~ /^class/ ; return unless $args{index}; # may be empty when class order is changed return if $self->class_was_changed($args{index}) ; $logger->info("class $args{index} was modified"); $self->add_modified_class($args{index}) ; } ; $self->meta_instance -> on_change_cb($cb) ; } sub add_tracked_class { my $self = shift; $self->set_class(shift,0) ; } sub add_modified_class { my $self = shift; $self->set_class(shift,1) ; } sub class_needs_write { my $self = shift; my $name = shift; return ($self->force_write or not $self->class_known($name) or $self->class_was_changed($name)) ; } sub read_app_files { my $self = shift; my $force_load = shift || 0; my $read_from = shift ; my $application = shift ; my $app_dir = $read_from || $self->model_dir->parent; my %apps; my %map; $logger->info("reading app files from ".$app_dir); foreach my $dir ( $app_dir->children(qr/\.d$/) ) { $logger->info("reading app dir ".$dir); foreach my $file ( $dir->children() ) { next if $file =~ m!/README!; next if $file =~ /(~|\.bak|\.orig)$/; next if $application and $file->basename ne $application; # bad categories are filtered by the model my %data = ( category => $dir->basename('.d') ); $logger->info("reading app file ".$file); foreach ($file->lines({ chomp => 1})) { s/^\s+//; s/\s+$//; s/#.*//; my ( $k, $v ) = split /\s*=\s*/; next unless $v; $data{$k} = $v; } my $appli = $file->basename; $apps{$appli} = $data{model} ; $map{$appli} = $file; $self->meta_root->load_data( data => { application => { $appli => \%data } }, check => $force_load ? 'no' : 'yes' ) ; } } $self->{app_map} = \%map; return \%apps; } sub read_all { my $self = shift ; my %args = @_ ; my $force_load = delete $args{force_load} || 0 ; my $read_from ; my $model_dir ; if ($args{read_from}) { $read_from = path (delete $args{read_from}); die "Cannot read from unknown dir ".$read_from unless $read_from->is_dir; $model_dir = $read_from->child('models'); die "Cannot read from unknown dir ".$model_dir unless $model_dir->is_dir; } my $apps = $self-> read_app_files($force_load, $read_from, delete $args{application}); my $root_model_arg = delete $args{root_model} || ''; my $model = $apps->{$root_model_arg} || $root_model_arg ; my $legacy = delete $args{legacy} ; croak "read_all: unexpected parameters ",join(' ', keys %args) if %args ; my $dir = $self->model_dir; $dir->mkdir ; my $root_model_file = $model ; $root_model_file =~ s!::!/!g ; my $read_dir = $model_dir || $dir; $logger->info("searching model files in ".$read_dir); my @files ; my $wanted = sub { push @files, $_ if ( $_->is_file and /\.pl$/ and m!$read_dir/$root_model_file\b! and not m!\.d/! ) ; } ; $read_dir->visit($wanted, { recurse => 1} ) ; my %read_models ; my %class_file_map ; my @all_models = $self->load_model_files( $read_dir, \@files, $legacy, \%class_file_map, \%read_models ); $self->{root_model} = $model || (sort @all_models)[0]; # Create all classes listed in %read_models to avoid problems with # include statement while calling load_data my $root_obj = $self->meta_root ; my $class_element = $root_obj->fetch_element('class') ; foreach my $class (sort keys %read_models) { $class_element->fetch_with_id($class); } #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 $root_obj->load_data( data => {class => [ %read_models ] }, check => $force_load ? 'no' : 'yes' ) ; $self->read_model_annotations( $dir, $root_obj, \@files); return $self->{map} = \%class_file_map ; } sub load_model_files { my ($self, $read_dir, $files, $legacy, $class_file_map, $read_models) = @_; my @all_models; 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 @legacy = $legacy ? ( legacy => $legacy ) : () ; my $tmp_model = Config::Model -> new( skip_include => 1, @legacy ) ; # @models order is important to write configuration class back in the same # order as the declaration my @models = $tmp_model -> load ( 'Tmp' , $file->absolute ) ; push @all_models, @models; my $rel_file = $file ; $rel_file =~ s/^$read_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) { $read_models->{$model_name} = $self->normalize_model($model_name, $tmp_model); } } return @all_models; } sub normalize_model { my ($self, $model_name, $tmp_model) = @_; # 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_clone( $model_name ) ; $self->upgrade_model($model_name, $new_model); # track read class to identify later classes added by user $self->add_tracked_class($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} = [] ; foreach my $name (@$list) { push @{$new_model->{$what}}, $name, $h->{$name} } ; } # remove hash key with undefined values foreach my $name (keys %$new_model) { if (not defined $new_model->{$name} or $new_model->{$name} eq '') { delete $new_model->{$name}; } } return $new_model ; } sub read_model_annotations { my ($self, $dir, $root_obj, $files) = @_; # 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; $root_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; } } # can be removed end of 2019 (after buster is released) sub upgrade_model { my ($self, $config_class_name, $model) = @_ ; my $multi_backend = 0; foreach my $config (qw/read_config write_config/) { my $ref = $model->{$config}; if ($ref and ref($ref) eq 'ARRAY') { if (@$ref == 1) { $model->{$config} = $ref->[0]; } elsif (@$ref > 1){ $logger->warn("$config_class_name $config: cannot migrate multiple backends to rw_config"); $multi_backend++; } } } if ($model->{read_config} and not $multi_backend) { say ("Model $config_class_name: moving read_config specification to rw_config"); $model->{rw_config} = delete $model->{read_config}; } if ($model->{write_config} and not $multi_backend) { say "Model $config_class_name: merging write_config specification in rw_config"; if (not $multi_backend) { foreach my $spec ( keys %{$model->{write_config}} ) { $model->{rw_config}{$spec} = $model->{write_config}{$spec} } ; delete $model->{write_config}; } } } # internal sub get_perl_data_model{ my $self = shift ; my %args = @_ ; my $root_obj = $self->{meta_root}; my $class_name = $args{class_name} || croak __PACKAGE__," read: undefined class name"; my $class_element = $root_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_app_files { my $self = shift; my $app_dir = $self->cm_lib_dir; my $app_obj = $self->meta_root->fetch_element('application'); foreach my $app_name ( $app_obj->fetch_all_indexes ) { $logger->debug("writing $app_name..."); my $app = $app_obj->fetch_with_id($app_name); my $cat_dir_name = $app->fetch_element_value( name =>'category' ).'.d'; $app_dir->child($cat_dir_name)->mkdir(); my $app_file = $app_dir->child($cat_dir_name)->child($app->index_value) ; my @lines ; foreach my $name ( $app->children ) { next if $name eq 'category'; # saved as directory above my $v = $app->fetch_element_value($name); # need to spit out 0 ? next unless defined $v; push @lines, "$name = $v\n"; } $logger->info("writing file ".$app_file); $app_file->spew(@lines); delete $self->{app_map}{$app_name}; } # prune removed app files foreach my $old_file ( values %{$self->{app_map}}) { $logger->debug("Removing $old_file."); $old_file->remove; } } sub write_all { my $self = shift ; my %args = @_ ; my $root_obj = $self->meta_root ; my $dir = $self->model_dir ; croak "write_all: unexpected parameters ",join(' ', keys %args) if %args ; $self->write_app_files; my $map = $self->{map} ; $dir->mkdir; # get list of all classes loaded by the editor my %loaded_classes = map { ($_ => 1); } $root_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; foreach my $class (keys %loaded_classes) { my $f = $class =~ s!::!/!gr; $new_map{"$f.pl"} = [ $class ] ; } my %map_to_write = (%$map,%new_map) ; foreach my $file (keys %map_to_write) { my ($data,$notes) = $self->check_model_to_write($file, \%map_to_write, \%loaded_classes); next unless @$data ; # don't write empty model write_model_file ($dir->child($file), $self->{header}{$file}, $notes, $data); delete $map_to_write{$file}; } # remove existing files that contain only deleted classes foreach my $goner (%map_to_write) { $logger->debug("Removing model file $goner."); $dir->child($goner)->remove; } $self->meta_instance->clear_changes ; } sub check_model_to_write { my ($self, $file, $map_to_write, $loaded_classes) = @_; $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->class_needs_write($class_name); $logger->info("file $file class $class_name needs write ",$file_needs_write); } if ($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->{meta_root}->grab("class:".$class_name) ; push @notes, $node->dump_annotations_as_pod ; # remove class name from above list delete $loaded_classes->{$class_name} ; } } return (\@data, \@notes); } sub write_model_plugin { my $self = shift ; my %args = @_ ; my $plugin_dir = delete $args{plugin_dir} || croak __PACKAGE__," write_model_plugin: undefined plugin_dir"; my $plugin_name = delete $args{plugin_name} || croak __PACKAGE__," write_model_plugin: undefined plugin_name"; croak "write_model_plugin: unexpected parameters ",join(' ', keys %args) if %args ; my $model = $self->meta_root->dump_as_data(mode => 'custom') ; # 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->meta_root->grab("class:$class")->dump_annotations_as_pod ; my $plugin_file = $class.'.pl'; $plugin_file =~ s!::!/!g; write_model_file ("$plugin_dir/$plugin_name/$plugin_file", [], \@notes, [ $data ]); } $self->meta_instance->clear_changes ; } sub read_model_plugin { my $self = shift ; my %args = @_ ; my $plugin_dir = delete $args{plugin_dir} || croak __PACKAGE__," write_model_plugin: undefined plugin_dir"; my $plugin_name = delete $args{plugin_name} || croak __PACKAGE__," read_model_plugin: undefined plugin_name"; croak "read_model_plugin: 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/$plugin_name! ) ; } ; find ($wanted, $plugin_dir ) ; foreach my $load_file (@files) { $self->read_plugin_file($load_file); } } sub read_plugin_file { my ($self, $load_file) = @_; $logger->info("trying to read plugin $load_file"); my $class_element = $self->meta_root->fetch_element('class') ; $load_file = "./$load_file" if $load_file !~ m!^/! and -e $load_file; my $plugin = do $load_file ; unless ($plugin) { if ($@) {die "couldn't parse $load_file: $@"; } elsif (not defined $plugin) {die "couldn't do $load_file: $!"} else { die "couldn't run $load_file" ;} } # there should be only only class in each plugin file foreach my $model (@$plugin) { 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 plugin file $load_file"); my $fh = IO::File->new($load_file) || die "Can't open $load_file: $!" ; my @lines = $fh->getlines ; $fh->close; $self->meta_root->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, oct(755) ) || 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( "use strict;\nuse warnings;\n\n" ); $wr->print( "return $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->{meta_root}->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->{meta_root}->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) { foreach my $inc (@include) { $res .= $self->list_one_class_element($inc,$pad.' ') ; } } 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) { foreach my $inc (@include) { $res .= $self->list_one_class_element($inc,$pad.' ') ; } } } return $res ; } sub get_dot_diagram { my $self = shift ; my $dot = "digraph model {\n" ; my $meta_class = $self->{meta_root}->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->{meta_root}->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 (or schema) editor for Config::Model __END__ =pod =head1 SYNOPSIS # Itself constructor returns an object to read or write the data # structure containing the model to be edited my $meta_model = Config::Model::Itself -> new( ) ; # now load the model to be edited $meta_model -> read_all( ) ; # For Curses UI prepare a call-back to write model my $wr_back = sub { $meta_model->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->config_root ) ; # 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. 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 follows a set of rules which are described for humans in L. The structure and rules documented in L are also expressed in a model in the files provided with C. Hence the possibity to verify, modify configuration data provided by L 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 ( [ cm_lib_dir => ... ] ) Creates a new read/write handler. If no model_object is passed, the required objects are created. C specifies where are the model files (defaults to C<./lib/Config/Model>. C is either a C object or a string. By default, this constructor will create all necessary C objects. If needed, you can pass already created object with options C (L object), C (L object) or C (L object). =head2 Methods =head1 read_all ( [ root_model => ... ], [ force_load => 1 ] ) Load all the model files contained in C and all its subdirectories. C is used to filter the classes read. Use C if you are trying to load a model containing errors. C 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_plugin( plugin_dir => foo, plugin_name => bar ) Write plugin models in the passed C directory. The written file is path is made of plugin name and class names. E.g. a plugin named C for class C is written in C file. This file is to be used by L '...', class_data )"> =head2 read_model_plugin( plugin_dir => foo, plugin_name => bar.pl ) This method searched recursively C<$plugin_dir/$plugin_name> and load all C<*.pl> files found 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 structure of the configuration model: =over =item * C relations are represented by solid lines =item * Class usage (i.e. C parameter) is represented by dashed lines. The name of the element is attached to the dashed line. =back =head1 BUGS Test menu entries are created from the content of C model parameter. Unfortunately, there's no way to build the menu dynamically. So user cme must be restarted to change the menu if the application list is changed. =head1 CREDITS Here's the list of people who helped improve this project: =over =item Gregor Herrmann =back Thanks for the patches ! =head1 SEE ALSO L, L, L =cut libconfig-model-itself-perl-2.025/lib/Config/Model/Itself/000077500000000000000000000000001477420254600232545ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/lib/Config/Model/Itself/BackendDetector.pm000066400000000000000000000070451477420254600266410ustar00rootroot00000000000000package Config::Model::Itself::BackendDetector ; # since this package is mostly targeted for dev environments # let the detector detect models under development use lib 'lib'; use Pod::POM ; use File::Find ; use base qw/Config::Model::Value/ ; use strict ; use warnings ; sub setup_enum_choice { my $self = shift ; # using a hash to make sure that a backend is not listed twice. This may # happen in development environment where a backend in found in /usr/lib # and in ./lib (or ./blib) my %choices = map { ($_ => 1);} ref $_[0] ? @{$_[0]} : @_ ; # find available backends in all @INC directories my $wanted = sub { my $n = $File::Find::name ; if (-f $_ and $n =~ s/\.pm$// and $n !~ /Any$/) { $n =~ s!.*Backend/!! ; $n =~ s!/!::!g ; $choices{$n} = 1 ; } } ; foreach my $inc (@INC) { my $path = "$inc/Config/Model/Backend" ; find ($wanted, $path ) if -d $path; } $self->SUPER::setup_enum_choice(sort keys %choices) ; } sub set_help { my ($self,$args) = @_ ; my $help = delete $args->{help} || {} ; my $path = $INC{"Config/Model.pm"} ; $path =~ s!\.pm!/Backend! ; my $parser = Pod::POM->new(); my $wanted = sub { my $n = $File::Find::name ; return unless (-f $n and $n !~ /Any\.pm$/) ; my $file = $n ; $n =~ s/\.pm$//; $n =~ s!/!::!g ; my $perl_name = $n ; $n =~ s!.*Backend::!! ; $perl_name =~ s!.*Config!Config! ; my $pom = $parser->parse_file($file)|| die $parser->error(); foreach my $head1 ($pom->head1()) { if ($head1->title() eq 'NAME') { my $c = $head1->content(); $c =~ s/.*?-\s*//; $c =~ s/\n//g; $help->{$n} = $c . " provided by L<$perl_name>"; last; } } }; find ($wanted, $path ) ; $self->{help} = $help; } 1; # ABSTRACT: Detect available read/write backends usable by config models __END__ =head1 SYNOPSIS # this class should be referenced in a configuration model and # created only by Config::Model::Node my $model = Config::Model->new() ; $model ->create_config_class ( name => "Test", 'element' => [ 'backend' => { type => 'leaf', class => 'Config::Model::Itself::BackendDetector' , value_type => 'enum', # specify backends built in Config::Model choice => [qw/cds_file perl_file ini_file custom/], help => { cds_file => "file ...", ini_file => "Ini file ...", perl_file => "file perl", custom => "Custom format", } } ], ); my $root = $model->instance(root_class_name => 'Test') -> config_root ; my $backend = $root->fetch_element('backend') ; my @choices = $backend->get_choice ; =head1 DESCRIPTION This class is derived from L. It is designed to be used in a 'enum' value where the choice (the available backends) are the backend built in L and all the plugin backends. The plugin backends are all the C classes. This module will detect available plugin backend and query their pod documentation to provide a contextual help for config-model graphical editor. =head1 SEE ALSO L, L, L =cut libconfig-model-itself-perl-2.025/lib/Config/Model/Itself/TkEditUI.pm000066400000000000000000000063521477420254600252420ustar00rootroot00000000000000package Config::Model::Itself::TkEditUI ; use strict; use warnings ; use Carp ; use 5.10.0; use Config::Model::TkUI 1.378; use base qw/Config::Model::TkUI/; Construct Tk::Widget 'ConfigModelEditUI'; sub ClassInit { my ($class, $mw) = @_; # ClassInit is often used to define bindings and/or other # resources shared by all instances, e.g., images. # cw->Advertise(name=>$widget); } sub Populate { my ($cw, $args) = @_; my $cm_lib_dir = (delete $args->{-cm_lib_dir})."/models" ; my $model_name = delete $args->{-model_name} || ''; my $root_dir = delete $args->{-root_dir} ; # used to test the edited model $args->{'-title'} ||= "cme meta edit $model_name" ; $cw->SUPER::Populate($args) ; my $model_menu = $cw->{my_menu}->cascade( -label => 'Model', -menuitems => $cw->build_menu() , ) ; $cw->{cm_lib_dir} = $cm_lib_dir ; $cw->{model_name} = $model_name ; $cw->{root_dir} = $root_dir ; $cw->show_message("Add a name in Class to create your model") unless $model_name; } sub build_menu { my $cw = shift ; # search for config_dir override my $root = $cw->{instance}->config_root; my $items = []; my %app; my $found_app = 0; foreach my $app ($root->fetch_element('application')->fetch_all_indexes) { push @$items, [ command => "test $app", '-command' => sub{ $cw->test_model($app) }]; $app{$app} = $root->grab_value("application:$app config_dir"); } push @$items, [ qw/command test -command/, sub{ $cw->test_model }] unless @$items ; return $items; } sub test_model { my $cw = shift ; my $app = shift; if ( $cw->{instance}->needs_save ) { my $answer = $cw->Dialog( -title => "save model before test", -text => "Save model ?", -buttons => [ qw/yes no cancel/, 'show changes' ], -default_button => 'yes', )->Show; if ( $answer eq 'yes' ) { $cw->save( sub {$cw->_launch_test($app);}); } elsif ( $answer eq 'no' ) { $cw->_launch_test($app); } elsif ( $answer =~ /show/ ) { $cw->show_changes( sub { $cw->test_model } ); } } else { $cw->_launch_test($app); } } sub _launch_test { my $cw = shift ; my $app = shift; my $testw = $cw -> {test_widget} ; $testw->destroy if defined $testw and Tk::Exists($testw); # need to read test model from where it was written... my $model = Config::Model -> new(model_dir => $cw->{cm_lib_dir}) ; # keep a reference on this object, otherwise it will vanish at the end of this block. $cw->{test_model} = $model ; my %args = ( root_dir => $cw->{root_dir} ); my $root = $cw->{instance}->config_root; $args{root_class_name} = $app ? $root->grab_value("application:$app model") : $cw->{model_name}; $args{instance_name} = $app ? "test $app" : $cw->{model_name}; if ($app) { $args{application} = $app; $args{config_dir} = $root->grab_value("application:$app config_dir"); } my $instance_to_test = $model->instance ( %args ) ; $cw -> {test_widget} = $cw->ConfigModelUI (-instance => $instance_to_test, -quit => 'soft') ; } 1; libconfig-model-itself-perl-2.025/lib/Config/Model/models/000077500000000000000000000000001477420254600233115ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/000077500000000000000000000000001477420254600245375ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/Application.pl000066400000000000000000000075621477420254600273510ustar00rootroot00000000000000use strict; use warnings; return [ { name => 'Itself::Application', # read/written by Config::Model::Itself (read_all) element => [ model => { refer_to => '! class', type => 'leaf', value_type => 'reference', description => 'Top class required to configure this application', }, synopsis => { type => 'leaf', value_type => 'uniline', description => "one line description of the application." }, link_to_doc => { type => 'leaf', value_type => 'uniline', description => "Documentation URL." }, category => { choice => [ 'system', 'user', 'application' ], type => 'leaf', value_type => 'enum', mandatory => 1, description => 'Can be "system", "user" or "application"', help => { system => 'Configuration file is owned by root and usually located in C', user => 'Configuration files is owned by user and usually located in C<~/.*>', application => 'Configuration file is located anywhere and is usually explicitly ' .'specified to application. E.g. C', } }, allow_config_file_override => { type => 'leaf', upstream_default => '0', value_type => 'boolean', description => 'Set if user can override the configuration file loaded by default by cme', }, require_config_file => { type => 'leaf', upstream_default => '0', value_type => 'boolean', description => "set when there's no default path for the configuration file." . "user will have to specify a configuration file with C<--file> option." }, require_backend_argument => { type => 'leaf', upstream_default => '0', value_type => 'boolean', description => "set when the application backend requires an argument passed " . "as 3rd argument to cme, e.g. cme ." }, use_backend_argument_as_config_file => { type => 'leaf', upstream_default => '0', value_type => 'boolean', description => "When backend argument is also used as the name of the config file." }, backend_argument_info => { type => 'leaf', value_type => 'uniline', description => "Short description of the backend argument. Used to generate error " ."message when user forgets to set the 3rd cme argument." }, config_dir => { type => 'leaf', value_type => 'uniline', description => "set configuration directory where config file is read from " . "or written to. This value does not override a directory specified in the model." }, support_info => { type => 'leaf', value_type => 'uniline', description => "Instructions to let user report a bug for this application. This URL is shown in " . 'the message of unknown element exception in the string "please submit a bug report ' . '$support_info". Defaults to an url to Config::Model bug tracker', upstream_default => 'to https://github.com/dod38fr/config-model/issues', } ], } ] ; libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/CargoElement.pl000066400000000000000000000025741477420254600274510ustar00rootroot00000000000000use strict; use warnings; return [ [ name => "Itself::CargoElement", include => [ 'Itself::NonWarpableElement', 'Itself::WarpableCargoElement' ], include_after => 'type', 'element' => [ # structural information 'type' => { type => 'leaf', value_type => 'enum', choice => [qw/node warped_node leaf check_list/], mandatory => 1, description => 'specify the type of the cargo.', }, # node element (may be within a hash or list) 'warp' => { type => 'warped_node', # ? level => 'hidden', warp => { follow => { elt_type => '- type' }, rules => [ '$elt_type ne "node"' => { level => 'normal', config_class_name => 'Itself::WarpValue', } ], }, description => "change the properties (i.e. default value or its value_type) " . "dynamically according to the value of another Value object locate " . "elsewhere in the configuration tree. " }, ], ], ]; libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/Class.pl000066400000000000000000000505431477420254600261500ustar00rootroot00000000000000# Copyright (c) 2007-2015 Dominique Dumont. # # This file is part of Config-Model-Itself. # # Config-Model-Itself is free software; you can redistribute it # and/or modify it under the terms of the GNU Lesser Public License # as published by the Free Software Foundation; either version 2.1 # of the License, or (at your option) any later version. # # Config-Model-Itself 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 Lesser Public License for more details. # # You should have received a copy of the GNU Lesser Public License # along with Config-Model-Itself; if not, write to the Free Software # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA use strict; use warnings; return [ [ name => "Itself::Class", author => 'Dominique Dumont', copyright => '2007-2011 Dominique Dumont.', license => 'LGPL-2', class_description => "Configuration class. This class represents a node of a configuration tree.", 'element' => [ [qw/class_description license gist/] => { type => 'leaf', value_type => 'string', }, [qw/author copyright/] => { type => 'list', cargo => { type => 'leaf', value_type => 'uniline', } }, 'class' => { type => 'leaf', value_type => 'uniline', summary => "Override implementation of configuration node", description => "Perl class name used to override the default implementation of a configuration node. " ."This Perl class must inherit L. Use with care.", assert => { "1_load_class" => { code => 'return 1 unless defined $_;' .'return Mouse::Util::load_class($_);', msg => 'Error while loading $_ class ', }, "2_class_inherit" => { code => 'not defined $_ or $_->isa("Config::Model::Node")', msg => 'class $_ must inherit Config::Model::Node', } }, }, 'element' => { type => 'hash', level => 'important', ordered => 1, index_type => 'string', cargo => { type => 'node', config_class_name => 'Itself::Element', }, }, [qw/include include_backend/] => { type => 'list', cargo => { type => 'leaf', value_type => 'reference', refer_to => '! class', } }, 'include_after' => { type => 'leaf', value_type => 'reference', refer_to => '- element', }, generated_by => { type => 'leaf', value_type => 'uniline', }, rw_config => { type => 'node', config_class_name => 'Itself::ConfigReadWrite', }, 'accept' => { type => 'hash', index_type => 'string', ordered => 1, cargo => { type => 'node', config_class_name => 'Itself::ConfigAccept', }, }, ], 'description' => [ element => "Specify the elements names of this configuration class.", gist => 'String used to construct a summary of the content of a node. This ' .'parameter is used by user interface to show users the gist of the ' .'content of this node. This parameter has no other effect. This string ' .'may contain element values in the form "C<{foo} or {bar}>". When ' .'constructing the gist, C<{foo}> is replaced by the value of element ' .'C. Likewise for C<{bar}>.', include => "Include the element description of another class into this class.", include_after => "insert the included elements after a specific element. " . "By default, included elements are placed before all other elements.", include_backend => "Include the read/write specification of another class into this class.", class_description => "Explain the purpose of this configuration class. This description is re-used to generate the documentation of your configuration class. You can use pod markup to format your description. See L for details.", rw_config => "Specify the backend used to read and write configuration data. See L for details", generated_by => "When set, this class was generated by some program. You should not edit " ."this class as your modifications may be clobbered later on when the class is regenerated.", accept => "Specifies names of the elements this configuration class accepts as valid. " ."The key of the hash is a regular expression that are be tested against candidate parameters. When the parameter matches the regular expression, a new parameter is created in the model using the description provided in the value of this hash key. Note that the regexp must match the whole name of the potential parameter. I.e. the specified regexp is eval\'ed with a leading C<^> and a trailing C<\$>." ], ], [ name => 'Itself::ConfigReadWrite::DefaultLayer', 'element' => [ 'config_dir' => { type => 'leaf', value_type => 'uniline', level => 'normal', }, os_config_dir => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'uniline', }, summary => 'configuration file directory for specific OS', description => 'Specify and alternate location of a configuration directory depending ' .q!on the OS (as returned by C<$^O> or C<$Config{'osname'}>, see L) ! .q!Common values for C<$^O> are 'linux', 'MSWin32', 'darwin'! }, 'file' => { type => 'leaf', value_type => 'uniline', level => 'normal', summary => 'target configuration file name', description => 'specify the configuration file name. This parameter may ' .'not be applicable depending on your application. It may also be ' .'hardcoded in a custom backend. If not specified, the instance name ' .'is used as base name for your configuration file. The configuration file name' .'can be specified with &index() or &element function. See ' .'L ' .'and L.' }, ] ], [ name => "Itself::ConfigReadWrite", include => "Itself::ConfigReadWrite::DefaultLayer", include_after => 'backend', 'element' => [ 'backend' => { type => 'leaf', class => 'Config::Model::Itself::BackendDetector', value_type => 'enum', choice => [qw/cds_file perl_file custom/], warn_if_match => { '^custom$' => { msg => "custom backend are deprecated" } }, replace => { perl => 'perl_file', ini => 'IniFile', ini_file => 'IniFile', cds => 'cds_file', }, description => 'specifies the backend to store permanently configuration data.', help => { cds_file => "file with config data string. This is Config::Model own serialisation format, designed to be compact and readable. Configuration filename is made with instance name", IniFile => "Ini file format. Beware that the structure of your model must match the limitations of the INI file format, i.e only a 2 levels hierarchy. Configuration filename is made with instance name", perl_file => "file with a perl data structure. Configuration filename is made with instance name", custom => "deprecated", } }, 'function' => { type => 'leaf', value_type => 'uniline', status => 'deprecated', level => 'hidden', warp => { follow => '- backend', rules => [ custom => { level => 'normal', upstream_default => 'read', } ], } }, 'auto_create' => { type => 'leaf', value_type => 'boolean', level => 'normal', upstream_default => 0, summary => 'Creates configuration files as needed', }, yaml_class => { type => 'leaf', value_type => 'uniline', level => 'hidden', description => 'Specify the YAML class that is used to load and dump YAML files.' .' Defaults to L.' .' See L for details on ' .' why another YAML class can suit your configuration file needs.', upstream_default => 'YAML::Tiny', warp => { follow => '- backend', rules => [ Yaml => { level => 'normal', } ], } }, file_mode => { type => 'leaf', value_type => 'uniline', level => 'normal', summary => 'configuration file mode', description => 'specify the configuration file mode. C parameter can be used to set the ' . 'mode of the written file. C value can be in any form supported by L.' }, default_layer => { type => 'node', config_class_name => 'Itself::ConfigReadWrite::DefaultLayer', summary => q!How to find default values in a global config file!, description => q!Specifies where to find a global configuration file that ! .q!specifies default values. For instance, this is used by OpenSSH to ! .q!specify a global configuration file (C) that is ! .q!overridden by user's file!, }, 'class' => { type => 'leaf', value_type => 'uniline', level => 'hidden', warp => { follow => '- backend', rules => [ custom => { level => 'normal', mandatory => 1, } ], } }, 'store_class_in_hash' => { type => 'leaf', value_type => 'uniline', level => 'hidden', description => 'Specify element hash name that contains all INI classes. ' .'See L', warp => { follow => '- backend', rules => [ IniFile => { level => 'normal', } ], } }, 'section_map' => { type => 'hash', level => 'hidden', index_type => 'string', description => 'Specify element name that contains one INI class. E.g. to store ' .'INI class [foo] in element Foo, specify { foo => "Foo" } ', warp => { follow => '- backend', rules => [ IniFile => { level => 'normal', } ], }, cargo => { type => 'leaf', value_type => 'uniline', }, }, ['split_list_value','split_check_list_value'] => { type => 'leaf', value_type => 'uniline', level => 'hidden', description => 'Regexp to split the value read from ini file. Usually "\s+" or "[,\s]"', warp => { follow => '- backend', rules => [ IniFile => { level => 'normal', } ], } }, assign_char => { type => 'leaf', value_type => 'uniline', level => 'hidden', description => 'Character used to assign value in INI file. Default is C<=>. ' .'See L', upstream_default => '#', warp => { follow => '- backend', rules => [ IniFile => { level => 'normal', } ], } }, assign_with => { type => 'leaf', value_type => 'uniline', level => 'hidden', description => 'String used write assignment in INI file. Default is "C< = >". ' .'See L', upstream_default => '#', warp => { follow => '- backend', rules => [ IniFile => { level => 'normal', } ], } }, ['join_list_value', 'join_check_list_value'] => { type => 'leaf', value_type => 'uniline', level => 'hidden', warp => { follow => '- backend', rules => [ IniFile => { level => 'normal', } ], } }, 'write_boolean_as' => { type => 'list', description => 'Specify how to write a boolean value in config file. Suggested values are ' . '"no","yes". ', max_index => 1, cargo => { type => 'leaf', value_type => 'uniline', }, }, force_lc_section => { type => 'leaf', value_type => 'boolean', level => 'hidden', upstream_default => 0, description => "force section to be lowercase", warp => { follow => '- backend', rules => [ IniFile => { level => 'normal', } ], } }, force_lc_key => { type => 'leaf', value_type => 'boolean', level => 'hidden', upstream_default => 0, description => "force key names to be lowercase", warp => { follow => '- backend', rules => [ IniFile => { level => 'normal', } ], } }, force_lc_value => { type => 'leaf', value_type => 'boolean', level => 'hidden', upstream_default => 0, description => "force values to be lowercase", warp => { follow => '- backend', rules => [ IniFile => { level => 'normal', } ], } }, 'full_dump' => { type => 'leaf', value_type => 'boolean', level => 'hidden', description => 'Also dump default values in the data structure. Useful if the dumped configuration data will be used by the application. (default is yes)', upstream_default => '1', warp => { follow => { backend => '- backend' }, rules => [ '$backend =~ /yaml|perl/i' => { level => 'normal', } ], } }, 'comment_delimiter' => { type => 'leaf', value_type => 'uniline', level => 'hidden', description => 'list of characters that start a comment. When more that one character' .' is used. the first one is used to write back comment. For instance,' .' value "#;" indicate that a comments can start with "#" or ";" and that all comments' .' are written back with "#".', upstream_default => '#', warp => { follow => '- backend', rules => [ IniFile => { level => 'normal', } ], } }, quote_value => { type => 'leaf', value_type => 'enum', choice => ['shell_style'], level => 'hidden', description => 'Specify how to handle quoted values. By default, quoted values ' .'are left as is. With C, value are parsed and unquoted like in a shell. ' .'Values containing a space are written back with double quotes.', warp => { follow => '- backend', rules => [ IniFile => { level => 'normal', } ], } }, 'auto_delete' => { type => 'leaf', value_type => 'boolean', level => 'normal', upstream_default => 0, summary => 'Delete empty configuration file', description => 'Delete configuration files when no information is left in there.' . ' This may happen when data is removed by user. This is mostly useful when the ' . ' configuration of an application is made of several files.', }, ], description => [ join_list_value => 'string to join list values before writing the entry in ini file. Usually " " or ", "', join_check_list_value => 'string to join checked items names before writing the entry in the ini file. Usually " " or ", "', ], ], [ name => 'Itself::ConfigAccept', include => "Itself::Element", include_after => 'accept_after', 'element' => [ 'name_match' => { type => 'leaf', value_type => 'uniline', upstream_default => '.*', status => 'deprecated', }, 'accept_after' => { type => 'leaf', value_type => 'reference' , refer_to => '- - element' , description => 'specify where to insert accepted element. This does' . ' not change the behavior and helps generating more consistent ' . ' user interfaces' } ], ], ]; libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/CommonElement.pl000066400000000000000000000336171477420254600276500ustar00rootroot00000000000000# Copyright (c) 2007-2011 Dominique Dumont. # # This file is part of Config-Model-Itself. # # Config-Model-Itself is free software; you can redistribute it # and/or modify it under the terms of the GNU Lesser Public License # as published by the Free Software Foundation; either version 2.1 # of the License, or (at your option) any later version. # # Config-Model-Itself 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 Lesser Public License for more details. # # You should have received a copy of the GNU Lesser Public License # along with Config-Model-Itself; if not, write to the Free Software # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA use strict; use warnings; my @warp_in_string_like_parameter = ( warp => { follow => { 'type' => '?type', 'vtype' => '?value_type', }, 'rules' => [ '$type eq "leaf" and ($vtype eq "uniline" or $vtype eq "string" or $vtype eq "enum")' => { level => 'normal', } ] }, ); my %warn_if_match_payload = ( type => 'hash', index_type => 'string', level => 'hidden', cargo => { type => 'node', config_class_name => 'Itself::CommonElement::WarnIfMatch', }, @warp_in_string_like_parameter, ); my @warp_in_leaf_parameter = ( warp => { follow => { 'type' => '?type', 'vtype' => '?value_type', }, 'rules' => [ '$type eq "leaf"' => { level => 'normal', } ] }, ); my %warn_if = ( type => 'hash', index_type => 'string', level => 'hidden', cargo => { type => 'node', config_class_name => 'Itself::CommonElement::WarnIfMatch', }, @warp_in_leaf_parameter, ); my %assert_payload = ( type => 'hash', index_type => 'string', level => 'hidden', cargo => { type => 'node', config_class_name => 'Itself::CommonElement::Assert', }, @warp_in_leaf_parameter, ); return [ [ name => 'Itself::CommonElement::WarnIfMatch', element => [ msg => { type => 'leaf', value_type => 'string', description => 'Warning message to show user. "$_" contains the bad value. Example "value $_ is bad". Leave blank or undef to use generated message', }, fix => { type => 'leaf', value_type => 'string', description => 'Perl instructions to fix the value. These instructions may be triggered by user. $_ contains the value to fix. $_ is stored as the new value once the instructions are done. C<$self> contains the value object. Use with care.', }, ], ], [ name => 'Itself::CommonElement::Assert', include => 'Itself::CommonElement::WarnIfMatch', include_after => 'code', element => [ code => { type => 'leaf', value_type => 'string', description => 'Perl instructions to test the value. $_ contains the value to test. C<$self> contains the value object. Use with care.', }, ], ], [ name => 'Itself::CommonElement', # warp often depend on this one, so list it first 'element' => [ 'mandatory' => { type => 'leaf', value_type => 'boolean', level => 'hidden', warp => { follow => '?type', 'rules' => { 'leaf' => { upstream_default => 0, level => 'normal', } } } }, # node element (may be within a hash or list) 'config_class_name' => { type => 'leaf', level => 'hidden', value_type => 'reference', refer_to => '! class', warp => { follow => { t => '?type' }, rules => [ '$t eq "warped_node" ' => { # should be able to warp refer_to ?? level => 'normal', }, '$t eq "node"' => { # should be able to warp refer_to ?? level => 'normal', mandatory => 1, }, ] } }, # warped_node: warp parameter for warped_node. They must be # warped out when type is not a warped_node # end warp elements for warped_node # leaf element 'choice' => { type => 'list', level => 'hidden', description => 'Specify the possible values of an enum. This can also be used in a ' .'reference element so the possible enum value will be the combination of the ' .'specified choice and the referred to values', warp => { follow => { t => '?type', vt => '?value_type', }, 'rules' => [ ' ($t eq "leaf" and ( $vt eq "enum" or $vt eq "reference") ) or $t eq "check_list"' => { level => 'normal', }, ] }, cargo => { type => 'leaf', value_type => 'uniline' }, }, 'min' => { type => 'leaf', value_type => 'number', level => 'hidden', description => 'minimum value', warp => { follow => { 'type' => '?type', 'vtype' => '?value_type', }, 'rules' => [ ' $type eq "leaf" and ( $vtype eq "integer" or $vtype eq "number" ) ' => { level => 'normal', } ] } }, 'max' => { type => 'leaf', value_type => 'number', level => 'hidden', description => 'maximum value', warp => { follow => { 'type' => '?type', 'vtype' => '?value_type', }, 'rules' => [ ' $type eq "leaf" and ( $vtype eq "integer" or $vtype eq "number" ) ' => { level => 'normal', } ] } }, 'min_index' => { type => 'leaf', value_type => 'integer', level => 'hidden', description => 'minimum number of keys', warp => { follow => { 'type' => '?type', }, 'rules' => [ '$type eq "hash"' => { level => 'normal', }, ] } }, 'max_index' => { type => 'leaf', value_type => 'integer', level => 'hidden', description => 'maximum number of keys', warp => { follow => { 'type' => '?type', }, 'rules' => [ '$type eq "hash" or $type eq "list"' => { level => 'normal', }, ] } }, 'default' => { type => 'leaf', level => 'hidden', value_type => 'string', description => 'Specify default value. This default value is written ' .'in the configuration data', warp => { follow => { 't' => '?type' }, 'rules' => [ '$t eq "leaf"' => { level => 'normal', } ] } }, 'upstream_default' => { type => 'leaf', level => 'hidden', value_type => 'string', description => 'Another way to specify a default value. But this default value is considered as "built_in" the application and is not written in the configuration data (unless modified)', warp => { follow => { 't' => '?type' }, 'rules' => [ '$t eq "leaf"' => { level => 'normal', } ] } }, 'convert' => { type => 'leaf', value_type => 'enum', level => 'hidden', description => 'Convert value or index to uppercase (uc) or lowercase (lc).', warp => { follow => { 't' => '?type' }, 'rules' => [ '$t eq "leaf" or $t eq "hash"' => { choice => [qw/uc lc/], level => 'normal', } ] } }, 'match' => { type => 'leaf', value_type => 'uniline', level => 'hidden', description => 'Perl regular expression to assert the validity of the value. To check the ' . q!whole value, use C<^> and C<$>. For instance C<^foo|bar$> allows ! . q!C or C but not C. To be case insentive, ! . q!use the C<(?i)> extended pattern. For instance, the regexp ! . q!C<^(?i)foo|bar$> also allows the values ! . q!C and C.!, @warp_in_string_like_parameter, }, 'assert' => { %assert_payload, description => 'Raise an error if the test code snippet does returns false. Note this snippet is ' . 'also run on undefined value, which may not be what you want.', }, 'warn_if' => { %assert_payload, description => 'Warn user if the code snippet returns true', }, 'warn_unless' => { %assert_payload, description => 'Warn user if the code snippet returns false', }, 'warn_if_match' => { %warn_if_match_payload, description => 'Warn user if a I value matches the regular expression. ', }, 'warn_unless_match' => { %warn_if_match_payload, description => 'Warn user if I value does not match the regular expression', }, 'warn' => { type => 'leaf', value_type => 'string', level => 'hidden', description => 'Unconditionally issue a warning with this string when this parameter is used. This should be used mostly with "accept"', warp => { follow => { t => '?type' }, 'rules' => [ '$t eq "leaf"' => { level => 'normal', }, ] }, }, 'grammar' => { type => 'leaf', value_type => 'string', level => 'hidden', description => "Feed this grammar to Parse::RecDescent to perform validation", @warp_in_string_like_parameter, }, 'default_list' => { type => 'check_list', level => 'hidden', refer_to => '- choice', description => 'Specify items checked by default', warp => { follow => { t => '?type', o => '?ordered' }, 'rules' => [ '$t eq "check_list" and not $o ' => { level => 'normal', }, '$t eq "check_list" and $o ' => { level => 'normal', ordered => 1, }, ] }, }, 'upstream_default_list' => { type => 'check_list', level => 'hidden', refer_to => '- choice', description => 'Specify items checked by default in the application', warp => { follow => { t => '?type', o => '?ordered' }, 'rules' => [ '$t eq "check_list" and not $o ' => { level => 'normal', }, '$t eq "check_list" and $o ' => { level => 'normal', ordered => 1, }, ] }, }, # hash element # list element ], ], ]; libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/ComputedValue.pl000066400000000000000000000022531477420254600276530ustar00rootroot00000000000000use strict; use warnings; return [ [ name => "Itself::ComputedValue", include => "Itself::MigratedValue" , element => [ allow_override => { type => 'leaf', value_type => 'boolean', compute => { formula => '$upstream_knowns', variables => { upstream_knowns => '- use_as_upstream_default', }, use_as_upstream_default => 1, }, level => 'normal', description => "Allow user to override computed value" .'For more details, see L ',, }, use_as_upstream_default => { type => 'leaf', value_type => 'boolean', upstream_default => 0, level => 'normal', description => "Indicate that the computed value is known by the " ."application and does not need to be written in the configuration file. Implies allow_override." }, ], ], ]; libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/Element.pl000066400000000000000000000100511477420254600264620ustar00rootroot00000000000000# Copyright (c) 2007-2008 Dominique Dumont. # # This file is part of Config-Model-Itself. # # Config-Model-Itself is free software; you can redistribute it # and/or modify it under the terms of the GNU Lesser Public License # as published by the Free Software Foundation; either version 2.1 # of the License, or (at your option) any later version. # # Config-Model-Itself 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 Lesser Public License for more details. # # You should have received a copy of the GNU Lesser Public License # along with Config-Model-Itself; if not, write to the Free Software # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA use strict; use warnings; return [ [ name => "Itself::Element", include => ['Itself::NonWarpableElement' ,'Itself::WarpableElement'], include_after => 'type' , 'element' => [ # structural information 'type' => { type => 'leaf', value_type => 'enum', choice => [qw/node warped_node hash list leaf check_list/], mandatory => 1 , description => 'specify the type of the configuration element.' . 'Leaf is used for plain value.', }, # all elements 'status' => { type => 'leaf', value_type => 'enum', choice => [qw/obsolete deprecated standard/], upstream_default => 'standard' , }, 'level' => { type => 'leaf', value_type => 'enum', choice => [qw/important normal hidden/] , upstream_default => 'normal', description => 'Used to highlight important parameter or to hide others. Hidden parameter are mostly used to hide features that are unavailable at start time. They can be made available later using warp mechanism', }, 'summary' => { type => 'leaf', value_type => 'uniline', description => 'enter short information regarding this element', }, 'description' => { type => 'leaf', value_type => 'string', description => 'enter detailed help information regarding this element', }, # all but node or warped_node 'warp' => { type => 'warped_node', level => 'hidden', config_class_name => 'Itself::WarpValue', warp => { follow => { elt_type => '- type' }, rules => [ '$elt_type ne "node"' => { level => 'normal' } ] }, description => "change the properties (i.e. default value or its value_type) dynamically according to the value of another Value object located elsewhere in the configuration tree. " }, # hash or list 'index_type' => { type => 'leaf', value_type => 'enum', level => 'hidden' , warp => { follow => '?type', 'rules' => { 'hash' => { level => 'important', mandatory => 1, choice => [qw/string integer/] , } } }, description => 'Specify the type of allowed index for the hash. "String" means no restriction.', }, 'cargo' => { type => 'warped_node', level => 'hidden', warp => { follow => { 't' => '- type' }, 'rules' => [ '$t eq "list" or $t eq "hash"' => { level => 'normal', config_class_name => 'Itself::CargoElement', }, ], }, description => 'Specify the properties of the configuration element configuration in this hash or list', } ], ], ]; libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/MigratedValue.pl000066400000000000000000000057621477420254600276370ustar00rootroot00000000000000use strict; use warnings; return [ [ name => "Itself::MigratedValue", element => [ variables => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'uniline' } , description => 'Specify where to find the variables using path notation. For the formula ' .'"$a + $b", you need to specify "a => \'- a_path\', b => \'! b_path\'. ' .'Functions like C<&index()> are allowed. ' .'For more details, see L ', }, formula => { type => 'leaf', value_type => 'string', # making formula mandatory makes mandatory setting the # compute parameter for a leaf. That's not a # desired behavior. # mandatory => 1 , description => 'Specify how the computation is done. This string can a Perl expression for ' .'integer value or a template for string values. Variables have the same notation ' .'than in Perl. Example "$a + $b". ' .'Functions like C<&index()> are allowed. ' .'For more details, see L ', }, replace => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string' } , description => 'Sometime, using the value of a tree leaf is not enough and you need to ' .'substitute a replacement for any value you can get. This replacement can be done ' .'using a hash like notation within the formula using the %replace hash. Example ' .'$replace{$who} , where "who => \'- who_elt\'. ' .'For more details, see L', }, use_eval => { type => 'leaf', value_type => 'boolean', upstream_default => 0, description => 'Set to 1 if you need to perform more complex operations than substition, ' .'like extraction with regular expressions. This forces an eval by Perl when ' .'computing the formula. The result of the eval is used as the computed value.' }, undef_is => { type => 'leaf', value_type => 'uniline', description => 'Specify a replacement for undefined variables. This replaces C' .' values in the formula before migrating values. Use \'\' (2 single quotes) ' . 'if you want to specify an empty string. ' .'For more details, see L', }, ], ], ]; libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/Model.pl000066400000000000000000000016561477420254600261440ustar00rootroot00000000000000use strict; use warnings; return [ [ name => "Itself::Model", element => [ class => { type => 'hash', index_type => 'string' , ordered => 1, cargo => { type => 'node', config_class_name => 'Itself::Class' , }, }, application => { type => 'hash', index_type => 'string', level => 'important', cargo => { type => 'node', config_class_name => 'Itself::Application', }, }, ], description => [ class => 'A configuration model is made of several configuration classes.', application => 'defines the application name provided by user to cme. E.g. cme edit ' ], ], ]; libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/NonWarpableElement.pl000066400000000000000000000242611477420254600306230ustar00rootroot00000000000000# Copyright (c) 2007-2011 Dominique Dumont. # # This file is part of Config-Model-Itself. # # Config-Model-Itself is free software; you can redistribute it # and/or modify it under the terms of the GNU Lesser Public License # as published by the Free Software Foundation; either version 2.1 # of the License, or (at your option) any later version. # # Config-Model-Itself 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 Lesser Public License for more details. # # You should have received a copy of the GNU Lesser Public License # along with Config-Model-Itself; if not, write to the Free Software # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA use strict; use warnings; return [ [ name => 'Itself::NonWarpableElement', # warp often depend on this one, so list it first 'element' => [ 'value_type' => { type => 'leaf', level => 'hidden', value_type => 'enum', choice => [ qw/boolean enum integer reference number uniline string file dir/ ], 'warp' => { follow => { 't' => '- type' }, 'rules' => [ '$t eq "leaf"' => { level => 'normal', mandatory => 1, } ] }, help => { integer => 'positive or negative integer', uniline => 'string with no embedded newline', } }, 'class' => { type => 'leaf', level => 'hidden', value_type => 'uniline', summary => "Override implementation of element", description => "Perl class name used to override the implementation of the configuration element. " ."This override Perl class must inherit a Config::Model class that matches the element type, " ."i.e. Config::Model::Value, Config::Model::HashId or Config::Model::ListId. " ."Use with care.", 'warp' => { follow => { 't' => '- type' }, 'rules' => [ '$t and $t !~ /node/' => { level => 'normal', } ] } }, 'morph' => { type => 'leaf', level => 'hidden', value_type => 'boolean', 'warp' => { follow => '- type', 'rules' => { 'warped_node' => { level => 'normal', upstream_default => 0, }, } }, description => "When set, a recurse copy of the value from the old object " . "to the new object is attempted. Old values are dropped when " ." a copy is not possible (usually because of mismatching types)." }, # end warp elements for warped_node # leaf element 'refer_to' => { type => 'leaf', level => 'hidden', value_type => 'uniline', warp => { follow => { t => '- type', vt => '- value_type', }, 'rules' => [ '$t eq "check_list" or $vt eq "reference"' => { level => 'important', }, ] }, description => "points to an array or hash element in the configuration " . "tree using L. " . "The available choice of this " . "reference value (or check list)is made from the available " . "keys of the pointed hash element or the values of the pointed array element.", }, 'computed_refer_to' => { type => 'warped_node', level => 'hidden', warp => { follow => { t => '- type', vt => '- value_type', }, 'rules' => [ '$t eq "check_list" or $vt eq "reference"' => { level => 'normal', config_class_name => 'Itself::ComputedValue', }, ], }, description => "points to an array or hash element in the configuration " . "tree using a path computed with value from several other " . "elements in the configuration tree. The available choice " . "of this reference value (or check list) is made from the " . "available keys of the pointed hash element or the values " . "of the pointed array element. The keys of several hashes (or lists) " . "can be combined by using the '+' operator in the formula. " . q(For instance, '! host:$a lan + ! host:foobar lan'. See ) . "L for more details." }, 'replace_follow' => { type => 'leaf', level => 'hidden', value_type => 'uniline', warp => { follow => { t => '- type' }, 'rules' => [ '$t eq "leaf"' => { level => 'important', }, ] }, description => "Path specifying a hash of value element in the configuration " . "tree. The hash if used in a way similar to the replace " . "parameter. In this case, the replacement is not coded " . "in the model but specified by the configuration.", }, 'compute' => { type => 'warped_node', level => 'hidden', warp => { follow => { t => '- type', }, 'rules' => [ '$t eq "leaf"' => { level => 'normal', config_class_name => 'Itself::ComputedValue', }, ], }, description => "compute the default value according to a formula and value " . "from other elements in the configuration tree.", }, 'migrate_from' => { type => 'warped_node', level => 'hidden', warp => { follow => { t => '- type', }, 'rules' => [ '$t eq "leaf"' => { level => 'normal', config_class_name => 'Itself::MigratedValue', }, ], }, description => "Specify an upgrade path from an old value and compute " . "the value to store in the new element.", }, 'write_as' => { type => 'list', level => 'hidden', max_index => 1, warp => { follow => { t => '- type', vt => '- value_type'}, rules => [ '$t eq "leaf" and $vt eq "boolean"' => { level => 'normal', }, ] }, cargo => { type => 'leaf', value_type => 'uniline', }, description => "Specify how to write a boolean value. Example 'no' 'yes'.", }, # hash or list element migrate_values_from => { type => 'leaf', level => 'hidden', value_type => 'uniline', warp => { follow => { 't' => '?type' }, 'rules' => [ '$t eq "hash" or $t eq "list"' => { level => 'normal', } ] } , description => 'Specifies that the values of the hash or list are copied ' . 'from another hash or list in the configuration tree once configuration ' . 'data are loaded.', }, # hash element migrate_keys_from => { type => 'leaf', level => 'hidden', value_type => 'uniline', warp => { follow => { 't' => '?type' }, 'rules' => [ '$t eq "hash"' => { level => 'normal', } ] }, description => 'Specifies that the keys of the hash are copied from another hash ' . 'in the configuration tree only when the hash is created.', }, write_empty_value => { type => 'leaf', level => 'hidden', value_type => 'boolean', upstream_default => 0, warp => { follow => { 't' => '?type' }, rules => [ '$t eq "hash"' => { level => 'normal', } ] }, description => 'By default, hash entries without data are not saved in configuration ' . 'files. Set this parameter to 1 if a key must be saved in the configuration ' . 'file even if the hash contains no value for that key.', }, # list element ], ], ]; libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/WarpOnlyElement.pl000066400000000000000000000016621477420254600301660ustar00rootroot00000000000000use strict; use warnings; return [ [ name => "Itself::WarpOnlyElement", include => 'Itself::WarpableElement' , 'element' => [ 'level' => { type => 'leaf', value_type => 'enum', choice => [qw/important normal hidden/] , }, 'index_type' => { type => 'leaf', value_type => 'enum', level => 'hidden' , warp => { follow => '?type', 'rules' => { 'hash' => { level => 'important', #mandatory => 1, choice => [qw/string integer/] , } } }, description => 'Specify the type of allowed index for the hash. "String" means no restriction.', }, ], 'description' => [ level => 'Used to highlight important parameter or to hide others. Hidden parameter are mostly used to hide features that are unavailable at start time. They can be made available later using warp mechanism', ], ], ]; libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/WarpValue.pl000066400000000000000000000030311477420254600267770ustar00rootroot00000000000000use strict; use warnings; return [ [ name => "Itself::WarpValue", class_description => 'Warp functionality enable a Value object to change its properties (i.e. default value or its type) dynamically according to the value of another Value object locate elsewhere in the configuration tree.', 'element' => [ 'follow' => { type => 'hash', index_type =>'string', cargo => { type => 'leaf', value_type => 'uniline' } , description => 'Specify with the path of the configuration element that drives ' .'the warp, i.e .the elements that control the property change. ' .'These are specified using a variable name (used in the "rules" formula)' .'and a path to fetch the actual value. Example $country => " ! country"', }, 'rules' => { type => 'hash', ordered => 1, index_type => 'string', cargo => { type => 'warped_node', warp => { rules => [ '&get_type =~ /hash|list/' => { config_class_name => 'Itself::WarpableCargoElement' }, '&get_type !~ /hash|list/' => { config_class_name => 'Itself::WarpOnlyElement' , } ] } }, description => 'Each key of the hash is a test (as formula using the variables defined in "follow" element) that are tried in sequences to apply its associated effects', }, ], ], ]; libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/WarpableCargoElement.pl000066400000000000000000000020511477420254600311150ustar00rootroot00000000000000# Copyright (c) 2007-2008 Dominique Dumont. # # This file is part of Config-Model-Itself. # # Config-Model-Itself is free software; you can redistribute it # and/or modify it under the terms of the GNU Lesser Public License # as published by the Free Software Foundation; either version 2.1 # of the License, or (at your option) any later version. # # Config-Model-Itself 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 Lesser Public License for more details. # # You should have received a copy of the GNU Lesser Public License # along with Config-Model-Itself; if not, write to the Free Software # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA use strict; use warnings; return [ [ name => "Itself::WarpableCargoElement", include => 'Itself::CommonElement' , class_description => 'attributes that can be warped within cargo of a hash or list element', ], ]; libconfig-model-itself-perl-2.025/lib/Config/Model/models/Itself/WarpableElement.pl000066400000000000000000000155541477420254600301550ustar00rootroot00000000000000# Copyright (c) 2007-2011 Dominique Dumont. # # This file is part of Config-Model-Itself. # # Config-Model-Itself is free software; you can redistribute it # and/or modify it under the terms of the GNU Lesser Public License # as published by the Free Software Foundation; either version 2.1 # of the License, or (at your option) any later version. # # Config-Model-Itself 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 Lesser Public License for more details. # # You should have received a copy of the GNU Lesser Public License # along with Config-Model-Itself; if not, write to the Free Software # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA use strict; use warnings; return [ [ name => "Itself::WarpableElement", include => 'Itself::CommonElement', 'element' => [ [ qw/allow_keys_from allow_keys_matching follow_keys_from warn_if_key_match warn_unless_key_match/ ] => { type => 'leaf', level => 'hidden', value_type => 'uniline', warp => { follow => { 't' => '?type' }, 'rules' => [ '$t eq "hash"' => { level => 'normal', } ] } }, [qw/ordered/] => { type => 'leaf', level => 'hidden', value_type => 'boolean', warp => { follow => { 't' => '?type' }, 'rules' => [ '$t eq "hash" or $t eq "check_list"' => { level => 'normal', } ] } }, [qw/default_keys auto_create_keys allow_keys/] => { type => 'list', level => 'hidden', cargo => { type => 'leaf', value_type => 'string' }, warp => { follow => { 't' => '?type' }, 'rules' => [ '$t eq "hash"' => { level => 'normal', } ] } }, [qw/auto_create_ids/] => { type => 'leaf', level => 'hidden', value_type => 'string', warp => { follow => { 't' => '?type' }, 'rules' => [ '$t eq "list"' => { level => 'normal', } ] } }, [qw/default_with_init/] => { type => 'hash', level => 'hidden', index_type => 'string', cargo => { type => 'leaf', value_type => 'string' }, warp => { follow => { 't' => '?type' }, 'rules' => [ '$t eq "hash" or $t eq "list"' => { level => 'normal', } ] } }, 'max_nb' => { type => 'leaf', level => 'hidden', value_type => 'integer', warp => { follow => { 'type' => '?type', }, 'rules' => [ '$type eq "hash"' => { level => 'normal', } ] } }, 'replace' => { type => 'hash', index_type => 'string', level => 'hidden', warp => { follow => { 't' => '?type' }, 'rules' => [ '$t eq "leaf" or $t eq "check_list"' => { level => 'normal', } ] }, # TBD this could be a reference if we restrict replace to # enum value... cargo => { type => 'leaf', value_type => 'string' }, }, [ qw/duplicates/ ] => { type => 'leaf', level => 'hidden', value_type => 'enum', choice => [qw/allow suppress warn forbid/], upstream_default => 'allow', warp => { follow => { 't' => '?type' }, 'rules' => [ '$t eq "hash" or $t eq "list"' => { level => 'normal', } ] } }, help => { type => 'hash', index_type => 'string', level => 'hidden', warp => { follow => { 't' => '?type' }, 'rules' => [ '$t eq "leaf" or $t eq "check_list"' => { level => 'normal', } ] }, # TBD this could be a reference if we restrict replace to # enum value... cargo => { type => 'leaf', value_type => 'string' }, }, ], 'description' => [ follow_keys_from => 'this hash contains the same keys as the hash pointed by the path string', allow_keys_from => 'this hash allows keys from the keys of the hash pointed by the path string', ordered => 'keep track of the order of the elements of this hash', default_keys => 'default keys hashes.', auto_create_keys => 'always create a set of keys specified in this list', auto_create_ids => 'always create the number of id specified in this integer', allow_keys => 'specify a set of allowed keys', allow_keys_matching => 'Keys must match the specified regular expression.', default_with_init => 'specify a set of keys to create and initialization on some elements . E.g. \' foo => "X=Av Y=Bv", bar => "Y=Av Z=Cz"\' ', help => 'Specify help string applicable to values. The keys are regexp matched to the beginning of the value. See C parameter of L for more possibilities', replace => 'Used for enum to substitute one value with another. This parameter must be used to enable user to upgrade a configuration with obsolete values. The old value is the key of the hash, the new one is the value of the hash', warn_if_key_match => 'Warn user if a key is created matching this regular expression', warn_unless_key_match => 'Warn user if a key is created not matching this regular expression', duplicates => 'Specify the policy regarding duplicated values stored in the list or as hash values (valid only when cargo type is "leaf"). The policy can be "allow" (default), "suppress", "warn" (which offers the possibility to apply a fix), "forbid".', ], ], ]; libconfig-model-itself-perl-2.025/t/000077500000000000000000000000001477420254600172565ustar00rootroot00000000000000libconfig-model-itself-perl-2.025/t/application.t000066400000000000000000000037731477420254600217600ustar00rootroot00000000000000# -*- cperl -*- use ExtUtils::testlib; use Test::More ; use Config::Model 2.138; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use Path::Tiny; use Config::Model::Itself ; use File::Copy::Recursive qw(fcopy rcopy dircopy); use Test::Memory::Cycle; use 5.10.1; use warnings; use strict; my ($meta_model, $trace) = init_test(); # do search for the models created in this test use lib "wr_root/itself/lib"; my $wr_test = setup_test_dir ; my $wr_lib = $wr_test->child("lib"); my $wr_model1 = $wr_lib->child("wr_model1"); $wr_model1->mkpath; # copy test model dircopy('data',$wr_model1->stringify) || die "cannot copy model data:$!" ; my $model = Config::Model->new( model_dir => $wr_model1->child("models")->relative($wr_lib)->stringify ) ; ok(1,"loaded Master model") ; # ok now we can load test model in Itself my $meta_inst = $meta_model -> instance ( root_class_name => 'Itself::Model', instance_name => 'itself_instance', root_dir => $wr_model1->stringify, ); ok($meta_inst,"Read Itself::Model and created instance") ; my $meta_root = $meta_inst -> config_root ; my $rw_obj = Config::Model::Itself -> new( model_object => $meta_root, cm_lib_dir => $wr_model1->stringify, ) ; ok($rw_obj,"Created model reader/writer"); $rw_obj->read_all( root_model => 'MasterModel', legacy => 'ignore', ) ; ok(1,"Read all models in data dir") ; is_deeply( [ $meta_root->grab('application')->fetch_all_indexes ], [ qw/goner master/], "check that 2 application files were read" ); # remove dummy application $meta_root->load("application:.rm(goner)"); is_deeply( [ $meta_root->grab('application')->fetch_all_indexes ], [ qw/master/], "check that 1 application is left" ); $rw_obj -> write_all(); ok(1,"Wrote back model") ; ok( ! $wr_model1->child('application.d/goner')->exists, "check that goner application file was removed" ); note("testing memory cycles. Please wait..."); memory_cycle_ok($meta_model, "Check memory cycle"); done_testing; libconfig-model-itself-perl-2.025/t/backend_detect.t000066400000000000000000000030471477420254600223660ustar00rootroot00000000000000# -*- cperl -*- use ExtUtils::testlib; use Test::More ; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Test::Memory::Cycle; use warnings; use strict; my ($model, $trace) = init_test(); $model ->create_config_class ( name => "Master", 'element' => [ 'backend' => { type => 'leaf', class => 'Config::Model::Itself::BackendDetector' , value_type => 'enum', choice => [qw/cds_file perl_file ini_file custom/], help => { cds_file => "file ...", ini_file => "Ini file ...", perl_file => "file perl", custom => "Custom format", } } ], ); ok(1,"test class created") ; my $root = $model->instance(root_class_name => 'Master') -> config_root ; my $backend = $root->fetch_element('backend') ; my @choices = $backend->get_choice ; ok( (scalar grep { $_ eq 'IniFile'} @choices), "IniFile plugin backend was found") ; SKIP: { skip "this help is available after Config::Model is built", 1 unless $Config::Model::VERSION < 3; # test break when using directly Config::Model repo because get_help # retrieves info from NAME section which is added at build time by # Pod::Weaver my $help = $backend->get_help('IniFile') ; like($help,qr/provided by L/, "Found IniFile doc in pod") ; } my $help = $backend->get_help('cds_file') ; is($help,"file ...", "cds_file help was kept") ; memory_cycle_ok($model, "memory cycle"); done_testing; libconfig-model-itself-perl-2.025/t/cme-meta-edit.t000066400000000000000000000017621477420254600220640ustar00rootroot00000000000000# -*- cperl -*- use warnings; use strict; use 5.10.1; use Test::More ; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Path::Tiny; use Test::File::Contents; use Getopt::Long; use App::Cmd::Tester; use App::Cme ; use Tk; init_test(); # edit and plugin need to be in separate test files. Otherwise the 2 # Tk widgets created one after the other interacts badly and the save # callback of -save-and-quit option is not called after the first test. SKIP: { my $mw = eval { MainWindow-> new ; }; # cannot create Tk window skip "Cannot create Tk window",1 if $@; $mw->destroy ; { my $result = test_app( 'App::Cme' => [ qw/meta edit fstab -system -test-and-quit q/ ]) ; is($result->stderr, '', 'nothing sent to sderr'); is($result->error, undef, 'threw no exceptions'); like($result->stdout , qr/Reading model from/, "edit and quit"); like($result->stdout , qr/Test mode: quit/, "edit is in test mode"); } } done_testing; libconfig-model-itself-perl-2.025/t/cme-meta-plugin.t000066400000000000000000000035311477420254600224310ustar00rootroot00000000000000# -*- cperl -*- use warnings; use strict; use 5.10.1; use Test::More ; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Path::Tiny; use Test::File::Contents; use App::Cmd::Tester; use App::Cme ; use Tk; my ($model, $trace) = init_test(); # edit and plugin need to be in separate test files. Otherwise the 2 # Tk widgets created one after the other interacts badly and the save # callback of -save-and-quit option is not called after the first test. SKIP: { my $mw = eval { MainWindow-> new ; }; # cannot create Tk window skip "Cannot create Tk window",1 if $@; $mw->destroy ; my $wr_test = path('wr_test/plugin-ui') ; $wr_test->remove_tree if $wr_test->is_dir; $wr_test->mkpath; $wr_test->child('models')->mkpath; { # test plugin my $plug_data = q!class:"Fstab::CommonOptions" element:async mandatory=1 !; my $plug = $wr_test->child('plug.cds'); $plug->spew($plug_data); my @test_args = ( qw/meta plugin fstab my-plugin/, '-test-and-quit' => 's', '-load' => $plug->stringify, '-dir' => $wr_test->stringify, ); say "test command: cme @test_args" if $trace; my $result = test_app( 'App::Cme' => \@test_args ) ; is($result->error, undef, 'threw no exceptions'); is($result->stderr, '', 'nothing sent to sderr'); say "-- stdout --\n", $result->stdout,"-----" if $trace; like($result->stdout , qr/Preparing plugin my-plugin for model Fstab/, "edit plugin and quit"); like($result->stdout , qr/Test mode: save and quit/, "edit plugin is in test mode"); my $plug_out = $wr_test->child('models/Fstab.d/my-plugin/Fstab/CommonOptions.pl'); file_contents_like $plug_out, qr/'mandatory' => '1'/, "check content of $plug_out"; } } done_testing; libconfig-model-itself-perl-2.025/t/cme-meta.t000066400000000000000000000047211477420254600211370ustar00rootroot00000000000000# -*- cperl -*- use warnings; use strict; use 5.10.1; use Test::More ; use Config::Model; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use Path::Tiny; use Test::File::Contents; use App::Cmd::Tester; use App::Cme ; binmode STDOUT, ':encoding(UTF-8)'; my ($model, $trace) = init_test(); my $wr_test = setup_test_dir ; SKIP: { skip "dev list does not yet work" ,1 ; my $result = test_app( 'App::Cme' => [ qw/list/]) ; like($result->stdout , qr/meta/, "meta sub command is found in dev env"); is($result->stderr, '', 'nothing sent to sderr'); is($result->error, undef, 'threw no exceptions'); } { my $result = test_app( 'App::Cme' => [ qw/help meta/]) ; like($result->stdout , qr/create configuration checker or editor/, "check help"); is($result->stderr, '', 'nothing sent to sderr'); is($result->error, undef, 'threw no exceptions'); } { my $result = test_app( 'App::Cme' => [ qw/meta check fstab -system/]) ; like($result->stdout , qr/checking data/, "meta check fstab"); is($result->stderr, '', 'nothing sent to sderr'); is($result->error, undef, 'threw no exceptions'); } # TODO: group tests with Test::Class or Test::Group ? { my $cds_out = $wr_test->child('fstab.cds'); my $result = test_app( 'App::Cme' => [ qw/meta dump fstab -system/, $cds_out->stringify ]) ; like($result->stdout , qr/Dumping Fstab/, "dump fstab model in $cds_out"); is($result->stderr, '', 'nothing sent to sderr'); is($result->error, undef, 'threw no exceptions'); file_contents_like $cds_out, qr/^class:Fstab/, "check content of $cds_out"; } { my $yaml_out = $wr_test->child('fstab.yml'); my $result = test_app( 'App::Cme' => [ qw/meta dump-yaml fstab -system/, $yaml_out->stringify ]) ; like($result->stdout , qr/Dumping Fstab/, "dump fstab model in $yaml_out"); is($result->stderr, '', 'nothing sent to sderr'); is($result->error, undef, 'threw no exceptions'); file_contents_like $yaml_out, qr/class:\n\s+Fstab:\n/, "check content of $yaml_out"; } { my $dot_out = $wr_test->child('fstab.dot'); my $result = test_app( 'App::Cme' => [ qw/meta gen-dot fstab -system/, $dot_out->stringify ]) ; like($result->stdout , qr/Creating dot file/, "dot diagram of Fstab in $dot_out"); is($result->stderr, '', 'nothing sent to sderr'); is($result->error, undef, 'threw no exceptions'); file_contents_like $dot_out, qr/Fstab -> Fstab__FsLine/, "check content of $dot_out"; } done_testing; libconfig-model-itself-perl-2.025/t/dot_graph.t000066400000000000000000000023051477420254600214120ustar00rootroot00000000000000# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Path::Tiny; use Config::Model; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use Test::Memory::Cycle; use Config::Model::Itself ; use warnings; use strict; my ($meta_model, $trace) = init_test(); my $wr_root = setup_test_dir; my $meta_inst = $meta_model-> instance ( root_class_name => 'Itself::Model', instance_name => 'itself_instance', root_dir => "data", ); ok($meta_inst,"Read Itself::Model and created instance") ; my $meta_root = $meta_inst -> config_root ; my $model_dir = path($INC{'Config/Model/Itself.pm'})->parent; note("Reading models from $model_dir"); my $rw_obj = Config::Model::Itself -> new( model_object => $meta_root, cm_lib_dir => $model_dir, ) ; my $map = $rw_obj -> read_all( root_model => 'Itself', force_load => 1, ) ; ok(1,"Read all models from $model_dir") ; my $dot_file = $wr_root->child("config-test.dot"); my $res = $rw_obj->get_dot_diagram ; ok($res,"got dot data, writting in $dot_file...") ; print $res if $trace ; $dot_file->spew_utf8($res); note("testing memory cycles, please wait..."); memory_cycle_ok($meta_model, "memory cycle"); done_testing; libconfig-model-itself-perl-2.025/t/itself-editor.t000066400000000000000000000104161477420254600222170ustar00rootroot00000000000000# -*- cperl -*- use Test::More ; use Config::Model; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use Config::Model::Itself ; use Tk ; use Path::Tiny; use Config::Model::Itself::TkEditUI; use File::Copy::Recursive qw(fcopy rcopy dircopy); use Test::Memory::Cycle; use warnings; use strict; $File::Copy::Recursive::DirPerms = oct(755); my ($meta_model, $trace, $args) = init_test('show','interactive'); note("You can play with the widget if you run the test with '--show' parameter"); my $wr_test = setup_test_dir ; my $wr_conf1 = $wr_test->child("wr_conf1"); my $wr_lib = $wr_test->child("lib"); my $wr_model1 = $wr_lib->child("wr_model1"); use lib "wr_root/itself-editor/lib"; { no warnings "redefine" ; sub Tk::Error { my ($widget,$error,@locations) = @_; die $error ; } } $wr_conf1->mkpath; $wr_model1->mkpath; $wr_conf1->child("etc/ssh")->mkpath; dircopy('data',$wr_model1->stringify) || die "cannot copy model data:$!" ; # cannot use $meta_model as the model dir are different my $model = Config::Model->new( model_dir => $wr_model1->child("models")->relative($wr_lib)->stringify ) ; ok(1,"loaded Master model") ; # check that Master Model can be loaded by Config::Model my $inst1 = $model->instance ( root_class_name => 'MasterModel', instance_name => 'test_orig', root_dir => $wr_conf1->stringify, ); ok($inst1,"created master_model instance") ; my $root1 = $inst1->config_root ; my @elt1 = $root1->get_element_name ; $root1->load("a_string=toto lot_of_checklist macro=AD - " ."! warped_values macro=C where_is_element=get_element " ." get_element=m_value_element m_value=Cv") ; ok($inst1,"loaded some data in master_model instance") ; # do search for the models created in this test my $meta_inst = $meta_model->instance( root_class_name => 'Itself::Model', instance_name => 'itself_instance', ); ok( $meta_inst, "Read Itself::Model and created instance" ); $meta_inst->initial_load_start ; my $meta_root = $meta_inst -> config_root ; my $rw_obj = Config::Model::Itself -> new( model_object => $meta_root, cm_lib_dir => $wr_model1->stringify, ) ; my $map = $rw_obj->read_all( root_model => 'MasterModel', legacy => 'ignore', ); $meta_inst->initial_load_stop ; ok(1,"Read all models in data dir") ; SKIP: { my $mw = eval { MainWindow-> new ; }; # cannot create Tk window skip "Cannot create Tk window",8 if $@; $mw->withdraw ; my $write_sub = sub { $rw_obj->write_all(); } ; my $cmu = $mw->ConfigModelEditUI ( -instance => $meta_inst, -root_dir => $wr_conf1->stringify, -cm_lib_dir => $wr_model1->relative($wr_lib)->stringify , -store_sub => $write_sub, -model_name => 'MasterModel', ) ; my $delay = 500 ; my $tktree= $cmu->Subwidget('tree') ; my $mgr = $cmu->Subwidget('multi_mgr') ; my @test = ( view => sub { $cmu->create_element_widget('view','itself_instance.class');}, open_class => sub { $tktree->open('itself_instance.class');1;}, open_instance => sub{$tktree->open('itself_instance.class.MasterModel');1;}, # save step is mandatory to avoid interaction save => sub { $cmu -> save ; 1;}, 'open test window' => sub { $cmu -> test_model ; }, 'reopen test window' => sub { $cmu -> test_model ; }, exit => sub { $cmu->quit ; 1;} ); unless ($args->{show} || $args->{interactive}) { my $step = 0; # build a FILO queue of test subs my $oldsub ; while (@test) { # iterate through test list in reverse order my $t = pop @test ; my $k = pop @test ; my $next_sub = $oldsub ; my $s = sub { my $res = &$t; ok($res,"Tk UI step ".$step++." $k done"); $mw->after($delay, $next_sub) if defined $next_sub; }; $oldsub = $s ; } $mw->after($delay, $oldsub) ; # will launch first test } ok(1,"window launched") ; MainLoop ; # Tk's } note("testing memory cycles. Please wait..."); memory_cycle_ok($meta_model,"memory cycles"); done_testing; libconfig-model-itself-perl-2.025/t/itself.t000066400000000000000000000170761477420254600207440ustar00rootroot00000000000000# -*- cperl -*- use ExtUtils::testlib; use Test::More ; use Config::Model 2.142; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use Data::Dumper ; use Path::Tiny; use Config::Model::Itself ; use File::Copy::Recursive qw(fcopy rcopy dircopy); use Test::Memory::Cycle; use Test::File::Contents; use warnings; use strict; my ($meta_model, $trace) = init_test(); # do search for the models created in this test use lib "wr_root/itself/lib"; my $wr_test = setup_test_dir ; my $wr_conf1 = $wr_test->child("wr_conf1"); my $wr_lib = $wr_test->child("lib"); my $wr_model1 = $wr_lib->child("wr_model1"); my $wr_model2 = $wr_lib->child("wr_model2"); $wr_model1->mkpath; $wr_model2->mkpath; $wr_conf1->child("etc/ssh")->mkpath; # copy test model dircopy('data',$wr_model1->stringify) || die "cannot copy model data:$!" ; my $model = Config::Model->new( model_dir => $wr_model1->child("models")->relative($wr_lib)->stringify ) ; ok(1,"loaded Master model") ; # check that Master Model can be loaded by Config::Model my $inst1 = $model->instance ( root_class_name => 'MasterModel', instance_name => 'test_orig', root_dir => $wr_conf1->stringify, ); ok($inst1,"created master_model instance") ; my $root1 = $inst1->config_root ; my @elt1 = $root1->get_element_name ; $root1->load("a_string=toto lot_of_checklist macro=AD - " ."! warped_values macro=C where_is_element=get_element " ." get_element=m_value_element m_value=Cv " ."! assert_leaf=foo leaf_with_warn_unless=bar") ; ok($inst1,"loaded some data in master_model instance") ; my $dump1 = $root1->dump_tree(mode => 'backend') ; ok($dump1,"dumped master instance") ; # ok now we can load test model in Itself my $meta_inst = $meta_model -> instance ( root_class_name => 'Itself::Model', instance_name => 'itself_instance', root_dir => $wr_model1->stringify, ); ok($meta_inst,"Read Itself::Model and created instance") ; my $meta_root = $meta_inst -> config_root ; my $rw_obj = Config::Model::Itself -> new( model_object => $meta_root, cm_lib_dir => $wr_model1->stringify, ) ; my $map = $rw_obj -> read_all( root_model => 'MasterModel', legacy => 'ignore', ) ; ok(1,"Read all models in data dir") ; print $meta_model->list_class_element if $trace ; my $expected_map = { 'MasterModel/HashIdOfValues.pl' => [ 'MasterModel::HashIdOfValues' ], 'MasterModel/CheckListExamples.pl' => [ 'MasterModel::CheckListExamples' ], 'MasterModel.pl' => [ 'MasterModel::SubSlave2', 'MasterModel::SubSlave', 'MasterModel::SlaveZ', 'MasterModel::SlaveY', 'MasterModel::TolerantNode', 'MasterModel' ], 'MasterModel/WarpedId.pl' => [ 'MasterModel::WarpedIdSlave', 'MasterModel::WarpedId' ], 'MasterModel/X_base_class.pl' => [ 'MasterModel::X_base_class2', 'MasterModel::X_base_class', ], 'MasterModel/WarpedValues.pl' => [ 'MasterModel::RSlave', 'MasterModel::Slave', 'MasterModel::WarpedValues' ], 'MasterModel/References.pl' => [ 'MasterModel::References::Host', 'MasterModel::References::If', 'MasterModel::References::Lan', 'MasterModel::References::Node', 'MasterModel::References' ], 'MasterModel/ToTrash.pl' => [ 'MasterModel::ToTrash' ], }; is_deeply($expected_map, $map, "Check file class map") ; print Dumper $map if $trace ; # check that deprecated backend specs are removed my $master_model = $meta_inst->grab('class:MasterModel'); # check => skip prevents deprecation warnings is($master_model->grab_value('rw_config backend'), 'cds_file', "read_config data was migrated in rw_config"); is($master_model->grab_value('rw_config file'), 'mymaster.cds', "write_config data was migrated in rw_config"); # add a new class $meta_root->load("class:Master::Created element:created1 type=leaf value_type=number" ." - element:created2 type=leaf value_type=uniline") ; ok(1,"added new class Master::Created") ; $meta_root->load("class:.rm(MasterModel::ToTrash)"); ok(1, "removed class ToTrash"); my $cds = $meta_root->dump_tree () ; my @cds_orig = split /\n/,$cds ; unlike($cds,qr/ToTrash/, "class to trash was removed from model"); print $cds if $trace ; ok($cds,"dumped full tree in cds format") ; #like($cds,qr/dumb/,"check for a peculiar warp effet") ; $wr_conf1->child("orig.cds")->spew($cds); $rw_obj -> write_all(); ok( ! $wr_model1->child("models/MasterModel/ToTrash.pl")->exists, "trashed model is not written back"); #create a 2nd empty model my $meta_inst2 = $meta_model->instance ( root_class_name => 'Itself::Model', instance_name => 'itself_instance2' ); my $meta_root2 = $meta_inst2 -> config_root ; # no check since included classes can be specified before they are # loaded. $meta_root2 -> load (steps => $cds, check => 'no') ; ok(1,"Created and loaded 2nd instance") ; my $cds2 = $meta_root2 ->dump_tree () ; $wr_conf1->child("inst2.cds")->spew($cds2); is_deeply([split /\n/,$cds2],\@cds_orig,"Compared the 2 full dumps") ; my $pdata2 = $meta_root2 -> dump_as_data ; print Dumper $pdata2 if $trace ; $wr_conf1->child("inst2.pl")->spew(Dumper $pdata2); my $rw_obj2 = Config::Model::Itself -> new( model_object => $meta_root2, cm_lib_dir => $wr_model2->stringify, force_write => 1, ) ; $rw_obj2 -> write_all(); my $written_model_file = $wr_model2->child("models/MasterModel.pl"); file_contents_like $written_model_file, qr/use strict;/, "stricture was added when writing file"; # create 3rd instance my $meta_inst3 = $meta_model->instance ( root_class_name => 'Itself::Model', instance_name => 'itself_instance3' ); my $meta_root3 = $meta_inst3 -> config_root ; $meta_root3 -> load_data (data => $pdata2, check => 'no') ; ok(1,"Created and loaded 3nd instance with perl data") ; my $cds3 = $meta_root3 ->dump_tree () ; $wr_conf1->child("inst3.cds")->spew($cds3); is_deeply([split /\n/,$cds3],\@cds_orig,"Compared the 3rd full dump with first one") ; # check dump of one class my $dump = $rw_obj -> get_perl_data_model ( class_name => 'MasterModel' ) ; print Dumper $dump if $trace ; ok($dump,"Checked dump of one class"); $rw_obj->write_all( ) ; my $model4 = Config::Model->new( legacy => 'ignore', model_dir => $wr_model1->child("models")->relative($wr_lib)->stringify ) ; my $inst4 = $model4->instance ( root_class_name => 'MasterModel', instance_name => 'test_instance4', root_dir => $wr_conf1->stringify, ); ok($inst4,"Read MasterModel and created instance") ; my $root4 = $inst4->config_root ; ok($root4,"Created MasterModel root") ; my @elt4 = $root4->get_element_name() ; is(scalar @elt4,scalar @elt1,"Check number of elements of root4") ; # require Tk::ObjScanner; Tk::ObjScanner::scan_object($meta_model) ; note("testing memory cycles. Please wait..."); memory_cycle_ok($meta_model, "Check memory cycle"); done_testing; libconfig-model-itself-perl-2.025/t/itself_snippet.t000066400000000000000000000071111477420254600224730ustar00rootroot00000000000000# -*- cperl -*- use ExtUtils::testlib; use Test::More ; use Test::Memory::Cycle; use Config::Model; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use Path::Tiny; use File::Copy::Recursive qw(fcopy rcopy dircopy); use Config::Model::Itself ; use Test::File::Contents ; use warnings; use strict; my ($meta_model, $trace) = init_test(); my $wr_test = setup_test_dir ; my $wr_model1 = $wr_test->child("wr_model1"); my $wr_plugin = $wr_test->child("wr_plugin.d"); $wr_model1->mkpath; # copy test model dircopy('data',$wr_model1->stringify) || die "cannot copy model data:$!" ; my $plugin_name = 'my_plugin'; # test model plugins, read model in layered mode my $meta_plugin_inst = $meta_model->instance( root_class_name => 'Itself::Model', instance_name => 'itself_plugin', root_dir => $wr_model1, ); ok($meta_plugin_inst,"Read Itself::Model and created instance for model plugin") ; my $meta_plugin_root = $meta_plugin_inst -> config_root ; my $plugin_rw_obj = Config::Model::Itself -> new( model_object => $meta_plugin_root, cm_lib_dir => 'data', ) ; $meta_plugin_inst->layered_start ; $plugin_rw_obj -> read_all( root_model => 'MasterModel', ) ; ok(1,"Read all models in data dir in layered mode") ; $meta_plugin_inst->layered_stop ; # modify model, X_base_class2 is not a mistake $meta_plugin_root->load(q!class:MasterModel::X_base_class2 element:X#"X note" help:Cv="Mighty help for Cv"!); $meta_plugin_root->load(q!class:MasterModel element:a_string warn_if_match:meh msg="said meh"!); $plugin_rw_obj->write_model_plugin(plugin_dir => $wr_plugin, plugin_name => $plugin_name) ; my %expected_plugin; $expected_plugin{MasterModel} = << "EOS" ; use strict; use warnings; return [ { 'element' => [ 'a_string', { 'warn_if_match' => { 'meh' => { 'msg' => 'said meh' } } } ], 'name' => 'MasterModel' } ] ; EOS $expected_plugin{"MasterModel/X_base_class2"} = << "EOS" ; use strict; use warnings; return [ { 'element' => [ 'X', { 'help' => { 'Cv' => 'Mighty help for Cv' } } ], 'name' => 'MasterModel::X_base_class2' } ] ; =head1 Annotations =over =item class:"MasterModel::X_base_class2" element:X X note =back EOS foreach my $name (keys %expected_plugin) { file_contents_eq_or_diff( $wr_plugin."/$plugin_name/$name.pl", $expected_plugin{$name}, "generated $name plugin file" ); } my $meta_plugin_inst2 = $meta_model->instance( root_class_name => 'Itself::Model', instance_name => 'itself_plugin', root_dir => $wr_model1, ); ok($meta_plugin_inst2,"Read Itself::Model and created instance for model plugin") ; my $meta_plugin_root2 = $meta_plugin_inst2 -> config_root ; my $plugin_rw_obj2 = Config::Model::Itself -> new( cm_lib_dir => 'data', model_object => $meta_plugin_root2, ) ; $meta_plugin_inst2->layered_start ; $plugin_rw_obj2->read_all( root_model => 'MasterModel', ); ok(1,"Read all models in data dir in layered mode") ; $meta_plugin_inst->layered_stop ; $plugin_rw_obj2->read_model_plugin(plugin_dir => $wr_plugin, plugin_name => $plugin_name) ; my $plugin_name2 = 'other_plugin'; $plugin_rw_obj2->write_model_plugin(plugin_dir => $wr_plugin, plugin_name => $plugin_name2) ; foreach my $name (keys %expected_plugin) { file_contents_eq_or_diff ( $wr_plugin."/$plugin_name2/$name.pl", $expected_plugin{$name}, "regenerated $name plugin file" ); } note("testing memory cycles. Please wait..."); memory_cycle_ok($meta_model, "Check memory cycle"); done_testing; libconfig-model-itself-perl-2.025/t/list_itself_structure.t000066400000000000000000000020651477420254600241070ustar00rootroot00000000000000# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Path::Tiny; use Config::Model; use Config::Model::Tester::Setup qw/init_test/; use Config::Model::Itself ; use warnings; use strict; my ($meta_model, $trace) = init_test(); my $meta_inst = $meta_model -> instance ( root_class_name => 'Itself::Model', instance_name => 'itself_instance', root_dir => "data", ); ok($meta_inst,"Read Itself::Model and created instance") ; my $meta_root = $meta_inst -> config_root ; my $model_dir = path($INC{'Config/Model/Itself.pm'})->parent; note("Reading models from $model_dir"); my $rw_obj = Config::Model::Itself->new( cm_lib_dir => $model_dir, model_object => $meta_root ); my $map = $rw_obj->read_all( root_model => 'Itself', force_load => 1, ); ok(1,"Read all models from $model_dir") ; my $list = $rw_obj->list_class_element; ok($list,"got structure") ; print $list if $trace ; note("testing memory cycles. Please wait..."); memory_cycle_ok($meta_model, "Check memory cycle"); done_testing; libconfig-model-itself-perl-2.025/t/load_write_itself.t000066400000000000000000000070531477420254600231470ustar00rootroot00000000000000# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Config::Model 2.138; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use Data::Dumper ; use Config::Model::Itself ; use Text::Diff; use Path::Tiny; use File::Copy::Recursive qw(fcopy rcopy dircopy); use warnings; use strict; use 5.10.1; $File::Copy::Recursive::KeepMode = 0; my ($meta_model, $trace) = init_test(); my $wr_test = setup_test_dir ; my $inst = $meta_model->instance ( root_class_name => 'Itself::Model', instance_name => 'itself_instance', root_dir => $wr_test, ); ok($inst,"Read Itself::Model and created instance") ; my $root = $inst -> config_root ; # copy itself model # avoid patching this file for Debian autopkgtest my $orig_cm_dir = path($INC{'Config/Model/Itself.pm'})->parent; my $orig_model_dir = $orig_cm_dir->child('models'); my $target_cm_dir = $wr_test->child('lib/Config/Model'); my $target_model_dir = $target_cm_dir->child('models'); note("Copying models from $orig_model_dir"); # start copy *below* models. # See https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=809294 dircopy($orig_cm_dir->stringify, $target_cm_dir->stringify); my $rw_obj = Config::Model::Itself->new( cm_lib_dir => $target_cm_dir->stringify, model_object => $root ); # filter out applications not related to "Itself" model. when using # "system" libraries my $map = $rw_obj->read_all( root_model => 'Itself', application => 'itself' ); ok(1,"Read all models from $target_model_dir") ; my @expected_classes = qw/Itself::Application Itself::CargoElement Itself::Class Itself::CommonElement Itself::CommonElement::Assert Itself::CommonElement::WarnIfMatch Itself::ComputedValue Itself::ConfigAccept Itself::ConfigReadWrite Itself::ConfigReadWrite::DefaultLayer Itself::Element Itself::MigratedValue Itself::Model Itself::NonWarpableElement Itself::WarpOnlyElement Itself::WarpValue Itself::WarpableCargoElement Itself::WarpableElement/; my @classes = $root->fetch_element('class')->fetch_all_indexes; is_deeply(\@classes, \@expected_classes, "found all configuration classes of Itself model"); my @apps = $root->fetch_element('application')->fetch_all_indexes; is_deeply(\@apps, [], "found no applications as they are filtered out"); my $cds = $root->dump_tree (mode => 'backend') ; print $cds if $trace ; ok($cds,"dumped full tree in cds format") ; #create a 2nd empty model my $inst2 = $meta_model->instance ( root_class_name => 'Itself::Model', instance_name => 'itself_instance2' ); my $root2 = $inst2 -> config_root ; foreach my $class (@expected_classes) { $root2->fetch_element('class')->fetch_with_id($class); } $root2 -> load ($cds) ; ok(1,"Created and loaded 2nd instance") ; my $cds2 = $root2 ->dump_tree (mode => 'backend') ; print $cds2 if $trace ; is(my_diff(\$cds,\$cds2),'',"Compared the 2 full dumps") ; my $pdata2 = $root2 -> dump_as_data ; print Dumper $pdata2 if $trace ; # create 3rd instance my $inst3 = $meta_model->instance ( root_class_name => 'Itself::Model', instance_name => 'itself_instance3' ); my $root3 = $inst -> config_root ; foreach my $class (@expected_classes) { $root3->fetch_element('class')->fetch_with_id($class); } $root3 -> load_data ($pdata2) ; ok(1,"Created and loaded 3nd instance with perl data") ; my $cds3 = $root3 ->dump_tree (mode => 'backend') ; is( my_diff(\$cds, \$cds3),'',"Compared the 3rd full dump with first one") ; $rw_obj->write_all() ; # require Tk::ObjScanner; Tk::ObjScanner::scan_object($meta_model) ; done_testing; sub my_diff { return diff( @_ , { STYLE => "Unified" } ); } libconfig-model-itself-perl-2.025/t/meta-class.t000066400000000000000000000017411477420254600214770ustar00rootroot00000000000000 use ExtUtils::testlib; use Test::More ; use Config::Model 2.138; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use Config::Model::Itself ; use Test::Memory::Cycle; use Test::Exception; use warnings; use strict; my ($meta_model, $trace) = init_test(); my $wr_root = setup_test_dir; my $meta_inst = $meta_model-> instance ( root_class_name => 'Itself::Model', instance_name => 'itself_instance', root_dir => "data", ); ok($meta_inst,"Read Itself::Model and created instance") ; my $meta_root = $meta_inst -> config_root ; $meta_root->load('class:Test'); ok(1,"Created dummy Test class"); throws_ok { $meta_root->load('class:Test class="Foo::Bar"'); } qr!Can't locate Foo/Bar.pm in \@INC!, "test explicit error message when attaching Config class to unknown Perl class"; print "normal error:\n", $@, "\n" if $trace; note("testing memory cycles. Please wait..."); memory_cycle_ok($meta_model, "Check memory cycle"); done_testing; libconfig-model-itself-perl-2.025/t/pod.t000066400000000000000000000001431477420254600202230ustar00rootroot00000000000000# -*- cperl -*- use strict; use warnings; use Test::More; use Test::Pod 1.00; all_pod_files_ok(); libconfig-model-itself-perl-2.025/t/pod_gen.t000066400000000000000000000037131477420254600210620ustar00rootroot00000000000000# -*- cperl -*- use ExtUtils::testlib; use Test::More ; use Test::Differences ; use Config::Model; use Config::Model::Tester::Setup qw/init_test setup_test_dir/; use Config::Model::Itself ; use warnings; use strict; my ($meta_model, $trace) = init_test(); my $wr_test = setup_test_dir ; my $wr_model1 = $wr_test->child("wr_model1"); my $meta_inst = $meta_model->instance( root_class_name => 'Itself::Model', instance_name => 'itself_instance', root_dir => $wr_model1, ); ok( $meta_inst, "Read Itself::Model and created instance" ); $meta_inst->initial_load_stop ; my $meta_root = $meta_inst -> config_root ; my $rw_obj = Config::Model::Itself -> new( model_object => $meta_root, cm_lib_dir => $wr_model1, force_write => 1, # can put 0 when Config::MOdel 1.214 is used ) ; # add a new class my @list = (1..3); foreach my $i (@list) { $meta_root->load( qq/class:Master::Created$i#"my great class $i" class_description="Master class created nb $i\nfor tests purpose." author="dod\@foo.com" copyright="2011 dod" license="LGPL" element:created1 type=leaf#"not autumn" value_type=number description="element 1" - element:created2 type=leaf value_type=uniline description="another element"/) ; } ok(1,"added new class Master::Created") ; $rw_obj->write_all( ) ; ok(1,"wrote back all stuff") ; my $meta_inst2 = $meta_model -> instance ( root_class_name => 'Itself::Model', instance_name => 'itself_instance2', root_dir => $wr_model1, ) ; my $meta_root2 = $meta_inst2->config_root ; $meta_inst2->initial_load_stop ; ok($meta_root2,"Read Itself::Model and created instance2") ; my $rw_obj2 = Config::Model::Itself -> new( cm_lib_dir => $wr_model1 , model_object => $meta_root2 ) ; $rw_obj2->read_all( root_model => 'Master' ) ; eq_or_diff($meta_root2->dump_tree, $meta_root->dump_tree,"compare 2 dumps"); done_testing; # require Tk::ObjScanner; Tk::ObjScanner::scan_object($meta_model) ; libconfig-model-itself-perl-2.025/weaver.ini000066400000000000000000000002101477420254600207760ustar00rootroot00000000000000[@Default] [-Transformer] transformer = List [Support] perldoc = 0 bugs = metadata websites = search,kwalitee,testers,testmatrix,deps