pax_global_header00006660000000000000000000000064147206410060014512gustar00rootroot0000000000000052 comment=90bd2e5195afd4a1ea347bdc97c283106fa9b1c4 libconfig-model-perl-2.155/000077500000000000000000000000001472064100600155205ustar00rootroot00000000000000libconfig-model-perl-2.155/.gitignore000066400000000000000000000005331472064100600175110ustar00rootroot00000000000000Config-Model-* lib/Config/Model/models/Fstab.pod lib/Config/Model/models/Fstab/FsLine.pod lib/Config/Model/models/LCDd.pl lib/Config/Model/models/LCDd.pod lib/Config/Model/models/LCDd/ lib/Config/Model/models/Multistrap.pod lib/Config/Model/models/Multistrap/Section.pod lib/Config/Model/models/PopCon.pod .build *.unison.tmp wr_root wr_root_p *~ libconfig-model-perl-2.155/.travis.yml000066400000000000000000000012521472064100600176310ustar00rootroot00000000000000# see https://travis-ci.community/t/older-perl-version-stopped-working/4294 dist: trusty language: perl perl: - "5.30" - "5.28" - "5.24" - "5.22" - "5.20" - "5.18" - "5.16" - "5.14" install: - cpanm --quiet --notest Dist::Zilla - cpanm --quiet --notest --skip-satisfied MouseX::NativeTraits - cpanm --quiet --notest --skip-satisfied Pod::POM - cpanm --quiet --notest --skip-satisfied Pod::Weaver::Section::Support - cpanm --quiet --notest --skip-satisfied Pod::Elemental::Transformer::List - "dzil authordeps --missing | cpanm --notest " - "dzil listdeps --missing | grep -v Fuse | cpanm --notest " script: - dzil smoke --release --author libconfig-model-perl-2.155/Build.PL000066400000000000000000000045211472064100600170160ustar00rootroot00000000000000# Copyright (c) 2005-2012 Dominique Dumont. # # This file is part of Config-Model. # # Config-Model is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General 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.010001 ; print "\nIf you want to use the TermUI interface, you should install\n", "Term::ReadLine::Perl or Term::ReadLine::Gnu\n\n"; # 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.062 system ($^X, qw!-I lib -MConfig::Model::Utils::GenClassPod -e gen_class_pod();!) == 0 or die "gen-class-pod failed: $?"; $self->SUPER::ACTION_build; } SUBCLASS my @version_info = @ARGV ? ( dist_version => $ARGV[0] ) : (); my %appli_files = map { ( $_, $_ ) } glob("lib/Config/Model/*.d/*"); my $build = $class->new( module_name => 'Config::Model', @version_info, license => 'lgpl', appli_files => \%appli_files, dist_abstract => 'Describe, edit and validate configuration data', dist_author => 'Dominique Dumont (ddumont at cpan dot org)', ##{ $plugin->get_prereqs ##} # cleanup required by t/auto_read.t # PreGrammar.pm is created by t/value_computer.t add_to_cleanup => [ qw/PreGrammar.pm wr_root wr_root_p/ ], ); $build->add_build_element('pl'); $build->add_build_element('conf'); $build->add_build_element('appli'); $build->create_build_script; libconfig-model-perl-2.155/CONTRIBUTING.md000066400000000000000000000076421472064100600177620ustar00rootroot00000000000000# 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 to the [author](mailto:ddumont@cpan.org) ## Log a bug ## Please report issue on the issue tracker that best match your problem. If you don't know please use [cme issue tracker](https://github.com/dod38fr/cme-perl/issues). Here are the dedicated trackers: * problem with cme command: https://github.com/dod38fr/cme-perl/issues * problem with `cme check|fix|edit openssh`: https://github.com/dod38fr/config-model-openssh/issues * problem with `cme check|fix|edit systemd`: https://github.com/dod38fr/config-model-systemd/issues * problem with `cme check|fix|edit systemd-user`: https://github.com/dod38fr/config-model-systemd/issues * problem with `cme check|fix|edit lcdproc`: https://github.com/dod38fr/config-model-lcdproc/issues * problem with `cme check|fix|edit approx`: https://github.com/dod38fr/config-model-approx/issues * problem with `cme check|fix|edit dpkg`: run `reportbug libconfig-model-dpkg-perl` * problem with `cme check|fix|edit popcon`: https://github.com/dod38fr/config-model/issues * problem with `cme check|fix|edit multistrap`: https://github.com/dod38fr/config-model/issues * problem with `cme meta edit`: https://github.com/dod38fr/config-model-itself/issues * problem with cme GUI: https://github.com/dod38fr/config-model-tkui/issues ## Source code structure ## The main parts of this modules are: * `lib/Config/Model/**.pm`: the core framework files * `lib/Config/Model/Backend/**.pm`: classes used to read and write configuration files * `lib/Config/Model/models/**.pl`: the model of the applications delivered with this module. These files can be modified with `cme meta edit` command. Their structure can be viewed with `cme meta gen-dot` and `dot -Tps model.dot > model.ps` * `lib/Config/Model/models/**.pod`: the doc of the above models. Can be re-generated with `cme gen_class_pod` * `t`: test files. Run the tests with `prove -l t` * `t/model_tests.d` test the application delivered with this module using [Config::Model::Tester](http://search.cpan.org/dist/Config-Model-Tester/lib/Config/Model/Tester.pm). Use `prove -l t/model_test.t` command to run only model tests. ## 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/` * 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-perl` * jump in `cd libconfig-model-perl-2.086` * 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 to the [author](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-2.086.tar.gz` * jump in `cd Config-Model-2.086` * 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 the [author](mailto:ddumont@cpan.org) ## Provide feedback ## Feedback is important. Please take a moment to rate, comment or add stars to this project: * [cme github](https://github.com/dod38fr/cme-perl) * [config-model github](https://github.com/dod38fr/config-model) or [config-model cpan ratings](http://cpanratings.perl.org/rate/?distribution=Config::Model) libconfig-model-perl-2.155/Changes000066400000000000000000004015411472064100600170200ustar00rootroot00000000000000{{$NEXT}} 2.155 2024-11-24 New feature: * Loader: add .set_to_standard_value() function 2.154 2024-06-15 Bug fixes: * AnyId: raise an error when copy is called on an unknown key or idx * HashId: raise an error when move is called on an unknown key * HashId: improve copy method to fix PlainFile backend * grab: fix error message when autoadd is 0 * loader: update .ensure() doc New feature: * Loader: add .rename() function for hash 2.153 2023-07-14 Bug fixes: * term_ui.t: fix test for Term::ReadLine::Gnu 1.46 * Config::Model::Value: remove deprecated given instruction * docs: remove links to cpanratings New feature: * Loader: add support for single quotes 2.152 2022-07-28 Bug fixes: * fix regression (Value): error_msg now returns empty string when there's no error 2.151 2022-07-26 Bug fixes: * fix (Value): do not check compute result with mandatory value (Debian #1015913) * fix (Value): consider an empty string as an unset value Misc: * Node: apply_fixes now returns $self 2.150 2022-05-08 New features: * Loader: add list:.ensure(value) function Bug fixes: * Loader: fix reading JSON file with utf8 characters 2.149 2022-01-13 Bug fixes: * fix regression with check_value method 2.148 2022-01-09 Bug fixes: * fix (Exception): keep ref to instance object * fix (Hashid): improve warning message when loading non ordered data * fix (modify instance): show changes before saving 2.147 2021-11-29 Bug fixes: * fix (test): ignore info Log. 2.146 2021-11-28 Model improvements: * fstab: add suid/nosuid (thanks Topi Miettinen) * feat (fstab model): add umask element in common options * feat (fstab model): add description to common options Bug fixes: * feat (Instance): modify methoed displays changes before saving * fix (Loader): typo in .substitute load string command * fix (Grab): improve error message of grab_value * fix (TermUI): add completion to display command * fix (SimpleUI): simplify error message shown to user * fix (SimpleUI): avoid undef warnings * fix (Describe): truncate long lines * fix (Describe): show default value in comments * fix (Describe): show value in user mode * Value: accept on/off as boolean values * fix: test error with perl 5.20 (Closes gh #32) 2.145 2021-11-06 Bug fixes: * fix: compilation error with perl 5.20 to 5.22 * fix (Node): undef warning on $filter value * fix (Model loader): crash with Config::Model::Itself (Debian #998601) 2.144 2021-11-04 Bug fixes: * fix (BackendMgr): try to fix crash on Windows * fix (Constants role): fix crash for perl < 5.28 2.143 2021-10-31 Main change: * requires perl 5.20 Bug fixes: * fix (Model load): fix load from absolute path * fix (BackEndMgr): crash when calling config_file_override with absolute path * fix (get_info): show upstream_default as written in file * feature (get_info): include write_as values 2.142 2021-04-07 New features: * cme function: add force-load parameter to behave like cme command Bug fix: * Avoid messing up array indexes when remove list items (gh #26) Thanks Hugo van der Sanden, James E Keenan and Slaven Rezić for the help * load method: forward value of check parameter 2.141 2021-01-17 New features: * Loader: can extract data from YAML file (requires YAML::Tiny) * Loader: can extract data from JSON file * feature (ini backend): add quote_value parameter Bug fix: * ListId: fix storage of undef value in store_set * Config::Model::Loader: update documentation. (Thanks gregoa) Other changes: * dist.ini: update copyright year 2.140 2020-07-31 API changes: * PlainFile backend: extract get_file_name method * AnyId: add fetch_value and fetch_summary method * Value: add fetch_summary method Bug fix: * fix loader_logs tests broken by Config::Model::Tester 4.006 2.139 2020-07-18 UI changes: * Show warnings in blue color (color can be configured using Log4Perl config file) * shell UI: * add info command * improve tree and ls commands API changes: * Node: add autoadd argument to fetch_element and has_element methods * add get_info method to most tree classes Bug fix: * Exception: drop constraint in parsed_file which avoids a crash when cme should be showing an error message Misc: * cleanup code. Thanks kritika.io for the suggestions * updated copyright years 2.138 2019-12-27 Bug fix: * CheckList: add missing "backend" fetch mode Doc improvements: * Value: update doc of allow_under mode * fix typo in pod doc 2.137 2019-12-01 Bug fixes: * AnyId: avoid deref of undef value * Loader: fix parsing of list assignment with quotes * Value: do not store warnings from computed value * Node: warn only once about deprecated elements * CheckList: accept non_upstream_default mode Doc improvements: * AnyId: clarify doc and error message * Add doc for container method * Value: clarify load_data doc * Value: fix typos in doc API changes: * Value: provide has_warnings along has_warning * DumpAsData, Dumper: * deprecate full_mode parameter * full dump is now mode => user 2.136 2019-07-29 Bug fix: * also tweak ~ dir for tests in Path::Tiny coercion (fixes Config::Model::Systemd tests that was broken with Config::Model 2.134) Doc update: * Mention force option in Instance doc 2.135 2019-06-05 Bug fix: * Fix undef start_node error occuring with 'cme run' command (this regression from previous version broke app-cme tests) * Instance: clear changes after reset Doc update: * remove mention of long gone privilege parameter 2.134 2019-05-05 Bug fix: * Fix Instance->reset_config method * improve error handling of get_model_doc Minor behavior changes: * dump_tree: add quote around value or if that contain '~' Deprecation: * Instance: remove deprecated read_root_dir method Misc: * update copyright year * Tests require Config::Model::Tester 4.002 2.133 2019-01-13 Read/write backend improvements: * Backend::Any: add auto_delete and auto_create * IniFile: delete empty file when auto_delete is set and config file contains no data * warn when restoring backup file 2.132 2018-12-22 Bug fix: * Value: really use old_value to track changes * restore "return undef" in Value.pm to avoid breaking apply_fix Add long forgotten credit (sorry): * add Ylya Arosov to credit 2.131 2018-12-16 With this release, this distribution no longer provides YAML backend. The YAML backend is now delivered in its own distribution. Look for Config::Model::Backend::Yaml on CPAN. Other changes: * Value: use warn_if warn_unless label in warning message shown to user. * BackendMgr: throw correctly "unknown backend" exception * Exception: trap missing object parameter Doc update * remove mention of old config-model-users mailing list (dead) * BackendMgr: mention that Yaml backend is now external 2.130 2018-12-07 Dependency changes: * require boolean module (really) 2.129 2018-12-05 Usability improvements: * Value" improve warning message about multi line value Perl backend improvement: * Convert cme boolean values (i.e. value of value_type boolean) to Perl boolean values Dependency changes: * build require boolean module 2.128 2018-11-21 Usability improvements: * CheckList: die or warn (with cme -force) when storing unknown item in check list. Bad values used to be silently dropped. Test fixes: * add \n at end of yaml test files (gh #22) Internal changes: * improve code quality thanks to the feedbacks provided by kritika.io Doc change: * Improve navigation in doc: move parameters from header line to paragraph. * Instance: add doc for backend_arg * Instance: improve doc of data method 2.127 2018-09-30 Feature improvement: * Can use regexp in leaf model to specify help on values Bug fix: * fix doc of ObjTreeScanner 2.126 2018-08-20 Bug fix: * Value: Don't crash with some chained fixes Usability improvements: * BackendMgr: log an error when eval'ed write dies 2.125 2018-06-24 Bug fix: * BackendMgr: remove close call on fh. This is now handled by Path::Tiny Breaking change: * BackendMgr: remove code to read from stdin. This removes the possibility to read a config file from STDIN. This was deprecated since January and nobody complained. Doc change: * improve pod doc on Grab.pm 2.124 2018-06-09 The main change of this release should help people see what's going on during 'cme run' or 'cme modify'. Config::Model::initialize_log4perl now accepts a verbose parameter to enable verbose message of Loader class (used by cme run and modify). In verbose mode, Loader now shows the effect for each instruction specified on 'cme modify' command line or specified in the script run by 'cme run'. This feature will be available with the next release of cme. Bug fixes: * display USER INFO log as plain message (no need of 'INFO:' prefix) * fix CheckList element handling when cme is run with -force option. (add check param to CheckList) * Value: avoid warning when loading wrong boolean (gh #19) * Avoid unneeded change notif when showing up a node that was previously hidden (gh #17) * improve error message about unknown element (gh #18) 2.123 2018-05-01 On-going improvements of R/W backends: * io_handle backend parameter is deprecated * use file_path in all backends instead of io_handle Test improvements: * build dep on Config::Model::Tester 3.006 * document prove command in t/README.pod * tests run without showing any warnings * all tests accept --log --error --trace parameters * all test models are updated to remove all deprecated declarations Bug fix: * fix parameter sanitisation in Instance * Value: remove self assignment (tx kritika.io) * update WarpedNode synopsis 2.122 2018-04-17 Bug fix: * Warper: fix crash when a warper (aka warp master) is a computed value 2.121 2018-04-15 * BackendMgr: fix handling of file argument * Instance: fix compat with Perl < 5.20 Log improvements: * use User class to log warning for User * Model: add doc for initialize_log4perl * Model: moved log4perl default conf in a separate file (lib/Config/Model/log4perl.conf) Test improvements: * add README for the tests * some tests can be run with --log, --trace and --error options. See t/README.pod for details 2.120 2018-04-08 Bug fix: * fix config file location declared with absolute path (i.e. all system application like ssh, systemd) 2.119 2018-04-02 Main change: * use logger to warn about issues. By default, logged warnings are shown on STDOUT. These warnings can be suppressed using ~/.log4config-model file. API change: * Instance: root_dir parameter can be a Path::Tiny object or a string Bug fixes: * BackendMgr: fix broken file backup * Backend: create dir before creating file * Yaml backend: avoid redefined sub warning 2.118 2018-03-26 On-going backend deprecation: * BackendMgr: deprecate using STDIN to load config file. Which means using '-' with cme '-file' option is deprecated. Backend: * Improve global comment extraction Other changes: * remove unused modules from BackendMgr * Exception: improve Model error message 2.117 2018-02-03 Bug fixes: * notify about addition of hash key only when needed * fix error message of "missing file" exception 2.116 2017-12-15 Fix broken cme: * Instance: fix regression about root_dir param 2.115 2017-12-14 On-going backend deprecation (which might be breaking): * Backend: deprecate using instance name as config file name * All backends: suffix method is deprecated Backend: * ShellVar backend: don't reorder when writing back (experimental) * trap when backend class has no implementation New features: * Loader: provide "english" operator foreach_match, rm rm_value, rm_match, substitute. These are equivalent to :-~ :- :-= :-~ :=~ operators (cme gh#2) Bug fixes: * Node gist: no need to show that value is undef * WarpedNode: forward fetch_gist instead of gist * Instance: add doc for root_path parameter 2.114 2017-11-11 On-going backend deprecation (which might be breaking): * support for multiple backends is now removed. Attempting to configure multiple backend leads to an error message with explanations. * when possible (i.e. when only one backend is specified), translate read_config and write_config in new rw_config. This should limit breakage to the minimum as multiple backends are seldom (if ever) used. New features: * AnyId: add fetch method * CheckList: add store method * Node: add gist parameter and fetch_gist method to get a summary of node content to be shown in user interface. Bug fixes: * Exception: fix call to fetch_element * ObjTreeScanner: Don't try to scan warped out node elements * Instance: no longer show diff-like changes * clean up check on node init (gh #15) * AnyId: add notification triggered by adding a new element to a hash or array. Build changes: * no longer use Text::Diff 2.113 2017-10-12 On-going backend deprecations: * using "custom" backend is now fatal * warn when more than one backend is declared in a model class. This soon will be fatal * udpated models (Fstab Multistrap PopCon) to use new rw_config parameter Bug fixes: * HashId: do not notify when deleting an undef value (Debian #876967) * Value: support file test in code eval done by warn_if and similar tests * remove confusing "master triggered changed" message * really avoid undef warning when homedir is not defined * avoid "unordered data" warning when loading one item in an ordered hash New features usable with 'cme modify' or in a cme script (used by 'cme run'): * add "=.env(...)" instruction to store the content of an environment variable in a value * add "=.file(...)" instruction to store a file in a value. ".file(-)" reads from STDIN. * add a User logger category to log messages to user. Direct calls to warn will be removed to make test output cleaner 2.112 2017-10-01 Fix bugs to make warp mechanism more consistent: * Value: trigger a warp after apply_fix is called * Value: apply replace when warping Other bug fixes: * don't initialise Log4Perl if already done * Avoid warning when YAML data is missing 2.111 2017-09-22 Deprecating features might be necessary, but there's no need to be obnoxious about it: * Reduce the number of legacy warning * use logger mechanism to issue these warnings 2.110 2017-09-21 Unfortunately the deprecations and updates done last release broke Config::Model::Itself. This release fixes these problems: * disable translation of read_config to rw_config * change deprecation messages from warn to say * put back old backend parameters for FsTab, Multistrap and PopCon models 2.109 2017-09-18 Deprecation and updates as announced in http://wp.me/pFBZb-f5 : * the model parameters read_config and write_config that are used to specify different read and write backends are deprecated in favor of rw_config to specify *one* r/w backend * multiple backends are deprecated. * update doc for these deprecations * Dump string backend (cds_file) is now handled by its own class (Config::Model::Backend::CdsFile) * Perl backend (perl_file) is now handled by its own class (Config::Model::Backend::PerlFile) * Model: die when model parameters allow, allow_from, follow are used. These parameters were deprecated several years ago. Other changes: * update backend parameters of FsTab, Multistrap, PopCon models * Value: allow regexp and code test for enum (like warn_if_match) Test improvements * can run tests concurrently: prove -j8 runs all tests in 4s (16s without -j8) 2.108 2017-08-31 Fix random failure in non-regression tests 2.107 2017-08-30 Deprecation: read/write backends have many complex features to read and write configuration files that are not used. This is the first step to deprecate and remove these features: * custom backends are deprecated * add doc that show how to replace a custom backend with a backend based on Config::Model::Backend::Any Security improvements: * ValueComputer: safer use of variables in eval: variables are passed to the eval'ed code in a hash insted of being inserted *in* the code to eval. Bug fixes: * value: fix mechanism to avoid repetitive warnings (Thanks Tincho) * use check => skip when fetching a value from is_element_available method. This avoid missing warnings when is_element_available function triggers a read of a configuration file (like debian/control) 2.106 2017-07-16 Doc updates: * BackendMgr: update doc of config_file_name Improvement on error behavior: * Fix message of WrongType Exception * die if model line is missing from application file * ensure that an application file is not parsed twice * avoid undef warning when homedir is not defined * cme function: improve error msg for unknown application 2.105 2017-06-09 Bug fixes: * Value: fix fetch in non_upstream_default mode to avoid breaking 'cme meta plugin' command 2.104 2017-06-03 Improvements: * Instance: add backend_arg to enable misc parameter for cme command (e.g a systemd service name for systemd model or a patch name for Dpkg patch model). (Build require Config::Model::Tester 2.062) Bug fixes: * BackendMgr: * allow empty but defined config_dir * ignore config_file in non-root node (do not die anymore) * Plainfile backend: try to fix a windows bug showing up on smoke tests * Dumper: * hash id containing @ must be quoted * accept non_upstream_default mode * Value: fix fetch in non_upstream_default mode 2.103 2017-05-25 Bug fix release: * dist.ini: put back YAML build dep which is used for tests * remove debug trace about YAML class * fix exception message to show any kind of data. 2.102 2017-05-14 Fix security issues: * do not rely on '.' in @INC to load snippet model files (CVE-2017-0374) * genclasspod: remove use lib (CVE-2017-0373) * avoid possible creation of Perl object through hostile YAML file: use YAML::Tiny in YAML backend instead of YAML::Any Model improvement * model can choose YAML parser (default YAML::Tiny) Bug fix: * boolean value: accept empty string as false value 2.101 2017-04-28 Model improvement: * Add assign_char and assign_with to IniFile backend. So it can be used for files with "key: value" lines. * add option to write hash key with empty values. By default empty hash values are dropped and the hash keys of these values are lost. Usability improvement: * Value: if possible show why a fix is applied, i.e. show the warning that triggered the fix * improved log levels (i.e. move some log from debug to info or trace) Improvement: * Model: add log_level parameter, so logs can be shown with a cme command line option * prevent undef warnings on Windows Deprecation warning: * Model: warn in case of undef constructor argument 2.100 2017-03-18 Usability improvement: * Unknown element excetption show instructions to report a bug. Improvement of doc generated from model: * add compute information in generated doc * pod generator: show default values in item list Bug fix: * Fix file mode test (fix CPAN smoke tests) 2.099 2017-03-05 Model improvement: * add file_mode parameter to backend specification. This parameter sets the permission (mode) of written configuration files (need Config::Model::Tester 2.059 to test) 2.098 2017-02-26 This release bring some improvements to enable more feature on Debian Dpkg model. Build: * build depends on Config::Model::Tester 2.059 * bump © year in dist.ini Model improvements: * allow injection of model snippet in another configuration class. This is used by dpkg model: a dpkg-control default value is computed from a value in dpkg model only when dpkg-control model is loaded with dpkg model, * add doc for has_instance and get_instance methods Plainfile backend improvements: * handle deletion of file managed by Plainfile backend * plainfile backend can handle file named with &element and &index functions, i.e the config file name can depend on the location of the value in the configuration tree. (used by dpkg model for debian/.install files) Value computer improvements: * doc: mention that functions are allowed in variable definition * allow '- -' or '--' param to &index Bug fix: * fix error forwarding in BackendMgr * warn when Term::ReadLine::Gnu is not installed * fix term UI set command to accept white spaces * Loader: allow creation of empty hash leaf 2.097 2016-12-22 Bug fix: * fix a regression seen when starting curses interface (fix retrieval of an instance using an instance name) 2.096 2016-12-11 Term UI improvement * fix autocompletion of 'cd' command * add -nz and -v option to ll command * ll command accept several patterns * improved ll output Bug fix: * show complete stack trace of rethrown exceptions * Node: propagate check param when calling init (which fix cme's -force option) Build: * dist.ini Add missing prereq 'parent' as plugin [AutoPrereqs] missed it (Mohammad S Anwar++) * new dependencies: List::Util Regexp::Common 2.095 2016-12-06 New feature usable by cme: * loader: add .insort() command for hash element * Hash element: add insort method Term UI improvement * better format the output of 'desc' command (transform pod doc to text). This requires Pod::Text and Pod::Simple 3.23 Bug fix: * track and save annotation changes (gh #12) * Node: propagate check override in init() (which fixes loading of a systemd config that contains an error) 2.094 2016-11-09 Fix compatibility with older Term::ReadLine::Gnu: * TermUI: skip call to enableUTF8 if not available (gh #11) 2.093 2016-11-08 Hygiene: * Add Travis CI file (Thanks Jose Luis Perez Diez) New feature in read/write backend: * Allow alternate comment char in INI config file (gh #10) required to support Systemd config files Bug fix: * Better support of utf8 in term UI 2.092 2016-09-23 * New feature in shell UI: * 'll' command shows a warning sign when an element has a warning that may be fixed * added 'check' command * 'fix' command can be applied to selected element instead on the whole config. Other bug fixes: * Node: fix deep_check propagation * Iterator triggers a call_back if a hash element has a warning (required to fix the wizard of the graphical interface which did not stop on a hash element when needed) 2.091 2016-09-13 Bug fix: * really fix issue with '.' removal from @INC (needed to close Debian #837682) 2.090 2016-09-10 New feature: * Model developer can use $std_value in warning messages tp provide better feedback to user. This variable is substituted with preset, computed or default value when the message is generated. Cleanup: * remove obsolete skip_read parameter (breaks App::Cme older than v1.011) Bug fix: * Add double quote when dumping value that contain '#' * Value: generates same error messages for warn_if, warn_if_match * fix other collaterals of '.' removal from @INC 2.089 2016-09-04 New feature: Now 3 types of check can be used on hash or array elements: content check, id check (as usual) and deep_check (should be used to check between if value and other part of config tree). Only the index check is run whenever an element of the hash/array is read. The other are used when check() or apply_fixes methods are called. Documentation: * converted README.pod to markdown Bug fix: * load perl data file even if @INC does not contain '.' (required for perl 5.14 or Debian perl 5.22.2-4) * Loader: trap another syntax error in load steps. This may breaks existing tests or cme scripts that contain such an error. 2.088 2016-07-09 Documentation improvements: * document repo structure in CONTRIBUTE file * document Instance application method * add auto_delete param in pod doc * add CREDITS section in main doc New instructions for 'cme modify' (in Config::Model::Loader): * add copy command for list * add clear command for list and hash Bug fix: * use sort keys to get consistent warning order (which is important for non-regression tests) * fix regexps for Perl 5.22 (gh #6) Tx mat813 2.087 2016-06-29 A release with mostly documentation improvements: * Fixed many grammatical issues in all pod docs * Added CONTRIBUTE.md * Instance doc: * separate data change methods from internal methods * specify value returned by load() Model specification change * move warp info in warp param in WarpedNode. The change is backward compatible and will show a notification on STDOUT. This notification will become later a warning. * always show a message when using some parameters that were deprecated in 2007. This may break tests. It's time to fix them. Bug fixes: * add as_string method to all exception classes * BackendMgr: correctly handle Path::Tiny exceptions * Value: show changes of boolean values as they are written in configuration file 2.086 2016-06-04 Fixed some bugs so that cme() works with new Systemd model: * cme() uses config_dir from app file * Node: element_type works on not yet accepted element * Node: improved doc of accept_element() 2.085 2016-05-29 The new releases brings new functions to simplify script that modify configuration files. For instance, the following line is enough to update popcon's configuration file: cme('popcon')->modify("PARTICIPATE=yes"); In more details: * Config::Model provides a 'cme' exported function (see also the SYNOPSIS of Config::Model doc) * Instance: added modify and save() methods Other changes: * Term::ReadLine is not required for build or tests * Instance skip_read parameter is deprecated 2.084 2016-05-26 Doc updates: * Model doc: * use cme meta instead of config-model-edit * removed Log4Perl init for synopsis.. * improved instance method doc * removed obsolete (and broken) example directory * Instance: clarified constructor doc Dependencies changes: * TermUI is now optional (like FuseUI). So Term::ReadLine dependency is now recommended instead of required. Bug fixes: * Fix gen_class_pod which skipped some classes (fix reproducible build of libconfig-model-openssh-perl) * Model: instance() accepts application param * Removed FATAL warnings from Instance * all tree elements: added has_data method * read model files (and doc) as utf8 2.083 2016-04-20 Functional improvements: * backend parameters: added auto_delete parameter so that a config file can be removed when it no longer contains data * attributes specified in a model plugin can override attributes of the base model. Bug fixes: * BackendMgr: do not remove links to config files * Fix ini backend to parse values that contain '=' Doc updates: * Improved instructions to specify a backend in Config::Model::BackendMgr doc * Added instructions to create your own backend in Config::Model::Backend::Any doc * updated model creation intro doc * Mentions Itself generated doc as reference doc * update CreateModelFromDoc to use cme meta edit 2.082 2016-03-29 No big change this time, but a lot of small improvements required by the systemd model I'm working on... Functional improvements: * Loader: list operator :~ with no argument loops over all values of a hash element * DumpAsData: also accepts 'mode' param like fetch from Config::Model::Value Bug fixes: * Fix tests broken by C::M::Tester 2.053 (required) * Loader: fix loop bug which exited too soon * Improve hash dump readability ... * DumpAsData: Fix corrupted output... * BackendMgr: always translate dir with ~/ Doc updates: * removed Log4Perl instructions from synopsis. Log4Perl initialisation is handled by Config::Model constructor since v2.057 * Improved C::M::Warper and C::M:Lister docs 2.081 2016-02-29 Bug fixes: * Fix error handling in Value. This should fix freebsd smoke tests. The weird thing is that these tests should have failed in all arch... 2.080 2016-02-27 Functional improvements: * storing a wrong value is no longer ignored but now triggers an exception. Other bug fixes: * Trigger change notif when store_set reduces the nb of items (closes gh #4) * Improved change message shown to user * Value: don't display grammar in case of error 2.079 2016-02-12 YAML backend changes: * Remove YAML file when no data is left * When a root class has only one element, the backend write (and read) only the content of that element (this reduce the depth of the written data structure by one). Functional improvements: * Added "ChangeTracker" log class and traces (Log::Log4Perl) * HashId: load_data can load ordered data in non-ordered hash Bug fixes: * Removed Exception::Class from warper error handler (gh #5, Thanks jplesnik) * Dumper/Loader: handle literal \\n 2.078 2016-01-24 A cleanup (and breaking) release: Error handling no longer uses Exception::Class. Config::Model::Exception was re-written to emulate most of Exception::Class behavior. This will break modules which traps or throw exceptions using Exception::Class (at least Config::Model::CursesUI will break). * Config::Model: fix get_element_property (fix a bug with cme dpkg where XS-Autobuild is wrongly added to debian/control file) * Config::Model::Value: * don't check value when loading layered config (aka system default values). These values are assumed to be correct. * accept when a mandatory value is set by a layered value. (this fixes hangs in Config::Model::Itself tests) 2.077 2016-01-20 New features: * Loader: added hash copy command. This new command can be used with something like: "cme modify stuff some_hash:.copy(from,to)" * Instance: added config_dir (used when provided by application info and not by model) Bug fix: * ValueComputer: escape variables containing a quote (Debian #810768) * Value: fix check of reference values 2.076 2016-01-14 One major feature of Config::Model is the possibility to change the structure of the tree depending on a configuration paramater value. This "warp" feature is used in lcdproc model: when a driver is choosen by user, the configuration parameter of this driver are shown and parameters for other drivers are hidden. Up to now, only one driver could be selected at a time because the warp mechanism could be driven only by a leaf value. Now this warp feature can be driven by a check list. So lcdproc model can now select more that one driver at a time. Other functionality improvements: * Ini backend: doc mentions "IniFile" instead of ini_file to match Config::Model::Backend::IniFile class name. * IniFile backend can read/write check list 2.075 2015-11-22 Functionality improvements: * Lister: can list local (dev) application Support: * changed bugtracker to github's 2.074 2015-09-30 Functionality improvements: * Loader: added navigation with upward search. E.g. with a command like '/foo', the loader will go up the tree until a node containing a 'foo' element is found. * C::M::Node: added backend_support_annotation method. This will ne used by the Tk GUI to decide whether to display a widget to edit annotation (aka comments) Doc improvements: * Backend::Any: added missing doc about method that can or must be overloaded by a read/write backend. 2.073 2015-07-19 Bug fix: * Fix typo in module name loaded in tests that led to impossible build requirement (RT #105938) 2.072 2015-07-18 Functionality improvements: * Loader: convert literal "\n" into real \n * shell UI: added 'tree' command to show config tree from current node Improvement of messages shown to user: * Node: Warn if an accepted element is likely a typo (Debian #789568) (this feature requires recommended module Text::Levenshtein::Damerau to be installed) * All: improved location_short output (truncates long path with '[...]' instead of '[truncated...]') * All: improved change summary message Documentation improvements: * Loader: Added examples using cme modify in pod doc * AnyThing: Added missing doc for location_short and composite_name_short * Updated wordpress link to use config-model tag Cruft cleanup: * removed cme-old command 2.071 2015-05-23 Bug and doc fix release: * shell like user interface: * fixed completion of commands (like set, clear...) * improved error message sent when command is wrong * use item location as prompt * Loader: fixed parding of command like foo:.insort("bar( stuff )") which are also used in shell UI. * Backend::Any: mention cme command used to edit config file in comment header when writing back files. (e.g. "You can run 'cme edit lcdproc' to modify this file" is written in header of /etc/LCDd.conf) * Value: fixed formatting and errors in pod doc 2.070 2015-05-03 Added minor features and bug fixes: * Model: + added include_backend model parameter for xorg * include no longer include read/write spec... (Debian #783952) * Hash and Array: clear now triggers notify_change * Value: boolean conversion (e.g yes/no to 1/0) during initial load must not trigger a change notification... * shell UI: + added fix command * added clear command for list hash and value... 2.069 2015-04-25 * Model: Allow inclusion of read/write specification 2.068 2015-03-29 Small improvements: * Value: request configuration save when initial load detects problem like duplicated or mismatched values in config file * Loader: raise an exception when ':' action is used with a value element New features: * C::M::Anything::grab: type param can also be an array ref * Instance: added 'update' method 2.067 2015-03-01 Bug fix release: * SimpleUI: fix 'll' command (failed without argument) * C::M::Backend::Any: + added show_message method (delegated to node) * added missing doc for node attribute * C::M::Instance: callback attributes are now rw (should fix test failures of Config::Model::Itself) * C::M::AnyThing: delegates show_message to instance 2.066 2015-02-15 * C::M::Instance: + added on_message_cb and show_message parameters * C::M::GenClassPod: * added missing doc for gen_class_pod parameters * generate doc in a reproducible way by using "sort keys". This should fix Debian problem with unreproducible build found on libconfig-model-dpkg-perl and libconfig-model-itself-perl * dist.ini: use free.fr address instead of cpan.org to avoid problems with automated release e-mail 2.065 2015-01-06 Bug fixes: * Value: avoid undef warning when creating error message * Node: Must load override class to be able to use it... New (small) feature: * Value: warning or error message defined in a model can contain a $_ to show the bad value to user 2.064 2014-12-04 A small change for this release: * Version 2.062 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. 2.063 2014-11-28 Bug fix release: * GenClassPod: use Exporter instead of Exporter::Lite. * adapted contrib/bash_completion for cme-old 2.062 2014-11-23 Big change for this release: * cme command is no longer delivered with this distribution. cme is now delivered by App::Cme distribution. To help the transition, this distribution delivers cme-old. You can use this command until App::Cme is available in CPAN (next few days) or if you find bugs in the new cme command (which now uses App::Cmd). Other incompatible changes: * old config-edit command is now really gone * cme extensions are obsolete. Extension mechanism is now provided by App::Cmd New feature: * The Perl class used to implement node, list and hash configuration element can be overridden using a new 'class' parameter. The Perl class passed to this parameter must inherit Config::Model::Node, or Config::Model::HashId or Config::Model::ListId. Bug fixes: * Value: skip notification if migrate yields an empty value * Model: use logger for tracing legacy translation 2.061 2014-09-23 Bug fix release: * ValueComputer: leave $@ and $! alone in formula. Also skip variables like '$ foo' 2.060 2014-08-19 Bug fix release: * value.t: avoid smoke test failures * Avoid new perl 5.20 warning (Debian #758320) * Value: improved notify change message (computed vs preset vs default) * fix pod doc in cme (RT 97605, Debian #756433) * depends directly on YAML, not YAML::Any which will be deprecated 2.059 2014-06-29 New features: * cme: + added shell command as a shortcut to 'cme edit -ui shell'. E.g 'cme shell ssh' to edit ssh_config through a shell like UI + add :@ and :.sort sub command for ordered hash. E.g.: "cme modify dpkg-control ~~ 'binary:~/.*/ Depends:.sort' -save" or "cme modify dpkg-copyright ~~ 'Files:.sort' -save " * Config::Model::Value: added warn_if parameter Bug fixes: * cme shell mode: * fix or add completion for several commands * added shell style pattern match to ll and ls command (e.g 'ls foo*') * remove version req from use YAML::Any 0.303 (resolve issues with Debian FTBS) * Value: fix crash when default value raises a warning and code fix returns undef. 2.058 2014-06-19 Bug fix release * cme: modify cryptic user message about "Fixing stuff" * Value: tweak migrate_value to always return something, even undef. This fixes 'cme check dpkg-copyright' crash (thanks gregoa) * Loader: fix pod doc about list operators * AnyThing: avoid undef warning that breaks test on freebsd perl 5.10.1 2.057 2014-06-12 New features: * Config::Model: initialise log4perl during construction * Value: added file and dir value type. A warning is issued when file or dir is not found. Other bug fixes: * Shortens long index to limit the length of warning and error messages * Value: fix check done during apply_fixes... * ObjTreeScanner: tolerate deprecated experience parameter. 2.056 2014-05-18 This release deprecates experience associated with configuration element. experience specification in models is now ignored. Other Changes: * added bash_completion snippet associated to a model. This will be useful for dpkg-patch model * C::M::Lister: skip backup files when listing available applications * replace File::Slurp with Path::Tiny in yaml backend test and gen-class-pod (RT #95692). (which changes the dependencies) * replaced Path::Class with Path::Tiny dependency 2.055 2014-05-02 This release removes all code related to asynchronous stores. This code was buggy. Making this work correctly would require re-writing most of Config::Model. * Config::Model::Value: * added deprecation warning about callback parameter * C::M::Value: removed async code * perltidy run on all files * removed dependency on namepace::autoclean * Removed AnyEvent dependency 2.054 2014-04-01 Bug fix release: * Loader Dumper: fix quote handling (Closes Debian 743097) * Loader: return 'ok' after dispatching an action (avoid undef warning during tests) * cme: -save options force a save even if no semantic change was done * ListId: sort may trigger notify_change is elements are actually moved around, so 'cme modify stuff list:.sort' will save the file as expected. 2.053 2014-03-25 Bug fix release: * Loader: fix broken list leaf assignment (like 'list:4=foo') 2.052 2014-03-23 This release provides new functionalities to 'cme modify stuff' and to the shell like interface ('cme edit -ui shell stuff). See Config::Model::Loader doc for details: + added remove by value on list and hash ( :-= and :-~ ) (Closes Debian #741453) + added lots of list and hash operator usable on 'cme modify stuff'. E.g. :.insort :.insert_before :.insert_at :.unshift :.push :.sort + handle list/hash value substitution ( e.g. list:=~s/foo/bar/ ) * warn when trying to remove a list element with a non numeric index * rationalize list and hash commands: list assignment is now list:=a,b,c instead of list=a,b,c Other changes: * Dumper: use new syntax when dumping a list of value (i.e. list:=a,b,c) * Instance: don't print change if old and new value are undef 2.051 2014-03-06 * cme: fix command like "cme modify foo ~~ " * ValueComputer: formula with eval no longer mess with $& and ${^MATCH} variables used in regexp 2.050 2014-02-27 * Restore NAME section in Config::Model::Manual::* man pages 2.049 2014-02-26 Bug fix and minor new feature release: * C::M::AnyThing: added has_warning fallback method (always return 0) (RT 93329) * C::M::Anything: added clear_annotation method 2.048 2014-02-23 The main changes of this release are the new features of cme command: * add possibility to override config file (for appli with allow_config_file_override) (part of Debian #739387) if config file override is '-', open STDIN to read and STDOUT to write. This way, cme can be used as a filter. * added -strict option so cme exits 1 when warnings are found (Closes Debian #736972) * added -save option to force save. Useful when just reformatting is desired * modify command can apply Perl substitution (s/foo/bar) to configuration values Other changes: * C::M::Loader: * changed hash selection =~ sub-command to :~ + added =~ subcommand to apply Perl substitution to values * Config::Model: load EV at compile time (Debian #738975) * C::M::Value: limit the number of re-try when applying fix to avoid deep recursion errors * C::M::Node: force a save when reading a deprecated parameter (RT 92639) * C::M::Instance: use msg parameter when listing changes * C::M::AnyThing: added doc for notify_change 2.047 2014-01-25 * Value: store a good value cancels the error stored in Instance * Term UI: * list unsaved changes and propose to save on exit or quit * fixed "save" command * added 'changes' command to list unsaved changes * allow also delete command on leaf element * added reset command to set a leaf element to undef * allow spaces around '=' and ':' * tweak cme-gen-class-pod so it can be run without cme (handy for tests) * Model generate_doc: write file if new doc is different from old (don't try to be smart with timestamps) 2.046 2013-12-15 * cme: + added -create option to force creation of missing configuration file * improved message about applied changes and don't show '0' as * added examples in pod doc * BackendMgr: + add note about cme in header of saved file (if comments are supported in the configuration file format) * Improved error message when no config file is found * skip backup copy if no original file is found * Node: avoid unknown element failure when check is 'no' * ValueComputer: * added note in doc about compute variable usage * correctly handles &index(-x) where x is a number > 1 * improved error message if 'follow' parameter does not point to a leaf in configuration tree * overdue doc changes: s/WarpedThing/Warper/g in pod docs 2.045 2013-10-18 * Manually restored dep on MouseX::NativeTraits * bumped dep on Config::Model::Tester to 2.046 * cme: print an error message when no application is specified (Closes Debian #726447) 2.044 2013-10-13 The main change of this release is the addition of a JSON backend so that cme can read and write JSON configuration files. Given that JSON is more and more used, this new backend is bound to be useful. Other fixes: * cme: * force write back if -force option is used * updated doc 2.043 2013-09-20 * build depends on Config::Model::Tester 2.046 to avoid dependency issues * Value: accept yes/no true/false as default value for Boolean. This can make model declaration more consistent when boolean value must be written as true/false, yes/no. In this case, forcing model developer to write default value as 0/1 was not cool and prevented generation of model like LcdProc's model. 2.042 2013-09-15 * Config::Model: load AnyEvent as soon as possible to avoid test issues * ListId: fix typos in pod doc * scripts: use /usr/bin/env to be more portable (e.g. for Mac OSX) 2.041 2013-08-14 Main changes for this release are: * The ENCRYPT parameter of Popularity contest model was changed from boolean type to a yes,maybe,no value, thus allowing a "réponse de Normand" ;) This follows up resolution of Debian bug #714917. * Config::Model::Tester class was moved in its own distribution. Hence this distribution now build depends on Config::Model::Tester Other bug fixes: * Avoid warning with 'cme list' (Closes Debian #719197) * ShellVar backend: Allow variable assignement like "foo = value". This is not legal is Shell but sometimes used in configuration files using a shell like syntax (Closes Debian #719256) Other changes: * Removed build-dep on File::Copy::Recursive 2.040 2013-07-20 * Fix '~' in path substitution in BackendMgr * Skip cme command test on non unix-like systems 2.039 2013-07-18 Framework changes: * CheckList: + Added clear_item and clear_layered methods + added user mode to retrieve data * clear now reset (undefs) a check-list instead of setting items to 0 * load_data accepts hash ref * get_check_list_as_hash: added user mode, don't return 0 for undef items * set_checked_list_as_hash: Missing items in the given list of parameters are now reset * Added dependency on Module::Runtime to avoid test failure on Mac and Windows Backends: * BackendAny: lack of suffix method is now an info not a warning * BackendMgr: + added $home override for tests + added default_layer backend parameter + added os_config_dir parameter - die if obsolete read_config_dir or write_config_dir is specified Test framework: * Tester: + allow override of home directory for tests + can also use $model for internal tests * check test item now accepts array refs Doc: * added log config file in contrib 2.038 2013-07-03 Framework changes: * cme: added -backup option. Application changes: * popcon model: * replace yes/no enum value with boolean written as yes/no + added ENCRYPT support Backends: * all: don't loose part of comment when '#' is embedded in comment * Ini backend: handle storage to non available element by ditching data 2.037 2013-06-15 Framework changes: * renamed ChangeLog in Changes to conform to Perl standards * added missing dep on File::Slurp * cme: added -try-app-as-model option (experimental) * Most pod docs: Replaced obsolete links to Config::Model::AutoRead with Config::Model::BackendMgr Application changes: * Removed LcdProc model (now in its own Perl distribution) 2.036 2013-05-25 Framework changes: * config-edit: added deprecation warning * Value: * fix pod doc error in L<> which tripped smoke tests * apply_fixes: check after fix must be asynchronous * Node::load_data: use a predictable order to accept elements. This change fixes the smoke test error in t/backend_ini.t (Closes Debian #709785) Test changes: * make t/pod.t run only when AUTHOR_TESTING is set (Closes RT 8533 and Debian #709784) 2.035 2013-04-27 * Node has_element: small optimisation for common case * cme: * make sure that async store is used before actual check * load Tk only when using edit command (avoids issues on exit with AnyEvent) 2.034 2013-04-17 * Model: fix generation of model doc that broke with 2.032 2.033 2013-04-15 * Model: load returns loaded class in the correct order. Otherwise Config::Model::Itself will write back config classes in a random order (for files declaring more than one class) 2.032 2013-04-15 Framework Changes: * Model: completely re-organized the way a model is loaded to be able to add model extensions to an included class * Doc: clarified and moved model plugin doc in advanced manual * config-edit: added deprecation warning in Synopsis Application changes: * Fstab model: added missing relatime option 2.031 2013-04-03 Framework Changes: * All: use directly Mouse instead of going through Any::Moose (which is deprecated) * Removed dependency on Any::Moose 2.030 2013-03-23 Framework Changes: * Value: fix reset value for mandatory with default value * Node load_data: added kludge to avoid breaking C::M::Itself Application changes: * LCDproc model generator: Added a more special treatment for Hello and GoodBye parameters to cope with new INI backend (which is more strict than previous versions) 01 2013-02-27 The main change of this release is to provide asynchronous store check. Now, a model can check the validity of a configuration value against a remote resource in a non-blocking way. This is currently used by Dpkg model to check the validity of package names with Debian server through several concurent http requests. This change is backward compatible except for Value store method: it returns now 1 instead of the stored value. OTOH, that feature was not documented. Classes inheriting Config::Model::Value may be impacted, although old version of Config::Model::Dpkg::Dependency is still working. In more details... Framework Changes: * Instance: * propagate check parameter to root node * store path of tree items having an error condition * ListId: * changed load_data signature to accept named parameters * load_data accepts hash_ref and store them in the first element * Value: * croak if notify_change is called for nothing * make sure that all fixes are applied * limit the number of times a fix can be tried * store always returns 1 Backend changes: * rewrote INI parser so that check is enabled directly on store Test Changes: * fixed multistrap tests * test ini backend: test split_reg parameter 2.029 2012-11-28 * cme-gen-class-pod: pod doc can be generated from a class specified on command line argument (really this time, previous version was broken) * cme: run the first extension found in @INC, not the last one 2.028 2012-11-27 * cme: + added a BUGS section in man page * Improved error message for unknown elements * cme-gen-class-pod: pod doc can be generated from a class specified on command line argument * fix test that broke with perl 5.17 * removed unneeded 'use UNIVERSAL'. (should fix smoke tests) 2.027 2012-10-30 * fix checklist problem with writing default values (which broke openssh demo). (Closes: Debian #691338) * Dumper: fix wrong module reference in pod doc 2.026 2012-09-27 * Re-released 2.026_2 as good to go. 02 2012-09-20 * Added build-time dep on YAML::Any 01 2012-09-20 * Application changes: * IMPORTANT: Debian Dpkg model was removed. It will be available on Debian soon as a native package. It will also be published on CPAN in Config::Model::Dpkg. * Framework changes: * cme: added possibility to run extensions. The first extension is gen-class-pod. I.e. you can run 'cme gen-class-pod' (which is useful only if you develop a configuration model...) 2.025 2012-09-10 * Test: Fix fuseui test regression that shows on non-linux systems 2.024 2012-09-04 * Debian dpkg dependency: * Warn and can remove unversioned dependency on essential package (Debian bug 684208) * Warn and replace perl-modules dependency with perl * Don't mess with alternate dependency with < relation (Closes Debian #682730) * remove Debian epoch when checking perl module version from corelist (Debian bug # 683861) * Framework changes: * Lister: use @INC to get available application models. This is mostly useful to use local models for tests * cme command changes: * added bash completion for 'fix' subcommand * fix pod doc (gregoa) * improved notification change (avoid duplication and added a clear message for swap) * cme: added -dir-char option for fusefs command 2.023 2012-07-04 * Application changes: * Debian dpkg control binary: * In control binary Depends, replace 'perl' dep with ${perl:Depends} This is implemented as a warning and is changed only if apply_fix is called. Duplicates ${perl:Depends} will also be removed by apply_fix. 2.022 2012-07-03 * Application changes: * Debian::Dpkg * fix a race condition between the various calls to Debian's madison site * Framework changes: * added -from and -filter option to cme fix command 2.021 2012-06-28 * Application changes: * Debian::Dpkg * Bump default compat level to 9 (for hardening) * dependency model: * Make concurrent calls to madison to reduce user wait with AnyEvent::HTTP * make sure that apply_fix trigger notification changes so the fixes are indeed saved when running apply_fix (thanks to gregoa for the heads up) * copyright: allow any non-space character for license short name * Framework changes: - Removed dependency on LWP::Simple + Added dependency on AnyEvent and AnyEvent::HTTP * cme: clean up the mess after AnyEvent headbutts Tk :-/ 2.020 2012-06-18 * Application changes: * Fix DEP-3 model: + added missing parameters (Subject ...) + accept Bug-* parameters * Better cope with unstructured text after Subject keyword * Framework changes: * prepare release. depends on List::MoreUtils * fix cme doc example (Closes Debian: #677069) * Node: accept stuff: added 'accept_after' parameter * Tester framework: * force write_back during tests 2.019 2012-06-05 * Framework changes: + doc generated from model now provides details on status (e.g. deprecation) and migration (HEAD, master) * check_list: make sure that apply_fixes can be called on check_list even though it does nothing there 2.018 2012-05-29 * Application changes: + Debian::Dependency: Added a check and fix for debhelper version requirement taking into account compat value. This check is available only with full dpkg model (i.e. "cme xxx dpkg" command). It is disabled when using only dpkg-contol model ("cme xxx dpkg-control"). * Debian::Dpkg model: fix default Vcs-Git URL for debian-perl packages * Framework changes: * Value: * avoid issuing the same warning twice * send a notif warning only when default data is different from current data as already seen by user (i.e. // ) * cme: better formatting when printing changes * WarpedNode: Don't call notify_change when not needed. * added a note parameter for notify_change * Instance: initial_load default value is now 0. * Node: correctly set initial_load mode when init is called recursively 2.017 2012-05-21 * Framework changes: * Fix missing YAML dependency in configure require 2.016 2012-05-20 * Framework changes: * Having dependencies in prereq does not mean they are listed in runtime require. The dependency list is now duplicated to have them in prereq (for smoke tests) and runtime require. This should help smoke tests for modules depending on Config::Model * Fixed small doc mistake in Tester 2.015 2012-05-14 * Application changes: * Copyright model: replace migrate_keys_from with new migrate_values_from. This simplifies the model * Framework changes: + List or Hash: added migrate_values_from to enable migration from another hash or list. migrate_keys_from for list element is now deprecated. * List, Hash, Value: ensure that migration is done after initial load, i.e. once all data from configuration file is loaded. * AnyId, List, Hash: deprecated get_all_indexes in favor of fetch_all_indexes * Value: * make sure that setting a default value triggers notify_change so the resulting modification in the config file can be saved * don't trigger notify_change with update undef -> undef * Test changes: * Tester: added file_contents_like and file_contents_unlike tests 2.014 2012-05-03 * Application changes: * cme: list changes before saving data (unless save is handled by user interface) (HEAD, master) * Dpkg backend: reworked the internal data structure used between DpkgSyntax and the other modules. The new data structure feature the file line number to provide error messages with the line number where the error was found. This patch also tracks what was changed during parsing (see "altered" keyword) to call change_notify with new option "really => 1" (closes debian #670441) * Framework changes: + all: added tracking of changes performed by user. The change list can retrieved from Instance object with list_changes method (this list can be cleared with clear_changes). + Depends on Text::Diff 2.013 2012-04-06 * Application changes: * Debian Dpkg model: Moved libtiff4 transition warning from source Build-Depends to binary Depends * Framework changes: Model doc generation: small formatting fix to avoid Pod::Html errors with Debian/Dpkg/Source.pod (should fix ActiveState breakage) * Test changes: * multitrap tests: really ignore warnings coming from Text::Balanced (which pop up in Perl smoke tests with perl 5.15.9) 2.012 2012-04-05 * Application changes: * Debian Dep-3 patch parser: quilt formats patch in a very concise way. There's no Index: line and no '====='. OTOH, imported patch may contain this lines until the patch is refreshed. This commit makes sure that both types of patch are parsed correctly. * Debian model: changed meta element into my-config. This should make clear that this element stores user's config regarding dpkg files. * Tester: Produced file order is not important. Make sure both list are sorted before being compared (Closes Debian #666705) * Test changes: * multistrap test: ignore load warnings (which pop up in Perl smoke tests with perl 5.15.9) * Framework changes: * Instance: added on_change_cb to take action when something is modified in the config tree 2.011 2012-03-19 * Application changes: + Debian copyright: added deprecated License-Alias paramater. When set to 'Perl', this parameter is migrated into License: Artistic or GPL-1+ + Debian DpkgSyntax: better error message. This was really annoying for DEP-3 patch parser. + cme: added forgotten -stack-trace option * Tester changes: - removed check_* parameter. + Added wr_check parameter + added possibility to pass options to grab and fetch with check and wr_check. 2.010 2012-03-13 * Application changes: * Debian control: * fix warning of section and priority fields + added check and fix for libpng and libtiff4 transistions * Debian Copyright: added warnings if Files uses either [ ] or | (thanks gregoa for the suggestion) * cme: check must check all values * Framework changes: * IdElementReference: use fetch in user mode to get choice list (means values in layered mode) * Value: fetch with allow_undef mode must behave like user mode, not backend mode (fix warp problem in layeredmode) * ValueComputer: added usage of compute as an upstream default value. Some cleanup was done around that 2.008 2012-03-01 * Application changes: * Debian control: + comments are now parsed correctly * Debian copyright model: + added support for deprecated X-Comment. X-Comment fields are converted to Comment fields (note that regular comments are forbidden) * Framework changes: * Requires perl 5.10.1 instead of 5.10.0 * provide file name and line number in syntax error message 2.007 2012-02-26 * cme: fix 'migrate' command. 2.006 2012-02-25 * Application changes: * Debian control model: * bumped default Debian source standards version to 3.9.3 - no longer try to enforce first lowercase in Synopsis. Too many false positives (fix debian #661184) - Removed check for virtual package (source packages are seen as virtual packages). Unfortunately, virtual packages are now reported as unknown packages. Suggestions on how to fix this are welcome. * Debian copyright model: * changed copyright type from line based list to string leaf * Framework changes: + cme: added forgotten 'migrate' command (i.e. cme migrate stuff) 2.005 2012-02-23 * Application changes: * Debian copyright model: updated url for dep-5 format with new Debian approved one. URL is no longer updated silently, user will have to request it with 'cme fix' command 2.004 2012-02-09 * Build.PL runs gen_class_pod.pl which loads Config::Model from lib, hence most of the runtime dependencies are now moved in configure_requires. This should improve Perl smoke tests. 2.003 2012-02-08 * Added configure_requires on File::Slurp (Fix RT#73611) * Updated meta-data to point toward github instead of sourceforge 2.002 2012-02-08 Most of the fixes aim to solve issues with Perl smoke tests * Application changes: * fix bash completion for cme options * Framework changes: * Added dependency on namespace::clean and Mouse * AnyId: remove deprecation warning. check is useful as an alias to check_content * Lister: no need to require perl 5.10 * Tester: don't use next to exit from sub * Tests: * avoid undef $ENV{HOME} problems on Windows 2.001 2012-02-06 Big change this time, hence the version bump tp 2.001. The main change for users is the deprecation of the config-edit program in favor of cme. Instead of using options, this cme uses command keywords like git, so users will have more possibilities while typing less. Internally, some performance improvements were implemented. Given the work required, core Config::Model classes were converted to Moose. In more details: * Application changes: + New cme program to edit/validate configuration. * model Debian::Dpkg: * fixed computed default value for VcsBrowser + added rules element for debian/rules file * DEP-5 model: updated doc and removed obsolete URL. Thanks to skaet for raising this point * Debian/Dpkg/Control/Binary model: + Added deprecated XC-Package-Type. + Added migration from XC-Package-Type to Package-Type * Framework changes: * All: + Improved performance by running validation only when data is modified. (implemented with notify_changes method) * breaks memory cycles in backend manager * Converted to Moose all classes inheriting Config::Model::AnyThing 1.265 2011-12-06 * Application changes: * model Debian::Dpkg: + added Multi-Arch parameter * don't fail when debian/copyright is missing or empty * Framework changes: * Config::Model::Value: layered value is also part of a standard value * Config::Model::CheckList: in custom mode, checklist must return the whole list when queried by user, not just the changed items. (Fix Config::Model::OpenSsh RT#72916) 1.264 2011-11-29 * Application changes: * model Debian::Dpkg: - removed another email check (was hiding in a hg branch) 1.263 2011-11-29 * Application changes: * model Multistrap: * Use convert =>lc on most parameters to match multistrap's behavior + added deprecated forceunpack parameter (migrated to unpack). + force sections and key names to be lowercase + added components parameter to Multistrap::Section model * model Debian::Dpkg: - removed email checks * bash_completion: use new Lister class to gain a lot of speed * Framework changes: + Config::Model::HashId: added convert parameter * Config::Model::Value: recompute choice before checking if a reference matches available choices. + Config::Model::Lister: new bunch of functions to list models and applications. Used only by bash_completion. * Inifile backend changes: * delay validation after read because read order depends on the INI file and not on the model. + added force_lc_(key|name|value) parameter to take care of case insensitive INI files 1.262 2011-11-18 * Config/Model/Tester: avoid test failure by sorting file list before comparing them 1.261 2011-11-17 * Test changes (Config/Model/Tester): * reworked cfg file list check * Avoid test conf pollution from one test to the other + added possibility to specify arbitrary file name (for multistrap) * Application changes: + new multistrap model. Supports multistrap's layered configuration * lcdproc: * lcdconf2model.pl: added better check of info in square brackets * lcdproc/LCDd.conf: resync with upstream lcdproc LCDd.conf * Inifile backend changes: + added write_boolean_as, split_list_value, section_map and join_list_value parameters to cope with special conventions regaring INI files * No longer write empty list parameter (i.e. just "foo=" lines) * ensure that empty sections are not written * Framework changes: * Config::Model::Value: + added write_as parameter for booleans + added clear_preset method + C::M::CheckList, C::M::Instance, C::M::Value: added layered value + C::M::Value::LayeredInclude: new class to include sub-layer of configuration data + config-edit: added -config_file option + added Test::File::Contents build dependency 1.260 2011-10-28 * Application changes * Backend Debian::Dpkg: skip empty lines in patch series files * Framework changes: + Config::Model::Tester: new class extracted from t/model_tests.t to test config files and models. * Config/Model/Loader.pm: Make sure that load("!") goes to root even if load was called from a child node. Fix RT#69480 1.259 2011-10-16 * Application changes * model Debian::Dpkg: Bumped compat default value to 8 * fixed test to work even if lcdproc is not installed 1.258 2011-10-14 * Application changes * model Debian::Dpkg::Patch: Synopsis is no longer mandatory. Issue a warning for empty Synopsis and propose a value based on patch name + model Debian::Dpkg::Meta: added email element + model Debian::Dpkg::Copyright::LicenseSpec: compute license text from Software::License (requires version patched for Debian) * Backend::Debian::Dpkg::Copyright: Rewrote parser to classify correctly Files and Licenses paragraph even if extra fields are prepended. * model Debian::Dpkg::Control::Source: Vcs-browser must also accep https URLs * lcdproc: fixed some specs in square brackets in LCDd.conf template. Reworked model generator to better specs in square brackets and handle model snippets in curly brackets * Framework changes: * ValueComputer: &index and &element can only work with parent or ancestors in tree. Fixed grammar inside of {} statements. It is now able to return '' when no replacement is found * Value: fix warn_if warn_unless check in custom mode. Cleaned up mess about mandatory value checks. Custom values are no longer checked this way 1.257 2011-09-16 * Framework changes: * config-edit: avoid deprecation warning * C::M::AnyId: enable automtic fix of duplicated values * C::M::Node: Create BackendMgr when read_config or write_config is defined (Fixes Debian FTBS in Config::Model::TkUI See #642157) * Application changes + models Debian::Dpkg::Control::Binary and Source: added duplicates warning in dependencies + model Debian::Dpkg::Control::Source: compute Vcs-Browser and Vcs-Git default value for pkg-perl team * model Debian::Dpkg::Patch: No need for a first capital letter restriction. Look for debian patches in the correct places 1.256 2011-09-16 * Application changes * Dpkg control model: warn (and offer to fix) duplicated dependencies + Dpkg model: new compat docs and dirs parameters * Framework changes: * TreeSearcher.pm: properly fix conflict between method name and Moose::Util::TypeConstraints 1.255 2011-09-15 * Framework changes: * Instance.pm, Node.pm: take into account force_load with delayed loading of config files * BackendMgr.pm: New Moose class (renamed from AutoLoader) 1.254 2011-09-04 * fix tests that blow up with Debian build tools 1.253 2011-09-02 * Framework changes: * AnyId: reworked warning storage and display * Value: check can be called without arg to check current value 1.252 2011-09-01 * Framework changes: * AutoRead.pm: correctly handle ~ as home dir (thanks fabreg) * Backend/ShellVar.pm: do not write global comments if there's no data to write * AutoRead.pm: do not leave empty files 1.251 2011-08-30 * Application changes * Backend Debian/Dpkg/Copyright.pm: Fixed parser to avoid confusing License and License-Alias + model Debian/Dpkg/Control/Source.pl: warn in case of duplicated dependencies * Debian/Dependency.pm: Fixed handling of dependency alternates * Backend Debian/Dpkg/Patch.pm: patch write is now working * Framework changes: * Value.pm: rewrote apply_fix to use check to apply fixes. No longer stores fixes as sub ref. * AnyId.pm: rewrote apply_fix to use check to apply fixes. Split check in a global check and dedicated index (check_idx) check * AnyId.pm: Added fix_duplicates feature * Instance.pm: apply_fixes: now relay the call to hash and lists objects * OjTreeScanner.pm: added hooks for node_content hash_element and list_element 1.250 2011-07-22 * Test changes * Debian dpkg tests: reworked cache file syntax (text instead of Perl). Perl file did change randomly depending on order of hash keys. That caused trouble when building Debian packages because running tests did change a source file. * Application changes * Debian Dpkg License model and backend: Reworked Licence models to allow comments and arbitrary parameters in stand-alone licences section (Closes Debian #633847) * Backend Debian::DpkgSyntax: Better handle newlines * Framework changes: * lib/Config/Model/Loader.pm: Raise an exception if a hash of node gets a load string like hash:foo=bar (this one is reserved for hash of leaves) 1.249 2011-07-12 * Framework changes: * Config/Model/Value.pm: * apply_fixes applies all available fixes of a value *then* save the value. * Emit one warning per problem instead of one warning per problematic values (with embedded newlines) * Application changes: * Config/Model/Debian/Dependency.pm: reworked to take buildd limitation into account (check if Perl version is available in sid to decide the order of the alternates dependencies) 1.248 2011-07-05 * Framework changes: * Reworked test framework * New test require new build dependency: File::Copy::Recursive * C::M::Value: allow an enum to have an empty ('') value. * Yaml backend: Do not try to call load_data when YAML file is almost empty (file present but no data in there) * config-edit: force save when command are passed in command line arguements * Application changes: * Debian::Dependency: Do not issue warning when a package is pure virtual (found from local apt cache) * Debian::Dpkg::Control backend: read control information according to element order in config class. This avoids problems when Maintainer field is declared after the Dependencies 1.247 2011-06-27 * Application changes: * examples/lcdproc/LCDd.conf: fix typos * Framework changes: * lib/Config/Model/Backend/IniFile.pm: Fix failure to load in debug trace: do not call location when $obj is undef 1.246 2011-06-17 * Application changes: * LCDd.pl model: re-generated with new C::M::Itself to avoid spurious pod formatting. Fix issue with embedded quotes in Hello and GoodBye parameters. 1.245 2011-06-17 * Application changes: * models Debian::Dpkg::Copyright::License: Allow any license exception keyword (fix Debian bug #627874) + New model for lcdproc: The model for lcdproc (LCDd) is generated from the template LCDd.conf file provided by lcdproc project. This model can be generated by running Dist::Zilla (when working from Mercurial) or by running Build.PL (when working from Config::Model Perl distribution). Note to packagers: LCDd conf files are (c) 1999-2011 William Ferrell and others, GPL-2. Consequently, all LCDd models files (generated from LCDd.conf) are (c) 1999-2011, D Dumont, William Ferrell and others, GPL-2. * Framework changes: * lib/Config/Model/Backend/IniFile.pm: - Do not write twice leaf comments - handle warped_node like nodes * lib/Config/Model/Loader.pm: Do not remove first and last escaped quotes * Build.PL: Check (and may be generate) pod doc at build time (on top of release time) * lib/Config/Model.pm: Fix doc generator to test correctly for time stamp before re-writing docs * lib/Config/Model/Backend/IniFile.pm: When check is 'no', discard data that belongs to unavailable elements 1.244 2011-05-16 * Application changes: * Fstab model: Prevent wrong value in fs_passno and fs_freq with bound mount point * Dpkg: Added doc for control Architecture. Fix pod doc in DpkgSyntax backend * Debian/Dpkg/Meta.pl: applied Debian patch fix_perl_group_filter (set group_filter of debian perl team to 'etch' instead of 'lenny') * Framework changes: * config-edit: added -search and -narrow-search options. This options enable search in tree element, values and tree documentation. * config-edit: cleaned up option names (always accept '-' in place of '_') * Config/Model/AnyThing.pm: fix location string and fix grab function 1.243 2011-05-02 * Application changes: * dpkg control: bumped standard version to 3.9.2 * dpkg: fix spelling . Closes RT# 67783 and 67784. Thanks carnil * dpkg control license: tweaked grammar to accept commas in license fields. Closes Debian #624305. Thanks Niko Tyni. * Dpkg/Control/Source.pl : added XS-Python-Version ans X-Python-Version (first steo to solve Debian #624321) * Debian Dpkg Meta model: package filter is computed from group-filter OR private policy * Framework changes: * reworked warp registration mechanism (Changed inherited WarpedThing into delegation to Warper) * t/debian*.t: Put back Apt::Pkg test to avoid smoke test failure * ValueComputer: Fixed bug to allow temporary variables and $_ in eval'ed formulas 1.242 2011-04-07 * Application changes: * dpkg control: added Build-Conflicts field * dpkg: Added model for debian/source/options and debian/clean files * Framework changes: * Value: don't perform value check when fetching standard or default value * Backend/Plainfile: now support list element in the form of multi line file. Each line of the file is a value of the list. * t/fuse_ui.t: skip test if lsmod cannot be used (e.g. Mandriva) * t/debian*.t: skip test when /etc/debian_version is not found 1.241 2011-04-07 * Framework changes: * Build depend on Test::Differences * Load and grab: fix to accept '-' in element names * Model.pm: Added value help and summary in generated documentation * DumpAsData: skip hash keys containing undef values 1.240 2011-04-05 * Framework changes: * Most *.pm: replaced 'no Moose' by 'no Any::Moose' 1.238 2011-04-05 * Framework changes: * Build.PL: removed dead code that cause downstream pacaking problems. * Model.pm: fix cosmetic issue with doc generation. 1.237 2011-04-04 * Framework changes: * added MouseX::NativeTraits dependency (fix RT #67196) * config-edit: fixed typo (fix RT #66403) * Value, Node, AnyId: use dclone to backup constructor parameters * Model: Correctly write author and copyright in doc (i.e not as ARRAY0x0...) * Yaml backend: fill full_dump option (did not work when set to 0) * Application changes: * dpkg control dependency: - Dependency filtering mechanism uses source package name to find filter value in Meta. This makes more sense than using binary package name 1.236 2011-04-01 * Application changes: * dpkg control dependency: - Dependency filtering mechanism now use dpkg meta package_dependency_filter value (i.e. a user parameter). Debian_perl package will be filtered on lenny by default Filter mechanism can be overriden in a package by package basis See Debian::Dpkg::Meta config class for details. - Warn if a package is unknown. - Accepts version specified with dpkg variables. * dpkg control and copyright: warn if dh-make-perl boilerplate is found * dpkg control: added Package-Type parameter (Peter Pentchev) * Dpkg meta: new class to enable user to customize dpkg editor. (email-updates and dependency-filter). Content of meta is saved in ~/.dpkg-meta.yml * Dpkg control: change e-mail address based on content of meta email-updates * Framework changes: * Value: added replace_follow parameter to specify automatic replacement based on a hash somewhere in the configuration tree (used by dpkg e-mail update) * Extracted initialisation of reader and writer from new() and moved in init() method to avoid deep recursion on startup. * Use Any::Moose instead of plain Moose * Removed dependency on MooseX::Singleton * Model: added author, copyright, license fields. This data is not used by Config::Model, but can be used in the user interface or to generate config class doc * AnyThing: Fix parsing of multi line annotations. Now use Pod::POM to load annocation from Pod document * dist.ini: Depends on Pod::POM * Model.pm: added generate_doc method * config-edit: new -gen-pod option to generate pod document from config class * HashId: fix default_with_init to be able to auto-create leaf values specified in the model 1.235 2011-03-01 * Application changes: * dpkg control source model: Encourage Standard-Version 3.9.1 * dpkg control dependency: only versions older than old-stable (i.e. not found on madison) will trigger a warning * dpkg copyright: Handle license in header (Closes Debian #614776) * Dpkg copyright backend: skip empty copyright lines * Framework changes: * WarpedThing: Can warp based on the location in a tree. For instance to make an element mandatory in one place and not in another. Used by Debian copyright model * Value: mandatory values also require non-empty strings * config-edit: Force to load all sub-models (i.e. control, copyright) of a top-model (err.. dpkg) when run with option -ui none 1.234 2011-02-21 * factor out comment extraction: code that retrieve comments and tie it to actual config data is generic. Now this is handled by C::M::B::Any::associates_comments_with_data * factored out comment writing in C::M::B::Any::write_global_comments and C::M::B::Any::write_data_and_comments * Fix bad handling of leaf type Ini backend (Thanks Krzysztof for the notice) 1.233 2011-02-11 * Application changes: * dpkg control source model: Added DM-Upload-Allowed and all Vcs-* tags defined in Debian reference guide (Thanks Peter Pentchev for the patch) (Fix RT 65575) * Framework changes: * Backend Ini file: Fixed comment handling * All modules: Improved synopsis. You can now save them in a file and have a working program * Remove crappy handling of comments in load_data methods. * DumpAsData: Write annotations as pod in method dump_annotations_as_pod * Anything: load_pod_annotation load annotations from a pod document * Instance write back: now correctly call all write_back when several nodes in model needs to be called back 1.232 2011-01-30 * Added missing Text::Autoformat dependency 1.231 2011-01-30 * Application changes: * Debian::Dependency: reworked to reduce calls to madison. Report available versions when unnessary version issue is found.). Source is optional. * dpkg control model: added forgotten Enhances and Pre-Depends. Added warnings for too long lines in Description (plus fixes based on Text::Autoformat). Added Synopsis element to better tune warnings and fixes * Framework changes: * FuseUI: Fix undef warning. Ensure that files finish with "\n". Fix bug where value 0 was shown as an empty file. * Added PlainFile backend (each config parameter is stored in its own file. useful for some dpkg data) 1.230 2011-01-21 * Application changes: * Debian::Dependency: don't check debhelper * Debian::Copyright: removed license keyword warnings. (fix Debian #610242), lots of other bug fixes (including debian bug #609889 #610231) * Framework changes: * AnyId: added migrate_keys_from to migrate list or hash content during updgrades. * ObjTreeScanner: Added node_dispatch_cb parameter to setup callback dedicated to specific configuration classes. * ValueComputer: added 'undef_is' to allow undef value in formulas. Useful for complex migration scenario where migration can come from several alternative parmeters. * FuseUI: Fix bug that disabled write in a boolean value 1.229 2011-01-10 * config-edit: added -apply-fixes option * Value: can specify wider replace instruction by using regexp as key of the 'replace' parameter * Debian::Dpkg::Copyright: updtead to new CANDIDATE DEP-5 specification. Copyright files written for older specifications are migrated to the new specification. This should save a lot of typing from my fellow Debian packagers. Feedbacks are welcome. 1.228 2011-01-09 * Specifically require DB_File as this module is not available by default on Ubuntu * Skip Debian dependency tests when AptPkg::Config is not available (non Debian systems) 1.227 2011-01-07 * Model.pm: deprecated name_match parameter in accept specification. The regexp should now be specified as a key of a hash. * Value.pm: warn_if_match and warn_unless_match can speficy instructions to "fix" the value. * WizardHelper: can be set to stop on items with warnings. Added bail_out method to bail out cleanly from wizard helper. * model Debian::Dpkg::Control::Binary: Depends element specifies Perl cargo class Config::Model::Debian::Dependency (see below) * Likewise for Debian::Dpkg::Control::Source Build-Depends* * Debian::Dependency: new class derived from Value to provide checks specific to Debian dependencies (syntax, whether a "(>= vers)" is necessary or not, ... ) * New dependency: LWP::Simple 1.226 2010-12-08 * config-edit: mount fuse file system in the background. (like sshfs) * FuseUI: Improved doc * C::M::Backend::Fstab: improved doc 1.225 2010-12-06 * Build.PL: build depends on Test::Command 0.08 to avoid smoke test problems 1.224 2010-12-06 * Node AnyId Value: get() now accepts check parameter, autoadd parameter * Node AnyId: added children method * Added Fuse interface: configuration tree is mapped to a virtual directory. Use config-edit -ui fuse -fuse_dir some/where to use. Stop with 'fusermount -u some/where' * Recommends Fuse (to be able to use fuse user interface) 1.223 2010-11-28 * Debian/Dpkg/Copyright: removed restrictions on copyright format * dist.ini: added build dependency on Probe::Perl (to run tests that invoke config-edit) * Model.pm: can now load model snippet from Foo.d directory. I.e. *.pl files found in Foo.d are used to augment Foo model. This will be useful to agregate models coming from several teams. For instance any team can extends the Fstab model provided in this distribution. 1.222 2010-11-22 * bash-completion: fixed missing application option * Fstab model: specify '/etc' dir inst 1.221 2010-11-21 * Annotation: can now save annotation for node and list objects * Added new Fstab model and backend. Supports ext2 to ext4 and other file systems. Please contact the author if options are missing. * Fix pod spelling errors (RT #62947). Thanks to carnil for the report and patches. * added config-edit test (build requires Test::Command) * config-edit: added -application option, added -list model|applications option * Model.pm: updated doc * bash_completion.config-edit: is now *not* executable 1.220 2010-11-10 * Fix Build.PL to install files found in lib/Config/Model/*.d * Added Cookbook::CreateModelFromDoc from SF wiki 1.219 2010-11-09 * config-edit: fixed syntax error * replaced command lines generated from template by bash-autocompletion. * Removed dependency on Text::Template * Added Config::Model::Manual::ModelCreationIntroduction doc from SF wiki 1.218 2010-11-05 * Moved doc from README into model.pm * Copyright: added deprecated parameters (Upstream-Name Upstream-Maintainer Upstream-Source). Added migrate_from instruction to migrate user data from old parameters to new parameters. * Copyright: Removed fuzziness around trailing '+' in licence names * AnyThing.pm: grab() : accept '+' without surrounding quotes in argument * WarpedNode: delegates copy_from and dump_tree to Node (fixes hash copy with warped nodes) * config-edit: added -open_item option * Build.PL: configure_depends on Text::Template to avoid CPANPLUS installation failure 1.217 2010-10-26 * Fix issue where value reference did not follow refered to parameters after creation. * Fstab example: split the model for the Debian mini-debconf workshop 1.216 2010-10-26 * Control.pl: fixed control fields order to be less confusing (thanks to ansgar for the advice) * Backend IniFile: Bug fix to write top level parameters before the first INI class * Node.pm: Bug fix when calling fetch_element with accepted parameters * Model.pm: updated doc to point to overview and introduction on SourceForge wiki * example/fstab/Fstab.pl: Fix model so it can be loaded by config-model-edit 1.215 2010-10-19 * Instance.pm and Loader.pm: added some stub to preserve backwards compatibility 1.213 2010-10-19 * AutoRead.pm: do not clobber configuration file when trying to write erroneous data * Value.pm: fix value check based on Parse::RecDescent * Dpkg::Copyright: fix bugs masked by above problem * Dpkg::Copyright: Fix read/write issues with License that can be stored either in Files section or their own sections 1.212 2010-10-15 * Value and AnyId: store wrong values when store check is disabled (i.e. config-edit is run with -force option). * Debian::Dpkg::Copyright: cosmetic improvements on written file * Instance.pm: Removed all overengineered push_no_value_check, pop_no_value_check. This stuff had too many drawbacks of global variables. An optional check parameter was added to a lot of calls on Config::Model. The API was also sanitized with some positional parameters replaced by named parameters. Most of these changes should be internal. The main impact is that read/write backends must now explicitely pass this check parameter lest the force_load will not work. * ValueComputer: Remove req on Parse::RecDescent version. (Debian bug #597794) * Value.pm: added silent parameter to fetch method to avoid displaying warnings on STDOUT * Enable read and write of utf8 characters 1.211 2010-10-01 * Value.pm: added warn_if_match and warn_unless_match parameters. Value will issue a warning if the stored value match (or does not) match a Perl regular expression specified in the model. * AnyId.pm: Likewise, added warn_if_key_match and warn_unless_key_match. * Value.pm: added warn parameter. Unconditionaly issue a warning with a string specified in the model. Mostly usefull for deprecated or accept'ed parameters * Loader.pm: load string can now undef a leaf with '~' action. E.g load("foo~") will set foo parameter to undef. * Copyright model: warn if unknown license is used. 1.210 2010-09-30 * renamed config-edit-dep5 in config-edit-dpkg-copyright * renamed Debian::Dep5 model to Debian::Dpkg::Copyright * renamed Config::Model::Backend::Debian::Dep5 backend to Config::Model::Backend::Debian::Dpkg::Copyright * Factored out code to read/write control files in Config::Model::Backend::Debian::DpkgSyntax * Created model and backend for Debian control files * added config-edit-dpkg-control command line 1.209 2010-09-20 * Fixed Debian::Dep5 parser: fixed read issue and added write capability 1.208 2010-09-16 * Fixed missing dependencies in Build.PL (Building from hg requires Dist::Zilla and Dist-Zilla-Plugins-CJM >= 3.01) 1.207 2010-09-14 * Added Debian's Dep-5 model (with config-edit-dep5 CLI) * Value.pm: Added validation of value based on a Parse::RecDescent grammar * AnyId.pm: Authorized keys can also be based of a Parse::RecDescent grammar * Node.pm (find_element): returns the element name (if known). Can also find the element in a case insensitive manner 1.206 2010-07-23 First version to feature code written during Google Summer of Code 2010. For this GSoC, Krzysztof Tyszecki has provided: * a new backend for INI file that can: * read and write comments to and from annotations. This way users comments are preserved * read and write parameters that are repeated in the INI file. This repeated parameters will be loaded in list elements * the capacity to load annotation from perl data structure * a new model feature to accept unknown element. This will enable loading and writing configuration files even if parameters are unknown. This feature is required to create models targeted for configuration upgrades: only upgrade and migration specifications need to be specified in a model. Parameters that don't change from one version to another need not to be specified in the model. Other changes: * lib/Config/Model/Loader.pm (_walk_node): bug fix to load node element annotation * lib/Config/Model/Dumper.pm (): bug fix to dump hash and list element annotations * Fixed Fstab example 1.205 2010-06-04 * t/node.t: patch by Niko Tyni to avoid Carp::Heavy failure. Fix Debian FTBS bug #582915 and countless CPAN smoke tests failures 1.204 2010-06-03 * MANIFEST.SKIP: Prompt re-release because 1.203 tarball contains debian packages used for tests (oops) 1.203 2010-06-03 * lib/Config/Model/Loader.pm (_load_hash): Bug fix: can load annotation tied to hash values (node or leaf). 1.202 2010-04-22 SUMMARY: * New core feature: user can store annotation (e.g. structured comments) with each configuration object of the configuration tree, be it node, leaf, hash or list. Read backend can parse confguration file comments and store them in annotations. For instance ShellVar read backend will parse comments and store them in the configuration tree. ShellVar write backend will put them back in the configuration file. * PopCon editor preserve comments in configuration file. * Code: Uses Moose for C::M::Annotation and C::M::Backend::Any. Moose looks good. I may use Moose for all other Config::Model classes later. * lib/Config/Model/Backend/ShellVar.pm (read): Tries its best to read user comments and store them in annotations. (write): Write annotation as comments. Write model documentation as comments starting with '##' * lib/Config/Model/AnyThing.pm (grab_annotation): new method * lib/Config/Model/Loader.pm (load): Can load string with annotations * lib/Config/Model/Dumper.pm (dump_tree): Dumps annotations in data string * lib/Config/Model/AnyThing.pm (annotation): new accessor method for annotations. * lib/Config/Model/Annotation.pm : New file to load and save configuration annotations (just like comments with a structure) * Build.PL: added dependency on Moose * lib/Config/Model/models/PopCon.pl: Fixed PopCon config directory. Cosmetic improvements for descriptions. * lib/Config/Model/*.pm: Put back VERSION number and bumped them all to 1.201 to make CPAN indexer happy 1.001 2010-03-28 * Build.PL (process_tmpl_files): Build depends on Text::Template. Generates config-edit-popcon * config-edit.tmpl: New file to create dedicated config-edit-foo commands * lib/Config/Model.pm: Version bumped to 1.001 * lib/Config/Model/Backend/ShellVar.pm : New backend to read and write configuration files used by shells (sourced by scripts) * lib/Config/Model/WizardHelper.pm (node_content_cb): no longer forget to scan element that are warped in while scanning the node. * lib/Config/Model/Node.pm (previous_element): new method to iterate through availalble node elements * lib/Config/Model/Value.pm (setup_match_regexp): added new 'match' parameter to validate a value against a Perl regular expression. * lib/Config/Model/Node.pm (load_data): can load data in hidden element when store check is ignored. 0.644 2010-03-11 * lib/Config/Model/Loader.pm (load): Load string now support: - '.=' operator to append to config values. - '=~' to loop configurations instruction over list or hash elements * all: Applied spelling corrections done by Debian Perl team (thanks gregoa) 0.643 2010-02-23 * lib/Config/Model/DumpAsData.pm (dump_as_data): Can dump ordered hash in hash ref with __order key to specify order of hash elements * lib/Config/Model/HashId.pm (load_data): Accept hash ref with __order to load ordered data * lib/Config/Model/AnyId.pm: For better clarity, Hash and List parameter max and min are changed to max_index and min_index. Backward compatibility is kept, but warning will be displayed on the terminal when the old parameters are used. * lib/Config/Model/Backend/Yaml.pm: New backend to read and write YAML configuration files. * lib/Config/Model/CheckList.pm (set): buf fix: split input value to get the list of checked items. Migrated to Log4perl * lib/Config/Model/CheckList.pm: Fixed default and upstream default handling 0.642 2010-01-21 * lib/Config/Model/WarpedNode.pm: added get_help to methods forwarded to Node object to avoid breaking the graphical model editor 0.641 2010-01-19 * lib/Config/Model/Node.pm: Ported to Log4Perl (Tree::Node class) * lib/Config/Model/AutoRead.pm: Doc updates on plugin mechanism for read/write classes * lib/Config/Model/Value.pm: model example updates * lib/Config/Model/Dumper.pm (dump_tree): Correctly quote values in list elements * lib/Config/Model/HashId.pm: Ported to Log4Perl (Tree::Element::Hash class) * lib/Config/Model/Instance.pm (write_back): Croak if no write_back callbacks were registered 0.640 2009-09-09 * lib/Config/Model/WizardHelper.pm (new): Correctly scan list element. 0.639 2009-07-30 * lib/Config/Model/WizardHelper.pm (leaf_element_cb): bug fix: scan correctly leaf elements of a hash. * lib/Config/Model/WizardHelper.pm: use Log4perl * config-edit: Tk cosmetic improvement. Thanks to Jerome Quelin for the suggestion * lib/Config/Model/WarpedThing.pm (_do_warp): Use Log4Perl. Improved error message * lib/Config/Model/Searcher.pm (): replace prints with Log4perl. Fixed data structure bug 0.638 2009-06-29 * lib/Config/Model/WarpedNode.pm (is_auto_write_for_type): Added new method that need to be forwarded to Node to avoid write cds_file bug. 0.637 2009-06-23 * lib/Config/Model/Value.pm: As suggested by Jonas Smedegaard, replaced 'built_in' parameter with 'upstream_default'. This change will trigger warnings but no errors with existing model. To get rid of the warnings, the easiest solution is to update the model by running "config-model-edit -model Foo -save" (config-model-edit is provided by Config::Model::Itself) * lib/Config/Model/CheckList.pm: replaced 'built_in_list' parameter with 'upstream_default_list'. This change may also trigger warnings. These warnings will also be fixed by running the config-model-edit command described above. * lib/Config/Model/Value.pm: use Log::Log4perl with categories Tree::Element::Value and Tree::Element::Warper 0.636 2009-05-30 * lib/Config/Model/AutoRead.pm: Added skip_open to avoid opening config target file when the open must be done by the backend (e.g. for Augeas backend) * lib/Config/Model.pm (instance): name parameter is no longer mandatory. Uses 'default' as default instance name. * lib/Config/Model/AutoRead.pm: When calling backend, 'file' parameter contains configuration file name without path and 'file_path' parameter contains complete path and file name 0.635 2009-04-17 * config-edit: added -dumptype option. -dump can now be used to specify a file name * lib/Config/Model/Instance.pm (new): Added skip_read parameter * lib/Config/Model/Node.pm (new): Added skip_read parameter * config-edit: Fix broken Log4Perl default config. Added -load option * lib/Config/Model/AutoRead.pm (): Reworked doc. Aligned read and write specs (now have same parameters). Read and write callback are passed an opened file handle if possible. Now use Log::Log4perl. * lib/Config/Model.pm (include_one_class): Can no longer clobber element with 'include' class feature. * lib/Config/Model.pm (check_class_parameters): Accept summary parameter. Summary is optional and will be used either to generate user interface or may be used to provide comments in saved configuration files. * lib/Config/Model/Node.pm (get_help): added options to get either summary or description of an element * config-edit: added -dump and -load options 0.634 2009-02-24 * config-edit: removed kludgy read_root_dir and write_root_dir options. For test, only one root_dir can be specified (like Augeas) * lib/Config/Model/ListId.pm: auto_create parameter is replaced by auto_create_ids (still trap wrong parameter to avoid memory problems) * lib/Config/Model/HashId.pm: auto_create parameter is replaced by auto_create_keys * lib/Config/Model/ListId.pm (auto_create_elements): Trap wrong auto_create argument (avoid massive memory consumption) 0.633 2008-12-23 * lib/Config/Model/AutoRead.pm : Added -allow_empty parameter so starting a configuration from scratch can be allowed by configuration model designer. No longer die if 'augeas' backend (or any other optional backend) is not found. Just emit a warning. 0.632 2008-12-16 * config-edit: added -backend parameter so (advanced) user can specify which read/write backend to use. The actual backed to use depends on the model loaded with -model option * lib/Config/Model/Instance.pm (write_back): Added backend parameter to specify which backend to use to write. By default, all backend are tried until one succeeds. This parameter can also be specified when calling the constructor 0.631 2008-11-10 * lib/Config/Model/Value.pm (_pre_fetch): removed dependency on Error * lib/Config/Model/WizardHelper.pm : removed dependency on Error * lib/Config/Model/AutoRead.pm (auto_write_init): Move Augeas read/write feature out of Config::Model. This feature is now available in an additional class: Config::Model::Backend::Augeas. This class is distributed in its own Perl distribution. * lib/Config/Model/Dumper.pm (dump_tree): No longer dump list elements that contain only undef values. No longer dump node that do not contain data. 0.630 2008-10-21 * t/augeas_backend.t: Skip sshd_config tests if Augeas library <= 0.3.1 0.629 2008-10-13 * lib/Config/Model/CheckList.pm (set_properties): Added ordered parameter to checklist. Ordered checklist feature is required by Ssh model for Ciphers list (see Config::Model::OpenSsh). * lib/Config/Model/AnyId.pm (get_cargo_info): New method 0.628 2008-09-29 * lib/Config/Model.pm: Allow include of read or write config parameters (required by Xorg model) 0.627 2008-09-23 * ChangeLog: I plainly forgot to update this file for v0.626. This is fixed now. 0.626 2008-09-22 * lib/Config/Model/AutoRead.pm (read_augeas): Lot of bug fix to read and write through Augeas. Now, lens containing 'seq' lenses must be explicitely declared. * lib/Config/Model/Value.pm (migrate_value): No longer fails when a migrated value is also a mandatory value. * lib/Config/Model.pm (create_config_class): No longer creates empty include in model when skip_include is true (breaks Config::Itself tests) 0.625 2008-07-30 * lib/Config/Model/ListId.pm (swap): Swapped or moved values in a list no longer provides wrong location in config tree. (index_value were not updated in objects contained in List after a swap or a move) 0.624 2008-07-24 * lib/Config/Model/Value.pm and others: Modified to allow smooth configuration data upgrades without requiring user input (if used by packaging, this should really help in avoiding rpmsave or dpkg-old files) (See migrate_from parameter) * lib/Config/Model/ValueComputer.pm: added 'use_eval' parameter to allow more complex computation like regexp in string or uniline values * lib/Config/Model/AutoRead.pm: Major changes to interface Config::Model with Augeas (http://augeas.net). Changes are compatible but new warnings are issued: - 'syntax' is replaced by 'backend' to indicate that permanent storage of configuration data is more than a matter of writing a configuration file. - introduced 'config_dir' and 'root' paramater so a backend can specify a configuration dir (e.g. /etc/foo) and a pseudo-root to perform tests (so the config file can land in my_root/etc/foo). * lib/Config/Model/Dumper.pm (new): skip_auto_write now take a storage backend name as a parameter instead of a boolean (See AutoRead for explanations about backends) * lib/Config/Model/Node.pm (set): New method to emulate (part of) augeas API (get): New method to emulate (part of) augeas API * lib/Config/Model/Loader.pm (): Added load command '~' which was forgotten. This command can delete hash or list item. I.e. load("foo~") will delete element 'a' for hash 'foo' (_load_list): command '=' now clear all values before storing the set of values in the list. * lib/Config/Model/AnyId.pm (clear_values): New method to clear values without destroying underlying objects. (set): New method to emulate (part of) augeas API (get): New method to emulate (part of) augeas API * lib/Config/Model/AutoRead.pm: Changed 'syntax' paramter to 'backend' as configuration data may be stored to files or through dedicated libraries like Augeas, gconf ... Backend now can be cds_file, perl_file, ini_file and custom 0.623 2008-05-19 * Build.PL: Moved from Makefile.PL to Build.PL * lib/Config/Model/CheckList.pm: added support for built_in default list * lib/Config/Model/SimpleUI.pm: Some cleanup. Added possibility to add and element name to 'll' command * config-edit: added "dev" and "experience" options. With "dev" option, config-edit will add "lib" to @INC and look for models in "lib" * lib/Config/Model/Node.pm (fetch_element): Bails out if element is hidden (this feature was forgotten) * lib/Config/Model/Value.pm (submit_to_compute): Fix bug where a compute variable in the form 'foo' => '- - &element' did not work (new): allow_compute_override is deprecated in favor of allow_override within the compute parameter (backward compatible change) * lib/Config/Model/AnyThing.pm (dump_as_data): dump_as_data can now be called on all configuration elements. (before, it could only be called on nodes) * lib/Config/Model/AutoRead.pm: Changed the way to specify auto read and write for better clarity. Now they must be specified with read_config => [ { syntax => 'ini'}, { syntax => 'custom', class => 'Mine', function=>'my_read' } ] instead of read_config => [ 'ini', { class => 'Mine',function=>'my_read'}] likewise for write_config * lib/Config/Model.pm: Changed 'permission' to 'experience' and 'intermediate' to 'beginner' for better clarify. Changes are backward compatible. * lib/Config/Model/HashId.pm (move): New method to take into account move within ordered hash * lib/Config/Model/WarpedThing.pm (compute_bool): warp rule no longer fail with eval $foo == 1 when $foo is undef 0.622 2008-04-18 * Value.pm (fetch): added 'allow_undef' mode to allow reading undefined mandatory value (fix morphing warped node containing undefined mandatory values) * Node.pm (copy_from): No longer die when copying undefined mandatory value. * AutoRead.pm (get_cfg_file_name): Do not use ':' in file names. This breaks windows. Now use sub-directories * Dumper.pm (dump_tree): skip undefined values in list element * DumpAsData.pm (dump_as_data): idem * Model.pm (list_class_element): New method to help debugging of configuration models * Model.pm (include_class): allow multiple includes * AnyId.pm: Changed the way the cargo parameter are specified. Now the cargo parameter holds all the information related to the payload of the hash or list. Instead of having : cargo_type => ... , cargo_args => {}, config_class_name => ... you now have: cargo => { type => ..., config_class_name => ..., => ... } Model.pm provides a translation from the old way to the new way so this change is (95%) backward compatible. * CheckList.pm (set): Fix bug that prevented to use level or permission or status parameter with check_list elements * Value.pm (pre_store): Fix bug that prevented to load models with errors even in tolerant mode. 0.621 2008-04-03 * Dumper.pm (dump_tree): Added auto_vivify parameter * DumpAsData.pm (dump_as_data): By default, now provide full dump (with default values). Added auto_vivify parameter * Value.pm (fetch): Check for mandatory values even if fetching only custom values * Value.pm (): Cannot warp value_type anymore (this feature was hard to use and encouraged too complex model). * HashId.pm (swap): Fix swap problem which led to duplicated keys in ordered hash (move_after): New method * ListId.pm (swap): new method (remove): New method, equivalent to splice (@list,$idx,1) 0.6201 2008-03-20 * Makefile.PL: Removed dependency on Term::ReadLine::Gnu. This module is just suggested (as well as Term::ReadLine::Perl) 0.620 2008-03-18 * TermUI.pm: Fixed to work with Term::ReadLine::Gnu or Term::ReadLine::Perl. Can also work in degraded mode without these 2 modules. The command handling part was moved to SimpleUI.pm * config-edit: added Simple UI mode so config-edit can be used with stdin and stdout 0.619 2008-02-29 * Value.pm: removed kludgy enum_integer value type * Instance.pm (write_back): can override directory where config data is written back (necessary for GUI menu like "save in dir ...") * Node.pm (get_help): do not mangle description text (don't remove spurious \s and \n. Leave that to user) 0.618 2008-02-12 * AnyThing.pm (composite_name): new method to return a name like element:index or element. * CheckList.pm (): added refer_to and computed_refer_to accessors 0.617 2008-01-28 * config-edit: added possibility to load Tk GUI (still under development) * Exception.pm (): Fixed misleading error message for UnavailableElement exception * Value.pm (): added "replace" parameter for enum Value. This enables to specify a substitution when storing value. * WarpedNode.pm (check): no longer die when trying to retrieve warped out node, just return undef. This is necessary to be able to load configuration files with important error (e.g. a xorg.conf file with a wrong device driver: all driver option are no longer valid.) * Value.pm (check): Added doc for check. * ObjTreeScanner.pm (permission): new method to get or set the permission of the scanner (after creation). 0.616 2007-12-04 * AutoRead.pm (read_ini): added capability to read configuration data from ini file (See Config::Tiny) (write_ini): can use ini files to store configuration data (read_perl): added capability to read configuration data from a perl data structure (see Config::Model::DumpAsData) from a .pl (write_perl): can use perl file to store configuration data (.pl file) (auto_read_init): configuration model can specify cds (dump string see Config::Model::Dumper), perl or ini with 'read_config' and 'write_config' parameter. 0.615 2007-11-15 * config-edit: added '-force-load' option to load erroneous configuration data. bad data is discarded. * Value.pm : handle 'preset' mode to store values (fetch):accept mode parameter ( [ custom | preset | standard | default | non_built_in ] ) * Loader.pm (_load_list): When loading list, empty value are considered as undef values. I.e 'list_a=a,,"",d' will load ('a',undef,'','d') to lista element * Instance.pm (new): added 'force_load' parameter to load erronueus configuration data. In this case, wrong data will be discarded. (preset_start): new. Use this method, then load configuration data that will be used as "preset data". You can use this feature to load data discovered by an automatic mechanism, like hardware scan. (preset_stop): new. Stop preset mode. Then all data entered will be considered as 'custom' data. These custom data can be compared to 'default' or 'preset' data for audit purpose (preset): new. Query if the instance is in 'preset' mode. * Dumper.pm (dump_tree): changed 'full_dump' parameter (0|1) to 'mode' (full | preset) (dump_tree): if a list contain undef values, they are dumped as a_list=a,b,,d. Empty values are dumped as a_list=a,b,"",d * CheckList.pm (store): work in preset mode (set_checked_list_as_hash): accept a mode parameter ([ custom | preset | standard | default ]) to be able to audit config data (fetch): idem 0.614 2007-10-19 * Value.pm: added 'uniline' value type for string with no embedded newline. (no "\n") * Model.pm (translate_id_names): new method to translate AnyId parameter changes * AnyId.pm: Changed some parameters: follow -> follow_keys, allow -> allow_keys, allow_from -> allow_keys_from * Model.pm (translate_id_default_info): provides backward compatibility for AnyId parameter changes. * AnyId.pm: default parameter is replaced by 'default_keys' and 'default_with_init'. 0.613 2007-09-25 * IdElementReference.pm: Changes the API of IdElementReference so that API is more explicit (Like the API change for ValueComputer). This change is backward compatible (model translation) * ValueComputer.pm: Now compute paramater must use explicit parameters for compute formula, variables and replace. Backward compatibility is kept by translating old compute declaration in Model.pm * Model.pm (include_class): permission, level and description parameters can also be declared within the element declaration. (i.e. at the same level than 'type' ) * IdElementReference.pm (): A reference to a list will now take into account the values of the list instead of the indexes of the list. This makes more sense... * CheckList.pm: Change the name of 'default' parameter to 'default_list' ('default' is still accepted but is deprecated) * WarpedNode.pm: improved synopsis in doc (load_data): new method (forgotten in 0.612) * Model.pm: -doc: added synopsis - inherit is deprecated in favor of include - inherit_after is deprecated in favor of include_after - Raise an exception if an element is declared twice in a model (even through include mechanism: overriding an included element leads to confusion) 0.612 2007-07-26 * HashId.pm : can preserve hash key order (when created with ordered => 1). New method to manipulate hash key order are swap, move_up, move_down. * Exception.pm :new error class Config::Model::Exception::LoadData * AnyThing.pm (grab): added 'grab_non_available' parameter. * AnyId.pm: added "ordered" parameter to create ordered hash elements. I.e. hashes where the order of the keys is kept (like Tie::IxHash) * Value.pm (load_data): new method * Node.pm (load_data): new method (dump_as_data): new method * Model.pm (inherit_class): added inherit_after parameter. In a model, the order of the elements is important. This parameter enable a model to inherit elements from another class and to place them in a specific place among the original elements. (load): returns the names of the class loaded by this method. * ListId.pm (load_data): new method * HashId.pm (load_data): new method * CheckList.pm (load_data): new method 0.611 2007-07-03 * WarpedThing.pm: Modified the way to specify complex warped rules. The former way based on list of lists was confusing. Now you can specify boolean expressions to find the warp rule to apply. * Model.pm: Simplified config class inheritance mechanism: inherit all or nothing. Added translation of legacy warp parameter (based on list of lists) to new warp parameters (based on boolean expressions). So the change done in WarpedThing is backward compatible. 0.610 2007-06-06 * Model.pm (inherit_class): Fix configuration class inheritance mechanism * Value.pm: can also warp help for enum value 0.609 2007-05-09 * config-edit: renamed from config-model * examples/fstab/fstab_test.pl (produce_fstab): added curses interface example (need to install Config::Model::CursesUI to work) * config-model: added possibility to use the curses interface provided by Config::Model::CursesUI (if this one is installed) * ValueComputer.pm: Modified so compute may return an undef value if one of the variable (extracted from the configuration data) of the formula is undefined. In other word, propagate undef instead of croaking. * Searcher.pm: Lots of bug fixes (get_searchable_elements): new method (prepare): new method. Search is now done in 3 moves: create the searcher object, prepare the search, and run the search * Value.pm: removed unique_value parameter which was a bad idea for a check list implementation. Moved reference handling into new IdElementReference class * IdElementReference.pm: New class extracted from Value object so reference can be used also by CheckList * CheckList.pm: re-wrote as a "check_list" type and not a "list" type * Instance.pm (reset_config): new method (searcher): renamed search_element to searcher. searcher retunrs a Config::Model::Searcher object. * AnyThing.pm (searcher): renamed search_element to searcher. searcher retunrs a Config::Model::Searcher object. * AnyId.pm (copy): new method to deep-copy the content of a hash or id element. * Value.pm: moved out reference facility in Config::Model::IdElementReference * Value.pm (fetch_no_check): new method 0.608 2007-02-23 * ObjTreeScanner.pm: Clarified call-back names. 0.607 2007-01-12 * t/term_ui.t: Changed tests to try to load Term::ReadLine and skip tests if Term::ReadLine cannot be loaded. 0.606 2007-01-11 * config-model: Corrected wrong doc for options. * Describe.pm: Small cosmetic changes in output. 0.605 2007-01-08 * config-model: Now uses Log::Log4perl. (Still need to use Log4perl for all *.pm files though). Now write config files back. Added option to read and write config in test directories. * *.pm: Changed e-mail address to reduce spam. * *.pm: Small bug and doc fixes. * Model.pm (load): Model files are expected to be delivered as Perl module and are searched using @INC. (E.g. Xorg.pl model will be searched as Config/Model/models/Xorg.pl in @INC elements) * Exception.pm (full_message): Clarified error message of RestrictedElement exception * examples/fstab/fstab_test.pl: Clarified notifications shown to user. Adapted to changes of 0.604 0.604 2006-12-06 * Node.pm: added check_list in possible element of a node. * Value.pm (set): Changed reference declaration: now value_type must be set to 'reference' when using 'refer_to' parameter. * WarpedThing.pm: can group rules declaration in warp argument to save typing * WizardHelper.pm: adapted for ObjTreeScanner changes * ObjTreeScanner.pm: Modified the callback signature so the user does no longer have to play with closures. - added check_list_cb for CheckList elements - improved doc - added callback example in doc * AutoRead.pm (auto_write_init): bug fix in auto_write functions * AnyId.pm (new): New allow and allow_from parameters to set "allowed" keys of a hash or list. This list of allowed keys can be fixed or dynamic. * AnyThing.pm (root): new method. Returns the root node of the configuration tree. (grab): bug fix so hash identifier can contain white spaces when calling grab (e.g. InputDevice:"Configured Mouse") * CheckList.pm: New class to implement a check list. * Describe.pm: adapted for ObjTreeScanner changes and new CheckList element type * Dumper.pm: idem * Report.pm: idem 0.603 2006-10-19 * Value.pm (set): forbids to specify both 'refer_to' and 'value_type' in value declaration * Loader.pm (load): Accepts now to load configuration data where index can contain white space. (e.g. Monitor:"Hercules Pro") * AnyId.pm: changed 'element_args' to 'cargo_args'. Changed 'element_class' to 'cargo_class'. Added 'follow' parameter so a hash key can mimic the keys of another hash in the configuration tree. * TermUI.pm: removed debug print. This makes auto-completion much easier to understand ;-) * Value.pm (set_default): added built_in default parameter. Built_in default parameter are not written in configuration files but can be used to audit configuration data. * AutoRead.pm (auto_read_init): bug fix: override of read_dir was not taken into account (auto_write_init): idem for write_dir * Instance.pm: added doc for the possibility to specify where to read or write the configuration files. * AnyId.pm (move): also change index value when moving items. 0.602 2006-09-07 * config-model: added -help and -man options to command line * Model.pm (load): model file now must return an array ref and not invoke Model methods. See t/big_model.pm for an example (load): can load model file for model class that contain '::'. In this case the model file is searched in a sub-directory just like a perl class (E.g Model::Foo -> Model/Foo.pm) * HashId.pm (create_default): can initialise children nodes while creating default keys. (Necessary to be able to write a configuration model for Xorg) * AnyId.pm (move): new method 0.601 2006-07-20 * config-model: new program. This programs can be invoked to modify configuration files (provided the corresponding model is available in /etc/config-model.d). (Still shaky. Don't run as root) * Node.pm (get_type): new method (get_cargo_type): new method (get_element_name): added type and cargo_type parameters to filter returned element depending on their type or cargo (contained) type (describe): new method. Uses new Describe.pm file * Value.pm (get_type): new method (get_cargo_type): new method * Model.pm (load): new method. Model can load model declaration from /etc/config-model.d. The model must be valid perl script that ends with an array ref containing configuraiton class declaration like the one accepted by create_config_class * ListId.pm (get_type): new method * HashId.pm (get_type): new method * Exception.pm : Added WrongType exception for new grab parameters * AnyThing.pm (get_type): New method (grab): added strict, autoadd, type parameter. * AnyId.pm (get_cargo_type): new method. (config_class_name): new mehtod * Describe.pm: New file. Provides a human readable description of a configuration node. 0.507 2006-06-15 * TermUI.pm: New file. Provides a shell like interactive user interface. * Node.pm: Now inherit AutoRead class * Instance.pm: Adapted for auto read/write. * AutoRead.pm: New file. Provides node the capabilities to load config data when creating a configuration node. 0.506 2006-05-19 * examples/fstab/FstabModel.pl: added Fstab example with its fstab configuration model. This example includes a small program that use this model to show some ways to extract configuration informations. * Report.pm: new file. Provides report and audit facility for Node.pm * Node.pm (report): new method (audit): new method * Model.pm (create_config_class): added inheritance of configuration models. * HashId.pm (_get_all_indexes): sort returned indexes * Dumper.pm (dump_tree): fix list dump which did not work * AnyId.pm (fetch_all_values): new method 0.505 2006-04-21 * WizardHelper.pm: New file. This class helps to create wizard widget for config models * Makefile.PL: ValueFormula is no longer compiled at build-time but on the fly at run-time. Hopefully this will fix Windows problem and ease integration downstream for a minor performance penalty at start time. 0.504 2006-04-10 * Searcher.pm: Added search element feature. This feature provides a way to search for a configuration element in a configuration tree. The search can be launcher from an instance or any node of a configuration tree. Getting to searched target can be manual or automatic (with call-backs provided by user) * Makefile.PL: Changed grammar pre-compilation to add a "1;" at the end of ValueFormulaParser.pm (Makes Windows happy) 0.503 2006-03-16 * Makefile.PL (MY::postamble): Corrected CPAN dependencies libconfig-model-perl-2.155/MANIFEST.SKIP000066400000000000000000000001651472064100600174200ustar00rootroot00000000000000^debian/ ~$ \.ptkdb$ \.old$ dist.ini libconfig _build \.orig$ ^MYMETA.yml$ blib wr_root \.rej$ README.build-from-git libconfig-model-perl-2.155/MODELS000066400000000000000000000010271472064100600164260ustar00rootroot00000000000000This distribution provides models for the following files (following Debian's config file locations) : - /etc/popularity-contest.conf (for Popcon) - /etc/fstab Models for users: - multistrap configuration Other models: - /etc/approx/approx.conf in Config::Model::Approx - /etc/ssh/sshd_config in Config::Model::OpenSsh - /etc/ssh/ssh_config in Config::Model::OpenSsh - ~/.ssh/config in Config::Model::OpenSsh - ./debian/copyright ./debian/control ... in Config::Model::Dpkg - /etc/LCDd.conf (for lcdproc) in Config::Model::LcdProc libconfig-model-perl-2.155/README.install.pod000066400000000000000000000021341472064100600206260ustar00rootroot00000000000000=head1 Installation =head2 Debian or Ubuntu L and most L modules are provided as Debian package. The following command will install the framework and all available models and UIs: sudo apt-get install --install-recommends --install-suggests cme =head2 Mac OSX L is provided as ppm package by L: =over =item * Install L =item * Update your $PATH variable to run ActiveState's perl =item * Run ppm to install L =back =head2 Windows You can also install L from L. See the instructions for Mac OSX for details. =head2 Fedora Run: yum install perl-Config-Model perl-App-Cme perl-Config-Model-TkUI See L =head2 Other systems For other systems, you should install L from CPAN: cpanp install App::Cme cpanp install Config::Model libconfig-model-perl-2.155/README.md000066400000000000000000000147461472064100600170130ustar00rootroot00000000000000# Config-Model Configuration schema on steroids. [![](https://travis-ci.org/dod38fr/config-model.svg?branch=master)](https://travis-ci.org/dod38fr/config-model) [![](https://badges.gitter.im/dod38fr/config-model.svg)](https://gitter.im/dod38fr/config-model?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) # What is Config-Model project [Config::Model](https://metacpan.org/pod/Config::Model) is: * a set of configuration editor and validator for several projects like [OpenSSH](http://www.openssh.com/), [Systemd](https://freedesktop.org/wiki/Software/systemd/), [LcdProc](http://www.lcdproc.org/)... See [full list of Configuration editors](https://github.com/dod38fr/config-model/wiki/Available-models-and-backends#Available_models_and_configuration_editors) * a framework that enables a project developer (or any advance user) to provide a configuration editor and validator to his users. To generate a configuration editor and validator for a project, [Config::Model](https://metacpan.org/pod/Config::Model) needs: * a description of the structure and constraints of a project configuration. (this is called a model, but could also be called a schema) * a way to read and write configuration data. This can be provided by [built-in read/write backends](https://github.com/dod38fr/config-model/wiki/Available-models-and-backends#Available_backend) or by a [new read/write backend](http://search.cpan.org/dist/Config-Model/lib/Config/Model/Backend/Any.pm#How_to_write_your_own_backend). With the elements above, [Config::Model](https://metacpan.org/pod/Config::Model) generates interactive configuration editors (with integrated help and data validation) and support several kinds of user interface, e.g. graphical, interactive command line. See the [list of available user interfaces](https://github.com/dod38fr/config-model/wiki/Available-models-and-backends#Available_user_interfaces) ## Installation See [installation instructions](https://github.com/dod38fr/config-model/blob/master/README.install.pod). Perl developers can also [build Config::Model from git](build-from-git.md) ## Getting started * To manage your configuration files with existing modules, see [Using cme wiki page](https://github.com/dod38fr/config-model/wiki/Using-cme) * To create configuration tools for your favorite project, see this [introduction to model creation](https://metacpan.org/pod/Config::Model::Manual::ModelCreationIntroduction) ## How does this work ? Using this project, a typical configuration editor will be made of 3 parts : 1. The user interface ( [cme](http://search.cpan.org/dist/Config-Model/script/cme) program and some other optional modules) 2. The validation engine which is in charge of validating all the configuration information provided by the user. This engine is made of the framework provided by this module and the configuration description (often referred as "configuration model", this could also be known as a schema). 3. The storage facility that store the configuration information (currently several backends are provided: ini files, perl files) The important part is the configuration model used by the validation engine. This model can be created or modified with a graphical editor ([cme meta edit](http://search.cpan.org/dist/Config-Model-Itself/lib/App/Cme/Command/meta.pm) provided by [Config::Model::Itself](https://metacpan.org/pod/Config::Model::Itself)). ## Don't we already have some configuration validation tools ? You're probably thinking of tools like webmin. Yes, these tools exist and work fine, but they have their set of drawbacks. Usually, the validation of configuration data is done with a script which performs semantic validation and often ends up being quite complex (e.g. 2500 lines for Debian's xserver-xorg.config script which handles xorg.conf file). In most cases, the configuration model is expressed in instructions (whatever programming language is used) and interspersed with a lot of processing to handle the actual configuration data. ## What's the advantage of this project ? [Config::Model](https://metacpan.org/pod/Config::Model) projects provide a way to get a validation engine where the configuration model is completely separated from the actual processing instructions. A configuration model can be created and modified with the graphical interface provided by ["cme meta edit"](#cme-meta-edit) distributed with [Config::Model::Itself](https://metacpan.org/pod/Config::Model::Itself). The model is saved in a declarative form (currently, a Perl data structure). Such a model is easier to maintain than a lot of code. The model specifies: * the structure of the configuration data (which can be queried by generic user interfaces) * the properties of each element (boundaries check, integer or string, enum like type ...) * the default values of parameters (if any) * mandatory parameters * Warning conditions (and optionally, instructions to fix warnings) * on-line help (for each parameter or value of parameter) So, in the end: * maintenance and evolution of the configuration content is easier * user will see a **common** interface for **all** programs using this project. * upgrade of configuration data is easier and sanity check is performed * audit of configuration is possible to check what was modified by the user compared to default values ## What about the user interface ? [Config::Model](https://metacpan.org/pod/Config::Model) interface can be: * a shell-like interface (plain or based on [Term::ReadLine](https://metacpan.org/pod/Term::ReadLine) with [Config::Model::TermUI](https://metacpan.org/pod/Config::Model::TermUI)). * Graphical with [Config::Model::TkUI](https://metacpan.org/pod/Config::Model::TkUI) (Perl/Tk interface). * based on curses with [Config::Model::CursesUI](https://metacpan.org/pod/Config::Model::CursesUI). All these interfaces are generated from the configuration model. And configuration model can be created or modified with a graphical user interface (["cme meta edit"](#cme-meta-edit)) ## What about configuration data storage ? Since the syntax of configuration files vary wildly form one program to another, most people who want to use this framework will have to provide a dedicated parser/writer. Nevertheless, this project provides a writer/parser for some common format: ini style file and perl file. ## More information See * the [config-model wiki](https://github.com/dod38fr/config-model/wiki) (i.e. the wiki tab above) * [https://ddumont.wordpress.com/category/perl/configmodel/](https://ddumont.wordpress.com/category/perl/configmodel/) libconfig-model-perl-2.155/TODO000066400000000000000000000011001472064100600162000ustar00rootroot00000000000000 o [domi] Update compute so that a built-in value can also be computed. This is required to fix a bug is sshd_config where match element values are needlessly written to files o [domi] Filter element according to element in SimpleUI and TERMUI * Rework backends: - obsolete custom backend - move cds backend in C::M::Backend::Any child class - move perl backend in C::M::Backend::Any child class - Use the same backend object to read and write files This need to move most parameters of read/write to object attributes - Migrate file handling to Path::Tiny libconfig-model-perl-2.155/build-from-git.md000066400000000000000000000032601472064100600206640ustar00rootroot00000000000000# How to build Config::Model from git repository `Config::Model` is build with [Dist::Zilla](http://dzil.org/). This pages 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-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 $ cpanm --quiet --notest --skip-satisfied MouseX::NativeTraits $ 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 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-perl-2.155/contrib/000077500000000000000000000000001472064100600171605ustar00rootroot00000000000000libconfig-model-perl-2.155/contrib/bash_completion.cme_multistrap000066400000000000000000000001371472064100600253010ustar00rootroot00000000000000_cme_multistrap() { COMPREPLY=( $( compgen -o filenames -G "$cur*" -W '~~ -' -- $cur ) ) } libconfig-model-perl-2.155/contrib/log4config-model000066400000000000000000000052241472064100600222370ustar00rootroot00000000000000# save this file as ~/.log4config-model # and edit the trace to customize the logs log4perl.rootLogger=WARN, Screen #log4perl.rootLogger=TRACE, Screen #log4perl.logger.Anything=TRACE, Screen #log4perl.logger.Anything::Change=TRACE, Screen #log4perl.logger.Anything::Fix=TRACE, Screen #log4perl.logger.Async::Value=TRACE, Screen #log4perl.logger.Async::Value::Dependency=TRACE, Screen #log4perl.logger.Backend.Dpkg::Control=TRACE, Screen #log4perl.logger.Backend.Dpkg::Copyright=TRACE, Screen #log4perl.logger.Backend.Dpkg::Patch=TRACE, Screen #log4perl.logger.Backend.Dpkg::Root=TRACE, Screen #log4perl.logger.Backend.DpkgSyntax=TRACE, Screen #log4perl.logger.Backend.Dpkg=TRACE, Screen #log4perl.logger.Backend::Fstab=TRACE, Screen #log4perl.logger.Backend::Itself=TRACE, Screen #log4perl.logger.Backend::OpenSsh=TRACE, Screen #log4perl.logger.Backend::IniFile=TRACE, Screen #log4perl.logger.Backend::PlainFile=TRACE, Screen #log4perl.logger.Backend::Xorg::Read=TRACE, Screen #log4perl.logger.Backend::Yaml=TRACE, Screen #log4perl.logger.BackendMgr=TRACE, Screen #log4perl.logger.FuseUI=TRACE, Screen #log4perl.logger.Instance=TRACE, Screen #log4perl.logger.Loader=TRACE, Screen #log4perl.logger.Model=DEBUG, Screen #log4perl.logger.Model.Loader=INFO, Screen #log4perl.logger.Tk::LeafEditor=TRACE, Screen #log4perl.logger.Tk::HashEditor=TRACE, Screen #log4perl.logger.Tk::CheckListEditor=TRACE, Screen #log4perl.logger.TkUI=TRACE, Screen #log4perl.logger.Tk::ListEditor=TRACE, Screen #log4perl.logger.Tree::Element::CheckList=TRACE, Screen #log4perl.logger.Tree::Element::Id=TRACE, Screen #log4perl.logger.Tree::Element::Id::List=TRACE, Screen #log4perl.logger.Tree::Element::Value::Dependency=TRACE, Screen #log4perl.logger.Tree::Element::Value=TRACE, Screen #log4perl.logger.Tree::Element::Value::LayeredInclude=TRACE, Screen #log4perl.logger.Tree::Element::Warped=TRACE, Screen #log4perl.logger.Tree::Node::Warped=TRACE, Screen #log4perl.logger.Tree::Node=TRACE, Screen #log4perl.logger.TreeSearcher=TRACE, Screen #log4perl.logger.ValueComputer=TRACE, Screen #log4perl.logger.Warper=TRACE, 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 %m %n log4perl.appender.Screen.layout.ConversionPattern = %M %m (%L) %n log4perl.appender.Logfile = Log::Log4perl::Appender::File log4perl.appender.Logfile.filename = test.log log4perl.appender.Logfile.mode = write log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout log4perl.appender.Logfile.layout.ConversionPattern = [%r] %F %L %m%n libconfig-model-perl-2.155/dist.ini000066400000000000000000000046571472064100600172000ustar00rootroot00000000000000name = Config-Model author = Dominique Dumont license = LGPL_2_1 copyright_holder = Dominique Dumont copyright_year = 2005-2022 [MetaResources] homepage = https://github.com/dod38fr/config-model/wiki bugtracker.web = https://github.com/dod38fr/config-model/issues bugtracker.mailto = ddumont at cpan.org repository.url = git://github.com/dod38fr/config-model.git repository.web = http://github.com/dod38fr/config-model repository.type = git [Prereqs] perl = v5.20 parent = 0 [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 = ^Fuse skip = Term::ReadLine skip = ExtUtils::testlib skip = Exporter [Prereqs / RuntimeRequires] ; traits are not found by Perl::PrereqScanner MouseX::NativeTraits = 0 [Prereqs / RuntimeRecommends] Fuse = 0 Text::Levenshtein::Damerau = 0 ; Making Term::ReadLine optional should ; fix Config::Model issues on ActiveState/Windows. ; If this raises too many problems, Config::Model::TermUI will be moved ; in its own distribution. ; term_ui.t skips tests when Term::ReadLine is not found Term::ReadLine = 0 [Prereqs / BuildRequires] ; not detected by dzil authordep. ; See Dist::Zilla::App::Command::authordeps man page ; authordep Pod::Weaver::Section::Support ; authordep Pod::Elemental::Transformer::List [@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)$ [PkgVersion] use_package = 1 finder = OnlyPmFiles [PodWeaver] finder = :ExecFiles finder = noModelFiles [Prepender] copyright=1 [Run::BeforeBuild] ;-- allow dzil listdeps when deps are missing fatal_errors = 0 ;-- Generate pod doc from model run = perl -I lib -MConfig::Model::Utils::GenClassPod -e 'gen_class_pod();' [Run::BeforeRelease] run = perl -I lib -MConfig::Model::Utils::GenClassPod -e 'gen_class_pod();' [Test::Perl::Critic] [Signature] libconfig-model-perl-2.155/lib/000077500000000000000000000000001472064100600162665ustar00rootroot00000000000000libconfig-model-perl-2.155/lib/Config/000077500000000000000000000000001472064100600174735ustar00rootroot00000000000000libconfig-model-perl-2.155/lib/Config/Model.pm000066400000000000000000002571751472064100600211120ustar00rootroot00000000000000package Config::Model; use 5.20.0; use strict ; use warnings; use Mouse; use Mouse::Util::TypeConstraints; use MouseX::StrictConstructor; use Carp; use Storable ('dclone'); use Data::Dumper (); use Log::Log4perl 1.11 qw(get_logger :levels); use Config::Model::Instance; use Hash::Merge 0.12 qw/merge/; use Path::Tiny 0.053; use File::HomeDir; use Cwd; use Config::Model::Lister; with "Config::Model::Role::Constants"; use parent qw/Exporter/; our @EXPORT_OK = qw/cme initialize_log4perl/; use feature qw/signatures postderef/; no warnings qw/experimental::signatures experimental::postderef/; # used in some tests where we don't want to load # ~/.log4config-model config my $force_default_log; sub force_usage_of_default_log_config () { return $force_default_log = 1; } my $legacy_logger = get_logger("Model::Legacy") ; my $loader_logger = get_logger("Model::Loader") ; my $logger = get_logger("Model") ; # used to keep one Config::Model object to simplify programs based on # cme function my $model_storage; enum LegacyTreament => qw/die warn ignore/; has skip_include => ( isa => 'Bool', is => 'ro', default => 0 ); has model_dir => ( isa => 'Str', is => 'ro', default => 'Config/Model/models' ); has legacy => ( isa => 'LegacyTreament', is => 'ro', default => 'warn' ); has instances => ( isa => 'HashRef[Config::Model::Instance]', is => 'ro', default => sub { {} }, traits => ['Hash'], handles => { store_instance => 'set', get_instance => 'get', has_instance => 'defined', }, ); # Config::Model stores 3 versions of each model # raw_model is the model exactly as passed by the user. Since the format is quite # liberal (e.g legacy parameters, grouped declaration of elements like '[qw/foo bar/] => {}}', # element description in class or in element declaration)), this raw format is not # usable without normalization (done by normalize_class_parameters) # the key if this hash is a model name has raw_models => ( isa => 'HashRef', is => 'ro', default => sub { {} }, traits => ['Hash'], handles => { raw_model_exists => 'exists', raw_model_defined => 'defined', raw_model => 'get', get_raw_model => 'get', store_raw_model => 'set', raw_model_names => 'keys', }, ); # the result of normalization is stored here. Normalized model aggregate user models and # augmented features (the one found in Foo.d directory). inclusion of other class is NOT # yet done. normalized_models are created while loading files (load method) or creating # configuration classes (create_config_class) has normalized_models => ( isa => 'HashRef', is => 'ro', default => sub { {} }, traits => ['Hash'], handles => { normalized_model_exists => 'exists', normalized_model_defined => 'defined', normalized_model => 'get', store_normalized_model => 'set', normalized_model_names => 'keys', }, ); # This attribute contain the model that will be used by Config::Model::Node. They # are created on demand when get_model is called. When created the inclusion of # other classes is done according to the class 'include' parameter. Note that get_model # will try to call load if the required normalized_model is not known (lazy loading) has models => ( isa => 'HashRef', is => 'ro', default => sub { {} }, traits => ['Hash'], handles => { model_exists => 'exists', model_defined => 'defined', _get_model => 'get', _store_model => 'set', }, ); # model snippet may be loaded when the target class is not available # so they must be stored before being used. has model_snippets => ( isa => 'ArrayRef', is => 'ro', default => sub { [] }, traits => ['Array'], handles => { add_snippet => 'push', all_snippets => 'elements', }, ); enum 'LOG_LEVELS', [ qw/ERROR WARN INFO DEBUG TRACE/ ]; has log_level => ( isa => 'LOG_LEVELS', is => 'ro', ); has skip_inheritance => ( isa => 'Bool', is => 'ro', default => 0, trigger => sub { my $self = shift; $self->show_legacy_issue("skip_inheritance is deprecated, use skip_include"); $self->skip_include = $self->skip_inheritance; } ); # remove this hack mid 2022 around BUILDARGS => sub ($orig, $class, %args) { my %new; foreach my $k (keys %args) { if (defined $args{$k}) { $new{$k} = $args{$k}; } else { # cannot use logger, it's not initialised yet croak("Config::Model new: passing undefined constructor argument is deprecated ($k argument)\n"); } } return $class->$orig(%new); }; # keep this as a separate sub from BUILD. So user can call it before # creating Config::Model object sub initialize_log4perl (@args) { if (ref $args[0]) { # may be called as $self-> initialize_log4perl shift @args; } my %args = @args; my $log4perl_syst_conf_file = path('/etc/log4config-model.conf'); # avoid undef warning when homedir is not defined (e.g. with Debian cowbuilder) my $home = File::HomeDir->my_home // ''; my $log4perl_user_conf_file = path( $home . '/.log4config-model' ); my $fallback_conf_file = path($INC{"Config/Model.pm"}) ->parent->child("Model/log4perl.conf") ; my $log4perl_file = $force_default_log ? $fallback_conf_file # for tests : $log4perl_user_conf_file->is_file ? $log4perl_user_conf_file : $log4perl_syst_conf_file->is_file ? $log4perl_syst_conf_file : $fallback_conf_file; my %log4perl_conf = map { split /\s*=\s*/,$_,2; } grep { chomp; ! /^\s*#/ } $log4perl_file->lines; my $verbose = $args{verbose}; if (defined $verbose) { my @loggers = ref $verbose ? @$verbose : $verbose; foreach my $logger (@loggers) { $log4perl_conf{"log4perl.logger.Verbose.$logger"} = "INFO, PlainMsgOnScreen"; } } Log::Log4perl::init(\%log4perl_conf); return \%log4perl_conf; # for tests } sub BUILD { my $self = shift; my $args = shift; initialize_log4perl(verbose => $args->{verbose}) unless Log::Log4perl->initialized(); return; } sub show_legacy_issue { my $self = shift; my $ref = shift; my $behavior = shift || $self->legacy; my @msg = ref $ref ? @$ref : $ref; unshift @msg, "Model "; if ( $behavior eq 'die' ) { die @msg, "\n"; } elsif ( $behavior eq 'warn' ) { $legacy_logger->warn(@msg); } elsif ( $behavior eq 'note' ) { $legacy_logger->info( @msg); } return; } sub _tweak_instance_args { my ($args) = @_ ; my $application = $args->{application} ; my $cat = ''; if (defined $application) { my ( $categories, $appli_info, $appli_map ) = Config::Model::Lister::available_models; # root_class_name may override class found (or not) by appli in tests if (not $args->{root_class_name}) { $args->{root_class_name} = $appli_map->{$application} || die "Unknown application $application. Expected one of " . join(' ',sort keys %$appli_map)."\n"; } $cat = $appli_info->{_category} // ''; # may be empty in tests # config_dir may be specified in application file $args->{config_dir} //= $appli_info->{$application}{config_dir}; $args->{appli_info} = $appli_info->{$application} // {}; } my $app_name = $application; if ($cat eq 'application') { # store dir in name to distinguish different runs of the same # app in different directories. $application .= " in " . cwd; } $args->{name} = delete $args->{instance_name} # backward compat with test || delete $args->{name} # preferred parameter || $app_name # fallback in most cases || 'default'; # fallback mostly in tests return; } sub cme (@args) { my %args = @args == 1 ? ( application => $args[0]) : @args ; if (my $force = delete $args{'force-load'}) { $args{check} = 'no' if $force; } my $cat =_tweak_instance_args(\%args); my $m_args = delete $args{model_args} // {} ; # used for tests # model_storage is used to keep Config::Model object alive $model_storage //= Config::Model->new(%$m_args); return $model_storage->instance(%args); } sub instance ($self, @args) { my %args = @args == 1 ? ( application => $args[0]) : @args ; # also creates a default name _tweak_instance_args(\%args); if ( $args{name} and $self->has_instance($args{name}) ) { return $self->get_instance($args{name}); } croak "Model: can't create instance without application or root_class_name " unless $args{root_class_name}; if ( defined $args{model_file} ) { my $file = delete $args{model_file}; $self->load( $args{root_class_name}, $file ); } my $i = Config::Model::Instance->new( config_model => $self, %args # for optional parameters like *directory ); $self->store_instance($args{name}, $i); return $i; } sub instance_names { my $self = shift; my @all = sort keys %{ $self->instances }; return @all; } # unpacked model is: # { # element_list => [ ... ], # element => { element_name => element_data (left as is) }, # class_description => , # include => 'class_name', # include_after => 'element_name', # } # description, summary, level, status are moved # into element description. my @legal_params_to_move = ( qw/read_config write_config rw_config/, # read/write stuff # this parameter is filled by class generated by a program. It may # be used to avoid interactive edition of a generated model 'generated_by', qw/class_description author copyright gist license include include_after include_backend class/ ); my @other_legal_params = qw/ author element status description summary level accept/; # keep as external API. All internal call go through _store_model # See comments around raw_models attribute for explanations sub create_config_class ($self, %raw_model) { my $config_class_name = delete $raw_model{name} or croak "create_config_class: no config class name"; get_logger("Model")->info("Creating class $config_class_name"); if ( $self->model_exists($config_class_name) ) { Config::Model::Exception::ModelDeclaration->throw( error => "create_config_class: attempt to clobber $config_class_name" . " config class name " ); } $self->store_raw_model( $config_class_name, dclone( \%raw_model ) ); my $model = $self->normalize_class_parameters( $config_class_name, \%raw_model ); $self->store_normalized_model( $config_class_name, $model ); return $config_class_name; } sub merge_included_class { my ( $self, $config_class_name ) = @_; my $normalized_model = $self->normalized_model($config_class_name); my $model = dclone $normalized_model ; # add included elements if ( $self->skip_include and defined $normalized_model->{include} ) { my $inc = $normalized_model->{include}; $model->{include} = ref $inc ? $inc : [$inc]; $model->{include_after} = $normalized_model->{include_after} if defined $normalized_model->{include_after}; } else { # include class in raw_copy, normalized_model is left as is $self->include_class( $config_class_name, $model ); } # add included backend if ( $self->skip_include and defined $normalized_model->{include_backend} ) { my $inc = $normalized_model->{include_backend}; $model->{include_backend} = ref $inc ? $inc : [$inc]; } else { # include read/write config specifications in raw_copy, # normalized_model is left as is $self->include_backend( $config_class_name, $model ); } return $model; } sub include_backend { my $self = shift; my $class_name = shift || croak "include_backend: undef includer"; my $target_model = shift || die "include_backend:: undefined target_model"; my $included_classes = delete $target_model->{include_backend}; return () unless defined $included_classes; foreach my $included_class (@$included_classes) { # takes care of recursive include, because get_model will perform # includes (and normalization). Is already a dclone my $included_model = $self->get_model_clone($included_class); foreach my $rw (qw/rw_config read_config write_config config_dir/) { if ($target_model->{$rw} and $included_model->{$rw}) { my $msg = "Included $rw from $included_class cannot clobber " . "existing data in $class_name"; Config::Model::Exception::ModelDeclaration->throw( error => $msg ); } elsif ($included_model->{$rw}) { $target_model->{$rw} = $included_model->{$rw}; } } } return; } sub normalize_class_parameters { my $self = shift; my $config_class_name = shift || die; my $normalized_model = shift || die; my $model = {}; # sanity check my $raw_name = delete $normalized_model->{name}; if ( defined $raw_name and $config_class_name ne $raw_name ) { my $e = "internal: config_class_name $config_class_name ne model name $raw_name"; Config::Model::Exception::ModelDeclaration->throw( error => $e ); } my @element_list; # first construct the element list my @compact_list = @{ $normalized_model->{element} || [] }; while (@compact_list) { my ( $item, $info ) = splice @compact_list, 0, 2; # store the order of element as declared in 'element' push @element_list, ref($item) ? @$item : ($item); } if ( defined $normalized_model->{inherit_after} ) { $self->show_legacy_issue([ "Model $config_class_name: inherit_after is deprecated ", "in favor of include_after" ]); $normalized_model->{include_after} = delete $normalized_model->{inherit_after}; } if ( defined $normalized_model->{inherit} ) { $self->show_legacy_issue( "Model $config_class_name: inherit is deprecated in favor of include"); $normalized_model->{include} = delete $normalized_model->{inherit}; } foreach my $info (@legal_params_to_move) { next unless defined $normalized_model->{$info}; $model->{$info} = delete $normalized_model->{$info}; } # first deal with perl file and cds_file backend $self->translate_legacy_backend_info( $config_class_name, $model ); # handle accept parameter my @accept_list; my %accept_hash; my $accept_info = delete $normalized_model->{'accept'} || []; while (@$accept_info) { my $name_match = shift @$accept_info; # should be a regexp # handle legacy if ( ref $name_match ) { my $implicit = defined $name_match->{name_match} ? '' : 'implicit '; unshift @$accept_info, $name_match; # put data back in list $name_match = delete $name_match->{name_match} || '.*'; $logger->warn("class $config_class_name: name_match ($implicit$name_match)", " in accept is deprecated"); } push @accept_list, $name_match; $accept_hash{$name_match} = shift @$accept_info; } $model->{accept} = \%accept_hash; $model->{accept_list} = \@accept_list; # check for duplicate in @element_list. my %check_list; foreach (@element_list) { $check_list{$_}++ }; my @extra = grep { $check_list{$_} > 1 } keys %check_list; if (@extra) { Config::Model::Exception::ModelDeclaration->throw( error => "class $config_class_name: @extra element " . "is declared more than once. Check the included parts" ); } $self->handle_experience_permission( $config_class_name, $normalized_model ); # element is handled first foreach my $info_name (qw/element status description summary level/) { my $raw_compact_info = delete $normalized_model->{$info_name}; next unless defined $raw_compact_info; Config::Model::Exception::ModelDeclaration->throw( error => "Data for parameter $info_name of $config_class_name" . " is not an array ref" ) unless ref($raw_compact_info) eq 'ARRAY'; my @raw_info = @$raw_compact_info; while (@raw_info) { my ( $item, $info ) = splice @raw_info, 0, 2; my @element_names = ref($item) ? @$item : ($item); # move element informations (handled first) if ( $info_name eq 'element' ) { # warp can be found only in element item $self->translate_legacy_info( $config_class_name, $element_names[0], $info ); $self->handle_experience_permission( $config_class_name, $info ); # copy in element data *after* legacy translation foreach (@element_names) { $model->{element}{$_} = dclone($info); }; } # move some information into element declaration (without clobberring) elsif ( $info_name =~ /description|level|summary|status/ ) { foreach (@element_names) { Config::Model::Exception::ModelDeclaration->throw( error => "create class $config_class_name: '$info_name' " . "declaration for non declared element '$_'" ) unless defined $model->{element}{$_}; $model->{element}{$_}{$info_name} ||= $info; } } else { die "Unexpected element $item in $config_class_name model"; } } } Config::Model::Exception::ModelDeclaration->throw( error => "create class $config_class_name: unexpected " . "parameters '" . join( ', ', sort keys %$normalized_model ) . "' " . "Expected '" . join( "', '", @legal_params_to_move, @other_legal_params ) . "'" ) if keys %$normalized_model; $model->{element_list} = \@element_list; return $model; } sub handle_experience_permission { my ( $self, $config_class_name, $model ) = @_; if (delete $model->{permission}) { die "$config_class_name: parameter permission is obsolete\n"; } if (delete $model->{experience}) { carp "experience parameter is deprecated"; } return; } sub translate_legacy_info { my $self = shift; my $config_class_name = shift || die; my $elt_name = shift; my $info = shift; $self->translate_warped_node_info( $config_class_name, $elt_name, 'warped_node', $info ); #translate legacy warp information if ( defined $info->{warp} ) { $self->translate_warp_info( $config_class_name, $elt_name, $info->{type}, $info->{warp} ); } $self->translate_cargo_info( $config_class_name, $elt_name, $info ); if ( defined $info->{cargo} && defined $info->{cargo}{type} && $info->{cargo}{type} eq 'warped_node' ) { $self->translate_warped_node_info( $config_class_name, $elt_name, 'warped_node', $info->{cargo} ); } if ( defined $info->{cargo} and defined $info->{cargo}{warp} ) { $self->translate_warp_info( $config_class_name, $elt_name, $info->{cargo}{type}, $info->{cargo}{warp} ); } # compute cannot be warped if ( defined $info->{compute} ) { $self->translate_compute_info( $config_class_name, $elt_name, $info, 'compute' ); $self->translate_allow_compute_override( $config_class_name, $elt_name, $info ); } if ( defined $info->{cargo} and defined $info->{cargo}{compute} ) { $self->translate_compute_info( $config_class_name, $elt_name, $info->{cargo}, 'compute' ); $self->translate_allow_compute_override( $config_class_name, $elt_name, $info->{cargo} ); } # refer_to cannot be warped if ( defined $info->{refer_to} ) { $self->translate_compute_info( $config_class_name, $elt_name, $info, refer_to => 'computed_refer_to' ); } if ( defined $info->{cargo} and defined $info->{cargo}{refer_to} ) { $self->translate_compute_info( $config_class_name, $elt_name, $info->{cargo}, refer_to => 'computed_refer_to' ); } # translate id default param # default cannot be stored in cargo since is applies to the id itself if ( defined $info->{type} and ( $info->{type} eq 'list' or $info->{type} eq 'hash' ) ) { if ( defined $info->{default} ) { $self->translate_id_default_info( $config_class_name, $elt_name, $info ); } if ( defined $info->{auto_create} ) { $self->translate_id_auto_create( $config_class_name, $elt_name, $info ); } $self->translate_id_min_max( $config_class_name, $elt_name, $info ); $self->translate_id_names( $config_class_name, $elt_name, $info ); if ( defined $info->{warp} ) { my $rules_a = $info->{warp}{rules}; my %h = @$rules_a; foreach my $rule_effect ( values %h ) { $self->translate_id_names( $config_class_name, $elt_name, $rule_effect ); $self->translate_id_min_max( $config_class_name, $elt_name, $rule_effect ); next unless defined $rule_effect->{default}; $self->translate_id_default_info( $config_class_name, $elt_name, $rule_effect ); } } $self->translate_id_class($config_class_name, $elt_name, $info ); } if ( defined $info->{type} and ( $info->{type} eq 'leaf' ) ) { $self->translate_legacy_builtin( $config_class_name, $info, $info, ); } if ( defined $info->{type} and ( $info->{type} eq 'check_list' ) ) { $self->translate_legacy_built_in_list( $config_class_name, $info, $info, ); } $legacy_logger->debug( Data::Dumper->Dump( [$info], [ 'translated_' . $elt_name ] ) ) if $legacy_logger->is_debug; return; } sub translate_legacy_backend_info { my ( $self, $config_class_name, $model ) = @_; # trap multi backend and change array spec into single spec 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){ $self->show_legacy_issue("$config_class_name $config: multiple backends are obsolete. You now must use only one backend.", 'die'); } } } # move read_config spec in re_config if ($model->{read_config}) { $self->show_legacy_issue("$config_class_name: read_config specification is deprecated, please move in rw_config", 'warn'); $model->{rw_config} = delete $model->{read_config}; } # merge write_config spec in rw_config if ($model->{write_config}) { $self->show_legacy_issue("$config_class_name: write_config specification is deprecated, please merge with read_config and move in rw_config", 'warn'); foreach (keys %{$model->{write_config}}) { $model->{rw_config}{$_} = $model->{write_config}{$_} } delete $model->{write_config}; } my $ref = $model->{'rw_config'} || return; die "undefined backend in rw_config spec of class $config_class_name\n" unless $ref->{backend} ; if ($ref->{backend} eq 'custom') { my $msg = "$config_class_name: custom read/write backend is obsolete." ." Please replace with a backend inheriting Config::Model::Backend::Any"; $self->show_legacy_issue( $msg, 'die'); } if ( $ref->{backend} =~ /^(perl|ini|cds)$/ ) { my $backend = $ref->{backend}; $self->show_legacy_issue("$config_class_name: deprecated backend '$backend'. Should be '$ {backend}_file'", 'warn'); $ref->{backend} .= "_file"; } if ( defined $ref->{allow_empty} ) { $self->show_legacy_issue("$config_class_name: backend $ref->{backend}: allow_empty is deprecated. Use auto_create", 'warn'); $ref->{auto_create} = delete $ref->{allow_empty}; } return; } sub translate_cargo_info { my $self = shift; my $config_class_name = shift; my $elt_name = shift; my $info = shift; my $c_type = delete $info->{cargo_type}; return unless defined $c_type; $self->show_legacy_issue("$config_class_name->$elt_name: parameter cargo_type is deprecated."); my %cargo; if ( defined $info->{cargo_args} ) { %cargo = %{ delete $info->{cargo_args} }; $self->show_legacy_issue( "$config_class_name->$elt_name: parameter cargo_args is deprecated."); } $cargo{type} = $c_type; if ( defined $info->{config_class_name} ) { $cargo{config_class_name} = delete $info->{config_class_name}; $self->show_legacy_issue([ "$config_class_name->$elt_name: parameter config_class_name is ", "deprecated. This one must be specified within cargo. ", "Ie. cargo=>{config_class_name => 'FooBar'}" ]); } $info->{cargo} = \%cargo; $legacy_logger->debug( Data::Dumper->Dump( [$info], [ 'translated_' . $elt_name ] ) ) if $legacy_logger->is_debug; return; } sub translate_id_names { my $self = shift; my $config_class_name = shift; my $elt_name = shift; my $info = shift; $self->translate_name( $config_class_name, $elt_name, $info, 'allow', 'allow_keys', 'die' ); $self->translate_name( $config_class_name, $elt_name, $info, 'allow_from', 'allow_keys_from', 'die' ); $self->translate_name( $config_class_name, $elt_name, $info, 'follow', 'follow_keys_from', 'die' ); return; } sub translate_name { my ($self, $config_class_name, $elt_name, $info, $from, $to, $legacy) = @_; if ( defined $info->{$from} ) { $self->show_legacy_issue( "$config_class_name->$elt_name: parameter $from is deprecated in favor of $to", $legacy ); $info->{$to} = delete $info->{$from}; } return; } sub translate_allow_compute_override { my $self = shift; my $config_class_name = shift; my $elt_name = shift; my $info = shift; if ( defined $info->{allow_compute_override} ) { $self->show_legacy_issue( "$config_class_name->$elt_name: parameter allow_compute_override is deprecated in favor of compute -> allow_override" ); $info->{compute}{allow_override} = delete $info->{allow_compute_override}; } return; } sub translate_compute_info { my $self = shift; my $config_class_name = shift; my $elt_name = shift; my $info = shift; my $old_name = shift; my $new_name = shift || $old_name; if ( ref( $info->{$old_name} ) eq 'ARRAY' ) { my $compute_info = delete $info->{$old_name}; $legacy_logger->debug( "translate_compute_info $elt_name input:\n", Data::Dumper->Dump( [$compute_info], [qw/compute_info/] ) ) if $legacy_logger->is_debug; $self->show_legacy_issue([ "$config_class_name->$elt_name: specifying compute info with ", "an array ref is deprecated" ]); my ( $user_formula, %var ) = @$compute_info; my $replace_h; foreach ( keys %var ) { $replace_h = delete $var{$_} if ref( $var{$_} ) }; # cleanup user formula $user_formula =~ s/\$(\w+)\{/\$replace{/g; # cleanup variable foreach ( values %var ) { s/\$(\w+)\{/\$replace{/g }; # change the hash *in* the info structure $info->{$new_name} = { formula => $user_formula, variables => \%var, }; $info->{$new_name}{replace} = $replace_h if defined $replace_h; $legacy_logger->debug( "translate_warp_info $elt_name output:\n", Data::Dumper->Dump( [ $info->{$new_name} ], [ 'new_' . $new_name ] ) ) if $legacy_logger->is_debug; } return; } sub translate_id_class { my $self = shift; my $config_class_name = shift || die; my $elt_name = shift; my $info = shift; $legacy_logger->debug( "translate_id_class $elt_name input:\n", Data::Dumper->Dump( [$info], [qw/info/] ) ) if $legacy_logger->is_debug; my $class_overide_param = $info->{type}.'_class'; my $class_overide = $info->{$class_overide_param}; if ($class_overide) { $info->{class} = $class_overide; $self->show_legacy_issue([ "$config_class_name->$elt_name: '$class_overide_param' is deprecated, ", "Use 'class' instead." ]); } $legacy_logger->debug( "translate_id_class $elt_name output:", Data::Dumper->Dump( [$info], [qw/new_info/]) ) if $legacy_logger->is_debug; return; } # internal: translate default information for id element sub translate_id_default_info { my $self = shift; my $config_class_name = shift || die; my $elt_name = shift; my $info = shift; $legacy_logger->debug( "translate_id_default_info $elt_name input:\n", Data::Dumper->Dump( [$info], [qw/info/] ) ) if $legacy_logger->is_debug; my $warn = "$config_class_name->$elt_name: 'default' parameter for list or " . "hash element is deprecated. "; my $def_info = delete $info->{default}; if ( ref($def_info) eq 'HASH' ) { $info->{default_with_init} = $def_info; $self->show_legacy_issue([ $warn, "Use default_with_init" ]); } elsif ( ref($def_info) eq 'ARRAY' ) { $info->{default_keys} = $def_info; $self->show_legacy_issue([ $warn, "Use default_keys" ]); } else { $info->{default_keys} = [$def_info]; $self->show_legacy_issue([ $warn, "Use default_keys" ]); } $legacy_logger->debug( "translate_id_default_info $elt_name output:", Data::Dumper->Dump( [$info], [qw/new_info/]) ) if $legacy_logger->is_debug; return; } # internal: translate auto_create information for id element sub translate_id_auto_create { my $self = shift; my $config_class_name = shift || die; my $elt_name = shift; my $info = shift; $legacy_logger->debug( "translate_id_auto_create $elt_name input:", Data::Dumper->Dump( [$info], [qw/info/] ) ) if $legacy_logger->is_debug; my $warn = "$config_class_name->$elt_name: 'auto_create' parameter for list or " . "hash element is deprecated. "; my $ac_info = delete $info->{auto_create}; if ( $info->{type} eq 'hash' ) { $info->{auto_create_keys} = ref($ac_info) eq 'ARRAY' ? $ac_info : [$ac_info]; $self->show_legacy_issue([ $warn, "Use auto_create_keys" ]); } elsif ( $info->{type} eq 'list' ) { $info->{auto_create_ids} = $ac_info; $self->show_legacy_issue([ $warn, "Use auto_create_ids" ]); } else { die "Unexpected element ($elt_name) type $info->{type} ", "for translate_id_auto_create"; } $legacy_logger->debug( "translate_id_default_info $elt_name output:\n", Data::Dumper->Dump( [$info], [qw/new_info/] ) ) if $legacy_logger->is_debug; return; } sub translate_id_min_max { my $self = shift; my $config_class_name = shift || die; my $elt_name = shift; my $info = shift; foreach my $bad (qw/min max/) { next unless defined $info->{$bad}; $legacy_logger->debug( "translate_id_min_max $elt_name $bad:") if $legacy_logger->is_debug; my $good = $bad . '_index'; my $warn = "$config_class_name->$elt_name: '$bad' parameter for list or " . "hash element is deprecated. Use '$good'"; $info->{$good} = delete $info->{$bad}; } return; } sub translate_warped_node_info { my ( $self, $config_class_name, $elt_name, $type, $info ) = @_; $legacy_logger->debug( "translate_warped_node_info $elt_name input:\n", Data::Dumper->Dump( [$info], [qw/info/] ) ) if $legacy_logger->is_debug; # type may not be defined when translating class snippet used to augment a class my $elt_type = $info->{type} ; foreach my $parm (qw/follow rules/) { next unless $info->{$parm}; next if defined $elt_type and $elt_type ne 'warped_node'; $self->show_legacy_issue( "$config_class_name->$elt_name: using $parm parameter in " ."warped node is deprecated. $parm must be specified in a warp parameter." ); $info->{warp}{$parm} = delete $info->{$parm}; } $legacy_logger->debug( "translate_warped_node_info $elt_name output:\n", Data::Dumper->Dump( [$info], [qw/new_info/] ) ) if $legacy_logger->is_debug; return; } # internal: translate warp information into 'boolean expr' => { ... } sub translate_warp_info { my ( $self, $config_class_name, $elt_name, $type, $warp_info ) = @_; $legacy_logger->debug( "translate_warp_info $elt_name input:\n", Data::Dumper->Dump( [$warp_info], [qw/warp_info/] ) ) if $legacy_logger->is_debug; my $follow = $self->translate_follow_arg( $config_class_name, $elt_name, $warp_info->{follow} ); # now, follow is only { w1 => 'warp1', w2 => 'warp2'} my @warper_items = values %$follow; my $multi_follow = @warper_items > 1 ? 1 : 0; my $rules = $self->translate_rules_arg( $config_class_name, $elt_name, $type, \@warper_items, $warp_info->{rules} ); $warp_info->{follow} = $follow; $warp_info->{rules} = $rules; $legacy_logger->debug( "translate_warp_info $elt_name output:\n", Data::Dumper->Dump( [$warp_info], [qw/new_warp_info/] ) ) if $legacy_logger->is_debug; return; } # internal sub translate_multi_follow_legacy_rules { my ( $self, $config_class_name, $elt_name, $warper_items, $raw_rules ) = @_; my @rules; # we have more than one warper_items for ( my $r_idx = 0 ; $r_idx < $#$raw_rules ; $r_idx += 2 ) { my $key_set = $raw_rules->[$r_idx]; my @keys = ref($key_set) ? @$key_set : ($key_set); # legacy: check the number of keys in the @rules set if ( @keys != @$warper_items and $key_set !~ /\$\w+/ ) { Config::Model::Exception::ModelDeclaration->throw( error => "Warp rule error in " . "'$config_class_name->$elt_name'" . ": Wrong nb of keys in set '@keys'," . " Expected " . scalar @$warper_items . " keys" ); } # legacy: # if a key of a rule (e.g. f1 or b1) is an array ref, all the # values passed in the array are considered as valid. # i.e. [ [ f1a, f1b] , b1 ] => { ... } # is equivalent to # [ f1a, b1 ] => { ... }, [ f1b , b1 ] => { ... } # now translate [ [ f1a, f1b] , b1 ] => { ... } # into "( $f1 eq f1a or $f1 eq f1b ) and $f2 eq b1)" => { ... } my @bool_expr; my $b_idx = 0; foreach my $key (@keys) { if ( ref $key ) { my @expr = map { "\$f$b_idx eq '$_'" } @$key; push @bool_expr, "(" . join( " or ", @expr ) . ")"; } elsif ( $key !~ /\$\w+/ ) { push @bool_expr, "\$f$b_idx eq '$key'"; } else { push @bool_expr, $key; } $b_idx++; } push @rules, join( ' and ', @bool_expr ), $raw_rules->[ $r_idx + 1 ]; } return @rules; } sub translate_follow_arg { my $self = shift; my $config_class_name = shift; my $elt_name = shift; my $raw_follow = shift; if ( ref($raw_follow) eq 'HASH' ) { # follow is { w1 => 'warp1', w2 => 'warp2'} return $raw_follow; } elsif ( ref($raw_follow) eq 'ARRAY' ) { # translate legacy follow arguments ['warp1','warp2',...] my $follow = {}; my $idx = 0; foreach ( @$raw_follow ) { $follow->{ 'f' . $idx++ } = $_ } ; return $follow; } elsif ( defined $raw_follow ) { # follow is a plain string return { f1 => $raw_follow }; } else { return {}; } } sub translate_rules_arg { my ( $self, $config_class_name, $elt_name, $type, $warper_items, $raw_rules ) = @_; my $multi_follow = @$warper_items > 1 ? 1 : 0; my $follow = @$warper_items; # $rules is either: # { f1 => { ... } } ( may be [ f1 => { ... } ] ?? ) # [ 'boolean expr' => { ... } ] # legacy: # [ f1, b1 ] => {..} ,[ f1,b2 ] => {...}, [f2,b1] => {...} ... # foo => {...} , bar => {...} my @rules; if ( ref($raw_rules) eq 'HASH' ) { # transform the hash { foo => { ...} } # into array ref [ '$f1 eq foo' => { ... } ] my $h = $raw_rules; @rules = $follow ? map { ( "\$f1 eq '$_'", $h->{$_} ) } keys %$h : keys %$h; } elsif ( ref($raw_rules) eq 'ARRAY' ) { if ($multi_follow) { push @rules, $self->translate_multi_follow_legacy_rules( $config_class_name, $elt_name, $warper_items, $raw_rules ); } else { # now translate [ f1a, f1b] => { ... } # into "$f1 eq f1a or $f1 eq f1b " => { ... } my @raw_rules = @{$raw_rules}; for ( my $r_idx = 0 ; $r_idx < $#raw_rules ; $r_idx += 2 ) { my $key_set = $raw_rules[$r_idx]; my @keys = ref($key_set) ? @$key_set : ($key_set); my @bool_expr = $follow ? map { /\$/ ? $_ : "\$f1 eq '$_'" } @keys : @keys; push @rules, join( ' or ', @bool_expr ), $raw_rules[ $r_idx + 1 ]; } } } elsif ( defined $raw_rules ) { Config::Model::Exception::ModelDeclaration->throw( error => "Warp rule error in element " . "'$config_class_name->$elt_name': " . "rules must be a hash ref. Got '$raw_rules'" ); } for ( my $idx = 1 ; $idx < @rules ; $idx += 2 ) { next unless ( ref $rules[$idx] eq 'HASH' ); # other cases are illegal and trapped later $self->handle_experience_permission( $config_class_name, $rules[$idx] ); next unless defined $type and $type eq 'leaf'; $self->translate_legacy_builtin( $config_class_name, $rules[$idx], $rules[$idx] ); } return \@rules; } sub translate_legacy_builtin { my ( $self, $config_class_name, $model, $normalized_model ) = @_; my $raw_builtin_default = delete $normalized_model->{built_in}; return unless defined $raw_builtin_default; $legacy_logger->debug( Data::Dumper->Dump( [$normalized_model], ['builtin to translate'] ) ) if $legacy_logger->is_debug; $self->show_legacy_issue([ "$config_class_name: parameter 'built_in' is deprecated " . "in favor of 'upstream_default'" ]); $model->{upstream_default} = $raw_builtin_default; $legacy_logger->debug( Data::Dumper->Dump( [$model], ['translated_builtin'] )) if $legacy_logger->is_debug; return; } sub translate_legacy_built_in_list { my ( $self, $config_class_name, $model, $normalized_model ) = @_; my $raw_builtin_default = delete $normalized_model->{built_in_list}; return unless defined $raw_builtin_default; $legacy_logger->debug( Data::Dumper->Dump( [$normalized_model], ['built_in_list to translate'] ) ) if $legacy_logger->is_debug; $self->show_legacy_issue([ "$config_class_name: parameter 'built_in_list' is deprecated " . "in favor of 'upstream_default_list'" ]); $model->{upstream_default_list} = $raw_builtin_default; $legacy_logger->debug( Data::Dumper->Dump( [$model], ['translated_built_in_list'] )) if $legacy_logger->is_debug; return; } sub include_class { my $self = shift; my $class_name = shift || croak "include_class: undef includer"; my $target_model = shift || die "include_class: undefined target_model"; my $include_class = delete $target_model->{include}; return () unless defined $include_class; my $include_after = delete $target_model->{include_after}; my @includes = ref $include_class ? @$include_class : ($include_class); # use reverse because included classes are *inserted* in front # of the list (or inserted after $include_after foreach my $inc ( reverse @includes ) { $self->include_one_class( $class_name, $target_model, $inc, $include_after ); } return; } sub include_one_class { my $self = shift; my $class_name = shift || croak "include_class: undef includer"; my $target_model = shift || croak "include_class: undefined target_model"; my $include_class = shift || croak "include_class: undef include_class param"; my $include_after = shift; get_logger('Model')->debug("class $class_name includes $include_class"); if ( defined $include_class and defined $self->{included_class}{$class_name}{$include_class} ) { Config::Model::Exception::ModelDeclaration->throw( error => "Recursion error ? $include_class has " . "already been included by $class_name." ); } $self->{included_class}{$class_name}{$include_class} = 1; # takes care of recursive include, because get_model will perform # includes (and normalization). Is already a dclone my $included_model = $self->get_model_clone($include_class); # now include element in element_list (special treatment because order is # important) my $target_list = $target_model->{element_list}; my $included_list = $included_model->{element_list}; my $splice_idx = 0; if ( defined $include_after and defined $included_model->{element} ) { my $idx = 0; my %elt_idx = map { ( $_, $idx++ ); } @$target_list; if ( not defined $elt_idx{$include_after} ) { my $msg = "Unknown element for 'include_after': " . "$include_after, expected " . join( ' ', sort keys %elt_idx ); Config::Model::Exception::ModelDeclaration->throw( error => $msg ); } # + 1 because we splice *after* $include_after $splice_idx = $elt_idx{$include_after} + 1; } splice( @$target_list, $splice_idx, 0, @$included_list ); get_logger('Model')->debug("class $class_name new elt list: @$target_list"); # now actually include all elements my $target_element = $target_model->{element} ||= {}; foreach my $included_elt (@$included_list) { if ( not defined $target_element->{$included_elt} ) { get_logger('Model')->debug("class $class_name includes elt $included_elt"); $target_element->{$included_elt} = $included_model->{element}{$included_elt}; } else { Config::Model::Exception::ModelDeclaration->throw( error => "Cannot clobber element '$included_elt' in $class_name" . " (included from $include_class)" ); } } get_logger('Model')->debug("class $class_name include $include_class done"); return; } sub find_model_file_in_dir ($model_name, $model_path) { foreach my $ext (qw/yml yaml pl/) { my $sub_path = $model_name =~ s!::!/!rg; my $path_load_file = $model_path->child($sub_path . '.' . $ext); return $path_load_file if $path_load_file->exists; } return; } sub find_model_file_in_inc { my ($self, $model_name, $load_file) = @_; my $path_load_file ; if ($load_file and $load_file =~ m!^/! ) { # load_file is absolute, do not search in @INC $path_load_file = $load_file; } elsif ($self->model_dir and $self->model_dir =~ m!^/!) { # model_dir is absolute, do not search in @INC my $model_path = path($self->model_dir); $path_load_file = find_model_file_in_dir ($model_name, $model_path); Config::Model::Exception::ModelDeclaration->throw( error => "Cannot find $model_name file in $model_path" ) unless $path_load_file; } else { foreach my $inc_str (@INC) { my $inc_path = path($inc_str); if ($load_file) { $path_load_file = $inc_path->child($load_file); } else { my $sub_path = $model_name =~ s!::!/!rg; my $model_path = $inc_path->child($self->model_dir); foreach my $ext (qw/yml yaml pl/) { $path_load_file = $model_path->child($sub_path . '.' . $ext); last if $path_load_file->exists; } } last if $path_load_file->exists; } } Config::Model::Exception::ModelDeclaration->throw( error => "Cannot find $model_name file in \@INC" ) unless $path_load_file; $loader_logger->debug("model $model_name from file $path_load_file"); return $path_load_file; } sub load_model_plugins { my ($self, @model_names) = @_; # look for additional model information my %model_graft_by_name; my %done; # avoid loading twice the same snippet (where system version may clobber dev version) foreach my $inc_str (@INC) { foreach my $name ( @model_names ) { my $snippet_path = $name; $snippet_path =~ s/::/\//g; my $snippet_dir = path($inc_str)->absolute->child($self->model_dir)->child($snippet_path . '.d'); $loader_logger->trace("looking for snippet in $snippet_dir"); if ( $snippet_dir->is_dir ) { my $iter = $snippet_dir->iterator({ recurse => 1 }); while ( my $snippet_file = $iter->() ) { next unless $snippet_file =~ /\.pl$/; # $snippet_file (Path::Tiny object) was # constructed from @INC content (i.e. $inc_str) # and contains an absolute path. Since # _load_model_in_hash uses 'do' (which may search # in @INC), the file path passed to # _load_model_in_hash must be either absolute or # relative to $inc_str my $snippet_file_rel = $snippet_file->relative($inc_str); my $done_key = $name . ':' . $snippet_file_rel; next if $done{$done_key}; $loader_logger->info("Found snippet $snippet_file in $inc_str dir"); my $snippet_model = $self->_load_model_file($snippet_file); $self->_merge_model_in_hash( \%model_graft_by_name, $snippet_model, $snippet_file_rel); $done{$done_key} = 1; } } } } return %model_graft_by_name; } # load a model from file. See comments around raw_models attribute for explanations sub load { my $self = shift; my $model_name = shift; # model name like Foo::Bar my $load_file = shift; # model file (override model name), used for tests $loader_logger->debug("called on model $model_name"); my $path_load_file = $self->find_model_file_in_inc($model_name, $load_file); my %models_by_name; # Searches $load_file in @INC and returns an array containing the # names of the loaded classes my $model = $self->_load_model_file($path_load_file->absolute); my @loaded_classes = $self->_merge_model_in_hash( \%models_by_name, $model, $path_load_file ); $self->store_raw_model( $model_name, dclone( \%models_by_name ) ); foreach my $name ( keys %models_by_name ) { my $data = $self->normalize_class_parameters( $name, $models_by_name{$name} ); $loader_logger->debug("Store normalized model $name"); $self->store_normalized_model( $name, $data ); } my %model_graft_by_name = $self->load_model_plugins(sort keys %models_by_name); # store snippet. May be used later foreach my $name (keys %model_graft_by_name) { # store snippet for later usage $loader_logger->trace("storing snippet for model $name"); $self->add_snippet($model_graft_by_name{$name}); } # check if a snippet is available for this class foreach my $snippet ( $self->all_snippets ) { my $class_to_merge = $snippet->{name}; next unless $models_by_name{$class_to_merge}; $self->augment_config_class_really( $class_to_merge, $snippet ); } # return the list of classes found in $load_file. Respecting the order of the class # declaration is important for Config::Model::Itself so the class are written back # in the same order. return @loaded_classes; } # New subroutine "_load_model_in_hash" extracted - Fri Apr 12 17:29:56 2013. # sub _merge_model_in_hash { my ( $self, $hash_ref, $model, $load_file ) = @_; my @names; foreach my $config_class_info (@$model) { my %data = ref $config_class_info eq 'HASH' ? %$config_class_info : ref $config_class_info eq 'ARRAY' ? @$config_class_info : croak "load $load_file: config_class_info is not a ref"; my $config_class_name = $data{name} or croak "load: missing config class name in $load_file"; # check config class parameters and fill %model $hash_ref->{$config_class_name} = \%data; push @names, $config_class_name; } return @names; } sub _load_model_file { my ( $self, $load_file ) = @_; $loader_logger->info("load model $load_file"); my $err_msg = ''; # do searches @INC if the file path is not absolute my $model = do $load_file; unless ($model) { if ($@) { $err_msg = "couldn't parse $load_file: $@"; } elsif ( not defined $model ) { $err_msg = "couldn't do $load_file: $!" } else { $err_msg = "couldn't run $load_file"; } } elsif ( ref($model) ne 'ARRAY' ) { $model = [$model]; } Config::Model::Exception::ModelDeclaration->throw( message => "load error: $err_msg" ) if $err_msg; return $model; } sub augment_config_class { my ( $self, %augment_data ) = @_; # %args must contain existing class name to augment # plus other data to merge to raw model my $config_class_name = delete $augment_data{name} || croak "augment_config_class: missing class name"; $self->augment_config_class_really( $config_class_name, \%augment_data ); return; } sub augment_config_class_really { my ( $self, $config_class_name, $augment_data ) = @_; my $orig_model = $self->normalized_model($config_class_name); croak "unknown class to augment: $config_class_name" unless defined $orig_model; my $model_addendum = $self->normalize_class_parameters( $config_class_name, dclone($augment_data) ); my $merge = Hash::Merge->new('RIGHT_PRECEDENT'); my $new_model = $merge->merge( $orig_model, $model_addendum ); # remove duplicates in element_list and accept_list while keeping order foreach my $list_name (qw/element_list accept_list/) { my %seen; my @newlist; foreach my $elt ( @{ $new_model->{$list_name} } ) { push @newlist, $elt unless $seen{$elt}; $seen{$elt} = 1; } $new_model->{$list_name} = \@newlist; } $self->store_normalized_model( $config_class_name => $new_model ); return; } sub model { my $self = shift; my $config_class_name = shift || die "Model::get_model: missing config class name argument"; $self->load($config_class_name) unless $self->normalized_model_exists($config_class_name); if ( not $self->model_defined($config_class_name) ) { $loader_logger->debug("creating model $config_class_name"); my $model = $self->merge_included_class($config_class_name); $self->_store_model( $config_class_name, $model ); } return $self->_get_model($config_class_name) || croak "get_model error: unknown config class name: $config_class_name"; } sub get_model { my ($self,$model) = @_; carp "get_model is deprecated in favor of get_model_clone"; return $self->get_model_clone($model); } sub get_model_clone { my ($self,$model) = @_; return dclone($self->model($model)); } # internal sub get_model_doc { my ( $self, $top_class_name, $done ) = @_; $done //= {}; if ( not defined $self->normalized_model($top_class_name) ) { eval { $self->model($top_class_name); }; if ($@) { my $e = $@; if ($e->isa('Config::Model::Exception::ModelDeclaration')) { Config::Model::Exception::Fatal->throw( message => "Unknown configuration class : $top_class_name ($@)" ); } else { $e->rethrow; } } } my @classes = ($top_class_name); my %result; while (@classes) { my $class_name = shift @classes; next if $done->{$class_name} ; my $c_model = $self->model($class_name) || croak "get_model_doc model error : unknown config class name: $class_name"; my $full_name = "Config::Model::models::$class_name"; my %see_also; my @pod = ( # Pod::Weaver compatibility "# PODNAME: $full_name", "# ABSTRACT: Configuration class " . $class_name, '', # assume utf8 for all docs "=encoding utf8", '', # plain old pod compatibility "=head1 NAME", '', "$full_name - Configuration class " . $class_name, '', "=head1 DESCRIPTION", '', "Configuration classes used by L", '' ); my %legalese; my $i = 0; my $class_desc = $c_model->{class_description}; push @pod, $class_desc, '' if defined $class_desc; my @elt = ( "=head1 Elements", '' ); foreach my $elt_name ( @{ $c_model->{element_list} } ) { my $elt_info = $c_model->{element}{$elt_name}; my $summary = $elt_info->{summary} || ''; $summary &&= " - $summary"; push @elt, "=head2 $elt_name$summary", ''; push @elt, $self->get_element_description($elt_info), ''; foreach ( $elt_info, $elt_info->{cargo} ) { if ( my $ccn = $_->{config_class_name} ) { push @classes, $ccn; $see_also{$ccn} = 1; } if ( my $migr = $_->{migrate_from} ) { push @elt, $self->get_migrate_doc( $elt_name, 'is migrated with', $migr ); } if ( my $migr = $_->{migrate_values_from} ) { push @elt, "Note: $elt_name values are migrated from '$migr'", ''; } if ( my $comp = $_->{compute} ) { push @elt, $self->get_migrate_doc( $elt_name, 'is computed with', $comp ); } } } foreach my $what (qw/author copyright license/) { my $item = $c_model->{$what}; push @{ $legalese{$what} }, $item if $item; } my @end; foreach my $what (qw/author copyright license/) { next unless @{ $legalese{$what} || [] }; push @end, "=head1 " . uc($what), '', '=over', '', ( map { ( "=item $_", '' ); } map { ref $_ ? @$_ : $_ } @{ $legalese{$what} } ), '', '=back', ''; } my @see_also = ( "=head1 SEE ALSO", '', "=over", '', "=item *", '', "L", '', ( map { ( "=item *", '', "L", '' ); } sort keys %see_also ), "=back", '' ); $result{$full_name} = join( "\n", @pod, @elt, @see_also, @end, '=cut', '' ) . "\n"; $done->{$class_name} = 1; } return \%result; } # # New subroutine "get_migrate_doc" extracted - Tue Jun 5 13:31:20 2012. # sub get_migrate_doc { my ( $self, $elt_name, $desc, $migr ) = @_; my $mv = $migr->{variables}; my $mform = $migr->{formula}; if ( $mform =~ /\n/) { $mform =~ s/^/ /mg; $mform = "\n\n$mform\n\n"; } else { $mform = "'C<$mform>' " } my $mdoc = "Note: $elt_name $desc ${mform}and with: \n\n=over\n\n=item *\n\n" . join( "\n\n=item *\n\n", map { qq!C<\$$_> => C<$mv->{$_}>! } sort keys %$mv ); if ( my $rep = $migr->{replace} ) { $mdoc .= "\n\n=item *\n\n" . join( "\n\n=item *\n\n", map { qq!C<\$replace{$_}> => C<$rep->{$_}>! } sort keys %$rep ); } $mdoc .= "\n\n=back\n\n"; return ( $mdoc, '' ); } sub get_element_description { my ( $self, $elt_info ) = @_; my $type = $elt_info->{type}; my $cargo = $elt_info->{cargo}; my $vt = $elt_info->{value_type}; my $of = ''; my $cargo_type = $cargo->{type}; my $cargo_vt = $cargo->{value_type}; $of = " of " . ( $cargo_vt or $cargo_type ) if defined $cargo_type; my $ccn = $elt_info->{config_class_name} || $cargo->{config_class_name}; $of .= " of class L<$ccn|Config::Model::models::$ccn> " if $ccn; my $desc = $elt_info->{description} || ''; if ($desc) { $desc .= '.' if $desc =~ /\w$/; $desc .= ' ' unless $desc =~ /\s$/; } if ( my $status = $elt_info->{status} ) { $desc .= 'B<' . ucfirst($status) . '> '; } my $info = $elt_info->{mandatory} ? 'Mandatory. ' : 'Optional. '; $info .= "Type " . ( $vt || $type ) . $of . '. '; foreach my $name (qw/choice/) { my $item = $elt_info->{$name}; next unless defined $item; $info .= "$name: '" . join( "', '", @$item ) . "'. "; } my @default_info = (); # assemble in over item for string value_type foreach my $name (qw/default upstream_default/) { my $item = $elt_info->{$name}; next unless defined $item; push @default_info, [$name, $item] ; } my $elt_help = $self->get_element_value_help($elt_info); # breaks pod if $info is multiline my $ret = $desc . "I< $info > "; if (@default_info) { $ret .= "\n\n=over 4\n\n"; for ( @default_info) { $ret .= "=item $_->[0] value :\n\n$_->[1]\n\n"; } $ret .= "=back\n\n"; } $ret.= $elt_help; return $ret; } sub get_element_value_help { my ( $self, $elt_info ) = @_; my $help = $elt_info->{help}; return '' unless defined $help; my $help_text = "\n\nHere are some explanations on the possible values:\n\n=over\n\n"; foreach my $v ( sort keys %$help ) { $help_text .= "=item '$v'\n\n$help->{$v}\n\n"; } return $help_text . "=back\n\n"; } sub generate_doc { my ( $self, $top_class_name, $dir_str, $done ) = @_; $done //= {} ; my $res = $self->get_model_doc($top_class_name, $done); if ( defined $dir_str and $dir_str ) { foreach my $class_name ( sort keys %$res ) { my $dir = path($dir_str); $dir->mkpath() unless $dir->exists; my $file_path = $class_name; $file_path =~ s!::!/!g; my $pl_file = $dir->child("$file_path.pl"); $pl_file->parent->mkpath unless $pl_file->parent->exists; my $pod_file = $dir->child("$file_path.pod"); my $old = ''; if ($pod_file->exists ) { $old = $pod_file->slurp_utf8; } if ( $old ne $res->{$class_name} ) { $pod_file->spew_utf8( $res->{$class_name} ); say "Wrote documentation in $pod_file"; } } } else { foreach my $class_name ( sort keys %$res ) { print "########## $class_name ############ \n\n"; print $res->{$class_name}; } } return; } sub get_element_model { my $self = shift; my $config_class_name = shift || die "Model::get_element_model: missing config class name argument"; my $element_name = shift || die "Model::get_element_model: missing element name argument"; my $model = $self->model($config_class_name); my $element_m = $model->{element}{$element_name} || croak "get_element_model error: unknown element name: $element_name"; return dclone($element_m); } # returns a hash ref containing the raw model, i.e. before expansion of # multiple keys (i.e. [qw/a b c/] => ... ) # internal. For now ... sub get_normalized_model { my $self = shift; my $config_class_name = shift; $self->load($config_class_name) unless defined $self->normalized_model($config_class_name); my $normalized_model = $self->normalized_model($config_class_name) || croak "get_normalized_model error: unknown config class name: $config_class_name"; return dclone($normalized_model); } sub get_element_name ($self, %args) { my $class = $args{class} || croak "get_element_name: missing 'class' parameter"; if (delete $args{for}) { carp "get_element_name: 'for' parameter is deprecated"; } my $model = $self->model($class); my @result; # this is a bit convoluted, but the order of the returned element # must respect the order of the elements declared in the model by # the user foreach my $elt ( @{ $model->{element_list} } ) { my $elt_data = $model->{element}{$elt}; my $l = $elt_data->{level} || get_default_property('level'); push @result, $elt if $l ne 'hidden' ; } return wantarray ? @result : join( ' ', @result ); } sub get_element_property ($self, %args) { my $elt = $args{element} || croak "get_element_property: missing 'element' parameter"; my $prop = $args{property} || croak "get_element_property: missing 'property' parameter"; my $class = $args{class} || croak "get_element_property:: missing 'class' parameter"; my $model = $self->model($class); # must take into account 'accept' model parameter if ( not defined $model->{element}{$elt} ) { $logger->debug("test accept for class $class elt $elt prop $prop"); foreach my $acc_re ( @{ $model->{accept_list} } ) { return $model->{accept}{$acc_re}{$prop} || get_default_property($prop) if $elt =~ /^$acc_re$/; } } return $self->model($class)->{element}{$elt}{$prop} || get_default_property($prop); } sub list_class_element { my $self = shift; my $pad = shift || ''; my $res = ''; foreach my $class_name ( $self->normalized_model_names ) { $res .= $self->list_one_class_element($class_name); } return $res; } sub list_one_class_element { my $self = shift; my $class_name = shift; my $pad = shift || ''; my $res = $pad . "Class: $class_name\n"; my $c_model = $self->normalized_model($class_name); my $elts = $c_model->{element_list}; # array ref return $res unless defined $elts and @$elts; foreach my $elt_name (@$elts) { my $type = $c_model->{element}{$elt_name}{type}; $res .= $pad . " - $elt_name ($type)\n"; } return $res; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: a framework to validate, migrate and edit configuration files __END__ =pod =head1 SYNOPSIS =head2 Perl program to use an existing model use Config::Model qw(cme); # load, modify and save popcon configuration file cme('popcon')->modify("PARTICIPATE=yes"); =head2 Command line to use an existing model # with App::Cme cme modify popcon 'PARTICIPATE=yes' =head2 Perl program with a custom model use Config::Model; # create new Model object my $model = Config::Model->new() ; # Config::Model object # create config model. A more complex model should be stored in a # file in lib/Config/Model/models. Then, run cme as explained below $model ->create_config_class ( name => "MiniModel", element => [ [qw/foo bar baz/ ] => { type => 'leaf', value_type => 'uniline' }, ], rw_config => { backend => 'IniFile', auto_create => 1, config_dir => '.', file => 'mini.ini', } ) ; # create instance (Config::Model::Instance object) my $instance = $model->instance (root_class_name => 'MiniModel'); # get configuration tree root my $cfg_root = $instance -> config_root ; # C::M:Node object # load some dummy data $cfg_root -> load("bar=BARV foo=FOOV baz=BAZV") ; # write new ini file $instance -> write_back; # now look for new mini.ini file un current directory =head2 Create a new model file and use it $ mkdir -p lib/Config/Model/models/ $ echo "[ { name => 'MiniModel', \ element => [ [qw/foo bar baz/ ] => { type => 'leaf', value_type => 'uniline' }, ], \ rw_config => { backend => 'IniFile', auto_create => 1, \ config_dir => '.', file => 'mini.ini', \ } \ } \ ] ; " > lib/Config/Model/models/MiniModel.pl # require App::Cme $ cme modify -try MiniModel -dev bar=BARV foo=FOOV baz=BAZV $ cat mini.ini Note that model creation is easier running C with L and L. =head1 DESCRIPTION Config::Model enables a project developer to provide an interactive configuration editor (graphical, curses based or plain terminal) to users. To provide these tools, Config::Model needs: =over =item * A description of the structure and constraints of the project's configuration (fear not, a GUI is available with L) =item * A module to read and write configuration data (aka a backend class). =back With the elements above, Config::Model generates interactive configuration editors (with integrated help and data validation). These editors can be graphical (with L), curses based (with L) or based on ReadLine. Smaller models targeted for configuration upgrades can also be created: =over =item * only upgrade and migration specifications are required =item * unknown parameters can be accepted =back A command line is provided to perform configuration upgrade with a single command. =head2 How does this work ? Using this project, a typical configuration editor/validator/upgrader is made of 3 parts : GUI <--------> |---------------| CursesUI <---> | |---------| | | | Model | | ShellUI <----> | |---------| |<-----read-backend------- |-------------| | |----write-backend-------> | config file | FuseUI <-----> | Config::Model | |-------------| |---------------| =over =item 1. A reader and writer that parse the configuration file and transform its data into a tree representation within Config::Model. The values contained in this configuration tree can be written back in the configuration file(s). =item 2. A validation engine which is in charge of validating the content and structure of configuration stored in the configuration tree. This validation engine follows the structure and constraint declared in a configuration model. This model is a kind of schema for the configuration tree. =item 3. A user interface to modify the content of the configuration tree. A modification is validated immediately by the validation engine. =back The important part is the configuration model used by the validation engine. This model can be created or modified with a graphical editor (Config::Model::Iself). =head1 Question you may ask yourself =head2 Don't we already have some configuration validation tools ? You're probably thinking of tools like webmin. Yes, these tools exist and work fine, but they have their set of drawbacks. Usually, the validation of configuration data is done with a script which performs semantic validation and often ends up being quite complex (e.g. 2500 lines for Debian's xserver-xorg.config script which handles C file). In most cases, the configuration model is expressed in instructions (whatever programming language is used) and interspersed with a lot of processing to handle the actual configuration data. =head2 What's the advantage of this project ? Config::Model projects provide a way to get a validation engine where the configuration model is completely separated from the actual processing instructions. A configuration model can be created and modified with the graphical interface provide by L. The model is saved in a declarative form (currently, a Perl data structure). Such a model is easier to maintain than a lot of code. The model specifies: =over =item * The structure of the configuration data (which can be queried by generic user interfaces) =item * The properties of each element (boundaries check, integer or string, enum like type, default value ...) =item * The targeted audience (beginner, advanced, master) =item * The on-line help =back So, in the end: =over =item * Maintenance and evolution of the configuration content is easier =item * User sees a *common* interface for *all* programs using this project. =item * Upgrade of configuration data is easier and sanity check is performed during the upgrade. =item * Audit of configuration is possible to check what was modified by the user compared to default values =back =head2 What about the user interface ? L interface can be: =over =item * a shell-like interface (plain or based on Term::ReadLine). =item * Graphical with L (Perl/Tk interface). =item * based on curses with L. This interface can be handy if your X server is down. =item * Through a virtual file system where every configuration parameter is mapped to a file. (Linux only) =back All these interfaces are generated from the configuration model. And configuration model can be created or modified with a graphical user interface (with C once L is installed) =head2 What about configuration data storage ? Since the syntax of configuration files vary wildly form one application to another, people who want to use this framework may have to provide a dedicated parser/writer. To help with this task, this project provides writer/parsers for common format: INI style file and perl file. With the additional Config::Model::Backend::Augeas, Augeas library can be used to read and write some configuration files. See http://augeas.net for more details. =head2 Is there an example of a configuration model ? The "example" directory contains a configuration model example for C file. This example includes a small program that use this model to show some ways to extract configuration information. =head1 Mailing lists For more question, please send a mail to: config-model-users at lists.sourceforge.net =head1 Suggested reads to start =head2 Beginners =over =item * L =item * L =back =head2 Advanced =over =item * L: This doc and its siblings describes all parameters available to create a model. These are the parameters available in the GUI launched by C command. =item * L =back =head2 Masters use the source, Luke =head1 STOP The documentation below is quite detailed and is more a reference doc regarding C class. For an introduction to model creation, please check: L =head1 Storage backend, configuration reader and writer See L for details =head1 Validation engine C provides a way to get a validation engine from a set of rules. This set of rules is called the configuration model. =head1 User interface The user interface uses some parts of the API to set and get configuration values. More importantly, a generic user interface needs to analyze the configuration model to be able to generate at run-time relevant configuration screens. A command line interface is provided in this module. Curses and Tk interfaces are provided by L and L. =head1 Constructor my $model = Config::Model -> new ; creates an object to host your model. =head2 Constructor parameters =over =item log_level Specify minimal log level. Default is C. Can be C, C or C to get more logs. Can also be C to get less traces. This parameter is used to override the log level specified in log configuration file. =back =head1 Configuration Model To validate a configuration tree, we must create a configuration model that defines all the properties of the validation engine you want to create. The configuration model is expressed in a declarative form (i.e. a Perl data structure which should be easier to maintain than a lot of code) Each configuration class may contain a set of: =over =item * node elements that refer to another configuration class =item * value elements that contain actual configuration data =item * list or hash elements that also contain several node or value elements =back The structure of your configuration tree is shaped by the a set of configuration classes that are used in node elements, The structure of the configuration data must be based on a tree structure. This structure has several advantages: =over =item * Unique path to get to a node or a leaf. =item * Simpler exploration and query =item * Simple hierarchy. Deletion of configuration items is simpler to grasp: when you cut a branch, all the leaves attached to that branch go down. =back But using a tree has also some drawbacks: =over 4 =item * A complex configuration cannot be mapped on a tree. Some more relation between nodes and leaves must be added. =item * A configuration may actually be structured as a graph instead as a tree (for instance, any configuration that maps a service to a resource). The graph relation must be decomposed in a tree with special I relations that complete the tree to form a graph. See L =back Note: a configuration tree is a tree of objects. The model is declared with classes. The classes themselves have relations that closely match the relation of the object of the configuration tree. But the class need not to be declared in a tree structure (always better to reuse classes). But they must be declared as a DAG (directed acyclic graph). See also LMore on DAGs> Each configuration class declaration specifies: =over =item * The C of the class (mandatory) =item * A C used in user interfaces (optional) =item * Optional include specification to avoid duplicate declaration of elements. =item * The class elements =back Each element specifies: =over =item * Most importantly, the type of the element (mostly C, or C) =item * The properties of each element (boundaries, check, integer or string, enum like type ...) =item * The default values of parameters (if any) =item * Whether the parameter is mandatory =item * Targeted audience (beginner, advance, master), i.e. the level of expertise required to tinker a parameter (to hide expert parameters from newbie eyes) =item * On-line help (for each parameter or value of parameter) =back See L for details on how to declare a configuration class. Example: $ cat lib/Config/Model/models/Xorg.pl [ { name => 'Xorg', class_description => 'Top level Xorg configuration.', include => [ 'Xorg::ConfigDir'], element => [ Files => { type => 'node', description => 'File pathnames', config_class_name => 'Xorg::Files' }, # snip ] }, { name => 'Xorg::DRI', element => [ Mode => { type => 'leaf', value_type => 'uniline', description => 'DRI mode, usually set to 0666' } ] } ]; =head1 Configuration instance methods A configuration instance is created from a model and is the starting point of a configuration tree. =head2 instance An instance must be created with a model name (using the root class name) or an application name (as shown by "L C" command). For example: my $model = Config::Model->new() ; $model->instance( application => 'approx'); Or: my $model = Config::Model->new() ; # note that the model class is slightly different compared to # application name $model->instance( root_class_name => 'Approx'); A custom configuration class can also be used with C parameter: my $model = Config::Model->new() ; # create_config_class is described below $model ->create_config_class ( name => "SomeRootClass", element => [ ... ] ) ; # instance name is 'default' my $inst = $model->instance (root_class_name => 'SomeRootClass'); You can create several separated instances from a model using C option: # instance name is 'default' my $inst = $model->instance ( root_class_name => 'SomeRootClass', name => 'test1' ); Usually, model files are loaded automatically using a path matching C (e.g. configuration class C is stored in C. You can choose to specify the file containing the model with C parameter. This is mostly useful for tests. The C method can also retrieve an instance that has already been created: my $inst = $model->instance( name => 'test1' ); =head2 get_instance Retrieve an existing instance using its name. my $inst = $model->get_instance('test1' ); =head2 has_instance Check if an instance name already exists my $maybe = $model->has_instance('test1'); =head2 cme This method is syntactic sugar for short program. It creates a new C object and returns a new instance. C arguments are passed to L method, except C. Like L command, C functions accepts C parameters. When this argument is true, the instance is created with C< 'no'>>. Hence bad values are stored in C and must be corrected before saving back the data. =head1 Configuration class A configuration class is made of series of elements which are detailed in L. Whatever its type (node, leaf,... ), each element of a node has several other properties: =over =item level Level is C, C or C. The level is used to set how configuration data is presented to the user in browsing mode. C elements are shown to the user no matter what. C elements are well, hidden. Their purpose is explained with the I notion. =item status Status is C, C or C (default). Using a deprecated element raises a warning. Using an obsolete element raises an exception. =item description Description of the element. This description is used while generating user interfaces. =item summary Summary of the element. This description is used while generating a user interfaces and may be used in comments when writing the configuration file. =item class_description Description of the configuration class. This description is used while generating user interfaces. =item generated_by Mention with a descriptive string if this class was generated by a program. This parameter is currently reserved for L model editor. =item include Include element description from another class. include => 'AnotherClass' , or include => [qw/ClassOne ClassTwo/] In a configuration class, the order of the element is important. For instance if C is warped by C, you must declare C element before C. When including another class, you may wish to insert the included elements after a specific element of your including class: # say AnotherClass contains element xyz include => 'AnotherClass' , include_after => "foo" , element => [ bar => ... , foo => ... , baz => ... ] Now the element of your class are: ( bar , foo , xyz , baz ) Note that include may not clobber an existing element. =item include_backend Include read/write specification from another class. include_backend => 'AnotherClass' , or include_backend => [qw/ClassOne ClassTwo/] =back Note that include may not clobber an existing read/write specification. =head2 create_config_class This method creates configuration classes. The parameters are described above and are forwarded to L constructor. See L for more details on configuration class parameters. Example: my $model = Config::Model -> new ; $model->create_config_class ( config_class_name => 'SomeRootClass', description => [ X => 'X-ray' ], level => [ 'tree_macro' => 'important' ] , class_description => "SomeRootClass description", element => [ ... ] ) ; For convenience, C and C parameters can also be declared within the element declaration: $model->create_config_class ( config_class_name => 'SomeRootClass', class_description => "SomeRootClass description", 'element' => [ tree_macro => { level => 'important'}, X => { description => 'X-ray', } , ] ) ; =head1 Load predeclared model You can also load predeclared model. =head2 load( ) This method opens the model directory and execute a C<.pl> file containing the model declaration, This perl file must return an array ref to declare models. E.g.: [ [ name => 'Class_1', element => [ ... ] ], [ name => 'Class_2', element => [ ... ] ] ]; do not put C<1;> at the end or C will not work When a model name contain a C<::> (e.g C), C looks for a file named C. This method also searches in C directory for additional model information. Model snippet found there are loaded with L. Returns a list containing the names of the loaded classes. For instance, if C contains a model for C and C, C returns C<( 'Foo::Bar' , 'Foo::Bar2' )>. =head2 augment_config_class (name => '...', class_data ) Enhance the feature of a configuration class. This method uses the same parameters as L. See L for more details on creating model plugins. =head1 Model query =head2 model Returns a hash containing the model declaration of the passed model name. Do not modify the content of the returned data structure. my $cloned = $model->model('Foo'); =head2 get_model_clone Like C, returns a hash containing the model declaration of the passed model name, this time in a deep clone of the data structure. my $cloned = $model->get_model_clone('Foo'); =head2 generate_doc ( top_class_name , directory , [ \%done ] ) Generate POD document for configuration class top_class_name and all classes used by top_class_name, and write them in specified directory. C<\%done> is an optional reference to a hash used to avoid writing twice the same documentation when this method is called several times. =head2 get_element_model( config_class_name , element) Return a hash containing the model declaration for the specified class and element. =head2 get_element_name( class => Foo ) Get all names of the elements of class C. =head2 get_element_property Returns the property of an element from the model. Parameters are: =over =item class =item element =item property =back =head2 list_class_element Returns a string listing all the class and elements. Useful for debugging your configuration model. =head1 Error handling Errors are handled with an exception mechanism. When a strongly typed Value object gets an authorized value, it raises an exception. If this exception is not caught, the programs exits. See L for details on the various exception classes provided with C. =head1 Logging See L =head2 initialize_log4perl This method can be called to load L configuration from C<~/.log4config-model>, or from C files or from L. Accepts C parameter with a list of log classes that are added to the log4perl configuration read above. For instance, with C<< verbose => 'Loader' >>, log4perl is initialised with log4perl.logger.Verbose.Loader = INFO, PlainMsgOnScreen Likewise, with C<< verbose => [ 'Loader', 'Foo' ] >>, log4perl is initialised with: log4perl.logger.Verbose.Loader = INFO, PlainMsgOnScreen log4perl.logger.Verbose.Foo = INFO, PlainMsgOnScreen Currently, this module supports only C as verbose parameters. =head1 BUGS Given Murphy's law, the author is fairly confident that you will find bugs or miss some features. Please report them to https://github.com/dod38fr/config-model/issues The author will be notified, and then you'll automatically be notified of progress on your bug. =head1 FEEDBACK Feedback from users are highly desired. If you find this module useful, please share your use cases, success stories with the author or with the config-model- users mailing list. =head1 PROJECT FOUNDER Dominique Dumont, "ddumont@cpan.org" =head1 CREDITS Contributors to this project are listed in alphabetical order: Harley Pig Ilya Arosov Jose Luis Perez Diez Krzysztof Tyszecki Mathieu Arnold Mohammad S Anwar Topi Miettinen Many thanks for your help =head1 SEE ALSO L, L L =head2 Model elements The arrow shows inheritance between classes =over =item * L <- L =item * L <- L <- L =item * L <- L <- L =item * L <- L =item * L <- L =item * L <- L =back =head2 command line L. =head2 Read and write backends =over =item * L <- L =item * L <- L =item * L <- L =item * L <- L =back =head2 Model utilities =over =item * L =item * L: Used by C object =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L: Search element in configuration model. =item * L =item * L: Search string or regexp in configuration tree. =item * L =item * L =item * L =item * L =back =head2 Test framework =over =item * L =back =cut libconfig-model-perl-2.155/lib/Config/Model/000077500000000000000000000000001472064100600205335ustar00rootroot00000000000000libconfig-model-perl-2.155/lib/Config/Model/Annotation.pm000066400000000000000000000141111472064100600232010ustar00rootroot00000000000000package Config::Model::Annotation; use Mouse; use English; use Mouse::Util::TypeConstraints; use Path::Tiny; use Data::Dumper; use Config::Model::TypeConstraints; use Config::Model::Exception; use Config::Model::Node; use Config::Model::ObjTreeScanner; use strict ; use warnings; use Carp qw/croak confess cluck/; #my $logger = get_logger("Annotation") ; has 'instance' => ( is => 'ro', isa => 'Config::Model::Instance', required => 1 ); has 'config_class_name' => ( is => 'ro', isa => 'Str', required => 1 ); has 'file' => ( is => 'ro', isa => 'Path::Tiny', lazy => 1, builder => '_set_file' ); has 'dir' => ( is => 'ro', isa => 'Path::Tiny', lazy => 1, builder => '_set_dir' ); has 'root_dir' => ( is => 'ro', isa => 'Config::Model::TypeContraints::Path', coerce => 1 ); sub _set_file { my $self = shift; return $self->dir->child( $self->config_class_name . '-note.pl'); } sub _set_dir { my $self = shift; return $self->root_dir ? $self->root_dir->child('config-model') : $EUID ? path("/var/lib/config-model") : path("~/.config-model"); } sub save { my $self = shift; my $dir = $self->dir; $dir->mkpath; my $h = $self->get_annotation_hash; $self->file->spew_utf8( Dumper($h) ); } sub get_annotation_hash { my $self = shift; my %data; my $scanner = Config::Model::ObjTreeScanner->new( leaf_cb => \&my_leaf_cb, hash_element_cb => \&my_hash_element_cb, list_element_cb => \&my_list_element_cb, node_element_cb => \&my_node_element_cb, fallback => 'all', ); my $root = $self->instance->config_root; $scanner->scan_node( \%data, $root ); return \%data; } # WARNING: not a method sub my_hash_element_cb { my ( $scanner, $data_ref, $node, $element_name, @keys ) = @_; # custom code using $data_ref store_note_in_data( $data_ref, $node->fetch_element($element_name) ); # resume exploration map { $scanner->scan_hash( $data_ref, $node, $element_name, $_ ) } @keys; } # WARNING: not a method sub my_node_element_cb { my ( $scanner, $data_ref, $node, $element_name, $key, $contained_node ) = @_; # your custom code using $data_ref store_note_in_data( $data_ref, $contained_node ); # explore next node $scanner->scan_node( $data_ref, $contained_node ); } # WARNING: not a method sub my_list_element_cb { my ( $scanner, $data_ref, $node, $element_name, @idx ) = @_; # custom code using $data_ref store_note_in_data( $data_ref, $node->fetch_element($element_name) ); # resume exploration (if needed) map { $scanner->scan_list( $data_ref, $node, $element_name, $_ ) } @idx; # note: scan_list and scan_hash are equivalent } # WARNING: not a method sub my_leaf_cb { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; store_note_in_data( $data_ref, $leaf_object ); } # WARNING: not a method sub store_note_in_data { my ( $data_ref, $obj ) = @_; my $note = $obj->annotation; return unless $note; my $key = $obj->location; $data_ref->{$key} = $note; } sub load { my $self = shift; my $f = $self->file; return unless $f->exists; my $hash = do "./$f" || croak "can't do $f:$!"; my $root = $self->instance->config_root; foreach my $path ( keys %$hash ) { my $obj = eval { $root->grab( step => $path, autoadd => 0 ) }; next if $@; # skip annotation of unknown elements $obj->annotation( $hash->{$path} ); } } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write configuration annotations __END__ =head1 SYNOPSIS use Config::Model ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put some data in config tree the hard way $root->fetch_element('foo')->store('yada') ; $root->fetch_element('baz')->fetch_with_id('en')->store('hello') ; # put annotation the hard way $root->fetch_element('foo')->annotation('english') ; $root->fetch_element('baz')->fetch_with_id('en')->annotation('also english') ; # put more data the easy way my $steps = 'baz:fr=bonjour#french baz:hr="dobar dan"#croatian'; $root->load( steps => $steps ) ; # dump resulting tree with annotations print $root->dump_tree; # save annotations my $annotate_saver = Config::Model::Annotation -> new ( config_class_name => 'MyClass', instance => $inst , root_dir => '/tmp/', # for test ) ; $annotate_saver->save ; # now check content of /tmp/config-model/MyClass-note.pl =head1 DESCRIPTION This module provides an object that read and write annotations (a bit like comments) to and from a configuration tree and save them in a file (not configuration file). This module can be used to save annotation for configuration files that do not support comments. THis module should not be used for configuration files that support comments. Depending on the effective id of the process, the annotation is saved in: =over =item * C<< /var/lib/config-model/-note.yml >> for root (EUID == 0) =item * C<< ~/.config-model/-note.yml >> for normal user (EUID > 0) =back =head1 CONSTRUCTOR Quite standard. The constructor is passed a L object. =head1 METHODS =head2 save Save annotations in a file (See L) =head2 load Loads annotations from a file (See L) =head1 CAVEATS This module is currently not used. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, =cut libconfig-model-perl-2.155/lib/Config/Model/AnyId.pm000066400000000000000000001334101472064100600220770ustar00rootroot00000000000000package Config::Model::AnyId; use 5.020; use Mouse; with "Config::Model::Role::NodeLoader"; with "Config::Model::Role::Utils"; use Config::Model::Exception; use Config::Model::Warper; use Carp qw/cluck croak carp/; use Log::Log4perl qw(get_logger :levels); use Storable qw/dclone/; use Mouse::Util::TypeConstraints; use Scalar::Util qw/weaken/; extends qw/Config::Model::AnyThing/; use feature qw/signatures postderef/; no warnings qw/experimental::signatures experimental::postderef/; subtype 'KeyArray' => as 'ArrayRef' ; coerce 'KeyArray' => from 'Str' => via { [$_] } ; my $logger = get_logger("Tree::Element::Id"); my $user_logger = get_logger("User"); my $deep_check_logger = get_logger('DeepCheck'); my $fix_logger = get_logger("Anything::Fix"); my $change_logger = get_logger("ChangeTracker"); enum 'DataMode' => [qw/preset layered normal/]; has data_mode => ( is => 'rw', isa => 'HashRef[DataMode]', traits => ['Hash'], handles => { get_data_mode => 'get', set_data_mode => 'set', delete_data_mode => 'delete', clear_data_mode => 'clear', }, default => sub { {}; } ); # this is cleared and set by set_properties has _warpable_check_content_actions => ( is => 'bare', # no direct accessor isa => 'ArrayRef[CodeRef]', traits => ['Array'], handles => { add_warpable_check_content => 'push', clear_warpable_check_content => 'clear', get_all_warpable_content_checks => 'elements', }, default => sub { []; } ); has _check_content_actions => ( is => 'bare', # no direct accessor isa => 'ArrayRef[CodeRef]', traits => ['Array'], handles => { add_check_content => 'push', get_all_content_checks => 'elements', }, default => sub { []; } ); # needs_content_check defaults to 1 to trap bad data right after loading has needs_content_check => ( is => 'rw', isa => 'Bool', default => 1 ); has has_fixes => ( is => 'ro', isa => 'Num', default => 0, traits => ['Number'], handles => { inc_fixes => [ add => 1 ], dec_fixes => [ sub => 1 ], add_fixes => 'add', flush_fixes => [ mul => 0 ], } ); # Some idea for improvement # suggest => 'foo' or '$bar foo' # creates a method analog to next_id (or next_id but I need to change # run_user_command) that suggest the next id as foo_ where # nb is incremented each time, or compute the passed formula # and performs the same my @common_int_params = qw/min_index max_index max_nb auto_create_ids/; has \@common_int_params => ( is => 'ro', isa => 'Maybe[Int]' ); my @common_hash_params = qw/default_with_init/; has \@common_hash_params => ( is => 'ro', isa => 'Maybe[HashRef]' ); my @common_list_params = qw/allow_keys default_keys auto_create_keys/; has \@common_list_params => ( is => 'ro', isa => 'KeyArray', coerce => 1, default => sub { []; } ); my @common_str_params = qw/allow_keys_from allow_keys_matching follow_keys_from migrate_keys_from migrate_values_from duplicates warn_if_key_match warn_unless_key_match/; has \@common_str_params => ( is => 'ro', isa => 'Maybe[Str]' ); my @common_params = ( @common_int_params, @common_str_params, @common_list_params, @common_hash_params ); my @allowed_warp_params = ( @common_params, qw/level convert/ ); around BUILDARGS => sub { my $orig = shift; my $class = shift; my %args = @_; my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @allowed_warp_params; return $class->$orig( backup => dclone( \%h ), @_ ); }; has [qw/backup cargo/] => ( is => 'ro', isa => 'HashRef', required => 1 ); has warp => ( is => 'ro', isa => 'Maybe[HashRef]' ); has [qw/morph/] => ( is => 'ro', isa => 'Bool', default => 0 ); has content_warning_list => ( is => 'rw', isa => 'ArrayRef', default => sub { []; } ); has [qw/cargo_class max_index index_class index_type/] => ( is => 'rw', isa => 'Maybe[Str]' ); has config_model => ( is => 'ro', isa => 'Config::Model', weak_ref => 1, lazy => 1, builder => '_config_model' ); sub _config_model { my $self = shift; return $self->instance->config_model; } sub config_class_name { my $self = shift; return $self->cargo->{config_class_name}; } sub BUILD { my $self = shift; croak "Missing cargo->type parameter for element " . $self->{element_name} || 'unknown' unless defined $self->cargo->{type}; if ( $self->cargo->{type} eq 'node' and not $self->cargo->{config_class_name} ) { croak "Missing cargo->config_class_name parameter for element " . $self->element_name || 'unknown'; } if ( $self->{cargo}{type} eq 'hash' or $self->{cargo}{type} eq 'list' ) { die "$self->{element_name}: using $self->{cargo}{type} will probably not work"; } $self->set_properties(); if ( defined $self->warp ) { $self->{warper} = Config::Model::Warper->new( warped_object => $self, %{ $self->warp }, allowed => \@allowed_warp_params ); } return $self; } # this method can be called by the warp mechanism to alter (warp) the # feature of the Id object. sub set_properties ($self, @args) { # mega cleanup for ( @allowed_warp_params ) { delete $self->{$_}; } my %args = ( %{ $self->{backup} }, @args ); # these are handled by Node or Warper for ( qw/level/ ) { delete $args{$_}; } $logger->trace( $self->name, " set_properties called with @args" ); for ( @common_params ) { $self->{$_} = delete $args{$_} if defined $args{$_}; } $self->set_convert( \%args ) if defined $args{convert}; $self-> clear_warpable_check_content; for ( $self-> get_all_content_checks ) { $self-> add_warpable_check_content($_); } for ( qw/duplicates/ ) { my $method = "check_$_"; my $weak_self = $self; weaken($weak_self); # weaken reference loop ($self - check_content - closure - self) $self-> add_check_content( sub { $weak_self->$method(@_);} ) if $self->{$_}; } Config::Model::Exception::Model->throw( object => $self, error => "Undefined index_type" ) unless defined $self->{index_type}; Config::Model::Exception::Model->throw( object => $self, error => "Unexpected index_type $self->{index_type}" ) unless ( $self->{index_type} eq 'integer' or $self->{index_type} eq 'string' ); my @current_idx = $self->_fetch_all_indexes(); if (@current_idx) { my $first_idx = shift @current_idx; my $last_idx = pop @current_idx; foreach my $idx ( ( $first_idx, $last_idx ) ) { my $ok = $self->check_idx($first_idx); next if $ok; # here a user input may trigger an exception even if fetch # or set value check is disabled. That's mostly because, # we cannot enforce more strict settings without random # deletion of data. For instance, if a hash contains 5 # items and the max_nb of items is reduced to 3. Which 2 # items should we remove ? # Since we cannot choose, we must raise an exception in # all cases. Config::Model::Exception::WrongValue->throw( error => "Error while setting id property:" . join( "\n\t", @{ $self->{idx_error_list} } ), object => $self ); } } $self->auto_create_elements; if ( defined $self->{duplicates} and defined $self->{cargo} and $self->{cargo}{type} ne 'leaf' ) { Config::Model::Exception::Model->throw( object => $self, error => "Cannot specify 'duplicates' with cargo type '$self->{cargo}{type}'", ); } my $ok_dup = 'forbid|suppress|warn|allow'; if ( defined $self->{duplicates} and $self->{duplicates} !~ /^$ok_dup$/ ) { Config::Model::Exception::Model->throw( object => $self, error => "Unexpected 'duplicates' $self->{duplicates} expected $ok_dup", ); } Config::Model::Exception::Model->throw( object => $self, error => "Unexpected parameters: " . join( ' ', keys %args ) ) if scalar keys %args; return; } sub create_default_with_init { my $self = shift; my $idx = shift; return unless defined $self->{default_with_init}; my $h = $self->{default_with_init}; foreach my $def_key ( keys %$h ) { $self->create_default_content($def_key); } return; } sub create_default_content { my $self = shift; my $idx = shift // die "missing index"; return unless defined $self->{default_with_init}; my $def = $self->{default_with_init}{$idx}; return unless defined $def; # no default content to create for $idx return if $self->_defined($idx) ; # object already created $self->auto_vivify($idx); my $v_obj = $self->_fetch_with_id($idx); if ( $v_obj->get_type eq 'leaf' ) { $v_obj->store( $def ); } else { $v_obj->load( $def ); } return; } sub max { my $self = shift; carp $self->name, ": max param is deprecated, use max_index\n"; return $self->max_index; } sub min { my $self = shift; carp $self->name, ": min param is deprecated, use min_index\n"; return $self->min_index; } sub cargo_type { goto &get_cargo_type; } sub get_cargo_type { my $self = shift; #my @ids = $self->fetch_all_indexes ; # the returned cargo type might be different from collected type # when collected type is 'warped_node'. #return @ids ? $self->fetch_with_id($ids[0])->get_cargo_type # : $self->{cargo_type} ; return $self->{cargo}{type}; } sub get_cargo_info { my $self = shift; my $what = shift; return $self->{cargo}{$what}; } # internal, does a grab with improved error message sub safe_typed_grab ($self, %args) { my $param = $args{param} || croak "safe_typed_grab: missing param"; my $res = eval { $self->grab( step => $self->{$param}, type => $self->get_type, check => $args{check} || 'yes', ); }; if ($@) { my $e = $@; my $msg = $e ? $e->full_message : ''; Config::Model::Exception::Model->throw( object => $self, error => "'$param' parameter: " . $msg ); } return $res; } sub get_default_keys { my $self = shift; if ( $self->{follow_keys_from} ) { my $followed = $self->safe_typed_grab( param => 'follow_keys_from' ); my @res = $followed->fetch_all_indexes; return wantarray ? @res : \@res; } my @res; push @res, @{ $self->{default_keys} } if defined $self->{default_keys}; push @res, keys %{ $self->{default_with_init} } if defined $self->{default_with_init}; return wantarray ? @res : \@res; } sub name { my $self = shift; return $self->{parent}->name . ' ' . $self->{element_name} . ' id'; } # internal. Handle model declaration arguments sub handle_args ($self, %args) { my $warp_info = delete $args{warp}; for (qw/index_class index_type morph ordered/) { $self->{$_} = delete $args{$_} if defined $args{$_}; } $self->{backup} = dclone( \%args ); $self->set_properties(%args) if defined $self->{index_type}; if ( defined $warp_info ) { $self->{warper} = Config::Model::Warper->new( warped_object => $self, %$warp_info, allowed => \@allowed_warp_params ); } return $self; } sub apply_fixes { my $self = shift; $fix_logger->trace( $self->location . ": apply_fixes called" ); $self->deep_check( fix => 1, logger => $fix_logger ); return; } my %check_idx_dispatch = map { ( $_ => 'check_' . $_ ); } qw/follow_keys_from allow_keys allow_keys_from allow_keys_matching warn_if_key_match warn_unless_key_match/; my %mode_move = ( layered => { preset => 1, normal => 1 }, preset => { normal => 1 }, normal => {}, ); around notify_change => sub ($orig, $self, %args) { if ($change_logger->is_trace) { my @a = map { ( $_ => $args{$_} // '' ); } sort keys %args; $change_logger->trace( "called for ", $self->name, " from ", join( ' ', caller ), " with ", join( ' ', @a ) ); } # $idx may be undef if $self has changed, not necessarily its content my $idx = $args{index}; if ( defined $idx ) { # use $idx to trigger move from layered->preset->normal my $imode = $self->instance->get_data_mode; my $old_mode = $self->get_data_mode($idx) || 'normal'; $self->set_data_mode( $idx, $imode ) if $mode_move{$old_mode}{$imode}; } return if $self->instance->initial_load and not $args{really}; $self-> needs_content_check(1); $self->$orig(%args); return; }; # the number of checks is becoming confusing. We have # - check_idx to check whether an index is fine. This is called when creating # a new index # - check_content: a more expensive check that runs all content checker registered # in this object. By default, none. A plain AnyId can contains a duplicated_content # checker if configured # - a deep_check (for lack of a better name): a also expensive check that involve index # versus other part of the config tree. By default, no check is done. This is currently # used only by DPkg model which check if the index value is used elsewhere # Using plain check in this class is avoided because it's too generic, but a polymorphic # entry point is still needed, oh well... sub check { # since check is not used when creating an index, but called explicitly # so it can be forwarded to deep_check. goto &deep_check; # backward compat } sub deep_check ($self, @args) { $deep_check_logger->trace("called on ".$self->name); for ( $self->fetch_all_indexes() ) { $self->check_idx(@args, index => $_); } $self->check_content(@args, logger => $deep_check_logger); return; } # check globally the list or hash, called by apply_fix or deep_check sub check_content ($self, %args) { my $silent = $args{silent} || 0; my $apply_fix = $args{fix} || 0; my $local_logger = $args{logger} || $logger; if ( $self-> needs_content_check ) { $local_logger->trace( "Running check_content on ",$self->location ); # need to keep track to update GUI $self-> flush_fixes; # reset before check my @error; my @warn; foreach my $sub ( $self-> get_all_content_checks ) { $sub->( \@error, \@warn, $apply_fix, $silent ); } my $nb = $self->fetch_size; push @error, "Too many items ($nb) limit $self->{max_nb}, " if defined $self->{max_nb} and $nb > $self->{max_nb}; if (not $silent) { for ( @warn ) { $user_logger->warn( "Warning in '" . $self->location_short . "': $_" ) } } $self->{content_warning_list} = \@warn; $self->{content_error_list} = \@error; $self-> needs_content_check(0); return scalar @error ? 0 : 1; } else { $local_logger->debug( $self->location, " has not changed, actual check skipped" ) if $local_logger->is_debug; my $err = $self->{content_error_list} // []; return scalar @$err ? 0 : 1; } } # internal function to check the validity of the index. Called when creating a new # index or when set_properties is called (init or during warp) sub check_idx ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'index'); my $idx = $args{index}; my $silent = $args{silent} || 0; my $check = $args{check} || 'yes'; my $apply_fix = $args{fix} // ($check eq 'fix' ? 1 : 0); Config::Model::Exception::Internal->throw( object => $self, error => "check_idx method: key or index is not defined" ) unless defined $idx; my @error; my @warn; foreach my $key_check_name ( keys %check_idx_dispatch ) { next unless $self->{$key_check_name}; my $method = $check_idx_dispatch{$key_check_name}; $self->$method( $idx, \@error, \@warn, $apply_fix ); } my $nb = $self->fetch_size; my $new_nb = $nb; $new_nb++ unless $self->_exists($idx); if ( $idx eq '' ) { push @error, "Index is empty"; } elsif ( $self->{index_type} eq 'integer' and $idx =~ /\D/ ) { push @error, "Index is not integer ($idx)"; } elsif ( defined $self->{max_index} and $idx > $self->{max_index} ) { push @error, "Index $idx > max_index limit $self->{max_index}"; } elsif ( defined $self->{min_index} and $idx < $self->{min_index} ) { push @error, "Index $idx < min_index limit $self->{min_index}"; } push @error, "Too many items ($new_nb) limit $self->{max_nb}, " . "rejected id '$idx'" if defined $self->{max_nb} and $new_nb > $self->{max_nb}; if ( scalar @error ) { my @a = $self->_fetch_all_indexes; push @error, "Item ids are '" . join( ',', @a ) . "'", $self->warp_error; } $self->{idx_error_list} = \@error; $self->{warning_hash}{$idx} = \@warn; if (@warn and not $silent and $check ne 'no') { for (@warn) { $user_logger->warn( "Warning in '" . $self->location_short . "': $_" ); } } return scalar @error ? 0 : 1; } #internal sub check_follow_keys_from { my ( $self, $idx, $error ) = @_; my $followed = $self->safe_typed_grab( param => 'follow_keys_from' ); return if $followed->exists($idx); push @$error, "key '" . $self->shorten_idx($idx) . "' does not exists in followed object '" . $followed->name . "'. Expected '" . join( "', '", $followed->fetch_all_indexes ) . "'"; return; } #internal sub check_allow_keys { my ( $self, $idx, $error ) = @_; my $ok = grep { $_ eq $idx } @{ $self->{allow_keys} }; push @$error, "Unexpected key '" . $self->shorten_idx($idx) . "'. Expected '" . join( "', '", @{ $self->{allow_keys} } ) . "'" unless $ok; return; } #internal sub check_allow_keys_matching { my ( $self, $idx, $error ) = @_; my $match = $self->{allow_keys_matching}; push @$error, "Unexpected key '" . $self->shorten_idx($idx) . "'. Key must match $match" unless $idx =~ /$match/; return; } #internal sub check_allow_keys_from { my ( $self, $idx, $error ) = @_; my $from = $self->safe_typed_grab( param => 'allow_keys_from' ); my $ok = grep { $_ eq $idx } $from->fetch_all_indexes; return if $ok; push @$error, "key '" . $self->shorten_idx($idx) . "' does not exists in '" . $from->name . "'. Expected '" . join( "', '", $from->fetch_all_indexes ) . "'"; return; } sub check_warn_if_key_match { my ( $self, $idx, $error, $warn ) = @_; my $re = $self->{warn_if_key_match}; push @$warn, "key '" . $self->shorten_idx($idx) . "' should not match $re\n" if $idx =~ /$re/; return; } sub check_warn_unless_key_match { my ( $self, $idx, $error, $warn ) = @_; my $re = $self->{warn_unless_key_match}; push @$warn, "key '" . $self->shorten_idx($idx) . "' should match $re\n" unless $idx =~ /$re/; return; } sub check_duplicates { my ( $self, $error, $warn, $apply_fix, $silent ) = @_; my $dup = $self->{duplicates}; return if $dup eq 'allow'; $logger->trace("check_duplicates called"); my %h; my @issues; my @to_delete; foreach my $i ( $self->fetch_all_indexes ) { my $v = $self->fetch_with_id( index => $i, check => 'no' )->fetch; next unless $v; $h{$v} = 0 unless defined $h{$v}; $h{$v}++; if ( $h{$v} > 1 ) { $logger->debug("got duplicates $i -> $v : $h{$v}"); push @to_delete, $i; push @issues, qq!$i:"$v"!; } } return unless @issues; if ($apply_fix) { $logger->debug("Fixing duplicates @issues, removing @to_delete"); for (reverse @to_delete) { $self->remove($_) } } elsif ( $dup eq 'forbid' ) { $logger->debug("Found forbidden duplicates @issues"); push @$error, "Forbidden duplicates value @issues"; } elsif ( $dup eq 'warn' ) { $logger->debug("warning condition: found duplicate @issues"); push @$warn, "Duplicated value: @issues"; $self->add_fixes( scalar @issues); } elsif ( $dup eq 'suppress' ) { $logger->debug("suppressing duplicates @issues"); for (reverse @to_delete) { $self->remove($_) } } else { die "Internal error: duplicates is $dup"; } return; } sub fetch_with_id ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'index'); my $check = $self->_check_check( $args{check} ); my $idx = $args{index}; $logger->trace( $self->name, " called for idx $idx" ) if $logger->is_trace; $idx = $self->{convert_sub}($idx) if ( defined $self->{convert_sub} and defined $idx ); # try migration only once $self->_migrate unless $self->{migration_done}; my $ok = 1; # check index only if it's unknown $ok = $self->check_idx( index => $idx, check => $check ) unless $self->_defined($idx) or $check eq 'no'; if ( $ok or $check eq 'no' ) { # create another method $self->create_default_content($idx); # no-op if idx exists $self->auto_vivify($idx) unless $self->_defined($idx); return $self->_fetch_with_id($idx); } else { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{idx_error_list} } ), object => $self ); } return; } sub get ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'path'); my $path = delete $args{path}; my $autoadd = 1; $autoadd = $args{autoadd} if defined $args{autoadd}; my $get_obj = delete $args{get_obj} || 0; $path =~ s!^/!!; my ( $item, $new_path ) = split m!/!, $path, 2; my $dcm = $args{dir_char_mockup}; # $item =~ s($dcm)(/)g if $dcm ; if ($dcm) { while (1) { my $i = index( $item, $dcm ); last if $i == -1; substr $item, $i, length($dcm), '/'; } } return unless ( $self->exists($item) or $autoadd ); $logger->trace("get: path $path, item $item"); my $obj = $self->fetch_with_id( index => $item, %args ); return $obj if ( ( $get_obj or $obj->get_type ne 'leaf' ) and not defined $new_path ); return $obj->get( path => $new_path, get_obj => $get_obj, %args ); } sub set ($self, $path, @args) { $path =~ s!^/!!; my ( $item, $new_path ) = split m!/!, $path, 2; return $self->fetch_with_id($item)->set( $new_path, @args ); } sub copy ( $self, $from, $to ) { Config::Model::Exception::User->throw( object => $self, message => "move: unknow from key $from" ) unless $self->exists($from); my $from_obj = $self->fetch_with_id($from); my $ok = $self->check_idx($to); if ( $ok && $self->{cargo}{type} eq 'leaf' ) { $logger->trace( "AnyId: copy leaf value from " . $self->name . " $from to $to" ); return $self->fetch_with_id($to)->store( $from_obj->fetch() ); } elsif ($ok) { # node object $logger->trace( "AnyId: deep copy node from " . $self->name ); my $target = $self->fetch_with_id($to); $logger->trace( "AnyId: deep copy node to " . $target->name ); return $target->copy_from($from_obj); } else { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{idx_error_list} } ), object => $self ); } return; } sub fetch_all { my $self = shift; my @keys = $self->fetch_all_indexes; return map { $self->fetch_with_id($_); } @keys; } sub fetch ($self, @args) { return join(',', $self->fetch_all_values(@args) ); } sub fetch_value ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'idx'); return $self->_fetch_value(%args, sub => 'fetch'); } sub fetch_summary ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'idx'); return $self->_fetch_value(%args, sub => 'fetch_summary'); } sub _fetch_value ($self, %args) { my $check = $self->_check_check( $args{check} ); my $sub = delete $args{sub}; if ( $self->{cargo}{type} eq 'leaf' ) { return $self->fetch_with_id($args{idx})->$sub( check => $check, mode => $args{mode} ); } else { Config::Model::Exception::WrongType->throw( object => $self, function => 'fetch_values', got_type => $self->{cargo}{type}, expected_type => 'leaf', info => "with index $args{idx}", ); } return; } sub fetch_all_values ($self, @args) { my %args = _resolve_arg_shortcut(\@args, 'mode'); my $mode = $args{mode}; my $check = $self->_check_check( $args{check} ); my @keys = $self->fetch_all_indexes; # verify content restrictions applied to List (e.g. no duplicate values) my $ok = $check eq 'no' ? 1 : $self->check_content(); if ( $ok or $check eq 'no' ) { return grep { defined $_ } map { $self->fetch_value(idx => $_, check => $check, mode => $mode ); } @keys; } else { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{content_error_list} } ), object => $self ); } return; } sub fetch_all_indexes { my $self = shift; $self->create_default; # will check itself if creation is necessary $self->_migrate; return $self->_fetch_all_indexes; } sub get_all_indexes { my $self = shift; carp "get_all_indexes is deprecated. use fetch_all_indexes"; return $self->fetch_all_indexes; } sub children { my $self = shift; return $self->fetch_all_indexes; } sub has_data { my $self = shift; return $self->fetch_size ; } # auto vivify must create according to cargo}{type # node -> Node or user class # leaf -> Value or user class # warped node cannot be used. Same effect can be achieved by warping # cargo_args my %element_default_class = ( warped_node => 'WarpedNode', node => 'Node', leaf => 'Value', ); my %can_override_class = ( node => 0, leaf => 1, ); #internal sub auto_vivify { my ( $self, $idx ) = @_; my %cargo_args = %{ $self->cargo }; my $class = delete $cargo_args{class}; # to override class in cargo my $cargo_type = delete $cargo_args{type}; Config::Model::Exception::Model->throw( object => $self, message => "unknown '$cargo_type' cargo type: " . "in cargo_args. Expected " . join( ' or ', keys %element_default_class ) ) unless defined $element_default_class{$cargo_type}; my $el_class = 'Config::Model::' . $element_default_class{$cargo_type}; if ( defined $class ) { Config::Model::Exception::Model->throw( object => $self, message => "$cargo_type class " . "cannot be overidden by '$class'" ) unless $can_override_class{$cargo_type}; $el_class = $class; } my @common_args = ( element_name => $self->{element_name}, index_value => $idx, instance => $self->{instance}, parent => $self->parent, container => $self, %cargo_args, ); my $item; # check parameters passed by the user if ( $cargo_type eq 'node' ) { $item = $self->load_node( @common_args, config_class_name => $self->config_class_name ); } else { Mouse::Util::load_class($el_class); $item = $el_class->new(@common_args); } my $imode = $self->instance->get_data_mode; $self->set_data_mode( $idx, $imode ); $self->_store( $idx, $item ); return; } ## no critic (Subroutines::ProhibitBuiltinHomonyms) sub defined { my ( $self, $idx ) = @_; return $self->_defined($idx); } ## no critic (Subroutines::ProhibitBuiltinHomonyms) sub exists { my ( $self, $idx ) = @_; return $self->_exists($idx); } ## no critic (Subroutines::ProhibitBuiltinHomonyms) sub delete { my ( $self, $idx ) = @_; delete $self->{warning_hash}{$idx}; my $ret = $self->_delete($idx); # notification is not needed if the value was already delete or missing $self->notify_change( note => "deleted entry $idx" ) if defined $ret; return $ret; } sub clear { my ($self) = @_; $self->{warning_hash} = {}; $self->_clear; $self->clear_data_mode; $self->notify_change( note => "cleared all entries" ); return; } sub clear_values { my ($self) = @_; carp "clear_values deprecated"; my $ct = $self->get_cargo_type; Config::Model::Exception::User->throw( object => $self, message => "clear_values() called on non leaf cargo type: '$ct'" ) if $ct ne 'leaf'; # this will trigger a notify_change for ( $self->fetch_all_indexes ) { $self->fetch_with_id($_)->store(undef); } $self->notify_change( note => "cleared all values" ); return; } sub warning_msg { my ( $self, $idx ) = @_; my $list ; if ( defined $idx ) { $list = $self->{warning_hash}{$idx} ; } elsif ( @{ $self->{content_warning_list} } ) { $list = $self->{content_warning_list} ; } return $list ? join( "\n", @$list ) : ''; } sub has_warning { my $self = shift; return @{ $self->{content_warning_list} }; } sub error_msg { my $self = shift; my @list; for (qw/idx_error_list content_error_list/) { push @list, @{ $self->{$_} } if $self->{$_}; } return unless @list; return wantarray ? @list : join( "\n\t", @list ); } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Base class for hash or list element __END__ =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "Foo", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, ] ); $model->create_config_class( name => "MyClass", element => [ plain_hash => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string', }, }, bounded_hash => { type => 'hash', # hash id index_type => 'integer', # hash boundaries min_index => 1, max_index => 123, max_nb => 2, # specify cargo held by hash cargo => { type => 'leaf', value_type => 'string' }, }, bounded_list => { type => 'list', # list id max_index => 123, cargo => { type => 'leaf', value_type => 'string' }, }, hash_of_nodes => { type => 'hash', # hash id index_type => 'string', cargo => { type => 'node', config_class_name => 'Foo' }, }, ], ); my $inst = $model->instance( root_class_name => 'MyClass' ); my $root = $inst->config_root; # put data my $steps = 'plain_hash:foo=boo bounded_list=foo,bar,baz bounded_hash:3=foo bounded_hash:30=baz hash_of_nodes:"foo node" foo="in foo node" - hash_of_nodes:"bar node" bar="in bar node" '; $root->load( steps => $steps ); # dump resulting tree print $root->dump_tree; =head1 DESCRIPTION This class provides hash or list elements for a L. The hash index can either be en enumerated type, a boolean, an integer or a string. =head1 CONSTRUCTOR AnyId object should not be created directly. =head1 Hash or list model declaration A hash or list element must be declared with the following parameters: =over =item type Mandatory element type. Must be C or C to have a collection element. The actual element type must be specified by C<< cargo => type >>. =item index_type Either C or C. Mandatory for hash. =item ordered Whether to keep the order of the hash keys (default no). (a bit like L). The hash keys are ordered along their creation. The order can be modified with L, L or L. =item duplicates Specify the policy regarding duplicated values stored in the list or as hash values (valid only when cargo type is C). The policy can be C (default), C, C (which offers the possibility to apply a fix), C. Note that duplicates I: this happens outside of this object. Duplicates can be check only after when the value is read. =item write_empty_value By default, hash entries without data are not saved in configuration files. Without data means the cargo of the hash key is empty: either its value is undef or all the values of the contained node are also empty. Set this parameter to 1 if the key must be saved in the configuration file even if the hash contains no value for that key. Note that writing hash entries without value may not be supported by all backends. Use with care. Supported only for hash elements. =item cargo Hash ref specifying the cargo held by the hash of list. This has must contain: =over 8 =item type Can be C or C (default). =item config_class_name Specifies the type of configuration object held in the hash. Only valid when C C is C. =item Constructor arguments passed to the cargo object. See L when C<< cargo->type >> is C. See L when C<< cargo->type >> is C. =back =item min_index Specify the minimum value (optional, only for hash and for integer index) =item max_index Specify the maximum value (optional, only for list or for hash with integer index) =item max_nb Specify the maximum number of indexes. (hash only, optional, may also be used with string index type) =item default_keys When set, the default parameter (or set of parameters) are used as default keys hashes and created automatically when the C or C functions are used on an I hash. You can use C<< default_keys => 'foo' >>, or C<< default_keys => ['foo', 'bar'] >>. =item default_with_init To perform special set-up on children nodes you can also use default_with_init => { foo => 'X=Av Y=Bv', bar => 'Y=Av Z=Cv' } When the hash contains leaves, you can also use: default_with_init => { def_1 => 'def_1 stuff', def_2 => 'def_2 stuff' } =item migrate_keys_from Specifies that the keys of the hash are copied from another hash in the configuration tree only when the hash is read for the first time after initial load (i.e. once the configuration files are completely read). migrate_keys_from => '- another_hash' =item migrate_values_from Specifies that the values of the hash (or list) are copied from another hash (or list) in the configuration tree only when the hash (or list) is read for the first time after initial load (i.e. once the configuration files are completely read). migrate_values_from => '- another_hash_or_list' =item follow_keys_from Specifies that the keys of the hash follow the keys of another hash in the configuration tree. In other words, the created hash always has the same keys as the other hash. follow_keys_from => '- another_hash' =item allow_keys Specifies authorized keys: allow_keys => ['foo','bar','baz'] =item allow_keys_from A bit like the C parameters. Except that the hash pointed to by C specified the authorized keys for this hash. allow_keys_from => '- another_hash' =item allow_keys_matching Keys must match the specified regular expression. For instance: allow_keys_matching => '^foo\d\d$' =item auto_create_keys When set, the default parameter (or set of parameters) are used as keys hashes and created automatically. (valid only for hash elements) Called with C<< auto_create_keys => ['foo'] >>, or C<< auto_create_keys => ['foo', 'bar'] >>. =item warn_if_key_match Issue a warning if the key matches the specified regular expression =item warn_unless_key_match Issue a warning unless the key matches the specified regular expression =item auto_create_ids Specifies the number of elements to create automatically. E.g. C<< auto_create_ids => 4 >> initializes the list with 4 undef elements. (valid only for list elements) =item convert => [uc | lc ] The hash key are converted to uppercase (uc) or lowercase (lc). =item warp See L below. =back =head1 Warp: dynamic value configuration The Warp functionality enables an L or L object to change its default settings (e.g. C, C or C parameters) dynamically according to the value of another C object. (See L for explanation on warp mechanism) For instance, with this model: $model ->create_config_class ( name => 'Root', 'element' => [ macro => { type => 'leaf', value_type => 'enum', name => 'macro', choice => [qw/A B C/], }, 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 => 'Dummy' } }, ] ); Setting C to C means that C can only accept one C class item . Setting C to C means that C accepts two C class items. Like other warped class, a HashId or ListId can have multiple warp masters (See L: warp => { follow => { m1 => '- macro1', m2 => '- macro2' }, rules => [ '$m1 eq "A" and $m2 eq "A2"' => { max_nb => 1}, '$m1 eq "A" and $m2 eq "B2"' => { max_nb => 2} ], } =head2 Warp and auto_create_ids or auto_create_keys When a warp is applied with C or C parameter, the auto_created items are created if they are not already present. But this warp never removes items that were previously auto created. For instance, when a tied hash is created with C<< auto_create => [a,b,c] >>, the hash contains C<(a,b,c)>. Then, once a warp with C<< auto_create_keys => [c,d,e] >> is applied, the hash then contains C<(a,b,c,d,e)>. The items created by the first auto_create_keys are not removed. =head2 Warp and max_nb When a warp is applied, the items that do not fit the constraint (e.g. min_index, max_index) are removed. For the max_nb constraint, an exception is raised if a warp leads to a number of items greater than the max_nb constraint. =head1 Content check By default, this class provides an optional content check that checks for duplicated values (when C parameter is set). Derived classes can register more global checker with the following method. =head2 add_check_content This method expects a sub ref with signature C<( $self, $error, $warn, $apply_fix )>. Where C<$error> and C<$warn> are array ref. You can push error or warning messages there. C<$apply_fix> is a boolean. When set to 1, the passed method can fix the warning or the error. Please make sure to weaken C<$self> to avoid memory cycles. Example: package MyId; use Mouse; extends qw/Config::Model::HashId/; use Scalar::Util qw/weaken/; sub setup { my $self = shift; weaken($self); $self-> add_check_content( sub { $self->check_usused_licenses(@_);} ) } =head1 Introspection methods The following methods returns the current value stored in the Id object (as declared in the model unless they were warped): =over =item min_index =item max_index =item max_nb =item index_type =item default_keys =item default_with_init =item follow_keys_from =item auto_create_ids =item auto_create_keys =item ordered =item morph =item config_model =back =head2 get_cargo_type Returns the object type contained by the hash or list (i.e. returns C<< cargo -> type >>). =head2 get_cargo_info Parameters: C<< ( < what > ) >> Returns more info on the cargo contained by the hash or list. C may be C or any other cargo info stored in the model. Returns undef if the requested info is not provided in the model. =head2 get_default_keys Returns a list (or a list ref) of the current default keys. These keys can be set by the C or C parameters or by the other hash pointed by C parameter. =head2 name Returns the object name. The name finishes with ' id'. =head2 config_class_name Returns the config_class_name of collected elements. Valid only for collection of nodes. This method returns undef if C C is not C. =head2 has_fixes Returns the number of fixes that can be applied to the current value. =head1 Information management =head2 fetch_with_id Parameters: C<< ( index => $idx , [ check => 'no' ]) >> Fetch the collected element held by the hash or list. Index check is 'yes' by default. Can be called with one parameter which is used as index. =head2 get Get a value from a directory like path. Parameters are: =over =item path Poor man's version of XPath style path. This string is in the form: /foo/bar/4 Each word between the '/' is either an element name or a hash key or a list index. =item mode Either C, C, C,... See C parameter in =item check Either C, C =item get_obj If the path leads to a leaf, this parameter tell whether to return the stored value or the value object. =item autoadd Whether to create missing keys =item dir_char_mockup When the hash key used contains '/', (for instance a directory value), the key cannot be used as is with this method. Because '/' is already used to separate configuration items (this is also important with L). This parameter specifies how the forbidden '/' char is shown in the path. Default is C<< >> =back =head2 set Parameters: C<( path, value )> Set a value with a directory like path. =head2 copy Parameters: C<( from_index, to_index )> Deep copy an element within the hash or list. If the element contained by the hash or list is a node, all configuration information is copied from one node to another. =head2 fetch_all Returns an array containing all elements held by the hash or list. =head2 fetch_value Parameters: C<< ( idx => ..., mode => ..., check => ...) >> Returns the value held by the C element of the hash or list. This method is only valid for hash or list containing leaves. See L for C argument documentation and L for C argument documentation. =head2 fetch_summary Arguments: C<< ( idx => ..., mode => ..., check => ...) >> Like L, but returns a truncated value when the value is a string or uniline that is too long to be displayed. =head2 fetch_all_values Parameters: C<< ( mode => ..., check => ...) >> Returns an array containing all defined values held by the hash or list. (undefined values are simply discarded). This method is only valid for hash or list containing leaves. With C parameter, this method returns either: =over =item custom The value entered by the user =item preset The value entered in preset mode =item standard The value entered in preset mode or checked by default. =item default The default value (defined by the configuration model) =back See L for C argument documentation. =head2 fetch Similar to L, with the same parameters, Returns the result as a string with comma separated list values. =head2 fetch_all_indexes Returns an array containing all indexes of the hash or list. Hash keys are sorted alphabetically, except for ordered hashed. =head2 children Like fetch_all_indexes. This method is polymorphic for all non-leaf objects of the configuration tree. =head2 defined Parameters: C<( index )> Returns true if the value held at C is defined. =head2 exists Parameters: C<( index )> Returns true if the value held at C exists (i.e the key exists but the value may be undefined). This method may not make sense for list element. =head2 has_data Return true if the array or hash is not empty. =head2 delete Parameters: C<( index )> Delete the Ced value =head2 clear Delete all values (also delete underlying value or node objects). =head2 clear_values Delete all values (without deleting underlying value objects). =head2 warning_msg Parameters: C<( [index] )> Returns warnings concerning indexes of this hash. Without parameter, returns a string containing all warnings or undef. With an index, return the warnings concerning this index or undef. =head2 has_warning Returns the current number of warning. =head2 error_msg Returns the error messages of this object (if any) =head1 AUTHOR Dominique Dumont, ddumont [AT] cpan [DOT] org =head1 SEE ALSO L, L, L, L, L, L, L, L =cut libconfig-model-perl-2.155/lib/Config/Model/AnyThing.pm000066400000000000000000000301411472064100600226110ustar00rootroot00000000000000package Config::Model::AnyThing; use Mouse; # FIXME: must cleanup warp mechanism to implement this # use MouseX::StrictConstructor; use Pod::POM; use Carp; use Log::Log4perl qw(get_logger :levels); use 5.10.1; my $logger = get_logger("Anything"); my $change_logger = get_logger("ChangeTracker"); has element_name => ( is => 'ro', isa => 'Str' ); has parent => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1 ); has instance => ( is => 'ro', isa => 'Config::Model::Instance', weak_ref => 1, handles => [qw/show_message root_path/] ); # needs_check defaults to 1 to trap undef mandatory values has needs_check => ( is => 'rw', isa => 'Bool', default => 1 ); # index_value can be written to when move method is called. But let's # not advertise this feature. has index_value => ( is => 'rw', isa => 'Str', trigger => sub { my $self = shift; $self->{location} = $self->_location; }, ); has container => ( is => 'ro', isa => 'Ref', required => 1, weak_ref => 1 ); has container_type => ( is => 'ro', isa => 'Str', builder => '_container_type', lazy => 1 ); sub _container_type { my $self = shift; my $p = $self->parent; return defined $p ? $p->element_type( $self->element_name ) : 'node'; # root node } has root => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1, builder => '_root', lazy => 1 ); sub _root { my $self = shift; return $self->parent || $self; } has location => ( is => 'ro', isa => 'Str', builder => '_location', lazy => 1 ); has location_short => ( is => 'ro', isa => 'Str', builder => '_location_short', lazy => 1 ); has backend_support_annotation => ( is => 'ro', isa => 'Bool', builder => '_backend_support_annotation', lazy => 1 ); sub _backend_support_annotation { my $self = shift; # this method is overridden in Config::Model::Node return $self->parent->backend_support_annotation; }; sub notify_change { my $self = shift; my %args = @_; return if $self->instance->initial_load and not $args{really}; if ($change_logger->is_trace) { my @with = map { "'$_' -> '". ($args{$_} // '') ."'" } sort keys %args; $change_logger->trace("called for ", $self->name, " from ", join( ' ', caller ), " with ", join( ' ', @with )); } # needs_save may be overridden by caller $args{needs_save} //= 1; $args{path} //= $self->location; $args{name} //= $self->element_name if $self->element_name; $args{index} //= $self->index_value if $self->index_value; # better use %args instead of @_ to forward arguments. %args eliminates duplicated keys $self->container->notify_change(%args); } sub _location { my $self = shift; my $str = ''; $str .= $self->parent->location if defined $self->parent; $str .= ' ' if $str; $str .= $self->composite_name; return $str; } sub _location_short { my $self = shift; my $str = ''; $str .= $self->parent->location_short if defined $self->parent; $str .= ' ' if $str; $str .= $self->composite_name_short; return $str; } #has composite_name => (is => 'ro', isa => 'Str' , builder => '_composite_name', lazy => 1); sub composite_name { my $self = shift; my $element = $self->element_name; $element = '' unless defined $element; my $idx = $self->index_value; return $element unless defined $idx; $idx = '"' . $idx . '"' if $idx =~ /\W/; return "$element:$idx"; } sub composite_name_short { my $self = shift; my $element = $self->element_name; $element = '' unless defined $element; my $idx = $self->shorten_idx($self->index_value); return $element unless length $idx; $idx = '"' . $idx . '"' if $idx =~ /\W/; return "$element:$idx"; } sub shorten_idx { my $self = shift; my $long_index = shift ; my @idx = split /\n/, $long_index // '' ; my $idx = shift @idx; $idx .= '[...]' if @idx; return $idx // ''; # may be undef on freebsd with perl 5.10.1 ... } ## Fixme: not yet tested sub xpath { my $self = shift; $logger->trace("xpath called on $self"); my $element = $self->element_name; $element = '' unless defined $element; my $idx = $self->index_value; my $str = ''; $str .= $self->cim_parent->parent->xpath if $self->can('cim_parent') and defined $self->cim_parent; $str .= '/' . $element . ( defined $idx ? "[\@id=$idx]" : '' ) if $element; return $str; } sub annotation { my $self = shift; my $old_note = $self->{annotation} || ''; if (@_ and not $self->instance->preset and not $self->instance->layered) { my $new = $self->{annotation} = join( "\n", grep { defined $_} @_ ); $self->notify_change(note => 'updated annotation') unless $new eq $old_note; } return $self->{annotation} || ''; } sub clear_annotation { my $self = shift; $self->notify_change(note => 'deleted annotation') if $self->{annotation}; $self->{annotation} = ''; } # may be used (but not yet) to load annotation from perl data file sub load_pod_annotation { my $self = shift; my $pod = shift; my $parser = Pod::POM->new(); my $pom = $parser->parse_text($pod) || croak $parser->error(); my $sections = $pom->head1(); foreach my $s (@$sections) { next unless $s->title eq 'Annotations'; foreach my $item ( $s->over->[0]->item ) { my $path = $item->title . ''; # force string representation. Not understood why... $path =~ s/^[\s\*]+//; my $note = $item->text . ''; $note =~ s/\s+$//; $logger->trace("load_pod_annotation: '$path' -> '$note'"); $self->grab( steps => $path )->annotation($note); } } } # fallback method for object that don't implement has_data sub has_data { my $self= shift; $logger->trace("called fall-back has_data for element", $self->name) if $logger->is_trace; return 1; } sub model_searcher { my $self = shift; my %args = @_; my $model = $self->instance->config_model; return Config::Model::SearchElement->new( model => $model, node => $self, %args ); } sub searcher { carp "Config::Model::AnyThing searcher is deprecated"; goto &model_searcher; } sub dump_as_data { my $self = shift; my %args = @_; my $full = delete $args{full_dump} || 0; if ($full) { carp "dump_as_data: full_dump parameter is deprecated. Please use 'mode => user' instead"; $args{mode} //= 'user'; } my $dumper = Config::Model::DumpAsData->new; $dumper->dump_as_data( node => $self, %args ); } # hum, check if the check information is valid sub _check_check { my $self = shift; my $p = shift; return 'yes' if not defined $p or $p eq '1' or $p eq 'yes'; return 'no' if $p eq '0' or $p eq 'no'; return $p if $p eq 'skip'; croak "Internal error: Unvalid check value: $p"; } sub has_fixes { my $self = shift; $logger->trace( "dummy has_fixes called on " . $self->name ); return 0; } sub has_warning { my $self = shift; $logger->trace( "dummy has_warning called on " . $self->name ); return 0; } sub warp_error { my $self = shift; return '' unless defined $self->{warper}; return $self->{warper}->warp_error; } # used by Value and AnyId sub set_convert { my ( $self, $arg_ref ) = @_; my $convert = delete $arg_ref->{convert}; # convert_sub keeps a subroutine reference $self->{convert_sub} = $convert eq 'uc' ? sub { uc(shift) } : $convert eq 'lc' ? sub { lc(shift) } : undef; Config::Model::Exception::Model->throw( object => $self, error => "Unexpected convert value: $convert, " . "expected lc or uc" ) unless defined $self->{convert_sub}; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Base class for configuration tree item __END__ =head1 SYNOPSIS # internal class =head1 DESCRIPTION This class must be inherited by all nodes or leaves of the configuration tree. AnyThing provides some methods and no constructor. =head1 Introspection methods =head2 element_name Returns the element name that contain this object. =head2 index_value For object stored in an array or hash element, returns the index (or key) containing this object. =head2 parent Returns the node containing this object. May return undef if C is called on the root of the tree. =head2 container A bit like parent, this method returns the element containing this object. See L =head2 container_type Returns the type (e.g. C or C or C or C or C) of the element containing this object. =head2 root Returns the root node of the configuration tree. =head2 location Returns the node location in the configuration tree. This location conforms with the syntax defined by L method. =head2 location_short Returns the node location in the configuration tree. This location truncates long indexes to be readable. It cannot be used by L method. =head2 composite_name Return the element name with its index (if any). I.e. returns C or C. =head2 composite_name_short Return the element name with its index (if any). Too long indexes are truncated to be readable. =head1 Annotation Annotation is a way to store miscellaneous information associated to each node. (Yeah... comments). Reading and writing annotation makes sense only if they can be read from and written to the configuration file, hence the need for the following method: =head2 backend_support_annotation Returns 1 if at least one of the backends attached to a parent node support to read and write annotations (aka comments) in the configuration file. =head2 support_annotation Returns 1 if at least one of the backends support to read and write annotations (aka comments) in the configuration file. =head2 annotation Parameters: C<( [ note1, [ note2 , ... ] ] )> Without argument, return a string containing the object's annotation (or an empty string). With several arguments, join the arguments with "\n", store the annotations and return the resulting string. =head2 load_pod_annotation Parameters: C<( pod_string )> Load annotations in configuration tree from a pod document. The pod must be in the form: =over =item path Annotation text =back =head2 clear_annotation Clear the annotation of an element =head1 Information management =head2 notify_change Notify the instance of semantic changes. Parameters are: =over 8 =item old old value. (optional) =item new new value (optional) =item path Location of the changed parameter starting from root node. Default to C<$self->location>. =item name element name. Default to C<$self->element_name> =item index If the changed parameter is part of a hash or an array, C contains the key or the index to get the changed parameter. =item note information about the change. Mandatory when neither old or new value are defined. =item really When set to 1, force recording of change even if in initial load phase. =item needs_save internal parameter. =back =head2 show_message Parameters: C<( string )> Forwarded to L. =head2 root_path Forwarded to L. =head2 model_searcher Returns an object dedicated to search an element in the configuration model. This method returns a L object. See L for details on how to handle a search. =head2 dump_as_data Dumps the configuration data of the node and its siblings into a perl data structure. Returns a hash ref containing the data. See L for details. =head2 warp_error Returns a string describing any issue with L object. Returns '' if invoked on a tree object without warp specification. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L =cut libconfig-model-perl-2.155/lib/Config/Model/Backend/000077500000000000000000000000001472064100600220625ustar00rootroot00000000000000libconfig-model-perl-2.155/lib/Config/Model/Backend/Any.pm000066400000000000000000000336111472064100600231530ustar00rootroot00000000000000package Config::Model::Backend::Any; use v5.20; use Carp; use Config::Model::Exception; use Mouse; use File::Path; use Log::Log4perl qw(get_logger :levels); use feature qw/postderef signatures/; no warnings qw/experimental::postderef experimental::signatures/; my $logger = get_logger("Backend"); has 'name' => ( is => 'ro', default => 'unknown', ); has [qw/annotation auto_create auto_delete/] => ( is => 'ro', isa => 'Bool', default => 0 ); has 'node' => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1, required => 1, handles => [ qw/show_message instance get_element_names/], ); sub skip_open { return 0; } sub read { my $self = shift; my $err = "Internal error: read not defined in backend $self->{name}."; $logger->error($err); croak $err; } sub write { my $self = shift; my $err = "Internal error: write not defined in backend $self->{name}."; $logger->error($err); croak $err; } sub read_global_comments { my $self = shift; my $lines = shift; my $cc = shift; # comment character(s) my $cc_re = length $cc > 1 ? "[$cc]" : $cc; my @global_comments; my @global_comment_lines; while ( defined( my $l = shift @$lines ) ) { next if $l =~ /^$cc_re{2}/; # remove comments added by Config::Model unshift @$lines, $l; last; } while ( defined( my $l = shift @$lines ) ) { next if $l =~ /^\s*$/; # remove empty lines unshift @$lines, $l; last; } while ( defined( my $l = shift @$lines ) ) { chomp $l; my ( $data, $comment ) = split /\s*$cc_re\s?/, $l, 2; if (defined $comment) { push @global_comment_lines, $l; push @global_comments, $comment; } if ( $l =~ /^\s*$/ ) { # we indeed had global comments which are now finished by # a blank line. Store them and bail out if (@global_comments) { $self->node->annotation(@global_comments); $logger->debug("Setting global comment with @global_comments on ", $self->node->name); } # stop global comment at first blank line last; } if ( $data ) { # The comment found is not global, put back line and any captured comment unshift @$lines, @global_comment_lines, $l; # stop global comment last; } } } sub associates_comments_with_data { my $self = shift; my $lines = shift; my $cc = shift; # comment character(s) my $cc_re = length $cc > 1 ? "[$cc]" : $cc; my @result; my @comments; foreach my $l (@$lines) { next if $l =~ /^$cc_re{2}/; # remove comments added by Config::Model chomp $l; my ( $data, $comment ) = split /\s*$cc_re\s?/, $l, 2; push @comments, $comment if defined $comment; next unless defined $data; $data =~ s/^\s+//g; $data =~ s/\s+$//g; if ($data) { my $note = ''; $note = join( "\n", @comments ) if @comments; $logger->trace("associates_comments_with_data: '$note' with '$data'"); push @result, [ $data, $note ]; @comments = (); } } return wantarray ? @result : \@result; } sub write_global_comment { goto &write_global_comments; } sub write_global_comments ($self, $cc) { croak "write_global_comments: no comment char specified" unless $cc; # no need to mention 'cme list' if current application is found my $app = $self->node->instance->application ; my $extra = '' ; if (not $app) { $extra = "$cc$cc Run 'cme list' to get the list of applications" . " available on your system\n"; $app = ''; } my $res = "$cc$cc This file was written by cme command.\n" . "$cc$cc You can run 'cme edit $app' to modify this file.\n" . $extra . "$cc$cc You may also modify the content of this file with your favorite editor.\n\n"; # write global comment my $global_note = $self->node->annotation; if ($global_note) { for ( split /\n/, $global_note ) { $res .= "$cc $_\n" } $res .= "\n"; } return $res; } # $cc can be undef when writing a list on a single line sub write_data_and_comments ( $self, $cc, @data_and_comments ) { my $res = ''; while (@data_and_comments) { my ( $d, $c ) = splice @data_and_comments, 0, 2; if ($c) { for (split /\n/, $c ) { $res .= "$cc $_\n" } } $res .= "$d\n" if defined $d; } return $res; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Virtual class for other backends __END__ =head1 SYNOPSIS package Config::Model::Backend::Foo ; use Mouse ; extends 'Config::Model::Backend::Any'; # mandatory sub read { my $self = shift ; my %args = @_ ; # args are: # root => './my_test', # fake root directory, used for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => Path::Tiny object for './my_test/etc/foo/foo.conf' # check => yes|no|skip return 0 unless $args{file_path}->exists ; # or die, your choice # read the file line by line # we assume the file contain lines like 'key=value' foreach ($args{file_path}->lines_utf8) { chomp ; # remove trailing \n s/#.*// ; # remove any comment next unless /\S/; # skip blank line # $data is 'foo=bar' which is compatible with load $self->node->load(steps => $_, check => $args{check} ) ; } return 1 ; } # mandatory sub write { my $self = shift ; my %args = @_ ; # args are: # root => './my_test', # fake root directory, used for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => Path::Tiny object for './my_test/etc/foo/foo.conf' # check => yes|no|skip # read the content of the configuration tree my @lines; foreach my $elt ($self->node->children) { # read the value from element $elt my $v = $self->node->grab_value($elt) ; # write value in file push @lines,qq!$elt="$v"\n! if defined $v ; } $args{file_path}->spew_utf8(@lines); return 1; } =head1 DESCRIPTION Some application have configuration files with a syntax which is not supported by existing C classes. In this case a new backend must be written. C was created to facilitate this task. The new backend class must use L and must extends (inherit) C. =head1 How to write your own backend =head2 Declare the new backend in a node of the model As explained in L, the new backend must be declared as an attribute of a L specification. Let's say your new backend is C. This new backend can be specified with: rw_config => { backend => 'Foo' , # can also be 'foo' config_dir => '/etc/cfg_dir' file => 'foo.conf', # optional } (The backend class name is constructed with C) C can also have custom parameters that are passed verbatim to C methods: rw_config => { backend => 'Foo' , # can also be 'foo' config_dir => '/etc/cfg_dir' file => 'foo.conf', # optional my_param => 'my_value', } C class must inherit (extend) L and is expected to provide the following methods: =over =item read C is called with the following parameters: %custom_parameters, # e.g. my_param => 'my_value' in the example above object => $obj, # Config::Model::Node object root => $root_dir, # fake root directory, used for tests backend => $backend, # backend name config_dir => $read_dir, # path below root file => 'foo.conf', # file name file_path => $full_name, # Path::Tiny object check => [yes|no|skip] The L object is undef if the file cannot be read. This method must return 1 if the read was successful, 0 otherwise. Following the C example above, C<%custom_parameters> contains C< ( 'my_param' , 'my_value' ) >, so C is called with C, C, C B C<< my_param => 'my_value' >>. =item write C is called with the following parameters: %$custom_parameters, # e.g. my_param => 'my_value' in the example above object => $obj, # Config::Model::Node object root => $root_dir, # fake root directory, used for tests auto_create => $auto_create, # boolean specified in backend declaration auto_delete => $auto_delete, # boolean specified in backend declaration backend => $backend, # backend name config_dir => $write_dir, # override from instance file => 'foo.conf', # file name file_path => $full_name, # full file name (root+path+file) write => 1, # always check => [ yes|no|skip] , backup => [ undef || '' || suffix ] # backup strategy required by user The L object is undef if the file cannot be written to. This method must return 1 if the write was successful, 0 otherwise =back =head2 How to test your new backend Using L, you can test your model with your backend following the instructions given in L. You can also test your backend with a minimal model (and L). In this case, you need to specify a small model to test in a C<*-test-conf.pl> file. See the L for an example and its L. =head1 CONSTRUCTOR =head2 new The constructor should be used only by L. Parameter: =over =item node Calling node object. Node ref is weakened, =item name Backend name =item auto_create Boolean. Set to true to create the configuration file if this one is missing (default 0) =item auto_delete Boolean. Set to true to remove the configuration file if this one no longer contain configuration information. (default 0) =back =head1 Methods to override =head2 annotation Whether the backend supports reading and writing annotation (a.k.a comments). Default is 0. Override this method to return 1 if your backend supports annotations. =head2 read Read the configuration file. This method must be overridden. =head2 write Write the configuration file. This method must be overridden. =head1 Methods =head2 node Return the node (a L) holding this backend. =head2 instance Return the instance (a L) holding this configuration. =head2 show_message Parameters: C<( string )> Show a message to STDOUT (unless overridden). Delegated to L. =head2 read_global_comments Parameters: =over =item * array ref of string containing the lines to be parsed =item * A string to specify how a comment is started. Each character is recognized as a comment starter (e.g 'C<#;>' allow a comment to begin with 'C<#>' or 'C<;>') =back Read the global comments (i.e. the first block of comments until the first blank or non comment line) and store them as root node annotation. Note that the global comment must be separated from the first data line by a blank line. Example: $self->read_global_comments( \@lines, ';'); $self->read_global_comments( \@lines, '#;'); =head2 associates_comments_with_data Parameters: =over =item * array ref of string containing the lines to be parsed =item * A string to specify how a comment is started. Each character is recognized as a comment starter (e.g 'C<#;>' allow a comment to begin with 'C<#>' or 'C<;>') =back This method extracts comments from the passed lines and associate them with actual data found in the file lines. Data is associated with comments preceding or on the same line as the data. Returns a list of [ data, comment ]. Example: my @lines = ( '# Foo comments', 'foo= 1', 'Baz = 0 # Baz comments' ); my @res = $self->associates_comments_with_data( \@lines, '#') # @res is: # ( [ 'foo= 1', 'Foo comments' ] , [ 'Baz = 0' , 'Baz comments' ] ) =head2 write_global_comments Return a string containing global comments using data from configuration root annotation. Requires one parameter: comment_char (e.g "#" or '//' ) Example: my $str = $self->write_global_comments('#') =head2 write_data_and_comments Returns a string containing comments (stored in annotation) and corresponding data. Comments are written before the data. If a data is undef, the comment is written on its own line. Positional parameters are C<( comment_char , data1, comment1, data2, comment2 ...)> Example: print $self->write_data_and_comments('#', 'foo', 'foo comment', undef, 'lone comment','bar') # returns "# foo comment\nfoo\n#lon Use C as comment char if comments are not supported by the syntax of the configuration file. Comments will then be dropped. =head1 Replacing a custom backend Custom backend are now deprecated and must be replaced with a class inheriting this module. Please: =over =item * Rename your class to begin with C =item * Add C and C in the header of your custom class. =item * Add C as the beginning of C and C functions... well... methods. =back Here's an L. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =cut libconfig-model-perl-2.155/lib/Config/Model/Backend/CdsFile.pm000066400000000000000000000072621472064100600237400ustar00rootroot00000000000000package Config::Model::Backend::CdsFile; use 5.10.1; use Carp; use strict; use warnings; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); use base qw/Config::Model::Backend::Any/; my $logger = get_logger("Backend::CdsFile"); sub read { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $file_path = $args{file_path}; return 0 unless $file_path->exists; $logger->info("Read cds data from $file_path"); $self->node->load( step => $file_path->slurp_utf8 ); return 1; } sub write { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $file_path = $args{file_path}; $logger->info("Write cds data to $file_path"); my $dump = $self->node->dump_tree( skip_auto_write => 'cds_file', check => $args{check} ); $file_path->spew_utf8($dump); return 1; } 1; # ABSTRACT: Read and write config as a Cds data structure __END__ =head1 SYNOPSIS use Config::Model ; use Data::Dumper ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], rw_config => { backend => 'cds_file' , config_dir => '/tmp', file => 'foo.pl', auto_create => 1, } ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; my $steps = 'foo=yada bar="bla bla" baz:en=hello baz:fr=bonjour baz:hr="dobar dan"'; $root->load( steps => $steps ) ; $inst->write_back ; Now, C contains: { bar => 'bla bla', baz => { en => 'hello', fr => 'bonjour', hr => 'dobar dan' }, foo => 'yada' } =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written with Cds syntax in C configuration tree. Note: =over 4 =item * Undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the data structure contains C<'a','b'>. =item * Cds file is not created (and may be deleted) when no data is to be written. =back =head1 backend parameter =head2 config_dir Mandoatory parameter to specify where is the Cds configuration file. =head1 CONSTRUCTOR =head2 new Inherited from L. The constructor is called by L. =head2 read Of all parameters passed to this read call-back, only C is used. It can also be undef. In which case C returns 0. When a file is read, C returns 1. =head2 write Of all parameters passed to this write call-back, only C is used. C returns 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =cut libconfig-model-perl-2.155/lib/Config/Model/Backend/Fstab.pm000066400000000000000000000126571472064100600234720ustar00rootroot00000000000000package Config::Model::Backend::Fstab; use Mouse; use Carp; use Log::Log4perl qw(get_logger :levels); extends 'Config::Model::Backend::Any'; my $logger = get_logger("Backend::Fstab"); sub annotation { return 1; } my %opt_r_translate = ( ro => 'rw=0', rw => 'rw=1', bsddf => 'statfs_behavior=bsddf', minixdf => 'statfs_behavior=minixdf', ); sub read { my $self = shift; my %args = @_; # args are: # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip return 0 unless $args{file_path}->exists; # no file to read my $check = $args{check} || 'yes'; my @lines = $args{file_path}->lines_utf8; # try to get global comments (comments before a blank line) $self->read_global_comments( \@lines, '#' ); my @assoc = $self->associates_comments_with_data( \@lines, '#' ); foreach my $item (@assoc) { my ( $data, $comment ) = @$item; $logger->trace("fstab read data '$data' comment '$comment'"); my ( $device, $mount_point, $type, $options, $dump, $pass ) = split /\s+/, $data; my $swap_idx = 0; my $label = $device =~ /LABEL=(\w+)$/ ? $1 : $type eq 'swap' ? "swap-" . $swap_idx++ : $mount_point; my $fs_obj = $self->node->fetch_element('fs')->fetch_with_id($label); if ($comment) { $logger->trace("Annotation: $comment\n"); $fs_obj->annotation($comment); } my $load_line = "fs_vfstype=$type fs_spec=$device fs_file=$mount_point " . "fs_freq=$dump fs_passno=$pass"; $logger->debug("Loading:$load_line\n"); $fs_obj->load( step => $load_line, check => $check ); # now load fs options $logger->trace("fs_type $type options is $options"); my @options; foreach ( split /,/, $options ) { my $o = $opt_r_translate{$_} // $_; $o =~ s/no(.*)/$1=0/; $o .= '=1' unless $o =~ /=/; push @options, $o; } $logger->debug("Loading:@options"); $fs_obj->fetch_element('fs_mntopts')->load( step => "@options", check => $check ); } return 1; } sub write { my $self = shift; my %args = @_; # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $node = $args{object}; croak "Undefined file handle to write" unless defined $args{file_path}; my $res = $self->write_global_comment( '#' ); # Using Config::Model::ObjTreeScanner would be overkill foreach my $line_obj ( $node->fetch_element('fs')->fetch_all ) { my $d = sprintf( "%-30s %-25s %-6s %-10s %d %d\n", (map { $line_obj->fetch_element_value($_); } qw/fs_spec fs_file fs_vfstype/), $self->option_string( $line_obj->fetch_element('fs_mntopts') ), (map { $line_obj->fetch_element_value($_); } qw/fs_freq fs_passno/), ); $res .= $self->write_data_and_comments( '#', $d, $line_obj->annotation ); } $args{file_path}->spew_utf8($res); return 1; } my %rev_opt_r_translate = reverse %opt_r_translate; sub option_string { my ( $self, $obj ) = @_; my @options; foreach my $opt ( $obj->get_element_name ) { my $v = $obj->fetch_element_value($opt); next unless defined $v; my $key = "$opt=$v"; my $str = defined $rev_opt_r_translate{$key} ? $rev_opt_r_translate{$key} : "$v" eq '0' ? 'no' . $opt : "$v" eq '1' ? $opt : $key; push @options, $str; } return join ',', @options; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config from fstab file __END__ =head1 SYNOPSIS No synopsis. This class is dedicated to configuration class C =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written with C syntax in C configuration tree. Typically this backend is used to read and write C. =head1 Comments in file_path This backend is able to read and write comments in the C file. =head1 STOP The documentation below describes methods that are currently used only by L. You don't need to read it to write a model. =head1 CONSTRUCTOR =head2 new Parameters: C<< ( node => $node_obj, name => 'fstab' ) >> Inherited from L. The constructor is called by L. =head2 read Of all parameters passed to this read call-back, only C is used. This parameter must be a L object. When a file is read, C returns 1. =head2 write Of all parameters passed to this write call-back, only C is used. C returns 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =cut libconfig-model-perl-2.155/lib/Config/Model/Backend/IniFile.pm000066400000000000000000000533461472064100600237520ustar00rootroot00000000000000package Config::Model::Backend::IniFile; use Carp; use Mouse; use 5.10.0; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); use base qw/Config::Model::Backend::Any/; use feature qw/postderef signatures/; no warnings qw/experimental::postderef experimental::signatures/; # change inherited attribute. See Moose::Manual::Attributes has '+node' => ( handles => ['load_data'], ); my $logger = get_logger("Backend::IniFile"); sub annotation { return 1; } ## no critic (Subroutines::ProhibitBuiltinHomonyms) sub read ($self, %args) { # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip return 0 unless $args{file_path}->exists; # no file to read my $section = ''; # dumb value used for logging my $delimiter = $args{comment_delimiter} || '#'; my $hash_class = $args{store_class_in_hash} || ''; my $section_map = $args{section_map} || {}; my $split_reg = $args{split_list_value}; my $check = $args{check} || 'yes'; my $assign_char = $args{assign_char} || '='; my $quote_value = $args{quote_value} || ''; my $obj = $self->node; my %force_lc; map { $force_lc{$_} = $args{"force_lc_$_"} ? 1 : 0; } qw/section key value/; #FIXME: Is it possible to store the comments with their location #in the file? It would be nice if comments that are after values #in input file, would be written in the same way in the output #file. Also, comments at the end of file are being ignored now. my @lines = $args{file_path}->lines_utf8; # try to get global comments (comments before a blank line) $self->read_global_comments( \@lines, $delimiter ); my @assoc = $self->associates_comments_with_data( \@lines, $delimiter ); # store INI data in a structure: # { # name => value leaf # name => [ value ] list # name => { key => value , ... } hash # name => { ... } node # name => [ { ... }, ... ] list of nodes # name => { key => { ... } , ... } hash of nodes # } my $ini_data = {}; my %ini_comment; my $section_ref = $ini_data; my $section_path = ''; foreach my $item (@assoc) { my ( $vdata, $comment ) = @$item; $logger->debug("ini read: reading '$vdata'"); my $comment_path; # Update section name if ( $vdata =~ /^\s*\[(.*)\]/ ) { $section = $force_lc{section} ? lc($1) : $1; my $remap = $section_map->{$section} || ''; if ( $remap eq '!' ) { # section_map maps section to root node $section_ref = $ini_data; $comment_path = $section_path = ''; $logger->debug("step 1: found node [$section]"); } elsif ($remap) { # section_map maps section to some node $section_ref = {}; $logger->debug("step 1: found node $remap [$section]"); $section_path = $comment_path = $self->set_or_push( $ini_data, $remap, $section_ref ); } elsif ($hash_class) { $ini_data->{$hash_class}{$section} = $section_ref = {}; $comment_path = $section_path = "$hash_class:$section"; $logger->debug("step 1: found node $hash_class and path $comment_path [$section]"); } else { $section_ref = {}; $logger->debug("step 1: found node $section [$section]"); $section_path = $comment_path = $self->set_or_push( $ini_data, $section, $section_ref ); } # for write later, need to store the obj if section map was used if ( defined $section_map->{$section} ) { $logger->debug("store section_map loc '$section_path' section '$section'"); $self->{reverse_section_map}{$section_path} = $section; } } else { my ( $name, $val ) = split( /\s*$assign_char\s*/, $vdata, 2 ); $name = lc($name) if $force_lc{key}; $val = lc($val) if $force_lc{value}; $val =~ s/"([^"]*)"/$1/g if $quote_value eq "shell_style"; $comment_path = $section_path . ' ' . $self->set_or_push( $section_ref, $name, $val ); $logger->debug("step 1: found node $comment_path name $name in [$section]"); } $ini_comment{$comment_path} = $comment if $comment; } my @load_args = ( data => $ini_data, check => $check ); push @load_args, split_reg => qr/$split_reg/ if $split_reg; $self->load_data(@load_args); while ( my ( $k, $v ) = each %ini_comment ) { my $item = $obj->grab( step => $k, mode => 'loose' ) or next; $item = $item->fetch_with_id(0) if $item->get_type eq 'list'; $logger->debug("annotate '$v' on ", $item->location); $item->annotation($v); } return 1; } sub set_or_push { my ( $self, $ref, $name, $val ) = @_; my $cell = $ref->{$name}; my $path; if ( defined $cell and ref($cell) eq 'ARRAY' ) { push @$cell, $val; $path = $name . ':' . $#$cell; } elsif ( defined $cell ) { $ref->{$name} = [ $cell, $val ]; $path = $name . ':1'; } else { $ref->{$name} = $val; $path = $name; # no way to distinguish between leaf and first value of list } return $path; } ## no critic (Subroutines::ProhibitBuiltinHomonyms) sub write ($self, %args) { # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $node = $args{object}; my $delimiter = $args{comment_delimiter} || '#'; croak "Undefined file handle to write" unless defined $args{file_path}; # use the first char of the list as a comment delimeter my $cc = substr($delimiter,0,1); $args{comment_delimiter} = $cc; my $res = ''; # some INI file have a 'General' section mapped in root node my $top_class_name = $self->{reverse_section_map}{''}; if ( defined $top_class_name ) { $logger->debug("writing class $top_class_name from reverse_section_map"); $res .= $self->write_data_and_comments( $cc, "[$top_class_name]" ); } $res .= $self->_write(%args); if ($res) { $args{file_path}->spew_utf8($self->write_global_comment( $cc ) . $res); } elsif ($self->auto_delete) { $args{file_path}->remove; } return; } sub _write_list{ my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $join_list = $args->{join_list_value}; my $delimiter = $args->{comment_delimiter} || '#'; my $assign_with = $args->{assign_with} // $args->{assign_char} // ' = '; my $list_obj = $node->fetch_element($elt); my $list_obj_note = $list_obj->annotation; if ( $join_list ) { my @v = grep { length } $list_obj->fetch_all_values(); my $v = join( $join_list, @v ); if ( length($v) ) { $logger->debug("writing joined list elt $elt -> $v"); $res .= $self->write_data_and_comments( $delimiter, "$elt$assign_with$v", $list_obj_note ); } } else { foreach my $obj ( $list_obj->fetch_all('custom') ) { my $note = $obj->annotation; my $v = $self->_fetch_obj_value($args, $obj); if ( length $v ) { $logger->debug("writing list elt $elt -> $v"); $res .= $self->write_data_and_comments( $delimiter, "$elt$assign_with$v", $list_obj_note . $note ); } else { $logger->trace("NOT writing undef or empty list elt"); } } } return $res; } sub _write_check_list{ my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $join_check_list = $args->{join_check_list_value}; my $delimiter = $args->{comment_delimiter} || '#'; my $assign_with = $args->{assign_with} // $args->{assign_char} // ' = '; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; if ($join_check_list ) { my $v = join( $join_check_list, $obj->get_checked_list() ); if ( length($v) ) { $logger->debug("writing check_list elt $elt -> $v"); $res .= $self->write_data_and_comments( $delimiter, "$elt$assign_with$v", $obj_note ); } } else { foreach my $v ( $obj->get_checked_list() ) { $logger->debug("writing joined check_list elt $elt -> $v"); $res .= $self->write_data_and_comments( $delimiter, "$elt$assign_with$v", $obj_note ); } } return $res; } sub _fetch_obj_value { my ($self, $args, $obj) = @_ ; my $v = $obj->fetch; if ( defined $args->{quote_value} and $args->{quote_value} eq 'shell_style' and defined $v and $v =~ /\s/ ) { $v = qq!"$v"!; } return $v; } sub _write_leaf { my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $write_bool_as = $args->{write_boolean_as}; my $delimiter = $args->{comment_delimiter} || '#'; my $assign_with = $args->{assign_with} // $args->{assign_char} // ' = '; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; my $v = $self->_fetch_obj_value($args, $obj); if ( $write_bool_as and defined($v) and length($v) and $obj->value_type eq 'boolean' ) { $v = $write_bool_as->[$v]; } if ( defined $v and length $v ) { $logger->debug("writing leaf elt $elt -> $v"); $res .= $self->write_data_and_comments( $delimiter, "$elt$assign_with$v", $obj_note ); } else { $logger->trace("NOT writing undef or empty leaf elt"); } return $res; } sub _write_hash { my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $delimiter = $args->{comment_delimiter} || '#'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; foreach my $key ( $obj->fetch_all_indexes ) { my $hash_obj = $obj->fetch_with_id($key); my $note = $hash_obj->annotation; $logger->debug("writing hash elt $elt key $key"); my $subres = $self->_write( %$args, object => $hash_obj ); if ($subres) { $res .= "\n" . $self->write_data_and_comments( $delimiter, "[$key]", $obj_note . $note ) . $subres; } } return $res; } sub _write_node { my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $delimiter = $args->{comment_delimiter} || '#'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; $logger->debug("writing class $elt"); my $subres = $self->_write( %$args, object => $obj ); if ($subres) { # some INI file may have a section mapped to a node as exception to mapped in a hash my $exception_name = $self->{reverse_section_map}{ $obj->location }; if ( defined $exception_name ) { $logger->debug("writing class $exception_name from reverse_section_map"); } my $c_name = $exception_name || $elt; $res .= "\n" . $self->write_data_and_comments( $delimiter, "[$c_name]", $obj_note ) . $subres; } return $res; } sub _write ($self, %args) { my $node = $args{object}; my $delimiter = $args{comment_delimiter} || '#'; $logger->trace( "called on ", $node->name ); my $res = ''; # Using Config::Model::ObjTreeScanner would be overkill # first write list and element, then classes foreach my $elt ( $node->get_element_name ) { my $type = $node->element_type($elt); $logger->trace("first loop on elt $elt type $type"); next if $type =~ /node/ or $type eq 'hash'; if ( $type eq 'list' ) { $res .= $self->_write_list (\%args, $node, $elt) ; } elsif ( $type eq 'check_list') { $res .= $self->_write_check_list (\%args, $node, $elt) ; } elsif ( $type eq 'leaf' ) { $res .= $self->_write_leaf (\%args, $node, $elt) ; } else { Config::Model::Exception::Model->throw( error => "unexpected type $type for leaf elt $elt", object => $node ); } } foreach my $elt ( $node->get_element_name ) { my $type = $node->element_type($elt); $logger->trace("second loop on elt $elt type $type"); next unless $type =~ /node/ or $type eq 'hash'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; if ( $type eq 'hash' ) { $res .= $self->_write_hash (\%args, $node, $elt) ; } else { $res .= $self->_write_node (\%args, $node, $elt) ; } } $logger->trace( "done on ", $node->name ); return $res; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config as a INI file __END__ =head1 SYNOPSIS use Config::Model; my $model = Config::Model->new; $model->create_config_class ( name => "IniClass", element => [ [qw/foo bar/] => { type => 'list', cargo => {qw/type leaf value_type string/} } ] ); # model for free INI class name and constrained class parameters $model->create_config_class( name => "MyClass", element => [ ini_class => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'IniClass' }, }, ], rw_config => { backend => 'IniFile', config_dir => '/tmp', file => 'foo.conf', store_class_in_hash => 'ini_class', auto_create => 1, } ); my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; $root->load('ini_class:ONE foo=FOO1 bar=BAR1 - ini_class:TWO foo=FOO2' ); $inst->write_back ; Now C contains: ## file written by Config::Model [ONE] foo=FOO1 bar=BAR1 [TWO] foo=FOO2 =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written with INI syntax in C configuration tree. This INI file can have arbitrary comment delimiter. See the example in the SYNOPSIS that sets a semi-column as comment delimiter. By default the comment delimiter is '#' like in Shell or Perl. Note that undefined values are skipped for list element. I.e. when a list element contains C<('a',undef,'b')>, the data structure contains C<'a','b'>. =head1 Limitations =head2 Structure Structure of the Config::Model must be very simple. Either: =over =item * A single class with hash of leaves elements. =item * 2 levels of classes. The top level has nodes elements. All other classes have only leaf elements. =back =head1 Comments in Ini file This backend tries to read and write comments from configuration file. The comments are stored as annotation within the configuration tree. Comments extraction is based on best estimation as to which parameter the comment may apply. Wrong estimations are possible. =head1 CONSTRUCTOR =head2 new Parameters: C<< ( node => $node_obj, name => 'inifile' ) >> Inherited from L. The constructor is called by L. =head1 Parameters Optional parameters declared in the model: =head2 comment_delimiter Change the character that starts comments in the INI file. Default is 'C<#>'. Some Ini files allows comments to begin with several characters (e.g. C<#> or C<;>). In this case, set C to the possible characters (e.g "C<#;>"). The first character is used to write back comments. (In the example above, comment C<; blah> is written back as C<# blah>. =head2 store_class_in_hash See L =head2 section_map Is a kind of exception of the above rule. See also L =head2 force_lc_section Boolean. When set, sections names are converted to lowercase. =head2 force_lc_key Idem for key name =head2 force_lc_value Idem for all values. =head2 split_list_value Some INI values are in fact a list of items separated by a space or a comma. This parameter specifies the regex to use to split the value into a list. This applies only to C elements. =head2 join_list_value Conversely, the list element split with C needs to be written back with a string to join them. Specify this string (usually ' ' or ', ') with C. =head2 split_check_list_value Some INI values are in fact a check list of items separated by a space or a comma. This parameter specifies the regex to use to split the value read from the file into a list of items to check. This applies only to C elements. =head2 join_check_list_value Conversely, the check_list element split with C needs to be written back with a string to join them. Specify this string (usually ' ' or ', ') with C. =head2 write_boolean_as Array ref. Reserved for boolean value. Specify how to write a boolean value. Default is C<[0,1]> which may not be the most readable. C can be specified as C<['false','true']> or C<['no','yes']>. =head2 assign_char Character used to assign value in INI file. Default is C<=>. =head2 assign_with String used write assignment in INI file. Default is "C< = >". =head2 quote_value How to quote value in INI file. Currrently only C is supported for C. E.g. INI backend declaration can contain this parameter: quote_value => 'shell_style' Here are some example of quoted values. The 3 columns shows the original value in file, how it's stored internally and how it's written back: # read => shown => write "foo" => foo => "foo" "foo bar" => foo bar => "foo bar" "20"x"4" => 20x4 => "20x4" =head1 Mapping between INI structure and model INI file typically have the same structure with 2 different conventions. The class names can be imposed by the application or may be chosen by user. =head2 Imposed class name In this case, the class names must match what is expected by the application. The elements of each class can be different. For instance: foo = foo_v [ A ] bar = bar_v [ B ] baz = baz_v In this case, class C and class C do not use the same configuration class. The model has this structure: Root class |- leaf element foo |- node element A of class_A | \- leaf element bar \- node element B of class_B \- leaf element baz =head2 Arbitrary class name In this case, the class names can be chosen by the end user. Each class has the same elements. For instance: foo = foo_v [ A ] bar = bar_v1 [ B ] bar = bar_v2 In this case, class C and class C do not use the same configuration class. The model has this structure: Root class |- leaf foo \- hash element my_class_holder |- key A (value is node of class_A) | \- element-bar \- key B (value is node of class_A) \- element-bar In this case, the C name is specified in C with C parameter: rw_config => { backend => 'IniFile', config_dir => '/tmp', file => 'foo.ini', store_class_in_hash => 'my_class_holder', } Of course they are exceptions. For instance, in C, the C<[General]> INI class must be mapped to a specific node object. This can be specified with the C parameter: rw_config => } backend => 'IniFile', config_dir => '/tmp', file => 'foo.ini', store_class_in_hash => 'my_class_holder', section_map => { General => 'general_node', } } C can also map an INI class to the root node: rw_config => { backend => 'ini_file', store_class_in_hash => 'sections', section_map => { General => '!' }, } =head1 Handle key value files This backend is able to handle simple configuration files where the values are written as key value pairs like: foo = bar or foo: bar The option C is used to specify which character is used to assign a value in the file (white spaces are ignored). C is "C<=>" (the default) in the first example, and "C<:>" in the second. The C is used to control how the file is written back. E.g: foo=bar # the default foo= bar # assign_with is "= " foo = bar # assign_with is " = " foo:bar # assign_char is ':', assign_with is the default foo: bar # assign_char is ':', assign_with is ": " foo : bar # assign_char is ':', assign_with is " : " =head1 Methods =head2 read Of all parameters passed to this read call-back, only C is used. This parameter must be L object. It can also be undef. In this case, C returns 0. When a file is read, C returns 1. =head2 write Of all parameters passed to this write call-back, only C is used. This parameter must be a L object. C returns 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org); Krzysztof Tyszecki, (krzysztof.tyszecki at gmail dot com) =head1 SEE ALSO L, L, L, =cut libconfig-model-perl-2.155/lib/Config/Model/Backend/Json.pm000066400000000000000000000074171472064100600233420ustar00rootroot00000000000000package Config::Model::Backend::Json; use Carp; use strict; use warnings; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); use base qw/Config::Model::Backend::Any/; use JSON; my $logger = get_logger("Backend::Json"); sub read { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip return 0 unless defined $args{file_path}->exists; # no file to read # load Json file my $json = $args{file_path}->slurp_utf8; # convert to perl data my $perl_data = decode_json $json ; if ( not defined $perl_data ) { $logger->warn("No data found in Json file $args{file_path}"); return 1; } # load perl data in tree $self->{node}->load_data( data => $perl_data, check => $args{check} || 'yes' ); return 1; } sub write { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $perl_data = $self->{node}->dump_as_data( full_dump => $args{full_dump} ); my $json = to_json( $perl_data, { pretty => 1 } ); $args{file_path}->spew_utf8($json); return 1; } 1; # ABSTRACT: Read and write config as a JSON data structure __END__ =head1 SYNOPSIS use Config::Model ; use Data::Dumper ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], rw_config => { backend => 'Json' , config_dir => '/tmp', file => 'foo.json', auto_create => 1, } ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; my $steps = 'foo=yada bar="bla bla" baz:en=hello baz:fr=bonjour baz:hr="dobar dan"'; $root->load( steps => $steps ) ; $inst->write_back ; Now, C contains: { "bar" : "bla bla", "foo" : "yada", "baz" : { "hr" : "dobar dan", "en" : "hello", "fr" : "bonjour" } } =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written with Json syntax in C configuration tree. Note that undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the data structure only contains C<'a','b'>. =head1 CONSTRUCTOR =head2 new Parameters: C<< ( node => $node_obj, name => 'Json' ) >> Inherited from L. The constructor is called by L. =head2 read Of all parameters passed to this read call-back, only C is used. This parameter must be a L. When a file is read, C returns 1. =head2 write Of all parameters passed to this write call-back, only C is used. This parameter must be L object. C returns 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =cut libconfig-model-perl-2.155/lib/Config/Model/Backend/PerlFile.pm000066400000000000000000000100201472064100600241130ustar00rootroot00000000000000package Config::Model::Backend::PerlFile; use 5.10.1; use Carp; use strict; use warnings; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); use base qw/Config::Model::Backend::Any/; my $logger = get_logger("Backend::PerlFile"); sub read { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $file_path = $args{file_path}; return 0 unless -r $file_path; $file_path = "./$file_path" unless $file_path =~ m!^\.?/!; $logger->info("Read Perl data from $file_path"); my $pdata = do $file_path || die "Cannot open $file_path:$?"; $self->node->load_data($pdata); return 1; } sub write { my $self = shift; my %args = @_; # args is: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $file_path = $args{file_path}; $logger->info("Write perl data to $file_path"); my $p_data = $self->node->dump_as_data( skip_auto_write => 'perl_file', check => $args{check} ); my $dumper = Data::Dumper->new( [$p_data] ); $dumper->Terse(1); $args{file_path}->spew_utf8( $dumper->Dump, ";\n" ); return 1; } 1; # ABSTRACT: Read and write config as a Perl data structure __END__ =head1 SYNOPSIS use Config::Model ; use Data::Dumper ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], rw_config => { backend => 'perl_file' , config_dir => '/tmp', file => 'foo.pl', auto_create => 1, }, ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; my $steps = 'foo=yada bar="bla bla" baz:en=hello baz:fr=bonjour baz:hr="dobar dan"'; $root->load( steps => $steps ) ; $inst->write_back ; Now, C contains: { bar => 'bla bla', baz => { en => 'hello', fr => 'bonjour', hr => 'dobar dan' }, foo => 'yada' } =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written with Perl syntax in C configuration tree. Note: =over 4 =item * Undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the data structure contains C<'a','b'>. =item * Perl file is not created (and may be deleted) when no data is to be written. =back =head1 backend parameter =head2 config_dir Mandoatory parameter to specify where is the Perl configuration file. =head1 CONSTRUCTOR =head2 new Inherited from L. The constructor is called by L. =head2 read Of all parameters passed to this read call-back, only C is used. This parameter must be L object already opened for read. It can also be undef. In which case C returns 0. When a file is read, C returns 1. =head2 write Of all parameters passed to this write call-back, only C is used. This parameter must be a L object. C returns 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =cut libconfig-model-perl-2.155/lib/Config/Model/Backend/PlainFile.pm000066400000000000000000000215211472064100600242640ustar00rootroot00000000000000package Config::Model::Backend::PlainFile; use 5.10.1; use Carp; use Mouse; use Config::Model::Exception; use Path::Tiny; use Log::Log4perl qw(get_logger :levels); extends 'Config::Model::Backend::Any'; with "Config::Model::Role::ComputeFunction"; with "Config::Model::Role::FileHandler"; use feature qw/postderef signatures/; no warnings qw/experimental::postderef experimental::signatures/; my $logger = get_logger("Backend::PlainFile"); sub annotation { return 0; } # remember that a read backend (and its config file(s)) is attached to a node # OTOH, PlainFile backend deal with files that are attached to elements of a node. # Hence the files must not be managed by backend manager. # file not opened by BackendMgr # file_path is undef sub skip_open { return 1; } sub get_file_name { my ($self, %args) = @_; my $obj = $args{object}->fetch_element( name => $args{elt} ); return $args{file} ? $obj->compute_string($args{file}) : $args{elt}; } ## no critic (Subroutines::ProhibitBuiltinHomonyms) sub read ($self, %args) { # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $check = $args{check} || 'yes'; my $node = $args{object}; $logger->trace( "called on node ", $node->name ); # read data from leaf element from the node # do not trigger warp when getting element names foreach my $elt ( $node->get_element_names(all => 1) ) { my $obj = $args{object}->fetch_element( name => $elt ); my $file_name = $self->get_file_name(%args, elt => $elt); my $dir = $self->get_tuned_config_dir(%args); my $file = $dir->child($file_name); $logger->trace("looking to read plainfile $file for ", $obj->location); my $type = $obj->get_type; if ( $type eq 'leaf' ) { $self->read_leaf( $obj, $elt, $check, $file, \%args ); } elsif ( $type eq 'list' ) { $self->read_list( $obj, $elt, $check, $file, \%args ); } elsif ( $type eq 'hash' ) { $self->read_hash( $obj, $elt, $check, $file, \%args ); } else { $logger->debug("PlainFile read skipped $type $elt"); } } return 1; } sub read_leaf { my ( $self, $obj, $elt, $check, $file, $args ) = @_; return unless $file->exists; my $v = $file->slurp_utf8; chomp($v) unless $obj->value_type eq 'string'; if ($logger->is_trace) { (my $str = $v) =~ s/\n.*/[...]/s; $logger->trace("storing leaf value '$str' from $file "); } $obj->store( value => $v, check => $check ); return; } sub read_list { my ( $self, $obj, $elt, $check, $file, $args ) = @_; return unless $file->exists; my @v = $file->lines_utf8({ chomp => 1}); $logger->trace("storing list value @v from $file "); $obj->store_set(@v); return; } sub read_hash { my ( $self, $obj, $elt, $check, $file, $args ) = @_; $logger->debug("PlainFile read skipped hash $elt"); return; } sub write ($self, %args){ # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path read # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $check = $args{check} || 'yes'; my $cfg_dir = $args{config_dir}; my $dir = $self->get_tuned_config_dir(%args); $dir->mkpath({ mode => oct(755) } ) unless $dir->is_dir; my $node = $args{object}; $logger->debug( "PlainFile write called on node ", $node->name ); # write data from leaf element from the node foreach my $elt ( $node->get_element_name() ) { my $obj = $args{object}->fetch_element( name => $elt ); my $file_name = $self->get_file_name(%args, elt => $elt); my $file = $dir->child($file_name); $logger->trace("looking to write plainfile $file for ", $obj->location); my $type = $obj->get_type; my @v; if ( $type eq 'leaf' ) { my $v = $obj->fetch( check => $args{check} ); $v .= "\n" if defined $v and $obj->value_type ne 'string'; push @v, $v if defined $v; } elsif ( $type eq 'list' ) { @v = map { "$_\n" } $obj->fetch_all_values; } else { $logger->debug("PlainFile write skipped $type $elt"); next; } if (@v) { $logger->trace("PlainFile write opening $file to write $elt"); $file->spew_utf8(@v); $file->chmod($args{file_mode}) if $args{file_mode}; } elsif ($file->exists) { $logger->trace("PlainFile delete $file"); $file->remove; } } return 1; } ## no critic (Subroutines::ProhibitBuiltinHomonyms) sub delete ($self, %args) { # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path read # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $dir = $self->get_tuned_config_dir(%args); my $node = $args{object}; $logger->debug( "PlainFile delete called on deleted node"); # write data from leaf element from the node foreach my $elt ( $node->get_element_name() ) { my $obj = $node->fetch_element( name => $elt ); my $file_name = $self->get_file_name(%args, elt => $elt); my $file = $dir->child( $file_name ); $logger->info( "Removing $file (deleted node)" ); $file->remove; } return; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config as plain file __END__ =head1 SYNOPSIS use Config::Model; my $model = Config::Model->new; my $inst = $model->create_config_class( name => "WithPlainFile", element => [ [qw/source new/] => { qw/type leaf value_type uniline/ }, ], rw_config => { backend => 'plain_file', config_dir => '/tmp', }, ); my $inst = $model->instance(root_class_name => 'WithPlainFile' ); my $root = $inst->config_root ; $root->load('source=foo new=yes' ); $inst->write_back ; Now C directory contains 2 files: C and C with C and C inside. =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written in several files. Each element of the node is written in a plain file. =head1 Element type and file mapping Element values are written in one or several files depending on their type. =over =item leaf The leaf value is written in one file. This file can have several lines if the leaf type is C =item list The list content is written in one file. Each line of the file is a value of the list. =item hash Not supported =back =head1 File mapping By default, the configuration file is named after the element name (like in synopsis above). The C parameter can also be used to specify a file name that take into account the path in the tree using C<&index()> and C<&element()> functions from L. For instance, with the following model: class_name => "Foo", element => [ string_a => { type => 'leaf', value_type => 'string'} string_b => { type => 'leaf', value_type => 'string'} ], rw_config => { backend => 'PlainFile', config_dir => 'foo', file => '&element(-).&element', file_mode => 0644, # optional } If the configuration is loaded with C, this backend writes "C" in file C and C in file C. C parameter can be used to set the mode of the written file. C value can be in any form supported by L. =head1 Methods =head2 read_leaf Parameters: C<(obj, elt, check, file, args)> Called by L method to read the file of a leaf element. C contains the arguments passed to L method. =head2 read_hash (obj,elt,check,file,args); Like L for hash elements. =head2 read_list Parameters: C<(obj, elt, check, file, args)> Like L for list elements. =head2 write C writes a file for each element of the calling class. Works only for leaf and list elements. Other element type are skipped. Always return 1 (unless it died before). =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =cut libconfig-model-perl-2.155/lib/Config/Model/Backend/ShellVar.pm000066400000000000000000000112111472064100600241340ustar00rootroot00000000000000package Config::Model::Backend::ShellVar; use Carp; use Mouse; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); use Config::Model::BackendTrackOrder; extends 'Config::Model::Backend::Any'; my $logger = get_logger("Backend::ShellVar"); has tracker => ( is => 'ro', isa => 'Config::Model::BackendTrackOrder', lazy_build => 1, handles => [qw/get_ordered_element_names/], ); sub _build_tracker { my $self = shift; return Config::Model::BackendTrackOrder->new( backend_obj => $self, node => $self->node, ) ; } sub annotation { return 1; } sub read { my $self = shift; my %args = @_; # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip return 0 unless $args{file_path}->exists; # no file to read my $check = $args{check} || 'yes'; my @lines = $args{file_path}->lines_utf8; # try to get global comments (comments before a blank line) $self->read_global_comments( \@lines, '#' ); my @assoc = $self->associates_comments_with_data( \@lines, '#' ); foreach my $item (@assoc) { my ( $data, $c ) = @$item; my ($k,$v) = split /\s*=\s*/, $data, 2; # make reader quite tolerant $v =~ s/^["']|["']$//g; if ($logger->is_debug) { my $msg = "Loading key '$k' value '$v'"; $msg .= " comment: '$c'" if $c; $logger->debug($msg); } $self->tracker->register_element($k); my $obj = $self->node->fetch_element($k); $obj->store( value => $v, check => $check ); $obj->annotation($c) if $c; } return 1; } sub write { my $self = shift; my %args = @_; # args are: # object => $obj, # Config::Model::Node object # root => './my_test', # fake root directory, userd for tests # config_dir => /etc/foo', # absolute path # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # check => yes|no|skip my $node = $args{object}; my @to_write; # Using Config::Model::ObjTreeScanner would be overkill foreach my $elt ( $self->get_ordered_element_names ) { my $obj = $node->fetch_element($elt); my $v = $node->grab_value($elt); next unless defined $v; push @to_write, [ qq!$elt="$v"!, $obj->annotation ]; } if (@to_write) { my $res = $self->write_global_comment( '#' ); foreach my $line_ref (@to_write) { $res .= $self->write_data_and_comments( '#', @$line_ref ); } $args{file_path}->spew_utf8($res); } return 1; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config as a C data structure __END__ =head1 SYNOPSIS use Config::Model; my $model = Config::Model->new; $model->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => {qw/type leaf value_type string/} ], rw_config => { backend => 'ShellVar', config_dir => '/tmp', file => 'foo.conf', auto_create => 1, } ); my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; $root->load('foo=FOO1 bar=BAR1' ); $inst->write_back ; File C now contains: ## This file was written by Config::Model ## You may modify the content of this file. Configuration ## modifications will be preserved. Modifications in ## comments may be mangled. ## foo="FOO1" bar="BAR1" =head1 DESCRIPTION This module is used directly by L to read or write the content of a configuration tree written with C syntax in C configuration tree. Note that undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the data structure contains C<'a','b'>. =head1 CONSTRUCTOR =head2 new Parameters: C<< ( node => $node_obj, name => 'shellvar' ) >> Inherited from L. The constructor is called by L. =head2 read Of all parameters passed to this read call-back, only C is used. When a file is read, C returns 1. =head2 write Of all parameters passed to this write call-back, only C is used. C returns 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =cut libconfig-model-perl-2.155/lib/Config/Model/BackendMgr.pm000066400000000000000000000517001472064100600230710ustar00rootroot00000000000000package Config::Model::BackendMgr; use Mouse; use strict; use warnings; use Carp; use 5.10.1; use Config::Model::Exception; use Data::Dumper; use Storable qw/dclone/; use Scalar::Util qw/weaken reftype/; use Log::Log4perl qw(get_logger :levels); use Path::Tiny 0.070; my $logger = get_logger('BackendMgr'); my $user_logger = get_logger('User'); # one BackendMgr per file has 'node' => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1, required => 1 ); has 'file_backup' => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } ); has 'rw_config' => ( is => 'ro', isa => 'HashRef', required => 1 ); has 'backend_obj' => ( is => 'rw', isa => 'Config::Model::Backend::Any', lazy => 1 , builder => '_build_backend_obj', ); sub _build_backend_obj { my $self = shift; my $backend = $self->rw_config->{backend}; $logger->warn("function parameter for a backend is deprecated. Please implement 'read' method in backend $backend") if $self->rw_config->{function}; # try to load a specific Backend class my $f = $self->rw_config->{function} || 'read'; my $c = $self->load_backend_class( $backend, $f ); no strict 'refs'; ## no critic (ProhibitNoStrict) return $c->new( node => $self->node, name => $backend, auto_create => $self->rw_config->{auto_create}, auto_delete => $self->rw_config->{auto_delete}, ); } has support_annotation => ( is => 'ro', isa => 'Bool', default => 0, ); with "Config::Model::Role::ComputeFunction"; with "Config::Model::Role::FileHandler"; # check if dir is present. May create it in auto_create write mode sub get_cfg_dir_path { my $self = shift; my %args = @_; my $w = $args{write} || 0; my $dir = $self->get_tuned_config_dir(%args); if ( not $dir->is_dir and $w and $args{auto_create} ) { $logger->info("creating directory $dir"); $dir->mkpath; } unless ( $dir->is_dir ) { my $mode = $w ? 'write' : 'read'; $logger->info( "$args{backend}: missing directory $dir ($mode mode)" ); return ( 0, $dir ); } $logger->trace( "dir: " . $dir // '' ); return ( 1, $dir ); } # return (1, config file path) constructed from arguments or return # (0). May create directory in auto_create write mode. sub get_cfg_file_path { my $self = shift; my %args = @_; my $w = $args{write} || 0; # config file override my $cfo = $args{config_file}; if ( defined $cfo) { my $override = $args{root} ? $args{root}->child($cfo) : $cfo =~ m!^/! ? path($cfo) : path('.')->child($cfo); my $mode = $w ? 'write' : 'read'; $logger->trace("$args{backend} override target file is $override ($mode mode)"); return ( 1, $override ); } my ( $dir_ok, $dir ) = $self->get_cfg_dir_path(%args); if ( defined $args{file} ) { my $file = $args{skip_compute} ? $args{file} : $self->node->compute_string($args{file}); my $res = $dir->child($file); $logger->trace("get_cfg_file_path: returns $res"); return ( $dir_ok, $res ); } return 0; } sub open_read_file { my ($self, $file_path) = @_; if ( $file_path->is_file ) { $logger->debug("open_read_file: open $file_path for read"); # store a backup in memory in case there's a problem $self->file_backup( [ $file_path->lines_utf8 ] ); return $file_path->filehandle("<", ":utf8"); } else { return; } } # called at configuration node creation # # New subroutine "load_backend_class" extracted - Thu Aug 12 18:32:37 2010. # sub load_backend_class { my $self = shift; my $backend = shift; my $function = shift; $logger->trace("load_backend_class: called with backend $backend, function $function"); my %c; my $k = "Config::Model::Backend::" . ucfirst($backend); my $f = $k . '.pm'; $f =~ s!::!/!g; $c{$k} = $f; # try another class $k =~ s/_(\w)/uc($1)/ge; $f =~ s/_(\w)/uc($1)/ge; $c{$k} = $f; foreach my $c ( sort keys %c ) { if ( $c->can($function) ) { # no need to load class $logger->debug("load_backend_class: $c is already loaded (can $function)"); return $c; } } # look for file to load my $class_to_load; foreach my $c ( sort keys %c ) { $logger->trace("load_backend_class: looking to load class $c"); foreach my $prefix (@INC) { my $realfilename = "$prefix/$c{$c}"; $class_to_load = $c if -f $realfilename; } } if (not defined $class_to_load) { Config::Model::Exception::Model->throw( object => $self->node, error => "backend error: cannot find Perl class for backend: '$backend'", ); }; my $file_to_load = $c{$class_to_load}; $logger->trace("load_backend_class: loading class $class_to_load, $file_to_load"); eval { require $file_to_load; }; if ($@) { die "Error with backend $backend: could not parse $file_to_load: $@\n"; } return $class_to_load; } sub read_config_data { my ( $self, %args ) = @_; $logger->trace( "called for node ", $self->node->location ); my $check = delete $args{check}; my $config_file_override = delete $args{config_file}; my $auto_create_override = delete $args{auto_create}; croak "unexpected args " . join( ' ', keys %args ) . "\n" if %args; my $rw_config = dclone $self->rw_config ; my $instance = $self->node->instance(); # root override is passed by the instance my $root_dir = $instance->root_dir ; my $auto_create = $rw_config->{auto_create}; my $backend = $rw_config->{backend}; if ( $rw_config->{default_layer} ) { $self->read_config_sub_layer( $rw_config, $root_dir, $config_file_override, $check, $backend ); } my ( $res, $file ) = $self->try_read_backend( $rw_config, $root_dir, $config_file_override, $check, $backend ); Config::Model::Exception::ConfigFile::Missing->throw ( file => $file || "", object => $self->node, ) unless $res or $auto_create_override or $auto_create; } sub read_config_sub_layer { my ( $self, $rw_config, $root_dir, $config_file_override, $check, $backend ) = @_; my $layered_config = delete $rw_config->{default_layer}; my $layered_read = dclone $rw_config ; foreach my $item ( qw/file config_dir os_config_dir/ ) { my $lc = delete $layered_config->{$item}; $layered_read->{$item} = $lc if $lc; } Config::Model::Exception::Model->throw( error => "backend error: unexpected default_layer parameters: " . join( ' ', sort keys %$layered_config ), object => $self->node, ) if %$layered_config; my $i = $self->node->instance; my $already_in_layered = $i->layered; # layered stuff here if ( not $already_in_layered ) { $i->layered_clear; $i->layered_start; } $self->try_read_backend( $layered_read, $root_dir, $config_file_override, $check, $backend ); if ( not $already_in_layered ) { $i->layered_stop; } } # called at configuration node creation, NOT when writing # # New subroutine "try_read_backend" extracted - Sun Jul 14 11:52:58 2013. # sub try_read_backend { my $self = shift; my $rw_config = shift; my $root_dir = shift; my $config_file_override = shift; my $check = shift; my $backend = shift; my $read_dir = $self->get_tuned_config_dir(%$rw_config); my @read_args = ( %$rw_config, root => $root_dir, config_dir => $read_dir, backend => $backend, check => $check, config_file => $config_file_override ); my $backend_obj = $self->backend_obj(); if ($backend_obj->can('suffix')) { $logger->warn("suffix method is deprecated. you can remove it from backend $backend"); } my ( $file_ok, $file_path ) = $self->get_cfg_file_path( @read_args, skip_compute => $backend_obj->skip_open, ); my $fh; if (not $backend_obj->skip_open and $file_ok) { $fh = $self->open_read_file($file_path) ; } my $f = $self->rw_config->{function} || 'read'; if ($logger->is_info) { my $fp = defined $file_path ? " on $file_path":'' ; $logger->info( "Read with $backend " . reftype($backend_obj) . "::$f".$fp); } my $res; eval { $res = $backend_obj->$f( @read_args, file_path => $file_path, object => $self->node, ); }; my $error = $@; # catch eval error if ( ref($error) and $error->isa('Config::Model::Exception::Syntax') ) { $error->parsed_file( $file_path) unless $error->parsed_file; $error->rethrow; } elsif ( ref $error and $error->isa('Config::Model::Exception') ) { $error->rethrow ; } elsif ( ref $error ) { die $error ; } elsif ( $error ) { die "Backend $backend failed to read $file_path: $error"; } # only backend based on C::M::Backend::Any can support annotations if ($backend_obj->can('annotation')) { $self->{support_annotation} = $backend_obj->annotation ; } return ( $res, $file_path ); } sub auto_write_init { my ( $self, %args ) = @_; croak "auto_write_init: unexpected args " . join( ' ', sort keys %args ) . "\n" if %args; my $rw_config = dclone $self->rw_config ; my $instance = $self->node->instance(); # root override is passed by the instance my $root_dir = $instance->root_dir; my $backend = $rw_config->{backend}; my $write_dir = $self->get_tuned_config_dir(%$rw_config); $logger->trace( "auto_write_init creating write cb ($backend) for ", $self->node->name ); my @wr_args = ( %$rw_config, # model data config_dir => $write_dir, # override from instance write => 1, # for get_cfg_file_path root => $root_dir, # override from instance ); # used bby C::M::Dumper and C::M::DumpAsData # TODO: is this needed once multi backend are removed $self->{auto_write}{$backend} = 1; my $wb; my $f = $rw_config->{function} || 'write'; my $backend_class = $self->load_backend_class( $backend, $f ); my $location = $self->node->name; my $node = $self->node; # closure # provide a proper write back function $wb = sub { my %cb_args = @_; my $force_delete = delete $cb_args{force_delete} ; $logger->debug( "write cb ($backend) called for $location ", $force_delete ? '' : ' (deleted)' ); my $backend_obj = $self->backend_obj(); my ($fh, $file_ok, $file_path ); if (not $backend_class->skip_open) { ( $file_ok, $file_path ) = $self->get_cfg_file_path( @wr_args, %cb_args); } if ($file_ok) { $fh = $self->open_file_to_write( $backend, $file_path, delete $cb_args{backup} ); } # override needed for "save as" button my %backend_args = ( @wr_args, file_path => $file_path, object => $node, %cb_args # override from user ); my $res; if ($force_delete) { $backend_obj->delete(%backend_args); } else { $res = eval { $backend_obj->$f( %backend_args ); }; my $error = $@; $logger->error( "write backend $backend $backend_class" . '::' . "$f failed: $error" ) if $error; $self->close_file_to_write( $error, $file_path, $rw_config->{file_mode} ); $self->auto_delete($file_path, \%backend_args) if $rw_config->{auto_delete} and not $backend_class->skip_open ; } return defined $res ? $res : $@ ? 0 : 1; }; $logger->trace( "registering write $backend in node " . $self->node->name ); $instance->register_write_back( $self->node->location, $backend, $wb ); } sub auto_delete { my ($self, $file_path, $args) = @_; return unless $file_path; my $perl_data; $perl_data = $self->node->dump_as_data( full_dump => $args->{full_dump} // 0) if defined $self->node; my $size = ref($perl_data) eq 'HASH' ? scalar keys %$perl_data : ref($perl_data) eq 'ARRAY' ? scalar @$perl_data : $perl_data ; if (not $size) { $logger->info( "Removing $file_path (no data to store)" ); unlink($file_path); } } sub open_file_to_write { my ( $self, $backend, $file_path, $backup ) = @_; my $do_backup = defined $backup; $backup ||= 'old'; # use old only if defined $backup = '.' . $backup unless $backup =~ /^\./; # make sure that parent dir exists before creating file $file_path->parent->mkpath; if ( $do_backup and $file_path->is_file ) { $file_path->copy( $file_path.$backup ) or die "Backup copy failed: $!"; } $logger->debug("$backend backend opened file $file_path to write"); return $file_path->filehandle(">",":utf8"); } sub close_file_to_write { my ( $self, $error, $file_path, $file_mode ) = @_; return unless defined $file_path; if ($error) { # restore backup and display error $logger->warn("Error during write, restoring backup data in $file_path" ); $file_path->append_utf8({ truncate => 1 }, $self->file_backup ); $error->rethrow if ref($error) and $error->can('rethrow'); die $error; } # TODO: move chmod in a backend role $file_path->chmod($file_mode) if $file_mode; # TODO: move in a backend role # check file size and remove empty files $file_path->remove if -z $file_path and not -l $file_path; } sub is_auto_write_for_type { my $self = shift; my $type = shift; return $self->{auto_write}{$type} || 0; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Load configuration node on demand __END__ =head1 SYNOPSIS # Use BackendMgr to write data in Yaml file # This example requires Config::Model::Backend::Yaml which is now # shipped outside of Config::Model. Please get it on CPAN use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "Foo", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, ] ); $model->create_config_class( name => "MyClass", # rw_config spec is used by Config::Model::BackendMgr rw_config => { backend => 'yaml', config_dir => '/tmp/', file => 'my_class.yml', auto_create => 1, }, element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, hash_of_nodes => { type => 'hash', # hash id index_type => 'string', cargo => { type => 'node', config_class_name => 'Foo' }, }, ], ); my $inst = $model->instance( root_class_name => 'MyClass' ); my $root = $inst->config_root; # put data my $steps = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( steps => $steps ); $inst->write_back; # now look at file /tmp/my_class.yml =head1 DESCRIPTION This class provides a way to specify how to load or store configuration data within the model. With these specifications, all configuration information is read during creation of a node (which triggers the creation of a backend manager object) and written back when L method is called either on the instance. =begin comment This feature is also useful if you want to read configuration class declarations at run time. (For instance in a C directory like C). In this case, each configuration class must specify how to read and write configuration information. Idea: sub-files name could be %.cds =end comment This load/store can be done with different backends: =over =item * Any of the C classes available on your system. For instance C. =item * C: Config dump string (cds) in a file. I.e. a string that describes the content of a configuration tree is loaded from or saved in a text file. This format is defined by this project. See L. =item * C: Perl data structure (perl) in a file. See L for details on the data structure. Now handled by L =back When needed, C method can be called on the instance (See L) to store back all configuration information. =head1 Backend specification The backend specification is provided as an attribute of a L specification. These attributes are optional: A node without C attribute must rely on another node to read or save its data. When needed (usually for the root node), the configuration class is declared with a C parameter which specifies the read/write backend configuration. =head2 Parameters available for all backends The following parameters are accepted by all backends: =over 4 =item config_dir Specify configuration directory. This parameter is optional as the directory can be hardcoded in the backend class. C beginning with 'C<~>' is munged so C<~> is replaced by C<< File::HomeDir->my_data >>. See L for details. =item file Specify configuration file name (without the path). This parameter is optional as the file name can be hardcoded in the backend class. The configuration file name can be specified with C<&index> keyword when a backend is associated to a node contained in a hash. For instance, with C set to C<&index.conf>: service # hash element foo # hash index nodeA # values of nodeA are stored in foo.conf bar # hash index nodeB # values of nodeB are stored in bar.conf Likewise, the keyword C<&element> can be used to specify the file name. For instance, with C set to C<&element-&index.conf>: service # hash element foo # hash index nodeA # values of nodeA are stored in service.foo.conf bar # hash index nodeB # values of nodeB are stored in service.bar.conf =item file_mode C parameter can be used to set the mode of the written file(s). C value can be in any form supported by L. Example: file_mode => 0664, file_mode => '0664', file_mode => 'g+w' =item os_config_dir Specify alternate location of a configuration directory depending on the OS (as returned by C<$^O>, see L). For instance: config_dir => '/etc/ssh', os_config_dir => { darwin => '/etc' } =item default_layer Optional. Specifies where to find a global configuration file that specifies default values. For instance, this is used by OpenSSH to specify a global configuration file (C) that is overridden by user's file: default_layer => { os_config_dir => { 'darwin' => '/etc' }, config_dir => '/etc/ssh', file => 'ssh_config' } Only the 3 above parameters can be specified in C. =item auto_create By default, an exception is thrown if no read was successful. This behavior can be overridden by specifying C<< auto_create => 1 >> in one of the backend specification. For instance: rw_config => { backend => 'IniFile', config_dir => '/tmp', file => 'foo.conf', auto_create => 1 }, Setting C to 1 is necessary to create a configuration from scratch =item auto_delete Delete configuration files that contains no data. (default is to leave an empty file) =back =head2 Config::Model::Backend::* backends Specify the backend name and the parameters of the backend defined in their documentation. For instance: rw_config => { backend => 'yaml', config_dir => '/tmp/', file => 'my_class.yml', }, See L for more details for this backend. =head2 Your own backend You can also write a dedicated backend. See L for details. =head1 Test setup By default, configurations files are read from the directory specified by C parameter specified in the model. You may override the C directory for test. =head1 Methods =head2 support_annotation Returns 1 if at least the backend supports read and write annotations (aka comments) in the configuration file. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L =cut libconfig-model-perl-2.155/lib/Config/Model/BackendTrackOrder.pm000066400000000000000000000120201472064100600243740ustar00rootroot00000000000000package Config::Model::BackendTrackOrder; # ABSTRACT: Track read order of elements from configuration use Mouse; use strict; use warnings; use Carp; use 5.10.0; use Mouse::Util; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger("BackendTrackOrder"); has backend_obj => ( is => 'ro', isa => 'Config::Model::Backend::Any', weak_ref => 1, required => 1, handles => [qw/node get_element_names/], ); has _creation_order => ( is => 'bare', isa => 'ArrayRef[Str]', traits => ['Array'], default => sub { [] }, handles => { _register_element => 'push', get_element_names_as_created => 'elements', _insert_element => 'insert', } ); has _created => ( is => 'rw', isa => 'HashRef[Str]', traits => ['Hash'], default => sub { {} }, handles => { register_created => 'set', has_created => 'exists', } ); # keeping order in Node does not make sense: one must read parameter # in canonical order to enable warp mechanism from one elemnet to the # other, so the read order will never differ from the canonical # order. Only some elements will be missing # What about default values, not created, no store done ???? # -> when writing back, mix all elements from canonical list into existing list ... # or at the end of initial load ??? # or mixall at the end of init() ? sub register_element { my ($self, $name) = @_; return if $self->has_created($name); $self->register_created($name => 1 ); if ($self->node->instance->initial_load) { $logger->debug("registering $name during init"); $self->_register_element($name); } else { # try to keep canonical order my $i = 1; my %has = map{ ($_ , $i++ ) } $self->get_element_names_as_created; my $found_me = 0; my $previous_idx = 0 ; my $previous_name ; # traverse the canonical list in reverse order (which includes # accepted elements) ... foreach my $std (reverse @{ $self->node->{model}{element_list} }) { # ... until the new element is found in the canonical list ... if ($name eq $std) { $found_me++; } # ... and the first previous element from the canonical # list already existing in the existing list is found elsif ($found_me and $has{$std}) { $previous_idx = $has{$std}; $previous_name = $std; last; } } # then insert this element in the existing list after the # previous element (which may be 0, if the previous element # was not found, i.e. do an unshift). push it if search has failed. if ($found_me) { if ($logger->is_debug) { my $str = $previous_name ? "after $previous_name" : "at beginning"; $logger->debug("registering $name $str"); } $self->_insert_element($previous_idx, $name); } else { $logger->debug("registering $name at end of list"); $self->_register_element($name); } } } sub get_ordered_element_names { my $self = shift; if ($self->node->instance->canonical) { return $self->get_element_names; } else { # triggers a registration of all remaining elements in _creation_order for ( $self->get_element_names ) { $self->register_element($_); } return $self->get_element_names_as_created; } } 1; __END__ =head1 SYNOPSIS # inside a backend use Config::Model::BackendTrackOrder; has tracker => ( is => 'ro', isa => 'Config::Model::BackendTrackOrder', lazy_build => 1, ); sub _build_tracker { my $self = shift; return Config::Model::BackendTrackOrder->new( backend_obj => $self, node => $self->node, ) ; } # register elements to record user order $self->tracker->register_element('foo'); $self->tracker->register_element('bar'); # later, when writing data back foreach my $elt ( $self->tracker->get_ordered_element_names ) { # write data } =head1 DESCRIPTION This module is used by backends to record the order of the configuration elements found in user file. Later these elements can be written back in the file using the same order. Data are written in canonical order if C method of the L returns true. =head1 CONSTRUCTOR THe constructor accepts the following parameters: =over 4 =item backend_obj The backend object holding this tracker (required). =item node The node holding the backend above =back =head1 METHODS =head2 register_element Register the element and keep track of the registration order during L Element registered after initial load (i.e . user modification) are registered using canonical order. =head2 get_ordered_element_names Returns a list of elements respecting user's order. Returns the canonical list if Instance canonical attribute is 1. =cut libconfig-model-perl-2.155/lib/Config/Model/CheckList.pm000066400000000000000000001033001472064100600227370ustar00rootroot00000000000000package Config::Model::CheckList; use Mouse; use 5.010; use Config::Model::Exception; use Config::Model::IdElementReference; use Config::Model::Warper; use List::MoreUtils qw/any none/; use Carp; use Log::Log4perl qw(get_logger :levels); use Storable qw/dclone/; extends qw/Config::Model::AnyThing/; with "Config::Model::Role::WarpMaster"; with "Config::Model::Role::Grab"; with "Config::Model::Role::HelpAsText"; with "Config::Model::Role::ComputeFunction"; my $logger = get_logger("Tree.Element.CheckList"); my $user_logger = get_logger("User"); my @introspect_params = qw/refer_to computed_refer_to/; my @accessible_params = qw/default_list upstream_default_list choice ordered/; my @allowed_warp_params = ( @accessible_params, qw/level/ ); has [qw/backup data preset layered/] => ( is => 'rw', isa => 'HashRef', default => sub { {}; } ); has computed_refer_to => ( is => 'rw', isa => 'Maybe[HashRef]' ); has [qw/refer_to/] => ( is => 'rw', isa => 'Str' ); has [qw/ordered_data choice/] => ( is => 'rw', isa => 'ArrayRef', default => sub { []; } ); has [qw/ordered/] => ( is => 'ro', isa => 'Bool' ); has [qw/warp help/] => ( is => 'rw', isa => 'Maybe[HashRef]' ); around BUILDARGS => sub { my $orig = shift; my $class = shift; my %args = @_; my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @allowed_warp_params; return $class->$orig( backup => dclone( \%h ), @_ ); }; sub BUILD { my $self = shift; if ( defined $self->refer_to or defined $self->computed_refer_to ) { $self->submit_to_refer_to(); } $self->set_properties(); # set will use backup data if ( defined $self->warp ) { my $warp_info = $self->warp; $self->{warper} = Config::Model::Warper->new( warped_object => $self, %$warp_info, allowed => \@allowed_warp_params ); } $self->cl_init; $logger->info( "Created check_list element " . $self->element_name ); return $self; } sub cl_init { my $self = shift; $self->warp if ( $self->{warp} ); if ( defined $self->{ref_object} ) { my $level = $self->parent->get_element_property( element => $self->{element_name}, property => 'level', ); $self->{ref_object}->get_choice_from_referred_to if $level ne 'hidden'; } } sub name { my $self = shift; my $name = $self->{parent}->name . ' ' . $self->{element_name}; return $name; } sub value_type { return 'check_list'; } # warning : call to 'set' are not cumulative. Default value are always # restored. Lest keeping track of what was modified with 'set' is # too hard for the user. sub set_properties { my $self = shift; # cleanup all parameters that are handled by warp for (@allowed_warp_params) { delete $self->{$_}, } if ( $logger->is_trace() ) { my %h = @_; my $keys = join( ',', keys %h ); $logger->trace("set_properties called on $self->{element_name} with $keys"); } # merge data passed to the constructor with data passed to set my %args = ( %{ $self->{backup} }, @_ ); # these are handled by Node or Warper for (qw/level/) { delete $args{$_} } $self->{ordered} = delete $args{ordered} || 0; if ( defined $args{choice} ) { my @choice = @{ delete $args{choice} }; $self->{default_choice} = \@choice; $self->setup_choice(@choice); } if ( defined $args{default} ) { $logger->warn($self->name, ": default param is deprecated, use default_list"); $args{default_list} = delete $args{default}; } if ( defined $args{default_list} ) { $self->{default_list} = delete $args{default_list}; } # store default data in a hash (more convenient) $self->{default_data} = { map { $_ => 1 } @{ $self->{default_list} } }; if ( defined $args{upstream_default_list} ) { $self->{upstream_default_list} = delete $args{upstream_default_list}; } # store upstream default data in a hash (more convenient) $self->{upstream_default_data} = { map { $_ => 1 } @{ $self->{upstream_default_list} } }; Config::Model::Exception::Model->throw( object => $self, error => "Unexpected parameters :" . join( ' ', keys %args ) ) if scalar keys %args; if ( $self->has_warped_slaves ) { my $hash = $self->get_checked_list_as_hash; # force scalar context $self->trigger_warp($hash, $self->fetch); } } sub setup_choice { my $self = shift; my @choice = ref $_[0] ? @{ $_[0] } : @_; $logger->trace("CheckList $self->{element_name}: setup_choice with @choice"); # store all enum values in a hash. This way, checking # whether a value is present in the enum set is easier delete $self->{choice_hash} if defined $self->{choice_hash}; for (@choice) { $self->{choice_hash}{$_} = 1; } $self->{choice} = \@choice; # cleanup current preset and data if it does not fit current choices foreach my $field (qw/preset data layered/) { next unless defined $self->{$field}; # do not create if not present foreach my $item ( keys %{ $self->{$field} } ) { delete $self->{$field}{$item} unless defined $self->{choice_hash}{$item}; } } } # Need to extract Config::Model::Reference (used by Value, and maybe AnyId). sub submit_to_refer_to { my $self = shift; if ( defined $self->refer_to ) { $self->{ref_object} = Config::Model::IdElementReference->new( refer_to => $self->refer_to, config_elt => $self, ); } elsif ( defined $self->computed_refer_to ) { $self->{ref_object} = Config::Model::IdElementReference->new( computed_refer_to => $self->computed_refer_to, config_elt => $self, ); my $var = $self->{computed_refer_to}{variables}; # refer_to registration is done for all element that are used as # variable for complex reference (ie '- $foo' , {foo => '- bar'} ) foreach my $path ( values %$var ) { # is ref during test case #print "path is '$path'\n"; next if $path =~ /\$/; # next if path also contain a variable my $master = $self->grab($path); next unless $master->can('register_dependency'); $master->register_dependency($self); } } else { croak "checklist submit_to_refer_to: undefined refer_to or computed_refer_to"; } } sub setup_reference_choice { my $self = shift; $self->setup_choice(@_); } sub get_type { my $self = shift; return 'check_list'; } sub get_cargo_type { goto &cargo_type } sub cargo_type { my $self = shift; return 'leaf'; } sub apply_fixes { # no operation. THere's no check_value method because a check list # supposed to be always correct. Hence apply_fixes is empty. } sub notify_change { my $self = shift; my %args = @_; return if $self->instance->initial_load and not $args{really}; $self->SUPER::notify_change( %args, value_type => $self->value_type ); # shake all warped or computed objects that depends on me foreach my $s ( $self->get_warped_slaves ) { $logger->debug( "calling notify_change on slave ", $s->name ) if $logger->is_debug; $s->needs_check(1); } } # does not check the validity, but check the item of the check_list sub check { my $self = shift; my @list = ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_; my %args = ref $_[0] eq 'ARRAY' ? @_[ 1, $#_ ] : ( check => 'yes' ); my $check = $self->_check_check( $args{check} ); if ( defined $self->{ref_object} ) { $self->{ref_object}->get_choice_from_referred_to; } my @changed; for (@list) { push @changed, $_ if $self->_store( $_, 1, $check ) } $self->notify_change( note => "check @changed" ) unless $self->instance->initial_load; } sub clear_item { my $self = shift; my $choice = shift; my $inst = $self->instance; my $data_name = $inst->preset ? 'preset' : $inst->layered ? 'layered' : 'data'; my $old_v = $self->{$data_name}{$choice}; my $changed = 0; if ($old_v) { $changed = 1; } delete $self->{$data_name}{$choice}; if ( $self->{ordered} and $changed ) { my $ord = $self->{ordered_data}; my @new = grep { $_ ne $choice } @$ord; $self->{ordered_data} = \@new; } return $changed; } # internal sub _store { my ( $self, $choice, $value, $check ) = @_; my $inst = $self->instance; if ( $value != 0 and $value != 1 ) { Config::Model::Exception::WrongValue->throw( error => "store: check item value must be boolean, " . "not '$value'.", object => $self ); return; } my $ok = $self->{choice_hash}{$choice} || 0; my $changed = 0; if ($ok) { my $data_name = $inst->preset ? 'preset' : $inst->layered ? 'layered' : 'data'; my $old_v = $self->{$data_name}{$choice} ; if ( not defined $old_v or $old_v ne $value ) { # no change notif when going from undef to 0 as the # logical value does not change { no warnings qw/uninitialized/; $changed = (!$old_v xor !$value); } $self->{$data_name}{$choice} = $value; } if ( $self->{ordered} and $value ) { my $ord = $self->{ordered_data}; push @$ord, $choice unless scalar grep { $choice eq $_ } @$ord; } } else { my $err_str = "Unknown check_list item '$choice'. Expected '" . join( "', '", @{ $self->{choice} } ) . "'"; $err_str .= "\n\t" . $self->{ref_object}->reference_info if defined $self->{ref_object}; if ($check eq 'yes') { Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } elsif ($check eq 'skip') { $user_logger->warn($err_str); } } if ( $ok and $changed and $self->has_warped_slaves and not( $self->instance->layered or $self->instance->preset ) ) { my $h = $self->get_checked_list_as_hash; my $str = $self->fetch; $self->trigger_warp($h , $str); } return $changed; } sub get_arguments { my $self = shift; my $arg = shift; my @list = ref $arg eq 'ARRAY' ? @$arg : ($arg, @_); my %args = ref $arg eq 'ARRAY' ? ( check => 'yes', @_ ) : (check => 'yes'); my $check = $self->_check_check( $args{check} ); return \@list, $check, \%args; } sub uncheck { my $self = shift; my ($list, $check) = $self->get_arguments(@_); if ( defined $self->{ref_object} ) { $self->{ref_object}->get_choice_from_referred_to; } my @changed; for ( @$list ) { push @changed, $_ if $self->_store( $_, 0, $check ) } $self->notify_change( note => "uncheck @changed" ) unless $self->instance->initial_load; } sub has_data { my $self = shift; my @set = $self->get_checked_list(qw/mode custom/) ; return scalar @set; } { my %accept_mode = map { ( $_ => 1 ) } qw/custom standard preset default layered upstream_default non_upstream_default user backend/; sub is_bad_mode { my ($self, $mode) = @_; if ( $mode and not defined $accept_mode{$mode} ) { my $good_ones = join( ' or ', sort keys %accept_mode ); return "expected $good_ones as mode parameter, not $mode"; } } } sub is_checked { my $self = shift; my $choice = shift; my %args = @_; my $mode = $args{mode} || ''; my $check = $self->_check_check( $args{check} ); my $ok = $self->{choice_hash}{$choice} || 0; if ($ok) { if ( my $err = $self->is_bad_mode($mode) ) { croak "is_checked: $err"; } my $dat = $self->{data}{$choice}; my $pre = $self->{preset}{$choice}; my $def = $self->{default_data}{$choice}; my $ud = $self->{upstream_default_data}{$choice}; my $lay = $self->{layered}{$choice}; my $std_v = $pre // $def // 0; my $non_up_def = $dat // $pre // $lay // $def // 0; my $user_v = $dat // $pre // $lay // $def // $ud // 0; my $result = $mode eq 'custom' ? ( $dat && !$std_v ? 1 : 0 ) : $mode eq 'preset' ? $pre : $mode eq 'layered' ? $lay : $mode eq 'upstream_default' ? $ud : $mode eq 'default' ? $def : $mode eq 'standard' ? $std_v : $mode eq 'non_upstream_default' ? $ud : $mode eq 'user' ? $user_v : $mode eq 'backend' ? $dat // $std_v : $dat // $std_v; return $result; } elsif ( $check eq 'yes' ) { my $err_str = "Unknown check_list item '$choice'. Expected '" . join( "', '", @{ $self->{choice} } ) . "'"; $err_str .= "\n\t" . $self->{ref_object}->reference_info if defined $self->{ref_object}; Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } } # get_choice is always called when using check_list, so having a # warp safety check here makes sense sub get_choice { my $self = shift; if ( defined $self->{ref_object} ) { $self->{ref_object}->get_choice_from_referred_to; } if ( not defined $self->{choice} ) { my $msg = "check_list element has no defined choice. " . $self->warp_error; Config::Model::Exception::UnavailableElement->throw( info => $msg, object => $self->parent, element => $self->element_name, ); } return @{ $self->{choice} }; } sub get_default_choice { my $self = shift; return @{ $self->{default_choice} || [] }; } sub get_builtin_choice { carp "get_builtin_choice is deprecated, use get_upstream_default_choice"; goto &get_upstream_default_choice; } sub get_upstream_default_choice { my $self = shift; return @{ $self->{upstream_default_data} || [] }; } sub get_help { my $self = shift; my $help = $self->{help}; return $help unless @_; my $on_value = shift; return $help->{$on_value} if defined $help and defined $on_value; return; } sub get_info { my $self = shift; my @items = ('type: check_list'); if ( defined $self->refer_to ) { push @items, "refer_to: " . $self->refer_to; } push @items, "ordered: " . ( $self->ordered ? 'yes' : 'no' ); return @items; } sub clear { my $self = shift; # also triggers notify changes for ($self->get_choice) { $self->clear_item($_) } } sub clear_values { goto &clear; } sub clear_layered { my $self = shift; $self->{layered} = {}; } my %old_mode = ( built_in_list => 'upstream_default_list', ); sub get_checked_list_as_hash { my $self = shift; my %args = @_ > 1 ? @_ : ( mode => $_[0] ); my $mode = $args{mode} || ''; foreach my $k ( keys %old_mode ) { next unless $mode eq $k; $mode = $old_mode{$k}; carp $self->location, " warning: deprecated mode parameter: $k, ", "expected $mode\n"; } if ( my $err = $self->is_bad_mode($mode)) { croak "get_checked_list_as_hash: $err"; } my $dat = $self->{data}; my $pre = $self->{preset}; my $def = $self->{default_data}; my $lay = $self->{layered}; my $ud = $self->{upstream_default_data}; # fill empty hash result my %h = map { $_ => 0 } $self->get_choice; my %predef = ( %$def, %$pre ); my %std = ( %$ud, %$lay, %$def, %$pre ); # use _std_backup if all data values are null (no checked items by user) my %old_dat = ( none { $_; } values %$dat ) ? %{ $self->{_std_backup} || {} } : %$dat; if ( not $mode and any { $_; } values %predef and none { $_; } values %old_dat ) { # changed from nothing to default checked list that must be written $self->{_std_backup} = { %$def, %$pre }; $self->notify_change( note => "use default checklist" ); } # custom test must compare the whole list at once, not just one item at a time. my %result = $mode eq 'custom' ? ( ( grep { $dat->{$_} xor $std{$_} } keys %h ) ? ( %$pre, %$dat ) : () ) : $mode eq 'preset' ? (%$pre) : $mode eq 'layered' ? (%$lay) : $mode eq 'upstream_default' ? (%$ud) : $mode eq 'default' ? (%$def) : $mode eq 'standard' ? %std : $mode eq 'user' ? ( %h, %std, %$dat ) : ( %predef, %$dat ); return wantarray ? %result : \%result; } sub get_checked_list { my $self = shift; my %h = $self->get_checked_list_as_hash(@_); my @good_order = $self->{ordered} ? @{ $self->{ordered_data} } : sort keys %h; my @res = grep { $h{$_} } @good_order; return wantarray ? @res : \@res; } sub fetch { my $self = shift; return join( ',', $self->get_checked_list(@_) ); } sub fetch_custom { my $self = shift; return join( ',', $self->get_checked_list('custom') ); } sub fetch_preset { my $self = shift; return join( ',', $self->get_checked_list('preset') ); } sub fetch_layered { my $self = shift; return join( ',', $self->get_checked_list('layered') ); } sub get { my $self = shift; my $path = shift; if ($path) { Config::Model::Exception::User->throw( object => $self, message => "get() called with a value with non-empty path: '$path'" ); } return $self->fetch(@_); } sub set { my ($self, $path, $list, %args) = @_; my $check_validity = $self->_check_check( $args{check} ); if ($path) { Config::Model::Exception::User->throw( object => $self, message => "set() called with a value with non-empty path: '$path'" ); } my @list = split /,/, $list; return $self->set_checked_list( \@list, check => $check_validity ); } sub load { goto &store; } sub store { my $self = shift; my %args = @_ == 1 ? ( value => $_[0] ) : @_ == 3 ? ( 'value', @_ ) : @_; my $check_validity = $self->_check_check( $args{check} ); my @set = split /\s*,\s*/, $args{value}; foreach (@set) { s/^"|"$//g; s/\\"/"/g; } $self->set_checked_list(\@set, check => $check_validity); } sub store_set { goto &set_checked_list } sub set_checked_list { my $self = shift; my ($list, $check) = $self->get_arguments(@_); $logger->trace("called with @$list"); my %set = map { $_ => 1 } @$list; my @changed; foreach my $c ( $self->get_choice ) { my $v = delete $set{$c} // 0; push @changed, "$c:$v" if $self->_store( $c, $v, $check ); } # Items left in %set are unknown. _store will handle the error foreach my $item (keys %set) { $self->_store( $item, 1, $check ); } $self->{ordered_data} = $list; $self->notify_change( note => "set_checked_list @changed" ) if @changed and not $self->instance->initial_load; } sub set_checked_list_as_hash { my $self = shift; my %check_list = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_; my %args = ref $_[0] eq 'HASH' ? @_[ 1, $#_ ] : ( check => 'yes' ); my $check_validity = $self->_check_check( $args{check} ); foreach my $c ( $self->get_choice ) { if ( defined $check_list{$c} ) { $self->_store( $c, $check_list{$c}, $check_validity ); } else { $self->clear_item($c); } } } sub load_data { my $self = shift; my %args = @_ > 1 ? @_ : ( data => shift ); my $data = $args{data}; my $check_validity = $self->_check_check( $args{check} ); if ( ref($data) eq 'ARRAY' ) { $self->set_checked_list($data, check => $check_validity); } elsif ( ref($data) eq 'HASH' ) { $self->set_checked_list_as_hash($data, check => $check_validity); } elsif ( not ref($data) ) { $self->set_checked_list([$data], check => $check_validity ); } else { Config::Model::Exception::LoadData->throw( object => $self, message => "check_list load_data called with unexpected type. ". "Expected plain scalar, array or hash ref", wrong_data => $data, ); } } sub swap { my ( $self, $a, $b ) = @_; foreach my $param ( $a, $b ) { unless ( $self->is_checked($param) ) { my $err_str = "swap: choice $param must be set"; Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } } # perform swap in ordered list foreach ( @{ $self->{ordered_data} } ) { if ( $_ eq $a ) { $_ = $b; } elsif ( $_ eq $b ) { $_ = $a; } } } sub move_up { my ( $self, $c ) = @_; unless ( $self->is_checked($c) ) { my $err_str = "swap: choice $c must be set"; Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } # perform move in ordered list my $list = $self->{ordered_data}; for ( my $i = 1 ; $i < @$list ; $i++ ) { if ( $list->[$i] eq $c ) { $list->[$i] = $list->[ $i - 1 ]; $list->[ $i - 1 ] = $c; last; } } } sub move_down { my ( $self, $c ) = @_; unless ( $self->is_checked($c) ) { my $err_str = "swap: choice $c must be set"; Config::Model::Exception::WrongValue->throw( error => $err_str, object => $self ); } # perform move in ordered list my $list = $self->{ordered_data}; for ( my $i = 0 ; $i + 1 < @$list ; $i++ ) { if ( $list->[$i] eq $c ) { $list->[$i] = $list->[ $i + 1 ]; $list->[ $i + 1 ] = $c; last; } } } # dummy to match Value call sub warning_msg { '' } 1; # ABSTRACT: Handle check list element __END__ =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "MyClass", element => [ # type check_list uses Config::Model::CheckList my_check_list => { type => 'check_list', choice => [ 'A', 'B', 'C', 'D' ], help => { A => 'A effect is this', D => 'D does that', } }, ], ); my $inst = $model->instance( root_class_name => 'MyClass' ); my $root = $inst->config_root; # put data $root->load( steps => 'my_check_list=A' ); my $obj = $root->grab('my_check_list'); my $v = $root->grab_value('my_check_list'); print "check_list value '$v' with help '", $obj->get_help($v), "'\n"; # more data $obj->check('D'); $v = $root->grab_value('my_check_list'); print "check_list new value is '$v'\n"; # prints check_list new value is 'A,D' =head1 DESCRIPTION This class provides a check list element for a L. In other words, this class provides a list of booleans items. Each item can be set to 1 or 0. The available items in the check list can be : =over =item * A fixed list (with the C parameter) =item * A dynamic list where the available choice are the keys of another hash of the configuration tree. See L for details. =back =head1 CONSTRUCTOR CheckList object should not be created directly. =head1 CheckList model declaration A check list element must be declared with the following parameters: =over =item type Always C. =item choice A list ref containing the check list items (optional) =item refer_to This parameter is used when the keys of a hash are used to specify the possible choices of the check list. C point to a hash or list element in the configuration tree. See L for details. (optional) =item computed_refer_to Like C, but use a computed value to find the hash or list element in the configuration tree. See L for details. (optional) =item default_list List ref to specify the check list items which are "on" by default. (optional) =item ordered Specify whether the order of checked items must be preserved. =item help Hash ref to provide information on the check list items. =item warp Used to provide dynamic modifications of the check list properties See L for details =back For example: =over =item * A check list with help: choice_list => { type => 'check_list', choice => ['A' .. 'Z'], help => { A => 'A help', E => 'E help' } , }, =item * A check list with default values: choice_list_with_default => { type => 'check_list', choice => ['A' .. 'Z'], default_list => [ 'A', 'D' ], }, =item * A check list whose available choice and default change depending on the value of the C parameter: warped_choice_list => { type => 'check_list', warp => { follow => '- macro', rules => { AD => { choice => [ 'A' .. 'D' ], default_list => ['A', 'B' ] }, AH => { choice => [ 'A' .. 'H' ] }, } } }, =back =head1 Introspection methods The following methods returns the checklist parameter : =over =item refer_to =item computed_refer_to =back =head1 Choice reference The choice items of a check_list can be given by another configuration element. This other element can be: =over =item * The keys of a hash =item * Another checklist. In this case only the checked items of the other checklist are available. =back This other hash or other checklist is indicated by the C or C parameter. C uses the syntax of the C parameter of L See L. =head2 Reference examples =over =item * A check list where the available choices are the keys of C configuration parameter: refer_to_list => { type => 'check_list', refer_to => '- my_hash' }, =item * A check list where the available choices are the checked items of C configuration parameter: other_check_list => { type => 'check_list', choice => [qw/A B C/] }, refer_to_list => { type => 'check_list', refer_to => '- other_check_list' }, =item * A check list where the available choices are the keys of C and C and C configuration parameter: refer_to_3_lists => { type => 'check_list', refer_to => '- my_hash + - my_hash2 + - my_hash3' }, =item * A check list where the available choices are the specified choice and the choice of C and a hash whose name is specified by the value of the C configuration parameter (this example is admittedly convoluted): refer_to_check_list_and_choice => { type => 'check_list', computed_refer_to => { formula => '- refer_to_2_list + - $var', variables => { var => '- indirection ' } }, choice => [qw/A1 A2 A3/], }, =back =head1 Methods =head2 get_type Returns C. =head2 cargo_type Returns 'leaf'. =head2 check Set choice. Parameter is either a list of choices to set or a list ref and some optional parameter. I.e: check (\@list, check => 'skip') ; C parameter decide on behavior in case of invalid choice value: either die (if yes) or discard bad value (if skip) =head2 uncheck Unset choice. Parameter is either a list of choices to unset or a list ref and some optional parameter. I.e: uncheck (\@list, check => 'skip') ; C parameter decide on behavior in case of invalid choice value: either die (if yes) or discard bad value (if skip) =head2 is_checked Parameters: C<< ( choice, [ check => yes|skip ] , [ mode => ... ]) >> Return 1 if the given C was set. Returns 0 otherwise. C parameter decide on behavior in case of invalid choice value: either die (if yes) or discard bad value (if skip) C is either: custom standard preset default layered upstream_default =head2 has_data Return true if the check_list contains a set of checks different from default or upstream default set of check. =head2 get_choice Returns an array of all items names that can be checked (i.e. that can have value 0 or 1). =head2 get_help Parameters: C<(choice_value)> Return the help string on this choice value =head2 get_info Returns a list of information related to the check list. See L for more details. =head2 clear Reset the check list (can also be called as C) =head2 clear_item Parameters: C<(choice_value)> Reset an element of the checklist. =head2 get_checked_list_as_hash Accept a parameter (referred below as C parameter) similar to C in L. Returns a hash (or a hash ref) of all items. The boolean value is the value of the hash. Example: { A => 0, B => 1, C => 0 , D => 1} By default, this method returns all items set by the user, or items set in preset mode or checked by default. With a C parameter set to a value from the list below, this method returns: =over =item backend The value written in config file, (ie. set by user or by layered data or preset or default) =item custom The list entered by the user. An empty list is returned if the list of checked items is identical to the list of items checked by default. The whole list of checked items is returned as soon as B item is different from standard value. =item preset The list entered in preset mode =item standard The list set in preset mode or checked by default. =item default The default list (defined by the configuration model) =item layered The list specified in layered mode. =item upstream_default The list implemented by upstream project (defined in the configuration model) =item user The set that is active in the application. (ie. set by user or by layered data or preset or default or upstream_default) =item non_upstream_default The choice set by user or by layered data or preset or default. =back =head2 get_checked_list Parameters: C<< ( < mode > ) >> Returns a list (or a list ref) of all checked items (i.e. all items set to 1). =head2 fetch Parameters: C<< ( < mode > ) >> Returns a string listing the checked items (i.e. "A,B,C") =head2 get Parameters: C<< ( path [, < mode> ] ) >> Get a value from a directory like path. =head1 Method to check or clear items in the check list All these methods accept an optional C parameter that can be: =over =item yes A wrong item to check trigger an exception (default) =item skip A wrong item trigger a warning =item no A wrong item is ignored =back =head2 set Parameters: C<< ( path, items_to_set, [ check => [ yes | no | skip ] ] ) >> Set a checklist with a directory like path. Since a checklist is a leaf, the path should be empty. The values are a comma separated list of items to set in the check list. Example : $leaf->set('','A,C,Z'); $leaf->set('','A,C,Z', check => 'skip'); =head2 set_checked_list Set all passed items to checked (1). All other available items in the check list are set to 0. Example, for a check list that contains A B C and D check items: # set cl to A=0 B=1 C=0 D=1 $cl->set_checked_list('B','D') $cl->set_checked_list( [ 'B','D' ]) $cl->set_checked_list( [ 'B','D' ], check => 'yes') =head2 store_set Alias to L, so a list and a check_list can use the same store method =head2 store Set all items listed in a string to checked. The items must be separated by commas. All other available items in the check list are set to 0. Example: $cl->store('B, D') $cl->store( value => 'B,C' ) $cl->store( value => 'B,C', check => 'yes' ) =head2 load Alias to L. =head2 set_checked_list_as_hash Set check_list items. Missing items in the given hash of parameters are cleared (i.e. set to undef). Example for a check list containing A B C D $cl->set_checked_list_as_hash( { A => 1, B => 0} , check => 'yes' ) # result A => 1 B => 0 , C and D are undef =head2 load_data Load items as an array or hash ref. Array is forwarded to L , and hash is forwarded to L. Example: $cl->load_data(['A','B']) # cannot use check param here $cl->load_data( data => ['A','B']) $cl->load_data( data => ['A','B'], check => 'yes') $cl->load_data( { A => 1, B => 1 } ) $cl->load_data( data => { A => 1, B => 1 }, check => 'yes') =head2 is_bad_mode Accept a mode parameter. This function checks if the mode is accepted by L method. Returns an error message if not. For instance: if (my $err = $val->is_bad_mode('foo')) { croak "my_function: $err"; } This method is intented as a helper ti avoid duplicating the list of accepted modes for functions that want to wrap fetch methods (like L or L) =head1 Ordered checklist methods All the methods below are valid only for ordered checklists. =head2 swap Parameters: C<< ( choice_a, choice_b) >> Swap the 2 given choice in the list. Both choice must be already set. =head2 move_up Parameters: C<< ( choice ) >> Move the choice up in the checklist. =head2 move_down Parameters: C<< ( choice ) >> Move the choice down in the checklist. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, L, L =cut libconfig-model-perl-2.155/lib/Config/Model/Cookbook/000077500000000000000000000000001472064100600223015ustar00rootroot00000000000000libconfig-model-perl-2.155/lib/Config/Model/Cookbook/CreateModelFromDoc.pod000066400000000000000000000211471472064100600264500ustar00rootroot00000000000000# PODNAME: Config::Model::Cookbook::CreateModelFromDoc # ABSTRACT: Create a configuration model from application documentation =pod =head1 Introduction This page shows step by step how was created C's model from C documentation provided as comments in C's sample configuration file. =head1 C configuration file A quick looks in C directory shows that C's configuration is stored in C: # Config file for Debian's popularity-contest package. # # To change this file, use: # dpkg-reconfigure popularity-contest # # You can also edit it by hand, if you so choose. # # See /usr/share/popularity-contest/default.conf for more info # on the options. MY_HOSTID="172921501FFFFFAAAA6897etc" PARTICIPATE="yes" USEHTTP="yes" DAY="5" The important part is the mention of C which contains all the required information to create C's configuration model. =head1 C documentation Let's start from C file. Since this file is loaded by C I loading C, all values there can be used as application default values (aka I): # Default config file for Debian's popularity-contest package. # # Local overrides are in /etc/popularity-contest.conf # PARTICIPATE can be one of "yes" or "no". # If you don't want to participate in the contest, say "no" # and we won't send messages. # # If this option is missing, the default is "no". # PARTICIPATE="no" # MAILTO specifies the address to e-mail statistics to each week. # MAILTO="survey@popcon.debian.org" # MAILFROM is the forged sender email address you want to use in # email submitted to the popularity-contest. If this is commented # out, no From: or Sender: lines will be added to the outgoing mail, # and it will be your MTA's job to add them. This is usually what # you want. # # If your MTA is misconfigured or impossible to configure correctly, # and it always generates invalid From: and/or Sender: lines, you # can force different results by setting MAILFROM here. This can # cause problems with spam bouncers, so most people should leave it # commented out. # #MAILFROM="root@example.org" # SUBMITURLS is a space separated list of where to submit # popularity-contest reports using http. SUBMITURLS="http://popcon.debian.org/cgi-bin/popcon.cgi" # USEHTTP enables http reporting. Set this to 'yes' to enable it. USEHTTP="yes" # HTTP_PROXY allows one to specify an HTTP proxy server, the syntax is # HTTP_PROXY="http://proxy:port". This overrides the environment # variable http_proxy. # MY_HOSTID is a secret number that the popularity-contest receiver # uses to keep track of your submissions. Whenever you send in a # new entry, it overwrites the last one that had the same HOSTID. # # This key was generated automatically so you should normally just # leave it alone. # #MY_HOSTID="_ID_" This file contains everything we need: =over =item * Parameter names =item * Documentation =item * Default values =back Now, we will use our favorite editor to edit this file and add YAML tags that can be understood by C =head1 Creating the YAML skeleton C is able to load a model described in YAML. To do this the above file needs to be translated in YAML. That's not as complicated as it may sound. First, a YAML file must begin with B<--->. Then the class must be declared: --- class: PopCon: Note that, like with Python language, the indentation is important to define the structure of the file. Here, the C class is followed by a ':' as it defines a new hierarchical level to describes the configuration elements of this class: element: Now we can deal with the configuration parameters. Let's detail the C element. Here's the spec in from C: # PARTICIPATE can be one of "yes" or "no". # If you don't want to participate in the contest, say "no" # and we won't send messages. # # If this option is missing, the default is "no". # PARTICIPATE="no" In the YAML file, the comments are moved in the C field and the value in the file is used as upstream default: PARTICIPATE: upstream_default: no description: > If you don't want to participate in the contest, say "no" and we won't send messages. Likewise for the remaining parameters: MAILTO: description: > specifies the address to e-mail statistics to each week. default: 'survey@popcon.debian.org' MAILFROM: description: >- MAILFROM is the forged sender email address you want to use in email submitted to the popularity-contest. If this is commented out, no From: or Sender: lines will be added to the outgoing mail, and it will be your MTA's job to add them. This is usually what you want. If your MTA is misconfigured or impossible to configure correctly, and it always generates invalid From: and/or Sender: lines, you can force different results by setting MAILFROM here. This can cause problems with spam bouncers, so most people should leave it commented out. In the description above, the C marker '-' after '>' is used to keep paragraph formatting in the help. SUBMITURLS: description: > Space separated list of where to submit popularity-contest reports using http. default: > http://popcon.debian.org/cgi-bin/popcon.cgi USEHTTP: description: > enables http reporting. Set this to 'yes' to enable it. default: "yes" HTTP_PROXY: description: > allows one to specify an HTTP proxy server, the syntax is "http://proxy:port". This overrides the environment variable http_proxy. MY_HOSTID: description: >- secret number that the popularity-contest receiver uses to keep track of your submissions. Whenever you send in a new entry, it overwrites the last one that had the same HOSTID. This key was generated automatically so you should normally just leave it alone. =head1 Loading the YAML skeleton Now that the YAML file was created, you can turn it into a model and load it in the model editor GUI with the following command: cme meta edit popcon -load-yaml popcon.yml -force Note that the model is incomplete: some mandatory parameters are missing from the YAML file so the I<-force> option must be used. These missing parameters are also flagged with a red cross in the GUI. =head1 Completing missing model parts To complete the model, the easiest way is to run the wizard to complete the missing values. In the GUI, you can use the menu C<< File -> wizard >> to launch the wizard. Then click on the 'OK' button in the new window. The wizard will first stop on the parameter list (not because there's an error, but because the parameter list is flagged as I) There, you can re-order the parameters by selecting one and clicking on one of the blue arrows to move it up or down. Once you're satisfied, click on I. The widget will now stop on the first missing information. Just select the correct type ('leaf' here), click 'store' and 'Next'. You can repeat these steps until the wizard exits. =head1 Specifying read and write backend Once the model is complete, it's time to specify how to read and write the file. In C class specification: =over =item * right-click on I =item * click on I to create a new read specification =item * right-click on the created item (shown at index "I<0>") =back You will get a window showing you the parameters to fill to specify the read backend. Now fill the blank on the right side. The backend to use is C since I is made of shell variables. Since the write specification is identical, there's no need to specify it. L will do the right thing. =head1 Testing the model You can test the model by clicking on menu C<< Test -> Model >>. You will be shown the C configuration editor GUI. The same that your users will get. If everything is fine, you can quit the model editor (menu File->quit) =head1 The resulting model The model you have just created is stored in C. You can test directly this model with : cme edit -dev -try Popcon =head1 Feedback welcome Feel free to send comments and suggestion about this page to the author. =head1 AUTHORS Dominique Dumont libconfig-model-perl-2.155/lib/Config/Model/Describe.pm000066400000000000000000000225641472064100600226220ustar00rootroot00000000000000 package Config::Model::Describe; use Carp; use strict; use warnings; use Config::Model::Exception; use Config::Model::ObjTreeScanner; use List::Util qw/max/; use utf8; sub new { bless {}, shift; } sub describe { my $self = shift; my %args = @_; my $desc_node = delete $args{node} || croak "describe: missing 'node' parameter"; my $check = delete $args{check} || 'yes'; my $element = delete $args{element} ; # optional my $pattern = delete $args{pattern} ; # optional my $hide_empty = delete $args{hide_empty} // 0 ; # optional my $verbose = delete $args{verbose} // 0 ; # optional my $show_empty = ! $hide_empty ; my $tag_name = sub { $_[1] .= ' ⚠' if $_[0]->has_warning; }; my $my_content_cb = sub { my ( $scanner, $data_ref, $node, @element ) = @_; # filter elements according to pattern my @scan = $pattern ? grep { $_ =~ $pattern } @element : @element; for (@scan) { $scanner->scan_element( $data_ref, $node, $_ ) } }; my $std_cb = sub { my ( $scanner, $data_r, $obj, $element, $index, $value_obj ) = @_; my $value = $value_obj->fetch( check => $check, mode => 'user' ); return unless $show_empty or (defined $value and length($value)); $value = substr($value,0,12).'[…]' if $value and length($value) > 12; $value = '"' . $value . '"' if defined $value and $value =~ /\s/; my $name = defined $index ? "$element:$index" : $element; $value = defined $value ? $value : '[undef]'; my $type = $value_obj->value_type; my @comment; if (my $default = $value_obj->fetch(mode => 'standard')) { my $defstr = $type =~ /uniline|string/ ? qq!"$default"! : $default; push @comment, "default: $defstr"; } push @comment, "choice: " . join( ' ', @{ $value_obj->choice } ) if $type eq 'enum'; push @comment, 'mandatory' if $value_obj->mandatory; $tag_name->($value_obj,$element); push @$data_r, [ $name, $type, $value, join( ', ', @comment ) ]; }; my $list_element_cb = sub { my ( $scanner, $data_r, $obj, $element, @keys ) = @_; #print "DEBUG: list_element_cb on $element, keys @keys\n"; my $list_obj = $obj->fetch_element($element); my $elt_type = $list_obj->cargo_type; $tag_name->($list_obj,$element); if ( $elt_type eq 'node' ) { my $class_name = $list_obj->config_class_name; my @show_keys = @keys ? @keys : (''); push @$data_r, [ $element, "<$class_name>", 'node list', "indexes: @show_keys" ]; } else { my @values = grep { $show_empty or length } $list_obj->fetch_all_values( check => 'no' ) ; push @$data_r, [ $element, 'list', join( ',', @values ), '' ] if ($show_empty or @values); } }; my $check_list_element_cb = sub { my ( $scanner, $data_r, $obj, $element, @choices ) = @_; my $list_obj = $obj->fetch_element($element); $tag_name->($list_obj,$element); my @checked = $list_obj->get_checked_list; push @$data_r, [ $element, 'check_list', join( ',', @checked ), '' ] if $show_empty or @checked; }; my $hash_element_cb = sub { my ( $scanner, $data_r, $obj, $element, @keys ) = @_; #print "DEBUG: hash_element_cb on $element, keys @keys\n"; my $hash_obj = $obj->fetch_element($element); my $elt_type = $hash_obj->cargo_type; $tag_name->($hash_obj,$element); if ( $elt_type eq 'node' ) { my $class_name = $hash_obj->config_class_name; my @show_keys = @keys ? map { qq("$_") } @keys : (''); my $show_str = "keys: @show_keys"; push @$data_r, [ $element, 'node hash', "<$class_name>", $show_str ]; } elsif (@keys) { for ( @keys ) { $scanner->scan_hash( $data_r, $obj, $element, $_ ) } } else { push @$data_r, [ $element, 'value hash', "[empty hash]", "" ] if $show_empty; } }; my $node_element_cb = sub { my ( $scanner, $data_r, $obj, $element, $key, $next ) = @_; #print "DEBUG: elt_cb on $element, key $key\n"; my $type = $obj->element_type($element); my $class_name = $next->config_class_name; push @$data_r, [ $element, 'node', "<$class_name>", $obj->gist ]; #$ret .= ":$key" if $type eq 'list' or $type eq 'hash'; #$view_scanner->scan_node($next); }; my @scan_args = ( fallback => 'all', auto_vivify => 0, list_element_cb => $list_element_cb, check_list_element_cb => $check_list_element_cb, hash_element_cb => $hash_element_cb, leaf_cb => $std_cb, node_element_cb => $node_element_cb, node_content_cb => $my_content_cb, ); my @left = keys %args; croak "Describe: unknown parameter:@left" if @left; # perform the scan my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args); my @ret; if ( defined $element and $desc_node->has_element($element) ) { $view_scanner->scan_element( \@ret, $desc_node, $element ); } elsif ( defined $element ) { Config::Model::Exception::UnknownElement->throw( object => $desc_node, function => 'Describe', where => $desc_node->location || 'configuration root', element => $element, ); } else { $view_scanner->scan_node( \@ret, $desc_node ); } my @header = qw/name type value/; my $name_length = max map { length($_->[0]) } (@ret, \@header ); my $type_length = max map { length($_->[1]) } (@ret, \@header ); my $value_length = max map { length($_->[2]) } (@ret, \@header ); my $sep_length = $name_length + $type_length + $value_length + 4 ; my @format = ("%-${name_length}s", "%-${type_length}s", "%-${value_length}s") ; my @show ; if ($verbose) { push @format, "%-35s"; @show = ( sprintf( join(" │ ", @format)."\n", qw/name type value comment/) , sprintf( join("─┼─", @format)."\n", '─' x $name_length,'─' x $type_length,'─' x $value_length,'─' x 20, ) , map { sprintf( join(" │ ", @format)."\n", @$_ ) } @ret ); } else { @show = ( sprintf( join(" │ ", @format)."\n", qw/name type value/) , sprintf( join("─┼─", @format)."\n", '─' x $name_length,'─' x $type_length,'─' x $value_length ) , map { sprintf( join(" │ ", @format)."\n", @$_[0,1,2] ) } @ret ); } return join ('', @show ); } 1; # ABSTRACT: Provide a description of a node element __END__ =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "Foo", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, ] ); $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, hash_of_nodes => { type => 'hash', # hash id index_type => 'string', cargo => { type => 'node', config_class_name => 'Foo' }, }, ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put data my $steps = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( steps => $steps ); print $root->describe ; ### prints # name type value comment # foo string FOO # bar string [undef] # hash_of_nodes node hash keys: "en" "fr" =head1 DESCRIPTION This module is used directly by L to describe a node element. This module returns a human readable string that shows the content of a configuration node. For instance (as shown by C example: name type value comment fs_spec string [undef] mandatory fs_vfstype enum [undef] choice: auto davfs ext2 ext3 swap proc iso9660 vfat ignore, mandatory fs_file string [undef] mandatory fs_freq boolean 0 fs_passno integer 0 This module is also used by the C command of L. =head1 CONSTRUCTOR =head2 new No parameter. The constructor should be used only by L. =head1 Methods =head2 describe Return a description string. Parameters are: =over =item node Reference to a L object. Mandatory =item element Describe only this element from the node. Optional. All elements are described if omitted. =item pattern Describe the element matching the regexp ref. Example: describe => ( pattern => qr/^foo/ ) =item hide_empty Boolean. Whether to hide empty value (i.e. C or C<''>) or not. Default is false. =item verbose Boolean. Display more information with each element. Default is false. =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L =cut libconfig-model-perl-2.155/lib/Config/Model/DumpAsData.pm000066400000000000000000000265611472064100600230660ustar00rootroot00000000000000package Config::Model::DumpAsData; use Carp; use strict; use warnings; use 5.10.1; use Config::Model::Exception; use Config::Model::ObjTreeScanner; sub new { bless {}, shift; } sub dump_as_data { my $self = shift; my %args = @_; my $dump_node = delete $args{node} || croak "dump_as_data: missing 'node' parameter"; my $mode = delete $args{mode} // ''; my $skip_aw = delete $args{skip_auto_write} || ''; my $auto_v = delete $args{auto_vivify} || 0; my $ordered_hash_as_list = delete $args{ordered_hash_as_list}; my $to_boolean = delete $args{to_boolean} // sub {return $_[0] }; $ordered_hash_as_list = 1 unless defined $ordered_hash_as_list; # mode and full_dump params are both accepted my $full = delete $args{full_dump} || 0; carp "dump_as_data: full_dump parameter is deprecated. Please use 'mode => user' instead" if $full; my $fetch_mode = $full ? 'user' : $mode eq 'full' ? 'user' : $mode ? $mode : 'custom'; my $std_cb = sub { my ( $scanner, $data_r, $obj, $element, $index, $value_obj ) = @_; my $v = $value_obj->fetch(mode => $fetch_mode); # transform boolean type in boolean object $$data_r = $value_obj->value_type eq 'boolean' ? $to_boolean->($v) : $v; }; my $check_list_element_cb = sub { my ( $scanner, $data_r, $node, $element_name, @check_items ) = @_; my $a_ref = $node->fetch_element($element_name)->get_checked_list; # don't store empty checklist $$data_r = $a_ref if @$a_ref; }; my $hash_element_cb = sub { my ( $scanner, $data_ref, $node, $element_name, @keys ) = @_; my $force_write = $node->fetch_element($element_name)->write_empty_value; # resume exploration but pass a ref on $data_ref hash element # instead of data_ref my %h; my @res; foreach my $k (@keys) { my $v; $scanner->scan_hash( \$v, $node, $element_name, $k ); # don't create the key if $v is undef if (defined $v or $force_write) { $h{$k} = $v; push @res , $k, $v; } } ; my $ordered_hash = $node->fetch_element($element_name)->ordered; if ( $ordered_hash and $ordered_hash_as_list ) { $$data_ref = \@res if @res; } else { $h{'__'.$element_name.'_order'} = \@keys if $ordered_hash and @keys; $$data_ref = \%h if scalar %h; } }; my $list_element_cb = sub { my ( $scanner, $data_ref, $node, $element_name, @idx ) = @_; # resume exploration but pass a ref on $data_ref hash element # instead of data_ref my @a; foreach my $i (@idx) { my $v; $scanner->scan_hash( \$v, $node, $element_name, $i ); push @a, $v if defined $v; } $$data_ref = \@a if scalar @a; }; my $node_content_cb = sub { my ( $scanner, $data_ref, $node, @element ) = @_; my %h; foreach my $e (@element) { my $v; $scanner->scan_element( \$v, $node, $e ); $h{$e} = $v if defined $v; } $$data_ref = \%h if scalar %h; }; my $node_element_cb = sub { my ( $scanner, $data_ref, $node, $element_name, $key, $next ) = @_; return if $skip_aw and $next->is_auto_write_for_type($skip_aw); $scanner->scan_node( $data_ref, $next ); }; my @scan_args = ( check => delete $args{check} || 'yes', fallback => 'all', auto_vivify => $auto_v, list_element_cb => $list_element_cb, check_list_element_cb => $check_list_element_cb, hash_element_cb => $hash_element_cb, leaf_cb => $std_cb, node_element_cb => $node_element_cb, node_content_cb => $node_content_cb, ); my @left = keys %args; croak "DumpAsData: unknown parameter:@left" if @left; # perform the scan my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args); my $obj_type = $dump_node->get_type; my $result; my $p = $dump_node->parent; my $e = $dump_node->element_name; my $i = $dump_node->index_value; # defined only for hash and list if ( $obj_type =~ /node/ ) { $view_scanner->scan_node( \$result, $dump_node ); } elsif ( defined $i ) { $view_scanner->scan_hash( \$result, $p, $e, $i ); } elsif ($obj_type eq 'list' or $obj_type eq 'hash' or $obj_type eq 'leaf' or $obj_type eq 'check_list' ) { $view_scanner->scan_element( \$result, $p, $e ); } else { croak "dump_as_data: unexpected type: $obj_type"; } return $result; } sub dump_annotations_as_pod { my $self = shift; my %args = @_; my $dump_node = delete $args{node} || croak "dump_annotations_as_pod: missing 'node' parameter"; my $annotation_to_pod = sub { my $obj = shift; my $path = shift || $obj->location; my $a = $obj->annotation; if ($a) { chomp $a; return "=item $path\n\n$a\n\n"; } else { return ''; } }; my $std_cb = sub { my ( $scanner, $data_r, $obj, $element, $index, $value_obj ) = @_; $$data_r .= $annotation_to_pod->($value_obj); }; my $hash_element_cb = sub { my ( $scanner, $data_ref, $node, $element_name, @keys ) = @_; my $h = $node->fetch_element($element_name); my $h_path = $h->location . ':'; foreach (@keys) { $$data_ref .= $annotation_to_pod->( $h->fetch_with_id($_), $h_path . $_ ); $scanner->scan_hash( $data_ref, $node, $element_name, $_ ); } }; my $node_content_cb = sub { my ( $scanner, $data_ref, $node, @element ) = @_; my $node_path = $node->location; $node_path .= ' ' if $node_path; foreach (@element) { $$data_ref .= $annotation_to_pod->( $node->fetch_element( name => $_, check => 'no' ), $node_path . $_ ); $scanner->scan_element( $data_ref, $node, $_ ); } }; my @scan_args = ( check => delete $args{check} || 'yes', fallback => 'all', leaf_cb => $std_cb, node_content_cb => $node_content_cb, hash_element_cb => $hash_element_cb, list_element_cb => $hash_element_cb, ); my @left = keys %args; croak "dump_annotations_as_pod: unknown parameter:@left" if @left; # perform the scan my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args); my $obj_type = $dump_node->get_type; my $result = ''; my $a = $dump_node->annotation; my $l = $dump_node->location; $result .= "=item $l\n\n$a\n\n" if $a; if ( $obj_type =~ /node/ ) { $view_scanner->scan_node( \$result, $dump_node ); } else { croak "dump_annotations_as_pod: unexpected type: $obj_type"; } return '' unless $result; return "=head1 Annotations\n\n=over\n\n" . $result . "=back\n\n"; } 1; # ABSTRACT: Dump configuration content as a perl data structure __END__ =head1 SYNOPSIS use Config::Model ; use Data::Dumper ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put some data in config tree the hard way $root->fetch_element('foo')->store('yada') ; $root->fetch_element('bar')->store('bla bla') ; $root->fetch_element('baz')->fetch_with_id('en')->store('hello') ; # put more data the easy way my $steps = 'baz:fr=bonjour baz:hr="dobar dan"'; $root->load( steps => $steps ) ; print Dumper($root->dump_as_data); # $VAR1 = { # 'bar' => 'bla bla', # 'baz' => { # 'en' => 'hello', # 'fr' => 'bonjour', # 'hr' => 'dobar dan' # }, # 'foo' => 'yada' # }; =head1 DESCRIPTION This module is used directly by L to dump the content of a configuration tree in perl data structure. The perl data structure is a hash of hash. Only L content is stored in an array ref. User can pass a sub reference to apply to values of boolean type. This sub can be used to convert the value to an object representing a boolean like L. (since 2.129) Note that undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the data structure then contains C<'a','b'>. =head1 CONSTRUCTOR =head2 new No parameter. The constructor should be used only by L. =head1 Methods =head2 dump_as_data Return a perl data structure Parameters are: =over =item node Reference to a L object. Mandatory =item full_dump Also dump default values in the data structure. Useful if the dumped configuration data is used by the application. This parameter is deprecated in favor of mode parameter. =item mode Note that C parameter is also accepted and overrides C parameter. See L for details on C. =item skip_auto_write Skip node that have a C capability in their model. See L. This option must be used when using DumpAsData: to write back configuration data. When a configuration model contains several backends (one at the tree root and others in tree nodes), setting this option ensure that the "root" configuration file does not contain data duplicated in configuration file of others tree nodes. =item auto_vivify Scan and create data for nodes elements even if no actual data was stored in them. This may be useful to trap missing mandatory values. =item ordered_hash_as_list By default, ordered hash (i.e. the order of the keys are important) are dumped as Perl list. This is the faster way to dump such hashed while keeping the key order. But it's the less readable way. When this parameter is 1 (default), the ordered hash is dumped as a list: my_hash => [ A => 'foo', B => 'bar', C => 'baz' ] When this parameter is set as 0, the ordered hash is dumped with a special key that specifies the order of keys. E.g.: my_hash => { __my_hash_order => [ 'A', 'B', 'C' ] , B => 'bar', A => 'foo', C => 'baz' } =item to_boolean Sub reference to map a value of type boolean to a boolean class (since 2.129). For instance: to_boolean => sub { boolean($_[0]); } Default is C =back =head1 Methods =head2 dump_annotations_as_pod Return a string formatted in pod (See L) with the annotations. Parameters are: =over =item node Reference to a L object. Mandatory =item check_list Yes, no or skip =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L =cut libconfig-model-perl-2.155/lib/Config/Model/Dumper.pm000066400000000000000000000250021472064100600223240ustar00rootroot00000000000000package Config::Model::Dumper; use Carp; use strict; use warnings; use Config::Model::Exception; use Config::Model::ObjTreeScanner; use Config::Model::Value; sub new { bless {}, shift; } sub quote { _quote( qr/[\s~"#*]/, @_ ); } sub id_quote { _quote( qr/[\s~"@*<>.=#]/, @_ ); } sub _quote { my ( $re, @res ) = @_; foreach (@res) { if ( defined $_ and ( /$re/ or $_ eq '' ) ) { s/"/\\"/g; # escape present quotes $_ = '"' . $_ . '"'; # add my quotes } } return wantarray ? @res : $res[0]; } sub note_quote { my @res = @_; foreach (@res) { if ( defined $_ and $_ and (/(\s|"|\*)/) ) { s/"/\\"/g; # escape present quotes $_ = '"' . $_ . '"'; # add my quotes } } return wantarray ? @res : $res[0]; } sub dump_tree { my $self = shift; my %args = @_; my $full = delete $args{full_dump} || 0; my $skip_aw = delete $args{skip_auto_write} || ''; my $auto_v = delete $args{auto_vivify} || 0; my $mode = delete $args{mode} || ''; if ($full) { carp "dump_tree: full_dump parameter is deprecated, please use mode => 'user'"; } my $check = delete $args{check} || 'yes'; if ( $check !~ /yes|no|skip/ ) { croak "dump_tree: unexpected 'check' value: $check"; } # mode parameter is slightly different from fetch's mode my $fetch_mode = $full ? 'user' : $mode eq 'full' ? 'user' : $mode ? $mode : 'custom'; if ( my $err = Config::Model::Value->is_bad_mode($fetch_mode) ) { croak "dump_tree: $err"; } my $node = delete $args{node} || croak "dump_tree: missing 'node' parameter"; my $compute_pad = sub { my $depth = 0; my $obj = shift; while ( defined $obj->parent ) { $depth++; $obj = $obj->parent; } return ' ' x $depth; }; my $leaf_cb = sub { my ( $scanner, $data_r, $node, $element, $index, $value_obj ) = @_; # get value or only customized value my $value = quote( $value_obj->fetch( mode => $fetch_mode, check => $check ) ); $index = id_quote($index); my $pad = $compute_pad->($node); my $name = defined $index ? "$element:$index" : $element; # add annotation for obj contained in hash or list my $note = note_quote( $value_obj->annotation ); $$data_r .= "\n" . $pad . $name if defined $value or $note; if (defined $value) { $value =~ s/\\n/\\\\n/g; $$data_r .= '=' . $value; } $$data_r .= '#' . $note if $note; }; my $check_list_cb = sub { my ( $scanner, $data_r, $node, $element, $index, $value_obj ) = @_; # get value or only customized value my $value = $value_obj->fetch( mode => $fetch_mode, check => $check ); my $qvalue = quote($value); $index = id_quote($index); my $pad = $compute_pad->($node); my $name = defined $index ? "$element:$index" : $element; # add annotation for obj contained in hash or list my $note = note_quote( $value_obj->annotation ); $$data_r .= "\n" . $pad . $name if $value or $note; $$data_r .= '=' . $qvalue if $value; $$data_r .= '#' . $note if $note; }; my $list_element_cb = sub { my ( $scanner, $data_r, $node, $element, @keys ) = @_; my $pad = $compute_pad->($node); my $list_obj = $node->fetch_element($element); # add annotation for list element my $list_note = note_quote( $list_obj->annotation ); $$data_r .= "\n$pad$element#$list_note" if $list_note; if ( $list_obj->cargo_type eq 'node' ) { foreach my $k (@keys) { $scanner->scan_list( $data_r, $node, $element, $k ); } } else { # write value comments foreach my $idx ( $list_obj->fetch_all_indexes ) { my $note = $list_obj->fetch_with_id($idx)->annotation; $$data_r .= "\n$pad$element:$idx#" . note_quote($note) if $note; } # skip undef values my @val = id_quote( grep { defined $_ } $list_obj->fetch_all_values(mode => $fetch_mode, check => $check) ); $$data_r .= "\n$pad$element:=" . join( ',', @val ) if @val; } }; my $hash_element_cb = sub { my ( $scanner, $data_r, $node, $element, @keys ) = @_; my $pad = $compute_pad->($node); my $hash_obj = $node->fetch_element($element); # add annotation for list or hash element my $note = note_quote( $hash_obj->annotation ); $$data_r .= "\n$pad$element#$note" if $note; # resume exploration map { $scanner->scan_hash( $data_r, $node, $element, $_ ); } @keys; }; # called for nodes contained in nodes (not root). # This node can be held by a plain element or a hash element or a list element my $node_element_cb = sub { my ( $scanner, $data_r, $node, $element, $key, $contained_node ) = @_; my $type = $node->element_type($element); return if $skip_aw and $contained_node->is_auto_write_for_type($skip_aw); my $pad = $compute_pad->($node); my $elt = $node->fetch_element($element); # load string can feature only one comment per element_type # ie foo#comment foo:bar#comment foo:bar=val#comment are fine # but foo#comment:bar if not valid -> foo#commaent foo:bar my $head = "\n$pad$element"; my $node_note = note_quote( $contained_node->annotation ); if ( $type eq 'list' or $type eq 'hash' ) { $head .= ':' . id_quote($key); $head .= '#' . $node_note if $node_note; my $sub_data = ''; $scanner->scan_node( \$sub_data, $contained_node ); $$data_r .= $head . $sub_data . ' -'; } else { $head .= '#' . $node_note if $node_note; my $sub_data = ''; $scanner->scan_node( \$sub_data, $contained_node ); # skip simple nodes that do not bring data $$data_r .= $head . $sub_data . ' -' if $sub_data; } }; my @scan_args = ( fallback => 'all', auto_vivify => $auto_v, list_element_cb => $list_element_cb, hash_element_cb => $hash_element_cb, leaf_cb => $leaf_cb, node_element_cb => $node_element_cb, check_list_element_cb => $check_list_cb, check => $check, ); my @left = keys %args; croak "Dumper: unknown parameter:@left" if @left; # perform the scan my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args); my $ret = ''; my $root_note = note_quote( $node->annotation ); $ret .= "\n#$root_note" if $root_note; $view_scanner->scan_node( \$ret, $node ); substr( $ret, 0, 1, '' ); # remove leading \n $ret .= ' -' if $ret; return $ret . "\n"; } 1; # ABSTRACT: Serialize data of config tree __END__ =head1 SYNOPSIS use Config::Model ; # define configuration tree object my $model = Config::Model->new ; $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put some data in config tree the hard way $root->fetch_element('foo')->store('yada') ; $root->fetch_element('bar')->store('bla bla') ; $root->fetch_element('baz')->fetch_with_id('en')->store('hello') ; # put more data the easy way my $steps = 'baz:fr=bonjour baz:hr="dobar dan"'; $root->load( steps => $steps ) ; # dump only customized data print $root->dump_tree; =head1 DESCRIPTION This module is used directly by L to serialize configuration data in a compact (but readable) string. The serialization can be done in standard mode where only customized values are dumped in the string. I.e. only data modified by the user are dumped. All other mode supported by L can be used, for instance, to get default values. The serialized string can be used by L to store the data back into a configuration tree. Note that undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the dump then contains C<'a','b'>. =head1 CONSTRUCTOR =head2 new No parameter. The constructor should be used only by L. =head1 Methods =head2 dump_tree Return a string that contains a dump of the object tree with all the values. This string follows the convention defined by L. The serialized string can be used by L to store the data back into a configuration tree. Parameters are: =over =item mode C dumps all configuration data including default values. All mode values from L can be used. By default, the dump contains only data modified by the user (i.e. C data that differ from default or preset values). =item node Reference to the L object that is dumped. All nodes and leaves attached to this node are also dumped. =item skip_auto_write ( ) Skip node that have a write capability matching C in their model. See L. This option must be used when using Dumper to write back configuration data. When a configuration model contains several backends (one at the tree root and others in tree nodes), setting this option ensure that the "root" configuration file does not contain data duplicated in configuration file of others tree nodes. =item auto_vivify Scan and create data for nodes elements even if no actual data was stored in them. This may be useful to trap missing mandatory values. (default: 0) =item check Check value before dumping. Valid check are 'yes', 'no' and 'skip'. =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L =cut libconfig-model-perl-2.155/lib/Config/Model/Exception.pm000066400000000000000000000325711472064100600230370ustar00rootroot00000000000000package Config::Model::Exception; use warnings; use strict; use Data::Dumper; use Mouse; use v5.20; use Carp; use feature qw/postderef signatures/; no warnings qw/experimental::postderef experimental::signatures/; @Carp::CARP_NOT=qw/Config::Model::Exception Config::Model::Exception::Any/; our $trace = 0; use Carp qw/longmess shortmess croak/; use overload '""' => \&full_msg_and_trace, 'bool' => \&is_error; has description => ( is => 'ro', isa => 'Str', lazy_build => 1 ); sub _build_description { my $self = shift; return $self->_desc; } sub _desc { 'config error' } has object => ( is => 'rw', isa => 'Ref') ; has info => (is => 'rw', isa =>'Str', default => ''); has message => (is => 'rw', isa =>'Str', default => ''); has error => (is => 'rw', isa =>'Str', default => ''); has trace => (is => 'rw', isa =>'Str', default => ''); # need to keep these objects around: in some tests the error() method is # called after the instance is garbage collected. Instances are kept # as weak ref in node (and othe tree objects). When instance is # garbage collected, it's destroyed so error() can no longer be invoked. # Solution: keep instance as error attributes. has instance => ( is => 'rw', isa => 'Ref') ; sub BUILD ($self, $) { $self->instance($self->object->instance) if defined $self->object; } # without this overload, a test like if ($@) invokes '""' overload sub is_error { return ref ($_[0])} sub Trace { $trace = shift; } sub error_or_msg { my $self = shift; return $self->error || $self->message; } sub throw { my $class = shift; my $self = $class->new(@_); # when an exception is thrown, caught and rethrown, the first full # trace (provided by longmess) is clobbered by a second, shorter # trace (also provided by longmess). To avoid that, the first # trace must be stored. $self->trace($trace ? longmess : '') ; die $self; } sub rethrow { my $self = shift; die $self; } sub full_msg_and_trace { my $self = shift; my $msg = $self->full_message; $msg .= $self->trace; return $msg; } sub as_string { goto &full_msg_and_trace; } sub full_message { my $self = shift; my $obj = $self->object; my $location = defined $obj ? $obj->name : ''; my $msg = "Configuration item "; $msg .= "'$location' " if $location; $msg .= "has a " . $self->description; $msg .= ":\n\t" . ($self->error || $self->message) . "\n"; $msg .= $self->info . "\n" if $self->info; return $msg; } package Config::Model::Exception::Any; use Mouse; extends 'Config::Model::Exception'; package Config::Model::Exception::ModelDeclaration; use Mouse; extends 'Config::Model::Exception::Fatal'; sub _desc {'configuration model declaration error' } package Config::Model::Exception::User ; use Mouse; extends 'Config::Model::Exception::Any'; sub _desc {'user error' } ## old classes below package Config::Model::Exception::Syntax; use Mouse; extends 'Config::Model::Exception::Any'; sub _desc { 'syntax error' } has [qw/parsed_file parsed_line/] => (is => 'rw'); sub full_message { my $self = shift; my $fn = $self->parsed_file || '?'; my $line = $self->parsed_line || '?'; my $msg = "File $fn line $line "; $msg .= "has a " . $self->description; $msg .= ":\n\t" . $self->error_or_msg . "\n"; return $msg; } package Config::Model::Exception::LoadData; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'Load data structure (perl) error' }; has wrong_data => (is => 'rw'); sub full_message { my $self = shift; my $obj = $self->object; my $location = defined $obj ? $obj->name : ''; my $msg = "Configuration item "; my $d = Data::Dumper->new( [ $self->wrong_data ], ['wrong data'] ); $d->Sortkeys(1); $msg .= "'$location' " if $location; $msg .= "(class " . $obj->config_class_name . ") " if $obj->get_type eq 'node'; $msg .= "has a " . $self->description; $msg .= ":\n\t" . $self->error_or_msg . "\n"; $msg .= $d->Dump; return $msg; } package Config::Model::Exception::Model; use Carp; use Mouse; extends 'Config::Model::Exception::Fatal'; sub _desc { 'configuration model error'} sub full_message { my $self = shift; my $obj = $self->object || croak "Internal error: no object parameter passed while throwing exception"; my $msg; if ( $obj->isa('Config::Model::Node') ) { $msg = "Node '" . $obj->name . "' of class " . $obj->config_class_name . ' '; } else { my $element = $obj->element_name; my $level = $obj->parent->get_element_property( element => $element, property => 'level' ); my $location = $obj->location; $msg = "In config class '" . $obj->parent->config_class_name. "',"; $msg .= " (location: $location)" if $location; $msg .= " element '$element' (level $level) "; } $msg .= "has a " . $self->description; $msg .= ":\n\t" . $self->error_or_msg . "\n"; return $msg; } package Config::Model::Exception::Load; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'Load command error'} has command => (is => 'rw', isa => 'ArrayRef|Str'); sub full_message { my $self = shift; my $location = defined $self->object ? $self->object->name : ''; my $msg = $self->description; my $cmd = $self->command; no warnings 'uninitialized'; my $cmd_str = ref($cmd) ? join('',@$cmd) : $cmd ? "'$cmd'" : defined $cmd ? '' : ''; $msg .= " in node '$location' " if $location; $msg .= ':'; $msg .= "\n\tcommand: $cmd_str"; $msg .= "\n\t" . $self->error_or_msg . "\n"; return $msg; } package Config::Model::Exception::UnavailableElement; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'unavailable element'} has [qw/element function/] => (is => 'rw', isa => 'Str'); sub full_message { my $self = shift; my $obj = $self->object; my $location = $obj->name; my $msg = $self->description; my $element = $self->element; my $function = $self->function; my $unavail = $obj->fetch_element( name => $element, check => 'no', accept_hidden => 1 ); $msg .= " '$element' in node '$location'.\n"; $msg .= "\tError occurred when calling $function.\n" if defined $function; $msg .= "\t" . $unavail->warp_error if $unavail->can('warp_error'); $msg .= "\t" . $self->info . "\n" if defined $self->info; return $msg; } package Config::Model::Exception::AncestorClass; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'unknown ancestor class'} package Config::Model::Exception::ObsoleteElement; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'Obsolete element' } has element => (is => 'rw', isa => 'Str'); sub full_message { my $self = shift; my $obj = $self->object; my $element = $self->element; my $msg = $self->description; my $location = $obj->name; my $help = $obj->get_help_as_text($element) || ''; $msg .= " '$element' in node '$location'.\n"; $msg .= "\t$help\n"; $msg .= "\t" . $self->info . "\n" if defined $self->info; return $msg; } package Config::Model::Exception::UnknownElement; use Carp; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'unknown element' } has [qw/element function where autoadd/] => (is => 'rw'); sub full_message { my $self = shift; my $obj = $self->object; confess "Exception::UnknownElement: object is ", ref($obj), ". Expected a node" unless ref($obj) && ($obj->isa('Config::Model::Node') || $obj->isa('Config::Model::WarpedNode')); my $class_name = $obj->config_class_name; # class_name is undef if the warped_node is warped out my @elements; @elements = $obj->get_element_name( class => $class_name, ) if defined $class_name; my $msg = ''; $msg .= "Configuration path '" . $self->where . "': " if defined $self->where; $msg .= "(function '" . $self->function . "') " if defined $self->function; $msg = "object '" . $obj->name . "' error: " unless $msg; $msg .= $self->description . " '" . $self->element . "'."; # retrieve a support url from application info to guide user toward the right bug tracker my $info = $obj->instance->get_support_info // 'to https://github.com/dod38fr/config-model/issues'; $msg .= " Either your file has an error or $class_name model is lagging behind. " . "In the latter case, please submit a bug report $info. See cme man " . "page for details.\n"; if (@elements) { $msg .= "\tExpected elements: '" . join( "','", @elements ) . "'\n"; } else { $msg .= " (node is warped out)\n"; } my @match_keys = $obj->can('accept_regexp') ? $obj->accept_regexp() : (); if (@match_keys and $self->autoadd) { $msg .= "\tor an acceptable parameter matching '" . join( "','", @match_keys ) . "'\n"; } # inform about available elements after a change of warp master value if ( defined $obj->parent ) { my $parent = $obj->parent; my $element_name = $obj->element_name; if ( $parent->element_type($element_name) eq 'warped_node' ) { $msg .= "\t" . $parent->fetch_element( name => $element_name, qw/check no accept_hidden 1/ )->warp_error; } } $msg .= "\t" . $self->info . "\n" if ( defined $self->info ); return $msg; } package Config::Model::Exception::WarpError; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'warp error'} package Config::Model::Exception::Fatal; use Mouse; extends 'Config::Model::Exception::Any'; sub _desc { 'fatal error' } package Config::Model::Exception::UnknownId; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'unknown identifier'} has [qw/element id function where/] => (is => 'rw', isa => 'Str'); sub full_message { my $self = shift; my $obj = $self->object; my $element = $self->element; my $id_str = "'" . join( "','", $obj->fetch_all_indexes() ) . "'"; my $msg = ''; $msg .= "In function " . $self->function . ": " if defined $self->function; $msg .= "In " . $self->where . ": " if defined $self->where; $msg .= $self->description . " '" . $self->id() . "'" . " for element '" . $obj->location . "'\n\texpected: $id_str\n"; return $msg; } package Config::Model::Exception::WrongValue; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'wrong value'}; package Config::Model::Exception::WrongType; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'wrong element type' }; has [qw/function got_type/] => (is => 'rw', isa => 'Str'); has [qw/expected_type/] => (is => 'rw'); sub full_message { my $self = shift; my $obj = $self->object; my $msg = ''; $msg .= "In function " . $self->function . ": " if defined $self->function; my $type = $self->expected_type; $msg .= $self->description . " for element '" . $obj->location . "'\n\tgot type '" . $self->got_type . "', expected '" . (ref $type ? join("' or '",@$type) : $type) . "' " . $self->info . "\n"; return $msg; } package Config::Model::Exception::ConfigFile; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'error in configuration file' } package Config::Model::Exception::ConfigFile::Missing; use Mouse; use Mouse::Util::TypeConstraints; extends 'Config::Model::Exception::ConfigFile'; sub _desc { 'missing configuration file'} subtype 'ExcpPathTiny', as 'Object', where {$_->isa('Path::Tiny')} ; has file => (is => 'rw', isa => 'Str | ExcpPathTiny' ); sub full_message { my $self = shift; return "Error: cannot find configuration file " . $self->file . "\n"; } package Config::Model::Exception::Formula; use Mouse; extends 'Config::Model::Exception::Model'; sub _desc { 'error in computation formula of the configuration model'} package Config::Model::Exception::Internal; use Mouse; extends 'Config::Model::Exception::Fatal'; sub _desc { 'internal error' } 1; # ABSTRACT: Exception mechanism for configuration model __END__ =head1 SYNOPSIS use Config::Model::Exception; # later my $kaboom = 1; Config::Model::Exception::Model->throw( error => "Went kaboom", object => $self ) if $kaboom; =head1 DESCRIPTION This module creates exception classes used by L. All exception class name begins with C The exception classes are: =over =item C Base class. It accepts an C argument. The user must pass the reference of the object where the exception occurred. The object name is used to generate the error message. =back TODO: list all exception classes and hierarchy. =head1 How to get trace By default, most of the exceptions do not print out the stack trace. For debug purpose, you can force a stack trace for all exception classes: Config::Model::Exception->Trace(1) ; =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L =cut libconfig-model-perl-2.155/lib/Config/Model/FuseUI.pm000066400000000000000000000246711472064100600222430ustar00rootroot00000000000000package Config::Model::FuseUI; # there's no Singleton with Mouse use Mouse; use Fuse qw(fuse_get_context); use Fcntl ':mode'; use POSIX qw(ENOENT EISDIR EINVAL); use Log::Log4perl qw(get_logger :levels); use English qw( -no_match_vars ); has model => ( is => 'rw', isa => 'Config::Model' ); has root => ( is => 'ro', isa => 'Config::Model::Node', required => 1 ); has mountpoint => ( is => 'ro', isa => 'Str', required => 1 ); my $logger = get_logger("FuseUI"); has dir_char_mockup => ( is => 'ro', isa => 'Str', default => '' ); our $fuseui; my $dir_char_mockup; sub BUILD { my $self = shift; croak( __PACKAGE__, " singleton constructed twice" ) if defined $fuseui and $fuseui ne $self; $fuseui = $self; # store singleton object in global variable $dir_char_mockup = $self->dir_char_mockup; } # nodes, list and hashes are directories sub getdir { my $name = shift; $logger->trace("FuseUI getdir called with $name"); my $obj = get_object($name); return -EINVAL() unless ( ref $obj and $obj->can('children') ); my @c = ( '..', '.', $obj->children ); for (@c) { s(/)($dir_char_mockup)g }; $logger->debug( "FuseUI getdir return @c , wantarray is " . ( wantarray ? 1 : 0 ) ); return ( @c, 0 ); } sub fetch_as_line { my $obj = shift; my $v = $obj->fetch( check => 'no' ); $v = '' unless defined $v; # let's append a \n so that returned files always have a line ending $v .= "\n" unless $v =~ /\n$/; return $v; } sub get_object { my $name = shift; return _get_object( $name, 0 ); } sub get_or_create_object { my $name = shift; return _get_object( $name, 1 ); } sub _get_object { my ( $name, $autoadd ) = @_; my $obj = $fuseui->root->get( path => $name, check => 'skip', get_obj => 1, autoadd => $autoadd, dir_char_mockup => $dir_char_mockup ); $logger->debug( "FuseUI _get_object on $name returns ", ( defined $obj ? $obj->name : '' ) ); return $obj; } sub getattr { my $name = shift; $logger->trace("FuseUI getattr called with $name"); my $obj = get_object($name); return -&ENOENT() unless ref $obj; my $type = $obj->get_type; # return -ENOENT() unless exists($files{$file}); my $size; if ( $type eq 'leaf' or $type eq 'check_list' ) { $size = length( fetch_as_line($obj) ); } else { # fuseui_obj->children does not return the right data in scalar context my @c = $obj->children; $size = @c; } my $mode; if ( $type eq 'leaf' or $type eq 'check_list' ) { $mode = S_IFREG | oct(644); } else { $mode = S_IFDIR | oct(755); } my ( $dev, $ino, $rdev, $blocks, $gid, $uid, $nlink, $blksize ) = ( 0, 0, 0, 1, $EGID, $EUID, 1, 1024 ); my ( $atime, $ctime, $mtime ); $atime = $ctime = $mtime = time; # 2 possible types of return values: #return -ENOENT(); # or any other error you care to #print(join(",",($dev,$ino,$modes,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks)),"\n"); my @r = ( $dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks ); $logger->trace( "FuseUI getattr returns '" . join( "','", @r ) . "'" ); return @r; } sub open { # VFS sanity check; it keeps all the necessary state, not much to do here. my $name = shift; $logger->trace("FuseUI open called on $name"); my $obj = $fuseui->root->get( path => $name, check => 'skip', get_obj => 1 ); my $type = $obj->get_type; return -ENOENT() unless defined $obj; return -EISDIR() unless ( $type eq 'leaf' or $type eq 'check_list' ); $logger->debug("FuseUI open on $name ok"); return 0; } sub read { # return an error numeric, or binary/text string. (note: 0 means EOF, "0" will # give a byte (ascii "0") to the reading program) my ( $name, $buf, $off ) = @_; $logger->trace("FuseUI read called on $name"); my $obj = get_or_create_object($name); my $type = $obj->get_type; return -ENOENT() unless defined $obj; return -EISDIR() unless ( $type eq 'leaf' or $type eq 'check_list' ); my $v = fetch_as_line($obj); return -EINVAL() if $off > length($v); return 0 if $off == length($v); my $ret = substr( $v, $off, $buf ); $logger->debug("FuseUI read returns '$ret'"); return "$ret"; } sub truncate { my ( $name, $off ) = @_; $logger->trace("FuseUI truncate called on $name with length $off"); my $obj = get_or_create_object($name); my $type = $obj->get_type; return -ENOENT() unless defined $obj; return -EISDIR() unless ( $type eq 'leaf' or $type eq 'check_list' ); my $v = substr fetch_as_line($obj), 0, $off; $logger->trace( "FuseUI truncate stores '$v' of length ", length($v) ); # store the value without any check. Check will be done in write() # the second parameter will trigger a notif_change. $obj->_store_value( $v, 1 ); return 0; } sub write { my ( $name, $buf, $off ) = @_; if ( $logger->is_trace ) { my $str = $buf; $str =~ s/\n/\\n/g; $logger->trace("FuseUI write called on $name with '$str' offset $off"); } my $obj = get_or_create_object($name); my $type = $obj->get_type; return -ENOENT() unless defined $obj; return -EISDIR() unless ( $type eq 'leaf' or $type eq 'check_list' ); my $v = fetch_as_line($obj); $logger->debug("FuseUI write starts with '$v'"); substr $v, $off, length($buf), $buf; chomp $v unless ( $type eq 'leaf' and $obj->value_type eq 'string' ); $logger->debug("FuseUI write stores '$v'"); $obj->store( value => $v, check => 'skip', say_dont_warn => 1 ); return length($buf); } sub mkdir { # return an error numeric, or binary/text string. (note: 0 means EOF, "0" will # give a byte (ascii "0") to the reading program) my ( $name, $mode ) = @_; $logger->trace("FuseUI mkdir called on $name with mode $mode"); my $obj = get_or_create_object($name); return -ENOENT() unless defined $obj; my $type = $obj->container_type; return -ENOENT() unless ( $type eq 'list' or $type eq 'hash' ); return 0; } sub rmdir { # return an error numeric, or binary/text string. (note: 0 means EOF, "0" will # give a byte (ascii "0") to the reading program) my ($name) = @_; $logger->trace("FuseUI rmdir called on $name"); my $obj = get_object($name); return -ENOENT() unless defined $obj; my $type = $obj->get_type; return -ENOENT() if ( $type eq 'leaf' or $type eq 'check_list' ); my $ct = $obj->container_type; my $elt_name = $obj->element_name; my $parent = $obj->parent; if ( $ct eq 'list' or $ct eq 'hash' ) { my $idx = $obj->index_value; $logger->debug("FuseUI rmdir actually deletes $idx"); $parent->fetch_element($elt_name)->delete($idx); } # ignore deletion request for other "non deletable" elements return 0; } sub unlink { my ($name) = @_; $logger->debug("FuseUI unlink called on $name"); my $obj = get_object($name); my $type = $obj->get_type; return -ENOENT() unless defined $obj; return -EISDIR() unless ( $type eq 'leaf' or $type eq 'check_list' ); my $ct = $obj->container_type; my $elt_name = $obj->element_name; my $parent = $obj->parent; if ( $ct eq 'list' or $ct eq 'hash' ) { my $idx = $obj->index_value; $logger->debug("FuseUI unlink actually deletes $idx"); $parent->fetch_element($elt_name)->delete($name); } # ignore deletion request for other "non deletable" elements return 0; } sub statfs { return 255, 1, 1, 1, 1, 2 } my @methods = map { ( $_ => __PACKAGE__ . "::$_" ) } qw/getattr getdir open read write statfs truncate unlink mkdir rmdir/; # FIXME: flush release # maybe also: readlink mknod symlink rename link chmod chown utime sub run_loop { my ( $self, %args ) = @_; my $debug = $args{debug} || 0; Fuse::main( mountpoint => $self->mountpoint, @methods, debug => $debug || 0, threaded => 0, ); } 1; # ABSTRACT: Fuse virtual file interface for Config::Model __END__ =head1 SYNOPSIS # command line mkdir mydir cme fusefs popcon -fuse-dir mydir ll mydir fusermount -u mydir # programmatic use Config::Model ; use Config::Model::FuseUI ; my $model = Config::Model -> new; my $root = $model -> instance (root_class_name => "PopCon") -> config_root ; my $ui = Config::Model::FuseUI->new( root => $root, mountpoint => "mydir" ); $ui -> run_loop ; # blocking call # explore mydir in another terminal then umount mydir directory =head1 DESCRIPTION This module provides a virtual file system interface for you configuration data. Each possible parameter of your configuration file is mapped to a file. =head1 Example $ cme fusefs popcon -fuse-dir fused Mounting config on fused in background. Use command 'fusermount -u fused' to unmount $ ll fused total 4 -rw-r--r-- 1 domi domi 1 Dec 8 19:27 DAY -rw-r--r-- 1 domi domi 0 Dec 8 19:27 HTTP_PROXY -rw-r--r-- 1 domi domi 0 Dec 8 19:27 MAILFROM -rw-r--r-- 1 domi domi 0 Dec 8 19:27 MAILTO -rw-r--r-- 1 domi domi 32 Dec 8 19:27 MY_HOSTID -rw-r--r-- 1 domi domi 3 Dec 8 19:27 PARTICIPATE -rw-r--r-- 1 domi domi 0 Dec 8 19:27 SUBMITURLS -rw-r--r-- 1 domi domi 3 Dec 8 19:27 USEHTTP $ fusermount -u fuse_dir =head1 BUGS =over =item * For some configuration, mapping each parameter to a file may lead to a high number of files. =item * The content of a file is when writing a wrong value. I.e. the files is empty and the old value is lost. =back =head1 constructor =head1 new parameters are: =over =item model Config::Model object =item root Root of the configuration tree (C object ) =item mountpoint =back =head1 Methods =head2 run_loop Parameters: C<< ( fork_in_loop => 1|0, debug => 1|0 ) >> Mount the file system either in the current process or fork a new process before mounting the file system. In the former case, the call is blocking. In the latter case, the call returns after forking a process that performs the mount. Debug parameter is passed to Fuse system to get traces from Fuse. =head2 fuse_mount Mount the fuse file system. This method blocks until the file system is unmounted (with C command) =cut =head1 SEE ALSO L, L, L libconfig-model-perl-2.155/lib/Config/Model/HashId.pm000066400000000000000000000436111472064100600222360ustar00rootroot00000000000000package Config::Model::HashId; use Mouse; use 5.20.0; use Config::Model::Exception; use Carp; use Mouse::Util::TypeConstraints; use feature qw/postderef signatures/; no warnings qw/experimental::postderef experimental::signatures/; subtype 'HaskKeyArray' => as 'ArrayRef' ; coerce 'HaskKeyArray' => from 'Str' => via { [$_] } ; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger("Tree::Element::Id::Hash"); extends qw/Config::Model::AnyId/; with "Config::Model::Role::Grab"; with "Config::Model::Role::ComputeFunction"; has data => ( is => 'rw', isa => 'HashRef', default => sub { {}; } ); has list => ( is => 'rw', isa => 'ArrayRef[Str]', traits => ['Array'], default => sub { []; }, handles => { _sort => 'sort_in_place', } ); has [qw/default_keys auto_create_keys/] => ( is => 'rw', isa => 'HaskKeyArray', coerce => 1, default => sub { []; } ); has [qw/ordered write_empty_value/] => ( is => 'ro', isa => 'Bool', default => 0 ); sub BUILD ($self,$) { # foreach my $wrong (qw/migrate_values_from/) { # Config::Model::Exception::Model->throw ( # object => $self, # error => "Cannot use $wrong with ".$self->get_type." element" # ) if defined $self->{$wrong}; # } # could use "required", but we'd get a Moose error instead of a Config::Model # error Config::Model::Exception::Model->throw( object => $self, error => "Undefined index_type" ) unless defined $self->index_type; return $self; } sub set_properties ($self, @args) { $self->SUPER::set_properties(@args); my $idx_type = $self->{index_type}; # remove unwanted items my $data = $self->{data}; my $idx = 1; my $wrong = sub { my $k = shift; if ( $idx_type eq 'integer' ) { return 1 if defined $self->{max_index} and $k > $self->{max_index}; return 1 if defined $self->{min_index} and $k < $self->{min_index}; } return 1 if defined $self->{max_nb} and $idx++ > $self->{max_nb}; return 0; }; # delete entries that no longer fit the constraints imposed by the # warp mechanism foreach my $k ( sort keys %$data ) { next unless $wrong->($k); $logger->trace( "set_properties: ", $self->name, " deleting id $k" ); delete $data->{$k}; } return; } sub _migrate ($self) { return if $self->{migration_done}; # migration must be done *after* initial load to make sure that all data # were retrieved from the file before migration. return if $self->instance->initial_load; $self->{migration_done} = 1; if ( $self->{migrate_keys_from} ) { my $followed = $self->safe_typed_grab( param => 'migrate_keys_from', check => 'no' ); if ( $logger->is_debug ) { $logger->debug( $self->name, " migrate keys from ", $followed->name ); } for my $idx ($followed->fetch_all_indexes) { $self->_store( $idx, undef ) unless $self->_defined($idx); } } elsif ( $self->{migrate_values_from} ) { my $followed = $self->safe_typed_grab( param => 'migrate_values_from', check => 'no' ); $logger->debug( $self->name, " migrate values from ", $followed->name ) if $logger->is_debug; foreach my $item ( $followed->fetch_all_indexes ) { next if $self->exists($item); # don't clobber existing entries my $data = $followed->fetch_with_id($item)->dump_as_data( check => 'no' ); $self->fetch_with_id($item)->load_data($data); } } return; } sub get_type ($self) { return 'hash'; } sub get_info ($self) { my @items = ( 'type: ' . $self->get_type . ( $self->ordered ? '(ordered)' : '' ), 'index: ' . $self->index_type, 'cargo: ' . $self->cargo_type, ); if ( $self->cargo_type eq 'node' ) { push @items, "cargo class: " . $self->config_class_name; } foreach my $what (qw/min_index max_index max_nb warn_if_key_match warn_unless_key_match/) { my $v = $self->$what(); my $str = $what; $str =~ s/_/ /g; push @items, "$str: $v" if defined $v; } return @items; } # important: return the actual size (not taking into account auto-created stuff) sub fetch_size ($self) { return scalar keys %{ $self->{data} }; } sub _fetch_all_indexes ($self) { return $self->{ordered} ? @{ $self->{list} } : sort keys %{ $self->{data} }; } # fetch without any check sub _fetch_with_id ($self, $key) { return $self->{data}{$key}; } # store without any check sub _store ($self, $key, $value) { push @{ $self->{list} }, $key unless exists $self->{data}{$key}; $self->notify_change(note => "added entry $key") if $self->write_empty_value; return $self->{data}{$key} = $value; } sub _exists ($self, $key) { return exists $self->{data}{$key}; } sub _defined { my ( $self, $key ) = @_; return defined $self->{data}{$key} ? 1 : 0; } #internal sub auto_create_elements ($self) { my $auto_p = $self->auto_create_keys; return unless defined $auto_p; # create empty slots foreach my $slot ( ref $auto_p ? @$auto_p : ($auto_p) ) { $self->_store( $slot, undef ) unless exists $self->{data}{$slot}; } return; } # internal sub create_default ($self) { my @temp = keys %{ $self->{data} }; return if @temp; # hash is empty so create empty element for default keys my $def = $self->get_default_keys; map { $self->_store( $_, undef ) } @$def; $self->create_default_with_init; return; } sub _delete ( $self, $key ) { # remove key in ordered list @{ $self->{list} } = grep { $_ ne $key } @{ $self->{list} }; return delete $self->{data}{$key}; } sub remove ($self, @args) { return $self->delete(@args); } sub _clear ($self) { $self->{list} = []; $self->{data} = {}; return; } ## no critic (Subroutines::ProhibitBuiltinHomonyms) sub sort ($self) { if ($self->ordered) { $self->_sort; } else { Config::Model::Exception::User->throw( object => $self, message => "cannot call sort on non ordered hash" ); } return; } sub insort ($self, $id) { if ($self->ordered) { my $elt = $self->fetch_with_id($id); $self->_sort; return $elt; } else { Config::Model::Exception::User->throw( object => $self, message => "cannot call insort on non ordered hash" ); } return; } # hash only method sub firstkey ($self) { $self->warp if ( $self->{warp} and @{ $self->{warp_info}{computed_master} } ); $self->create_default if defined $self->{default}; # reset "each" iterator (to be sure, map is also an iterator) my @list = $self->_fetch_all_indexes; $self->{each_list} = \@list; return shift @list; } # hash only method sub nextkey ($self) { $self->warp if ( $self->{warp} and @{ $self->{warp_info}{computed_master} } ); my $res = shift @{ $self->{each_list} }; return $res if defined $res; # reset list for next call to next_keys $self->{each_list} = [ $self->_fetch_all_indexes ]; return; } sub swap ($self, $key1, $key2 ) { foreach my $k ($key1, $key2) { Config::Model::Exception::User->throw( object => $self, message => "swap: unknow key $k" ) unless exists $self->{data}{$k}; } my @copy = @{ $self->{list} }; for ( my $idx = 0 ; $idx <= $#copy ; $idx++ ) { if ( $copy[$idx] eq $key1 ) { $self->{list}[$idx] = $key2; } if ( $copy[$idx] eq $key2 ) { $self->{list}[$idx] = $key1; } } $self->notify_change( note => "swap ordered hash keys '$key1' and '$key2'" ); return; } sub move ($self, $from, $to, %args) { $logger->trace("moving item from $from to $to"); Config::Model::Exception::User->throw( object => $self, message => "move: unknow from key $from" ) unless exists $self->{data}{$from}; my $ok = $self->check_idx($to); my $check = $args{check}; if ($ok or $check eq 'no') { # this places $to at the end of the ordered list (for ordered hash) $self->copy($from, $to); $self->notify_change( note => "rename key from '$from' to '$to'" ); # data_mode is preset or layered or user. Actually only user # mode makes sense here my $imode = $self->instance->get_data_mode; $self->set_data_mode( $to, $imode ); # find where are $to and $from keys my ( $to_idx, $from_idx ); my $list = $self->{list}; for (my $idx = 0; $idx <= $#$list; $idx++) { $to_idx = $idx if $list->[$idx] eq $to; $from_idx = $idx if $list->[$idx] eq $from; } # replace $from with $to in the order list of the ordered hash # Since $to is clobbered, $from takes its place in the list $list->[$from_idx] = $to; # and the obsolete place for $to entry is removed from the list splice @$list, $to_idx, 1; $self->_delete($from); delete $self->{warning_hash}{$from}; } elsif ($check eq 'yes') { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{error} } ), object => $self ); } $logger->debug("Skipped move $from -> $to"); return $ok; } sub move_after ($self, $key_to_move, $ref_key = undef) { if ( not $self->ordered ) { $logger->warn("called move_after on unordered hash"); return; } foreach my $k ($key_to_move, $ref_key) { next unless defined $k; Config::Model::Exception::User->throw( object => $self, message => "swap: unknow key $k" ) unless exists $self->{data}{$k}; } # remove the key to move in ordered list @{ $self->{list} } = grep { $_ ne $key_to_move } @{ $self->{list} }; my $list = $self->{list}; my $msg; if ( defined $ref_key ) { for ( my $idx = 0 ; $idx <= $#$list ; $idx++ ) { if ( $list->[$idx] eq $ref_key ) { splice @$list, $idx + 1, 0, $key_to_move; last; } } $msg = "moved key '$key_to_move' after '$ref_key'"; } else { unshift @$list, $key_to_move; $msg = "moved key '$key_to_move' at beginning"; } $self->notify_change( note => $msg ); return; } sub move_up ($self, $key) { if ( not $self->ordered ) { $logger->warn("called move_up on unordered hash"); return; } Config::Model::Exception::User->throw( object => $self, message => "move_up: unknow key $key" ) unless exists $self->{data}{$key}; my $list = $self->{list}; # we start from 1 as we can't move up idx 0 for ( my $idx = 1 ; $idx < scalar @$list ; $idx++ ) { if ( $list->[$idx] eq $key ) { $list->[$idx] = $list->[ $idx - 1 ]; $list->[ $idx - 1 ] = $key; $self->notify_change( note => "moved up key '$key'" ); last; } } # notify_change is placed in the loop so the notification # is not sent if the user tries to move up idx 0 return; } sub move_down ($self, $key) { if ( not $self->ordered ) { $logger->warn("called move_down on unordered hash"); return; } Config::Model::Exception::User->throw( object => $self, message => "move_down: unknown key $key" ) unless exists $self->{data}{$key}; my $list = $self->{list}; # we end at $#$list -1 as we can't move down last idx for ( my $idx = 0 ; $idx < scalar @$list - 1 ; $idx++ ) { if ( $list->[$idx] eq $key ) { $list->[$idx] = $list->[ $idx + 1 ]; $list->[ $idx + 1 ] = $key; $self->notify_change( note => "moved down key $key" ); last; } } # notify_change is placed in the loop so the notification # is not sent if the user tries to move past last idx return; } sub _load_data_from_hash ($self, %args) { my $data = $args{data}; my %backup = %$data ; my @ordered_keys; my $from = ''; my $order_key = '__'.$self->element_name.'_order'; if ( $self->{ordered} and (defined $data->{$order_key} or defined $data->{__order} )) { @ordered_keys = @{ delete $data->{$order_key} or delete $data->{__order} }; $from = ' with '.$order_key; } elsif ( $self->{ordered} and (not $data->{__skip_order} and keys %$data > 1)) { $logger->warn( "HashId " . $self->location . ": loading ordered " . "hash from hash ref without special key '__order'. Element " . "order is not defined. If needed, this warning can be suppressed by passing " . " key '__skip_order' set to 1." ); $from = ' without '.$order_key; } delete $data->{__skip_order}; if (@ordered_keys) { my %data_keys = map { $_ => 1 ; } keys %$data; my @left_keys; foreach my $k (@ordered_keys) { push @left_keys, $k unless delete $data_keys{$k}; } if ( %data_keys or @left_keys) { my @msg ; push @msg, "Unlisted keys in __order:", keys %data_keys if %data_keys; push @msg, "Extra keys in __order:", @left_keys if @left_keys; Config::Model::Exception::LoadData->throw( object => $self, message => "load_data: ordered keys mistmatch: @msg", wrong_data => \%backup, ); } } my @load_keys = @ordered_keys ? @ordered_keys : sort keys %$data; $logger->info( "HashId load_data (" . $self->location . ") will load idx @load_keys from hash ref $from" ); my $res = 0; foreach my $elt (@load_keys) { my $obj = $self->fetch_with_id($elt); $res += $obj->load_data( %args, data => $data->{$elt} ) if defined $data->{$elt}; } return !!$res; } sub load_data ($self, @args) { my %args = @args > 1 ? @args : ( data => $args[0] ); my $data = delete $args{data}; my $check = $self->_check_check( $args{check} ); if ( ref($data) eq 'HASH' ) { return $self->_load_data_from_hash(data => $data, %args); } elsif ( ref($data) eq 'ARRAY' ) { my $res = 0; $logger->info( "HashId load_data (" . $self->location . ") will load idx 0..$#$data from array ref" ); $self->notify_change( note => "Converted ordered data to non ordered", really => 1) unless $self->ordered; my $idx = 0; while ( $idx < @$data ) { my $elt = $data->[ $idx++ ]; my $obj = $self->fetch_with_id($elt); $res += $obj->load_data( %args, data => $data->[ $idx++ ] ); } return !!$res; } elsif ( defined $data ) { # we can skip undefined data my $expected = $self->{ordered} ? 'array' : 'hash'; Config::Model::Exception::LoadData->throw( object => $self, message => "load_data called with non $expected ref arg", wrong_data => $data, ); } return; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Handle hash element for configuration model __END__ =head1 SYNOPSIS See L =head1 DESCRIPTION This class provides hash elements for a L. The hash index can either be en enumerated type, a boolean, an integer or a string. =head1 CONSTRUCTOR HashId object should not be created directly. =head1 Hash model declaration See L from L. =head1 Methods =head2 get_type Returns C. =head2 fetch_size Returns the number of elements of the hash. =head2 sort Sort an ordered hash. Throws an error if called on a non ordered hash. =head2 insort Parameters: key Create a new element in the ordered hash while keeping alphabetical order of the keys Returns the newly created element. Throws an error if called on a non ordered hash. =head2 firstkey Returns the first key of the hash. Behaves like C core perl function. =head2 nextkey Returns the next key of the hash. Behaves like C core perl function. =head2 swap Parameters: C<< ( key1 , key2 ) >> Swap the order of the 2 keys. Ignored for non ordered hash. =head2 move Parameters: C<< ( key1 , key2 ) >> Rename key1 in key2. Also also optional check parameter to disable warning: move ('foo','bar', check => 'no') =head2 move_after Parameters: C<< ( key_to_move [ , after_this_key ] ) >> Move the first key after the second one. If the second parameter is omitted, the first key is placed in first position. Ignored for non ordered hash. =head2 move_up Parameters: C<< ( key ) >> Move the key up in a ordered hash. Attempt to move up the first key of an ordered hash is ignored. Ignored for non ordered hash. =head2 move_down Parameters: C<< ( key ) >> Move the key down in a ordered hash. Attempt to move up the last key of an ordered hash is ignored. Ignored for non ordered hash. =head2 load_data Parameters: C<< ( data => ( hash_ref | array_ref ) [ , check => ... , ... ]) >> Load data as a hash ref for standard hash. Ordered hash should be loaded with an array ref or with a hash containing a special C<__order> element. E.g. loaded with either: [ a => 'foo', b => 'bar' ] or { __order => ['a','b'], b => 'bar', a => 'foo' } C<__skip_order> parameter can be used if loading order is not important: { __skip_order => 1, b => 'bar', a => 'foo'} load_data can also be called with a single ref parameter. Return 1 of some data was loaded. =head2 get_info Returns a list of information related to the hash. See L for more details. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L =cut libconfig-model-perl-2.155/lib/Config/Model/IdElementReference.pm000066400000000000000000000240411472064100600245570ustar00rootroot00000000000000package Config::Model::IdElementReference; use Mouse; use Carp; use Config::Model::ValueComputer; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger("Tree::Element::IdElementReference"); # config_elt is a reference to the object that called new has config_elt => ( is => 'ro', isa => 'Config::Model::AnyThing', required => 1, weak_ref => 1 ); has refer_to => ( is => 'ro', isa => 'Maybe[Str]' ); has computed_refer_to => ( is => 'ro', isa => 'Maybe[HashRef]' ); sub BUILD { my $self = shift; my $found = scalar grep { defined $self->$_; } qw/refer_to computed_refer_to/; if ( not $found ) { Config::Model::Exception::Model->throw( object => $self->config_elt, message => "missing " . "refer_to or computed_refer_to parameter" ); } elsif ( $found > 1 ) { Config::Model::Exception::Model->throw( object => $self->config_elt, message => "cannot specify both " . "refer_to and computed_refer_to parameters" ); } my $rft = $self->{refer_to}; my $crft = $self->{computed_refer_to} || {}; my %c_args = %$crft; my $refer_path = defined $rft ? $rft : delete $c_args{formula}; # split refer_path on + then create as many ValueComputer as # required my @references = split /\s+\+\s+/, $refer_path; foreach my $single_path (@references) { push @{ $self->{compute} }, Config::Model::ValueComputer->new( formula => $single_path, variables => {}, %c_args, value_object => $self->{config_elt}, value_type => 'string' # a reference is always a string ); } return $self; } # internal # FIXME: do not call back value object -> may recurse sub get_choice_from_referred_to { my $self = shift; my $config_elt = $self->{config_elt}; my @enum_choice = $config_elt->get_default_choice; foreach my $compute_obj ( @{ $self->{compute} } ) { my $user_spec = $compute_obj->compute; next unless defined $user_spec; my @path = split( /\s+/, $user_spec ); $logger->trace("path: @path"); my $referred_to = eval { $config_elt->grab("@path"); }; if (ref $@) { my $e = $@; # don't use $e->full_description as it will recurse badly Config::Model::Exception::Model->throw( object => $config_elt, error => "'refer_to' parameter with path '@path': " .$e->description ); } my $element = pop @path; my $obj = $referred_to->parent; my $type = $obj->element_type($element); my @choice; if ( $type eq 'check_list' ) { @choice = $obj->fetch_element($element)->get_checked_list(); } elsif ( $type eq 'hash' ) { @choice = $obj->fetch_element($element)->fetch_all_indexes(); } elsif ( $type eq 'list' ) { my $list_obj = $obj->fetch_element($element); my $ct = $list_obj->get_cargo_type; if ( $ct eq 'leaf' ) { @choice = $list_obj->fetch_all_values( mode => 'user' ); } else { Config::Model::Exception::Model->throw( object => $obj, message => "element '$element' cargo_type is $ct. " . "Expected 'leaf'" ); } } else { Config::Model::Exception::Model->throw( object => $obj, message => "element '$element' type is $type. " . "Expected hash or list or check_list" ); } # use a hash so choices are unique push @enum_choice, @choice; } # prune out repeated items my %h; my @unique = grep { my $found = $h{$_} || 0; $h{$_} = 1; not $found; } @enum_choice; my @res; if ( $config_elt->value_type eq 'check_list' and $config_elt->ordered ) { @res = @unique; } else { @res = sort @unique; } $logger->debug( "Setting choice to '", join( "','", @res ), "'" ); $config_elt->setup_reference_choice(@res); } sub reference_info { my $self = shift; my $str = "choice was retrieved with: "; foreach my $compute_obj ( @{ $self->{compute} } ) { my $path = $compute_obj->formula; $path = defined $path ? "'$path'" : 'undef'; $str .= "\n\tpath $path"; $str .= "\n\t" . $compute_obj->compute_info; } return $str; } sub compute_obj { my $self = shift; return @{ $self->{compute} }; } sub reference_path { my $self = shift; return map { $_->formula } @{ $self->{compute} }; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Refer to id element(s) and extract keys __END__ =head1 SYNOPSIS # synopsis shows an example of model of a network to use references use Config::Model; my $model = Config::Model->new; # model of several hosts with several NICs $model->create_config_class( name => 'Host', 'element' => [ ip_nic => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'uniline', } }, ] ); # model to choose a master host and a master NIC (whatever that may be) # among configured hosts. Once these 2 are configured, the model computes # the master IP $model->create_config_class( name => "MyNetwork", element => [ host => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'Host' }, }, # master_host is one of the configured hosts master_host => { type => 'leaf', value_type => 'reference', # provided by tConfig::Model::IdElementReference refer_to => '! host' }, # master_nic is one NIC of the master host master_nic => { type => 'leaf', value_type => 'reference', # provided by tConfig::Model::IdElementReference computed_refer_to => { # provided by Config::Model::ValueComputer formula => ' ! host:$h ip_nic ', variables => { h => '- master_host' } } }, # provided by Config::Model::ValueComputer master_ip => { type => 'leaf', value_type => 'string', compute => { formula => '$ip', variables => { h => '- master_host', nic => '- master_nic', ip => '! host:$h ip_nic:$nic' } } }, ], ); my $inst = $model->instance(root_class_name => 'MyNetwork' ); my $root = $inst->config_root ; # configure hosts on my network my $steps = 'host:foo ip_nic:eth0=192.168.0.1 ip_nic:eth1=192.168.1.1 - host:bar ip_nic:eth0=192.168.0.2 ip_nic:eth1=192.168.1.2 - host:baz ip_nic:eth0=192.168.0.3 ip_nic:eth1=192.168.1.3 '; $root->load( steps => $steps ); print "master host can be one of ", join(' ',$root->fetch_element('master_host')->get_choice),"\n" ; # prints: master host can be one of bar baz foo # choose master host $root->load('master_host=bar') ; print "master NIC of master host can be one of ", join(' ',$root->fetch_element('master_nic')->get_choice),"\n" ; # prints: master NIC of master host can be one of eth0 eth1 # choose master nic $root->load('master_nic=eth1') ; # check what is the master IP computed by the model print "master IP is ",$root->grab_value('master_ip'),"\n"; # prints master IP is 192.168.1.2 =head1 DESCRIPTION This class is user by L to set up an enumerated value where the possible choice depends on the key of a L or the content of a L object. This class is also used by L to define the checklist items from the keys of another hash (or content of a list). =head1 CONSTRUCTOR Construction is handled by the calling object (L). =head1 Config class parameters =over =item refer_to C is used to specify a hash element that is used as a reference. C points to an array or hash element in the configuration tree using the path syntax (See L for details). =item computed_refer_to When C is used, the path is computed using values from several elements in the configuration tree. C is a hash with 2 mandatory elements: C and C. =back The available choice of this (computed or not) reference value is made from the available keys of the C hash element or the values of the C array element. The example means the the value must correspond to an existing host: value_type => 'reference', refer_to => '! host' This example means the the value must correspond to an existing lan within the host whose Id is specified by hostname: value_type => 'reference', computed_refer_to => { formula => '! host:$a lan', variables => { a => '- hostname' } } If you need to combine possibilities from several hash, use the "C<+>" token to separate 2 paths: value_type => 'reference', computed_refer_to => { formula => '! host:$a lan + ! host:foobar lan', variables => { a => '- hostname' } } You can specify C or C with a C argument so the possible enum value will be the combination of the specified choice and the referred_to values. =head1 Methods =head2 reference_info Returns a human readable string with explains how is retrieved the reference. This method is mostly used to construct an error messages. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L =cut libconfig-model-perl-2.155/lib/Config/Model/Instance.pm000066400000000000000000000642021472064100600226410ustar00rootroot00000000000000package Config::Model::Instance; #use Scalar::Util qw(weaken) ; use strict; use 5.10.1; use Mouse; use Mouse::Util::TypeConstraints; use MouseX::StrictConstructor; with "Config::Model::Role::NodeLoader"; use File::Path; use Path::Tiny; use Log::Log4perl qw(get_logger :levels); use Config::Model::TypeConstraints; use Config::Model::Exception; use Config::Model::Node; use Config::Model::Loader; use Config::Model::SearchElement; use Config::Model::Iterator; use Config::Model::ObjTreeScanner; use warnings ; use Carp qw/carp croak confess cluck/; my $logger = get_logger("Instance"); my $change_logger = get_logger("Anything::Change"); my $user_logger = get_logger("User"); has [qw/root_class_name/] => ( is => 'ro', isa => 'Str', required => 1 ); sub location { return "in instance" } has config_model => ( is => 'ro', isa => 'Config::Model', weak_ref => 1, required => 1 ); has check => ( is => 'ro', isa => 'Str', default => 'yes', reader => 'read_check', ); # used by cme -create option has auto_create => ( is => 'ro', isa => 'Bool', default => 0, ); # a unique (instance wise) placeholder for various tree objects # to store information has _safe => ( is => 'rw', isa => 'HashRef', traits => ['Hash'], default => sub { {} }, handles => { data => 'accessor', }, ); has appli_info => ( is => 'rw', isa => 'HashRef', traits => ['Hash'], default => sub { {} }, handles => { get_appli_info => 'get', # currying See Moose::Manual::Delegation get_support_info => [qw/get support_info/], }, ); # preset mode: to load values found by HW scan or other automatic scheme # layered mode: to load values found in included files (e.g. a la multistrap) # canonical mode: write config data back using model order instead of user order has [qw/preset layered canonical/] => ( is => 'ro', isa => 'Bool', default => 0, ); has changes => ( is => 'ro', isa => 'ArrayRef', traits => ['Array'], default => sub { [] }, handles => { add_change => 'push', c_count => 'count', has_changes => 'count', #needs_save => 'count' , clear_changes => 'clear', } ); sub needs_save { my $self = shift; my $arg = shift; if ( defined $arg ) { if ($arg) { croak "replace needs_save(1) call with add_change"; $self->add_change(); # may not work } else { croak "replace needs_save(0) call with clear_changes"; $self->clear_changes; } } return $self->c_count; } has errors => ( is => 'ro', isa => 'HashRef', traits => ['Hash'], default => sub { {} }, handles => { _set_error => 'set', cancel_error => 'delete', has_error => 'count', clear_errors => 'clear', error_paths => 'keys' } ); sub add_error { my $self = shift; $self->_set_error( shift, '' ); } sub error_messages { my $self = shift; my @errs = map { "$_: " . $self->config_root->grab($_)->error_msg } $self->error_paths; return wantarray ? @errs : join( "\n", @errs ); } sub has_warning { my $self = shift; my $count_leaf_warnings = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $$data_ref += $leaf_object->has_warning; }; my $count_list_warnings = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $$data_ref += $node->fetch_element($element_name)->has_warning; }; my $scan = Config::Model::ObjTreeScanner->new( leaf_cb => $count_leaf_warnings, list_element_hook => $count_list_warnings, hash_element_hook => $count_list_warnings, ); my $result = 0; $scan->scan_node( \$result, $self->config_root ); return $result; } has on_change_cb => ( is => 'rw', traits => ['Code'], isa => 'CodeRef', default => sub { sub { } }, ); has on_message_cb => ( traits => ['Code'], is => 'rw', isa => 'CodeRef', default => sub { sub { say @_; } }, handles => { show_message => 'execute', }, ); # initial_load mode: when data is loaded the first time has initial_load => ( is => 'rw', isa => 'Bool', default => 0, trigger => \&_trace_initial_load, traits => [qw/Bool/], handles => { initial_load_start => 'set', initial_load_stop => 'unset', } ); sub _trace_initial_load { my ( $self, $n, $o ) = @_; $logger->debug("switched to $n"); } # This array holds a set of sub ref that will be invoked when # the user requires to write all configuration tree in their # backend storage. has _write_back => ( is => 'ro', isa => 'HashRef', traits => ['Hash'], handles => { count_write_back => 'count', # mostly for tests has_no_write_back => 'is_empty', nodes_to_write_back => 'keys', write_back_node_info => 'get', delete_write_back => 'delete', clear_write_back => 'clear', }, default => sub { {} }, ); sub register_write_back { my ($self, $path, $backend, $wb) = @_; push @{ $self->_write_back->{$path} //= [] }, [$backend, $wb]; } # used for auto_read auto_write feature has [qw/name application backend_arg backup/] => ( is => 'ro', isa => 'Maybe[Str]', ); has 'root_dir' => ( is => 'ro', isa => 'Config::Model::TypeContraints::Path', coerce => 1 ); has root_path => ( is => 'ro', isa => 'Path::Tiny', lazy_build => 1, ); sub _build_root_path { my $self = shift; my $root_dir = $self->root_dir // ''; return $root_dir ? path($root_dir) : Path::Tiny->cwd; } has [qw/config_dir config_file/] => ( is => 'ro', isa => 'Config::Model::TypeContraints::Path', coerce => 1 ); has tree => ( is => 'ro', isa => 'Config::Model::Node', builder => '_build_tree', lazy => 1, clearer => '_clear_config', reader => 'config_root', handles => [qw/apply_fixes deep_check grab grab_value/], ); sub reset_config { my $self = shift; $self->_clear_config; $self->clear_changes; return $self->config_root; } sub _build_tree { my $self = shift; return $self->load_node ( config_class_name => $self->{root_class_name}, instance => $self, container => $self, config_file => $self->{config_file}, ); } sub preset_start { my $self = shift; $logger->info("Starting preset mode"); carp "Cannot start preset mode during layered mode" if $self->{layered}; $self->{preset} = 1; } sub preset_stop { my $self = shift; $logger->info("Stopping preset mode"); $self->{preset} = 0; } sub preset_clear { my $self = shift; my $leaf_cb = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $$data_ref ||= $leaf_object->clear_preset; }; $self->_stuff_clear($leaf_cb); } sub layered_start { my $self = shift; $logger->info("Starting layered mode"); carp "Cannot start layered mode during preset mode" if $self->{preset}; $self->{layered} = 1; } sub layered_stop { my $self = shift; $logger->info("Stopping layered mode"); $self->{layered} = 0; } sub layered_clear { my $self = shift; my $leaf_cb = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $$data_ref ||= $leaf_object->clear_layered; }; $self->_stuff_clear($leaf_cb); } sub get_data_mode { my $self = shift; return $self->{layered} ? 'layered' : $self->{preset} ? 'preset' : 'normal'; } sub _stuff_clear { my ( $self, $leaf_cb ) = @_; # this sub may remove hash keys that were entered by user if the # corresponding hash value has no data. # it also clear auto_created ids if there's no data in there my $h_cb = sub { my ( $scanner, $data_ref, $node, $element_name, @keys ) = @_; my $obj = $node->fetch_element($element_name); # Since remove method uses splice(array) on list elements, the # removal must be done in reverse order to avoid messing up # the indexes of the array (i.e. the last indexes becomes # greater than the length of the array). foreach my $k (reverse @keys) { my $has_data = 0; $scanner->scan_hash( \$has_data, $node, $element_name, $k ); $obj->remove($k) unless $has_data; $$data_ref ||= $has_data; } }; my $wiper = Config::Model::ObjTreeScanner->new( fallback => 'all', auto_vivify => 0, check => 'skip', leaf_cb => $leaf_cb, hash_element_cb => $h_cb, list_element_cb => $h_cb, ); $wiper->scan_node( undef, $self->config_root ); } sub modify { my $self = shift ; my %args = @_ eq 1 ? ( step => $_[0] ) : @_; my $force = delete $args{force_save} || delete $args{force}; my $quiet = delete $args{quiet}; $self->load(%args); $self->say_changes() unless $quiet; $self->write_back( force => $force ); return $self; } sub load { my $self = shift; my $loader = Config::Model::Loader->new( start_node => $self->config_root ); my %args = @_ eq 1 ? ( step => $_[0] ) : @_; $loader->load( %args ); return $self; } sub search_element { my $self = shift; $self->config_root->search_element(@_); } sub wizard_helper { carp __PACKAGE__, "::wizard_helper helped is deprecated. Call iterator instead"; goto &iterator; } sub iterator { my $self = shift; my @args = @_; my $tree_root = $self->config_root; return Config::Model::Iterator->new( root => $tree_root, @args ); } sub read_directory { carp "read_directory is deprecated"; return shift->root_dir; } sub write_directory { my $self = shift; carp "write_directory is deprecated"; return $self->root_dir; } sub write_root_dir { my $self = shift; carp "deprecated"; return $self->root_dir; } # FIXME: record changes to implement undo/redo ? sub notify_change { my $self = shift; my %args = @_; if ( $change_logger->is_debug ) { $change_logger->debug( "in instance ", $self->name, ' for path ', $args{path} ); } foreach my $obsolete (qw/note_only msg/) { if ( my $m = delete $args{$obsolete} ) { carp "notify_change: param $obsolete is obsolete ($m)"; $args{note} //=''; $args{note} .= $m; } } $self->add_change( \%args ); $self->on_change_cb->( %args ); } sub _truncate { my @lines = @_; foreach my $l (@lines) { next unless defined $l; $l =~ s/\n/ /g; substr ($l, 60) = '[...]' if length $l > 60; # limit string length } return @lines; } sub list_changes { my $self = shift; my $l = $self->changes; my @all; foreach my $c (@$l) { my $path = $c->{path} ; my $vt = $c->{value_type} || ''; my ( $o, $n ) = _truncate( $c->{old}, $c->{new} ); my $note = $c->{note} ? " # $c->{note}" : ''; if ( defined $n and not defined $o ) { push @all, "$path has new value: '$n'$note"; } elsif ( not defined $n and defined $o) { push @all, "$path deleted value: '$o'$note"; } elsif ( defined $o and defined $n ) { push @all, "$path: '$o' -> '$n'$note"; } elsif ( defined $c->{note} ) { push @all, "$path: ".$c->{note}; } else { # something's unexpected with the call to notify_change push @all, "changed ".join(' ', each %$c); } } return wantarray ? @all : join( "\n", @all ); } sub say_changes { my $self = shift; my @changes = $self->list_changes; return $self unless @changes; my $msg = "\n" . join( "\n- ", "Changes applied to " . ($self->application // $self->name) . " configuration:", @changes ) . "\n"; $user_logger->info($msg); return $self; } sub write_back { my $self = shift; my %args = scalar @_ > 1 ? @_ : scalar @_ == 1 ? ( config_dir => $_[0] ) : (); my $force_write = delete $args{force} || 0; if (delete $args{root}) { say "write_back: root argument is no longer supported"; } # make sure that root node is loaded $self->config_root->init; if ($force_write) { # make sure that the whole tree is loaded my $dump = $self->config_root->dump_tree; } foreach my $k ( keys %args ) { if ($k eq 'config_dir') { $args{$k} ||= ''; $args{$k} .= '/' if $args{$k} and $args{$k} !~ m(/$); } elsif ( $k ne 'config_file' ) { croak "write_back: wrong parameters $k"; } } if ($self->has_no_write_back ) { my $info = $self->application ? "the model of application ".$self->application : "model ".$self->root_class_name ; croak "Don't know how to save data of $self->{name} instance. ", "Either $info has no configured ", "read/write backend or no node containing a backend was loaded. ", "Try with -force option or add read/write backend to $info\n"; } foreach my $path ( sort $self->nodes_to_write_back ) { $logger->info("write_back called on node $path"); if ( $path and $self->{config_file} ) { $logger->warn("write_back: cannot override config_file in non root node ($path)"); delete $self->{config_file} } $self->_write_back_node(%args, path => $path, force_write => $force_write) ; } $self->clear_changes; } sub _write_back_node { my $self = shift; my %args = @_; my $path = delete $args{path}; my $force_write = delete $args{force_write}; my $node = $self->config_root->grab( step => $path, type => 'node', mode => 'loose', autoadd => 0, ); foreach my $wb_info (@{ $self->write_back_node_info($path) }) { my ($backend, $cb) = @$wb_info; my @wb_args = ( %args, config_file => $self->{config_file}, force => $force_write, backup => $self->backup, ); if (defined $node and ($node->needs_save or $force_write)) { my $dir = $args{config_dir}; mkpath( $dir, 0, oct(755) ) if $dir and not -d $dir; # exit when write is successfull my $res = $cb->(@wb_args); $logger->info( "write_back called with $backend backend, result is ", defined $res ? $res : '' ); } if (not defined $node) { $logger->debug("deleting file for deleted node $path"); $cb->(@wb_args, force_delete => 1); $self->delete_write_back($path); } } $logger->trace( "write_back on node '$path' done" ); } sub save { goto &write_back; } sub update { my ($self, %args) = @_; my @msgs ; my $hook = sub { my ($scanner, $data_ref,$node,@element_list) = @_; if ($node->can('update')) { my $loc = $node->location; say "Calling update on node '$loc'" if $loc and not $args{quiet}; push (@msgs, $node->update(%args)) } ; }; my $root = $self->config_root ; Config::Model::ObjTreeScanner->new( node_content_hook => $hook, check => ($args{quiet} ? 'no' : 'yes'), leaf_cb => sub { } )->scan_node( \@msgs, $root ); return @msgs; } sub DEMOLISH { my $self = shift; $self->clear_write_back; # avoid reference loops } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Instance of configuration tree __END__ =head1 SYNOPSIS use Config::Model; use File::Path ; # setup a dummy popcon conf file my $wr_dir = '/tmp/etc/'; my $conf_file = "$wr_dir/popularity-contest.conf" ; unless (-d $wr_dir) { mkpath($wr_dir, { mode => 0755 }) || die "can't mkpath $wr_dir: $!"; } open(my $conf,"> $conf_file" ) || die "can't open $conf_file: $!"; $conf->print( qq!MY_HOSTID="aaaaaaaaaaaaaaaaaaaa"\n!, qq!PARTICIPATE="yes"\n!, qq!USEHTTP="yes" # always http\n!, qq!DAY="6"\n!); $conf->close ; my $model = Config::Model->new; # PopCon model is provided. Create a new Config::Model::Instance object my $inst = $model->instance (root_class_name => 'PopCon', root_dir => '/tmp', ); my $root = $inst -> config_root ; print $root->describe; =head1 DESCRIPTION This module provides an object that holds a configuration tree. =head1 CONSTRUCTOR An instance object is created by calling L on an existing model. This model can be specified by its application name: my $inst = $model->instance ( # run 'cme list' to get list of applications application => 'foo', # optional instance_name => 'test1' ); my $inst = $model->instance ( root_class_name => 'SomeRootClass', instance_name => 'test1' ); The directory (or directories) holding configuration files is specified within the configuration model. For test purpose you can change the "root" directory with C parameter. Constructor parameters are: =over =item root_dir Pseudo root directory where to read I write configuration files (L object or string). Configuration directory specified in model or with C option is appended to this root directory =item root_path L object created with C value or with current directory if C is empty. =item config_dir Directory to read or write configuration file. This parameter must be supplied if not provided by the configuration model. (string) =item backend_arg Specify a backend argument that may be retrieved by some backend. Instance is used as a relay and does not use this data. =item check Specify whether to check value while reading config files. Either: =over =item yes Check value and throws an error for bad values. =item skip Check value and skip bad value. =item no Do not check. =back =item canonical When true: write config data back using model order. By default, write items back using the order found in the configuration file. This feature is experimental and not supported by all backends. =item on_change_cb Call back this function whenever C is called. Called with arguments: C<< name => , index => >> =item on_message_cb Call back this function when L is called. By default, messages are displayed on STDOUT. =item error_paths Returns a list of tree items that currently have an error. =item error_messages Returns a list of error messages from the tree content. =back Note that the root directory specified within the configuration model is overridden by C parameter. If you need to load configuration data that are not correct, you can use C<< force_load => 1 >>. Then, wrong data are discarded (equivalent to C<< check => 'no' >> ). =head1 METHODS =head2 Manage configuration data =head2 modify Calls L and then L. Takes the same parameter as C plus: =over =item C Force saving configuration file even if no value was modified (default is 0) =item C Do no display the changes brought by the modification steps =back =head2 load Load configuration tree with configuration data. See L for parameters. Returns <$self>. =head2 save Save the content of the configuration tree to configuration files. (See L for more details) Use C<< force => 1 >> option to force saving configuration data. =head2 config_root Returns the L of the configuration tree. =head2 apply_fixes Scan the tree and apply fixes that are attached to warning specifications. See C or C in L. =head2 deep_check Scan the tree and deep check on all elements that support this. Currently only hash or list element have this feature. =head2 needs_save Returns 1 (or more) if the instance contains data that needs to be saved. I.e some change were done in the tree that needs to be saved. =head2 has_changes Returns true if the instance contains unsasved changes. =head2 list_changes In list context, returns a array ref of strings describing the changes. In scalar context, returns a big string. Useful to print. =head2 say_changes Print all changes on STDOUT and return C<$self>. =head2 clear_changes Clear list of changes. Note that changes pending in the configuration tree is not affected. This clears only the list shown to user. Use only for tests. =head2 has_warning Returns the number of warning found in the elements of this configuration instance. =head2 update Parameters: C<< ( quiet => (0|1), %args ) >> Try to run update command on all nodes of the configuration tree. Node without C method are ignored. C prints a message otherwise (unless C is true). =head2 grab Use the steps parameter to retrieve and returns an object from the configuration tree. Forwarded to L =head2 grab_value Use the steps parameter to retrieve and returns the value of a leaf object from the configuration tree. Forwarded to L =head2 searcher Returns an object dedicated to search an element in the configuration model. This method returns a L object. See L for details on how to handle a search. =head2 iterator This method returns a L object. See L for details. Arguments are explained in L L. =head2 application Returns the application name of the instance. (E.g C, C ...) =head2 wizard_helper Deprecated. Call L instead. =head1 Internal methods =head2 name Returns the instance name. =head2 read_check Returns which kind of check is performed while reading configuration files. (see C parameter in L section) =head2 show_message Parameters: C<( string )> Display the message on STDOUT unless a custom function was passed to C parameter. =head2 reset_config Destroy current configuration tree (with data) and returns a new tree with data (and annotations) loaded from disk. =head2 config_model Returns the model (L object) of the configuration tree. =head2 annotation_saver Returns the object loading and saving annotations. See L for details. =head2 preset_start All values stored in preset mode are shown to the user as default values. This feature is useful to enter configuration data entered by an automatic process (like hardware scan) =head2 preset_stop Stop preset mode =head2 preset Get preset mode =head2 preset_clear Clear all preset values stored. =head2 layered_start All values stored in layered mode are shown to the user as default values. This feature is useful to enter configuration data entered by an automatic process (like hardware scan) =head2 layered_stop Stop layered mode =head2 layered Get layered mode =head2 layered_clear Clear all layered values stored. =head2 get_data_mode Returns 'normal' or 'preset' or 'layered'. Does not take into account initial_load. =head2 initial_load_start Start initial_load mode. This mode tracks the first modifications of the tree done with data read from the configuration file. Instance is built with initial_load as 1. Read backend clears this value once the first read is done. Other modifications, when initial_load is zero, are assumed to be user modifications. =head2 initial_load_stop Stop initial_load mode. Instance is built with initial_load as 1. Read backend clears this value once the first read is done. =head2 initial_load Get initial_load mode =head2 data This method provides a way to store some arbitrary data in the instance object. E.g: $instance->data(foo => 'bar'); Later: my $foo = $instance->data('foo'); # $foo contains 'bar' =head1 Read and write backend features Usually, a program based on config model must first create the configuration model, then load all configuration data. This feature enables you to declare with the model a way to load configuration data (and to write it back). See L for details. =head2 backend_arg Get L command line argument that may be used by the backend to get the configuration file. These method is typically used in the read and write method of a backend to know where is the configuration file to edit. =head2 root_dir Returns a L object for the root directory where configuration data is read from or written to. =head2 root_path Same as C =head2 register_write_back Parameters: C<( node_location )> Register a node path that is called back with C method. =head2 notify_change Notify that some data has changed in the tree. See L for more details. =head2 write_back In summary, save the content of the configuration tree to configuration files. In more details, C tries to run all subroutines registered with C to write the configuration information. (See L for details). You can specify here another config directory to write configuration data back with C parameter. This overrides the model specifications. C croaks if no write call-back are known. Use C<< force => 1 >> option to force saving configuration data. This is useful to write back a file even no change are done at semantic level, i.e. to reformat a file or remove unnecessary data. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, =cut libconfig-model-perl-2.155/lib/Config/Model/Iterator.pm000066400000000000000000000307101472064100600226630ustar00rootroot00000000000000package Config::Model::Iterator; use v5.20; use Carp; use strict; use warnings; use Config::Model::ObjTreeScanner; use Log::Log4perl qw(get_logger :levels); use Config::Model::Exception; use feature qw/postderef signatures/; no warnings qw/experimental::postderef experimental::signatures/; my $logger = get_logger("Iterator"); sub new ($type, %args){ my $self = { call_back_on_important => 0, forward => 1, status => 'standard', }; if (delete $args{experience}) { carp "experience parameter is deprecated"; } foreach my $p (qw/root/) { $self->{$p} = delete $args{$p} or croak "Iterator->new: Missing $p parameter"; } foreach my $p (qw/call_back_on_important call_back_on_warning status/) { $self->{$p} = delete $args{$p} if defined $args{$p}; } bless $self, $type; my %cb_hash; # mandatory call-back parameters foreach my $item (qw/leaf_cb hash_element_cb/) { $cb_hash{$item} = delete $args{$item} or croak "Iterator->new: Missing $item parameter"; } # handle optional list_element_cb parameter $cb_hash{list_element_cb} = delete $args{list_element_cb} || $cb_hash{hash_element_cb}; # optional call-back parameter $cb_hash{check_list_element_cb} = delete $args{check_list_element_cb} || $cb_hash{leaf_cb}; # optional call-back parameters foreach my $p ( qw/enum_value reference_value integer_value number_value boolean_value string_value uniline_value/ ) { my $item = $p . '_cb'; $cb_hash{$item} = delete $args{$item} || $cb_hash{leaf_cb}; } $self->{dispatch_cb} = \%cb_hash; if (%args) { die "Iterator->new: unexpected parameters: ", join( ' ', keys %args ), "\n"; } # user call-back are *not* passed to ObjTreeScanner. They will be # called indirectly through wizard-helper own call-backs $self->{scanner} = Config::Model::ObjTreeScanner->new( fallback => 'all', hash_element_cb => sub { $self->hash_element_cb(@_) }, list_element_cb => sub { $self->hash_element_cb(@_) }, node_content_cb => sub { $self->node_content_cb(@_) }, leaf_cb => sub { $self->leaf_cb(@_) }, ); return $self; } sub start { my $self = shift; $self->{bail_out} = 0; $self->{scanner}->scan_node( undef, $self->{root} ); return; } sub bail_out { my $self = shift; $self->{bail_out} = 1; return; } # internal. This call-back is passed to ObjTreeScanner. It will call # scan_element in an order which depends on $self->{forward}. sub node_content_cb { my ( $self, $scanner, $data_r, $node, @element ) = @_; $logger->info( "node_content_cb called on '", $node->name, "' element: @element" ); my $element; while (1) { # @element from ObjTreeScanner is not used as user actions may # change the element list due to warping $element = $node->next_element( name => $element, status => $self->{status}, reverse => 1 - $self->{forward} ); last unless defined $element; $logger->info( "node_content_cb calls scan_element ", "on element $element" ); $self->{scanner}->scan_element( $data_r, $node, $element ); return if $self->{bail_out}; } return; } # internal. Used to find which user call-back to use for a given # element type. sub get_cb { my $self = shift; my $elt_type = shift; return $self->{dispatch_cb}{ $elt_type . '_cb' } || croak "wizard get_cb: unexpected type $elt_type"; } # internal. This call-back is passed to ObjTreeScanner. It will call # scan_hash in an order which depends on $self->{forward}. it will # also check if the hash (or list) element is flagged as 'important' # and call user's hash or list call-back if needed sub hash_element_cb ( $self, $scanner, $data_r, $node, $element, @raw_keys ) { my @keys = sort @raw_keys; my $level = $node->get_element_property( element => $element, property => 'level' ); $logger->info( "hash_element_cb (element $element) called on '", $node->location, "' level $level, keys: '@keys'" ); # get the call-back to use my $cb = $self->get_cb( $node->element_type($element) . '_element' ); # use the same algorithm for check_important and # scan_element pseudo elements my $i = $self->{forward} == 1 ? 0 : 1; while ( $i >= 0 and $i < 2 ) { if ( $self->{call_back_on_important} and $i == 0 and $level eq 'important' ) { $cb->( $self, $data_r, $node, $element, @keys ); return if $self->{bail_out}; # may be modified in callback # recompute keys as they may have been modified during call-back @keys = $self->{scanner}->get_keys( $node, $element ); } if ( $self->{call_back_on_warning} and $i == 0 and $node->fetch_element($element)->has_warning ) { $logger->info("hash_element_cb found elt with warning: '", $node->name, "' element $element"); $cb->( $self, $data_r, $node, $element, @keys ); } if ( $i == 1 ) { my $j = $self->{forward} == 1 ? 0 : $#keys; while ( $j >= 0 and $j < @keys ) { my $k = $keys[$j]; $logger->info( "hash_element_cb (element $element) calls ", "scan_hash on key $k" ); $self->{scanner}->scan_hash( $data_r, $node, $element, $k ); $j += $self->{forward}; } } $i += $self->{forward}; } return; } # internal. This call-back is passed to ObjTreeScanner. It will also # check if the leaf element is flagged as 'important' or if the leaf # element contains an error (mostly undefined mandatory values) and # call user's call-back if needed sub leaf_cb { my ( $self, $scanner, $data_r, $node, $element, $index, $value_obj ) = @_; $logger->info( "leaf_cb called on '", $node->name, "' element '$element'", defined $index ? ", index $index" : '' ); my $elt_type = $node->element_type($element); my $key = $elt_type eq 'check_list' ? 'check_list_element' : $value_obj->value_type . '_value'; my $user_leaf_cb = $self->get_cb($key); my $level = $node->get_element_property( element => $element, property => 'level' ); if ( $self->{call_back_on_important} and $level eq 'important' ) { $logger->info( "leaf_cb found important elt: '", $node->name, "' element $element", defined $index ? ", index $index" : '' ); $user_leaf_cb->( $self, $data_r, $node, $element, $index, $value_obj ); } if ( $self->{call_back_on_warning} and $value_obj->warning_msg ) { $logger->info( "leaf_cb found elt with warning: '", $node->name, "' element $element", defined $index ? ", index $index" : '' ); $user_leaf_cb->( $self, $data_r, $node, $element, $index, $value_obj ); } # now need to check for errors... my $result; eval { $result = $value_obj->fetch(); }; my $e = $@; if ( ref $e and $e->isa('Config::Model::Exception::User') ) { # ignore errors that has just been catched and call user call-back $logger->info( "leaf_cb oopsed on '", $node->name, "' element $element", defined $index ? ", index $index" : '' ); $user_leaf_cb->( $self, $data_r, $node, $element, $index, $value_obj, $e->error ); } elsif ( ref $e ) { $e->rethrow; # does not return ... } elsif ($e) { die "Iterator failed on value object: $e"; } return; } sub go_forward { my $self = shift; $logger->info("Going forward") if $self->{forward} == -1; $self->{forward} = 1; return; } sub go_backward { my $self = shift; $logger->info("Going backward") if $self->{forward} == 1; $self->{forward} = -1; return; } 1; # ABSTRACT: Iterates forward or backward a configuration tree __END__ =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "Foo", element => [ [qw/bar baz/] => { type => 'leaf', value_type => 'string', level => 'important' , }, ] ); $model->create_config_class( name => "MyClass", element => [ foo_nodes => { type => 'hash', # hash id index_type => 'string', level => 'important' , cargo => { type => 'node', config_class_name => 'Foo' }, }, ], ); my $inst = $model->instance( root_class_name => 'MyClass' ); # create some Foo objects $inst->config_root->load("foo_nodes:foo1 - foo_nodes:foo2 ") ; my $my_leaf_cb = sub { my ($iter, $data_r,$node,$element,$index, $leaf_object) = @_ ; print "leaf_cb called for ",$leaf_object->location,"\n" ; } ; my $my_hash_cb = sub { my ($iter, $data_r,$node,$element,@keys) = @_ ; print "hash_element_cb called for element $element with keys @keys\n" ; } ; my $iterator = $inst -> iterator ( leaf_cb => $my_leaf_cb, hash_element_cb => $my_hash_cb , ); $iterator->start ; ### prints # hash_element_cb called for element foo_nodes with keys foo1 foo2 # leaf_cb called for foo_nodes:foo1 bar # leaf_cb called for foo_nodes:foo1 baz # leaf_cb called for foo_nodes:foo2 bar # leaf_cb called for foo_nodes:foo2 baz =head1 DESCRIPTION This module provides a class that is able to iterate forward or backward a configuration tree. The iterator stops and calls back user defined subroutines on one of the following condition: =over =item * A configuration item contains an error (mostly undefined mandatory values) =item * A configuration item contains warnings and the constructor's argument C was set. =item * A configuration item has a C level and the constructor's argument C was set.. See L for details. =back The iterator supports going forward and backward (to support C and C buttons on a wizard widget). =head1 CONSTRUCTOR The constructor should be used only by L with the L method. =head1 Creating an iterator A iterator requires at least two kind of call-back: a call-back for leaf elements and a call-back for hash elements (which is also used for list elements). These call-back must be passed when creating the iterator (the parameters are named C and C) Here are the the parameters accepted by C: =head2 call_back_on_important Whether to call back when an important element is found (default 0). =head2 call_back_on_warning Whether to call back when an item with warnings is found (default 0). =head2 status Specifies the status of the element scanned by the wizard (default 'standard'). =head2 leaf_cb Subroutine called backed for leaf elements. See L for signature and details. (mandatory) =head2 hash_element_cb Subroutine called backed for hash elements. See L for signature and details. (mandatory) =head1 Custom callbacks By default, C is called for all types of leaf elements (i.e enum. integer, strings, ...). But you can provide dedicated call-back for each type of leaf: enum_value_cb, integer_value_cb, number_value_cb, boolean_value_cb, uniline_value_cb, string_value_cb Likewise, you can also provide a call-back dedicated to list elements with C =head1 Methods =head2 start Start the scan and perform call-back when needed. This function returns when the scan is completely done. =head2 bail_out When called, a variable is set so that all call_backs returns as soon as possible. Used to abort wizard. =head2 go_forward Set wizard in forward (default) mode. =head2 go_backward Set wizard in backward mode. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, L, L, L, =cut libconfig-model-perl-2.155/lib/Config/Model/ListId.pm000066400000000000000000000411771472064100600222730ustar00rootroot00000000000000package Config::Model::ListId; use 5.10.1; use Mouse; use Config::Model::Exception; use Log::Log4perl qw(get_logger :levels); use Carp; extends qw/Config::Model::AnyId/; with "Config::Model::Role::Grab"; with "Config::Model::Role::ComputeFunction"; my $logger = get_logger("Tree::Element::Id::List"); my $user_logger = get_logger("User"); has data => ( is => 'rw', isa => 'ArrayRef', default => sub { []; }, traits => ['Array'], handles => { _sort_data => 'sort_in_place', _all_data => 'elements', _splice_data => 'splice', } ); # compatibility with HashId has index_type => ( is => 'ro', isa => 'Str', default => 'integer' ); has auto_create_ids => ( is => 'rw' ); sub BUILD { my $self = shift; foreach my $wrong (qw/max_nb min_index default_keys/) { Config::Model::Exception::Model->throw( object => $self, error => "Cannot use $wrong with " . $self->get_type . " element" ) if defined $self->{$wrong}; } if ( defined $self->{migrate_keys_from} ) { $user_logger->warn( $self->name, "Using migrate_keys_from with ", "list element is deprecated. Use migrate_values_from" ); } # Supply the mandatory parameter return $self; } sub set_properties { my $self = shift; $self->SUPER::set_properties(@_); # remove unwanted items my $data = $self->{data}; return unless defined $self->{max_index}; # delete entries that no longer fit the constraints imposed by the # warp mechanism foreach my $k ( 0 .. $#{$data} ) { next unless $k > $self->{max_index}; $logger->trace( "set_properties: ", $self->name, " deleting index $k" ); delete $data->[$k]; } } sub _migrate { my $self = shift; return if $self->{migration_done}; # migration must be done *after* initial load to make sure that all data # were retrieved from the file before migration. return if $self->instance->initial_load; $self->{migration_done} = 1; if ( $self->{migrate_values_from} ) { my $followed = $self->safe_typed_grab( param => 'migrate_values_from', check => 'no' ); $logger->debug( $self->name, " migrate values from ", $followed->name ) if $logger->is_debug; my $idx = $self->fetch_size; foreach my $item ( $followed->fetch_all_indexes ) { my $data = $followed->fetch_with_id($item)->dump_as_data( check => 'no' ); $self->fetch_with_id( $idx++ )->load_data($data); } } elsif ( $self->{migrate_keys_from} ) { # FIXME: remove this deprecated stuff my $followed = $self->safe_typed_grab( param => 'migrate_keys_from', check => 'no' ); for ( $followed->fetch_all_indexes ) { $self->_store( $_, undef ) unless $self->_defined($_); } } } sub get_type { my $self = shift; return 'list'; } sub get_info { my $self = shift; my @items = ( 'type: ' . $self->get_type, 'index: ' . $self->index_type, 'cargo: ' . $self->cargo_type, ); if ( $self->cargo_type eq 'node' ) { push @items, "cargo class: " . $self->config_class_name; } if ( $self->cargo_type eq 'leaf' ) { push @items, "leaf value type: " . ( $self->get_cargo_info('value_type') || '' ); } foreach my $what (qw/min_index max_index/) { my $v = $self->$what(); my $str = $what; $str =~ s/_/ /g; push @items, "$str: $v" if defined $v; } return @items; } # important: return the actual size (not taking into account auto-created stuff) sub fetch_size { my $self = shift; return scalar @{ $self->{data} }; } sub _fetch_all_indexes { my $self = shift; my $data = $self->{data}; return scalar @$data ? ( 0 .. $#$data ) : (); } # fetch without any check sub _fetch_with_id { my ( $self, $idx ) = @_; return $self->{data}[$idx]; } sub load { my ( $self, $string, %args ) = @_; my $check = $self->_check_check( $args{check} ); # I write too many checks. my @set; my $cmd = $string; $logger->debug( "load: ", $self->name, " called with ->$string<-" ); my $regex = qr/^( (?: " (?: \\" | [^"] )*? " ) | [^,]+ ) /x; while ( length($string) ) { $string =~ s/$regex// or last; my $tmp = $1; $tmp =~ s/^"|"$//g if defined $tmp; $tmp =~ s/\\"/"/g if defined $tmp; push @set, $tmp; last unless length($string); } continue { $string =~ s/^,// or last; } if ( length($string) ) { Config::Model::Exception::Load->throw( object => $self, command => $cmd, message => "unexpected load command '$cmd', left '$cmd'" ); } $self->store_set(\@set, check => $check); } sub store_set { my $self = shift; my (@v, %args); if (ref $_[0] eq 'ARRAY') { @v = @{ shift @_ }; %args = @_; } else { %args = ( check => 'yes' ); @v = @_; } if ($logger->is_debug) { no warnings "uninitialized"; $logger->debug($self->name, " store_set called with ".map {"«$_» "} @v); } my @comments = @{ $args{comment} || [] }; my $idx = 0; foreach my $value (@v) { my $v_obj = $self->fetch_with_id( $idx++ ); $v_obj->store( %args, value => $value ); $v_obj->annotation( shift @comments ) if @comments; } # and delete unused items $self->_prune_above_idx($idx); } sub _prune_above_idx { my ($self, $idx) = @_; # and delete unused items my $ref = $self->{data}; while (scalar @$ref > $idx) { $logger->debug($self->name, " pruning idx ", $#$ref); $self->delete($#$ref); } } # store without any check sub _store { my ( $self, $idx, $value ) = @_; return $self->{data}[$idx] = $value; } sub _defined { my ( $self, $key ) = @_; croak "argument '$key' is not numeric" unless $key =~ /^\d+$/; return defined $self->{data}[$key]; } sub _exists { my ( $self, $idx ) = @_; return exists $self->{data}[$idx]; } sub _delete { my ( $self, $idx ) = @_; return delete $self->{data}[$idx]; } sub _clear { my ($self) = @_; $self->{data} = []; } sub move { my ( $self, $from, $to, %args ) = @_; my $check = $self->_check_check( $args{check} ); my $moved = $self->fetch_with_id($from); $self->_delete($from); delete $self->{warning_hash}{$from}; my $ok = $self->check_idx($to); if ( $ok or $check eq 'no' ) { $self->_store( $to, $moved ); $moved->index_value($to); $self->notify_change( note => "moved from index $from to $to" ); my $imode = $self->instance->get_data_mode; $self->set_data_mode( $to, $imode ); } else { # restore moved item where it came from $self->_store( $from, $moved ); if ( $check ne 'skip' ) { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{error} } ), object => $self ); } } } # list only methods sub push { my $self = shift; $self->_assert_leaf_cargo; my $idx = $self->fetch_size; map { $self->fetch_with_id( $idx++ )->store($_); } @_; } # list only methods sub push_x { my $self = shift; my %args = @_; $self->_assert_leaf_cargo; my $check = delete $args{check} || 'yes'; my $v_arg = delete $args{values} || delete $args{value}; my @v = ref($v_arg) ? @$v_arg : ($v_arg); my $anno = delete $args{annotation}; my @a = ref($anno) ? @$anno : $anno ? ($anno) : (); croak( "push_x: unexpected parameter ", join( ' ', keys %args ) ) if %args; my $idx = $self->fetch_size; while (@v) { my $val = shift @v; my $obj = $self->fetch_with_id( $idx++ ); $obj->store($val); $obj->annotation( shift @a ) if @a; } } sub unshift { my $self = shift; $self->insert_at( 0, @_ ); } sub insert_at { my $self = shift; my $idx = shift; $self->_assert_leaf_cargo; # check if max_idx is respected $self->check_idx( $self->fetch_size + scalar @_ ); # make room at the beginning of the array $self->_splice_data( $idx, 0, (undef) x scalar @_ ); my $i = $idx; map { $self->fetch_with_id( $i++ )->store($_); } @_; $self->_reindex; } sub insert_before { my $self = shift; my $val = shift; my $test = ref($val) eq 'Regexp' ? sub { $_[0] =~ /$val/ } : sub { $_[0] eq $val }; $self->_assert_leaf_cargo; my $point = 0; foreach my $v ( $self->fetch_all_values ) { last if $test->($v); $point++; } $self->insert_at( $point, @_ ); } sub insort { my $self = shift; $self->_assert_leaf_cargo; my @insert = sort @_; my $point = 0; foreach my $v ( $self->fetch_all_values ) { while ( @insert and $insert[0] lt $v ) { $self->insert_at( $point++, shift @insert ); } $point++; } $self->push(@insert) if @insert; } sub store { my $self = shift; $self->push_x(@_); } sub _assert_leaf_cargo { my $self = shift; my $ct = $self->cargo_type; Config::Model::Exception::User->throw( object => $self, error => "Cannot call sort on list of $ct" ) unless $ct eq 'leaf'; } sub sort_algorithm { return sub { $_[0]->fetch cmp $_[1]->fetch; }; } sub sort { my $self = shift; $self->_assert_leaf_cargo; $self->_sort_data( $self->sort_algorithm ); my $has_changed = $self->_reindex; $self->notify_change( note => "sorted" ) if $has_changed; } sub _reindex { my $self = shift; my $i = 0; my $has_changed = 0; foreach my $o ( $self->_all_data ) { next unless defined $o; $has_changed = 1 if $o->index_value != $i; $o->index_value( $i++ ); } return $has_changed; } sub swap { my $self = shift; my $ida = shift; my $idb = shift; my $obja = $self->{data}[$ida]; my $objb = $self->{data}[$idb]; # swap the index values contained in the objects my $obja_index = $obja->index_value; $obja->index_value( $objb->index_value ); $objb->index_value($obja_index); # then swap the objects $self->{data}[$ida] = $objb; $self->{data}[$idb] = $obja; $self->notify_change( note => "swapped index $ida and $idb" ); } #die "check index number after wap"; sub remove { my $self = shift; my $idx = shift; Config::Model::Exception::User->throw( object => $self, error => "Non numeric index for list: $idx" ) unless $idx =~ /^\d+$/; $self->delete_data_mode( index => $idx ); my $note = "removed idx $idx"; if ( $self->{cargo}{type} eq 'leaf' ) { $note .= ' ("' . $self->fetch_summary($idx) . '")'; } $self->notify_change(note => $note); splice @{ $self->{data} }, $idx, 1; } #internal sub auto_create_elements { my $self = shift; my $auto_nb = $self->auto_create_ids; return unless defined $auto_nb; $logger->debug( $self->name, " auto-creating $auto_nb elements" ); Config::Model::Exception::Model->throw( object => $self, error => "Wrong auto_create argument for list: $auto_nb" ) unless $auto_nb =~ /^\d+$/; my $auto_p = $auto_nb - 1; # create empty slots map { $self->{data}[$_] = undef unless defined $self->{data}[$_]; } ( 0 .. $auto_p ); } # internal sub create_default { my $self = shift; return if @{ $self->{data} }; # list is empty so create empty element for default keys my $def = $self->get_default_keys; map { $self->{data}[$_] = undef } @$def; $self->create_default_with_init; } sub load_data { my $self = shift; my %args = @_ > 1 ? @_ : ( data => shift ); my $raw_data = delete $args{data}; my $check = $self->_check_check( $args{check} ); my $data = ref($raw_data) eq 'ARRAY' ? $raw_data : $args{split_reg} ? [ split $args{split_reg}, $raw_data ] : defined $raw_data ? [$raw_data] : undef; Config::Model::Exception::LoadData->throw( object => $self, message => "load_data called with non expected data. Expected array ref or scalar", wrong_data => $raw_data, ) unless defined $data; my $idx = 0; $logger->info( "ListId load_data (", $self->location, ") will load idx ", "0..$#$data" ); foreach my $item (@$data) { my $obj = $self->fetch_with_id( $idx ); # increment idx only if the value was accepted. This allow to # prune the array to the right size. $idx += $obj->load_data( %args, data => $item ); } # and delete unused items $self->_prune_above_idx($idx); } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Handle list element for configuration model __END__ =head1 SYNOPSIS See L =head1 DESCRIPTION This class provides list elements for a L. =head1 CONSTRUCTOR ListId object should not be created directly. =head1 List model declaration See L from L. =head1 Methods =head2 get_type Returns C. =head2 fetch_size Returns the number of elements of the list. =head2 load Parameters: C<< (string, [ check => 'no' ] ) >> Store a set of values passed as a comma separated list of values. Values can be quoted strings. (i.e C<"a,a",b> yields C<('a,a', 'b')> list). C can be yes, no or skip =head2 store_set Store a set of values (passed as list) If tinkering with check is required, use the following way : store_set ( \@v , check => 'skip' ); =head2 move Parameters: C<< ( from_index, to_index, [ check => 'no' ) >> Move an element within the list. C can be 'yes' 'no' 'skip' =head2 push Parameters: C<< ( value1, [ value2 ... ] ) >> push some values at the end of the list. =head2 push_x Parameters: C<< ( values => [ v1','v2', ...] , ... ) >> Like push with extended options. Options are: =over =item check Check value validaty. Either C (default), C, C =item values Values to push (array_ref) =item value Single value to push =item annotation =back =head2 unshift Parameters: C<< ( value1, [ value2 ... ] ) >> unshift some values at the end of the list. =head2 insert_at Parameters: C<< ( idx, value1, [ value2 ... ] ) >> unshift some values at index idx in the list. =head2 insert_before Parameters: C<< ( ( val | qr/stuff/ ) , value1, [ value2 ... ] ) >> unshift some values before value equal to C or before value matching C. =head2 insort Parameters: C<< ( value1, [ value2 ... ] ) >> Insert C value on C list so that existing alphanumeric order is preserved. C yields unpexpected results when called on an unsorted list. =head2 store Equivalent to push_x. This method is provided to help write configuration parser, so the call is the same when dealing with leaf or list values. Prefer C when practical. =over 4 =item check C, C or C =item annotation list ref of annotation to store with the list values =back Example: $elt->push_x ( values => [ 'v1','v2' ] , annotation => [ 'v1 comment', 'v2 comment' ], check => 'skip' ); =head2 sort Sort the content of the list. Can only be called on list of leaf. =head2 swap Parameters: C<< ( ida , idb ) >> Swap 2 elements within the array =head2 remove Parameters: C<< ( idx ) >> Remove an element from the list. Equivalent to C =head2 load_data Parameters: C<< ( data => ( ref | scalar ) [, check => ... ] [ , split_reg => $re ] ) >> Clear and load list from data contained in the C array ref. If a scalar or a hash ref is passed, the list is cleared and the data is stored in the first element of the list. If split_reg is specified, the scalar is split to load the array. For instance $elt->load_data( data => 'foo,bar', split_reg => qr(,) ) ; loads C< [ 'foo','bar']> in C<$elt> =head2 sort_algorithm Returns a sub used to sort the list elements. See L. Used only for list of leaves. This method can be overridden to alter sort order. =head2 get_info Returns a list of information related to the list. See L for more details. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L =cut libconfig-model-perl-2.155/lib/Config/Model/Lister.pm000066400000000000000000000061211472064100600223330ustar00rootroot00000000000000package Config::Model::Lister; use strict; use warnings; use Exporter; use vars qw/@EXPORT/; @EXPORT = qw(applications models); sub available_models { my $test = shift || 0; my ( %categories, %appli_info, %applications ); my %done_cat; my @dir_to_scan = $test ? qw/lib/ : @INC; foreach my $dir ( map { glob("$_/Config/Model/*.d") } @dir_to_scan ) { my ($cat) = ( $dir =~ m!.*/([\w\-]+)\.d! ); if ( $cat !~ /^user|system|application$/ ) { warn "available_models: skipping unexpected category: $cat\n"; next; } foreach my $file ( sort glob("$dir/*") ) { next if $file =~ m!/README!; next if $file =~ /(~|\.bak|\.orig)$/; my ($appli) = ( $file =~ m!.*/([\w\-]+)! ); # ensure that an appli file of a cat is not parsed twice # (useful in dev, where system appli file may clobber # appli file in dvelopment next if $done_cat{$cat}{$appli}; $appli_info{$appli}{_file} = $file; $appli_info{$appli}{_category} = $cat; open my $fh, '<', $file || die "Can't open file $file:$!"; while (<$fh>) { chomp; s/^\s+//; s/\s+$//; s/#.*//; my ( $k, $v ) = split /\s*=\s*/; next unless $v; if ( $k =~ /model/i ) { push @{ $categories{$cat} }, $appli unless $done_cat{$cat}{$appli}; $done_cat{$cat}{$appli} = 1; } $appli_info{$appli}{$k} = $v; $applications{$appli} = $v if $k =~ /model/i; } die "Missing model line in file $file\n" unless $done_cat{$cat}{$appli}; } } return \%categories, \%appli_info, \%applications; } sub models { my @i = available_models(@_); return join( ' ', sort values %{ $i[2] } ) . "\n"; } sub applications { my @i = available_models(@_); return join( ' ', sort keys %{ $i[2] } ) . "\n"; } 1; # ABSTRACT: List available models and applications __END__ =head1 SYNOPSIS perl -MConfig::Model::Lister -e'print Config::Model::Lister::models;' perl -MConfig::Model::Lister -e'print Config::Model::Lister::applications;' =head1 DESCRIPTION Small modules to list available models or applications whose config can be edited by L. This module is designed to be used by bash completion. All functions accept an optional boolean parameter. When true, only the local C dir is scanned. =head1 FUNCTIONS =head1 available_models Returns an array of 3 hash refs: =over =item * category (system or user or application) => application list. E.g. { system => [ 'popcon' , 'fstab'] } =item * application name to model information. E.g. { 'multistrap' => { model => 'Multistrap', require_config_file => 1 } =item * application name to model name. E.g. { popcon => 'Popcon', 'multistrap' => 'Multistrap' } =back =head1 models Returns a string with the list of models. =head1 applications Returns a string with the list of editable applications. =cut libconfig-model-perl-2.155/lib/Config/Model/Loader.pm000066400000000000000000001363241472064100600223100ustar00rootroot00000000000000package Config::Model::Loader; use Carp; use strict; use warnings; use 5.10.1; use Mouse; use Config::Model::Exception; use Log::Log4perl qw(get_logger :levels); use JSON; use Path::Tiny; use YAML::Tiny; use feature qw/postderef signatures/; no warnings qw/experimental::postderef experimental::signatures/; my $logger = get_logger("Loader"); my $verbose_logger = get_logger("Verbose.Loader"); ## load stuff, similar to grab, but used to set items in the tree ## starting from this node has start_node => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1, required => 1, ); has instance => ( is => 'ro', isa => 'Config::Model::Instance', weak_ref => 1, lazy_build => 1, ); sub _build_instance { return $_[0]->start_node->instance; } my %log_dispatch = ( name => sub { my $loc = $_[0]->location; return $loc ? $_[0]->get_type." '$loc'" : "root node"}, qs => sub { my $s = shift; unquote($s); return "'$s'"}, qa => sub { return '"'.join('", "', @{$_[0]}).'"'}, s => sub { return $_[0] }, # nop leaf => sub { return $_[0]->get_type." '". $_[0]->location."' ".$_[0]->value_type;} ); sub _log_cmd { my ($self, $cmd, $message, @params) = @_; return unless $verbose_logger->is_info; return if $self->instance->initial_load; $cmd =~ s/\n/\\n/g; foreach my $p (@params) { $message =~ s/%(\w+)/$log_dispatch{$1}->($p)/e; } my $str = ref $cmd eq 'ARRAY' ? "@$cmd" : ref $cmd ? $$cmd : $cmd; $verbose_logger->info("command '$str': $message"); } sub _split_string ($str) { # do a split on ' ' but take quoted string into account return ( $str =~ m/ ( # begin of *one* command (?: # group parts of a command (e.g ...:...=... ) [^\s"']+ # match anything but a space and a quote (?: # begin quoted group " # begin of a string (?: # begin group \\" # match an escaped quote | # or [^"] # anything but a quote )* # lots of time " # end of the string ) # end of quoted group ? # match if I got more than one group (?: # begin quoted group ' # begin of a string (?: # begin group \\' # match an escaped quote | # or [^'] # anything but a quote )* # lots of time ' # end of the string ) # end of quoted group ? # match if I got more than one group )+ # can have several parts in one command ) # end of *one* command /gx # 'g' means that all commands are fed into @command array ); #"asdf ; } sub load { my $self = shift; my %args = @_; my $node = $self->start_node; my $steps = delete $args{steps} // delete $args{step}; croak "load error: missing 'steps' parameter" unless defined $steps; my $caller_is_root = delete $args{caller_is_root}; if (delete $args{experience}) { carp "load: experience parameter is deprecated"; } my $inst = $node->instance; # tune value checking my $check = delete $args{check} || 'yes'; croak __PACKAGE__, "load: unexpected check $check" unless $check =~ /yes|no|skip/; # accept commands my $huge_string = ref $steps ? join( ' ', @$steps ) : $steps; my @command = _split_string($huge_string); #print "command is ",join('+',@command),"\n" ; my $current_node = $node; my $ret; do { $ret = $self->_load( $current_node, $check, \@command, 1 ); $logger->trace("_load returned $ret"); # found '!' command if ( $ret eq 'root' ) { $current_node = $caller_is_root ? $node : $current_node->root; if ($logger->debug) { $logger->debug("Setting current_node to root node: ".$current_node->name); } } } while ( $ret eq 'root' ); if (@command) { my $str = "Error: could not execute the required command, "; if ($command[0] =~ m!^/([\w-]+)!) { $str .= "the searched item '$1' was not found" ; } else { $str .= "you may have specified too many '-' in your command"; } Config::Model::Exception::Load->throw( command => $command[0], error => $str, object => $node ) if $check eq 'yes'; } if (%args) { Config::Model::Exception::Internal->throw( error => __PACKAGE__ . " load: unexpected parameters: " . join( ', ', keys %args ) ); } return $ret; } # returns elt action id subaction value sub _split_cmd { my $cmd = shift; $logger->trace("split on: ->$cmd<-"); my $quoted_string = qr/(?:"(?: \\" | [^"] )* ")|(?:'(?: \\' | [^'] )* ')/x; # quoted string # do a split on ' ' but take quoted string into account my @command = ( $cmd =~ m!^ (\w[\w-]*)? # element name can be alone (?: (:~|:-[=~]?|:=~|:\.\w+|:[=<>@]?|~) # action (?: (?: \( ( $quoted_string | [^)]+ ) \) ) # capture parameters between ( ) | ( /[^/]+/ # regexp | (?: $quoted_string (?:,)? | [^#=\.<>]+ # non action chars )+ ) )? )? (?: (=~|\.=|=\.\w+|[=<>]) # apply regexp or assign or append (?: (?: \( ( $quoted_string | [^)]+ ) \) ) # capture parameters between ( ) | ( (?: $quoted_string | [^#\s"'] # or non whitespace )+ # many ) )? )? (?: \# # optional annotation ( (?: $quoted_string | [^\s] # or non whitespace )+ # many ) )? (.*) # leftover !gx ); my $leftout = pop @command; if ($leftout) { Config::Model::Exception::Load->throw( command => $cmd, error => "Syntax error: spurious char at command end: '$leftout'. Did you forget double quotes ?" ); } return @command; } my %load_dispatch = ( node => \&_walk_node, warped_node => \&_walk_node, hash => \&_load_hash, check_list => \&_load_check_list, list => \&_load_list, leaf => \&_load_leaf, ); # return 'done', 'root', 'up', 'error' sub _load { my ( $self, $node, $check, $cmdref, $at_top_level ) = @_; $at_top_level ||= 0; my $node_name = "'" . $node->name . "'"; $logger->trace("_load: called on node $node_name"); my $inst = $node->instance; my $cmd; while ( $cmd = shift @$cmdref ) { if ( $logger->is_debug ) { my $msg = $cmd; $msg =~ s/\n/\\n/g; $logger->debug("Loader: Executing cmd '$msg' on node $node_name"); } next if $cmd =~ /^\s*$/; if ( $cmd eq '!' ) { $self->_log_cmd(\$cmd,"Going from %name to root node", $node ); $logger->debug("_load: going to root, at_top_level is $at_top_level"); # Do not change current node as we don't want to mess up =~ commands return 'root'; } if ( $cmd eq '-' ) { my $parent = $node->parent; if (defined $parent) { $self->_log_cmd($cmd,'Going up from %name to %name', $node, $node->parent); } else { $self->_log_cmd($cmd,'Going up from %name to exit Loader.', $node); } return 'up'; } if ( $cmd =~ m!^/([\w-]+)! ) { my $search = $1; if ($node->has_element($search)) { $self->_log_cmd($cmd, 'Element %qs found in current node (%name).', $search, $node); $cmd =~ s!^/!! ; } else { $self->_log_cmd( $cmd, 'Going up from %name to %name to search for element %qs.', $node, $node->parent, $search ); unshift @$cmdref, $cmd; return 'up'; } } my ( $element_name, $action, $function_param, $id, $subaction, $value_function_param2, $value_param, $note ) = _split_cmd($cmd); # regexp ensure that only $value_function_param $value_param is set my $value = $value_function_param2 // $value_param ; my @instructions = ( $element_name, $action, $function_param, $id, $subaction, $value, $note ); if ( $logger->is_debug ) { my @disp = map { defined $_ ? "'$_'" : '' } @instructions; $logger->debug("_load instructions: @disp (from: $cmd)"); } if ( not defined $element_name and not defined $note ) { Config::Model::Exception::Load->throw( command => $cmd, error => 'Syntax error: cannot find element in command' ); } unless ( defined $node ) { Config::Model::Exception::Load->throw( command => $cmd, error => "Error: Got undefined node" ); } unless ( $node->isa("Config::Model::Node") or $node->isa("Config::Model::WarpedNode") ) { Config::Model::Exception::Load->throw( command => $cmd, error => "Error: Expected a node (even a warped node), got '" . $node->name . "'" ); # below, has_element method from WarpedNode will raise # exception if warped_node is not available } if ( not defined $element_name and defined $note ) { $self->_set_note($node, \$cmd, $note); next; } unless ( $node->has_element($element_name) ) { Config::Model::Exception::UnknownElement->throw( object => $node, element => $element_name, ) if $check eq 'yes'; unshift @$cmdref, $cmd; return 'error'; } unless ( $node->is_element_available( name => $element_name ) ) { Config::Model::Exception::UnavailableElement->throw( object => $node, element => $element_name ) if $check eq 'yes'; unshift @$cmdref, $cmd; return 'error'; } unless ( $node->is_element_available( name => $element_name ) ) { Config::Model::Exception::RestrictedElement->throw( object => $node, element => $element_name, ) if $check eq 'yes'; unshift @$cmdref, $cmd; return 'error'; } my $element_type = $node->element_type($element_name); my $method = $load_dispatch{$element_type}; croak "_load: unexpected element type '$element_type' for $element_name" unless defined $method; $logger->debug("_load: calling $element_type loader on element $element_name"); my $ret = $self->$method( $node, $check, \@instructions, $cmdref, $cmd ); $logger->debug("_load: $element_type loader on element $element_name returned $ret"); die "Internal error: method dispatched for $element_type returned an undefined value " unless defined $ret; if ( $ret eq 'error' or $ret eq 'done' ) { $logger->debug("_load return: $node_name got $ret"); return $ret; } if ( $ret eq 'root' and not $at_top_level ) { $logger->debug("_load return: $node_name got $ret"); return 'root'; } # ret eq up or ok -> go on with the loop } return 'done'; } sub _set_note { my ($self, $target, $cmd, $note) = @_; $self->_log_cmd($cmd, "Setting %name annotation to %qs", $target, $note); $target->annotation($note); } sub _load_note { my ( $self, $target_obj, $note, $instructions, $cmdref, $cmd ) = @_; unquote($note); # apply note on target object if ( defined $note ) { if ( defined $target_obj ) { $self->_set_note($target_obj, $cmd,$note); } else { Config::Model::Exception::Load->throw( command => $$cmdref, error => "Error: cannot set annotation with '" . join( "','", grep { defined $_ } @$instructions ) . "'" ); } } } sub _walk_node { my ( $self, $node, $check, $inst, $cmdref, $cmd ) = @_; my $element_name = shift @$inst; my $note = pop @$inst; my $new_node = $node->fetch_element($element_name); $self->_load_note( $new_node, $note, $inst, $cmdref, $cmd ); my @left = grep { defined $_ } @$inst; if (@left) { Config::Model::Exception::Load->throw( command => $inst, object => $node, error => "Don't know what to do with '@left' " . "for node element $element_name" ); } $self->_log_cmd($cmd, 'Going down from %name to %name', $node, $new_node); return $self->_load( $new_node, $check, $cmdref ); } sub unquote { for (@_) { if (defined $_) { s/(?fetch_element( name => $element_name, check => $check ); if ( defined $note and not defined $action and not defined $subaction ) { $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); return 'ok'; } if ( defined $subaction and $subaction eq '=' ) { $logger->debug("_load_check_list: set whole list"); $self->_log_cmd($cmd, 'Setting %name items %qs.', $element, $value); # valid for check_list or list $element->load( $value, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); return 'ok'; } if ( not defined $action and defined $subaction ) { Config::Model::Exception::Load->throw( object => $element, command => join( '', grep { defined $_} @$inst ), error => "Wrong assignment with '$subaction' on check_list" ); } my $a_str = defined $action ? $action : ''; Config::Model::Exception::Load->throw( object => $element, command => join( '', map { $_ || '' } @$inst ), error => "Wrong assignment with '$a_str' on check_list" ); } { # sub is called with ( $self, $element, $check, $instance, @function_args ) # function_args are the arguments passed to the load command my %dispatch_action = ( list_leaf => { ':.sort' => sub { $_[1]->sort; return 'ok';}, ':.push' => sub { $_[1]->push( @_[ 5 .. $#_ ] ); return 'ok'; }, ':.unshift' => sub { $_[1]->unshift( @_[ 5 .. $#_ ] ); return 'ok'; }, ':.insert_at' => sub { $_[1]->insert_at( @_[ 5 .. $#_ ] ); return 'ok'; }, ':.insort' => sub { $_[1]->insort( @_[ 5 .. $#_ ] ); return 'ok'; }, ':.insert_before' => \&_insert_before, ':.ensure' => \&_ensure_list_value, }, 'list_*' => { ':.copy' => sub { $_[1]->copy( $_[5], $_[6] ); return 'ok'; }, ':.clear' => sub { $_[1]->clear; return 'ok'; }, }, hash_leaf => { ':.insort' => sub { $_[1]->insort($_[5])->store($_[6]); return 'ok'; }, }, hash_node => => { ':.insort' => \&_insort_hash_of_node, }, 'hash_*' => { ':.sort' => sub { $_[1]->sort; return 'ok'; }, ':.copy' => sub { $_[1]->copy( $_[5], $_[6] ); return 'ok'; }, ':.rename' => sub { $_[1]->move( $_[5], $_[6] ); return 'ok'; }, ':.clear' => sub { $_[1]->clear; return 'ok';}, }, # part of list or hash. leaf element have their own dispatch table # (%load_value_dispatch) because the signture of the sub ref are # different between the 2 dispatch tables. leaf => { ':.rm_value' => \&_remove_by_value, ':.rm_match' => \&_remove_matched_value, ':.substitute' => \&_substitute_value, }, fallback => { ':.rm' => \&_remove_by_id, ':.json' => \&_load_json_vector_data, } ); my %equiv = ( 'hash_*' => { qw/:@ :.sort :.move :.rename/}, list_leaf => { qw/:@ :.sort :< :.push :> :.unshift/ }, # fix for cme gh#2 leaf => { qw/:-= :.rm_value :-~ :.rm_match :=~ :.substitute/ }, fallback => { qw/:- :.rm ~ :.rm/ }, ); while ( my ($target, $sub_equiv) = each %equiv) { while ( my ($new_action, $existing_action) = each %$sub_equiv) { $dispatch_action{$target}{$new_action} = $dispatch_action{$target}{$existing_action}; } } sub _get_dispatch_data { my ($dispatch, $type, $cargo_type, $action) = @_; return $dispatch->{ $type.'_'.$cargo_type }{$action} || $dispatch->{$type.'_*'}{$action} || $dispatch->{$cargo_type}{$action} || $dispatch->{'fallback'}{$action}; } sub _get_dispatch { my ($self, $element, $type, $cargo_type, $action, $cmd, @f_args, ) = @_; return unless (defined $action and $action ne ':'); my $dispatch = _get_dispatch_data(\%dispatch_action, $type => $cargo_type, $action); if ($dispatch) { my $real_action = _get_dispatch_data(\%equiv, $type => $cargo_type, $action) // $action; $self->_log_cmd($cmd, 'Running %qs on %name with %qa.', substr($real_action,2), $element, \@f_args); } return $dispatch; } } sub _insert_before { my ( $self, $element, $check, $inst, $cmdref, $before_str, @values ) = @_; my $before = ($before_str =~ s!^/!! and $before_str =~ s!/$!!) ? qr/$before_str/ : $before_str; $element->insert_before( $before, @values ); return 'ok'; } sub _ensure_list_value { my ( $self, $element, $check, $inst, $cmdref, @values ) = @_; my %content = map { $_ => 1 } $element->fetch_all_values; foreach my $one_value (@values) { next if $content{$one_value}; $element->insort($one_value); $content{$one_value} = 1; } return 'ok'; } sub _remove_by_id { my ( $self, $element, $check, $inst, $cmdref, $id ) = @_; $logger->debug("_remove_by_id: removing id '$id'"); $element->remove($id); return 'ok'; } sub __load_json_file ($file) { # utf8 decode is done by JSON module, so slurp_raw must be used return decode_json($file->slurp_raw); } sub _load_json_vector_data { my ( $self, $element, $check, $inst, $cmdref, $vector ) = @_; $logger->debug("_load_json_vector_data: loading '$vector'"); my ($file, @vector) = $self->__get_file_from_vector($element,$inst,$vector); my $data = __load_json_file($file); # test for diff before clobbering ? What about deep data ??? $element->load_data( data => __data_from_vector($data, @vector), check => $check ); return 'ok'; } sub _remove_by_value { my ( $self, $element, $check, $inst, $cmdref, $rm_val ) = @_; $logger->debug("_remove_by_value value $rm_val"); foreach my $idx ( $element->fetch_all_indexes ) { my $v = $element->fetch_with_id($idx)->fetch; $element->delete($idx) if defined $v and $v eq $rm_val; } return 'ok'; } sub _remove_matched_value { my ( $self, $element, $check, $inst, $cmdref, $rm_val ) = @_; $logger->debug("_remove_matched_value $rm_val"); $rm_val =~ s!^/|/$!!g; foreach my $idx ( $element->fetch_all_indexes ) { my $v = $element->fetch_with_id($idx)->fetch; $element->delete($idx) if defined $v and $v =~ /$rm_val/; } return 'ok'; } sub _substitute_value { my ( $self, $element, $check, $inst, $cmdref, $s_val ) = @_; $logger->debug("_substitute_value $s_val"); foreach my $idx ( $element->fetch_all_indexes ) { my $l = $element->fetch_with_id($idx); $self->_load_value( $l, $check, '=~', $s_val, $inst ); } return 'ok'; } sub _insort_hash_of_node { my ( $self, $element, $check, $inst, $cmdref, $id ) = @_; my $node = $element->insort($_[5]); $logger->debug("_insort_hash_of_node: calling _load on node id $id"); return $self->_load( $node, $check, $cmdref ); } sub _load_list { my ( $self, $node, $check, $inst, $cmdref, $cmd ) = @_; my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$inst; my $element = $node->fetch_element( name => $element_name, check => $check ); my @f_args = grep { defined } ( ( $f_arg // $id // '' ) =~ /([^,"]+)|"([^"]+)"/g ); my $elt_type = $node->element_type($element_name); my $cargo_type = $element->cargo_type; if ( defined $note and not defined $action and not defined $subaction ) { $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); return 'ok'; } if ( defined $action and $action eq ':=' and $cargo_type eq 'leaf' ) { # due to ':=' action, the value is contained in $id $logger->debug("_load_list: set whole list with ':=' action"); # valid for check_list or list $self->_log_cmd($cmd, 'Setting %name values to %qs.', $element, $id); $element->load( $id, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); return 'ok'; } # compat mode for list=a,b,c,d commands if ( not defined $action and defined $subaction and $subaction eq '=' and $cargo_type eq 'leaf' ) { $logger->debug("_load_list: set whole list with '=' subaction'"); # valid for check_list or list $self->_log_cmd($cmd, 'Setting %name values to %qs.', $element, $value); $element->load( $value, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); return 'ok'; } unquote( $id, $value, $note ); if ( my $dispatch = $self->_get_dispatch($element, list => $cargo_type, $action, $cmd, @f_args)) { return $dispatch->( $self, $element, $check, $inst, $cmdref, @f_args ); } if ( not defined $action and defined $subaction ) { Config::Model::Exception::Load->throw( object => $element, command => join( '', grep { defined $_} @$inst ), error => "Wrong assignment with '$subaction' on " . "element type: $elt_type, cargo_type: $cargo_type" ); } if ( defined $action and $action eq ':' ) { unquote($id); my $obj = $element->fetch_with_id( index => $id, check => $check ); $self->_load_note( $obj, $note, $inst, $cmdref, $cmd ); if ( $cargo_type =~ /node/ ) { # remove possible leading or trailing quote $self->_log_cmd($cmd,'Going down from %name to %name', $node, $obj ); return $self->_load( $obj, $check, $cmdref ); } return 'ok' unless defined $subaction; if ( $cargo_type =~ /leaf/ ) { $logger->debug("_load_list: calling _load_value on $cargo_type id $id"); # _log_cmd done in _load_value $self->_load_value( $obj, $check, $subaction, $value, $cmdref, $cmd ) and return 'ok'; } } my $a_str = defined $action ? $action : ''; Config::Model::Exception::Load->throw( object => $element, command => join( '', map { $_ || '' } @$inst ), error => "Wrong assignment with '$a_str' on " . "element type: $elt_type, cargo_type: $cargo_type" ); } sub _load_hash { my ( $self, $node, $check, $inst, $cmdref, $cmd ) = @_; my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$inst; unquote( $id, $value, $note ); my $element = $node->fetch_element( name => $element_name, check => $check ); my $cargo_type = $element->cargo_type; if ( defined $note and not defined $action ) { # _log_cmd done in _load_note $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); return 'ok'; } if ( not defined $action ) { Config::Model::Exception::Load->throw( object => $element, command => join( '', map { $_ || '' } @$inst ), error => "Missing key (e.g. '$element_name:some_key') on hash element, cargo_type: $cargo_type" ); } # loop requires $subaction so does not fit in the dispatch table if ( $action eq ':~' or $action eq ':.foreach_match' ) { my @keys = $element->fetch_all_indexes; my $ret = 'ok'; my $pattern = $id // $f_arg; $pattern =~ s!^/|/$!!g if $pattern; my @loop_on = $pattern ? grep { /$pattern/ } @keys : @keys; if ($logger->is_debug) { my $str = $pattern ? " with regex /$pattern/" : ''; $logger->debug("_load_hash: looping$str on keys @loop_on"); } my @saved_cmd = @$cmdref; foreach my $loop_id ( @loop_on ) { @$cmdref = @saved_cmd; # restore command before loop my $sub_elt = $element->fetch_with_id($loop_id); $self->_log_cmd($cmd,'Running foreach_map loop on %name.',$sub_elt); if ( $cargo_type =~ /node/ ) { # remove possible leading or trailing quote $ret = $self->_load( $sub_elt, $check, $cmdref ); } elsif ( $cargo_type =~ /leaf/ ) { $ret = $self->_load_value( $sub_elt, $check, $subaction, $value, $cmdref, $cmd ); } else { Config::Model::Exception::Load->throw( object => $element, command => join( '', @$inst ), error => "Hash assignment with '$action' on unexpected " . "cargo_type: $cargo_type" ); } $logger->debug("_load_hash: loop on id $loop_id returned $ret (left cmd: @$cmdref)"); if ( $ret eq 'error') { return $ret; } } return $ret; } my @f_args = grep { defined } ( ( $f_arg // $id // '' ) =~ /([^,"]+)|"([^"]+)"/g ); if ( my $dispatch = $self->_get_dispatch($element, hash => $cargo_type, $action, $cmd, @f_args)) { return $dispatch->( $self, $element, $check, $inst, $cmdref, @f_args ); } if (not defined $id) { Config::Model::Exception::Load->throw( object => $element, command => join( '', @$inst ), error => qq!Unexpected hash instruction: '$action' or missing id! ); } my $obj = $element->fetch_with_id( index => $id, check => $check ); $self->_load_note( $obj, $note, $inst, $cmdref, $cmd ); if ( $action eq ':' and $cargo_type =~ /node/ ) { # remove possible leading or trailing quote $self->_log_cmd($cmd,'Going down from %name to %name', $node, $obj ); if ( defined $subaction ) { Config::Model::Exception::Load->throw( object => $element, command => join( '', @$inst ), error => qq!Hash assignment with '$action"$id"$subaction"$value"' on unexpected ! . "cargo_type: $cargo_type" ); } return $self->_load( $obj, $check, $cmdref ); } elsif ( $action eq ':' and defined $subaction and $cargo_type =~ /leaf/ ) { # _log_cmd is done in _load_value $logger->debug("_load_hash: calling _load_value on leaf $id"); $self->_load_value( $obj, $check, $subaction, $value, $cmdref, $cmd ) and return 'ok'; } elsif ( $action eq ':' ) { $self->_log_cmd($cmd,'Creating empty %name.', $obj ); $logger->debug("_load_hash: created empty element of type $cargo_type"); return 'ok'; } elsif ($action) { $logger->debug("_load_hash: giving up"); Config::Model::Exception::Load->throw( object => $element, command => join( '', grep { defined $_ } @$inst ), error => "Hash load with '$action' on unexpected " . "cargo_type: $cargo_type" ); } } sub _load_leaf { my ( $self, $node, $check, $inst, $cmdref, $cmd ) = @_; my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$inst; unquote( $id, $value ); my $element = $node->fetch_element( name => $element_name, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref, $cmd ); if ( defined $action and $element->isa('Config::Model::Value')) { if ($action eq '~') { $self->_log_cmd($cmd, "Deleting %name.", $element ); $element->store(value => undef, check => $check); } elsif ($action eq ':') { Config::Model::Exception::Load->throw( object => $element, command => $inst, error => "Error: list or hash command (':') detected on a leaf." . "(element '" . $element->name . "')" ); } else { Config::Model::Exception::Load->throw( object => $element, command => $inst, error => "Load error on leaf with " . "'$element_name$action$id' command " . "(element '" . $element->name . "')" ); } } return 'ok' unless defined $subaction; if ( $logger->is_debug ) { my $msg = defined $value ? $value : ''; $msg =~ s/\n/\\n/g; $logger->debug("_load_leaf: action '$subaction' value '$msg'"); } my $res = $self->_load_value( $element, $check, $subaction, $value, $inst, $cmd ); return $res if $res ; Config::Model::Exception::Load->throw( object => $element, command => $inst, error => "Load error on leaf with " . "'$element_name$subaction$value' command " . "(element '" . $element->name . "')" ); } # sub is called with ( $self, $element, $value, $check, $instructions ) # function_args are the arguments passed to the load command my %load_value_dispatch = ( '=' => \&_store_value , '.=' => \&_append_value, '=~' => \&_apply_regexp_on_value, '=.file' => \&_store_file_in_value, '=.set_to_std_value' => \&_set_to_standard_value, '=.set_to_standard_value' => \&_set_to_standard_value, '=.json' => \&_store_json_vector_in_value, '=.yaml' => \&_store_yaml_vector_in_value, '=.env' => sub { $_[1]->store( value => $ENV{$_[2]}, check => $_[3] ); return 'ok'; }, ); sub _store_value { my ( $self, $element, $value, $check, $instructions, $cmd ) = @_; $self->_log_cmd($cmd, 'Setting %leaf to %qs.', $element, $value); $element->store( value => $value, check => $check ); return 'ok'; } sub _append_value { my ( $self, $element, $value, $check, $instructions, $cmd ) = @_; my $orig = $element->fetch( check => $check ); my $next = $orig.$value; $self->_log_cmd( $cmd, 'Appending %qs to %leaf. Result is %qs.', $value, $element, $next ); $element->store( value => $next, check => $check ); } sub _apply_regexp_on_value { my ( $self, $element, $value, $check, $instructions, $cmd ) = @_; my $orig = $element->fetch( check => $check ); if (defined $orig) { # $value may change at each run and is like s/foo/bar/ do block # eval is not possible eval("\$orig =~ $value;"); ## no critic (ProhibitStringyEval) my $res = $@; $self->_log_cmd( $cmd, "Applying regexp %qs to %leaf. Result is %qs.", $value, $element, $orig ); if ($res) { Config::Model::Exception::Load->throw( object => $element, command => $instructions, error => "Failed regexp '$value' on " . "element '" . $element->name . "' : $res" ); } $element->store( value => $orig, check => $check ); } else { $self->_log_cmd( $cmd, "Not applying regexp %qs on undefined value of %leaf.", $value, $element, $orig ); } } sub _set_to_standard_value { my ( $self, $element, $value, $check, $instructions, $cmd ) = @_; # check value is done by store $element->store($element->_fetch_std_no_check); } sub _store_file_in_value { my ( $self, $element, $value, $check, $instructions, $cmd ) = @_; if ($value eq '-') { $element->store( value => join('',), check => $check ); return 'ok'; } my $path = $element->root_path->child($value); if ($path->is_file) { $element->store( value => $path->slurp_utf8, check => $check ); } else { Config::Model::Exception::Load->throw( object => $element, command => $instructions, error => "cannot read file $value" ); } } sub __data_from_vector { my ($data, @vector) = @_; for my $step (@vector) { $data = (ref($data) eq 'HASH') ? $data->{$step} : $data->[$step]; } return $data; } sub __get_file_from_vector { my ($self, $element,$instructions,$raw_vector) = @_; my @vector = split m![/]+!m, $raw_vector; my $cur = path('.'); my $file; while (my $subpath = shift @vector) { my $new_path = $cur->child($subpath); if ($new_path->is_file) { $file = $new_path; last; } elsif ($new_path->is_dir) { $cur = $new_path; } } if (not defined $file) { my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$instructions; Config::Model::Exception::Load->throw( object => $element, command => "$element_name" . ( $action ? "$action($f_arg)" : '' ) . ( $subaction ? "$subaction($value)" : '' ), error => qq!Load error: Cannot find file in $value! ); } return ($file, @vector); } sub _store_json_vector_in_value { my ( $self, $element, $value, $check, $instructions, $cmd ) = @_; my ($file, @vector) = $self->__get_file_from_vector($element,$instructions,$value); my $data = __load_json_file($file); $element->store( value => __data_from_vector($data, @vector), check => $check ); } sub _store_yaml_vector_in_value { my ( $self, $element, $value, $check, $instructions, $cmd ) = @_; my ($file, @vector) = $self->__get_file_from_vector($element,$instructions,$value); my $data = YAML::Tiny->read($file->stringify); $element->store( value => __data_from_vector($data, @vector), check => $check ); } sub _load_value { my ( $self, $element, $check, $subaction, $value, $instructions, $cmd ) = @_; if (not $element->isa('Config::Model::Value')) { my $class = ref($element); Config::Model::Exception::Load->throw( object => $element, command => $instructions, error => "Load error: _load_value called on non Value object. ($class)" ); } $logger->debug("_load_value: action '$subaction' value '$value' check $check"); my $dispatch = $load_value_dispatch{$subaction}; if ($dispatch) { return $dispatch->( $self, $element, $value, $check, $instructions, $cmd ); } else { Config::Model::Exception::Load->throw( object => $element, command => $instructions, error => "Unexpected operator or function on value: $subaction" ); } $logger->debug("_load_value: done returns ok"); return 'ok'; } 1; # ABSTRACT: Load serialized data into config tree __END__ =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "Foo", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, ] ); $model ->create_config_class ( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, hash_of_nodes => { type => 'hash', # hash id index_type => 'string', cargo => { type => 'node', config_class_name => 'Foo' }, }, [qw/lista listb/] => { type => 'list', cargo => {type => 'leaf', value_type => 'string' } }, ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put data my $steps = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello ! lista=foo,bar lista:2=baz listb:0=foo listb:1=baz'; $root->load( steps => $steps ); my $s = $root->fetch_element_value('foo'); # => is 'FOO' $s = $root->grab_value('hash_of_nodes:en foo'); # => is 'hello' $s = $root->grab_value('lista:1'); # => is 'bar' $s = $root->grab_value('lista:2'); # => is 'baz' # delete some data $root->load( steps => 'lista~2' ); $s = $root->grab_value('lista:2'); # => is undef # append some data $root->load( steps => q!hash_of_nodes:en foo.=" world"! ); $s = $root->grab_value('hash_of_nodes:en foo'); # => is 'hello world' =head1 DESCRIPTION This module is used directly by L to load serialized configuration data into the configuration tree. Serialized data can be written by the user or produced by L while dumping data from a configuration tree. =head1 CONSTRUCTOR =head2 new The constructor should be used only by L. Parameters: =over =item start_node node ref of the root of the tree (of sub-root) to start the load from. Stored as a weak reference. =back =head1 load string syntax The string is made of the following items (also called C) separated by spaces. These actions can be divided in 4 groups: =over =item * navigation: moving up and down the configuration tree. =item * list and hash operation: select, add or delete hash or list item (also known as C items) =item * leaf operation: select, modify or delecte leaf value =item * annotation: modify or delete configuration annotation (aka comment) =back =head2 navigation =over 8 =item - Go up one node =item ! Go to the root node of the configuration tree. =item xxx Go down using C element. (For C type element) =item /xxx Go up until the element C is found. This search can be combined with one of the command specified below, e.g C =back =head2 list and hash operation =over =item xxx:yy Go down using C element and id C (For C or C element with C cargo_type). Literal C<\n> are replaced by real C<\n> (LF in Unix). =item xxx:.foreach_match(yy) or xxx:~yy Go down using C element and loop over the ids that match the regex specified by C. (For C). For instance, with C model, you could do Host:~"/.*.debian.org/" user='foo-guest' to set "foo-user" users for all your debian accounts. The leading and trailing '/' may be omitted. Be sure to surround the regexp with double quote if space are embedded in the regex. Note that the loop ends when the load command goes above the element where the loop is executed. For instance, the instruction below tries to execute C and C for all elements of C hash: std_id:~/^\w+$/ DX=Bv int_v=9 In the examples below only C is executed by the loop: std_id:~/^\w+$/ DX=Bv - int_v=9 std_id:~/^\w+$/ DX=Bv ! int_v=9 The loop is done on all elements of the hash when no value is passed after "C<:~>" (mnemonic: an empty regexp matches any value). =item xxx:.rm(yy) or xxx:-yy Delete item referenced by C element and id C. For a list, this is equivalent to C. This command does not go down in the tree (since it has just deleted the element). I.e. a 'C<->' is generally not needed afterwards. =item xxx:.rm_value(yy) or xxx:-=yy Remove the element whose value is C. For list or hash of leaves. Does not not complain if the value to delete is not found. =item xxx:..rm_match(yy) or xxx:-~/yy/ Remove the element whose value matches C. For list or hash of leaves. Does not not complain if no value were deleted. =item xxx:.substitute(/yy/zz/) or xxx:=~s/yy/zz/ Substitute a value with another. Perl switches can be used(e.g. C) =item xxx: value on C list =item xxx:>yy or xxx:.unshift(yy) Unshift C value on C list =item xxx:@ or xxx:.sort Sort the list =item xxx:.insert_at(yy,zz) Insert C value on C list before B C. =item xxx:.insert_before(yy,zz) Insert C value on C list before B C. =item xxx:.insert_before(/yy/,zz) Insert C value on C list before B matching C. =item xxx:.insort(zz) Insert C value on C list so that existing alphanumeric order is preserved. =item xxx:.insort(zz) For hash element containing nodes: creates a new hash element with C key on C hash so that existing alphanumeric order of keys is preserved. Note that all keys are sorted once this instruction is called. Following instructions are applied on the created element. I.e. putting key order aside, C has the same effect as C instruction. =item xxx:.insort(zz,vv) For hash element containing leaves: creates a new hash element with C key and assing value C so that existing alphanumeric order of keys is preserved. Note that all keys are sorted once this instruction is called. Putting key order aside, C has the same effect as C instruction. =item xxx:.ensure(zz,...) Ensure that list C contains value C. If value C is already stored in C list, this function does nothing. In the other case, value C is inserted in alphabetical order. This function accepts a list of values separated by a comma. =item xxx:=z1,z2,z3 Set list element C to list C. Use C<,,> for undef values, and C<""> for empty values. I.e, for a list C<('a',undef,'','c')>, use C. =item xxx:yy=zz For C element containing C cargo_type. Set the leaf identified by key C to value C. Using C is also possible. =item xxx:.copy(yy,zz) copy item C in C (hash or list). =item xxx:.rename(yy,zz) rename item C in C (hash). =item xxx:.move(yy,zz) Alias to rename. =item xxx:.json("path/to/file.json/foo/bar") Store C content in array or hash. This should be used to store hash or list of values. You may store deep data structure. In this case, make sure that the structure of the loaded data matches the structure of the model. This won't happen by chance. =item xxx:.clear Clear the hash or list. =back =head2 leaf operation =over =item xxx=zz Set element C to value C. load also accepts to set elements with a quoted string. (For C element) Literal C<\n> are replaced by real C<\n> (LF in Unix). Literal C<\\> are replaced by C<\>. For instance C or C. =item xxx=~s/foo/bar/ Apply the substitution to the value of xxx. C is the standard Perl C substitution pattern. Patterns with white spaces must be surrounded by quotes: xxx=~"s/foo bar/bar baz/" Perl pattern modifiers are accepted xxx=~s/FOO/bar/i =item xxx~ Undef element C =item xxx.=zzz Appends C value to current value (valid for C elements). =item xxx=.set_to_standard_value() Set to standard value. Standard value is like a suggested value which requires an action from user to be set. C is also accepted. =item xxx=.file(yyy) Store the content of file C in element C. Store STDIn in value xxx when C is '-'. =item xxx=.json(path/to/data.json/foo/bar) Open file C and store value from JSON data extracted with C subpath. For instance, if C contains: { "foo": { "bar": 42 } } The instruction C stores C<42> in C element. =item xxx=.yaml(path/to/data.yaml/0/foo/bar) Open file C and store value from YAML data extracted with C<0/foo/bar> subpath. Since a YAML file can contain several documents (separated by C<---> lines, the subpath must begin with a number to select the document containing the required value. For instance, if C contains: --- foo: bar: 42 The instruction C stores C<42> in C element. =item xxx=.env(yyy) Store the content of environment variable C in element C. =back =head2 annotation =over =item xxx#zzz or xxx:yyy#zzz Element annotation. Can be quoted or not quoted. Note that annotations are always placed at the end of an action item. I.e. C, C or C are valid. C is B valid. =back =head2 Quotes You can surround indexes and values with single or double quotes. E.g.: a_string='"foo" and "bar"' Single quotes were added in version 2.153. =head1 Examples You can use L to modify configuration with C command. For instance, if L is installed, you can run: cme modify ssh 'ControlMaster=auto ControlPath="~/.ssh/master-%r@%n:%p"' To delete C entry: cme modify ssh 'Host:-"*"' To specify 2 C with a single command: cme modify ssh 'Host:"foo* bar*" ForwardX11=yes HostName="foo.com" - Host:baz HostName="baz.com"' Note the 'C<->' used to go up one node before "C". In this case, "up one node" leads to the "root node", so "C" could also be used instead of "C<->": cme modify ssh 'Host:"foo* bar*" ForwardX11=yes HostName="foo.com" ! Host:baz HostName="baz.com"' Let's modify now the host name of using a C<.org> domain instead of C<.com>. The C<:~> operator uses a regexp to loop over several Host entries: cme modify ssh 'Host:~/ba[rz]/ HostName=~s/.com$/.org/' Now that ssh config is mucked up with dummy entries, let's clean up: cme modify ssh 'Host:-"baz" Host:-"foo* bar*"' =head1 Methods =head2 load Load data into the node tree (from the node passed with C) and fill values as we go following the instructions passed with C. (C can also be an array ref). Parameters are: =over =item steps (or step) A string or an array ref containing the steps to load. See L for a description of the string. =item check Whether to check values while loading. Either C (default), C or C. Bad values are discarded when C is set to C. =item caller_is_root Change the target of the C command: when set, the C command go to caller node instead of going to root node. (default is false) =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L =cut libconfig-model-perl-2.155/lib/Config/Model/Manual/000077500000000000000000000000001472064100600217505ustar00rootroot00000000000000libconfig-model-perl-2.155/lib/Config/Model/Manual/ModelCreationAdvanced.pod000066400000000000000000000203031472064100600266250ustar00rootroot00000000000000# PODNAME: Config::Model::Manual::ModelCreationAdvanced # ABSTRACT: Creating a model with advanced features =head1 Introduction The page L explains what is a configuration tree and a configuration model and how to create a simple configuration model. But a configuration model can be more complex and define interactions between elements with the following features: =over =item * Model warp. For instance, Xorg driver options change depending on driver name (C, C...) =item * Simple computation from other elements (used for upgrades) =item * References. For instance, in C, C name must refer to one of the monitors declared in C section. =back Caveat: Xorg examples are based on Xorg 1.4 and may not be valid for Xorg 1.5 or 1.6 =head1 Model plugin Config::Model can also use model plugins. Each model can be augmented by model snippets stored into directory C<< .d >>. All files found there are merged to existing model. For instance, this model in file C<.../Config/Model/models/Fstab/Fsline.pl>: { name => "Fstab::Fsline", element => [ fs_vfstype => { type => 'leaf', value_type => 'enum', choice => [ qw/ext2 ext3/ ], }, fs_mntopts => { type => 'warped_node', follow => { 'f1' => '- fs_vfstype' }, rules => [ '$f1 eq \'ext2\'', { 'config_class_name' => 'Fstab::Ext2FsOpt' }, '$f1 eq \'ext3\'', { 'config_class_name' => 'Fstab::Ext3FsOpt' }, ], } ] } can be augmented with the content of C<.../Config/Model/models/Fstab/Fsline.d/addext4.pl>: { name => "Fstab::Fsline", element => [ fs_vfstype => { choice => [ qw/ext4/ ], }, fs_mntopts => { rules => [ q!$f1 eq 'ext4'!, { 'config_class_name' => 'Fstab::Ext4FsOpt' }, ], }, ] } ; Then, the merged model will feature C with choice C. Likewise, C will feature rules for the 3 filesystems. Under the hood, L method is used to load model snippets. =head1 Model warp From a user's point of view, model warp looks like the structure or properties of the configuration is changing (or adapting) dynamically depending on the values being entered. For instance, when changing a driver name from C to C, some options disappear from the GUI and some other options pop-in. Model warping need not be that spectacular and can have more subtle effect like changing a default value. Of course, there's no magic, model warp properties needs to be prepared and declared in the model. =head2 Warped value Let's start simple with value warp: the properties of a single value is changed dynamically. Let's imagine a configuration file with 2 values: I which can be set to I or I and I whose maximum value is 10 when size is small and 50 when size is big. (this may be dumb, but it's for the sake of the example). So the basic model without warp is element => [ size => { type => 'leaf', value_type => 'enum', choice => ['big','small'], }, length => { type => 'leaf', value_type => 'integer', max => '10', }, ] Now we need to declare the relationship between I and I to be able to change dynamically the I property. This setup is made of 2 specifications: =over =item * what is the element that triggers the change (called I in the doc) =item * what is the effect of the warp master change =back The first is done with a declaration of the I to I to find the warp master (associated to a variable). The second is a set of value properties: element => [ size => { type => 'leaf', value_type => 'enum', choice => ['big','small'], }, length => { type => 'leaf', value_type => 'integer', warp => { # change specification follow => { # declare what trigger the change size_type => '- size' # size_type: go 1 level above and fetch # size value }, rules => { # how to apply change '$size_type eq "small"' => { # set max to 10 when size is small max => 10 }, '$size_type eq "big" ' => { # set max to 50 when size is big max => 50 }, }, }, } ] =head2 Warp in or warp out an element Here's a real use case scenario from OpenSsh. C enables a user to set up a tunnel through ssh. The input of this tunnel can listen to localhost (default) or to other hosts. These other hosts are specified by the I part of the C parameter. But this bind address is ignored if C is false (which is the default). In order to present only meaningful parameters to the user, I parameter must be hidden when C is false and shown when C is true. Here's the recipe. First create a boolean element for C: GatewayPorts => { type => 'leaf', value_type => 'boolean', upstream_default => 0, }, And C that provides I parameter: LocalForward => { type => 'list', cargo => { type => 'node', config_class_name => 'Ssh::PortForward' }, summary => 'Local port forwarding', } In C configuration class, declare I with the warp instructions: bind_address => { type => 'leaf', value_type => 'uniline', level => 'hidden', # by default, is hidden from user warp => { # instructions to show bind_address follow => { # specify what does trigger the change gp => '- - GatewayPorts' # gp: go to 2 levels above in tree ('- -') and # fetch GatewayPorts value }, rules => [ # specify how to apply the change triggered by gp '$gp' => { # apply change when $gp is true level => 'normal' # set level to normal (instead of 'hidden'). This change # will show this parameter in the UI } ] }, }, =head2 warped node Sometimes, warping a value line by line is not practical. For instance, in C the mount options of a file system change drastically from one file system to another. In this case, it's better to swap a configuration class with another. For instance, swap C mount options with C mount options when a file system is changed from C to C. Here's how this can be done. First declare the C parameter: fs_vfstype => { type => 'leaf', mandatory => 1, value_type => 'enum', choice => [ 'auto', 'davfs', 'vfat', 'ext2', 'ext3', ] , # etc ... } Then declare C as a B (not a simple C)) that uses C to swap one config class with another: fs_mntopts => { type => 'warped_node', # a shape-shifting node follow => { f1 => '- fs_vfstype' , # use fs_vfstype as a trigger }, rules => [ # condition => effect: config class to swap in "$f1 eq 'proc'" => { config_class_name => 'Fstab::CommonOptions' }, "$f1 eq 'auto'" => { config_class_name => 'Fstab::CommonOptions' }, "$f1 eq 'vfat'" => { config_class_name => 'Fstab::CommonOptions' }, "$f1 eq 'swap'" => { config_class_name => 'Fstab::SwapOptions' }, "$f1 eq 'ext3'" => { config_class_name => 'Fstab::Ext3FsOpt' }, # etc ... ] } =head1 References =head1 Computation and migrations =head2 Cascaded warp Config::Model also supports cascaded warps: A warped value is dependent on another value which is itself a warped value. =head1 Feedback welcome Feel free to send comments and suggestion about this page at config-model-users at lists dot sourceforge dot net. =head1 AUTHORS Dominique Dumont libconfig-model-perl-2.155/lib/Config/Model/Manual/ModelCreationIntroduction.pod000066400000000000000000000505311472064100600276070ustar00rootroot00000000000000# PODNAME: Config::Model::Manual::ModelCreationIntroduction # ABSTRACT: Introduction to model creation with Config::Model =head1 Introduction This page describes how to write a simple configuration model. Creation of more complex models are described in L. Note that this document shows a lot of Perl data structure to highlight the content of a model. A Perl data structure is very similar to a JSON structure. The only thing you need to know are: =over =item * Curly braces C<{ ... }> contain a dictionary of key, value pairs (a C in Perl land)) =item * Square brackets C<[ ... ]> contain a list of items (C or C in Perl land) =back =head1 Some definitions =over =item configuration file Text file where configuration data are stored. This configuration file is used by an application -- the I =item configuration tree The semantic content of the configuration file stored in a tree representation =item configuration model Structure and constraints of the configuration tree. Like a schema for the configuration tree =item target application The application that uses the configuration file. The application can be of type C (i.e. the configuration file is located in C), C (i.e. the configuration file is located in a user directory like C<~/.config>) or C (the configuration file is in or below the current directory) =item end user User of the target application =item application developer Target application developer =item model developer People developing the configuration model. Not necessarily the application developer =back =head1 What is a configuration tree? Most configuration files are actually organized mostly as a tree structure. Depending on the syntax of the file, this structure may be obvious to see (e.g. for XML, Apache) or not so obvious (C syntax, INI syntax). For some files like C or C, this tree structure is quite flat. It looks much like a rake than a tree, but still, it's a tree. For instance, this C: $pdiffs 1 $max_wait 14 debian http://ftp.fr.debian.org/debian can have this tree representation: root |--pdiff=1 |--max_wait=14 `--distrib(debian)=http://ftp.fr.debian.org/debian Other configuration files like C or C have a structure that look more like a tree. For instance, consider this C snippet: Section "Device" Identifier "Device0" Driver "nvidia" EndSection Section "Screen" Identifier "Screen0" Device "Device0" Option "AllowGLXWithComposite" "True" Option "DynamicTwinView" "True" SubSection "Display" Depth 24 EndSubSection EndSection Knowing that Xorg.conf can have several Device or Screen sections identified by their C, the configuration can be represented in this tree as: root |--Device(Device0) | `--Driver=nvidia `--Screen(Screen0) |--Device=Device0 |--Option | |--AllowGLXWithComposite=True | `--DynamicTwinView=True `--Display `--Depth=24 One may argue that some C parameter refer to others (i.e.C and C value in C section) and so they cannot be represented as a tree. That's right, there are some more complex relations that are added to the tree structure. This will be covered in more details when dealing with complex models. In some other case, the structure of a tree is not fixed. For instance, C options in C are different depending on the value of the C. In this case, the structure of the configuration tree must be adapted (morphed) depending on a parameter value. Just like XML data can have Schema to validate their content, the configuration tree structure needs to have its own schema to validate its content. Since the tree structure cannot be represented as a static tree without reference, XML like schema are not enough to validate configuration data. L provides a kind of schema for configuration data that takes care of the cross references mentioned above and of the dynamic nature of the configuration tree required for C (and others). =head1 What is a model? A configuration model defines the configuration tree structure: =over =item * A model defines one or more configuration class =item * At least one class is required to define the configuration tree root =item * Each class contains several elements. An element can be: =over =item * A leaf to represent one configuration parameter =item * A list of hash of leaves to represent several parameter =item * A node to hold a node of a configuration tree =item * A list or hash of nodes =back =back These basic relations enable to define the main parts of a configuration tree. If we refer to the C example mentioned above, one only class is required (let's say the C class). This class must contain (see approx.conf man page): =over =item * A boolean leaf for C (1 if not specified) =item * An integer leaf for C (10 seconds unless specified otherwise) =item * A hash of string leaves for C (no default). =back A configuration model is stored this way by Config::Model: { name => 'Approx', element => [ pdiffs => { type => 'leaf', value_type => 'boolean', upstream_default => '1' }, max_wait => { type => 'leaf', value_type => 'integer', upstream_default => '10' }, distributions => { type => 'hash', index_type => 'string' , cargo => { value_type => 'uniline', type => 'leaf', }, } ] } The C example leads to a slightly more complex model with several classes: =over =item * C (root class) =item * C =item * C =item * C for the Screen options =item * C for theC subsection =back The root class is declared this way: { name => 'Xorg', element => [ Device => { type => 'hash', index_type => 'string' cargo => { type => 'node', config_class_name => 'Xorg::Device' }, }, Screen => { type => 'hash', index_type => 'string' cargo => { type => 'node', config_class_name => 'Xorg::Screen' }, }, ] } TheC class is: { name => 'Xorg::Screen', element => [ Device => { type' => 'leaf', value_type => 'uniline', }, Display => { type => 'hash', index_type => 'integer' cargo => { type => 'node', config_class_name => 'Xorg::Screen::Display' }, } Option => { type => 'node', config_class_name => 'Xorg::Screen::Option' }, ] } It's now time to detail how the elements of a class are constructed. =head1 Model analysis To define the required configuration classes, you should read the documentation of the target application to : =over =item * Find the structure of the configuration tree =item * Identify configuration parameters, their constraints and relations =back Last but not least, you should also find several valid examples of your application configuration. These examples can be used as non-regression tests and to verify that the application documentation was understood. =head1 Model declaration =head2 Configuration class declaration Since writing the data structure shown below is not fun (even with Perl), you are encouraged to use the model editor provided by L using C command (provided by L). This commands provides a GUI to create or update your model. When saving, C writes the data structure in the correct directory. =head2 Configuration class declaration (the hard way) In summary, configuration documentation is translated in a format usable by Config::Model: =over =item * The structure is translated into configuration classes =item * Configuration parameters are translated into elements =item * Constraints are translated into element attributes =back All models files must be written in a specific directory. For instance, for model C, you must create C<./lib/Config/Model/models/Xorg.pl>. Other classes like C can be stored in their own file C<./lib/Config/Model/models/Xorg/Screen.pl> or included in C A model file is a Perl file containing an array for hash ref. Each Hash ref contains a class declaration: [ { name => 'Xorg', ... } , { name => 'Xorg::Screen', ... } ] ; A class can have the following parameters: =over =item * name: mandatory name of the class =item * class_description: Description of the configuration class. =item * generated_by: Mention with a descriptive string if this class was generated by a program. This parameter is currently reserved for C model editor. =item * include: Include element description from another class. =back For more details, see L. For instance: $ cat lib/Config/Model/models/Xorg.pl [ { name => 'Xorg', class_description => 'Top level Xorg configuration.', include => [ 'Xorg::ConfigDir'], element => [ Files => { type => 'node', description => 'File pathnames', config_class_name => 'Xorg::Files' }, # snip ] }, { name => 'Xorg::DRI', element => [ Mode => { type => 'leaf', value_type => 'uniline', description => 'DRI mode, usually set to 0666' } ] } ]; =head2 Common attributes for all elements This first set of attributes helps the user by providing guidance (with C and C) and documentation (C and C). All elements (simple or complex) can have the following attributes: =over =item * C: full length description of the attribute =item * C: one line summary of the above description =item * C: is C, C or C. The level is used to set how configuration data is presented to the user in browsing mode. Important elements are shown to the user no matter what. hidden elements are explained with the warp notion. =item * C: is C, C or C (default). Warnings are shown when using a deprecated element and an exception is raised when an obsolete element is used. =back See L for details. =head2 Leaf elements Leaf element is the most common type to represent configuration data. A leaf element represents a specific configuration parameter. In more details, a leaf element have the following attributes (See L doc): =over =item type Set to C (mandatory) =item value_type Either C, C, C, C, C, C (i.e. a string without "\n") (mandatory) =item min Minimum value (for C or C) =item max Maximum value (for C or C) =item choice Possible values for an enum =item mandatory Whether the value is mandatory or not =item default Default value that must be written in the configuration file =item upstream_default Default value that is known by the target application and thus does not need to be written in the configuration file. =back To know which attributes to use, you should read the documentation of the target application. For instance, C parameter (sshd_config(5)) is specified with: I For Config::Model, C is a type C element, value_type C and the application falls back to C if this parameter is left blank in C file. Thus the model of this element is : AddressFamily => { type => 'leaf', value_type => 'enum', upstream_default => 'any', description => 'Specifies which address family should be used by sshd(8).', choice => [ 'any', 'inet', 'inet6' ] } =head2 Simple list or hash element Some configuration parameters are in fact a list or a hash of parameters. For instance, C can feature a list of remote repositories: # remote repositories debian http://ftp.fr.debian.org/debian multimedia http://www.debian-multimedia.org These repositorie URLs must be stored as a hash where the key is I or I and the associated value is a URL. But this hash must have something which is not explicit in C file: a parameter name. Approx man page mentions that: I. So let's use C as a parameter name. The example is stored this way in the configuration tree: root |--distribution(debian)=http://ftp.fr.debian.org/debian `--distribution(multimedia)=http://www.debian-multimedia.org The model needs to declare that C is: =over =item * a type C parameter =item * the hash key is a string =item * the values of the hash are of type C and value_type C =back distribution => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'uniline', }, summary => 'remote repositories', description => 'The other name/value pairs are ...', } For more details on list and hash elements, see L man page. =head2 node element A node element is necessary if the configuration file has more than a list of variable. In this case, the tree is deeper than a rake and a node element if necessary to provide a new node within the tree. In the Xorg example above, the options of C need their own sub-branch in the tree: Screen(Screen0) `--Option |--AllowGLXWithComposite=True `--DynamicTwinView=True For this, a new dedicated class is necessary>Xorg::Screen::Option> (see its declaration above). This new class must be tied to the Screen class with a node element. A node element has the following parameters: =over =item * type (set to C) =item * the name of the configuration class name (>config_class_name>) =back So the C