Config-Model-2.082000755001750001750 012676543661 13053 5ustar00domidomi000000000000TODO100644001750001750 101212676543661 13616 0ustar00domidomi000000000000Config-Model-2.082 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 o [domi] Provide import/export of configuration data in free form XML o [domi] REmove Exception::Class. Does not behave well when a error is throw within an external eval: error message in lost (seen with XML::Twig). * A web interface. May be a Webmin integration MODELS100644001750001750 102712676543661 14042 0ustar00domidomi000000000000Config-Model-2.082This 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 Changes100644001750001750 31117312676543661 14475 0ustar00domidomi000000000000Config-Model-2.0822.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 t000755001750001750 012676543661 13237 5ustar00domidomi000000000000Config-Model-2.082pod.t100644001750001750 55612676543661 14334 0ustar00domidomi000000000000Config-Model-2.082/tBEGIN { unless ( $ENV{AUTHOR_TESTING} ) { require Test::More; Test::More::plan( skip_all => 'these tests are for testing by the author' ); } } use strict; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; my @poddirs = qw( lib script ); all_pod_files_ok( all_pod_files(@poddirs) ); LICENSE100644001750001750 6013212676543661 14163 0ustar00domidomi000000000000Config-Model-2.082This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 The GNU Lesser General Public License (LGPL) Version 2.1, February 1999 (The master copy of this license lives on the GNU website.) Copyright (C) 1991, 1999 Free Software Foundation, Inc. 59 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Build.PL100644001750001750 755712676543661 14446 0ustar00domidomi000000000000Config-Model-2.082# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # 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)', 'build_requires' => { 'Config::Model::Tester' => '2.053', 'Module::Build' => '0.34', 'Term::ReadLine::Gnu' => '0', 'Term::ReadLine::Perl' => '0', 'Test::Differences' => '0', 'Test::Exception' => '0', 'Test::File::Contents' => '0', 'Test::Memory::Cycle' => '0', 'Test::More' => '0', 'Test::Warn' => '0.11', 'YAML' => '0' }, 'configure_requires' => { 'Module::Build' => '0.34' }, 'recommends' => { 'Fuse' => '0', 'Text::Levenshtein::Damerau' => '0', 'YAML' => '0' }, 'requires' => { 'Carp' => '0', 'Carp::Assert::More' => '0', 'Data::Dumper' => '0', 'English' => '0', 'Fcntl' => '0', 'File::Copy' => '0', 'File::HomeDir' => '0', 'File::Path' => '0', 'Hash::Merge' => '0.12', 'IO::File' => '0', 'JSON' => '0', 'List::MoreUtils' => '0', 'Log::Log4perl' => '1.11', 'Mouse' => '0', 'Mouse::Role' => '0', 'Mouse::Util' => '0', 'Mouse::Util::TypeConstraints' => '0', 'MouseX::NativeTraits' => '0', 'MouseX::StrictConstructor' => '0', 'POSIX' => '0', 'Parse::RecDescent' => 'v1.90.0', 'Path::Tiny' => '0', 'Pod::POM' => '0', 'Scalar::Util' => '0', 'Storable' => '0', 'Term::ReadLine' => '0', 'Text::Diff' => '0', 'Text::Levenshtein::Damerau' => '0', 'Text::Wrap' => '0', 'perl' => '5.010', 'warnings::register' => '0' }, # cleanup required by t/auto_read.t # PreGrammar.pm is created by t/value_computer.t add_to_cleanup => [ qw/PreGrammar.pm wr_root r_root/ ], ); $build->add_build_element('pl'); $build->add_build_element('appli'); $build->create_build_script; load.t100644001750001750 4610612676543661 14532 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Data::Dumper; use Log::Log4perl qw(:easy :levels); use warnings; no warnings qw(once); use strict; my $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; # See caveats in Test::More doc my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; ok( 1, "compiled" ); # test mega regexp, 'x' means undef my @regexp_test = ( # id_operation leaf_operation # string elt op (param) id op val note [ 'a', [ 'a', 'x', 'x', 'x', 'x', 'x', 'x' ] ], [ '#C', [ 'x', 'x', 'x', 'x', 'x', 'x', 'C' ] ], [ '#"m C"', [ 'x', 'x', 'x', 'x', 'x', 'x', '"m C"' ] ], [ 'a=b', [ 'a', 'x', 'x', 'x', '=', 'b', 'x' ] ], [ 'a-z=b', [ 'a-z', 'x', 'x', 'x', '=', 'b', 'x' ] ], [ "a=\x{263A}", [ 'a', 'x', 'x', 'x', '=', "\x{263A}", 'x' ] ], # utf8 smiley [ 'a.=b', [ 'a', 'x', 'x', 'x', '.=', 'b', 'x' ] ], [ "a.=\x{263A}", [ 'a', 'x', 'x', 'x', '.=', "\x{263A}", 'x' ] ], # utf8 smiley [ 'a="b=c"', [ 'a', 'x', 'x', 'x', '=', '"b=c"', 'x' ] ], [ 'a="b=\"c\""', [ 'a', 'x', 'x', 'x', '=', '"b=\"c\""', 'x' ] ], [ 'a=~/a/A/', [ 'a', 'x', 'x', 'x', '=~', '/a/A/', 'x' ] ], # subst on value [ 'a=b#B', [ 'a', 'x', 'x', 'x', '=', 'b', 'B' ] ], [ 'a#B', [ 'a', 'x', 'x', 'x', 'x', 'x', 'B' ] ], [ 'a#"b=c"', [ 'a', 'x', 'x', 'x', 'x', 'x', '"b=c"' ] ], # string elt op (param) id op val note [ 'a:b=c', [ 'a', ':', 'x', 'b', '=', 'c', 'x' ] ], # fetch and assign elt [ 'a:"b\""="\"c"', [ 'a', ':', 'x', '"b\""', '=', '"\"c"', 'x' ] ] , # fetch and assign elt qith quotes [ 'a:~', [ 'a', ':~', 'x', 'x', 'x', 'x', 'x' ] ], # loop on matched value [ 'a:~.=b', [ 'a', ':~', 'x', 'x', '.=', 'b', 'x' ] ], # loop on matched value [ 'a:~/b.*/', [ 'a', ':~', 'x', '/b.*/', 'x', 'x', 'x' ] ], # loop on matched value [ 'a:~"b.*"', [ 'a', ':~', 'x', '"b.*"', 'x', 'x', 'x' ] ], # loop on matched value [ 'a:~/b.*/.="\"a"', [ 'a', ':~', 'x', '/b.*/', '.=', '"\"a"', 'x' ] ], # loop on matched value and append [ 'a:~"b.*".="\"a"', [ 'a', ':~', 'x', '"b.*"', '.=', '"\"a"', 'x' ] ], # loop on matched value and append [ 'a:~/^\w+$/', [ 'a', ':~', 'x', '/^\w+$/', 'x', 'x', 'x' ] ], # loop on matched value [ 'a:="dod@foo.com"', [ 'a', ':=', 'x', '"dod@foo.com"', 'x', 'x', 'x' ] ], # set list [ 'a:=b,c,d', [ 'a', ':=', 'x', 'b,c,d', 'x', 'x', 'x' ] ], # set list [ 'a=b,c,d', [ 'a', 'x', 'x', 'x', '=', 'b,c,d', 'x' ] ], # set list old style [ 'm:=a,"a b "', [ 'm', ':=', 'x', 'a,"a b "', 'x', 'x', 'x' ] ], # set list with quotes [ 'm:="a b ",c', [ 'm', ':=', 'x', '"a b ",c', 'x', 'x', 'x' ] ], # set list with quotes [ 'm:="a b","c d"', [ 'm', ':=', 'x', '"a b","c d"', 'x', 'x', 'x' ] ], # set list with quotes [ 'm=a,"a b "', [ 'm', 'x', 'x', 'x', '=', 'a,"a b "', 'x' ] ] , # set list with quotes, old style [ 'a:b#C', [ 'a', ':', 'x', 'b', 'x', 'x', 'C' ] ], # fetch elt and add comment [ 'a:"b\""#"\"c"', [ 'a', ':', 'x', '"b\""', 'x', 'x', '"\"c"' ] ] , # fetch elt and add comment with quotes [ 'a:b=c#C', [ 'a', ':', 'x', 'b', '=', 'c', 'C' ] ], # fetch and assign elt and add comment [ 'a:-', [ 'a', ':-', 'x', 'x', 'x', 'x', 'x' ] ], # empty list [ 'a:-b', [ 'a', ':-', 'x', 'b', 'x', 'x', 'x' ] ], # remove id b [ 'a:-=b', [ 'a', ':-=', 'x', 'b', 'x', 'x', 'x' ] ], # remove value b from list or hash [ 'a:-~/b/', [ 'a', ':-~', 'x', '/b/', 'x', 'x', 'x' ] ], # remove value matching stuff [ 'a:=~s/b/c/g', [ 'a', ':=~', 'x', 's/b/c/g', 'x', 'x', 'x' ] ] , # subsitute value value matching stuff [ 'a:@', [ 'a', ':@', 'x', 'x', 'x', 'x', 'x' ] ], # sort list [ 'a:.b', [ 'a', ':.b', 'x', 'x', 'x', 'x', 'x' ] ], # function called on elt [ 'a:.b(foo)', [ 'a', ':.b', 'foo', 'x', 'x', 'x', 'x' ] ], # idem with param [ 'a:c', [ 'a', ':>', 'x', 'c', 'x', 'x', 'x' ] ], # unshift value [ 'a:b b)")', [ 'a', ':.b', '"foo(a > b)"', 'x', 'x', 'x', 'x' ] ], # tricky value with () ); foreach my $subtest (@regexp_test) { my ( $cmd, $ref ) = @$subtest; my $res = Config::Model::Loader::_split_cmd($cmd); #print Dumper $res,"\n"; foreach (@$res) { $_ = 'x' unless defined $_; } eq_or_diff( $res, $ref, "test _split_cmd with '$cmd'" ); } my $inst = $model->instance( root_class_name => 'Master', model_file => 't/dump_load_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; # check with embedded \n my $step = qq!#"root cooment " std_id:ab X=Bv -\na_string="titi and\nfoo" !; ok( $root->load( step => $step ), "load steps with embedded \\n" ); is( $root->fetch_element('a_string')->fetch, "titi and\nfoo", "check a_string" ); # check with embedded \n and \\n $step = q!a_string="titi and\nfoo and \\\\n literal" !; ok( $root->load( step => $step ), 'load steps with embedded \n and \\n' ); is( $root->fetch_element('a_string')->fetch, "titi and\nfoo and \\n literal", "check a_string" ); # check search up for element $step = qq!std_id:ab X=Bv /a_string="titi and\ntoto" !; ok( $root->load( step => $step ), "load steps with /a_string" ); is( $root->fetch_element('a_string')->fetch, "titi and\ntoto", "check a_string found with search" ); $step = qq!a_string:toto!; # should blow up throws_ok { $root->load( step => $step ) ; } qr/f/, "use ':' on a leaf"; # test apply regexp $step = qq!a_string=~s/TOTO/tata/i!; ok( $root->load( step => $step ), "load steps with apply regexp" ); is( $root->fetch_element('a_string')->fetch, qq!titi and\ntata!, "check a_string after regexp" ); # test apply regexp with embedded spaces $step = qq!a_string=~"s/titi and\n//""!; ok( $root->load( step => $step ), "load steps with apply regexp with embedded spaces" ); is( $root->fetch_element('a_string')->fetch, qq!tata!, "check a_string after regexp with embedded spaces" ); # check with embedded quotes $step = qq!std_id:ab X=Bv -\na_string="\"titi\" and \"toto\"" std_id:bc X=Av!; ok( $root->load( step => $step ), "load steps with embedded quotes" ); is( $root->fetch_element('a_string')->fetch, qq!"titi" and "toto"!, "check a_string with embedded quotes" ); # check with embedded utf8 $step = qq!#"root cooment \x{263A} " std_id:\x{263A} X=Bv -\na_string="titi and\ntoto and \x{263A}" !; ok( $root->load( step => $step ), "load steps with embedded \x{263A}" ); is( $root->fetch_element('a_string')->fetch, "titi and\ntoto and \x{263A}", "check a_string" ); is( $root->fetch_element('std_id')->fetch_with_id("\x{263A}")->fetch_element_value('X'), 'Bv', "check hash with utf8 index" ); # check with embedded literal \n that are switched with real \n # note: using q and not qq $step = q!std_id:"long\nkey" X=Bv - a_string="titi and\ntoto" !; ok( $root->load( step => $step ), 'load steps with embedded \n' ); # now double quote for real \n is( $root->fetch_element('a_string')->fetch, "titi and\ntoto", 'check a_string with embedded \n' ); is( $root->fetch_element('std_id')->fetch_with_id("long\nkey")->fetch_element_value('X'), 'Bv', 'check hash with index with embedded \n' ); $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="titi , toto" '; ok( $root->load( step => $step ), "load '$step'" ); is( $root->fetch_element('a_string')->fetch, 'titi , toto', "check a_string" ); # check that we can go to root node starting from below my $stdab = $root->grab("std_id:ab"); $stdab->load("! a_string=titi"); ok( 1, "go to root node starting from below" ); ok( $root->load( step => 'tree_macro=XZ' ), "Set tree_macro to XZ" ); # test load with warped_node below root (used to fail) $step = 'slave_y warp2 aa2="foo bar baz"'; ok( $root->load( step => $step ), "load '$step'" ); # this will warp out slave_y warp2 ok( $root->load( step => 'tree_macro=XY' ), "Set tree_macro to XY" ); # use indexes with white spaces $step = 'std_id:"a b" X=Bv - std_id:" b c " X=Av " '; ok( $root->load( step => $step ), "load '$step'" ); is_deeply( [ $root->fetch_element('std_id')->fetch_all_indexes ], [ ' b c ', 'a b', 'ab', 'bc', "long\nkey", "\x{263A}" ], "check indexes" ); $step = 'std_id:ab ZZX=Bv - std_id:bc X=Bv'; throws_ok { $root->load( step => $step ); } "Config::Model::Exception::UnknownElement", "load wrong '$step'"; $step = 'lista:=a,b,c,d lista:4=e olist:0 X=Av - olist:1 X=Bv - listb:=b,c,d,,f,"",h,0'; throws_ok { $root->load( step => $step ); } qr/comma/, "load wrong '$step'"; $step = 'listb:=b,c,d,f,"",h,0 listc:="dod@foo.com"'; ok( $root->load( step => $step ), "load '$step'" ); # perform some checks my $olist = $root->fetch_element('olist'); is( $olist->fetch_with_id(0)->element_name, 'olist', 'check list element_name' ); map { is( $olist->fetch_with_id($_)->config_class_name, 'SlaveZ', "check list element $_ class" ); } ( 0, 1 ); my $lista = $root->fetch_element('lista'); isa_ok( $lista, 'Config::Model::ListId', 'check lista class' ); map { isa_ok( $lista->fetch_with_id($_), 'Config::Model::Value', "check lista element $_ class" ); } ( 0, 1 ); is( $olist->fetch_with_id(0)->fetch_element('X')->fetch, 'Av', "check list element 0 content" ); is( $olist->fetch_with_id(1)->fetch_element('X')->fetch, 'Bv', "check list element 1 content" ); my @expect = qw/a b c d e/; map { is( $lista->fetch_with_id($_)->fetch, $expect[$_], "check lista element $_ content" ); } ( 0 .. $#expect ); my $listb = $root->fetch_element('listb'); @expect = ( qw/b c d/, 'f', '', 'h', '0' ); map { is( $listb->fetch_with_id($_)->fetch, $expect[$_], "check listb element $_ content" ); } ( 0 .. $#expect ); $step = 'a_string="foo bar"'; ok( $root->load( step => $step, ), "load quoted string: '$step'" ); is( $root->fetch_element('a_string')->fetch, "foo bar", 'check result' ); $step = 'a_string="foo bar baz" lista:=a,b,c,d,e'; ok( $root->load( step => $step, ), "load : '$step'" ); is( $root->fetch_element('a_string')->fetch, "foo bar baz", 'check result' ); @expect = qw/a b c d e/; map { is( $lista->fetch_with_id($_)->fetch, $expect[$_], "check lista element $_ content" ); } ( 0 .. 4 ); # set the value of the previous object $step = 'std_id:"f/o/o:b.ar" X=Bv'; ok( $root->load( step => $step, ), "load : '$step'" ); eq_or_diff( [ sort $root->fetch_element('std_id')->fetch_all_indexes ], [ ' b c ', 'a b', qw!ab bc f/o/o:b.ar!, "long\nkey", "\x{263A}" ], "check result after load '$step'" ); $step = 'hash_a:a=z hash_a:b=z2 hash_a:"a b "="z 1"'; ok( $root->load( step => $step, ), "load : '$step'" ); is_deeply( [ sort $root->fetch_element('hash_a')->fetch_all_indexes ], [ 'a', 'a b ', 'b' ], "check result after load '$step'" ); is( $root->fetch_element('hash_a')->fetch_with_id('a')->fetch, 'z', 'check result' ); my $elt = $root->fetch_element('hash_a')->fetch_with_id('a b '); is( $elt->fetch, 'z 1', 'check result with white spaces' ); is( $elt->location, 'hash_a:"a b "', 'check location' ); $step = 'my_check_list=a,"a b "'; ok( $root->load( step => $step, ), "load : '$step'" ); $step = 'a_string="a \"b\" "'; ok( $root->load( step => $step, ), "load : '$step'" ); is( $root->fetch_element('a_string')->fetch, 'a "b" ', "test value loaded by '$step'" ); $step = 'lista:=a,"a \"b\" "'; ok( $root->load( step => $step, ), "load : '$step'" ); is( $lista->fetch_with_id(1)->fetch, 'a "b" ', "test value loaded by '$step'" ); # test that lista~a complains about non numeric index $step = 'lista~a'; throws_ok { $root->load( step => $step ); } "Config::Model::Exception::User", "load wrong '$step'"; # use new and old notation $step = 'lista:-1 hash_a~"a b "'; ok( $root->load( step => $step, ), "load : '$step'" ); is( $lista->fetch_with_id(1)->fetch, undef, "test list value loaded by '$step'" ); $elt = $root->fetch_element('hash_a')->fetch_with_id('a b '); is( $elt->fetch, undef, "test hash value loaded by '$step'" ); # test append mode $root->load('a_string.=c'); is( $root->fetch_element_value('a_string'), 'a "b" c', "test append on list" ); # test append mode with utf8 $root->load("a_string.=\x{263A}"); is( $root->fetch_element_value('a_string'), 'a "b" c' . "\x{263A}", "test append on list with utf8" ); $root->load('lista:0.=" b c"'); is( $lista->fetch_with_id(0)->fetch,, 'a b c', "test append on leaf" ); $root->load('hash_a:b.=" z3"'); is( $root->fetch_element('hash_a')->fetch_with_id('b')->fetch,, 'z2 z3', "test append on hash" ); # test loop mode $root->load('std_id:~ DX=Av - int_v=9'); is( $root->grab_value('std_id:ab DX'), 'Av', "check looped assign 1" ); is( $root->grab_value('std_id:bc DX'), 'Av', "check looped assign 2" ); is( $root->grab_value('std_id:"a b" DX'), 'Av', "check looped assign 3" ); $root->load('std_id:~/^\w+$/ DX=Bv - int_v=9'); is( $root->grab_value('std_id:ab DX'), 'Bv', "check looped assign 1" ); is( $root->grab_value('std_id:bc DX'), 'Bv', "check looped assign 2" ); is( $root->grab_value('std_id:"a b" DX'), 'Av', "check out of loop left alone" ); # test annotation setting my @anno_test = ( 'std_id', 'std_id:ab', 'lista', 'lista:0', ); foreach my $path (@anno_test) { $root->load(qq!$path#"$path annotation"!); is( $root->grab($path)->annotation, "$path annotation", "fetch $path annotation" ); } # test remove by value and remove by matched value $root->load('lista:=a,b,c,d,foo lista:-=b lista:-~/oo/'); eq_or_diff( [ $lista->fetch_all_values ], [qw/a c d/], "removed value from list" ); # test remove by value and remove by matched value $root->load('lista:=Foo1,foo2,bar lista:=~s/foo/doh/i'); eq_or_diff( [ $lista->fetch_all_values ], [qw/doh1 doh2 bar/], "test :=~ on list" ); $root->load('hash_a:a=Foo3 hash_a:b=foo4 hash_a:c=bar hash_a:=~s/foo/doh/i'); eq_or_diff( [ sort $root->fetch_element('hash_a')->fetch_all_values ], [qw/bar doh3 doh4/], "test :=~ on hash" ); $root->load('lista:=j,h,g,f lista:@'); eq_or_diff( [ $lista->fetch_all_values ], [qw/f g h j/], "test :@ on list" ); $root->load('lista:=j,h,g,f lista:.sort'); eq_or_diff( [ $lista->fetch_all_values ], [qw/f g h j/], "test :.sort on list" ); $root->load('lista:=a,b lista:.push(c) lista:fetch_all_values ], [qw/a b c d/], "test push on list" ); $root->load('lista:=a,b lista:.unshift(1) lista:>2'); eq_or_diff( [ $lista->fetch_all_values ], [qw/2 1 a b/], "test unshift on list" ); # test insert_before $root->load('lista=foo,baz lista:.insert_before(baz,bar1,bar2)'); eq_or_diff( [ $lista->fetch_all_values ], [qw/foo bar1 bar2 baz/], "check insert_before result" ); $root->load('lista:.insert_before(/z/,bar3,bar4)'); eq_or_diff( [ $lista->fetch_all_values ], [qw/foo bar1 bar2 bar3 bar4 baz/], "check insert_before with regexp /z/" ); $root->load('lista:.insert_before(/1/,"bar0a bar0b, bar0c")'); eq_or_diff( [ $lista->fetch_all_values ], [ foo => "bar0a bar0b, bar0c", qw/bar1 bar2 bar3 bar4 baz/ ], "check insert_before with regexp /1/" ); # test insort my @set1 = qw/c1 e i1 j1 p1/; my @set2 = qw/a2 z2 d2 e b2 k2/; $root->load( 'lista=' . join( ',', @set1 ) . ' lista:.sort lista:.insort(' . join( ',', @set2 ) . ')' ); eq_or_diff( [ $lista->fetch_all_values ], [ sort( @set1, @set2 ) ], "check insort result" ); # test insort with a tricky value my $tricky = q!libmodule-build-perl (>= 0.421100-2)!; $root->load( qq!lista:.insort("$tricky")! ); eq_or_diff( [ $lista->fetch_all_values ], [ sort( @set1, @set2, $tricky ) ], "check insort result" ); # test sort on ordered hash my $oh = $root->fetch_element('ordered_hash'); $root->load('ordered_hash:b=bv ordered_hash:a=av'); eq_or_diff( [$oh->fetch_all_indexes()],[qw/b a/], "check unsorted keys") ; $root->load('ordered_hash:.sort') ; eq_or_diff( [$oh->fetch_all_indexes()],[qw/a b/], "check sorted keys") ; # test combination of annotation plus load and some utf8 $step = 'std_id#std_id_note ! std_id:ab#std_id_ab_note X=Bv X#X_note - std_id:bc X=Av X#X2_note ' . '- a_string="toto \"titi\" tata" a_string#string_note ' . 'lista:=a,b,c,d olist:0 - olist:0#olist0_note X=Av - olist:1 X=Bv - listb:=b,"c c2",d ' . '! hash_a:X2=x#x_note hash_a:Y2=xy hash_b:X3=xy my_check_list=X2,X3 ' . 'plain_object#"plain comment" aa2="aa2_value ' . "\x{263A}\""; my $inst2 = $model->instance( root_class_name => 'Master', instance_name => 'test2' ); my $root2 = $inst2->config_root; ok( $root2->load( step => $step ), "set up data in tree with combination of load and annotations" ); my @to_check = ( [ 'std_id', 'std_id_note' ], [ 'std_id:ab', 'std_id_ab_note' ], [ 'std_id:ab X', 'X_note' ], [ 'std_id:bc X', 'X2_note' ], [ 'a_string', 'string_note' ], [ 'olist:0', 'olist0_note' ], [ 'hash_a:X2', 'x_note' ], [ 'plain_object', 'plain comment' ], ); foreach (@to_check) { is( $root2->grab( $_->[0] )->annotation, $_->[1], "Check annotation for '$_->[0]'" ); } # check utf8 value is( $root2->grab_value('plain_object aa2'), "aa2_value \x{263A}", "utf8 value" ); # test deletion of leaf items $step = 'a_string=foobar a_string~'; ok( $root2->load( step => $step ), "set up data then delete it" ); is( $root2->grab_value('a_string'), undef, "check that another_string was undef'ed" ); $root2->load("lista:0.=\x{263A}"); is( $root2->grab_value('lista:0'), "a\x{263A}", "check that list append work" ); # test element with embedded dash $root->load("std_id:ab X-Y-Z=Av"); is( $root->grab_value('std_id:ab X-Y-Z'), "Av", "check load grab of X-Y-Z" ); # test deep copy $root->load("std_id:.copy(ab,copy)"); is( $root->grab_value('std_id:copy X-Y-Z'), "Av", "check hash copy" ); # test some errors cases my %errors = ( 'std_id', qr/Missing assignment/, 'olist', qr/Wrong assignment/, ); foreach my $bad ( sort keys %errors ) { throws_ok { $root->load($bad) } $errors{$bad}, "Check error for load('$bad')"; } memory_cycle_ok( $model, "check memory cycles" ); done_testing; grab.t100644001750001750 677512676543661 14516 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 42; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy); use warnings; no warnings qw(once); use strict; use Data::Dumper; my $arg = shift || ''; my ( $log, $show ) = (0) x 3; my $do; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } my $model = Config::Model->new( legacy => 'ignore', ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; Config::Model::Exception::Any->Trace(1) if $trace =~ /e/; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - std_id:"b c" X=Av - a_string="titi , toto" '; ok( $root->load( step => $step ), "load '$step'" ); my $grabbed = $root->grab('olist:0'); is( $grabbed->location, 'olist:0', 'test grab olist:0 (obj)' ); is( $root->grab('olist:0')->index_value, 0, 'test grab olist:0 (index)' ); my $wp = 'olist:0'; eval { $root->grab( \$wp )->index_value; }; ok( $@, "Test grab with wrong parameter" ); print "normal error:\n", $@, "\n" if $trace; eval { $root->grab('std_xid:toto')->index_value; }; ok( $@, "Test grab with wrong element" ); print "normal error:\n", $@, "\n" if $trace; like( $root->grab('olist')->name, qr/olist/, 'test grab olist' ); is( $root->location(), '', 'location test' ); foreach my $wstep ( 'std_id:ab', 'olist:0', 'olist:1', 'warp', 'warp std_id:toto', 'warp std_id:"b c"' ) { my $obj = $root->grab($wstep); ok( $obj, "grab $wstep..." ); is( $obj->location, $wstep, "... and test its location" ); } print $root->dump_tree() if $trace =~ /t/; my $leaf = $root->grab('warp std_id:toto DX'); my @tests = ( [ '?warp', 'warp', 'WarpedNode' ], [ '?std_id:ab', 'warp std_id:ab', 'Node' ], [ '?hash_a:ab', 'hash_a:ab', 'Value' ], [ '?std_id', 'warp std_id', 'HashId' ], [ '!Master', '', 'Node' ], [ '!SlaveY', 'warp', 'Node' ], [ '!SlaveZ', 'warp std_id:toto', 'Node' ], ); foreach my $unit_test (@tests) { my $obj = $leaf->grab( $unit_test->[0] ); is( $obj->location, $unit_test->[1], "test grab with '$unit_test->[0]'" ); isa_ok( $obj, 'Config::Model::' . $unit_test->[2] ); } eval { $leaf->grab('?argh'); }; ok( $@, "test grab with wrong step: '?argh'" ); print "normal error:\n", $@, "\n" if $trace; eval { $root->grab( step => 'std_id:zzz', autoadd => 0 ); }; ok( $@, "test autoadd 0 with 'std_id:zzz'" ); print "normal error:\n", $@, "\n" if $trace; $root->grab( step => 'std_id:zzz', autoadd => 1 ); ok( 1, "test autoadd 1 with 'std_id:zzz'" ); my $obj = $root->grab( step => 'std_id:zzz foobar', mode => 'adaptative' ); is( $obj->location, "std_id:zzz", "test no strict grab" ); $obj = $root->grab( step => 'std_id:ab X', type => 'node', mode => 'adaptative' ); is( $obj->location, "std_id:ab", "test no strict grab with type node" ); eval { $root->grab( step => 'std_id:ab X', type => 'node', mode => 'strict' ); }; ok( $@, "test strict grab with type node" ); print "normal error:\n", $@, "\n" if $trace; memory_cycle_ok($model); node.t100644001750001750 1270112676543661 14532 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More ; use Test::Exception; use Test::Warn; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $model = Config::Model->new(); $model->create_config_class( name => 'Sarge', status => [ D => 'deprecated' ], #could be obsolete, standard description => [ X => 'X-ray (long description)' ], summary => [ X => 'X-ray (summary)' ], class => 'Config::Model::Node', element => [ [qw/D X Y Z/] => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', choice => [qw/Av Bv Cv/] } ], ); $model->create_config_class( name => 'Captain', element => [ bar => { type => 'node', config_class_name => 'Sarge' } ] ); $model->create_config_class( name => "Master", level => [ qw/captain/ => 'important' ], element => [ captain => { type => 'node', config_class_name => 'Captain', }, [qw/array_args hash_args/] => { type => 'node', config_class_name => 'Captain', }, ], class_description => "Master description", description => [ captain => "officer", array_args => 'not officer' ] ); ok( 1, "Model created" ); my $instance = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( 1, "Instance created" ); my $root = $instance->config_root; ok( $root, "Config root created" ); is( $root->config_class_name, 'Master', "Created Master" ); is_deeply( [ sort $root->get_element_name( ) ], [qw/array_args captain hash_args/], "check Master elements" ); is_deeply( [ sort $root->get_element_name( ) ], [qw/array_args captain hash_args/], "check Master elements" ); is_deeply( [ sort $root->get_element_name( ) ], [qw/array_args captain hash_args/], "check Master elements" ); my $w = $root->fetch_element('captain'); ok( $w, "Created Captain" ); is( $w->config_class_name, 'Captain', "test class_name" ); is( $w->element_name, 'captain', "test element_name" ); is( $w->name, 'captain', "test name" ); is( $w->location, 'captain', "test captain location" ); my $b = $w->fetch_element('bar'); ok( $b, "Created Sarge" ); is( $b->fetch_element_value('Z'), undef, "test Z value" ); warning_like { $b->fetch_element('D'); } qr/Element 'D' of node 'captain bar' is deprecated/, 'Check deprecated element warning'; my $tested = $root->fetch_element('hash_args')->fetch_element('bar'); is( $tested->config_class_name, 'Sarge', "test bar config_class_name" ); is( $tested->element_name, 'bar', "test bar element_name" ); is( $tested->name, 'hash_args bar', "test bar name" ); is( $tested->location, 'hash_args bar', "test bar location" ); my $inst2 = $model->instance( root_class_name => 'Master', instance_name => 'test2' ); isa_ok( $inst2, 'Config::Model::Instance', "Created 2nd Master" ); isa_ok( $inst2->config_root, 'Config::Model::Node', "created 2nd tree" ); # test help included with the model is( $root->get_help, "Master description", "Test master global help" ); is( $root->get_help('captain'), "officer", "Test master slot help captain" ); is( $root->get_help('hash_args'), '', "Test master slot help hash_args" ); is( $tested->get_help('X'), "X-ray (long description)", "Test sarge slot help X" ); is( $tested->get_help( description => 'X' ), "X-ray (long description)", "Test sarge slot help X (description)" ); is( $tested->get_help( summary => 'X' ), "X-ray (summary)", "Test sarge slot help X (summary)" ); is( $root->has_element('daughter'), 0, "Non-existing element" ); is( $root->has_element('captain'), 1, "existing element" ); is( $root->has_element( name => 'captain', type => 'node' ), 1, "existing node element" ); is( $root->has_element( name => 'captain', type => 'leaf' ), 0, "non existing leaf element" ); ok( $root->is_element_available( name => 'captain' ), "test element" ); is( $root->get_element_property( property => 'level', element => 'hash_args' ), 'normal', "test (non) importance" ); is( $root->get_element_property( property => 'level', element => 'captain' ), 'important', "test importance" ); is( $root->set_element_property( property => 'level', element => 'captain', value => 'hidden' ), 'hidden', "test importance" ); is( $root->get_element_property( property => 'level', element => 'captain' ), 'hidden', "test hidden" ); is( $root->reset_element_property( property => 'level', element => 'captain' ), 'important', "test importance" ); map { my $key_label = defined $_->[0] ? $_->[0] : 'undef'; is( $root->next_element( name => $_->[0] ), $_->[1], "test next_element ($key_label)" ); is( $root->previous_element( name => $_->[1] ), $_->[0], "test previous_element ($key_label)" ) unless ( defined $_->[0] and $_->[0] eq '' ); } ( [ undef, 'captain' ], [ '', 'captain' ], [qw/captain array_args/], [qw/array_args hash_args/] ); memory_cycle_ok($model); done_testing ; META.yml100644001750001750 305012676543661 14403 0ustar00domidomi000000000000Config-Model-2.082--- abstract: 'Create tools to validate, migrate and edit configuration files' author: - 'Dominique Dumont' build_requires: Config::Model::Tester: '2.053' Module::Build: '0.34' Term::ReadLine::Gnu: '0' Term::ReadLine::Perl: '0' Test::Differences: '0' Test::Exception: '0' Test::File::Contents: '0' Test::Memory::Cycle: '0' Test::More: '0' Test::Warn: '0.11' YAML: '0' configure_requires: Module::Build: '0.34' dynamic_config: 0 generated_by: 'Dist::Zilla version 5.043, CPAN::Meta::Converter version 2.150005' license: lgpl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Config-Model recommends: Fuse: '0' Text::Levenshtein::Damerau: '0' YAML: '0' requires: Carp: '0' Carp::Assert::More: '0' Data::Dumper: '0' English: '0' Fcntl: '0' File::Copy: '0' File::HomeDir: '0' File::Path: '0' Hash::Merge: '0.12' IO::File: '0' JSON: '0' List::MoreUtils: '0' Log::Log4perl: '1.11' Mouse: '0' Mouse::Role: '0' Mouse::Util: '0' Mouse::Util::TypeConstraints: '0' MouseX::NativeTraits: '0' MouseX::StrictConstructor: '0' POSIX: '0' Parse::RecDescent: v1.90.0 Path::Tiny: '0' Pod::POM: '0' Scalar::Util: '0' Storable: '0' Term::ReadLine: '0' Text::Diff: '0' Text::Levenshtein::Damerau: '0' Text::Wrap: '0' perl: '5.010' warnings::register: '0' resources: bugtracker: https://github.com/dod38fr/config-model/issues homepage: https://github.com/dod38fr/config-model/wiki repository: git://github.com/dod38fr/config-model.git version: '2.082' MANIFEST100644001750001750 1214612676543661 14311 0ustar00domidomi000000000000Config-Model-2.082# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.043. Build.PL Changes LICENSE MANIFEST MANIFEST.SKIP META.json META.yml MODELS README.install.pod README.pod TODO contrib/bash_completion.cme_multistrap contrib/log4config-model examples/fstab/README examples/fstab/add-ext4-workshop.txt examples/fstab/fstab.sample examples/fstab/fstab_test.pl examples/fstab/lib/Config/Model/models/MyFstab.pl examples/fstab/lib/Config/Model/models/MyFstab/CommonOptions.pl examples/fstab/lib/Config/Model/models/MyFstab/Ext2FsOpt.pl examples/fstab/lib/Config/Model/models/MyFstab/Ext3FsOpt.pl examples/fstab/lib/Config/Model/models/MyFstab/FsLine.pl examples/fstab/lib/Config/Model/models/MyFstab/Iso9660_Opt.pl examples/fstab/lib/Config/Model/models/MyFstab/SwapOptions.pl examples/fstab/lib/Config/Model/models/MyFstab/UsbFsOptions.pl lib/Config/Model.pm lib/Config/Model/Annotation.pm lib/Config/Model/AnyId.pm lib/Config/Model/AnyThing.pm lib/Config/Model/Backend/Any.pm lib/Config/Model/Backend/Fstab.pm lib/Config/Model/Backend/IniFile.pm lib/Config/Model/Backend/Json.pm lib/Config/Model/Backend/PlainFile.pm lib/Config/Model/Backend/ShellVar.pm lib/Config/Model/Backend/Yaml.pm lib/Config/Model/BackendMgr.pm lib/Config/Model/CheckList.pm lib/Config/Model/Cookbook/CreateModelFromDoc.pod lib/Config/Model/Describe.pm lib/Config/Model/DumpAsData.pm lib/Config/Model/Dumper.pm lib/Config/Model/Exception.pm lib/Config/Model/FuseUI.pm lib/Config/Model/HashId.pm lib/Config/Model/IdElementReference.pm lib/Config/Model/Instance.pm lib/Config/Model/Iterator.pm lib/Config/Model/ListId.pm lib/Config/Model/Lister.pm lib/Config/Model/Loader.pm lib/Config/Model/Manual/ModelCreationAdvanced.pod lib/Config/Model/Manual/ModelCreationIntroduction.pod lib/Config/Model/Node.pm lib/Config/Model/ObjTreeScanner.pm lib/Config/Model/Report.pm lib/Config/Model/Role/NodeLoader.pm lib/Config/Model/Role/WarpMaster.pm lib/Config/Model/SearchElement.pm lib/Config/Model/SimpleUI.pm lib/Config/Model/TermUI.pm lib/Config/Model/TreeSearcher.pm lib/Config/Model/Utils/GenClassPod.pm lib/Config/Model/Value.pm lib/Config/Model/Value/LayeredInclude.pm lib/Config/Model/ValueComputer.pm lib/Config/Model/WarpedNode.pm lib/Config/Model/Warper.pm lib/Config/Model/application.d/multistrap lib/Config/Model/models/Fstab.pl lib/Config/Model/models/Fstab.pod lib/Config/Model/models/Fstab/CommonOptions.pl lib/Config/Model/models/Fstab/Ext2FsOpt.pl lib/Config/Model/models/Fstab/Ext3FsOpt.pl lib/Config/Model/models/Fstab/Ext4FsOpt.pl lib/Config/Model/models/Fstab/FsLine.pl lib/Config/Model/models/Fstab/FsLine.pod lib/Config/Model/models/Fstab/Iso9660_Opt.pl lib/Config/Model/models/Fstab/NoneOptions.pl lib/Config/Model/models/Fstab/SwapOptions.pl lib/Config/Model/models/Fstab/UsbFsOptions.pl lib/Config/Model/models/Multistrap.pl lib/Config/Model/models/Multistrap.pod lib/Config/Model/models/Multistrap/Section.pl lib/Config/Model/models/Multistrap/Section.pod lib/Config/Model/models/PopCon.pl lib/Config/Model/models/PopCon.pod lib/Config/Model/system.d/fstab lib/Config/Model/system.d/popcon t/accept.t t/annotation.t t/apply_fix.t t/array_id.t t/array_with_data_migration.t t/augment_class.t t/auto_load_model.t t/backend_ini.t t/backend_ini_with_section_map.t t/backend_mgr.t t/backend_multiple.t t/backend_plainfile.t t/big_model.pm t/check_list.t t/check_list_warp.t t/describe_node.t t/dump_as_data.t t/dump_load_model.pm t/dump_tree.t t/fuse_ui.t t/gen-class-doc.t t/grab.t t/hash_id_of_node.t t/hash_id_of_values.t t/hash_with_data_migration.t t/include.t t/instance.t t/iterator.t t/lib/DummyNode.pm t/load.t t/load_model_snippets.t t/model.t t/model_tests.d/backend-json-examples/basic t/model_tests.d/backend-json-test-conf.pl t/model_tests.d/backend-shellvar-examples/debian-719256 t/model_tests.d/backend-shellvar-test-conf.pl t/model_tests.d/fstab-examples/t0 t/model_tests.d/fstab-examples/t1 t/model_tests.d/fstab-test-conf.pl t/model_tests.d/layer-examples/mini/etc/foo-config.pl t/model_tests.d/layer-examples/mini/home/joe/foo/config.pl t/model_tests.d/layer-test-conf.pl t/model_tests.d/multistrap-examples/arm/home/foo/my_arm.conf t/model_tests.d/multistrap-examples/arm/usr/share/multistrap/crosschroot.conf t/model_tests.d/multistrap-examples/from_scratch/usr/share/multistrap/crosschroot.conf t/model_tests.d/multistrap-examples/igep0020/home/foo/strap-igep0020.conf t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/arm.conf t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/crosschroot.conf t/model_tests.d/multistrap-examples/igep0020/usr/share/multistrap/squeeze.conf t/model_tests.d/multistrap-test-conf.pl t/model_tests.d/popcon-examples/t0 t/model_tests.d/popcon-test-conf.pl t/model_tests.t t/multi_warp_object.t t/multi_warp_value.t t/node-load.t t/node.t t/node_get_set.t t/obj_tree_scanner.t t/pod.t t/pod_generation.t t/recursive_warp_value.t t/report.t t/search_element.t t/search_in_tree.t t/simple_ui.t t/smooth_upgrade.t t/term_ui.t t/test_ini_backend_model.pl t/test_yaml_model.pl t/value.t t/value_compute.t t/value_refer_to.t t/value_simple_warp.t t/warped_id.t t/warped_node.t t/warped_node_collateral.t t/warped_value.t t/yaml_backend.t weaver.ini META.json100644001750001750 541412676543661 14561 0ustar00domidomi000000000000Config-Model-2.082{ "abstract" : "Create tools to validate, migrate and edit configuration files", "author" : [ "Dominique Dumont" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.043, CPAN::Meta::Converter version 2.150005", "license" : [ "lgpl_2_1" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Config-Model", "prereqs" : { "build" : { "requires" : { "Module::Build" : "0.34", "YAML" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.34" } }, "runtime" : { "recommends" : { "Fuse" : "0", "Text::Levenshtein::Damerau" : "0", "YAML" : "0" }, "requires" : { "Carp" : "0", "Carp::Assert::More" : "0", "Data::Dumper" : "0", "English" : "0", "Fcntl" : "0", "File::Copy" : "0", "File::HomeDir" : "0", "File::Path" : "0", "Hash::Merge" : "0.12", "IO::File" : "0", "JSON" : "0", "List::MoreUtils" : "0", "Log::Log4perl" : "1.11", "Mouse" : "0", "Mouse::Role" : "0", "Mouse::Util" : "0", "Mouse::Util::TypeConstraints" : "0", "MouseX::NativeTraits" : "0", "MouseX::StrictConstructor" : "0", "POSIX" : "0", "Parse::RecDescent" : "v1.90.0", "Path::Tiny" : "0", "Pod::POM" : "0", "Scalar::Util" : "0", "Storable" : "0", "Term::ReadLine" : "0", "Text::Diff" : "0", "Text::Levenshtein::Damerau" : "0", "Text::Wrap" : "0", "perl" : "5.010", "warnings::register" : "0" } }, "test" : { "requires" : { "Config::Model::Tester" : "2.053", "Term::ReadLine::Gnu" : "0", "Term::ReadLine::Perl" : "0", "Test::Differences" : "0", "Test::Exception" : "0", "Test::File::Contents" : "0", "Test::Memory::Cycle" : "0", "Test::More" : "0", "Test::Warn" : "0.11" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "ddumont at cpan.org", "web" : "https://github.com/dod38fr/config-model/issues" }, "homepage" : "https://github.com/dod38fr/config-model/wiki", "repository" : { "type" : "git", "url" : "git://github.com/dod38fr/config-model.git", "web" : "http://github.com/dod38fr/config-model" } }, "version" : "2.082" } value.t100644001750001750 6446312676543661 14735 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use 5.010; use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Warn; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::Value; use Log::Log4perl qw(:easy :levels); use strict; binmode STDOUT, ':utf8'; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new(); $model->create_config_class( name => "BadClass", element => [ crooked => { type => 'leaf', class => 'Config::Model::Value', }, crooked_enum => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', default => 'foo', choice => [qw/A B C/] }, ] ); $model->create_config_class( name => "Master", element => [ scalar => { type => 'leaf', class => 'Config::Model::Value', value_type => 'integer', min => 1, max => 4, }, string => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', }, bounded_number => { type => 'leaf', class => 'Config::Model::Value', value_type => 'number', min => 1, max => 4, }, mandatory_string => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', mandatory => 1, }, mandatory_boolean => { type => 'leaf', class => 'Config::Model::Value', value_type => 'boolean', mandatory => 1, }, mandatory_with_default_value => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', mandatory => 1, default => 'booya', }, boolean_with_write_as => { type => 'leaf', value_type => 'boolean', write_as => [qw/false true/], }, boolean_with_write_as_and_default => { type => 'leaf', value_type => 'boolean', write_as => [qw/false true/], default => 'true', }, bare_enum => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', choice => [qw/A B C/] }, enum => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', default => 'A', choice => [qw/A B C/] }, enum_with_help => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', choice => [qw/a b c/], help => { a => 'a help' } }, uc_convert => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', convert => 'uc', }, lc_convert => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', convert => 'lc', }, upstream_default => { type => 'leaf', value_type => 'string', upstream_default => 'up_def', }, a_uniline => { type => 'leaf', value_type => 'uniline', upstream_default => 'a_uniline_def', }, with_replace => { type => 'leaf', value_type => 'enum', choice => [qw/a b c/], replace => { a1 => 'a', c1 => 'c', 'foo/.*' => 'b', }, }, replacement_hash => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'uniline', }, }, with_replace_follow => { type => 'leaf', value_type => 'string', replace_follow => '- replacement_hash', }, match => { type => 'leaf', value_type => 'string', match => '^foo\d{2}/$', }, prd_test_action => { type => 'leaf', value_type => 'string', }, prd_match => { type => 'leaf', value_type => 'string', grammar => q^check: check: token (oper token)(s?) oper: 'and' | 'or' token: 'Apache' | 'CC-BY' | 'Perl' { my $v = $arg[0]->grab("! prd_test_action")->fetch || ''; $failed++ unless $v =~ /$item[1]/ ; } ^, }, warn_if_match => { type => 'leaf', value_type => 'string', warn_if_match => { 'foo' => { fix => '$_ = uc;' } }, }, warn_unless_match => { type => 'leaf', value_type => 'string', warn_unless_match => { foo => { msg => '', fix => '$_ = "foo".$_;' } }, }, assert => { type => 'leaf', value_type => 'string', assert => { assert_test => { code => 'defined $_ and /\w/', msg => 'must not be empty', fix => '$_ = "foobar";' } }, }, warn_if_number => { type => 'leaf', value_type => 'string', warn_if => { warn_test => { code => 'defined $_ && /\d/;', msg => 'should not have numbers', fix => 's/\d//g;' } }, }, warn_unless => { type => 'leaf', value_type => 'string', warn_unless => { warn_test => { code => 'defined $_ and /\w/', msg => 'should not be empty', fix => '$_ = "foobar";' } }, }, always_warn => { type => 'leaf', value_type => 'string', warn => 'Always warn whenever used', }, 'Standards-Version' => { 'value_type' => 'uniline', 'warn_unless_match' => { '3\\.9\\.2' => { 'msg' => 'Current standard version is 3.9.2', 'fix' => '$_ = undef; #restore default' } }, 'match' => '\\d+\\.\\d+\\.\\d+(\\.\\d+)?', 'default' => '3.9.2', 'type' => 'leaf', }, t_file => { type => 'leaf', value_type => 'file' }, t_dir => { type => 'leaf', value_type => 'dir' } ], # dummy class ); my $bad_inst = $model->instance( root_class_name => 'BadClass', instance_name => 'test_bad_class' ); ok( $bad_inst, "created bad_class instance" ); $bad_inst->initial_load_stop; my $bad_root = $bad_inst->config_root; my $result; throws_ok { $bad_root->fetch_element('crooked'); } 'Config::Model::Exception::Model', "test create expected failure"; print "normal error:\n", $@, "\n" if $trace; my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); $inst->initial_load_stop; sub check_store_error { my ( $obj, $v, $qr ) = @_; my $path = $obj->location; $obj->store( value => $v, silent => 1, check => 'skip' ); is( $inst->errors->{$path}, '', "store error in $path is tracked" ); like( scalar $inst->error_messages, $qr, "check $path error message" ); } sub check_error { my ( $obj, $v, $qr ) = @_; my $old_v = $obj->fetch; check_store_error(@_); is( $obj->fetch, $old_v, "check that wrong value $v was not stored" ); } my $root = $inst->config_root; my $i = $root->fetch_element('scalar'); ok( $i, "test create bounded integer" ); is( $inst->needs_save, 0, "verify instance needs_save status after creation" ); is( $i->needs_check, 1, "verify check status after creation" ); $i->store(1); ok( 1, "store test done" ); is( $i->needs_check, 0, "store does not trigger a check (check done during store)" ); is( $inst->needs_save, 1, "verify instance needs_save status after store" ); is( $i->fetch, 1, "fetch test" ); is( $i->needs_check, 0, "check was done during fetch" ); is( $inst->needs_save, 1, "verify instance needs_save status after fetch" ); check_error( $i, 5, qr/max limit/ ); check_error( $i, 'toto', qr/not of type/ ); check_error( $i, 1.5, qr/number but not an integer/ ); # test that bad storage triggers an error throws_ok { $i->store(5); } 'Config::Model::Exception::WrongValue', "test max nb expected failure"; print "normal error:\n", $@, "\n" if $trace; my $nb = $root->fetch_element('bounded_number'); ok( $nb, "created " . $nb->name ); $nb->store( value => 1, callback => sub { is( $nb->fetch, 1, "assign 1" ); } ); $nb->store( value => 1.5, callback => sub { is( $nb->fetch, 1.5, "assign 1.5" ); } ); $nb->store(undef); ok( defined $nb->fetch() ? 0 : 1, "store undef" ); my $ms = $root->fetch_element('mandatory_string'); ok( $ms, "created mandatory_string" ); throws_ok { my $v = $ms->fetch; } 'Config::Model::Exception::User', "mandatory string: undef error"; print "normal error:\n", $@, "\n" if $trace; $ms->store('toto'); is( $ms->fetch, 'toto', "mandatory_string: store and read" ); my $toto_str = "a\nbig\ntext\nabout\ntoto"; $ms->store($toto_str); $toto_str =~ s/text/string/; $ms->store($toto_str); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; $inst->clear_changes; my $mwdv = $root->fetch_element('mandatory_with_default_value'); $mwdv->store('booya'); # emulate reading a file containing default value is( $mwdv->fetch, 'booya', "status quo" ); is( $inst->needs_save, 0, "verify instance needs_save status after storing default value" ); $mwdv->store('boo'); is( $mwdv->fetch, 'boo', "overrode default" ); is( $inst->needs_save, 1, "verify instance needs_save status after storing another value" ); $mwdv->store(undef); is( $mwdv->fetch, 'booya', "restore default by writing undef value in mandatory string" ); is( $inst->needs_save, 1, "verify instance needs_save status after restoring default value" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; $inst->clear_changes; my $mb = $root->fetch_element('mandatory_boolean'); ok( $mb, "created mandatory_boolean" ); throws_ok { my $v = $mb->fetch; } 'Config::Model::Exception::User', "mandatory bounded: undef error"; print "normal error:\n", $@, "\n" if $trace; check_store_error( $mb, 'toto', qr/boolean error/ ); check_store_error( $mb, 2, qr/boolean error/ ); my @bool_test = ( 1, 1, yes => 1, Yes => 1, no => 0, Nope => 0, true => 1, False => 0 ); while (@bool_test) { my $store = shift @bool_test; my $read = shift @bool_test; $mb->store($store); is( $mb->fetch, $read, "mandatory boolean: store $store and read $read value" ); } $inst->clear_changes; my $bwwa = $root->fetch_element('boolean_with_write_as'); is( $bwwa->fetch, undef, "boolean_with_write_as reads undef" ); $bwwa->store('no'); is( $bwwa->fetch, 'false', "boolean_with_write_as returns 'false'" ); is( $inst->needs_save, 1, "check needs_save after writing 'boolean_with_write_as'" ); eq_or_diff([$inst->list_changes],["boolean_with_write_as: '' -> '0'"], "check change message after writing 'boolean_with_write_as'"); $bwwa->store('false'); is( $inst->needs_save, 1, "check needs_save after writing twice 'boolean_with_write_as'" ); $bwwa->store(1); is( $bwwa->fetch, 'true', "boolean_with_write_as returns 'true'" ); my $bwwaad = $root->fetch_element('boolean_with_write_as_and_default'); is( $bwwa->fetch, 'true', "boolean_with_write_as_and_default reads true" ); throws_ok { $bad_root->fetch_element('crooked_enum'); } 'Config::Model::Exception::Model', "test create expected failure with enum with wrong default"; print "normal error:\n", $@, "\n" if $trace; my $de = $root->fetch_element('enum'); ok( $de, "Created enum with correct default" ); $inst->clear_changes; is( $de->fetch, 'A', "enum with default: read default value" ); is( $inst->needs_save, 1, "check needs_save after reading a default value" ); $inst->clear_changes; $de->store('A'); # emulate config file read is( $inst->needs_save, 0, "check needs_save after storing a value identical to default value" ); is( $de->fetch, 'A', "enum with default: read default value" ); is( $inst->needs_save, 0, "check needs_save after reading a default value" ); print "enum with default: read custom\n" if $trace; is( $de->fetch_custom, undef, "enum with default: read custom value" ); $de->store('B'); is( $de->fetch, 'B', "enum: store and read B" ); is( $de->fetch_custom, 'B', "enum: read custom value" ); is( $de->fetch_standard, 'A', "enum: read standard value" ); ## check model data is( $de->value_type, 'enum', "enum: check value_type" ); eq_array( $de->choice, [qw/A B C/], "enum: check choice" ); ok( $de->set_properties( default => 'B' ), "enum: warping default value" ); is( $de->default(), 'B', "enum: check new default value" ); throws_ok { $de->set_properties( default => 'F' ) } 'Config::Model::Exception::Model', "enum: warped default value to wrong value"; print "normal error:\n", $@, "\n" if $trace; ok( $de->set_properties( choice => [qw/A B C D/] ), "enum: warping choice" ); ok( $de->set_properties( choice => [qw/A B C D/], default => 'D' ), "enum: warping default value to new choice" ); ok( $de->set_properties( choice => [qw/F G H/], default => undef ), "enum: warping choice to completely different set" ); is( $de->default(), undef, "enum: check that new default value is undef" ); is( $de->fetch, undef, "enum: check that new current value is undef" ); $de->store('H'); is( $de->fetch(), 'H', "enum: set and read a new value" ); ### my $uc_c = $root->fetch_element('uc_convert'); ok( $uc_c, "testing convert => uc" ); $uc_c->store('coucou'); is( $uc_c->fetch(), 'COUCOU', "uc_convert: testing" ); my $lc_c = $root->fetch_element('lc_convert'); ok( $lc_c, "testing convert => lc" ); $lc_c->store('coUcOu'); is( $lc_c->fetch(), 'coucou', "lc_convert: testing" ); print "Testing integrated help\n" if $trace; my $value_with_help = $root->fetch_element('enum_with_help'); my $full_help = $value_with_help->get_help; is( $full_help->{a}, 'a help', "full enum help" ); is( $value_with_help->get_help('a'), 'a help', "enum help on one choice" ); is( $value_with_help->get_help('b'), undef, "test undef help" ); is( $value_with_help->fetch, undef, "test undef enum" ); print "Testing upstream default value\n" if $trace; my $up_def = $root->fetch_element('upstream_default'); is( $up_def->fetch, undef, "upstream actual value" ); is( $up_def->fetch_standard, 'up_def', "upstream standard value" ); is( $up_def->fetch('upstream_default'), 'up_def', "upstream actual value" ); is( $up_def->fetch('non_upstream_default'), undef, "non_upstream value" ); $up_def->store('yada'); is( $up_def->fetch('upstream_default'), 'up_def', "after store: upstream actual value" ); is( $up_def->fetch('non_upstream_default'), 'yada', "after store: non_upstream value" ); is( $up_def->fetch, 'yada', "after store: upstream actual value" ); is( $up_def->fetch('standard'), 'up_def', "after store: upstream standard value" ); ### my $uni = $root->fetch_element('a_uniline'); check_error( $uni, "foo\nbar", qr/value must not contain embedded newlines/ ); $uni->store("foo bar"); is( $uni->fetch, "foo bar", "tested uniline value" ); is( $inst->errors()->{'a_uniline'}, undef, "check that error was deleted by correct store" ); $uni->store(''); is( $uni->fetch, '', "tested empty value" ); ### test replace feature my $wrepl = $root->fetch_element('with_replace'); $wrepl->store('c1'); is( $wrepl->fetch, "c", "tested replaced value" ); $wrepl->store('foo/bar'); is( $wrepl->fetch, "b", "tested replaced value with regexp" ); ### test preset feature my $pinst = $model->instance( root_class_name => 'Master', instance_name => 'preset_test' ); ok( $pinst, "created dummy preset instance" ); my $p_root = $pinst->config_root; $pinst->preset_start; ok( $pinst->preset, "instance in preset mode" ); my $p_scalar = $p_root->fetch_element('scalar'); $p_scalar->store(3); my $p_enum = $p_root->fetch_element('enum'); $p_enum->store('B'); $pinst->preset_stop; is( $pinst->preset, 0, "instance in normal mode" ); is( $p_scalar->fetch, 3, "scalar: read preset value as value" ); $p_scalar->store(4); is( $p_scalar->fetch, 4, "scalar: read overridden preset value as value" ); is( $p_scalar->fetch('preset'), 3, "scalar: read preset value as preset_value" ); is( $p_scalar->fetch_standard, 3, "scalar: read preset value as standard_value" ); is( $p_scalar->fetch_custom, 4, "scalar: read custom_value" ); is( $p_enum->fetch, 'B', "enum: read preset value as value" ); $p_enum->store('C'); is( $p_enum->fetch, 'C', "enum: read overridden preset value as value" ); is( $p_enum->fetch('preset'), 'B', "enum: read preset value as preset_value" ); is( $p_enum->fetch_standard, 'B', "enum: read preset value as standard_value" ); is( $p_enum->fetch_custom, 'C', "enum: read custom_value" ); is( $p_enum->default, 'A', "enum: read default_value" ); ### test layered feature my $layer_inst = $model->instance( root_class_name => 'Master', instance_name => 'layered_test' ); ok( $layer_inst, "created dummy layered instance" ); my $l_root = $layer_inst->config_root; $layer_inst->layered_start; ok( $layer_inst->layered, "instance in layered mode" ); my $l_scalar = $l_root->fetch_element('scalar'); $l_scalar->store(3); my $l_enum = $l_root->fetch_element('bare_enum'); $l_enum->store('B'); my $msl = $l_root->fetch_element('mandatory_string'); $msl->store('plop'); $layer_inst->layered_stop; is( $layer_inst->layered, 0, "instance in normal mode" ); is( $l_scalar->fetch, undef, "scalar: read layered value as backend value" ); is( $l_scalar->fetch( mode => 'user' ), 3, "scalar: read layered value as user value" ); $l_scalar->store(4); is( $l_scalar->fetch, 4, "scalar: read overridden layered value as value" ); is( $l_scalar->fetch('layered'), 3, "scalar: read layered value as layered_value" ); is( $l_scalar->fetch_standard, 3, "scalar: read standard_value" ); is( $l_scalar->fetch_custom, 4, "scalar: read custom_value" ); is( $l_enum->fetch, undef, "enum: read layered value as backend value" ); is( $l_enum->fetch( mode => 'user' ), 'B', "enum: read layered value as user value" ); $l_enum->store('C'); is( $l_enum->fetch, 'C', "enum: read overridden layered value as value" ); is( $l_enum->fetch('layered'), 'B', "enum: read layered value as layered_value" ); is( $l_enum->fetch_standard, 'B', "enum: read layered value as standard_value" ); is( $l_enum->fetch_custom, 'C', "enum: read custom_value" ); is($msl->fetch('layered'), 'plop',"check mandatory value in layer"); is($msl->fetch, undef,"check mandatory value backend mode"); is($msl->fetch('user'), 'plop',"check mandatory value user mode with layer"); ### test match regexp my $match = $root->fetch_element('match'); check_error( $match, 'bar', qr/does not match/ ); $match->store('foo42/'); is( $match->fetch, 'foo42/', "test stored matching value" ); ### test Parse::RecDescent validation my $prd_match = $root->fetch_element('prd_match'); check_error( $prd_match, 'bar', qr/does not match grammar/ ); check_error( $prd_match, 'Perl', qr/does not match grammar/ ); $root->fetch_element('prd_test_action')->store('Perl CC-BY Apache'); foreach my $prd_test ( ( 'Perl', 'Perl and CC-BY', 'Perl and CC-BY or Apache' ) ) { $prd_match->store($prd_test); is( $prd_match->fetch, $prd_test, "test stored prd value $prd_test" ); } ### test warn_if parameter my $wip = $root->fetch_element('warn_if_match'); warning_like { $wip->store('foobar'); } qr/should not match/, "test warn_if condition"; is( $wip->has_fixes, 1, "test has_fixes" ); is( $wip->fetch( check => 'no', silent => 1 ), 'foobar', "check warn_if stored value" ); is( $wip->has_fixes, 1, "test has_fixes after fetch with check=no" ); is( $wip->fetch( mode => 'standard' ), undef, "check warn_if standard value" ); is( $wip->has_fixes, 1, "test has_fixes after fetch with mode = standard" ); ### test fix included in model $wip->apply_fixes; is( $wip->fetch, 'FOOBAR', "test if fixes were applied" ); ### test warn_if_number parameter my $win = $root->fetch_element('warn_if_number'); warning_like { $win->store('bar51'); } qr/should not have numbers/, "test warn_if condition"; is( $win->has_fixes, 1, "test has_fixes" ); $win->apply_fixes; is( $win->fetch, 'bar', "test if fixes were applied" ); ### test warn_unless parameter my $wup = $root->fetch_element('warn_unless_match'); warning_like { $wup->store('bar'); } qr/should match/, "test warn_unless_match condition"; is( $wup->has_fixes, 1, "test has_fixes" ); $wup->apply_fixes; is( $wup->fetch, 'foobar', "test if fixes were applied" ); ### test always_warn parameter my $aw = $root->fetch_element('always_warn'); warning_like { $aw->store('whatever'); } qr/always/i, "test unconditional warn"; # test unicode my $smiley = "\x{263A}"; # See programming perl chapter 15 $wip->store(':-)'); # to test list_changes just below $wip->store($smiley); is( $wip->fetch, $smiley, "check utf-8 string" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; # test replace_follow my $wrf = $root->fetch_element('with_replace_follow'); $inst->clear_changes; $wrf->store('foo'); is( $inst->needs_save, 1, "check needs_save after store" ); $inst->clear_changes; is( $wrf->fetch, 'foo', "check replacement_hash with foo (before replacement)" ); is( $inst->needs_save, 0, "check needs_save after simple fetch" ); $root->load('replacement_hash:foo=repfoo replacement_hash:bar=repbar'); is( $inst->needs_save, 2, "check needs_save after load" ); $inst->clear_changes; is( $wrf->fetch, 'repfoo', "check replacement_hash with foo (after replacement)" ); is( $inst->needs_save, 1, "check needs_save after fetch with replacement" ); $wrf->store('bar'); is( $wrf->fetch, 'repbar', "check replacement_hash with bar" ); $wrf->store('baz'); is( $wrf->fetch, 'baz', "check replacement_hash with baz (no replacement)" ); ok( !$root->fetch_element('replacement_hash')->exists('baz'), "check that replacement hash was not changed by missed substitution" ); $inst->clear_changes; my $sv = $root->fetch_element('Standards-Version'); warning_like { $sv->store('3.9.1'); } qr/Current/, "store old standard version"; is( $inst->needs_save, 1, "check needs_save after load" ); $sv->apply_fixes; is( $inst->needs_save, 2, "check needs_save after load" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; is( $sv->fetch, '3.9.2', "check fixed standard version" ); is( $sv->fetch( mode => 'custom' ), undef, "check custom standard version" ); ### test assert my $assert_elt = $root->fetch_element('assert'); throws_ok { $assert_elt->fetch(); } 'Config::Model::Exception::WrongValue', "check assert error"; $assert_elt->apply_fixes; ok( 1, "assert_elt apply_fixes called" ); is( $assert_elt->fetch, 'foobar', "check fixed assert pb" ); ### test warn_unless my $warn_unless = $root->fetch_element('warn_unless'); warning_like { $warn_unless->fetch(); } qr/should not be empty/, "check warn_unless"; $warn_unless->apply_fixes; ok( 1, "warn_unless apply_fixes called" ); is( $warn_unless->fetch, 'foobar', "check fixed warn_unless pb" ); ### test file and dir my $t_file = $root->fetch_element('t_file'); my $t_dir = $root->fetch_element('t_dir'); warning_like {$t_file->store('toto')} qr/not exist/, "test non existent file" ; warning_like {$t_file->store('t')} qr/not a file/, "test not a file" ; warning_like {$t_dir->store('t/value.t')} qr/not a dir/, "test not a dir" ; $t_file->store('t/value.t') ; is($t_file->has_warning, 0, "test a file"); $t_dir->store('t/') ; is($t_dir->has_warning, 0, "test a dir"); ### test problems during initial load my $inst2 = $model->instance( root_class_name => 'Master', instance_name => 'initial_test' ); ok( $inst2, "created initial_test inst2ance" ); # is triggered internally only when at least one node has a RW backend $inst2->initial_load_start; my $s = $inst2->config_root->fetch_element('string'); $s->store('foo'); $s->store('foo'); is( $inst2->needs_save, 1, "verify instance needs_save status after redundant data" ); eq_or_diff([$inst2->list_changes],['string: removed redundant initial value'],"check change message for redundant data"); $inst2->clear_changes; is( $inst2->needs_save, 0, "needs_save after clearing changes" ); $s->store('bar'); eq_or_diff([$inst2->list_changes],['string: \'foo\' -> \'bar\' # conflicting initial values'],"check change message for redundant data"); is( $inst2->needs_save, 1, "verify instance needs_save status after conflicting data" ); $inst2->clear_changes; $s->parent->fetch_element('uc_convert')->store('foo'); eq_or_diff([$inst2->list_changes],['uc_convert: \'foo\' -> \'FOO\' # initial value changed by model'], "check change message when model changes data coming from config file"); $inst2->clear_changes; $s->parent->fetch_element('boolean_with_write_as')->store('true'); is( $inst2->needs_save, 0, "verify instance needs_save status after writing 'boolean_with_write_as'" ); $inst2->initial_load_stop; memory_cycle_ok( $model, "check memory cycles" ); done_testing; model.t100644001750001750 757012676543661 14675 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Warn 0.11; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::Lister; use Data::Dumper; use Log::Log4perl qw(:easy :levels); use warnings; no warnings qw(once); use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "compiled" ); my $model = Config::Model->new(); my ( $cat, $models ) = Config::Model::Lister::available_models(1); eq_or_diff( $cat->{system}, [qw/fstab popcon/], "check available system models" ); is( $models->{popcon}{model}, 'PopCon', "check available popcon" ); eq_or_diff( $cat->{application}, [qw/multistrap/], "check available application models" ); my $class_name = $model->create_config_class( name => 'Sarge', status => [ D => 'deprecated' ], #could be obsolete, standard description => [ X => 'X-ray (long description)' ], summary => [ X => 'X-ray (summary)' ], element => [ [qw/D X Y Z/] => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', choice => [qw/Av Bv Cv/] } ], ); is( $class_name, 'Sarge', "check $class_name class name" ); my $canonical_model = $model->get_model($class_name); print "$class_name model:\n", Dumper($canonical_model) if $trace; eq_or_diff( $model->get_element_model( $class_name, 'D' ), { 'value_type' => 'enum', 'status' => 'deprecated', 'type' => 'leaf', 'class' => 'Config::Model::Value', 'choice' => [ 'Av', 'Bv', 'Cv' ] }, "check $class_name D element model" ); eq_or_diff( $model->get_element_model( $class_name, 'X' ), { 'value_type' => 'enum', 'summary' => 'X-ray (summary)', 'type' => 'leaf', 'class' => 'Config::Model::Value', 'choice' => [ 'Av', 'Bv', 'Cv' ], 'description' => 'X-ray (long description)' }, "check $class_name X element model" ); $class_name = $model->create_config_class( name => 'Captain', element => [ bar => { type => 'node', config_class_name => 'Sarge' } ] ); my @bad_model = ( name => "Master", level => [ [qw/captain many/] => 'important' ], element => [ captain => { type => 'node', config_class_name => 'Captain', }, ], ); throws_ok { $model->create_config_class(@bad_model) } "Config::Model::Exception::ModelDeclaration", "check model with orphan level"; $class_name = $model->create_config_class( name => "Master", level => [ qw/captain/ => 'important' ], force_element_order => [qw/captain array_args hash_args/], element => [ captain => { type => 'node', config_class_name => 'Captain', }, [qw/array_args hash_args/] => { type => 'node', config_class_name => 'Captain', }, ], class_description => "Master description", description => [ captain => "officer", array_args => 'not officer' ] ); ok( 1, "Model created" ); is( $class_name, 'Master', "check $class_name class name" ); $canonical_model = $model->get_model($class_name); print "$class_name model:\n", Dumper($canonical_model) if $trace; memory_cycle_ok( $model, "memory cycles" ); done_testing; README.pod100644001750001750 1270012676543661 14615 0ustar00domidomi000000000000Config-Model-2.082=head1 Config::Model - Describe and edit configuration data L enables a project developer to provide an interactive configuration editor (graphical, curses based or plain terminal) to his users. For this, he must: =over =item * describe the structure and constraints of his project's configuration. (this is called a model, but could also be called a schema) =item * find a way to read and write configuration data. This can be provided by L backends or by custom code =back With the elements above, L will generate interactive configuration editors (with integrated help and data validation). These editors can be graphical (with L), curses based (with L) or based on ReadLine (with L). =head2 Installation See L =head2 Getting started =over =item * To manage your configuration files with existing modules, see L =item * To create configuration tools for your favorite project, see this L =back =head2 How does this work ? Using this project, a typical configuration editor will be made of 3 parts : =over =item 1. The user interface ( L program and some other optional modules) =item 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). =item 3. The storage facility that store the configuration information (currently several backends are provided: ini files, perl files, and Augeas) =back The important part is the configuration model used by the validation engine. This model can be created or modified with a graphical editor (L provided by L). =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 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. =head2 What's the advantage of this project ? L 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 L distributed with 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 ...) =item * the default values of parameters (if any) =item * mandatory parameters =item * Warning conditions (and optionally, instructions to fix warnings) =item * on-line help (for each parameter or value of parameter) =back So, in the end: =over =item * maintenance and evolution of the configuration content is easier =item * user will see a B interface for B programs using this project. =item * upgrade of configuration data is easier and sanity check is performed =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 L with L). =item * Graphical with L (Perl/Tk interface). =item * based on curses with L. =back All these interfaces are generated from the configuration model. And configuration model can be created or modified with a graphical user interface (L) =head2 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. With the additional L, L library can be used to read and write some configuration files. =head2 If you want to discuss Config::Model ? Subscribe to the config-model-users list: L =head2 More information See =over =item * the L (i.e. the wiki tab above) =item * L =back weaver.ini100644001750001750 22512676543661 15105 0ustar00domidomi000000000000Config-Model-2.082[@Default] [-Transformer] transformer = List [Support] perldoc = 0 bugs = metadata websites = search,anno,ratings,kwalitee,testers,testmatrix,deps report.t100644001750001750 502112676543661 15075 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- # $Author$ # $Date$ # $Revision$ use ExtUtils::testlib; use Test::More tests => 9; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Config root created" ); my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata" ' . 'lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - listb=b,c,d ' . '! hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy my_check_list=X2,X3'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); $step = 'tree_macro=XY'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); my $report = $root->report; print "report string:\n$report" if $trace; my $expect = <<'EOF' ; std_id:ab X = Bv std_id:ab DX = Dv std_id:bc X = Av std_id:bc DX = Dv lista:0 = a lista:1 = b lista:2 = c lista:3 = d listb:0 = b listb:1 = c listb:2 = d hash_a:X2 = x hash_a:Y2 = xy hash_b:X3 = xy olist:0 X = Av olist:0 DX = Dv olist:1 X = Bv olist:1 DX = Dv tree_macro = XY DESCRIPTION: controls behavior of other elements SELECTED: XY help string_with_def = "yada yada" a_uniline = "yada yada" a_string = "toto tata" int_v = 10 my_check_list = X2,X3 EOF is_deeply( [ split /\n/, $report ], [ split /\n/, $expect ], "check dump of only customized values " ); $report = $root->audit(); print "audit string:\n$report" if $trace; $expect = <<'EOF' ; std_id:ab X = Bv std_id:bc X = Av lista:0 = a lista:1 = b lista:2 = c lista:3 = d listb:0 = b listb:1 = c listb:2 = d hash_a:X2 = x hash_a:Y2 = xy hash_b:X3 = xy olist:0 X = Av olist:1 X = Bv tree_macro = XY DESCRIPTION: controls behavior of other elements SELECTED: XY help a_string = "toto tata" my_check_list = X2,X3 EOF is_deeply( [ split /\n/, $report ], [ split /\n/, $expect ], "check dump of all values " ); my $list = $model->list_class_element; ok( $list, "check list_class_element" ); print $list if $trace; #use Tk::ObjScanner; Tk::ObjScanner::scan_object($model) ; memory_cycle_ok($model); accept.t100644001750001750 1003212676543661 15037 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Warn; use Test::Memory::Cycle; use Config::Model; use File::Path; use File::Copy; use Data::Dumper; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new(); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $ERROR ); ok( 1, "compiled" ); $model->create_config_class( name => 'Host', accept => [ 'list.*' => { type => 'list', cargo => { type => 'leaf', value_type => 'string', }, accept_after => 'id', }, 'str.*' => { type => 'leaf', value_type => 'uniline' }, 'bad.*' => { type => 'leaf', value_type => 'uniline', warn => 'gotcha', }, 'ot.*' => { type => 'leaf', value_type => 'uniline', }, #TODO: Some advanced structures, hashes, etc. ], element => [ [qw/id other/] => { type => 'leaf', value_type => 'uniline', }, 'strhidden' => { type => 'leaf', value_type => 'uniline', level => 'hidden', }, ] ); ok( 1, "Created new class with accept parameter" ); # set_up data my $i_hosts = $model->instance( instance_name => 'hosts_inst', root_class_name => 'Host', ); is($model->get_element_property(qw/class Host element otary property value_type/),'uniline', "get_element_property on accepted element" ); is($model->get_element_property(qw/class Host element other property value_type/),'uniline', "get_element_property on a predefined element matching an accepted one" ); # Test fix where XS-Autobuild did show up with cme edit dpkg-control is($model->get_element_property(qw/class Host element strhidden property level/),'hidden', "get_element_property on hidden accepted element" ); is($model->get_element_property(qw/class Host element strok property level/),'normal', "get_element_property on a predefined hidden element matching an accepted one" ); ok( $i_hosts, "Created instance" ); my $i_root = $i_hosts->config_root; is_deeply( [ $i_root->accept_regexp ], [qw/list.* str.* bad.* ot.*/], "check accept_regexp" ); is_deeply( [ $i_root->get_element_name ], [qw/id other/], "check explicit element list" ); my $load = "listA=one,two,three,four listB=1,2,3,4 listC=a,b,c,d str1=test str2=of str3=accept str4=parameter - "; $i_root->load($load); ok( 1, "Data loaded" ); is_deeply( [ $i_root->fetch_element('listC')->fetch_all_values ], [qw/a b c d/], "check accepted list content" ); is_deeply( [ $i_root->get_element_name ], [qw/id listC listB listA other str1 str2 str3 str4/], "check element list with accepted parameters" ); foreach my $oops (qw/foo=bar vlistB=test/) { throws_ok { $i_root->load($oops); } "Config::Model::Exception::UnknownElement", "caught unacceptable parameter: $oops"; } ### test always_warn parameter my $bad = $i_root->fetch_element('badbad'); warning_like { $bad->store('whatever'); } qr/gotcha/, "test unconditional warn"; eval {require Text::Levenshtein::Damerau} ; my $has_tld = ! $@ ; SKIP: { skip "Text::Levenshtein::Damerau is not installed", 5 unless $has_tld; ### test user typo: accepted element is too close to real element my @shaves = qw/oter 1 other2 1 otehr 1 other23 1 oterh23 0/; while ( my $close_shave = shift @shaves) { my $expect = shift @shaves; if ($expect) { warning_like { $i_root->fetch_element($close_shave); } qr/distance/, "test $close_shave too close to 'other'"; } else { warnings_are { $i_root->fetch_element($close_shave); } [], "test accept $close_shave, is not too close to 'other'"; } } } memory_cycle_ok($model); done_testing; term_ui.t100644001750001750 550112676543661 15231 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Differences; # this block is necessary to avoid failure on some automatic cpan # testers setup which fail while loading Term::ReadLine BEGIN { my $ok = eval { require Term::ReadLine; my $test = new Term::ReadLine 'Test'; 1; } and ( eval { require Term::ReadLine::Gnu; 1; } or eval { require Term::ReadLine::Perl; 1; } ); if ($ok) { plan tests => 12; } else { plan skip_all => "Cannot load Term::ReadLine"; } } use Test::Memory::Cycle; use Config::Model; use Config::Model::TermUI; use warnings; no warnings qw(once); use strict; use Data::Dumper; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); note("you can run the test in interactive mode by passing 'i' argument, i.e. perl -Ilib t/term_ui.t i"); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $step = 'std_id:ab X=Bv - ' . 'std_id:bc X=Av - ' . 'std_id:"abc def" X=Av - ' . 'std_id:"abc hij" X=Av - ' . 'a_string="toto tata"'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); # this test test only execution of user command, not their actual # input my $prompt = 'Test Prompt'; my $term_ui = Config::Model::TermUI->new( root => $root, title => 'Test Title', prompt => $prompt, ); if ($arg =~ /i/) { $term_ui->run_loop; exit; } my @std_id_list = ('std_id:','std_id:ab ','std_id:"abc def" ' ,'std_id:"abc hij" ', 'std_id:bc ') ; my @test = ( # text line start ## expected completions [ [ '', '', 0 ], [qw/cd changes clear delete desc description display dump fix help ll ls reset save set tree/] ], [ [ '', 'cd ', 3 ], [ '!', '-', @std_id_list , 'olist:', 'warp ', 'slave_y ' ] ], [ [ 's', 'cd s', 3 ], [ @std_id_list, 'slave_y ' ] ], [ [ 'sl', 'cd sl', 3 ], ['slave_y '] ], [ [ 'std_id:', 'cd std_id:', 10 ], \@std_id_list ], [ [ 'std_id:"', 'cd std_id:"', 11 ], ['std_id:"abc def" ' ,'std_id:"abc hij" ' ] ], [ [ 'std_id:"abc', 'cd std_id:"abc',14 ], ['std_id:"abc def" ' ,'std_id:"abc hij" ' ] ], [ [ 'std_id:a', 'cd std_id:a', 3 ], ['std_id:ab '] ], ); foreach my $a_test (@test) { my ( $input, $expect ) = @$a_test; my @comp = $term_ui->completion(@$input); print Dumper ( \@comp ) if $trace; eq_or_diff( \@comp, $expect, "exec '" . join( "', '", @$input ) . "'" ); } memory_cycle_ok($model); include.t100644001750001750 512312676543661 15210 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Data::Dumper; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new(); $model->create_config_class( name => "Two", element => [ two => { type => 'leaf', value_type => 'string', }, ] ); $model->create_config_class( name => "Three", element => [ three => { type => 'leaf', value_type => 'string', }, ] ); $model->create_config_class( name => "Four", include => [qw/Three/], element => [ four => { type => 'leaf', value_type => 'string', }, ] ); $model->create_config_class( name => "Master", include => [qw/Two Four/], include_after => 'one', element => [ one => { type => 'leaf', value_type => 'string', }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my @elt = $root->get_element_name(); is_deeply( \@elt, [qw/one two three four/], "check multiple include order" ); my @bad_class = ( name => "EvilMaster", include => [qw/Master/], element => [ one => { type => 'leaf', value_type => 'string', }, ] ); # failure occurs later $model->create_config_class(@bad_class); throws_ok { $model->get_model('EvilMaster'); } qr/cannot clobber/i, "Check that include does not clobber elements"; # test include of read/write spec $model->create_config_class( name => 'LikeXorg', 'include_backend' => [ 'Xorg::ConfigDir' ], element => [ one => { type => 'leaf', value_type => 'string', }, ], ); my $read_config = [{ 'auto_create' => 1, 'backend' => 'Xorg', 'config_dir' => '/etc/X11', 'file' => 'xorg.conf' }] ; $model->create_config_class( 'name' => 'Xorg::ConfigDir', 'read_config' => $read_config ); my $xorg_model = $model->get_model('LikeXorg'); eq_or_diff($xorg_model->{read_config}, $read_config,"check included read specification"); memory_cycle_ok($model, "memory cycles"); done_testing; fuse_ui.t100644001750001750 1210012676543661 15235 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Path::Tiny; use Test::Memory::Cycle; use Config::Model; use Config; # Config::Model::FuseUI is loaded later within an eval if ( $Config{osname} ne 'linux' ) { plan skip_all => "Not a Linux system"; } my @lsmod = eval { `lsmod`; }; if ($@) { plan skip_all => "Cannot check is fuse module is loaded: $@"; } if ( not grep ( /fuse/, @lsmod ) ) { plan skip_all => "fuse module is not loaded"; } if ( not grep ( m!/!, `bash -c 'type fusermount'` ) ) { plan skip_all => "fusermount not found"; } my $umount_str = `bash -c 'umount --version'`; my ($umount_v) = $umount_str =~ / (\d+\.\d+)/; if ( $umount_v + 0 < 2.18 ) { plan skip_all => "Did not find umount with version >= 2.18"; } eval { require Config::Model::FuseUI; }; if ($@) { plan skip_all => "Config::Model::FuseUI or Fuse is not installed"; } else { # the forked process prints an ok, hence done_testing cannot be used plan tests => 17; } use warnings; use strict; # required to handle warnings in forked process local $SIG{__WARN__} = sub { die $_[0] unless $_[0] =~ /deprecated/ }; use Data::Dumper; use POSIX ":sys_wait_h"; my $arg = shift || ''; my $log = 0; my $trace = $arg =~ /t/ ? 1 : 0; my $fuse_debug = $arg =~ /f/ ? 1 : 0; $log = 1 if $arg =~ /l/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init($WARN); } ok( 1, "Compilation done" ); # pseudo root where config files are written by config-model my $wr_root = path('wr_root'); # cleanup before tests $wr_root->remove_tree; $wr_root->mkpath( { mode => 0755 } ); my $fused = $wr_root->child('fused'); $fused->mkpath( { mode => 0755 } ); my $model = Config::Model->new( legacy => 'ignore' ); $model->load( Master => 't/big_model.pm' ); $model->augment_config_class( name => 'Master', element => [ 'a_boolean' => { type => 'leaf', value_type => 'boolean', default => 0 }, ], ); my $inst = $model->instance( root_class_name => 'Master' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - std_id:"a/c" X=Av - a_string="toto tata"'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); my $ui = Config::Model::FuseUI->new( root => $root, mountpoint => "$fused", dir_char_mockup => '\\', ); my $dir_char_mockup = $ui->dir_char_mockup; ok( $ui, "Created ui (dir mockup is $dir_char_mockup)" ); # now fork my $pid = fork; if ( defined $pid and $pid == 0 ) { # child process, just run fuse and wait for exit $ui->run_loop( debug => $fuse_debug ); exit; } # WARNING: the child process has its own copy of the config tree # there's no use in modifying the tree on the parent process. # wait for fuse to do its job sleep 1; # child process, continue tests my @content = sort map { $_->relative($fused); } $fused->children; is_deeply( \@content, [ sort $root->get_element_name() ], "check $fused content" ); my $std_id = $fused->child('std_id'); @content = sort map { $_->relative($std_id); } $std_id->children; my @std_id_elements = sort $root->fetch_element('std_id')->fetch_all_indexes(); map { s(/){$dir_char_mockup}g; } @std_id_elements; is_deeply( \@content, \@std_id_elements, "check $std_id content (@content)" ); is( $fused->child('a_string')->slurp, $root->grab_value('a_string') . "\n", "check a_string content" ); my $a_string_fhw = $fused->child('a_string')->openw; $a_string_fhw->print("foo bar"); $a_string_fhw->close; is( $fused->child('a_string')->slurp, "foo bar\n", "check new a_string content" ); $std_id->child('cd')->mkpath(); ok( 1, "mkpath on cd dir done" ); @content = sort map { $_->relative($std_id); } $std_id->children; is_deeply( \@content, [ @std_id_elements, 'cd' ], "check $std_id new content (@content)" ); $std_id->child('cd')->remove_tree(); ok( 1, "remove_tree on cd dir done" ); @content = sort map { $_->relative($std_id); } $std_id->children; is_deeply( \@content, \@std_id_elements, "check $std_id content after rmdir (@content)" ); is( $fused->child('a_boolean')->slurp, "0\n", "check new a_boolean content" ); my $a_boolean_fhw = $fused->child('a_boolean')->openw; $a_boolean_fhw->print("1"); $a_boolean_fhw->close; is( $fused->child('a_boolean')->slurp, "1\n", "check new a_boolean content (set to 1)" ); $a_boolean_fhw = $fused->child('a_boolean')->openw; $a_boolean_fhw->print("a"); $a_boolean_fhw->close; is( $fused->child('a_boolean')->slurp, "\n", "check new a_boolean content (blank after error)" ); END { if ($pid) { # run this only in parent process # umount so child process will exit system("fusermount -u $fused"); # inspired from perlipc man page my $child; while ( ( $child = wait ) > 0 ) { ok( 1, "Process pid $child done" ); } } exit; } memory_cycle_ok( $model, "memory cycles" ); instance.t100644001750001750 564712676543661 15404 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More; use Test::Warn; use Test::Memory::Cycle; use Config::Model; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => "WarnMaster", element => [ warn_if => { type => 'leaf', value_type => 'string', warn_if_match => { 'foo' => { fix => '$_ = uc;' } }, }, warn_unless => { type => 'leaf', value_type => 'string', warn_unless_match => { foo => { msg => '', fix => '$_ = "foo".$_;' } }, }, ] ); my $messager ; my $inst = $model->instance( root_class_name => 'WarnMaster', instance_name => 'test1', root_dir => 'foobar', on_message_cb => sub { $messager = shift;}, ); ok( $inst, "created dummy instance" ); $inst->show_message('hello'); is($messager,'hello',"test show_message_cb"); isa_ok( $inst->config_root, 'Config::Model::Node', "test config root class" ); is( $inst->data('test'), undef, "test empty private data ..." ); $inst->data( 'test', 'coucou' ); is( $inst->data('test'), 'coucou', "retrieve private data" ); is( $inst->read_root_dir, 'foobar/', "test read directory" ); is( $inst->write_root_dir, 'foobar/', "test write directory" ); # test if fixes can be applied through the instance my $root = $inst->config_root; my $wip = $root->fetch_element('warn_if'); my $wup = $root->fetch_element('warn_unless'); warning_like { $wip->store('foobar'); } qr/should not match/, "test warn_if condition (instance test)"; warning_like { $wup->store('bar'); } qr/should match/, "test warn_unless condition (instance test)"; is( $inst->has_warning, 2, "check warning count at instance level" ); $inst->apply_fixes; is( $wup->fetch, 'foobar', "test if fixes were applied (instance test)" ); is( $wup->fetch, 'foobar', "test if fixes were applied (instance test)" ); is( $inst->has_warning, 0, "check cleared warning count at instance level" ); my $binst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test2' ); ok( $binst, "created dummy instance" ); my $root2 = $binst->config_root; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata" ' . 'lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - listb=b,c,d ' . '! hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy my_check_list=X2,X3'; ok( $root2->load( step => $step ), "set up data in tree with '$step'" ); is( $binst->has_warning, 0, "test has_warning with big model" ); Config::Model::Exception::Any->Trace(1) if $trace =~ /e/; memory_cycle_ok($model); done_testing; array_id.t100644001750001750 3552212676543661 15405 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Warn; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Config::Model::AnyId; use Log::Log4perl qw(:easy :levels); use strict; my $arg = shift || ''; my $log = 0; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } my $model = Config::Model->new(); Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "compiled" ); my @element = ( # Value constructor args are passed in their specific array ref cargo => { type => 'leaf', value_type => 'string' }, ); # minimal set up to get things working $model->create_config_class( name => "Master", element => [ bounded_list => { type => 'list', class => 'Config::Model::ListId', # default max => 123, cargo => { type => 'leaf', value_type => 'string' }, }, plain_list => { type => 'list', @element }, list_with_auto_created_id => { type => 'list', auto_create_ids => 4, @element }, olist => { type => 'list', cargo => { type => 'node', config_class_name => 'Slave' }, }, list_with_default_with_init_leaf => { type => 'list', default_with_init => { 0 => 'def_1 stuff', 1 => 'def_2 stuff' }, @element, }, list_with_default_with_init_node => { type => 'list', default_with_init => { 0 => 'X=Bv Y=Cv', 1 => 'X=Av' }, cargo => { type => 'node', config_class_name => 'Slave' }, }, map { ( "list_with_" . $_ . "_duplicates" => { type => 'list', duplicates => $_, @element, }, ); } qw/warn allow forbid suppress/, ] ); $model->create_config_class( name => "Bogus", element => [ list_with_wrong_auto_create => { type => 'list', auto_create_ids => ['foo'], @element }, list_with_wrong_duplicates => { type => 'list', duplicates => 'forbid', cargo => { type => 'node', config_class_name => 'Slave' }, }, list_with_yada_duplicates => { type => 'list', duplicates => 'yada', @element, }, ] ); $model->create_config_class( name => "Slave", element => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ] ); ok( 1, "config classes created" ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); $inst->initial_load_stop; my $root = $inst->config_root; eq_or_diff( [ $root->fetch_element('olist')->fetch_all_indexes ], [], "check index list of empty list" ); is( $inst->needs_save, 0, "verify instance needs_save status after creation" ); my $b = $root->fetch_element('bounded_list'); ok( $b, "bounded list created" ); is( $inst->needs_save, 0, "verify instance needs_save status after element creation" ); is( $b->fetch_with_id(1)->store('foo'), 1, "stored in 1" ); is( $b->fetch_with_id(0)->store('baz'), 1, "stored in 0" ); is( $b->fetch_with_id(2)->store('bar'), 1, "stored in 2" ); is( $inst->needs_save, 3, "verify instance needs_save status after storing into element" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; throws_ok { $b->fetch_with_id(124)->store('baz'); } qr/Index 124 > max_index limit 123/, 'max error caught'; my $bogus_root = $model->instance( root_class_name => 'Bogus' )->config_root; throws_ok { $bogus_root->fetch_element('list_with_wrong_auto_create'); } qr/Wrong auto_create argument for list/, 'wrong auto_create caught'; eq_or_diff( [ $b->fetch_all_indexes ], [ 0, 1, 2 ], "check ids" ); $b->delete(1); is( $b->fetch_with_id(1)->fetch, undef, "check deleted id" ); is( $b->index_type, 'integer', 'check list index_type' ); is( $b->max_index, 123, 'check list max boundary' ); $b->push( 'toto', 'titi' ); is( $b->fetch_with_id(2)->fetch, 'bar', "check last item of table" ); is( $b->fetch_with_id(3)->fetch, 'toto', "check pushed toto item" ); is( $b->fetch_with_id(4)->fetch, 'titi', "check pushed titi item" ); $b->push_x( values => [ 'toto', 'titi' ], check => 'no', annotation => ['toto comment'] ); is( $b->fetch_with_id(5)->fetch, 'toto', "check pushed toto item with push_x" ); is( $b->fetch_with_id(5)->annotation, 'toto comment', "check pushed toto annotation with push_x" ); is( $b->fetch_with_id(6)->fetch, 'titi', "check pushed titi item with push_x" ); $b->push_x( values => 'toto2', check => 'no', annotation => 'toto2 comment' ); is( $b->fetch_with_id(7)->fetch, 'toto2', "check pushed toto2 item with push_x" ); is( $b->fetch_with_id(7)->annotation, 'toto2 comment', "check pushed toto2 annotation with push_x" ); my @all = $b->fetch_all_values; eq_or_diff( \@all, [qw/baz bar toto titi toto titi toto2/], "check fetch_all_values" ); my $lac = $root->fetch_element('list_with_auto_created_id'); eq_or_diff( [ $lac->fetch_all_indexes ], [ 0 .. 3 ], "check list_with_auto_created_id" ); map { is( $b->fetch_with_id($_)->index_value, $_, "Check index value $_" ); } ( 0 .. 4 ); $b->move( 3, 4 ); is( $b->fetch_with_id(3)->fetch, undef, "check after move idx 3 in 4" ); is( $b->fetch_with_id(4)->fetch, 'toto', "check after move idx 3 in 4" ); map { is( $b->fetch_with_id($_)->index_value, $_, "Check moved index value $_" ); } ( 0 .. 4 ); $b->fetch_with_id(3)->store('titi'); $b->swap( 3, 4 ); map { is( $b->fetch_with_id($_)->index_value, $_, "Check swapped index value $_" ); } ( 0 .. 4 ); is( $b->fetch_with_id(3)->fetch, 'toto', "check value after swap" ); is( $b->fetch_with_id(4)->fetch, 'titi', "check value after swap" ); $b->remove(3); is( $b->fetch_with_id(3)->fetch, 'titi', "check after remove" ); # test move swap with node list my $ol = $root->fetch_element('olist'); my @set = ( [qw/X Av/], [qw/X Bv/], [qw/Y Av/], [qw/Z Cv/], [qw/Z Av/], ); my $i = 0; foreach my $item (@set) { my ( $e, $v ) = @$item; $ol->fetch_with_id( $i++ )->fetch_element($e)->store($v); } $inst->clear_changes; $ol->move( 3, 4 ); is( $inst->needs_save, 1, "verify instance needs_save status after move" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; is( $ol->fetch_with_id(3)->fetch_element('Z')->fetch, undef, "check after move idx 3 in 4" ); is( $ol->fetch_with_id(4)->fetch_element('Z')->fetch, 'Cv', "check after move idx 3 in 4" ); map { is( $ol->fetch_with_id($_)->index_value, $_, "Check moved index value $_" ); } ( 0 .. 4 ); $ol->swap( 0, 2 ); is( $inst->needs_save, 1, "verify instance needs_save status after move" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; is( $ol->fetch_with_id(0)->fetch_element('X')->fetch, undef, "check after move idx 0 in 2" ); is( $ol->fetch_with_id(0)->fetch_element('Y')->fetch, 'Av', "check after move" ); is( $ol->fetch_with_id(2)->fetch_element('Y')->fetch, undef, "check after move" ); is( $ol->fetch_with_id(2)->fetch_element('X')->fetch, 'Av', "check after move" ); map { is( $ol->fetch_with_id($_)->index_value, $_, "Check moved index value $_" ); } ( 0 .. 4 ); print $root->dump_tree( ) if $trace; is( $ol->fetch_with_id(0)->fetch_element('X')->fetch, undef, "check before move" ); $ol->remove(0); print $root->dump_tree( ) if $trace; is( $ol->fetch_with_id(0)->fetch_element('X')->fetch, 'Bv', "check after move" ); # test store my @test = ( [ a1 => ['a1'] ], [ '"a","b"' => [qw/a b/] ], [ 'a,b' => [qw/a b/] ], [ '"a\"a",b' => [qw/a"a b/] ], [ '"a,a",b' => [ 'a,a', 'b' ] ], [ '",a1"' => [',a1'] ], ); foreach my $l (@test) { $b->load( $l->[0] ); eq_or_diff( [ $b->fetch_all_values ], $l->[1], "test store $l->[0]" ); } throws_ok { $b->load('a,,b'); } "Config::Model::Exception::Load", "fails load 'a,,b'"; # test preset mode $inst->preset_start; my $pl = $root->fetch_element('plain_list'); $pl->fetch_with_id(0)->store('prefoo'); $pl->fetch_with_id(1)->store('prebar'); $inst->preset_stop; ok( 1, "filled preset values" ); eq_or_diff( [ $pl->fetch_all_values ], [ 'prefoo', 'prebar' ], "check that preset values are read" ); $pl->fetch_with_id(2)->store('bar'); eq_or_diff( [ $pl->fetch_all_values ], [ 'prefoo', 'prebar', 'bar' ], "check that values are read" ); eq_or_diff( [ $pl->fetch_all_values( mode => 'custom' ) ], ['bar'], "check that custom values are read" ); # test default_with_init on leaf my $lwdwil = $root->fetch_element('list_with_default_with_init_leaf'); # note: calling fetch_all_indexes is required to trigger creation of default_with_init keys eq_or_diff( [ $lwdwil->fetch_all_indexes ], [ 0, 1 ], "check default keys" ); is( $lwdwil->fetch_with_id(0)->fetch, 'def_1 stuff', "test default_with_init leaf 0" ); is( $lwdwil->fetch_with_id(1)->fetch, 'def_2 stuff', "test default_with_init leaf 1" ); # test default_with_init on node my $lwdwin = $root->fetch_element('list_with_default_with_init_node'); eq_or_diff( [ $lwdwin->fetch_all_indexes ], [ 0, 1 ], "check default keys" ); is( $lwdwin->fetch_with_id(0)->fetch_element('X')->fetch, 'Bv', "test default_with_init node 0" ); is( $lwdwin->fetch_with_id(0)->fetch_element('Y')->fetch, 'Cv', "test default_with_init node 0" ); is( $lwdwin->fetch_with_id(1)->fetch_element('X')->fetch, 'Av', "test default_with_init node 0" ); throws_ok { $bogus_root->fetch_element('list_with_wrong_duplicates'); } "Config::Model::Exception::Model", "fails duplicates with node cargo"; throws_ok { $bogus_root->fetch_element('list_with_yada_duplicates'); } "Config::Model::Exception::Model", "fails yada duplicates"; foreach my $what (qw/forbid warn suppress/) { my $lwd = $root->fetch_element( 'list_with_' . $what . '_duplicates' ); $lwd->push(qw/string1 string2/); $lwd->push('string1'); # does not trigger duplicate issues, yet $lwd->push('string1'); # does not trigger duplicate issues, yet # there we go if ( $what eq 'forbid' ) { is( $lwd->needs_check, 1, "verify needs_check is true" ); throws_ok { $lwd->fetch_all_values; } "Config::Model::Exception::WrongValue", "fails forbidden duplicates"; is( $lwd->needs_check, 0, "verify needs_check after fetch_all_values" ); throws_ok { $lwd->fetch_all_values; } "Config::Model::Exception::WrongValue", "fails forbidden duplicates even if needs_check is false"; is( $lwd->needs_check, 0, "verify again needs_check after fetch_all_values" ); $lwd->delete(2); is( $lwd->needs_check, 1, "verify needs_check after list content modif" ); } elsif ( $what eq 'warn' ) { warnings_like { $lwd->fetch_all_values; } qr/Duplicated/, "warns with duplicated values"; is( $lwd->has_fixes, 2, "check nb of fixes" ); $inst->apply_fixes; warnings_like { $lwd->fetch_all_values; }[], # no warning accepted "no longer warns with duplicated values"; } else { $lwd->check_content; } is( $lwd->fetch_with_id(0)->fetch, 'string1', "check that original values is untouched after $what duplicates" ); } $inst->clear_changes; $pl->clear; is( $inst->needs_save, 1, "verify instance needs_save status after clear array" ); eq_or_diff( [ $pl->fetch_all_indexes ], [], "check that array was cleared" ); eq_or_diff([$inst->list_changes],['plain_list: cleared all entries'],"check change message after clear"); # test preset clear stuff # done after auto_create_ids tests, because preset_clear or layered_clear # also clean up auto_create_ids (if there's no data in there) $inst->preset_start; $pl->fetch_with_id(0)->store('prefoo'); $pl->fetch_with_id(1)->store('prebar'); $inst->preset_stop; eq_or_diff( [ $pl->fetch_all_indexes ], [ 0, 1 ], "check preset indexes" ); $pl->fetch_with_id(1)->store('bar'); $inst->preset_clear; eq_or_diff( [ $pl->fetch_all_indexes ], [0], "check that only preset stuff was cleared" ); is( $pl->fetch_with_id(0)->fetch, 'bar', "check that bar was moved from 1 to 0" ); # test layered stuff $pl->clear; $inst->layered_start; $pl->fetch_with_id(0)->store('prefoo'); $pl->fetch_with_id(1)->store('prebar'); $inst->layered_stop; eq_or_diff( [ $pl->fetch_all_indexes ], [ 0, 1 ], "check layered indexes" ); $pl->fetch_with_id(1)->store('bar'); $inst->layered_clear; eq_or_diff( [ $pl->fetch_all_indexes ], [0], "check that only layered stuff was cleared" ); is( $pl->fetch_with_id(0)->fetch, 'bar', "check that bar was moved from 1 to 0" ); $pl->clear; # test notify change after implicit deletion (github #4) $pl->store_set(qw/j h g f k l/); $inst->clear_changes; @set = qw/j h g f/; $pl->store_set(@set); is( $inst->c_count, 2, "check that store smaller set triggered a change" ); $inst->clear_changes; # test sort $pl->sort; eq_or_diff( [ $pl->fetch_all_values ], [ sort @set ], "check sort result" ); is( $inst->c_count, 1, "check that sort has triggered a change" ); $pl->sort; is( $inst->c_count, 1, "check that redundant sort has not triggered a change" ); # test unshift @set = qw/j h g f/; $pl->store_set(qw/a b/); $pl->unshift(qw/1 2 3 4/); eq_or_diff( [ $pl->fetch_all_values ], [qw/1 2 3 4 a b/], "check unshift result" ); eq_or_diff( [ $pl->fetch_all_indexes ], [ ( 0 .. 5 ) ], "check that indexes are reset correctly" ); # test insert_at $pl->store_set(qw/a b/); $pl->insert_at(qw/1 d e/); eq_or_diff( [ $pl->fetch_all_values ], [qw/a d e b/], "check insert_at result" ); eq_or_diff( [ $pl->fetch_all_indexes ], [ ( 0 .. 3 ) ], "check that indexes are reset correctly" ); # test insert_before $pl->store_set(qw/foo baz/); $pl->insert_before(qw/baz bar1 bar2/); eq_or_diff( [ $pl->fetch_all_values ], [qw/foo bar1 bar2 baz/], "check insert_before result" ); $pl->insert_before( qr/z/, qw/bar3 bar4/ ); eq_or_diff( [ $pl->fetch_all_values ], [qw/foo bar1 bar2 bar3 bar4 baz/], "check insert_before with regexp result" ); # test insort my @set1 = qw/c1 e i1 j1 p1/; my @set2 = qw/a2 z2 d2 e b2 k2/; $pl->store_set(@set1); $pl->sort; $pl->insort(@set2); eq_or_diff( [ $pl->fetch_all_values ], [ sort( @set1, @set2 ) ], "check insort result" ); memory_cycle_ok( $model, "memory cycles" ); done_testing; iterator.t100644001750001750 1157412676543661 15445 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 33; use Test::Memory::Cycle; use Config::Model; use Config::Model::Value; use Log::Log4perl qw(get_logger :levels); use warnings; no warnings qw(once); use strict; use Data::Dumper; # use Config::Model::ObjTreeScanner; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; my $log = $arg =~ /l/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -r $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init($WARN); } ok( 1, "compiled" ); my @models = $model->load( Master => 't/big_model.pm' ); is_deeply( \@models, [qw/SubSlave2 SubSlave X_base_class2 X_base_class SlaveZ SlaveY Master/], "check list of model declared in t/big_model.pm (taking order into account)" ); $model->augment_config_class( name => 'Master', element => [ warn_if => { type => 'leaf', value_type => 'string', warn_if_match => { 'foo' => { fix => '$_ = uc;' } }, }, warn_unless => { type => 'leaf', value_type => 'string', warn_unless_match => { foo => { msg => '', fix => '$_ = "foo".$_;' } }, }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; Config::Model::Exception::Any->Trace(1) if $trace =~ /e/; my $step = qq! warn_if=foobar std_id:ab X=Bv - std_id:ab2 - std_id:bc X=Av - std_id:"a b" X=Av - std_id:"a b.c" X=Av - tree_macro=mXY hash_a:toto=toto_value hash_a:titi=titi_value hash_a:"ti ti"="ti ti value" ordered_hash:z=1 ordered_hash:y=2 ordered_hash:x=3 lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - my_reference="titi" warp warp2 aa2="foo bar" !; $Config::Model::Value::nowarning = 1; ok( $root->load( step => $step ), "set up data in tree" ); my @expected = ( [ '', 'lista' ], [ '', 'lista:0' ], [ 'back', 'lista:1' ], [ '', 'lista:0' ], [ 'for', 'lista' ], [ '', 'lista:0' ], [ '', 'lista:1' ], [ '', 'lista:2' ], [ '', 'lista:3' ], [ '', 'hash_a' ], [ '', 'hash_a:"ti ti"' ], [ '', 'hash_a:titi' ], [ '', 'hash_a:toto' ], [ '', 'tree_macro' ], [ '', 'a_string' ], [ 'back', 'int_v' ], [ '', 'a_string' ], [ '', 'tree_macro' ], [ '', 'hash_a:toto' ], [ 'for', 'hash_a:titi' ], [ '', 'hash_a:toto' ], [ '', 'tree_macro' ], [ '', 'a_string' ], [ '', 'int_v' ], [ 'back', 'warn_if' ], [ 'bail', 'int_v' ], ); my $steer = sub { my ( $iter, $item ) = @_; my ( $dir, $expect ) = @$item; $iter->bail_out if $dir eq 'bail'; $iter->go_forward if $dir eq 'for'; $iter->go_backward if $dir eq 'back'; return @$item; }; my $leaf_element_cb = sub { my ( $iter, $data_r, $node, $element, $index, $leaf_object ) = @_; print "test: leaf_element_cb called for ", $leaf_object->location, "\n" if $trace; my ( $dir, $expect ) = $steer->( $iter, shift @expected ); is( $leaf_object->location, $expect, "leaf_element_cb got $expect and '$dir'" ); }; my $int_cb = sub { my ( $iter, $data_r, $node, $element, $index, $leaf_object ) = @_; print "test: int_cb called for ", $leaf_object->location, "\n" if $trace; my ( $dir, $expect ) = $steer->( $iter, shift @expected ); is( $leaf_object->location, $expect, "int_cb got $expect and '$dir'" ); }; my $hash_element_cb = sub { my ( $iter, $data_r, $node, $element, @keys ) = @_; print "test: hash_element_cb called for ", $node->location, " element $element\n" if $trace; my $obj = $node->fetch_element($element); my ( $dir, $expect ) = $steer->( $iter, shift @expected ); is( $obj->location, $expect, "hash_element_cb got $expect and '$dir'" ); }; my $list_element_cb = sub { my ( $iter, $data_r, $node, $element, @idx ) = @_; print "test: list_element_cb called for ", $node->location, " element $element\n" if $trace; my $obj = $node->fetch_element($element); my ( $dir, $expect ) = $steer->( $iter, shift @expected ); is( $obj->location, $expect, "list_element_cb got $expect and '$dir'" ); }; my $iterator = $inst->iterator( leaf_cb => $leaf_element_cb, integer_value_cb => $int_cb, hash_element_cb => $hash_element_cb, list_element_cb => $list_element_cb, call_back_on_warning => 1, call_back_on_important => 1, ); ok( $iterator, "created iterator helper" ); $iterator->start; is_deeply( \@expected, [], "iterator explored all items" ); memory_cycle_ok($model); MANIFEST.SKIP100644001750001750 16512676543661 15014 0ustar00domidomi000000000000Config-Model-2.082^debian/ ~$ \.ptkdb$ \.old$ dist.ini libconfig _build \.orig$ ^MYMETA.yml$ blib wr_root \.rej$ README.build-from-git node-load.t100644001750001750 476312676543661 15440 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 13; use Test::Memory::Cycle; use Config::Model; use 5.010; use warnings; use strict; use lib 't/lib'; my $model = Config::Model->new(); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); $model->create_config_class ( name => "OverriddenNode", class => 'DummyNode', element => [ [qw/foo bar baz/ ] => { type => 'leaf', value_type => 'uniline' }, ], ) ; $model->create_config_class ( name => "PlainNode", element => [ [qw/foo/ ] => { type => 'leaf', value_type => 'uniline' }, ], ) ; my $node = { type => 'node', config_class_name => 'OverriddenNode'} ; $model->create_config_class ( name => "OverriddenRoot", class => 'DummyNode', element => [ a_node => $node, a_list => { type => 'list', cargo => $node} , a_hash => { type => 'hash', index_type => 'string', cargo => $node}, master_switch => { type => 'leaf', value_type => 'enum', choice => [qw/plain dummy/] }, 'a_warped_node' => { type => 'warped_node', follow => { ms => '! master_switch' }, rules => [ '$ms eq "plain"' => { config_class_name => 'PlainNode' }, '$ms eq "dummy"' => { config_class_name => 'OverriddenNode' }, ] }, ], ) ; my $inst = $model->instance( root_class_name => 'OverriddenRoot', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Config root created" ); $root->load('master_switch=dummy a_node foo=boo ! a_list:0 bar=far ! a_list:1 bar=far2 ! a_hash:a baz=taz'); my $hook = sub { my ($scanner, $data_ref,$node,@element_list) = @_; isa_ok( $node, 'DummyNode', "check class of ".$node->name) ; $node->dummy($$data_ref) ; }; my $count = 0; Config::Model::ObjTreeScanner->new( node_content_hook => $hook, leaf_cb => sub { } )->scan_node( \$count, $root ); is($count, 6, "check nb of dummy calls"); $root->load('master_switch=plain'); my $plain = $root->grab('a_warped_node')->get_actual_node; isa_ok( $plain, 'Config::Model::Node', "check class of warped node on plain mode") ; is($plain->can('dummy'),undef,"plain node is not a dummy"); memory_cycle_ok($model, "check memory cycles"); dump_tree.t100644001750001750 1623612676543661 15600 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Test::Differences; use Config::Model; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/dump_load_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Config root created" ); $inst->preset_start; $root->fetch_element( name => 'hidden_string', accept_hidden => 1 )->store('hidden value'); my $step = 'std_id:ab X=Bv ' . '! lista:=a,b listb:=b '; ok( $root->load( step => $step ), "preset data in tree with '$step'" ); $inst->preset_stop; $step = 'std_id:ab X=Bv - std_id:bc X=Av - std_id:"b d " X=Av ' . '- a_string="toto \"titi\" tata" another_string="foobar" a_string2=dod@foo.com ' . 'a_string_to_test_newline="foo\nbar\\\\nbaz" ' . 'lista:=a,b,c,d olist:0 X=Av - olist:1 X=Bv - listb:=b,"c c2",d listc:="dod@foo.com" ' . '! hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy my_check_list=X2,X3'; ok( $root->load( step => $step ), "set up data in tree" ); eq_or_diff( [ sort $root->fetch_element('std_id')->fetch_all_indexes ], [ 'ab', 'b d ', 'bc' ], "check std_id keys" ); eq_or_diff( [ sort $root->fetch_element('lista')->fetch_all_values( mode => 'custom' ) ], [qw/c d/], "check lista custom values" ); my $cds = $root->dump_tree; print "cds string:\n$cds" if $trace; my $orig_expect = <<'EOF' ; std_id:ab - std_id:"b d " X=Av - std_id:bc X=Av - lista:=c,d listb:="c c2",d listc:="dod@foo.com" hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy olist:0 X=Av - olist:1 X=Bv - a_string="toto \"titi\" tata" a_string2=dod@foo.com a_string_to_test_newline="foo bar\\nbaz" another_string=foobar my_check_list=X2,X3 - EOF $cds =~ s/\s+\n/\n/g; eq_or_diff( [ split /\n/, $cds ], [ split /\n/, $orig_expect ], "check dump of only customized values " ); $cds = $root->dump_tree( full_dump => 1 ); print "cds string:\n$cds" if $trace; my $expect = <<'EOF' ; std_id:ab X=Bv DX=Dv - std_id:"b d " X=Av DX=Dv - std_id:bc X=Av DX=Dv - lista:=a,b,c,d listb:=b,"c c2",d listc:="dod@foo.com" hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy olist:0 X=Av DX=Dv - olist:1 X=Bv DX=Dv - string_with_def="yada yada" a_uniline="yada yada" a_string="toto \"titi\" tata" a_string2=dod@foo.com a_string_to_test_newline="foo bar\\nbaz" another_string=foobar int_v=10 my_check_list=X2,X3 - EOF $cds =~ s/\s+\n/\n/g; eq_or_diff( [ split /\n/, $cds ], [ split /\n/, $expect ], "check dump of all values " ); my $listb = $root->fetch_element('listb'); $listb->clear; $cds = $root->dump_tree( full_dump => 1 ); print "cds string:\n$cds" if $trace; $expect = <<'EOF' ; std_id:ab X=Bv DX=Dv - std_id:"b d " X=Av DX=Dv - std_id:bc X=Av DX=Dv - lista:=a,b,c,d listc:="dod@foo.com" hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy olist:0 X=Av DX=Dv - olist:1 X=Bv DX=Dv - string_with_def="yada yada" a_uniline="yada yada" a_string="toto \"titi\" tata" a_string2=dod@foo.com a_string_to_test_newline="foo bar\\nbaz" another_string=foobar int_v=10 my_check_list=X2,X3 - EOF $cds =~ s/\s+\n/\n/g; eq_or_diff( [ split /\n/, $cds ], [ split /\n/, $expect ], "check dump of all values after listb is cleared" ); # check empty strings my $a_s = $root->fetch_element('a_string'); $a_s->store(""); $expect = <<'EOF' ; std_id:ab X=Bv DX=Dv - std_id:"b d " X=Av DX=Dv - std_id:bc X=Av DX=Dv - lista:=a,b,c,d listc:="dod@foo.com" hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy olist:0 X=Av DX=Dv - olist:1 X=Bv DX=Dv - string_with_def="yada yada" a_uniline="yada yada" a_string="" a_string2=dod@foo.com a_string_to_test_newline="foo bar\\nbaz" another_string=foobar int_v=10 my_check_list=X2,X3 - EOF $cds = $root->dump_tree( full_dump => 1 ); print "cds string:\n$cds" if $trace; $cds =~ s/\s+\n/\n/g; eq_or_diff( [ split /\n/, $cds ], [ split /\n/, $expect ], "check dump of all values after a_string is set to ''" ); # check preset values $cds = $root->dump_tree( mode => 'preset' ); print "cds string:\n$cds" if $trace; $expect = <<'EOF' ; std_id:ab X=Bv - std_id:"b d " - std_id:bc - lista:=a,b olist:0 - olist:1 - - EOF $cds =~ s/\s+\n/\n/g; eq_or_diff( [ split /\n/, $cds ], [ split /\n/, $expect ], "check dump of all preset values" ); # shake warp stuff my $tm = $root->fetch_element('tree_macro'); map { $tm->store($_); } qw/XY XZ mXY XY mXY XZ/; $cds = $root->dump_tree( full_dump => 1, skip_auto_write => 'cds_file' ); print "cds string:\n$cds" if $trace; like( $cds, qr/hidden value/, "check that hidden value is shown (macro=XZ)" ); # check that list of undef is not shown map { $listb->fetch_with_id($_)->store(undef) } ( 0 .. 3 ); $cds = $root->dump_tree( full_dump => 1 ); print "Empty listb dump:\n$cds" if $trace; unlike( $cds, qr/listb/, "check that listb containing undef values is not shown" ); # reload test my $reload_root = $model->instance( root_class_name => 'Master', instance_name => 'reload_test' )->config_root; $reload_root->load($orig_expect); my $reloaded_dump = $reload_root->dump_tree; eq_or_diff( [ split /\n/, $reloaded_dump ], [ split /\n/, $orig_expect ], "check dump of tree load with dump result" ); # annotation tests my $root2 = $model->instance( root_class_name => 'Master', instance_name => 'test2' )->config_root; $step = ' std_id:ab#std_id_ab_note X=Bv X#std_id_ab_X_note - std_id#std_id_note std_id:bc X=Av X#std_id_bc_X_note ' . '- a_string="toto \"titi\" tata" a_string#a_string_note another_string="foobar"' . 'lista#lista_note lista:=a,b,c,d lista:1#lista_1_note olist#o_list_note olist:0#olist_0_note X=Av - olist:1#olist1_c X=Bv - listb:=b,"c c2",d ' . '! hash_a:X2=x#hash_a_X2 hash_a:Y2=xy#"hash_a Y2 note" hash_b:X3=xy#hash_b_X3 my_check_list=X2,X3 plain_object#"plain comment" aa2=aa2_value'; ok( $root2->load( step => $step ), "set up data in tree annotation" ); is( $root2->fetch_element('std_id')->annotation, 'std_id_note', "check annotation for std_id" ); is( $root2->grab('std_id:ab')->annotation, 'std_id_ab_note', "check annotation for std_id:ab" ); is( $root2->grab('olist:0')->annotation, 'olist_0_note', "check annotation for olist:0" ); my $expect_count = scalar grep { /#/ } split //, $step; $cds = $root2->dump_tree( full_dump => 1 ); print "Dump with annotations:\n$cds" if $trace; is( ( scalar grep { /#/ } split //, $cds ), $expect_count, "check that $expect_count annotations are found" ); my $root3 = $model->instance( root_class_name => 'Master', instance_name => 'test3' )->config_root; ok( $root3->load( step => $cds ), "set up data in tree with dumped data+annotation" ); my $cds2 = $root3->dump_tree( full_dump => 1 ); print "Dump second instance with annotations:\n$cds2" if $trace; is( $cds2, $cds, "check both dumps" ); memory_cycle_ok( $model, "memory cycles" ); done_testing; warped_id.t100644001750001750 1612712676543661 15551 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- # $Author$ # $Date$ # $Revision$ use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More tests => 37; use Test::Memory::Cycle; use Config::Model; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => 'Slave', element => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/], } ] ); $model->create_config_class( name => 'Master', 'element' => [ macro => { type => 'leaf', value_type => 'enum', choice => [qw/A B C/], }, version => { type => 'leaf', value_type => 'integer', default => 1 }, warped_hash => { type => 'hash', index_type => 'integer', max_nb => 3, warp => { follow => '- macro', rules => { A => { max_nb => 1 }, B => { max_nb => 2 } } }, cargo_type => 'node', config_class_name => 'Slave' }, 'multi_warp' => { type => 'hash', index_type => 'integer', min => 0, max => 3, default => [ 0 .. 3 ], warp => { follow => [ '- version', '- macro' ], 'rules' => [ [ '2', 'C' ] => { max => 7, default => [ 0 .. 7 ] }, [ '2', 'A' ] => { max => 7, default => [ 0 .. 7 ] } ] }, cargo_type => 'node', config_class_name => 'Slave' }, # how to properly hide bar when macro != A ??? 'hash_with_warped_value' => { type => 'hash', index_type => 'string', cargo_type => 'leaf', level => 'hidden', # must also accept level and description here warp => { follow => '- macro', 'rules' => { 'A' => { level => 'advanced', }, } }, cargo_args => { value_type => 'string', warp => { follow => '- macro', 'rules' => { 'A' => { default => 'dumb string' }, } } } }, 'multi_auto_create' => { type => 'hash', index_type => 'integer', min => 0, max => 3, auto_create => [ 0 .. 3 ], 'warp' => { follow => [ '- version', '- macro' ], 'rules' => [ [ '2', 'C' ] => { max => 7, auto_create_keys => [ 0 .. 7 ] }, [ '2', 'A' ] => { max => 7, auto_create_keys => [ 0 .. 7 ] } ], }, cargo_type => 'node', config_class_name => 'Slave' }, ] ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $macro = $root->fetch_element('macro'); is( $root->is_element_available('hash_with_warped_value'), 0, "check warped out hash_with_warped_value (macro is undef)" ); is( $macro->store('A'), 1, "Set macro to A" ); is( $macro->fetch(), 'A', "Check macro" ); is( $root->is_element_available('hash_with_warped_value'), 1, "check warped out hash_with_warped_value (macro is A)" ); my $warped_hash = $root->fetch_element('warped_hash'); ok( $warped_hash->fetch_with_id('1'), "Set one slave" ); my $res = eval { $warped_hash->fetch_with_id('2'); }; ok( $@, "Set second slave (normal error)" ); print "normal error:", $@, "\n" if $trace; is( $macro->store('B'), 1, "Set macro to B" ); ok( $warped_hash->fetch_with_id('2'), "Set second slave" ); $res = eval { $warped_hash->fetch_with_id('3'); }; ok( $@, "Set third slave (normal error)" ); print "normal error:", $@, "\n" if $trace; is( $macro->store('C'), 1, "Set macro to C (warp_reset)" ); ok( $warped_hash->fetch_with_id('3'), "Set third slave" ); $res = eval { $warped_hash->fetch_with_id('4'); }; ok( $@, "Set fourth slave (normal error)" ); print "normal error:", $@, "\n" if $trace; eval { $macro->store('B'); }; ok( $@, "Set macro to B: limit max to 2 when the hash has id '3'" ); print "normal error:", $@, "\n" if $trace; # so remove one item $warped_hash->delete('3'); # and retry is( $macro->store('B'), 1, "Set macro to B (limit max to 2)" ); is_deeply( [ $warped_hash->fetch_all_indexes ], [qw/1 2/], "check reduced key set" ); my $multi_warp = $root->fetch_element('multi_warp'); is( $multi_warp->max_index, 3, "check multi_warp default max_index" ); my $multi_auto_create = $root->fetch_element('multi_auto_create'); is( $multi_auto_create->max_index, 3, "check multi_auto_create default max_index" ); is( $root->fetch_element('version')->store(2), 1, 'set version to 2' ); is( $macro->store('C'), 1, 'set macro to C' ); is_deeply( $multi_warp->default_keys, [ 0 .. 7 ], "check multi_warp default_keys index parameter" ); is_deeply( [ sort $multi_warp->fetch_all_indexes ], [ 0 .. 7 ], "check multi_warp default key set with different warp master" ); is( $multi_warp->fetch_with_id('5')->fetch_element('X')->store('Av'), 1, "store Av in X" ); $root->load( step => 'multi_warp:5 X=Av' ); is( $root->grab_value('multi_warp:5 X'), 'Av', 'check X value' ); is( $multi_warp->max_index, 7, "check multi_warp warped_hash max_index" ); is_deeply( [ sort $multi_auto_create->fetch_all_indexes ], [ 0 .. 7 ], "check multi_auto_create default key set with different warp master" ); $root->load( step => 'multi_auto_create:5 X=Av' ); is( $root->grab_value('multi_auto_create:5 X'), 'Av', "check X value" ); is( $multi_auto_create->max_index, 7, "check multi_auto_create warped_hash max_index" ); # remove one item to avoid error when setting macro to A $warped_hash->delete('2'); is( $root->is_element_available('hash_with_warped_value'), 0, "check warped out hash_with_warped_value (macro is C)" ); ok( $macro->store('A'), "assign new value to warp master (same effect)" ); is( $root->grab_value('multi_warp:5 X'), 'Av', "check X value after assign" ); is( $root->is_element_available('hash_with_warped_value'), 1, "check warped out hash_with_warped_value (macro is A)" ); is( $root->grab_value('hash_with_warped_value:5'), 'dumb string', "check hash_with_warped_value:5" ); is( $root->grab_value('hash_with_warped_value:6'), 'dumb string', "check hash_with_warped_value:6" ); memory_cycle_ok($model); apply_fix.t100644001750001750 472312676543661 15565 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Memory::Cycle; use Config::Model; use Config::Model::Value; use Data::Dumper; use Log::Log4perl qw(:easy); BEGIN { plan tests => 9; } use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } ok( 1, "Compilation done" ); $Config::Model::Value::nowarning = 1 unless $trace; # minimal set up to get things working my $model = Config::Model->new(); $model->create_config_class( name => "NodeFix", element => [ 'fix-gnu' => { type => 'leaf', value_type => 'uniline', 'warn_if_match' => { 'Debian GNU/Linux' => { 'msg' => 'deprecated in favor of Debian GNU', 'fix' => 's!Debian GNU/Linux!Debian GNU!g;' }, }, }, 'fix-long' => { type => 'leaf', value_type => 'uniline', 'warn_if_match' => { '[^\\n]{10,}' => { 'msg' => 'Line too long', 'fix' => '$_ = substr $_,0,8;' }, }, } ] ); $model->create_config_class( name => "Master", element => [ [ map { "my_broken_node_$_" } (qw/a b c/) ] => { type => 'node', config_class_name => 'NodeFix', } ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; foreach my $w (qw/a b c/) { $root->load( qq!my_broken_node_$w fix-gnu="Debian GNU/Linux for $w" fix-long="$w is way too long"!); } print $root->dump_tree if $trace; $root->apply_fixes('long'); map { is( $root->grab_value("my_broken_node_$_ fix-long"), "$_ is way", "check that $_ long stuff was fixed" ); is( $root->grab_value("my_broken_node_$_ fix-gnu"), "Debian GNU/Linux for $_", "check that $_ gnu stuff was NOT fixed" ); } qw/a b c/; print $root->dump_tree if $trace; memory_cycle_ok($model); simple_ui.t100644001750001750 550412676543661 15556 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 27; use Test::Memory::Cycle; use Config::Model; use Config::Model::SimpleUI; use warnings; no warnings qw(once); use strict; use Data::Dumper; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); note("you can run the test in interactive mode by passing 'i' argument, i.e. perl -Ilib t/simple_ui.t i"); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata"'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); # this test test only execution of user command, not their actual # input my $prompt = 'Test Prompt'; my $ui = Config::Model::SimpleUI->new( root => $root, title => 'Test Title', prompt => $prompt, ); my $expected_prompt = $prompt . ':$ '; ok( $ui, "Created ui" ); if ($arg =~ /i/) { $ui->run_loop; exit; } my $path = $ui->list_cd_path; is_deeply( $path, [ qw/std_id:ab std_id:bc tree_macro warp slave_y string_with_def a_uniline a_string int_v my_check_list my_reference/ ], 'check list cd path at root' ); is( $ui->prompt, $expected_prompt, 'test prompt at root' ); my @test = ( [ 'vf std_id:ab', "Unexpected command 'vf'", $expected_prompt ], [ 'ls', 'std_id lista listb hash_a hash_b ordered_hash olist tree_macro warp slave_y string_with_def a_uniline a_string int_v my_check_list my_reference', $expected_prompt ], [ 'ls hash*', 'hash_a hash_b', $expected_prompt], [ 'll hash*', "name value type comment \n" ."hash_a [empty hash] value hash \n" ."hash_b [empty hash] value hash \n", $expected_prompt ], [ 'set a_string="some value with space"', "", $expected_prompt ], [ 'cd std_id:ab', "", $prompt . ': std_id:ab $ ' ], [ 'set X=Av', "", $prompt . ': std_id:ab $ ' ], [ 'display X', "Av", $prompt . ': std_id:ab $ ' ], [ 'cd !', "", $expected_prompt ], [ 'delete std_id:ab', "", $expected_prompt ], ); foreach my $a_test (@test) { my ( $cmd, $expect, $expect_prompt ) = @$a_test; my $res = $ui->run($cmd); $res =~ s/ +/ /g; is($res , $expect, "exec $cmd" ); is( $ui->prompt, $expect_prompt, "test prompt is $expect_prompt" ); } memory_cycle_ok($model); annotation.t100644001750001750 710612676543661 15742 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 19; use Test::Memory::Cycle; use Config::Model; use Config::Model::Annotation; use File::Path; use Data::Dumper; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; # pseudo root where config files are written by config-model my $wr_root = 'wr_root/'; # cleanup before tests rmtree($wr_root); mkpath( $wr_root, { mode => 0755 } ); use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', root_dir => $wr_root, instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Config root created" ); # use Tk::ObjScanner; Tk::ObjScanner::scan_object($model) ; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata" ' . 'lista=a,b,c,d olist:0 X=Av - olist:1#olist1_comment X=Bv - listb=b,c,d ' . '! hash_a:X2=x hash_a:Y2=xy hash_a:toto#"index comment" hash_b:X3=xy my_check_list=X2,X3'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); my @annotate = map { [ $_ => "$_ annotation" ] } ( 'std_id', 'std_id:bc X', 'my_check_list', 'olist:0', 'olist:2' ); my %expect = ( 'hash_a:toto' => "index comment", 'olist:1' => 'olist1_comment' ); foreach (@annotate) { my ( $l, $a ) = @$_; $expect{$l} = $a; $root->grab($l)->annotation($a); ok( 1, "set annotation of $l" ); } is( $root->grab("std_id:ab X")->annotation('to delete'), 'to delete', "test clear annotation" ); is( $root->grab("std_id:ab X")->clear_annotation, '', "test clear annotation" ); my $annotate_saver = Config::Model::Annotation->new( config_class_name => 'Master', instance => $inst, root_dir => $wr_root, ); ok( $annotate_saver, "created annotation read/write object" ); my $yaml_dir = $annotate_saver->dir; is( $yaml_dir, 'wr_root/config-model/', "check saved dir" ); my $yaml_file = $annotate_saver->file; is( $yaml_file, 'wr_root/config-model/Master-note.pl', "check saved file" ); my $h_ref = $annotate_saver->get_annotation_hash(); print Dumper ($h_ref) if $trace; is_deeply( $h_ref, \%expect, "check annotation data" ); $annotate_saver->save; ok( -e $yaml_file, "check annotation file exists" ); my $inst2 = $model->instance( root_class_name => 'Master', root_dir => $wr_root, instance_name => 'test2' ); my $root2 = $inst2->config_root; my $saver2 = Config::Model::Annotation->new( config_class_name => 'Master', instance => $inst2, root_dir => $wr_root, ); $saver2->load; my $h2_ref = $saver2->get_annotation_hash(); #use Data::Dumper ; print Dumper ( $h_ref ) ; print Dumper ($h2_ref) if $trace; my %expect2 = %expect; # delete annotations loaded on missing elements delete $expect2{'std_id:bc X'}; delete $expect2{'hash_a:toto'}; delete $expect2{'olist:0'}; delete $expect2{'olist:1'}; delete $expect2{'olist:2'}; is_deeply( $h2_ref, \%expect2, "check loaded annotation data with empty tree" ); $root2->load( step => $step ); $saver2->load; my %expect3 = %expect; # delete annotations loaded on missing elements delete $expect3{'olist:2'}; my $h3_ref = $saver2->get_annotation_hash(); print Dumper ($h3_ref) if $trace; is_deeply( $h3_ref, \%expect3, "check loaded annotation data with non-empty tree" ); memory_cycle_ok($model); big_model.pm100644001750001750 1476312676543661 15711 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- # # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # this file is used by test script [ [ name => 'SubSlave2', element => [ [qw/aa2 ab2 ac2 ad2 Z/] => { type => 'leaf', value_type => 'string' } ], description => [ Z => 'Z comme zorro' ], ], [ name => 'SubSlave', element => [ [qw/aa ab ac ad/] => { type => 'leaf', value_type => 'string' }, sub_slave => { type => 'node', config_class_name => 'SubSlave2', } ] ], [ name => 'X_base_class2', element => [ X => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ], class_description => 'rather dummy class to check include feature', ], [ name => 'X_base_class', include => 'X_base_class2', ], [ name => 'SlaveZ', element => [ [qw/Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, [qw/DX/] => { type => 'leaf', value_type => 'enum', default => 'Dv', choice => [qw/Av Bv Cv Dv/] }, ], include => 'X_base_class', include_after => 'Z', ], [ name => 'SlaveY', element => [ std_id => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'SlaveZ', }, sub_slave => { type => 'node', config_class_name => 'SubSlave', }, warp2 => { type => 'warped_node', follow => '! tree_macro', config_class_name => 'SubSlave', morph => 1, rules => [ mXY => { config_class_name => 'SubSlave2' }, XZ => { config_class_name => 'SubSlave2' } ] }, Y => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ], include => 'X_base_class', ], [ name => 'Master', class_description => "Master configuration class is a wonderful test class\n" . "widely used in Config::Model self tests", copyright => ["2005-2011, Dominique Dumont"], license => 'LGPL-2', author => 'Dominique Dumont', level => [ [qw/lista hash_a tree_macro int_v/] => 'important' ], element => [ std_id => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'SlaveZ', }, [qw/lista listb/] => { type => 'list', cargo_type => 'leaf', cargo_args => { value_type => 'string' }, }, [qw/hash_a hash_b/] => { type => 'hash', index_type => 'string', cargo_type => 'leaf', cargo_args => { value_type => 'string' }, }, ordered_hash => { type => 'hash', index_type => 'string', ordered => 1, cargo_type => 'leaf', cargo_args => { value_type => 'string' }, }, olist => { type => 'list', cargo_type => 'node', config_class_name => 'SlaveZ', }, tree_macro => { type => 'leaf', value_type => 'enum', choice => [qw/XY XZ mXY/], help => { XY => 'XY help', XZ => 'XZ help', mXY => 'mXY help', } }, warp => { type => 'warped_node', follow => '! tree_macro', config_class_name => 'SlaveY', morph => 1, rules => [ #XY => { config_class_name => 'SlaveY'}, mXY => { config_class_name => 'SlaveY' }, XZ => { config_class_name => 'SlaveZ' } ] }, 'slave_y' => { type => 'node', config_class_name => 'SlaveY', }, string_with_def => { type => 'leaf', value_type => 'string', default => 'yada yada' }, a_uniline => { type => 'leaf', value_type => 'uniline', default => 'yada yada' }, a_string => { type => 'leaf', mandatory => 1, value_type => 'string' }, hidden_string => { type => 'leaf', level => 'hidden', value_type => 'string', warp => { follow => '! tree_macro', rules => { XZ => { level => 'normal', } } }, }, int_v => { type => 'leaf', value_type => 'integer', default => '10', min => 5, max => 15 }, my_check_list => { type => 'check_list', refer_to => '- hash_a + ! hash_b', }, my_reference => { type => 'leaf', value_type => 'reference', refer_to => '- hash_a + ! hash_b', } ], description => [ tree_macro => 'controls behavior of other elements', hidden_string => 'shy text', ] ], ]; # do not put 1; at the end or Model-> load will not work check_list.t100644001750001750 4245412676543661 15725 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Data::Dumper; use Log::Log4perl qw(:easy :levels); use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new(); $model->create_config_class( name => "Master", element => [ [qw/my_hash my_hash2 my_hash3/] => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string' }, }, choice_list => { type => 'check_list', choice => [ 'A' .. 'Z' ], help => { A => 'A help', E => 'E help' }, }, ordered_checklist => { type => 'check_list', choice => [ 'A' .. 'Z' ], ordered => 1, help => { A => 'A help', E => 'E help' }, }, ordered_checklist_refer_to => { type => 'check_list', refer_to => '- ordered_checklist', ordered => 1, }, choice_list_with_default => { type => 'check_list', choice => [ 'A' .. 'Z' ], default_list => [ 'A', 'D' ], help => { A => 'A help', E => 'E help' }, }, choice_list_with_upstream_default => { type => 'check_list', choice => [ 'A' .. 'Z' ], upstream_default_list => [ 'A', 'D' ], help => { A => 'A help', E => 'E help' }, }, choice_list_with_default_and_upstream_default => { type => 'check_list', choice => [ 'A' .. 'Z' ], default_list => [ 'A', 'C' ], upstream_default_list => [ 'A', 'D' ], help => { A => 'A help', E => 'E help' }, }, macro => { type => 'leaf', value_type => 'enum', choice => [qw/AD AH AZ/], }, 'warped_choice_list' => { type => 'check_list', level => 'hidden', warp => { follow => '- macro', rules => { AD => { choice => [ 'A' .. 'D' ], level => 'normal', default_list => [ 'A', 'B' ] }, AH => { choice => [ 'A' .. 'H' ], level => 'normal', }, } } }, refer_to_list => { type => 'check_list', refer_to => '- my_hash' }, warped_refer_to_list => { type => 'check_list', refer_to => '- warped_choice_list', level => 'hidden', warp => { follow => '- macro', rules => { AD => { choice => [ 'A' .. 'D' ], level => 'normal', }, }, }, }, refer_to_2_list => { type => 'check_list', refer_to => '- my_hash + - my_hash2 + - my_hash3' }, 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/], }, indirection => { type => 'leaf', value_type => 'string' }, dumb_list => { type => 'list', cargo => { type => 'leaf', value_type => 'string' } }, refer_to_dumb_list => { type => 'check_list', refer_to => '- dumb_list + - my_hash', }, 'Ciphers', { 'ordered' => '1', 'upstream_default_list' => [ '3des-cbc', 'aes128-cbc', 'aes128-ctr', 'aes192-cbc', 'aes192-ctr', 'aes256-cbc', 'aes256-ctr', 'arcfour', 'arcfour128', 'arcfour256', 'blowfish-cbc', 'cast128-cbc' ], 'type' => 'check_list', 'description' => 'Specifies the ciphers allowed for protocol version 2 in order of preference. By default, all ciphers are allowed.', 'choice' => [ 'aes128-cbc', '3des-cbc', 'blowfish-cbc', 'cast128-cbc', 'arcfour128', 'arcfour256', 'arcfour', 'aes192-cbc', 'aes256-cbc', 'aes128-ctr', 'aes192-ctr', 'aes256-ctr' ] }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); $inst->initial_load_stop; my $root = $inst->config_root; my $cl = $root->fetch_element('choice_list'); # check get_choice is_deeply( [ $cl->get_choice ], [ 'A' .. 'Z' ], "check_get_choice" ); is( $inst->needs_save, 0, "verify instance needs_save status after creation" ); ok( 1, "test get_checked_list for empty check_list" ); my @got = $cl->get_checked_list; is( scalar @got, 0, "test nb of elt in check_list " ); is_deeply( \@got, [], "test get_checked_list after set_checked_list" ); my %expect; my $hr = $cl->get_checked_list_as_hash; is_deeply( $hr, \%expect, "test get_checked_list_as_hash for empty checklist" ); # check help is( $cl->get_help('A'), 'A help', "test help" ); is( $inst->needs_save, 0, "verify instance needs_save status after reading meta data" ); # test with the polymorphic 'set' method $cl->set( '', 'A,Z,Y,B' ); ok( 1, "test set method" ); @got = $cl->get_checked_list; is( scalar @got, 4, "test nb of elt in check_list after set" ); is_deeply( \@got, [qw/A B Y Z/], "test get_checked_list after set" ); is( $inst->needs_save, 1, "verify instance needs_save after set" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; $inst->clear_changes; my @set = sort qw/A C Z V Y/; $cl->set_checked_list(@set); ok( 1, "test set_checked_list" ); @got = $cl->get_checked_list; is( scalar @got, 5, "test nb of elt in check_list after set_checked_list" ); is_deeply( \@got, \@set, "test get_checked_list after set_checked_list" ); is( $inst->needs_save, 1, "verify instance needs_save after set_checked_list" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; $inst->clear_changes; # test global get and set as hash $hr = $cl->get_checked_list_as_hash; map { $expect{$_} = 0 } ( 'A' .. 'Z' ); map { $expect{$_} = 1 } @set; eq_or_diff( $hr, \%expect, "test get_checked_list_as_hash" ); $expect{V} = 0; $expect{W} = 1; $cl->set_checked_list_as_hash(%expect); ok( 1, "test set_checked_list_as_hash" ); @got = sort $cl->get_checked_list; is_deeply( \@got, [ sort qw/A C Z W Y/ ], "test get_checked_list after set_checked_list_as_hash" ); $cl->clear; # test global get and set @got = $cl->get_checked_list; is( scalar @got, 0, "test nb of elt in check_list after clear" ); eval { $cl->check('a'); }; ok( $@, "check 'a': which is an error" ); print "normal error:\n", $@, "\n" if $trace; # test layered choice_list $inst->layered_start; my @l_set = qw/B M W/; $cl->set_checked_list(@l_set); $inst->layered_stop; eq_or_diff( [ $cl->get_checked_list( mode => 'layered' ) ], \@l_set, "check layered content" ); eq_or_diff( [ $cl->get_checked_list( mode => 'standard' ) ], \@l_set, "check standard content" ); eq_or_diff( [ $cl->get_checked_list() ], [], "check user content" ); $cl->set_checked_list_as_hash( V => 1, W => 1 ); eq_or_diff( [ $cl->get_checked_list( mode => 'layered' ) ], \@l_set, "check layered content" ); eq_or_diff( [ $cl->get_checked_list( mode => 'standard' ) ], \@l_set, "check standard content" ); eq_or_diff( [ $cl->get_checked_list( mode => 'user' ) ], [qw/B M V W/], "check user content" ); eq_or_diff( [ $cl->get_checked_list() ], [qw/V W/], "check content" ); $cl->clear_layered; eq_or_diff( [ $cl->get_checked_list( mode => 'layered' ) ], [], "check layered content after clear" ); # now test with a refer_to parameter $root->load("my_hash:X=x my_hash:Y=y"); ok( 1, "load my_hash:X=x my_hash:Y=y worked correctly" ); my $rflist = $root->fetch_element('refer_to_list'); ok( $rflist, "created refer_to_list" ); is_deeply( [ $rflist->get_choice ], [qw/X Y/], 'check simple refer choices' ); $root->load("my_hash:Z=z"); ok( 1, "load my_hash:Z=z worked correctly" ); is_deeply( [ $rflist->get_choice ], [qw/X Y Z/], 'check simple refer choices after 2nd load' ); # load hashes that are used by reference check list $root->load("my_hash2:X2=x my_hash2:X=xy"); my $rf2list = $root->fetch_element('refer_to_2_list'); ok( $rf2list, "created refer_to_2_list" ); is_deeply( [ sort $rf2list->get_choice ], [qw/X X2 Y Z/], 'check refer_to_2_list choices' ); $root->load("my_hash3:Y2=y"); is_deeply( [ sort $rf2list->get_choice ], [qw/X X2 Y Y2 Z/], 'check refer_to_2_list choices' ); my $rtclac = $root->fetch_element('refer_to_check_list_and_choice'); ok( $rtclac, "created refer_to_check_list_and_choice" ); is_deeply( [ sort $rtclac->get_choice ], [qw/A1 A2 A3/], 'check refer_to_check_list_and_choice choices' ); eval { $rtclac->check('X'); }; ok( $@, "get_choice with undef 'indirection' parm: which is an error" ); print "normal error:\n", $@, "\n" if $trace; $root->fetch_element('indirection')->store('my_hash'); is_deeply( [ sort $rtclac->get_choice ], [qw/A1 A2 A3 X Y Z/], 'check refer_to_check_list_and_choice choices with indirection set' ); $rf2list->check('X2'); is_deeply( [ sort $rtclac->get_choice ], [ sort qw/A1 A2 A3 X X2 Y Z/ ], 'check X2 and test choices' ); # load hashes that are used by reference check list $root->load("my_hash2:X3=x"); $rf2list->check( 'X3', 'Y2' ); is_deeply( [ sort $rf2list->get_choice ], [qw/X X2 X3 Y Y2 Z/], 'check refer_to_2_list choices with X3' ); is_deeply( [ sort $rtclac->get_choice ], [qw/A1 A2 A3 X X2 X3 Y Y2 Z/], 'check refer_to_check_list_and_choice choices' ); my $dflist = $root->fetch_element('choice_list_with_default'); ok( $dflist, "created choice_list_with_default" ); @got = $dflist->get_checked_list; is_deeply( \@got, [ 'A', 'D' ], "test default of choice_list_with_default" ); $dflist->check('C'); $dflist->uncheck('D'); @got = $dflist->get_checked_list; is_deeply( \@got, [ 'A', 'C' ], "test default of choice_list_with_default" ); @got = $dflist->get_checked_list('custom'); is_deeply( \@got, ['C'], "test custom of choice_list_with_default" ); @got = $dflist->get_checked_list('standard'); is_deeply( \@got, [ 'A', 'D' ], "test standard of choice_list_with_default" ); my $warp_list; eval { $warp_list = $root->fetch_element('warped_choice_list'); }; ok( $@, "fetch_element without warp set (macro=undef): which is an error" ); print "normal error:\n", $@, "\n" if $trace; # force read of hidden element $warp_list = $root->fetch_element( name => 'warped_choice_list', accept_hidden => 1 ); ok( $warp_list, "created warped_choice_list" ); eval { $warp_list->get_choice; }; ok( $@, "get_choice without warp set (macro=undef): which is an error" ); print "normal error:\n", $@, "\n" if $trace; $root->load("macro=AD"); is_deeply( [ $warp_list->get_choice ], [ 'A' .. 'D' ], 'check warp_list choice after setting macro=AD' ); @got = $warp_list->get_checked_list; is_deeply( \@got, [ 'A', 'B' ], "test default of warped_choice_list" ); $root->load("macro=AH"); is_deeply( [ $warp_list->get_choice ], [ 'A' .. 'H' ], 'check warp_list choice after setting macro=AH' ); @got = $warp_list->get_checked_list; is_deeply( \@got, [], "test default of warped_choice_list after setting macro=AH" ); # test reference to list values $root->load("dumb_list=a,b,c,d,e"); my $rtl = $root->fetch_element("refer_to_dumb_list"); is_deeply( [ $rtl->get_choice ], [qw/X Y Z a b c d e/], "check choice of refer_to_dumb_list" ); # test check list with built_in default my $wud = $root->fetch_element("choice_list_with_upstream_default"); @got = $wud->get_checked_list(); is_deeply( \@got, [], "test default of choice_list_with_upstream_default" ); @got = $wud->get_checked_list('upstream_default'); is_deeply( \@got, [qw/A D/], "test upstream_default of choice_list_with_upstream_default" ); # test check list with upstream_default *and* default (should override) $inst->clear_changes; my $wudad = $root->fetch_element("choice_list_with_default_and_upstream_default"); is( $inst->needs_save, 0, "check needs_save after reading a default value" ); @got = $wudad->get_checked_list('default'); is_deeply( \@got, [qw/A C/], "test default of choice_list_with_default_and_upstream_default" ); is( $inst->needs_save, 0, "check needs_save after reading a default value" ); @got = $wudad->get_checked_list(); is_deeply( \@got, [qw/A C/], "test choice_list_with_default_and_upstream_default" ); is( $inst->needs_save, 1, "check needs_save after reading a default value" ); is_deeply( $wudad->fetch(), 'A,C', "test fetch choice_list_with_default_and_upstream_default" ); is( $inst->needs_save, 1, "check needs_save after reading a default value" ); ### test preset feature my $pinst = $model->instance( root_class_name => 'Master', instance_name => 'preset_test' ); ok( $pinst, "created dummy preset instance" ); my $p_root = $pinst->config_root; $pinst->preset_start; ok( $pinst->preset, "instance in preset mode" ); my $p_cl = $p_root->fetch_element('choice_list'); $p_cl->set_checked_list(qw/H C L/); # acid burn test :-) $pinst->preset_stop; is( $pinst->preset, 0, "instance in normal mode" ); is( $p_cl->fetch, "C,H,L", "choice_list: read preset list" ); $p_cl->check(qw/A S H/); is( $p_cl->fetch, "A,C,H,L,S", "choice_list: read completed preset LIST" ); is( $p_cl->fetch('preset'), "C,H,L", "choice_list: read preset value as preset_value" ); is( $p_cl->fetch('standard'), "C,H,L", "choice_list: read preset value as standard_value" ); is( $p_cl->fetch('custom'), "A,C,H,L,S", "choice_list: read custom_value" ); $p_cl->set_checked_list(qw/A S H E/); is( $p_cl->fetch, "A,E,H,S", "choice_list: read overridden preset LIST" ); is( $p_cl->fetch('custom'), "A,E,H,S", "choice_list: read custom_value after override" ); my $wrtl = $p_root->fetch_element( name => 'warped_refer_to_list', accept_hidden => 1 ); ok( $wrtl, "created warped_refer_to_list (hidden)" ); my $ocl = $root->fetch_element('ordered_checklist'); @got = $ocl->get_checked_list(); is_deeply( \@got, [], "test default of ordered_checklist" ); @set = qw/A C Z V Y/; $ocl->set_checked_list(@set); @got = $ocl->get_checked_list; is_deeply( \@got, \@set, "test ordered_checklist after set_checked_list" ); $ocl->swap(qw/A Y/); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y C Z V A/], "test ordered_checklist after swap" ); $ocl->move_up(qw/Y/); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y C Z V A/], "test ordered_checklist after move_up Y" ); $ocl->move_up(qw/V/); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y C V Z A/], "test ordered_checklist after move_up V" ); $ocl->move_down(qw/A/); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y C V Z A/], "test ordered_checklist after move_down A" ); $ocl->move_down(qw/C/); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y V C Z A/], "test ordered_checklist after move_down C" ); $ocl->check('B'); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y V C Z A B/], "test ordered_checklist after check B" ); $ocl->move_up(qw/B/); $ocl->uncheck('B'); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y V C Z A/], "test ordered_checklist after move_up B uncheck B" ); $ocl->check('B'); @got = $ocl->get_checked_list; is_deeply( \@got, [qw/Y V C Z B A/], "test ordered_checklist after check B" ); is( $root->grab_value( $ocl->location ), "Y,V,C,Z,B,A", "test grab_value" ); my $oclrt = $root->fetch_element('ordered_checklist_refer_to'); @got = $oclrt->get_choice(); is_deeply( \@got, [qw/Y V C Z B A/], "test default of ordered_checklist_refer_to" ); my $ciphers = $root->fetch_element('Ciphers'); my @cipher_list = qw/aes192-cbc aes128-cbc 3des-cbc blowfish-cbc aes256-cbc/; $ciphers->set_checked_list(@cipher_list); eq_or_diff( [ $ciphers->get_checked_list ], \@cipher_list, "check cipher list" ); # test warp in layered mode my $layered_i = $model->instance( root_class_name => 'Master', instance_name => 'test_layered' ); ok( $layered_i, "created layered instance" ); my $l_root = $layered_i->config_root; $layered_i->layered_start; my $locl = $l_root->fetch_element('ordered_checklist'); $locl->set_checked_list(@set); my $loclrt = $root->fetch_element('ordered_checklist_refer_to'); @got = $loclrt->get_choice(); is_deeply( \@got, [qw/Y V C Z B A/], "test default of ordered_checklist_refer_to in layered mode" ); $inst->apply_fixes; ok( 1, "apply_fixes works" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; memory_cycle_ok( $model, "memory cycle" ); done_testing; backend_mgr.t100644001750001750 3273512676543661 16052 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use File::Path; use File::Copy; use Test::Warn; use Test::Exception; use Test::File::Contents; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new(); my $arg = shift || ''; my $log = 0; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init($ERROR); } ok( 1, "compiled" ); # pseudo root for config files my $wr_root = 'wr_root'; my $root1 = "$wr_root/test1/"; my $root2 = "$wr_root/test2/"; my $root3 = "$wr_root/test3/"; my $conf_dir = '/etc/test/'; # cleanup before tests rmtree($wr_root); # model declaration $model->create_config_class( name => 'Level2', element => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] } ] ); $model->create_config_class( name => 'Level1', # try first to read with cds string and then custom class read_config => [ { backend => 'cds_file', config_dir => $conf_dir }, { backend => 'custom', config_dir => $conf_dir, class => 'Level1Read', function => 'read_it' } ], write_config => [ { backend => 'cds_file', config_dir => $conf_dir }, { backend => 'perl_file', config_dir => $conf_dir, auto_create => 1 }, { backend => 'ini_file', config_dir => $conf_dir } ], element => [ bar => { type => 'node', config_class_name => 'Level2', } ] ); $model->create_config_class( name => 'SameReadWriteSpec', # try first to read with cds string and then custom class read_config => [ { backend => 'cds_file', config_dir => $conf_dir }, { backend => 'custom', class => 'SameRWSpec', config_dir => $conf_dir }, { backend => 'ini_file', config_dir => $conf_dir, auto_create => 1 } ], element => [ bar => { type => 'node', config_class_name => 'Level2', } ] ); $model->create_config_class( name => 'Master', read_config => [ { backend => 'cds_file', config_dir => $conf_dir }, { backend => 'perl_file', config_dir => $conf_dir }, { backend => 'ini_file', config_dir => $conf_dir }, { backend => 'custom', class => 'MasterRead', config_dir => $conf_dir, function => 'read_it' } ], write_config => [ { backend => 'cds_file', config_dir => $conf_dir }, { backend => 'perl_file', config_dir => $conf_dir }, { backend => 'ini_file', config_dir => $conf_dir }, { class => 'MasterRead', function => 'wr_stuff', config_dir => $conf_dir, auto_create => 1 } ], element => [ aa => { type => 'leaf', value_type => 'string' }, level1 => { type => 'node', config_class_name => 'Level1', }, samerw => { type => 'node', config_class_name => 'SameReadWriteSpec', }, ] ); $model->create_config_class( name => 'FromScratch', read_config => [ { backend => 'cds_file', config_dir => $conf_dir, auto_create => 1 }, ], element => [ aa => { type => 'leaf', value_type => 'string' }, ] ); $model->create_config_class( name => 'CdsWithFile', read_config => [ { backend => 'cds_file', config_dir => $conf_dir, file => 'scratch_inst.cds' }, ], element => [ aa => { type => 'leaf', value_type => 'string' }, ] ); $model->create_config_class( name => 'CdsWithNoFile', read_config => [ { backend => 'cds_file' }, ], element => [ aa => { type => 'leaf', value_type => 'string' }, ] ); $model->create_config_class( name => 'SimpleRW', read_config => [ { backend => 'custom', config_dir => $conf_dir, class => 'SimpleRW', file => 'toto.conf' }, ], element => [ aa => { type => 'leaf', value_type => 'string' }, ] ); #global variable to snoop on read config action my %result; package MasterRead; my $custom_aa = 'aa was set (custom mode)'; sub read_it { my %args = @_; $result{master_read} = $args{config_dir}; $args{object}->store_element_value( 'aa', $custom_aa ); } sub wr_stuff { my %args = @_; $result{wr_stuff} = $args{config_dir}; $result{wr_root_name} = $args{object}->name; } package Level1Read; sub read_it { my %args = @_; $result{level1_read} = $args{config_dir}; $args{object}->load('bar X=Cv'); } package SameRWSpec; sub read { my %args = @_; $result{same_rw_read} = $args{config_dir}; $args{object}->load('bar Y=Cv'); } sub write { my %args = @_; $result{same_rw_write} = $args{config_dir}; } package SimpleRW; sub read { my %args = @_; $result{simple_rw}{rfile} = $args{file_path}; my $io = $args{io_handle}; return 0 unless defined $io; $args{object}->load( $io->getlines ); return 1; } sub write { my %args = @_; $result{simple_rw}{wfile} = $args{file_path}; my $io = $args{io_handle}; return 0 unless defined $io; my $dump = $args{object}->dump_tree(); $io->print($dump); } package main; my $i_fail = $model->instance( instance_name => 'failed_inst', root_class_name => 'Master', root_dir => $root1, backend => 'perl_file', ); throws_ok { $i_fail->config_root->init; } qr/failed_inst.pl/, "read with forced perl_file backend fails (normal: no perl file)"; my $i_no_read = $model->instance( instance_name => 'no_read_inst', root_class_name => 'Master', root_dir => $root1, skip_read => 1, ); ok( $i_no_read, "Created instance (from scratch without read)-> no warning" ); # check that conf dir was NOT read when instance was created is( $result{master_read}, undef, "Master read conf dir" ); my $i_zero = $model->instance( instance_name => 'zero_inst', root_class_name => 'Master', root_dir => $root1, ); ok( $i_zero, "Created instance (from scratch)" ); my $master = $i_zero->config_root; ok( $master, "Master node created" ); $master->init; # check that conf dir was read when instance was created is( $result{master_read}, $conf_dir, "Master read conf dir" ); is( $master->fetch_element_value('aa'), $custom_aa, "Master custom read" ); my $level1; $level1 = $master->fetch_element('level1'); $level1->init; ok( $level1, "Level1 object created" ); is( $level1->grab_value('bar X'), 'Cv', "Check level1 custom read" ); is( $result{level1_read}, $conf_dir, "check level1 custom read conf dir" ); my $same_rw = $master->fetch_element('samerw'); ok( $same_rw, "SameRWSpec object created" ); is( $same_rw->grab_value('bar Y'), 'Cv', "Check samerw custom read" ); is( $result{same_rw_read}, $conf_dir, "check same_rw_spec custom read conf dir" ); is( $i_zero->count_write_back, 10, "check that write call back are present" ); # perform write back of dodu tree dump string $i_zero->write_back( backend => 'all', force => 1 ); # check written files foreach my $suffix (qw/cds ini/) { map { my $f = "$root1$conf_dir/$_.$suffix"; ok( -e $f, "check written file $f" ); } ( 'zero_inst', 'zero_inst/level1', 'zero_inst/samerw' ); } foreach my $suffix (qw/pl/) { map { my $f = "$root1$conf_dir/$_.$suffix"; ok( -e "$f", "check written file $f" ); } ( 'zero_inst', 'zero_inst/level1' ); } # check called write routine is( $result{wr_stuff}, $conf_dir, 'check custom write dir' ); is( $result{wr_root_name}, 'Master', 'check custom conf root to write' ); # perform write back of dodu tree dump string in an overridden dir my $override = 'etc/wr_2/'; $i_zero->write_back( backend => 'all', config_dir => $override, force => 1 ); # check written files foreach my $suffix (qw/cds ini/) { map { ok( -e "$root1$override$_.$suffix", "check written file $root1$override$_.$suffix" ); } ( 'zero_inst', 'zero_inst/level1', 'zero_inst/samerw' ); } foreach my $suffix (qw/pl/) { map { ok( -e "$root1$override$_.$suffix", "check written file $root1$override$_.$suffix" ); } ( 'zero_inst', 'zero_inst/level1' ); } is( $result{wr_stuff}, $override, 'check custom overridden write dir' ); my $dump = $master->dump_tree( skip_auto_write => 'cds_file' ); print "Master dump:\n$dump\n" if $trace; is( $dump, qq!aa="$custom_aa" -\n!, "check master dump" ); $dump = $level1->dump_tree( skip_auto_write => 'cds_file' ); print "Level1 dump:\n$dump\n" if $trace; is( $dump, qq! bar\n X=Cv - -\n!, "check level1 dump" ); my $inst2 = 'second_inst'; my %cds = ( $inst2 => 'aa="aa was set by file" - ', "$inst2/level1" => 'bar X=Av Y=Bv - ' ); my $dir2 = "$root2/etc/test/"; mkpath( $dir2 . $inst2, 0, 0755 ) || die "Can't mkpath $dir2.$inst2:$!"; # write input config files foreach my $f ( keys %cds ) { my $fout = "$dir2/$f.cds"; next if -r $fout; open( FOUT, ">$fout" ) or die "can't open $fout:$!"; print FOUT $cds{$f}; close FOUT; } # create another instance my $test2_inst = $model->instance( root_class_name => 'Master', instance_name => $inst2, root_dir => $root2, ); ok( $test2_inst, "created second instance" ); # access level1 to autoread it my $root_2 = $test2_inst->config_root; my $level1_2 = $root_2->fetch_element('level1'); $level1_2->init; is( $root_2->grab_value('aa'), 'aa was set by file', "$inst2: check that cds file was read" ); my $dump2 = $root_2->dump_tree(); print "Read Master dump:\n$dump2\n" if $trace; my $expect2 = 'aa="aa was set by file" level1 bar X=Av Y=Bv - - samerw bar Y=Cv - - - '; is( $dump2, $expect2, "$inst2: check dump" ); # test loading with ini files map { my $o = $_; s!$root1/zero!ini!; copy( $o, "$root2/$_" ) or die "can't copy $o $_:$!" } glob("$root1/*.ini"); # create another instance to load ini files my $ini_inst = $model->instance( root_class_name => 'Master', instance_name => 'ini_inst' ); ok( $ini_inst, "Created instance to load ini files" ); my $expect_custom = 'aa="aa was set (custom mode)" level1 bar X=Cv - - samerw bar Y=Cv - - - '; $dump = $ini_inst->config_root->dump_tree; is( $dump, $expect_custom, "ini_test: check dump" ); unlink( glob("$root2/*.ini") ); # test loading with pl files map { my $o = $_; s!$root1/zero!pl!; copy( $o, "$root2/$_" ) or die "can't copy $o $_:$!" } glob("$root1/*.pl"); # create another instance to load pl files my $pl_inst = $model->instance( root_class_name => 'Master', instance_name => 'pl_inst' ); ok( $pl_inst, "Created instance to load pl files" ); $dump = $pl_inst->config_root->dump_tree; is( $dump, $expect_custom, "pl_test: check dump" ); #create from scratch instance my $scratch_i = $model->instance( root_class_name => 'FromScratch', instance_name => 'scratch_inst', root_dir => $root3, ); ok( $scratch_i, "Created instance from scratch to load cds files" ); $scratch_i->config_root->load("aa=toto"); $scratch_i->write_back; ok( -e "$root3/$conf_dir/scratch_inst.cds", "wrote cds config file" ); # create model for simple RW class my $cdswf = $model->instance( root_class_name => 'CdsWithFile', instance_name => 'cds_with_file_inst', root_dir => $root3, ); ok( $cdswf, "Created instance to load custom cds file" ); $cdswf->config_root->load("aa=toto2"); my $expect = 'aa=toto2 - '; is( $cdswf->config_root->dump_tree, $expect, "check dump" ); $cdswf->write_back; my $toto_conf = "$root3/$conf_dir/toto.conf"; copy( "$root3/$conf_dir/scratch_inst.cds", $toto_conf ) or die "can't copy scratch_inst.cds to toto.conf:$!"; my $ctoto = $model->instance( root_class_name => 'SimpleRW', instance_name => 'custom_toto', root_dir => $root3, ); ok( $ctoto, "Created instance to load custom custom toto file" ); is( $ctoto->config_root->dump_tree, $expect, "check dump" ); $ctoto->config_root->load("aa=toto3"); $ctoto->write_back; map { is( $result{simple_rw}{$_}, 'wr_root/test3//etc/test/toto.conf', "Check Simple_Rw cb file argument ($_)" ) } qw/rfile wfile/; file_contents_eq( $toto_conf, "aa=toto3 -\n", "checked file written by simpleRW" ); # test config-file override, reading cds file my $scratch_conf = 'etc/test/scratch_inst.cds'; my $cdswnf = $model->instance( root_class_name => 'CdsWithNoFile', instance_name => 'cds_with_no_file_inst', root_dir => $root3, config_file => $scratch_conf, ); ok( $cdswnf, "Created instance to load overridden cds config file" ); $expect = 'aa=toto2 - '; is( $cdswnf->config_root->dump_tree, $expect, "check dump" ); $cdswnf->config_root->load("aa=toto4"); $cdswnf->write_back( config_file => $scratch_conf ); file_contents_eq( "$root3/$scratch_conf", "aa=toto4 -\n", "checked file written by simpleRW" ); memory_cycle_ok($model); done_testing; backend_ini.t100644001750001750 1277312676543661 16044 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use File::Path; use File::Copy; use Data::Dumper; use Log::Log4perl qw(:easy); use warnings; no warnings qw(once); use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; my $log = $arg =~ /l/ ? 1 : 0; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "compiled" ); # pseudo root where config files are written by config-model my $wr_root = 'wr_root/'; # set_up data my @with_semi_column_comment = my @with_hash_comment = ; # change delimiter comments map { s/#/;/; } @with_semi_column_comment; sub init_test { my ($test_class, $test_data, $config_dir) = @_; my $model = Config::Model->new(); my @orig = @$test_data ; # cleanup before tests rmtree($wr_root); ok( 1, "Starting $test_class tests" ); my $test1 = 'ini1'; my $wr_dir = $wr_root . '/' . $test1; my $conf_file = "$wr_dir/etc/test.ini"; mkpath( $wr_dir . '/etc', { mode => 0755 } ) || die "can't mkpath: $!"; open( CONF, "> $conf_file" ) || die "can't open $conf_file: $!"; print CONF @orig; close CONF; my $i_test = $model->instance( instance_name => 'test_inst', root_class_name => $test_class, root_dir => $wr_dir, model_file => 't/test_ini_backend_model.pl', config_dir => $config_dir, # optional ); ok( $i_test, "Created $test_class instance" ); my $i_root = $i_test->config_root; ok( $i_root, "created $test_class tree root" ); $i_root->init; ok( 1, "$test_class root init done" ); return ($model, $i_test, $wr_dir); } sub finish { my ($test_class, $wr_dir, $model,$i_test) = @_; my $orig = $i_test->config_root->dump_tree; print $orig if $trace; $i_test->write_back; ok( 1, "IniFile write back done" ); my $ini_file = $wr_dir . '/etc/test.ini'; ok( -e $ini_file, "check that config file $ini_file was written" ); # create another instance to read the IniFile that was just written my $wr_dir2 = $wr_root . '/ini2'; mkpath( $wr_dir2 . '/etc', { mode => 0755 } ) || die "can't mkpath: $!"; copy( $wr_dir . '/etc/test.ini', $wr_dir2 . '/etc/' ) or die "can't copy from test1 to test2: $!"; my $i2_test = $model->instance( instance_name => 'test_inst2', root_class_name => $test_class, root_dir => $wr_dir2, config_dir => $i_test->config_dir, # propagate from first test instance ); ok( $i2_test, "Created instance" ); my $i2_root = $i2_test->config_root; my $p2_dump = $i2_root->dump_tree; print "2nd dump:\n",$p2_dump if $trace; is( $p2_dump, $orig, "compare original data with 2nd instance data" ); } my %test_setup = ( IniTest => [ \@with_hash_comment, 'class1' ], IniTest2 => [ \@with_semi_column_comment, 'class1' ], AutoIni => [ \@with_hash_comment, 'class1' ], MyClass => [ \@with_hash_comment, 'any_ini_class:class1' ] ); foreach my $test_class ( sort keys %test_setup ) { my ($model, $i_test, $wr_dir) = init_test($test_class, $test_setup{$test_class}[0]); my $test_path = $test_setup{$test_class}[1]; my $i_root = $i_test->config_root; $i_root->load("bar:0=\x{263A}"); # utf8 smiley is( $i_root->annotation, "some global comment with embedded '#' and stuff", "check global comment" ); is( $i_root->grab($test_path)->annotation, "class1 comment", "check $test_path comment" ); is( $i_root->grab($test_path)->backend_support_annotation, 1, "check support annotation " ); my $lista_obj = $i_root->grab($test_path)->fetch_element('lista'); is( $lista_obj->annotation, '', "check $test_path lista comment" ); foreach my $i ( 1 .. 3 ) { my $elt = $lista_obj->fetch_with_id( $i - 1 ); is( $elt->fetch, "lista$i", "check lista[$i] content" ); is( $elt->annotation, "lista$i comment", "check lista[$i] comment" ); } finish ($test_class, $wr_dir, $model,$i_test); memory_cycle_ok( $model, "memory cycle test" ); } # test ini file using a check list { # IniCheck my ($model, $i_test, $wr_dir) = init_test(IniCheck => \@with_hash_comment, '/etc/'); my $i_root = $i_test->config_root; ok($i_root->grab('foo')->is_checked('foo1'),"foo foo1 choice is set"); ok($i_root->grab('foo')->is_checked('bar1') == 0,"foo bar1 choice is not set"); ok($i_root->grab('bar')->is_checked('bar1'),"bar bar1 choice is set"); # I'm cheating. To reuse test data, list is actually a check_list in test model ok($i_root->grab('class1 lista')->is_checked('nolist') == 0,"class1 lista nolist choice is not set"); ok($i_root->grab('class1 lista')->is_checked('lista2'),"class1 lista lista1 choice is set"); $i_root->grab('class1 lista')->check('nolist'); finish ('IniCheck', $wr_dir, $model,$i_test); memory_cycle_ok( $model, "memory cycle test" ); } done_testing; __DATA__ #some global comment with embedded '#' and stuff # foo1 comment also with '#' stuff foo = foo1 foo = foo2 # foo2 comment bar = bar1 baz = bazv # class1 comment [class1] lista=lista1 #lista1 comment # lista2 comment lista = lista2 # lista3 comment lista = lista3 model_tests.t100644001750001750 36312676543661 16070 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings; use strict; use Config::Model::Tester 2.053; use ExtUtils::testlib; my $arg = shift || ''; my $test_only_model = shift || ''; my $do = shift; run_tests( $arg, $test_only_model, $do ); warped_node.t100644001750001750 1727312676543661 16105 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings ; use ExtUtils::testlib; use Test::More; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy); use strict; my ( $log, $show ) = (0) x 3; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => 'SlaveY', element => [ [qw/X Y/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/], warp => { follow => '- - v_macro', rules => { A => { default => 'Av' }, B => { default => 'Bv' } } } }, [qw/a_string a_long_string another_string/] => { type => 'leaf', mandatory => 1, value_type => 'string' }, ] ); $model->create_config_class( name => 'SlaveZ', element => [ [qw/X Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/], warp => { follow => '! v_macro', rules => { A => { default => 'Av' }, B => { default => 'Bv' } } } } ] ); $model->create_config_class( name => 'Master', element => [ v_macro => { type => 'leaf', value_type => 'enum', choice => [qw/A B/] }, b_macro => { type => 'leaf', value_type => 'boolean' }, tree_macro => { type => 'leaf', value_type => 'enum', choice => [qw/XY XZ mXY W AR/] }, 'a_hash_of_warped_nodes' => { type => 'hash', index_type => 'string', level => 'hidden', warp => { follow => '! tree_macro', rules => { XY => { level => 'normal', }, mXY => { level => 'normal', }, XZ => { level => 'normal', }, } }, cargo => { type => 'warped_node', follow => '! tree_macro', morph => 1, rules => { XY => { config_class_name => 'SlaveY', }, mXY => { config_class_name => 'SlaveY', }, XZ => { config_class_name => 'SlaveZ' } } }, }, 'a_warped_node' => { type => 'warped_node', follow => '! tree_macro', morph => 1, rules => { XY => { config_class_name => ['SlaveY'], }, mXY => { config_class_name => 'SlaveY', }, XZ => { config_class_name => 'SlaveZ' } } }, bool_object => { type => 'warped_node', follow => '! b_macro', rules => { 1 => { config_class_name => 'SlaveY' }, } }, ] ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $tm = $root->fetch_element('tree_macro'); $tm->store('AR'); is( $root->is_element_available('a_warped_node'), 0, 'check that a_warped_node is not accessible' ); is( $root->is_element_available('a_hash_of_warped_nodes'), 0, 'check that a_hash_of_warped_nodes is not available' ); eval { $root->fetch_element('a_hash_of_warped_nodes')->fetch_with_id(1)->fetch_element('X') ->store('coucou'); }; ok( $@, 'test stored on a warped node element (should fail)' ); print "Normal error:\n", $@ if $trace; is( $root->fetch_element('tree_macro')->store('XY'), 1, 'set master->tree_macro to XY' ); is( $root->fetch_element('a_warped_node')->is_accessible, 1, 'check that a_warped_node is accessible' ); my $ahown = $root->fetch_element('a_hash_of_warped_nodes'); is( $ahown->fetch_with_id(234)->config_class_name, 'SlaveY', "reading a_hash_of_warped_nodes (is SlaveY because tree_macro was set)" ); is( $root->fetch_element('tree_macro')->store('XZ'), 1, 'set master->tree_macro to XZ' ); is( $ahown->fetch_with_id(234)->config_class_name, 'SlaveZ', "reading a_hash_of_warped_nodes (is SlaveZ because tree_macro was set)" ); is( $ahown->fetch_with_id(234)->fetch_element('X')->fetch, undef, 'reading master a_hash_of_warped_nodes:234 X (undef)' ); is( $root->fetch_element('v_macro')->store('A'), 1, 'set master v_macro to A' ); map { is( $ahown->fetch_with_id(234)->fetch_element($_)->fetch, 'Av', "reading master a_hash_of_warped_nodes:234 $_ (default value)" ); } qw/X Z/; map { is( $ahown->fetch_with_id(234)->fetch_element($_)->store('Cv'), 1, "Set master a_hash_of_warped_nodes:234 $_ to Cv" ); } qw/X Z/; is( $root->fetch_element('tree_macro')->store('mXY'), 1, 'set master->tree_macro to mXY (with morphing which looses Z element)...' ); is( $ahown->fetch_with_id(234)->fetch_element('X')->fetch, 'Cv', "... X value was kept ..." ); is( $ahown->fetch_with_id(234)->fetch_element('Y')->fetch, 'Av', "... Y is back to default value" ); is( $root->fetch_element('v_macro')->store('B'), 1, 'set master v_macro to B' ); is( $ahown->fetch_with_id(234)->fetch_element('X')->fetch, 'Cv', "... X value was kept ..." ); is( $ahown->fetch_with_id(234)->fetch_element('Y')->fetch, 'Bv', "... Y is to new default value" ); # TBD #print "Testing dump on warped object\n" if $trace; #my $dump = cute_dump( object => $master ); #ok( $dump, qr/ X = Cv/ ); my $warped_node = $root->fetch_element('a_warped_node'); isa_ok( $warped_node, "Config::Model::WarpedNode", "created warped node" ); is( $ahown->fetch_with_id(234)->element_name, 'a_hash_of_warped_nodes', 'Check element name of warped node' ); is( $ahown->fetch_with_id(234)->index_value, '234', 'Check index value of warped node' ); # should also check that info was passed to actual node below (data # element) is( $ahown->fetch_with_id(234)->element_name, 'a_hash_of_warped_nodes', 'Check element name of actual node below warped node' ); is( $ahown->fetch_with_id(234)->index_value, '234', 'Check index value of actual node below warped node' ); $ahown->copy( 234, 2345 ); print $root->dump_tree( check => 'no' ) if $trace; is( $ahown->fetch_with_id(234)->fetch_element_value('X'), $ahown->fetch_with_id(2345)->fetch_element_value('X'), "check that has copy works on warped_node" ); is( $root->fetch_element('tree_macro')->store('W'), 1, 'set master->tree_macro to W (warp out)...' ); eq_or_diff( [ $root->get_element_name() ], [qw/v_macro b_macro tree_macro/], 'reading elements of root after warp out' ); eq_or_diff( [ $root->get_element_name() ], [qw/v_macro b_macro tree_macro/], 'reading elements of root after warp out' ); is( $root->fetch_element('b_macro')->store(1), 1, 'set master->b_macro to 1 (warp in bool_object)...' ); $root->fetch_element('b_macro')->store(1); is( $root->fetch_element('bool_object')->config_class_name, 'SlaveY', 'check theorical bool_object type...' ); memory_cycle_ok( $model, "mem cycle test" ); done_testing; warped_value.t100644001750001750 4637212676543661 16276 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Differences; use Test::Memory::Cycle; use Test::Exception; use Config::Model; use Config::Model::ValueComputer; use Log::Log4perl qw(:easy); use strict; my ( $log, $show ) = (0) x 3; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "Compilation done" ); my $model = Config::Model->new(); $model->create_config_class( name => "RSlave", element => [ recursive_slave => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'RSlave' }, }, big_compute => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string', compute => { variables => { 'm' => '! macro', }, formula => 'macro is $m, my idx: &index, ' . 'my element &element, ' . 'upper element &element( - ), ' . 'up idx &index( - )', } }, }, big_replace => { type => 'leaf', value_type => 'string', compute => { formula => 'trad idx $replace{&index(-)}', replace => { l1 => 'level1', l2 => 'level2' } } }, [qw/bar foo foo2/] => { type => 'node', config_class_name => 'Slave' }, macro_replace => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string', compute => { formula => 'trad macro is $replace{$m}', variables => { 'm' => '! macro', }, replace => { A => 'macroA', B => 'macroB', C => 'macroC' }, } }, } ], ); $model->create_config_class( name => "Slave", 'element' => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/], warp => { follow => '- - macro', rules => { A => { default => 'Av' }, B => { default => 'Bv' } } } }, 'recursive_slave' => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'RSlave', }, }, W => { type => 'leaf', value_type => 'enum', level => 'hidden', warp => { follow => '- - macro', 'rules' => { A => { default => 'Av', level => 'normal', choice => [qw/Av Bv Cv/], }, B => { default => 'Bv', level => 'normal', choice => [qw/Av Bv Cv/] } } }, }, Comp => { type => 'leaf', value_type => 'string', compute => { formula => 'macro is $m', variables => { 'm' => '- - macro' }, }, }, warped_by_location => { type => 'leaf', value_type => 'uniline', default => 'slaved', warp => { rules => [ '&location =~ /recursive/', { 'default' => 'rslaved' } ] }, }, ] ); $model->create_config_class( name => "Master", element => [ get_element => { type => 'leaf', value_type => 'enum', choice => [qw/m_value_element compute_element/] }, where_is_element => { type => 'leaf', value_type => 'enum', choice => [qw/get_element/] }, macro => { type => 'leaf', value_type => 'enum', mandatory => 1, choice => [qw/A B C D/] }, m_value_out => { type => 'leaf', value_type => 'uniline', warp => { follow => '- macro', 'rules' => [ "B" => { level => 'hidden', }, ] } }, m2_value_out => { type => 'leaf', value_type => 'uniline', warp => { follow => { m => '- macro', m2 => '- macro2' }, rules => [ '$m eq "A" or $m2 eq "A"' => { level => 'hidden', }, ] } }, macro2 => { type => 'leaf', value_type => 'enum', level => 'hidden', warp => { follow => '- macro', 'rules' => [ "B" => { level => 'normal', choice => [qw/A B C D/] }, ] } }, 'm_value' => { type => 'leaf', value_type => 'enum', level => 'hidden', 'warp' => { follow => { m => '- macro' }, 'rules' => [ '$m eq "A" or $m eq "D"' => { choice => [qw/Av Bv/], level => 'normal', help => { Av => 'Av help' }, }, '$m eq "B"' => { choice => [qw/Bv Cv/], level => 'normal', help => { Bv => 'Bv help' }, }, '$m eq "C"' => { choice => [qw/Cv/], level => 'normal', help => { Cv => 'Cv help' }, } ] } }, 'm_value_old' => { type => 'leaf', value_type => 'enum', level => 'hidden', 'warp' => { follow => '- macro', 'rules' => [ [qw/A D/] => { choice => [qw/Av Bv/], level => 'normal', help => { Av => 'Av help' }, }, B => { choice => [qw/Bv Cv/], level => 'normal', help => { Bv => 'Bv help' }, }, C => { choice => [qw/Cv/], level => 'normal', help => { Cv => 'Cv help' }, } ] } }, 'compute' => { type => 'leaf', value_type => 'string', compute => { formula => 'macro is $m, my element is &element', variables => { 'm' => '! macro' }, }, }, 'var_path' => { type => 'leaf', value_type => 'string', mandatory => 1, # will croak if value cannot be computed compute => { formula => 'get_element is $replace{$s}, indirect value is \'$v\'', variables => { 's' => '! $where', where => '! where_is_element', v => '! $replace{$s}', }, replace => {qw/m_value_element m_value compute_element compute/} } }, 'class' => { type => 'hash', index_type => 'string', cargo => { type => 'leaf', value_type => 'string' }, }, 'warped_out_ref' => { type => 'leaf', refer_to => '! class', value_type => 'reference', level => 'hidden', warp => { follow => { m => '- macro', m2 => '- macro2' }, rules => [ '$m eq "A" or $m2 eq "A"' => { level => 'normal', }, ] } }, [qw/bar foo foo2/] => { type => 'node', config_class_name => 'Slave' }, 'ClientAliveCheck', { 'value_type' => 'boolean', 'upstream_default' => '0', 'type' => 'leaf', }, 'ClientAliveInterval', { 'value_type' => 'integer', 'level' => 'hidden', 'min' => '1', 'warp' => { 'follow' => { 'c_a_check' => '- ClientAliveCheck' }, 'rules' => [ '$c_a_check == 1', { 'level' => 'normal' } ] }, 'type' => 'leaf' }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $mvo = $root->fetch_element('m_value_out'); isa_ok( $mvo->{warper}, 'Config::Model::Warper', "check warper object" ); my $macro = $root->fetch_element('macro'); my @macro_slaves = ('Warper of Master m_value_out'); eq_or_diff( [ map { $_->name } $macro->get_depend_slave ], \@macro_slaves, "check m_value_out warper" ); my $mvo2 = $root->fetch_element('m2_value_out'); isa_ok( $mvo2->{warper}, 'Config::Model::Warper', "check warper object" ); push @macro_slaves, 'Warper of Master m2_value_out', 'Warper of Master macro2'; eq_or_diff( [ sort map { $_->name } $macro->get_depend_slave ], [ sort @macro_slaves ], "check m_value_out and m2_value_out warper" ); eq_or_diff( [ $root->get_element_name() ], [ qw'get_element where_is_element macro m_value_out m2_value_out compute var_path class bar foo foo2 ClientAliveCheck' ], "Elements of Master" ); # query the model instead of the instance eq_or_diff( [ $model->get_element_name( class => 'Slave', ) ], [qw'X Y Z recursive_slave Comp warped_by_location'], "Elements of Slave from the model" ); my $slave = $root->fetch_element('bar'); ok( $slave, "Created slave(bar)" ); eq_or_diff( [ $slave->get_element_name() ], [qw'X Y Z recursive_slave Comp warped_by_location'], "Elements of Slave from the object" ); throws_ok { $slave->fetch_element('W')->fetch; } qr/unavailable/, "reading slave->W (undef value_type error)"; is( $slave->fetch_element('X')->fetch, undef, "reading slave->X (undef)" ); is( $macro->store('B'), 1, "setting master->macro to B" ); eq_or_diff( [ $root->get_element_name() ], [ qw'get_element where_is_element macro m2_value_out macro2 m_value m_value_old compute var_path class bar foo foo2 ClientAliveCheck' ], "Elements of Master when macro = B" ); is( $root->fetch_element('macro2')->store('A'), 1, "setting master->macro2 to A" ); is_deeply( [ $root->get_element_name() ], [ qw'get_element where_is_element macro macro2 m_value m_value_old compute var_path class warped_out_ref bar foo foo2 ClientAliveCheck' ], "Elements of Master when macro = B macro2 = A" ); $root->fetch_element('class')->fetch_with_id('foo')->store('foo_v'); $root->fetch_element('class')->fetch_with_id('bar')->store('bar_v'); is( $root->fetch_element('warped_out_ref')->store('foo'), 1, "setting master->warped_out_ref to foo" ); is( $root->fetch_element('macro')->store('A'), 1, "setting master->macro to A" ); map { is( $slave->fetch_element($_)->fetch, 'Av', "reading slave->$_ (Av)" ); } qw/X Y Z/; is( $root->fetch_element('macro')->store('C'), 1, "setting master->macro to C" ); is( $root->fetch_element('m_value')->get_help('Cv'), 'Cv help', 'test m_value help with macro=C' ); is( $slave->fetch_element('X')->fetch, undef, "reading slave->X (undef)" ); $root->fetch_element('macro')->store('A'); is( $root->fetch_element('m_value')->store('Av'), 1, 'test m_value with macro=A' ); is( $root->fetch_element('m_value_old')->store('Av'), 1, 'test m_value_old with macro=A' ); is( $root->fetch_element('m_value')->get_help('Av'), 'Av help', 'test m_value help with macro=A' ); is( $root->fetch_element('m_value')->get_help('Cv'), undef, 'test m_value help with macro=A' ); $root->fetch_element('macro')->store('D'); is( $root->fetch_element('m_value')->fetch, 'Av', 'test m_value with macro=D' ); is( $root->fetch_element('m_value_old')->fetch, 'Av', 'test m_value_old with macro=D' ); $root->fetch_element('macro')->store('A'); is_deeply( [ $slave->get_element_name() ], [qw/X Y Z recursive_slave W Comp warped_by_location/], "Slave elements from the object (W pops in when macro is set to A)" ); $root->fetch_element('macro')->store('B'); is_deeply( [ $slave->get_element_name() ], [qw/X Y Z recursive_slave W Comp warped_by_location/], "Slave elements from the object" ); map { is( $slave->fetch_element($_)->fetch, 'Bv', "reading slave->$_ (Bv)" ); } qw/X Y Z/; is( $slave->fetch_element('Y')->store('Cv'), 1, 'Set slave->Y to Cv' ); # testing warp in warp out $root->fetch_element('macro')->store('C'); is( $slave->is_element_available( name => 'W' ), 0, " test W is not available" ); $root->fetch_element('macro')->store('B'); is( $slave->is_element_available( name => 'W' ), 1, " test W is available" ); $root->fetch_element('macro')->store('C'); map { is( $slave->fetch_element($_)->fetch, undef, "reading slave->$_ (undef)" ); } qw/X Z/; is( $slave->fetch_element('Y')->fetch, 'Cv', "reading slave->Y (Cv)" ); is( $slave->fetch_element('Comp')->fetch, 'macro is C', "reading slave->Comp" ); is( $root->fetch_element('m_value')->store('Cv'), 1, 'set m_value to Cv' ); my $rslave1 = $slave->fetch_element('recursive_slave')->fetch_with_id('l1'); my $rslave2 = $rslave1->fetch_element('recursive_slave')->fetch_with_id('l2'); my $big_compute_obj = $rslave2->fetch_element('big_compute')->fetch_with_id('b1'); isa_ok( $big_compute_obj, 'Config::Model::Value', 'Created new big compute object' ); my $bc_val = $rslave2->fetch_element('big_compute')->fetch_with_id("test_1")->fetch; is( $bc_val, 'macro is C, my idx: test_1, my element big_compute, upper element recursive_slave, up idx l2', 'reading slave->big_compute(test1)' ); is( $big_compute_obj->fetch, 'macro is C, my idx: b1, my element big_compute, upper element recursive_slave, up idx l2', 'reading slave->big_compute(b1)' ); is( $rslave1->fetch_element('big_replace')->fetch(), 'trad idx level1', 'reading rslave1->big_replace(br1)' ); is( $rslave2->fetch_element('big_replace')->fetch(), 'trad idx level2', 'reading rslave2->big_replace(br1)' ); is( $rslave1->fetch_element('macro_replace')->fetch_with_id('br1')->fetch, 'trad macro is macroC', 'reading rslave1->macro_replace(br1)' ); is( $rslave2->fetch_element('macro_replace')->fetch_with_id('br1')->fetch, 'trad macro is macroC', 'reading rslave2->macro_replace(br1)' ); is( $root->fetch_element('compute')->fetch(), 'macro is C, my element is compute', 'reading root->compute' ); my @masters = $root->fetch_element('macro')->get_depend_slave(); my @names = sort map { $_->name } @masters; print "macro controls:\n\t", join( "\n\t", @names ), "\n" if $trace; is( scalar @masters, 16, 'reading macro slaves' ); eq_or_diff( \@names, [ 'Master compute', 'Warper of Master m2_value_out', 'Warper of Master m_value', 'Warper of Master m_value_old', 'Warper of Master m_value_out', 'Warper of Master macro2', 'Warper of Master warped_out_ref', 'Warper of bar W', 'Warper of bar X', 'Warper of bar Y', 'Warper of bar Z', 'bar Comp', 'bar recursive_slave:l1 macro_replace:br1', 'bar recursive_slave:l1 recursive_slave:l2 big_compute:b1', 'bar recursive_slave:l1 recursive_slave:l2 big_compute:test_1', 'bar recursive_slave:l1 recursive_slave:l2 macro_replace:br1', ], "check names of values using 'macro' element" ); Config::Model::Exception::Any->Trace(1); throws_ok { $root->fetch_element('var_path')->fetch; } qr/'! where_is_element' is undef/, 'reading var_path while where_is_element variable is undef'; # set one variable of the formula $root->fetch_element('where_is_element')->store('get_element'); throws_ok { $root->fetch_element('var_path')->fetch; } qr/'! where_is_element' is 'get_element'/, 'reading var_path while where_is_element is defined' ; throws_ok { $root->fetch_element('var_path')->fetch; } qr/Undefined mandatory value/, 'reading var_path while get_element variable is undef'; # set the other variable of the formula $root->fetch_element('get_element')->store('m_value_element'); is( $root->fetch_element('var_path')->fetch(), 'get_element is m_value, indirect value is \'Cv\'', "reading var_path through m_value element" ); # modify the other variable of the formula $root->fetch_element('get_element')->store('compute_element'); is( $root->fetch_element('var_path')->fetch(), 'get_element is compute, indirect value is \'macro is C, my element is compute\'', "reading var_path through compute element" ); $root->fetch_element('ClientAliveCheck')->store(0); throws_ok { $root->fetch_element('ClientAliveInterval')->fetch; } qr/unavailable element/, 'reading ClientAliveInterval when ClientAliveCheck is 0'; $root->fetch_element('ClientAliveCheck')->store(1); $root->fetch_element('ClientAliveInterval')->store(10); is( $root->fetch_element('ClientAliveInterval')->fetch, 10, "check ClientAliveInterval" ); my %loc_h = ( qw/bar slaved foo2 slaved/, 'bar recursive_slave:l1 foo2' => 'rslaved', 'bar recursive_slave:l1 recursive_slave:l2 foo2' => 'rslaved' ); foreach my $k ( sort keys %loc_h ) { my $path = "$k warped_by_location"; is( $root->grab_value($path), $loc_h{$k}, "check &location with $path" ); } # test warp in layered mode my $layered_i = $model->instance( root_class_name => 'Master', instance_name => 'test_layered' ); ok( $layered_i, "created layered instance" ); my $l_root = $layered_i->config_root; $layered_i->layered_start; my $l_macro = $l_root->fetch_element('macro'); $l_macro->store('D'); my $l_mv = $l_root->fetch_element('m_value'); $layered_i->layered_stop; $l_mv->store('Av'); is( $l_mv->fetch, 'Av', "test warp in layered mode" ); memory_cycle_ok( $model, "test memory cycle" ); done_testing ; yaml_backend.t100644001750001750 740512676543661 16203 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Path::Tiny; use YAML::Any; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new(); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $ERROR ); ok( 1, "compiled" ); # pseudo root where config files are written by config-model my $wr_root = path('wr_root'); # cleanup before tests $wr_root->remove_tree; my $yaml_dir = $wr_root->child('yaml'); $yaml_dir->mkpath(); my $i_hosts = $model->instance( instance_name => 'hosts_inst', root_class_name => 'Hosts', root_dir => $wr_root->stringify, model_file => 't/test_yaml_model.pl', ); ok( $i_hosts, "Created instance" ); my $i_root = $i_hosts->config_root; my $load = "record:0 ipaddr=127.0.0.1 canonical=localhost alias=localhost - record:1 ipaddr=192.168.0.1 canonical=bilbo - - "; $i_root->load($load); $i_hosts->write_back; ok( 1, "yaml write back done" ); # TODO: test yaml content for skipped element my $yaml_file = $yaml_dir ->child('hosts.yml'); ok( $yaml_file->exists, "check that config file $yaml_file was written" ); my $written = $yaml_file->slurp; unlike($written, qr/record/, "check that list element name is not written"); # create another instance to read the yaml that was just written my $i2_hosts = $model->instance( instance_name => 'hosts_inst2', root_class_name => 'Hosts', root_dir => $wr_root->stringify, ); ok( $i2_hosts, "Created instance" ); my $i2_root = $i2_hosts->config_root; my $p2_dump = $i2_root->dump_tree; is( $p2_dump, $load, "compare original data with 2nd instance data" ); # since full_dump is null, check that dummy param is not written in yaml files my $yaml = $yaml_file->slurp || die "can't open $yaml_file:$!"; unlike( $yaml, qr/dummy/, "check yaml dump content" ); $yaml_file->remove; # test yaml content for single hash class my $i_single_hash = $model->instance( instance_name => 'single_hash', root_class_name => 'SingleHashElement', root_dir => $wr_root->stringify, ); ok( $i_single_hash, "Created single hash instance" ); $load = "record:foo ipaddr=127.0.0.1 canonical=localhost alias=localhost - record:bar ipaddr=192.168.0.1 canonical=bilbo - - "; $i_single_hash->config_root->load($load); $i_single_hash->write_back; ok( 1, "yaml single_hash write back done" ); ok( $yaml_file->exists, "check that config file $yaml_file was written" ); $yaml = $yaml_file->slurp || die "can't open $yaml_file:$!"; unlike( $yaml, qr/record/, "check single_hash yaml content" ); # test that yaml file is removed when no data is left $i_single_hash->config_root->fetch_element("record")->clear; $i_single_hash->write_back; ok( ! $yaml_file->exists, "check that config file $yaml_file was removed by clearing content" ); # idem for more complex class defined in model my $i_2_elements = $model->instance( instance_name => '2 elements', root_class_name => 'TwoElements', root_dir => $wr_root->stringify, ); ok( $i_single_hash, "Created '2 elements' instance" ); $i_2_elements->config_root->load($load); $i_2_elements->write_back; ok( 1, "yaml 2 elements write back done" ); ok( $yaml_file->exists, "check that config file $yaml_file was written" ); $yaml = $yaml_file->slurp || die "can't open $yaml_file:$!"; like( $yaml, qr/record/, "check 2 elements yaml content" ); $i_2_elements->config_root->fetch_element("record")->clear; $i_2_elements->write_back; ok( ! $yaml_file->exists, "check that config file $yaml_file was removed by clearing content" ); memory_cycle_ok( $model, "check model mem cycles" ); done_testing; dump_as_data.t100644001750001750 1265012676543661 16231 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 38; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $ERROR ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/dump_load_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Config root created" ); my $step = ' std_id:ab X=Bv - std_id:bc X=Av - tree_macro=mXY another_string="toto tata" hash_a:toto=toto_value hash_a:titi=titi_value ordered_hash:z=1 ordered_hash:y=2 ordered_hash:x=3 lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - my_check_list=toto my_reference="titi" warp warp2 aa2="foo bar" '; $step =~ s/\n/ /g; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); # load some values with undef $root->fetch_element('hash_a')->fetch_with_id('undef_val'); $root->fetch_element('lista')->fetch_with_id(6)->store('g'); $root->load_data( { listb => 'bb' } ); ok( 1, "loaded single array element as listb => 'bb'" ); my $data = $root->dump_as_data( full_dump => 0 ); my $expect = { 'olist' => [ { 'X' => 'Av' }, { 'X' => 'Bv' } ], 'my_check_list' => ['toto'], 'tree_macro' => 'mXY', 'ordered_hash' => [ 'z', '1', 'y', '2', 'x', '3' ], 'another_string' => 'toto tata', 'listb' => ['bb'], 'my_reference' => 'titi', 'hash_a' => { 'toto' => 'toto_value', 'titi' => 'titi_value', }, 'std_id' => { 'ab' => { 'X' => 'Bv' }, 'bc' => { 'X' => 'Av' } }, 'lista' => [qw/a b c d g/], 'warp' => { 'warp2' => { 'aa2' => 'foo bar' } }, }; #use Data::Dumper; print Dumper $data ; is_deeply( $data, $expect, "check data dump" ); # add default information provided by model to check full dump $expect->{string_with_def} = 'yada yada'; $expect->{int_v} = 10; $expect->{olist}[0]{DX} = 'Dv'; $expect->{olist}[1]{DX} = 'Dv'; $expect->{std_id}{ab}{DX} = 'Dv'; $expect->{std_id}{bc}{DX} = 'Dv'; $expect->{a_uniline} = 'yada yada'; my $full_data = $root->dump_as_data(); is_deeply( $full_data, $expect, "check full data dump" ); my $inst2 = $model->instance( root_class_name => 'Master', instance_name => 'test2' ); ok( $inst, "created 2nd dummy instance" ); my $root2 = $inst2->config_root; ok( $root2, "Config root2 created" ); $root2->load_data($data); ok( 1, "loaded perl data structure in 2nd instance" ); my $dump1 = $root->dump_tree; my $dump2 = $root2->dump_tree; is( $dump2, $dump1, "check that dump of 2nd tree is identical to dump of the first tree" ); # try partial dumps my @tries = ( [ 'olist' => $expect->{olist} ], [ 'olist:0' => $expect->{olist}[0] ], [ 'olist:0 DX' => $expect->{olist}[0]{DX} ], [ 'string_with_def' => $expect->{string_with_def} ], [ 'ordered_hash' => $expect->{ordered_hash} ], [ 'hash_a' => $expect->{hash_a} ], [ 'std_id:ab' => $expect->{std_id}{ab} ], [ 'my_check_list' => $expect->{my_check_list} ], ); foreach my $test (@tries) { my ( $path, $expect ) = @$test; my $obj = $root->grab($path); my $dump = $obj->dump_as_data(); is_deeply( $dump, $expect, "check data dump for '$path'" ); } # try dump of ordered hash as hash my $ohah_dump = $root->grab('ordered_hash')->dump_as_data( ordered_hash_as_list => 0 ); is_deeply( $ohah_dump, { __ordered_hash_order => [qw/z y x/], 'z', '1', 'y', '2', 'x', '3' }, "check dump of ordered hash as hash" ); # test ordered hash load with hash ref instead of array ref my $inst3 = $model->instance( root_class_name => 'Master', instance_name => 'test3' ); ok( $inst, "created 3rd dummy instance" ); my $root3 = $inst3->config_root; $data->{ordered_hash} = { @{ $expect->{ordered_hash} } }; $root3->load_data($data); @tries = ( [ 'olist' => $expect->{olist} ], [ 'olist:0' => $expect->{olist}[0] ], [ 'olist:0 DX' => $expect->{olist}[0]{DX} ], [ 'string_with_def' => $expect->{string_with_def} ], [ 'ordered_hash' => [qw/x 3 y 2 z 1/] ], [ 'hash_a' => $expect->{hash_a} ], [ 'std_id:ab' => $expect->{std_id}{ab} ], [ 'my_check_list' => $expect->{my_check_list} ], ); foreach my $test (@tries) { my ( $path, $expect ) = @$test; my $obj = $root3->grab($path); my $dump = $obj->dump_as_data(); is_deeply( $dump, $expect, "check data dump for '$path'" ); } # test dump of annotations as pod my %notes = map { ( $_ => $_ ? "$_ annotation\nwith long text" : "root annotation" ); } ( '', 'olist', 'olist:0', 'olist:0 DX', 'hash_a', 'std_id:ab', 'my_check_list' ); foreach ( keys %notes ) { $root->grab($_)->annotation( $notes{$_} ); } print $root->dump_tree if $trace; my $pod_notes = $root->dump_annotations_as_pod; print $pod_notes if $trace; foreach ( keys %notes ) { my $v = $notes{$_}; like( $pod_notes, qr/$v/, "found note for $_ in pod notes" ); } $root2->load_pod_annotation($pod_notes); my $pod_notes2 = $root2->dump_annotations_as_pod; is( $pod_notes2, $pod_notes, "check 2nd pod notes" ); memory_cycle_ok($model); node_get_set.t100644001750001750 246612676543661 16233 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 9; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; my $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; # check with embedded \n my $step = qq!std_id:ab X=Bv - std_id:bc X=Av - a_string="titi and toto" !; ok( $root->load( step => $step ), "load '$step'" ); foreach ( [ "/std_id/cc/X", "Bv" ], ) { my ( $path, $exp ) = @$_; is( $root->set( $path, $exp ), 1, "Test set $path" ); } foreach ( [ "/std_id/bc/X", "Av" ], [ "/std_id/cc/X", "Bv" ], ) { my ( $path, $exp ) = @$_; is( $root->get($path), $exp, "Test get $path" ); } is( $root->get( path => "/std_id/bc/X", get_obj => 1 ), $root->grab("std_id:bc X"), "test get with get_obj" ); is( $root->get( path => '/BDMV', check => 'skip' ), undef, "get with check skip does not die" ); memory_cycle_ok($model); value_compute.t100644001750001750 5102312676543661 16455 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More; use Test::Warn; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy); use strict; my $arg = shift || ''; my $log = 0; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "Compilation done" ); my $model = Config::Model->new(); $model->create_config_class( name => "Slave", element => [ find_node_element_name => { type => 'leaf', value_type => 'string', compute => { formula => '&element(-)', }, }, location_function_in_formula => { type => 'leaf', value_type => 'string', compute => { formula => '&location', }, }, check_node_element_name => { type => 'leaf', value_type => 'boolean', compute => { formula => '"&element(-)" eq "foo2"', }, }, [qw/av bv/] => { type => 'leaf', value_type => 'integer', compute => { variables => { p => '! &element' }, formula => '$p', }, }, ] ); # Tx to Ilya Arosov $model->create_config_class( 'name' => 'TestIndex', 'element' => [ name => { 'type' => 'leaf', 'value_type' => 'uniline', 'compute' => { 'formula' => '$my_name is my name', 'variables' => { 'my_name' => '! index_function_target:&index(-) name' } }, } ] ); $model->create_config_class( 'name' => 'TargetIndex', 'element' => [ name => { 'type' => 'leaf', 'value_type' => 'uniline', } ] ); $model->create_config_class( 'name' => 'LicenseSpec', 'element' => [ 'text', { 'value_type' => 'string', 'type' => 'leaf', 'compute' => { 'replace' => { 'GPL-1+' => "yada yada GPL-1+\nyada yada", 'Artistic' => "yada yada Artistic\nyada yada", }, 'formula' => '$replace{&index(-)}', 'allow_override' => '1', undef_is => '', }, }, short_name_from_index => { 'type' => 'leaf', 'value_type' => 'string', compute => { 'formula' => '&index( - );', 'use_eval' => 1, }, } ] ); $model->create_config_class( name => "Master", element => [ [qw/av bv/] => { type => 'leaf', class => 'Config::Model::Value', value_type => 'integer', }, compute_int => { type => 'leaf', class => 'Config::Model::Value', value_type => 'integer', compute => { formula => '$a + $b', variables => { a => '- av', b => '- bv' } }, min => -4, max => 4, }, [qw/sav sbv/] => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', }, one_var => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', compute => { formula => '&element().$bar', variables => { bar => '- sbv' } }, }, one_wrong_var => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', compute => { formula => '$bar', variables => { bar => '- wrong_v' } }, }, meet_test => { type => 'leaf', class => 'Config::Model::Value', value_type => 'string', compute => { formula => 'meet $a and $b', variables => { a => '- sav', b => '- sbv' } }, }, compute_with_override => { type => 'leaf', class => 'Config::Model::Value', value_type => 'integer', compute => { formula => '$a + $b', variables => { a => '- av', b => '- bv' }, allow_override => 1, }, min => -4, max => 4, }, compute_with_override_and_fix => { type => 'leaf', class => 'Config::Model::Value', value_type => 'uniline', compute => { formula => 'def value', allow_override => 1, }, warn_unless => { device_file => { code => 'm/def/;', msg => "not default value", fix => '$_ = undef;' } } }, # emulate imon problem where /dev/lcd0 is the default value and may not be found compute_with_override_and_powerless_fix => { type => 'leaf', class => 'Config::Model::Value', value_type => 'uniline', compute => { formula => q"my $l = '/dev/lcd-imon'; -e $l ? $l : '/dev/lcd0';", use_eval => 1, allow_override => 1, }, warn_if => { not_lcd_imon => { code => q!my $l = '/dev/lcd-imon';defined $_ and -e $l and $_ ne $l ;!, msg => "not lcd-foo.txt", fix => '$_ = undef;' }, }, warn_unless => { good_value => { code => 'defined $_ ? -e : 1;', msg => "not good value", fix => '$_ = undef;' } } }, compute_with_upstream => { type => 'leaf', class => 'Config::Model::Value', value_type => 'integer', compute => { formula => '$a + $b', variables => { a => '- av', b => '- bv' }, use_as_upstream_default => 1, }, }, compute_no_var => { type => 'leaf', value_type => 'string', compute => { formula => '&element()', }, }, [qw/bar foo2/] => { type => 'node', config_class_name => 'Slave' }, 'url' => { type => 'leaf', value_type => 'uniline', }, 'host' => { type => 'leaf', value_type => 'uniline', compute => { formula => '$url =~ m!http://([\w\.]+)!; $1 ;', variables => { url => '- url' }, use_eval => 1, }, }, 'with_tmp_var' => { type => 'leaf', value_type => 'uniline', compute => { formula => 'my $tmp = $url; $tmp =~ m!http://([\w\.]+)!; $1 ;', variables => { url => '- url' }, use_eval => 1, }, }, 'Upstream-Contact' => { 'cargo' => { 'value_type' => 'uniline', 'migrate_from' => { 'formula' => '$maintainer', 'variables' => { 'maintainer' => '- Upstream-Maintainer:&index' } }, 'type' => 'leaf' }, 'type' => 'list', }, 'Upstream-Maintainer' => { 'cargo' => { 'value_type' => 'uniline', 'migrate_from' => { 'formula' => '$maintainer', 'variables' => { 'maintainer' => '- Maintainer:&index' } }, 'type' => 'leaf' }, 'status' => 'deprecated', 'type' => 'list' }, 'Maintainer' => { 'cargo' => { 'value_type' => 'uniline', 'type' => 'leaf' }, 'type' => 'list', }, 'Source' => { 'value_type' => 'string', 'mandatory' => '1', 'migrate_from' => { 'use_eval' => '1', 'formula' => '$old || $older ;', undef_is => "''", 'variables' => { 'older' => '- Original-Source-Location', 'old' => '- Upstream-Source' } }, 'type' => 'leaf', }, 'Source2' => { 'value_type' => 'string', 'mandatory' => '1', 'compute' => { 'use_eval' => '1', 'formula' => '$old || $older ;', undef_is => "''", 'variables' => { 'older' => '- Original-Source-Location', 'old' => '- Upstream-Source' } }, 'type' => 'leaf', }, [qw/Upstream-Source Original-Source-Location/] => { 'value_type' => 'string', 'status' => 'deprecated', 'type' => 'leaf' }, Licenses => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'LicenseSpec' } }, index_function_target => { 'type' => 'hash', 'index_type' => 'string', 'cargo' => { 'config_class_name' => 'TargetIndex', 'type' => 'node' }, }, test_index_function => { 'type' => 'hash', 'index_type' => 'string', 'cargo' => { 'config_class_name' => 'TestIndex', 'type' => 'node' }, }, 'OtherMaintainer' => { type => 'leaf', value_type => 'uniline' }, 'Vcs-Browser' => { 'type' => 'leaf', 'value_type' => 'uniline', 'compute' => { 'allow_override' => '1', 'formula' => '$maintainer =~ /pkg-(perl|ruby-extras)/p ? "http://anonscm.debian.org/gitweb/?p=${^MATCH}/packages/$pkgname.git" : undef ;', 'use_eval' => '1', 'variables' => { 'maintainer' => '- OtherMaintainer', 'pkgname' => '- Source' } } }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); $inst->initial_load_stop; my $root = $inst->config_root; # order is important. Do no use sort. eq_or_diff( [ $root->get_element_name() ], [ qw/av bv compute_int sav sbv one_var one_wrong_var meet_test compute_with_override compute_with_override_and_fix compute_with_override_and_powerless_fix compute_with_upstream compute_no_var bar foo2 url host with_tmp_var Upstream-Contact Maintainer Source Source2 Licenses index_function_target test_index_function OtherMaintainer Vcs-Browser/ ], "check available elements" ); my ( $av, $bv, $compute_int ); $av = $root->fetch_element('av'); $bv = $root->fetch_element('bv'); ok( $bv, "created av and bv values" ); ok( $compute_int = $root->fetch_element('compute_int'), "create computed integer value (av + bv)" ); no warnings 'once'; my $parser = new Parse::RecDescent($Config::Model::ValueComputer::compute_grammar); use warnings 'once'; { no warnings qw/once/; $::RD_HINT = 1 if $arg =~ /rdt?h/; $::RD_TRACE = 1 if $arg =~ /rdh?t/; } my $object = $root->fetch_element('one_var'); my $rules = { bar => '- sbv', }; my $srules = { bv => 'rbv' }; my $ref = $parser->pre_value( '$bar', 1, $object, $rules, $srules ); is( $$ref, '$bar', "test pre_compute parser on a very small formula: '\$bar'" ); $ref = $parser->value( '$bar', 1, $object, $rules, $srules ); is( $$ref, undef, "test compute parser on a very small formula with undef variable" ); $root->fetch_element('sbv')->store('bv'); $ref = $parser->value( '$bar', 1, $object, $rules, $srules ); is( $$ref, 'bv', "test compute parser on a very small formula: '\$bar'" ); $ref = $parser->pre_value( '$replace{$bar}', 1, $object, $rules, $srules ); is( $$ref, '$replace{$bar}', "test pre-compute parser with substitution" ); $ref = $parser->value( '$replace{$bar}', 1, $object, $rules, $srules ); is( $$ref, 'rbv', "test compute parser with substitution" ); my $txt = 'my stuff is $bar, indeed'; $ref = $parser->pre_compute( $txt, 1, $object, $rules, $srules ); is( $$ref, $txt, "test pre_compute parser with a string" ); $ref = $parser->compute( $txt, 1, $object, $rules, $srules ); is( $$ref, 'my stuff is bv, indeed', "test compute parser with a string" ); $txt = 'local stuff is element:&element!'; $ref = $parser->pre_compute( $txt, 1, $object, $rules, $srules ); is( $$ref, 'local stuff is element:one_var!', "test pre_compute parser with function (&element)" ); # In fact, function is formula is handled only by pre_compute. $ref = $parser->compute( $txt, 1, $object, $rules, $srules ); is( $$ref, $txt, "test compute parser with function (&element)" ); ## test integer formula my $result = $compute_int->fetch; is( $result, undef, "test that compute returns undef with undefined variables" ); $av->store(1); $bv->store(2); $result = $compute_int->fetch; is( $result, 3, "test result : computed integer is $result (a: 1, b: 2)" ); eval { $compute_int->store(4); }; ok( $@, "test assignment to a computed value (normal error)" ); print "normal error:\n", $@, "\n" if $trace; $result = $compute_int->fetch; is( $result, 3, "result has not changed" ); $bv->store(-2); $result = $compute_int->fetch; is( $result, -1, "test result : computed integer is $result (a: 1, b: -2)" ); ok( $bv->store(4), "change bv value" ); eval { $result = $compute_int->fetch; }; ok( $@, "computed integer: computed value error" ); print "normal error:\n", $@, "\n" if $trace; is( $compute_int->fetch( check => 0 ), undef, "test result : computed integer is undef (a: 1, b: -2)" ); my $s = $root->fetch_element('meet_test'); $result = $s->fetch; is( $result, undef, "test for undef variables in string" ); my ( $as, $bs ) = ( 'Linus', 'his penguin' ); $root->fetch_element('sav')->store($as); $root->fetch_element('sbv')->store($bs); $result = $s->fetch; is( $result, 'meet Linus and his penguin', "test result : computed string is '$result' (a: $as, b: $bs)" ); print "test allow_compute_override\n" if $trace; my $comp_over = $root->fetch_element('compute_with_override'); $bv->store(2); is( $comp_over->fetch, 3, "test computed value" ); $comp_over->store(4); is( $comp_over->fetch, 4, "test overridden value" ); my $cwu = $root->fetch_element('compute_with_upstream'); is( $cwu->fetch, undef, "test computed with upstream value" ); is( $cwu->fetch( mode => 'custom' ), undef, "test computed with upstream value (custom)" ); is( $cwu->fetch( mode => 'standard' ), 3, "test computed with upstream value (standard)" ); $cwu->store(4); is( $cwu->fetch, 4, "test overridden value" ); my $owv = $root->fetch_element('one_wrong_var'); eval { $owv->fetch; }; ok( $@, "expected failure with one_wrong_var" ); print "normal error:\n", $@, "\n" if $trace; my $cnv = $root->fetch_element('compute_no_var'); is( $cnv->fetch, 'compute_no_var', "test compute_no_var" ); my $foo2 = $root->fetch_element('foo2'); my $fen = $foo2->fetch_element('find_node_element_name'); ok( $fen, "created element find_node_element_name" ); is( $fen->fetch, 'foo2', "did find node element name" ); my $cen = $foo2->fetch_element('check_node_element_name'); ok( $cen, "created element check_node_element_name" ); is( $cen->fetch, 1, "did check node element name" ); my $slave_av = $root->fetch_element('bar')->fetch_element('av'); my $slave_bv = $root->fetch_element('bar')->fetch_element('bv'); is( $slave_av->fetch, $av->fetch, "compare slave av and av" ); is( $slave_bv->fetch, $bv->fetch, "compare slave bv and bv" ); $root->fetch_element('url')->store('http://foo.bar/baz.html'); my $h = $root->fetch_element('host'); is( $h->fetch, 'foo.bar', "check extracted host" ); $root->fetch_element( name => 'Maintainer', check => 'no' )->store_set( [qw/foo bar baz/] ); # reset to check if migration is seen as a change to be saved $inst->clear_changes; is( $inst->needs_save, 0, "check needs save before migrate" ); is( $root->grab_value( step => 'Upstream-Maintainer:0', check => 'no' ), 'foo', "check migrate_from first stage" ); is( $root->grab_value( step => 'Upstream-Contact:0' ), 'foo', "check migrate_from second stage" ); is( $inst->needs_save, 2, "check needs save before migrate" ); print join( "\n", $inst->list_changes("\n") ), "\n" if $trace; $root->fetch_element( name => 'Original-Source-Location', check => 'no' )->store('foobar'); is( $root->grab_value( step => 'Source' ), 'foobar', "check migrate_from with undef_is" ); my $v; warning_like { $v = $root->grab_value( step => 'Source2' ); }[ (qr/deprecated/) x 4 ], "check Source2 compute with undef_is"; is( $v, 'foobar', "check result of compute with undef_is" ); foreach (qw/bar foo2/) { my $path = "$_ location_function_in_formula"; is( $root->grab_value($path), $path, "check &location with $path" ); } # test formula with tmp variable my $tmph = $root->fetch_element('with_tmp_var'); is( $tmph->fetch, 'foo.bar', "check extracted host with temp variable" ); my $lic_gpl = $root->grab('Licenses:"GPL-1+"'); is( $lic_gpl->grab_value('text'), "yada yada GPL-1+\nyada yada", "check replacement with &index()" ); is( $root->grab_value('Licenses:PsF text'), "", "check missing replacement with &index()" ); is( $root->grab_value('Licenses:"MPL-1.1" text'), "", "check missing replacement with &index()" ); is( $root->grab_value('Licenses:"MPL-1.1" short_name_from_index'), "MPL-1.1", 'evaled &index($holder)' ); $root->load('index_function_target:foo name=Bond007'); is( $root->grab_value('test_index_function:foo name'), "Bond007 is my name", 'variable with &index(-)' ); $root->load( 'OtherMaintainer="Debian Ruby Extras Maintainers " Source=ruby-pygments.rb' ); is( $root->grab_value("Vcs-Browser"), 'http://anonscm.debian.org/gitweb/?p=pkg-ruby-extras/packages/ruby-pygments.rb.git', 'test compute with complex regexp formula' ); $root->load( 'OtherMaintainer="Debian Perl Group " Source=libconfig-model-perl' ); is( $root->grab_value("Vcs-Browser"), 'http://anonscm.debian.org/gitweb/?p=pkg-perl/packages/libconfig-model-perl.git', 'test compute with complex regexp formula' ); # Debian #810768, test a variable containing quote $root->load( q!OtherMaintainer="Bla Bla O'bla " Source=libconfig-model-perl! ); is( $root->grab_value("Vcs-Browser"), 'http://anonscm.debian.org/gitweb/?p=pkg-perl/packages/libconfig-model-perl.git', 'test compute with complex regexp formula' ); my $cwoaf = $root->fetch_element('compute_with_override_and_fix'); is($cwoaf->fetch, 'def value', "test compute_with_override_and_fix default value"); warning_like {$cwoaf->store('oops') ; }[ qr/not default value/], "check warning with modified compute_with_override_and_fix"; $cwoaf->apply_fixes; is($cwoaf->fetch, 'def value', "test compute_with_override_and_fix value after fix"); my $cwoapf = $root->fetch_element('compute_with_override_and_powerless_fix'); warning_like { $cwoapf->apply_fixes;} [ qr/not good value/], "check warning when applying powerless fix"; is($cwoapf->fetch, '/dev/lcd0', "test default value after powerless fix"); memory_cycle_ok( $model, "test memory cycles" ); done_testing; augment_class.t100644001750001750 754312676543661 16422 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Memory::Cycle; use Test::Differences; use Config::Model; use Data::Dumper; use Log::Log4perl qw(:easy :levels); BEGIN { plan tests => 8; } use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new(); $model->create_config_class( name => "Master", accept => [ '.*' => { type => 'leaf', value_type => 'uniline', } ], element => [ one => { type => 'leaf', value_type => 'string', }, fs_vfstype => { type => 'leaf', value_type => 'enum', choice => [qw/auto ext2 ext3/], }, fs_mntopts => { type => 'warped_node', follow => { 'f1' => '- fs_vfstype' }, rules => [ '$f1 eq \'auto\'', { 'config_class_name' => 'Fstab::CommonOptions' }, '$f1 eq \'ext2\'', { 'config_class_name' => 'Fstab::Ext2FsOpt' }, '$f1 eq \'ext3\'', { 'config_class_name' => 'Fstab::Ext3FsOpt' }, ], } ] ); $model->create_config_class( name => "Two", element => [ two => { type => 'leaf', value_type => 'string', }, ] ); $model->augment_config_class( name => "Master", include => 'Two', include_after => 'fs_mntopts', accept => [ '.*' => { description => "catchall" }, 'ip.*' => { type => 'leaf', value_type => 'uniline', } ], element => [ three => { type => 'leaf', value_type => 'string', }, fs_vfstype => { choice => [qw/ext4/], }, fs_mntopts => { rules => [ q!$f1 eq 'ext4'!, { 'config_class_name' => 'Fstab::Ext4FsOpt' }, ], }, ] ); # augment a class which is inherited $model->augment_config_class( name => "Two", element => [ two_and_a_half => { type => 'leaf', value_type => 'string', }, ] ); # use Tk::ObjScanner; Tk::ObjScanner::scan_object($model) ; my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $augmented_model = $model->get_model('Master'); print Dumper ($augmented_model) if $trace; my @elt = $root->get_element_name(); print "element list: @elt\n" if $trace; eq_or_diff( \@elt, [qw/one fs_vfstype two two_and_a_half three/], "check augmented class" ); my $fstype = $root->fetch_element('fs_vfstype'); my @fs_choices = $fstype->get_choice; eq_or_diff( \@fs_choices, [qw/auto ext2 ext3 ext4/], "check augmented choices" ); eq_or_diff( $augmented_model->{element}{fs_mntopts}{rules}, [ '$f1 eq \'auto\'', { 'config_class_name' => 'Fstab::CommonOptions' }, '$f1 eq \'ext2\'', { 'config_class_name' => 'Fstab::Ext2FsOpt' }, '$f1 eq \'ext3\'', { 'config_class_name' => 'Fstab::Ext3FsOpt' }, '$f1 eq \'ext4\'', { 'config_class_name' => 'Fstab::Ext4FsOpt' } ], "test augmented rules" ); eq_or_diff( $augmented_model->{accept_list}, [ '.*', 'ip.*' ], "test accept_list" ); is( $augmented_model->{accept}{'.*'}{description}, 'catchall', "test augmented rules" ); memory_cycle_ok($model); describe_node.t100644001750001750 602212676543661 16351 0ustar00domidomi000000000000Config-Model-2.082/tuse ExtUtils::testlib; use Test::More tests => 9; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Config root created" ); my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata" ' . 'hash_a:toto=toto_value hash_a:titi=titi_value ' . 'lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - listb=b,c,d ' . 'my_check_list=toto my_reference="titi"'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); my $description = $root->describe; $description =~ s/\s*\n/\n/g; print "description string:\n$description" if $trace; my $expect = <<'EOF' ; name value type comment std_id node hash keys: "ab" "bc" lista a,b,c,d list listb b,c,d list hash_a:titi titi_value string hash_a:toto toto_value string hash_b [empty hash] value hash ordered_hash [empty hash] value hash olist node list indexes: 0 1 tree_macro [undef] enum choice: XY XZ mXY warp node slave_y node string_with_def "yada yada" string a_uniline "yada yada" uniline a_string "toto tata" string mandatory int_v 10 integer my_check_list toto check_list my_reference titi reference EOF is( $description, $expect, "check root description " ); $description = $root->grab('std_id:ab')->describe(); $description =~ s/\s*\n/\n/g; print "description string:\n$description" if $trace; $expect = <<'EOF' ; name value type comment Z [undef] enum choice: Av Bv Cv X Bv enum choice: Av Bv Cv DX Dv enum choice: Av Bv Cv Dv EOF is( $description, $expect, "check std_id:ab description " ); $expect = <<'EOF' ; name value type comment std_id node hash keys: "ab" "bc" EOF $description = $root->describe( element => 'std_id' ); $description =~ s/\s*\n/\n/g; print "description string:\n$description" if $trace; is( $description, $expect, "check root description of std_id" ); $expect = <<'EOF' ; name value type comment hash_a:titi titi_value string hash_a:toto toto_value string hash_b [empty hash] value hash EOF $description = $root->describe( pattern => qr/^hash_/ ); $description =~ s/\s*\n/\n/g; print "description string:\n$description" if $trace; is( $description, $expect, "check root description of std_id" ); memory_cycle_ok($model); gen-class-doc.t100644001750001750 153612676543661 16210 0ustar00domidomi000000000000Config-Model-2.082/tuse ExtUtils::testlib; use Test::More tests => 5; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); $model->load( 'Master', 't/big_model.pm' ); ok( 1, "big_model loaded" ); my $res = $model->get_model_doc('Master'); is_deeply( [ sort keys %$res ], [ map { "Config::Model::models::$_" } qw/Master SlaveY SlaveZ SubSlave SubSlave2/ ], "check doc classes" ); like( $res->{'Config::Model::models::Master'}, qr/Configuration class Master/, "check that doc is generated" ); memory_cycle_ok($model); README.install.pod100644001750001750 172512676543661 16247 0ustar00domidomi000000000000Config-Model-2.082=head1 Installation =head2 Debian or Ubuntu L is provided as Debian package. Just type sudo apt-get install libconfig-model-perl Or use your favorite installer =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 L on Fedora is severely oudated. See below for installation. =head2 Other systems For other systems, you should install L from CPAN: cpanp install Config::Modelvalue_refer_to.t100644001750001750 1530012676543661 16604 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::Warn; use Test::More ; use Test::Memory::Cycle; use Test::Exception; use Config::Model; use Log::Log4perl qw(:easy :levels); use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => 'Host', 'element' => [ if => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'If', }, trap => { type => 'leaf', value_type => 'string' } ] ); $model->create_config_class( name => 'If', element => [ ip => { type => 'leaf', value_type => 'string' } ] ); $model->create_config_class( name => 'Lan', element => [ node => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'Node', }, ] ); $model->create_config_class( name => 'Node', element => [ host => { type => 'leaf', value_type => 'reference', refer_to => '! host' }, if => { type => 'leaf', value_type => 'reference', refer_to => [ ' ! host:$h if ', h => '- host' ] }, ip => { type => 'leaf', value_type => 'string', compute => [ '$ip', ip => '! host:$h if:$card ip', h => '- host', card => '- if' ] } ] ); $model->create_config_class( name => 'Master', element => [ host => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'Host' }, lan => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'Lan' }, host_reference => { type => 'leaf', value_type => 'reference', refer_to => ['! host '], }, host_and_choice => { type => 'leaf', value_type => 'reference', refer_to => ['! host '], choice => [qw/foo bar/] }, host_and_replace => { type => 'leaf', value_type => 'reference', refer_to => ['! host '], replace => { 'fou' => 'Foo', 'barre' => 'Bar' }, }, dumb_list => { type => 'list', cargo_type => 'leaf', cargo_args => { value_type => 'string' } }, refer_to_list_enum => { type => 'leaf', value_type => 'reference', refer_to => '- dumb_list', }, refer_to_wrong_path => { type => 'leaf', value_type => 'reference', refer_to => '! unknown_class unknown_elt', }, refer_to_unknown_elt => { type => 'leaf', value_type => 'reference', refer_to => '! unknown_elt', }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Created Root" ); $root->load( ' host:A if:eth0 ip=10.0.0.1 - if:eth1 ip=10.0.1.1 - - host:B if:eth0 ip=10.0.0.2 - if:eth1 ip=10.0.1.2 - - ' ); ok( 1, "host setup done" ); my $node = $root->grab('lan:A node:1'); ok( $node, "got lan:A node:1" . $node->name ); $node->load('host=A'); is( $node->grab_value('host'), 'A', "setup host=A" ); $node->load('if=eth0'); is( $node->grab_value('if'), 'eth0', "set up if=eth0 " ); # magic is( $node->grab_value('ip'), '10.0.0.1', "got ip 10.0.0.1" ); $root->load( ' lan:A node:2 host=B if=eth0 - - lan:B node:1 host=A if=eth1 - node:2 host=B if=eth1 - - ' ); ok( 1, "lan setup done" ); is( $root->grab_value('lan:A node:1 ip'), '10.0.0.1', "got ip 10.0.0.1" ); is( $root->grab_value('lan:A node:2 ip'), '10.0.0.2', "got ip 10.0.0.2" ); is( $root->grab_value('lan:B node:1 ip'), '10.0.1.1', "got ip 10.0.1.1" ); is( $root->grab_value('lan:B node:2 ip'), '10.0.1.2', "got ip 10.0.1.2" ); #print distill_root( object => $root ); #print dump_root( object => $root ); my $hac = $root->fetch_element('host_and_choice'); is_deeply( [ $hac->get_choice ], [ 'A', 'B', 'bar', 'foo' ], "check that default choice and refer_to add up" ); # choice needs to be recomputed for references $root->load("host~B"); is_deeply( [ $hac->get_choice ], [ 'A', 'bar', 'foo' ], "check that default choice and refer_to follow removed elements" ); # test reference to list values $root->load("dumb_list=a,b,c,d,e"); my $rtle = $root->fetch_element("refer_to_list_enum"); is_deeply( [ $rtle->get_choice ], [qw/a b c d e/], "check choice of refer_to_list_enum" ); throws_ok { $root->fetch_element("refer_to_wrong_path"); } 'Config::Model::Exception::Model',"fetching refer_to_wrong_path" ; throws_ok { $root->fetch_element("refer_to_unknown_elt") } 'Config::Model::Exception::Model',"fetching refer_to_unknown_elt" ; warning_like { $root->fetch_element("host_reference")->store(value => 'Foo', check => 'skip') } qr/skipping value/,"store unknown host (skip mode)"; throws_ok { $root->fetch_element("host_reference")->store('Foo') } "Config::Model::Exception::WrongValue","store unknown host (failure mode)"; $root->load("host:Foo - host:Bar"); $root->fetch_element("host_reference")->store('Foo'); ok(scalar $root->fetch_element("host_reference")->check, "check reference to Foo host"); $root->load("host_and_replace=fou"); is($root->grab_value("host_and_replace"),'Foo',"check replaced host fou->Foo"); $root->load("host~Foo"); ok( !$root->fetch_element("host_reference")->check, "check reference to removed Foo host"); # todo: need an exclude parameter (to avoid cycle in config_class_name) memory_cycle_ok($model,"test memory cycle"); done_testing; search_element.t100644001750001750 4223312676543661 16566 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 24; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; use Data::Dumper; # use Config::Model::ObjTreeScanner; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; $Data::Dumper::Indent = 1; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "created root" ); Config::Model::Exception::Any->Trace(1) if $trace =~ /e/; my @data = ( [ 'Z', "std_id:foo", { 'Z' => { 'next_step' => { 'Z' => '' } }, 'X' => { 'next_step' => { 'X' => '' } }, 'DX' => { 'next_step' => { 'DX' => '' } } } ], [ 'ab2', 'warp', { 'ab2' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ab2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ab2' => '' } } } } } }, 'aa2' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'aa2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'aa2' => '' } } } } } }, 'X' => { 'next_step' => { 'X' => '', 'std_id' => { 'next_step' => { 'X' => '' } } } }, 'ac' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ac' => '' } } } }, 'Y' => { 'next_step' => { 'Y' => '' } }, 'DX' => { 'next_step' => { 'std_id' => { 'next_step' => { 'DX' => '' } } } }, 'Z' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'Z' => '' } } } }, 'std_id' => { 'next_step' => { 'Z' => '' } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'Z' => '' } } } } } }, 'ab' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ab' => '' } } } }, 'ad2' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ad2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ad2' => '' } } } } } }, 'ad' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ad' => '' } } } }, 'aa' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'aa' => '' } } } }, 'ac2' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ac2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ac2' => '' } } } } } } } ], [ 'Z', '!', { 'string_with_def' => { 'next_step' => { 'string_with_def' => '' } }, 'aa2' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'aa2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'aa2' => '' } } } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'aa2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'aa2' => '' } } } } } } } } } }, 'Y' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'Y' => '' } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'Y' => '' } } } } } }, 'DX' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'std_id' => { 'next_step' => { 'DX' => '' } } } }, 'olist' => { 'next_step' => { 'DX' => '' } }, 'warp' => { 'next_class' => { 'SlaveZ' => { 'next_step' => { 'DX' => '' } }, 'SlaveY' => { 'next_step' => { 'std_id' => { 'next_step' => { 'DX' => '' } } } } } }, 'std_id' => { 'next_step' => { 'DX' => '' } } } }, 'Z' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'Z' => '' } } } }, 'std_id' => { 'next_step' => { 'Z' => '' } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'Z' => '' } } } } } }, 'olist' => { 'next_step' => { 'Z' => '' } }, 'warp' => { 'next_class' => { 'SlaveZ' => { 'next_step' => { 'Z' => '' } }, 'SlaveY' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'Z' => '' } } } }, 'std_id' => { 'next_step' => { 'Z' => '' } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'Z' => '' } } } } } } } }, 'std_id' => { 'next_step' => { 'Z' => '' } } } }, 'ad2' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ad2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ad2' => '' } } } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ad2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ad2' => '' } } } } } } } } } }, 'tree_macro' => { 'next_step' => { 'tree_macro' => '' } }, 'a_string' => { 'next_step' => { 'a_string' => '' } }, 'ad' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ad' => '' } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ad' => '' } } } } } } } }, 'ordered_hash' => { 'next_step' => { 'ordered_hash' => '' } }, 'aa' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'aa' => '' } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'aa' => '' } } } } } } } }, 'ac2' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ac2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ac2' => '' } } } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ac2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ac2' => '' } } } } } } } } } }, 'lista' => { 'next_step' => { 'lista' => '' } }, 'hash_b' => { 'next_step' => { 'hash_b' => '' } }, 'ab2' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ab2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ab2' => '' } } } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'warp2' => { 'next_class' => { 'SubSlave2' => { 'next_step' => { 'ab2' => '' } } } }, 'sub_slave' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ab2' => '' } } } } } } } } } }, 'int_v' => { 'next_step' => { 'int_v' => '' } }, 'listb' => { 'next_step' => { 'listb' => '' } }, 'my_reference' => { 'next_step' => { 'my_reference' => '' } }, 'X' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'X' => '', 'std_id' => { 'next_step' => { 'X' => '' } } } }, 'olist' => { 'next_step' => { 'X' => '' } }, 'warp' => { 'next_class' => { 'SlaveZ' => { 'next_step' => { 'X' => '' } }, 'SlaveY' => { 'next_step' => { 'X' => '', 'std_id' => { 'next_step' => { 'X' => '' } } } } } }, 'std_id' => { 'next_step' => { 'X' => '' } } } }, 'ac' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ac' => '' } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ac' => '' } } } } } } } }, 'a_uniline' => { 'next_step' => { 'a_uniline' => '' } }, 'ab' => { 'next_step' => { 'slave_y' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ab' => '' } } } }, 'warp' => { 'next_class' => { 'SlaveY' => { 'next_step' => { 'sub_slave' => { 'next_step' => { 'ab' => '' } } } } } } } }, 'my_check_list' => { 'next_step' => { 'my_check_list' => '' } }, 'hash_a' => { 'next_step' => { 'hash_a' => '' } } } ] ); my @items = $root->model_searcher->get_searchable_elements; my @expected = qw/DX X Y Z a_string a_uniline aa aa2 ab ab2 ac ac2 ad ad2 hash_a hash_b int_v lista listb my_check_list my_reference ordered_hash string_with_def tree_macro/; is_deeply( \@items, \@expected, "list of searchable items" ); foreach my $item (@data) { next unless @$item == 3; my $node = $root->grab( $item->[1] ); my $model_searcher = $node->model_searcher->prepare( element => $item->[0] ); is_deeply( $model_searcher->{data}, $item->[2], "verify search data on " . $node->config_class_name . "($item->[0],$item->[1])" ) || print Dumper $model_searcher->{data}; } my $model_searcher = $root->model_searcher->prepare( element => 'X' ); $root->load("tree_macro=XZ"); my $step = $model_searcher->next_step(); is_deeply( $step, [qw/olist slave_y std_id warp/], 'check first step' ); my $obj = $model_searcher->choose('warp'); is( $obj->name, 'warp', 'check chosen object' ); my $target = $model_searcher->auto_choose( sub { }, sub { } ); is( $target->name, 'warp X', 'check auto chosen object for X' ); $step = $model_searcher->next_step(); is_deeply( $step, [], 'check that no more steps are left' ); # no user choice to look for aa $root->load("tree_macro=XY"); $model_searcher = $root->model_searcher->prepare( element => 'aa' ); $model_searcher->choose('warp'); $target = $model_searcher->auto_choose( sub { }, sub { } ); is( $target->name, 'warp sub_slave aa', 'check auto chosen object for aa' ); # try choose_next $model_searcher = $root->model_searcher->prepare( element => 'aa' ); $model_searcher->choose('warp'); $step = $model_searcher->next_choice(); is_deeply( $step, [], 'check that no more steps are left after next_choice' ); $target = $model_searcher->current_object; is( $target->name, 'warp sub_slave aa', 'check chosen object for aa' ); $model_searcher = $root->model_searcher->prepare( element => 'DX' ); $root->load("tree_macro=XZ"); my $cb1 = sub { my $object = shift; is( $object->config_class_name, 'Master', 'check object of element call-back (DX))' ); is_deeply( [@_], [qw/olist slave_y std_id warp/], 'check param of element call-back (DX)' ); return 'warp'; }; $target = $model_searcher->auto_choose( $cb1, sub { } ); is( $target->name, 'warp DX', 'check auto chosen object for DX (warp)' ); # restart and try through olist $model_searcher->reset; $target = $model_searcher->auto_choose( sub { 'olist' }, sub { return 1; } ); is( $target->name, 'olist:1 DX', 'check auto_choose target for DX (olist)' ); # restart and try through std_d $model_searcher->reset; $target = $model_searcher->auto_choose( sub { 'std_id' }, sub { return 'foo'; } ); is( $target->name, 'std_id:foo DX', 'check auto_choose target for DX (std_id)' ); # restart and try through std_d with next_choice $model_searcher->reset; $step = $model_searcher->next_choice(); is_deeply( $step, [qw/olist slave_y std_id warp/], 'next_choice 1' ); $model_searcher->choose('std_id'); ok( 1, "std_id choice done" ); #print $root->dump_tree(full_dump =>1) ; $step = $model_searcher->next_choice(); is_deeply( $step, [], 'next_choice 2' ); is( $model_searcher->current_object->name, 'std_id:foo DX', 'next_choice target' ); memory_cycle_ok($model); search_in_tree.t100644001750001750 367012676543661 16544 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy); use warnings; use strict; my $arg = shift; $arg = '' unless defined $arg; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } my $model = Config::Model->new( legacy => 'ignore', ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata" ' . 'hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy my_check_list=X2,X3 ' . 'olist:0 DX=Dv'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); my @tests = ( [qw/value toto a_string/], [qw/value tot a_string/], [qw/key ab std_id:ab/], [qw/value xy hash_a:Y2 hash_b:X3/], [ qw/description zorro/, 'warp sub_slave sub_slave Z','warp warp2 sub_slave Z', 'slave_y sub_slave sub_slave Z', 'slave_y warp2 sub_slave Z' ], [ qw/value Bv/, 'std_id:ab X' ], [ qw/value B/, 'std_id:ab X' ], [ qw/value Dv/, 'std_id:ab DX', 'std_id:bc DX', 'olist:0 DX' ], [ qw/value X3/, 'my_check_list' ], ); foreach my $ref (@tests) { my ( $type, $string, @expected ) = @$ref; my $searcher = $root->tree_searcher( type => $type ); my @res = $searcher->search($string); eq_or_diff( \@res, \@expected, "searched for $type $string" ); print "\treturned '", join( "', '", @res ), "'\n" if $trace; } memory_cycle_ok($model); done_testing; pod_generation.t100644001750001750 240712676543661 16564 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 8; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy); use File::Path; use warnings; no warnings qw(once); use strict; # pseudo root where config files are written by config-model my $wr_root = 'wr_root'; # cleanup before tests rmtree($wr_root); mkpath( $wr_root, { mode => 0755 } ); my $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; my $log = $arg =~ /l/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); $model->generate_doc('Master') if $trace; $model->generate_doc( 'Master', $wr_root ); map { ok( -r "wr_root/Config/Model/models/$_", "Found doc $_" ); } qw /Master.pod SlaveY.pod SlaveZ.pod SubSlave2.pod SubSlave.pod/; memory_cycle_ok($model); smooth_upgrade.t100644001750001750 1335712676543661 16635 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More tests => 22; use Test::Exception; use Test::Warn; use Test::Memory::Cycle; use Config::Model; use Config::Model::Value; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => "Master", 'element' => [ # obsolete element cannot be used at all 'obsolete_p' => { type => 'leaf', value_type => 'enum', choice => [qw/cds perl ini custom/], status => 'obsolete', description => 'obsolete_p is replaced by non_obso', }, 'deprecated_p' => { type => 'leaf', value_type => 'enum', choice => [qw/cds perl ini custom/], status => 'deprecated', description => 'deprecated_p is replaced by new_from_deprecated', }, 'new_from_deprecated' => { type => 'leaf', value_type => 'enum', choice => [qw/cds_file perl_file ini_file augeas custom/], migrate_from => { formula => '$replace{$old}', variables => { old => '- deprecated_p' }, replace => { perl => 'perl_file', ini => 'ini_file', cds => 'cds_file', }, }, }, 'hidden_p' => { type => 'leaf', value_type => 'enum', choice => [qw/cds perl ini custom/], level => 'hidden', description => 'hidden_p is replaced by new_from_hidden', }, ] ); $model->create_config_class( name => "UrlMigration", 'element' => [ 'old_url' => { type => 'leaf', value_type => 'uniline', status => 'deprecated', }, 'host' => { type => 'leaf', value_type => 'uniline', mandatory => 1, migrate_from => { formula => '$old =~ m!http://([\w\.]+)!; $1 ;', variables => { old => '- old_url' }, use_eval => 1, }, }, 'port' => { type => 'leaf', value_type => 'uniline', migrate_from => { formula => '$old =~ m!http://[\w\.]+:(\d+)!; $1 ;', variables => { old => '- old_url' }, use_eval => 1, }, }, 'path' => { type => 'leaf', value_type => 'uniline', migrate_from => { formula => '$old =~ m!http://[\w\.]+(?::\d+)?(/.*)!; $1 ;', variables => { old => '- old_url' }, use_eval => 1, }, }, ], ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; # emulate start of file read $inst->initial_load_start; throws_ok { $root->fetch_element('obsolete_p'); } 'Config::Model::Exception::ObsoleteElement', 'tried to fetch obsolete element'; my $dp; warning_like { $dp = $root->fetch_element('deprecated_p'); } qr/Element 'deprecated_p' of node 'Master' is deprecated/, "check warning when fetching deprecated element"; my $nfd = $root->fetch_element('new_from_deprecated'); is( $nfd->fetch, undef, "undef old and undef new" ); # does not generate a warning $dp->store('ini'); $inst->initial_load_stop; is( $nfd->fetch, 'ini_file', "old is 'ini' and new is 'ini_file'" ); is( $nfd->fetch_custom, 'ini_file', "likewise for custom_value" ); is( $nfd->fetch('non_upstream_default'), 'ini_file', "likewise for non_builtin_default" ); is( $nfd->fetch_standard, undef, "but standard value is undef" ); # check element list is_deeply( [ $root->get_element_name ], [qw/new_from_deprecated/], "check that deprecated and obsolete parameters are hidden" ); is( $root->dump_tree, "new_from_deprecated=ini_file -\n", "check dump tree" ); # now override the migrated value $nfd->store('perl_file'); is( $nfd->fetch, 'perl_file', "overridden value is 'perl_file'" ); is( $nfd->fetch_custom, 'perl_file', "likewise for custom_value" ); is( $nfd->fetch('non_upstream_default'), 'perl_file', "likewise for non_builtin_default" ); is( $nfd->fetch_standard, undef, "but standard value is undef" ); # test migration with regexp value my $uinst = $model->instance( root_class_name => 'UrlMigration', instance_name => 'urltest' ); ok( $uinst, "created url test instance" ); my $uroot = $uinst->config_root; # emulate start of file read $uinst->initial_load_start; my $host = 'foo.gre.hp.com'; my $port = 2345; my $path = '/bar/baz.html'; my $url = "http://$host:$port$path"; # check element list is_deeply( [ $uroot->get_element_name ], [qw/host port path/], "check that url deprecated and obsolete parameters are hidden" ); warning_like { $dp = $uroot->fetch_element('old_url')->store($url); } qr/Element 'old_url' of node 'UrlMigration' is deprecated/, "check warning when fetching deprecated element"; $uinst->initial_load_stop; my $h = $uroot->fetch_element('host'); is( $h->fetch, $host, "check extracted host" ); is( $uroot->fetch_element('port')->fetch, $port, "check extracted port" ); is( $uroot->fetch_element('path')->fetch, $path, "check extracted path" ); memory_cycle_ok( $model, "test memory cycles" ); lib000755001750001750 012676543661 14005 5ustar00domidomi000000000000Config-Model-2.082/tDummyNode.pm100644001750001750 46312676543661 16367 0ustar00domidomi000000000000Config-Model-2.082/t/lib# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package DummyNode; use base qw/Config::Model::Node/; sub dummy { $_[1]++; } 1; Config000755001750001750 012676543661 14747 5ustar00domidomi000000000000Config-Model-2.082/libModel.pm100644001750001750 23520512676543661 16554 0ustar00domidomi000000000000Config-Model-2.082/lib/Config# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model; $Config::Model::VERSION = '2.082'; use strict ; use warnings; use 5.10.1; 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 File::Path qw/make_path/; # this class holds the version number of the package use vars qw(@status @level %default_property); my $legacy_logger = get_logger("Model::Legacy") ; my $logger = get_logger("Model") ; %default_property = ( status => 'standard', level => 'normal', summary => '', description => '', ); 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 { {} } ); # 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) has raw_models => ( isa => 'HashRef', is => 'ro', default => sub { {} }, traits => ['Hash'], handles => { raw_model_exists => 'exists', raw_model_defined => 'defined', raw_model => 'get', store_raw_model => 'set', raw_model_names => 'keys', }, ); sub get_raw_model { my $self = shift; return $self->raw_model(@_); } # 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', model => 'get', _store_model => 'set', }, ); 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; } ); around BUILDARGS => sub { my $orig = shift; my $class = shift; my %args = @_; my %new = map { defined $args{$_} ? ( $_ => $args{$_} ) : () } keys %args; 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 { my $log4perl_syst_conf_file = '/etc/log4config-model.conf'; my $log4perl_user_conf_file = $ENV{HOME} . '/.log4config-model'; my $fallback_conf = << 'EOC'; log4perl.logger=WARN, Screen log4perl.appender.Screen = Log::Log4perl::Appender::Screen log4perl.appender.Screen.stderr = 0 log4perl.appender.Screen.layout = Log::Log4perl::Layout::PatternLayout log4perl.appender.Screen.layout.ConversionPattern = %d %m %n EOC my $log4perl_conf = -e $log4perl_user_conf_file ? $log4perl_user_conf_file : -e $log4perl_syst_conf_file ? $log4perl_syst_conf_file : \$fallback_conf; Log::Log4perl::init_once($log4perl_conf); } sub BUILD { my $self = shift; $self->initialize_log4perl ; } sub show_legacy_issue { my $self = shift; my $behavior = $self->legacy; if ( $behavior eq 'die' ) { die @_, "\n"; } elsif ( $behavior eq 'warn' ) { warn @_, "\n"; } } sub instance { my $self = shift; my %args = @_; my $instance_name = delete $args{instance_name} || delete $args{name} || 'default'; # could add more syntactic suger with 'hash' trait # see Moose::Meta::Attribute::Native if ( defined $self->instances->{$instance_name} ) { return $self->instances->{$instance_name}; } my $root_class_name = delete $args{root_class_name} or croak "Model: can't create instance without root_class_name "; if ( defined $args{model_file} ) { my $file = delete $args{model_file}; $self->load( $root_class_name, $file ); } my $i = Config::Model::Instance->new( config_model => $self, root_class_name => $root_class_name, name => $instance_name, %args # for optional parameters like *directory ); $self->instances->{$instance_name} = $i; return $i; } sub instance_names { my $self = shift; return sort keys %{ $self->instances }; } @level = qw/hidden normal important/; @status = qw/obsolete deprecated standard/; # 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 read_config_dir write_config write_config_dir/, # 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 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 { my $self = shift; my %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($included_class); foreach my $rw (qw/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}; } } } } 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); } # optional parameter to force element order. Useful when parameters declarations # are grouped. Although interaction with include may be tricky. Let's not advertise it. # yet. if ( defined $normalized_model->{force_element_order} ) { my @forced_list = @{ delete $normalized_model->{force_element_order} }; my %forced = map { ( $_ => 1 ) } @forced_list; foreach (@element_list) { next if delete $forced{$_}; Config::Model::Exception::ModelDeclaration->throw( error => "class $config_class_name: element $_ is not in force_element_order list" ); } if (%forced) { Config::Model::Exception::ModelDeclaration->throw( error => "class $config_class_name: force_element_order list has unknown elements " . join( ' ', keys %forced ) ); } } 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}; } # get data read/write information (if any) $model->{read_config_dir} = $model->{write_config_dir} = delete $normalized_model->{config_dir} if defined $normalized_model->{config_dir}; foreach my $info (@legal_params_to_move) { next unless defined $normalized_model->{$info}; $model->{$info} = delete $normalized_model->{$info}; } # 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} || '.*'; warn "class $config_class_name: name_match ($implicit$name_match)", " in accept is deprecated\n"; } 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; map { $check_list{$_}++ } @element_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 map { $model->{element}{$_} = dclone($info); } @element_names; } # 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"; } } sub translate_legacy_info { my $self = shift; my $config_class_name = shift || die; my $elt_name = shift; my $info = shift; #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} and defined $info->{cargo}{warp} ) { $self->translate_warp_info( $config_class_name, $elt_name, $info->{cargo}{type}, $info->{cargo}{warp} ); } if ( defined $info->{cargo} && defined $info->{cargo}{type} && $info->{cargo}{type} eq 'warped_node' ) { $self->translate_warp_info( $config_class_name, $elt_name, 'warped_node', $info->{cargo} ); } if ( defined $info->{type} && $info->{type} eq 'warped_node' ) { $self->translate_warp_info( $config_class_name, $elt_name, 'warped_node', $info ); } # 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; } 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; } 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' ); $self->translate_name( $config_class_name, $elt_name, $info, 'allow_from', 'allow_keys_from' ); $self->translate_name( $config_class_name, $elt_name, $info, 'follow', 'follow_keys_from' ); } sub translate_name { my $self = shift; my $config_class_name = shift; my $elt_name = shift; my $info = shift; my $from = shift; my $to = shift; if ( defined $info->{$from} ) { $self->show_legacy_issue( "$config_class_name->$elt_name: parameter $from is deprecated in favor of $to"); $info->{$to} = delete $info->{$from}; } } 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}; } } 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; map { $replace_h = delete $var{$_} if ref( $var{$_} ) } keys %var; # cleanup user formula $user_formula =~ s/\$(\w+){/\$replace{/g; # cleanup variable map { s/\$(\w+){/\$replace{/g } values %var; # 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; } } 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; } # 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; } # 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; } 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}; } } # 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; } # 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; map { $follow->{ 'f' . $idx++ } = $_ } @$raw_follow; return $follow; } elsif ( defined $raw_follow ) { # follow is a simple 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 simple 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; } 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; } 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 ); } } 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')->info("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($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')->info("class $class_name include $include_class done"); } # 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 my $load_path = $model_name; $load_path =~ s/::/\//g; $load_file ||= $self->model_dir . '/' . $load_path . '.pl'; get_logger("Model::Loader")->debug("model $model_name from file $load_file"); # no special treatment, returns an array my %models_by_name; my @loaded_classes = $self->_load_model_in_hash( \%models_by_name, $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} ); get_logger("Model::Loader")->debug("Store normalized model $name"); $self->store_normalized_model( $name, $data ); } # 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 (@INC) { foreach my $name ( keys %models_by_name ) { my $snippet_path = $name; $snippet_path =~ s/::/\//g; my $snippet_dir = "$inc/" . $self->model_dir . '/' . $snippet_path . '.d'; get_logger("Model::Loader")->trace("looking for snippet in $snippet_dir"); if ( -d $snippet_dir ) { foreach my $snippet_file ( glob("$snippet_dir/*.pl") ) { my $done_key = $name . ':' . $snippet_file; next if $done{$done_key}; get_logger("Model::Loader")->info("Found snippet $snippet_file"); $self->_load_model_in_hash( \%model_graft_by_name, $snippet_file ); $done{$done_key} = 1; } } } } foreach my $class_to_merge ( keys %model_graft_by_name ) { my $data = $model_graft_by_name{$class_to_merge}; $self->augment_config_class_really( $class_to_merge, $data ); } # 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 _load_model_in_hash { my ( $self, $hash_ref, $load_file ) = @_; my $model = $self->_do_model_file($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; } # # New subroutine "_do_model_file" extracted - Sun Nov 28 17:25:35 2010. # sub _do_model_file { my ( $self, $load_file ) = @_; get_logger("Model::Loader")->info("load model $load_file"); my $err_msg = ''; 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 ); } 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, $augment_data ); my $new_model = 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 ); } sub get_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) ) { get_logger("Model::Loader")->debug("creating model $config_class_name"); my $model = $self->merge_included_class($config_class_name); $self->_store_model( $config_class_name, $model ); } my $model = $self->model($config_class_name) || croak "get_model error: unknown config class name: $config_class_name"; return dclone($model); } sub get_model_doc { my ( $self, $top_class_name ) = @_; if ( not defined $self->normalized_model($top_class_name) ) { croak "get_model_doc error : unknown config class name: $top_class_name"; } my @classes = ($top_class_name); my %result; while (@classes) { my $class_name = shift @classes; next if defined $result{$class_name}; my $c_model = $self->get_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, # 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'", ''; } } } 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"; } 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 ( $migr->{use_eval} ) { $mform =~ s/^/ /mg; $mform = "\n\n$mform\n\n"; } else { $mform = "'C<$mform>' " } my $mdoc = "Note: $elt_name $desc ${mform}and with " . join( ", ", map { qq!\$$_ => "C<$mv->{$_}>"! } sort keys %$mv ); if ( my $rep = $migr->{replace} ) { $mdoc .= ' and ' . join( ", ", map { qq!'C<\$replace{$_}>' => "C<$rep->{$_}>"! } sort keys %$rep ); } 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$/; } if ( my $status = $elt_info->{status} ) { $desc .= 'B<' . ucfirst($status) . '> '; } my $info = $elt_info->{mandatory} ? 'Mandatory. ' : 'Optional. '; $info .= "Type " . ( $vt || $type ) . $of . '. '; foreach (qw/choice default upstream_default/) { my $item = $elt_info->{$_}; next unless defined $item; my @list = ref($item) ? @$item : ($item); $info .= "$_: '" . join( "', '", @list ) . "'. "; } my $elt_help = $self->get_element_value_help($elt_info); return $desc . "I<< $info >> " . $elt_help; } 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 ) = @_; my $res = $self->get_model_doc($top_class_name); my @wrote; if ( defined $dir and $dir ) { foreach my $class_name ( sort keys %$res ) { my $file = $class_name; $file =~ s!::!/!g; my $pl_file = $dir . "/$file.pl"; my $pod_file = $dir . "/$file.pod"; my $pod_dir = $pod_file; $pod_dir =~ s!/[^/]+$!!; make_path( $pod_dir, { mode => 0755 } ) unless -d $pod_dir; # -M returns age of file, not date or epoch. hence greater is older my $old = ''; if ( -e $pod_file ) { my $fh = IO::File->new( $pod_file, 'r' ) || die "Can't open $pod_file: $!"; $old = join( '', $fh->getlines ); $fh->close; } if ( $old ne $res->{$class_name} ) { my $fh = IO::File->new( $pod_file, 'w' ) || die "Can't open $pod_file: $!"; $fh->binmode(":utf8"); $fh->print( $res->{$class_name} ); $fh->close; print "Wrote documentation in $pod_file\n"; push @wrote, $pod_file; } } } else { foreach my $class_name ( sort keys %$res ) { print "########## $class_name ############ \n\n"; print $res->{$class_name}; } } return @wrote; } 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->get_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 { my $self = shift; my %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->get_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} || $default_property{level}; push @result, $elt if $l ne 'hidden' ; } return wantarray ? @result : join( ' ', @result ); } sub get_element_property { my $self = shift; my %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} || $default_property{$prop} if $elt =~ /^$acc_re$/; } } return $self->model($class)->{element}{$elt}{$prop} || $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: Create tools to validate, migrate and edit configuration files __END__ =pod =encoding UTF-8 =head1 NAME Config::Model - Create tools to validate, migrate and edit configuration files =head1 VERSION version 2.082 =head1 SYNOPSIS =head2 Perl program use Config::Model; use Log::Log4perl qw(:easy) ; Log::Log4perl->easy_init($WARN); # create new Model object my $model = Config::Model->new() ; # Config::Model object # create config model. Most users will want to store the model # in lib/Config/Model/models and run cme as explained below $model ->create_config_class ( name => "MiniModel", element => [ [qw/foo bar baz/ ] => { type => 'leaf', value_type => 'uniline' }, ], read_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 More convenient $ mkdir -p lib/Config/Model/models/ $ echo "[ { name => 'MiniModel', \ element => [ [qw/foo bar baz/ ] => { type => 'leaf', value_type => 'uniline' }, ], \ read_config => { backend => 'IniFile', auto_create => 1, \ config_dir => '.', file => 'mini.ini', \ } \ } \ ] ; " > lib/Config/Model/models/MiniModel.pl $ cme modify -try MiniModel -dev bar=BARV foo=FOOV baz=BAZV $ cat mini.ini =head2 Look Ma, no Perl $ echo "Make sure that Config::Model::Itself is installed" $ mkdir -p lib/Config/Model/models/ $ config-model-edit -model MiniModel -save \ class:MiniModel element:foo type=leaf value_type=uniline - \ element:bar type=leaf value_type=uniline - \ element:baz type=leaf value_type=uniline - \ read_config:0 backend=IniFile file=mini.ini config_dir=. auto_create=1 - - - $ cme modify -try MiniModel -dev bar=BARV foo=FOOV baz=BAZV $ cat mini.ini =head1 DESCRIPTION Config::Model enables a project developer to provide an interactive configuration editor (graphical, curses based or plain terminal) to his users. For this he must: =over =item * Describe the structure and constraints of his project's configuration (fear not, a GUI is available) =item * Find a way to read and write configuration data using read/write backend provided by Config::Model or other Perl modules. =back With the elements above, Config::Model will generate 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 will be 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 will parse the configuration file and transform in 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 will follow 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 will be validated instantly 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 will see a *common* interface for *all* programs using this project. =item * Beginners will not see advanced parameters (advanced and master parameters are hidden from beginners) =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 Config::Model::Itself) =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 =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 Dedicated Config::Model::Manual pages will follow soon. =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 will use some parts of the API to set and get configuration values. More importantly, a generic user interface will need to explore the configuration model to be able to generate at run-time relevant configuration screens. Simple text interface if provided in this module. Curses and Tk interfaces are provided by L and L. =head1 Constructor Simply call new without parameters: my $model = Config::Model -> new ; This will create an empty shell for your model. =head1 Configuration Model To validate a configuration tree, we must create a configuration model that will set 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 is always easier to maintain than a lot of code) Each configuration class contains a set of: =over =item * node element that will refer to another configuration class =item * value element that will contains actual configuration data =item * List or hash of node or value elements =back By declaring a set of configuration classes and referring them in node element, you will shape the structure of your configuration tree. 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 attaches 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 simple tree. Some more relation between nodes and leaves must be added. =item * Some configuration part are actually graph instead of a tree (for instance, any configuration that will map a service to a resource). The graph relation must be decomposed in a tree with special I relation. 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). =for html More 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 will specify: =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 A configuration instance if the staring point of a configuration tree. When creating a model instance, you must specify the root class name, I.e. the configuration class that is used by the root node of the tree. my $model = Config::Model->new() ; $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 will be loaded automatically depending on C. But you can choose to specify the file containing the model with C parameter. This is mostly useful for tests. =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 will be shown to the user no matter what. C elements will be explained with the I notion. =item status Status is C, C or C (default). Using a deprecated element will issue a warning. Using an obsolete element will raise an exception. =item description Description of the element. This description will be used when generating user interfaces. =item summary Summary of the element. This description will be used when generating user interfaces and may be used in comments when writing the configuration file. =item class_description Description of the configuration class. This description will be used when 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 will be: ( 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 will open 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 If a model name contain a C<::> (e.g C), C will look for a file named C. This method will also look in C directory for additional model information. Model snippet found there will be 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 will return 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 get_model( config_class_name ) Return a hash containing the model declaration (in a deep clone copy of the hash). You may modify the hash at leisure. =head2 get_model_doc Generate POD document for configuration class. =head2 generate_doc ( top_class_name , [ directory ] ) Generate POD document for configuration class top_class_name and all classes used by top_class_name, and write them on STDOUT or in specified directory. Returns a list of written file names. =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 =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 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 LICENSE 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 General 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 =head1 SEE ALSO L, L L =head2 Model elements The arrow shows the inheritance of the 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 =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 =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Websites The following websites have more information about this module, and may be of help to you. As always, in addition to those websites please use your favorite search engine to discover more resources. =over 4 =item * Search CPAN The default CPAN search engine, useful to view POD in HTML format. L =item * AnnoCPAN The AnnoCPAN is a website that allows community annotations of Perl module documentation. L =item * CPAN Ratings The CPAN Ratings is a website that allows community ratings and reviews of Perl modules. L =item * CPANTS The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution. L =item * CPAN Testers The CPAN Testers is a network of smokers who run automated tests on uploaded CPAN distributions. L =item * CPAN Testers Matrix The CPAN Testers Matrix is a website that provides a visual overview of the test results for a distribution on various Perls/platforms. L =item * CPAN Testers Dependencies The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution. L =back =head2 Bugs / Feature Requests Please report any bugs or feature requests by email to C, or through the web interface at L. You will be automatically notified of any progress on the request by the system. =head2 Source Code The code is open to the world, and available for you to hack on. Please feel free to browse it and play with it, or whatever. If you want to contribute patches, please send me a diff or prod me to pull from your repository :) L git clone git://github.com/dod38fr/config-model.git =cut hash_id_of_node.t100644001750001750 731412676543661 16661 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More tests => 18; use Test::Memory::Cycle; use Config::Model; use Data::Dumper; use Log::Log4perl qw(:easy :levels); use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; Log::Log4perl->easy_init( $log ? $TRACE : $WARN ); Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "Compilation done" ); my @element = ( # Value constructor args are passed in their specific array ref cargo => { type => 'node', config_class_name => 'Slave' }, ); # minimal set up to get things working my $model = Config::Model->new(); $model->create_config_class( name => "Master", element => [ 'plain_hash' => { type => 'hash', class => 'Config::Model::HashId', # default index_type => 'integer', @element }, 'bounded_hash' => { type => 'hash', class => 'Config::Model::HashId', # default index_type => 'integer', # hash boundaries min => 1, max => 123, max_nb => 2, @element }, 'hash_with_default_and_init' => { type => 'hash', index_type => 'string', default_with_init => { 'def_1' => 'X=Av Y=Bv', 'def_2' => 'Y=Av Z=Cv' }, @element }, ], ); $model->create_config_class( name => "Slave", element => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $b = $root->fetch_element('bounded_hash'); ok( $b, "bounded hash created" ); is( $b->name, 'Master bounded_hash id', "check hash id name" ); my $b1 = $b->fetch_with_id(1); isa_ok( $b1, 'Config::Model::Node', "fetched element id 1" ); is( $b1->config_class_name, 'Slave', 'check config_class_name' ); my $h_with_def = $root->fetch_element('hash_with_default_and_init'); my $res = [ $h_with_def->fetch_all_indexes ]; #print Dumper( $res ) ; is_deeply( $res, [qw/def_1 def_2/], 'check default items' ); #print $root->dump_tree ; is( $root->dump_tree, 'bounded_hash:1 - hash_with_default_and_init:def_1 X=Av Y=Bv - hash_with_default_and_init:def_2 Y=Av Z=Cv - - ', "check default items with children setup" ); is( $h_with_def->fetch_with_id('def_1')->index_value, 'def_1', 'check index_value prior to move' ); $h_with_def->move( 'def_1', 'moved_1' ); is( $h_with_def->fetch_with_id('moved_1')->index_value, 'moved_1', 'check index_value after move' ); $res = [ $h_with_def->fetch_all_indexes ]; is_deeply( $res, [qw/def_2 moved_1/], 'check moved items keys' ); #print $root->dump_tree ; is( $root->dump_tree, 'bounded_hash:1 - hash_with_default_and_init:def_2 Y=Av Z=Cv - hash_with_default_and_init:moved_1 X=Av Y=Bv - - ', "check moved items with children setup" ); $root->load("plain_hash:2 X=Av Y=Av Z=Cv"); my $ph = $root->fetch_element('plain_hash'); ok( $ph->copy( 2, 3 ), "node copy in hash" ); is( $ph->fetch_with_id(2)->dump_tree, $ph->fetch_with_id(3)->dump_tree, "compare copied values" ); ok( $ph->move( 2, 4 ), "node move in hash" ); is( $ph->fetch_with_id(4)->dump_tree, $ph->fetch_with_id(3)->dump_tree, "compare copied then moved values" ); is_deeply( [ $ph->fetch_all_indexes ], [ 3, 4 ], "compare indexes after move" ); memory_cycle_ok($model); auto_load_model.t100644001750001750 247712676543661 16725 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 6; use Test::Memory::Cycle; use Config::Model; use warnings; no warnings qw(once); use strict; my $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Config root created" ); my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata" ' . 'lista=a,b,c,d olist:0 X=Av - olist:1 X=Bv - listb=b,c,d'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); # no need to check more. The above command would have failed if # the file containing the model was not loaded. # check that loading a model without inheritance works my $model2 = Config::Model->new( legacy => 'ignore', skip_include => 1 ); my $inst2 = $model2->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst2, "created dummy instance 2" ); memory_cycle_ok($model); check_list_warp.t100644001750001750 502112676543661 16723 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings; use strict; use 5.10.0; use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Test::Differences; use Config::Model; use Log::Log4perl qw(:easy); my ( $log, $show ) = (0) x 3; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "Compilation done" ); my $model = Config::Model->new(); my @slave_classes = ('Slave0' .. 'Slave1'); my @master_elems ; foreach my $slave_class (@slave_classes) { $model->create_config_class( name => $slave_class, element => [ [qw/X Y/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] } ] ); push @master_elems , $slave_class => { type => 'warped_node', level => 'hidden', config_class_name => $slave_class, follow => { selected => '- macro1' }, 'rules' => [ '$selected.is_set(&element_name)' => { level => 'normal' } ], }; } $model->create_config_class( name => 'Master', element => [ macro1 => { type => 'check_list', choice => \@slave_classes }, @master_elems ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Created Root" ); eq_or_diff( [$root->get_element_name], ['macro1'],"all slaves are hidden"); note("setting ",$slave_classes[0]) if $trace; my $mac = $root->fetch_element('macro1'); $mac->check($slave_classes[0]); eq_or_diff( [$root->get_element_name], ['macro1', $slave_classes[0]],"first slave is enabled"); $mac->check($slave_classes[1]); eq_or_diff( [$root->get_element_name], ['macro1', @slave_classes[0,1]],"2 slave is enabled"); $mac->uncheck($slave_classes[0]); eq_or_diff( [$root->get_element_name], ['macro1', $slave_classes[1]],"second slave is enabled"); $mac->uncheck($slave_classes[1]); eq_or_diff( [$root->get_element_name], ['macro1'],"all slaves are hidden again"); memory_cycle_ok($model); done_testing; dump_load_model.pm100644001750001750 1554612676543661 17114 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- # # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # this file is used by test script [ [ name => 'SubSlave2', element => [ [qw/aa2 ab2 ac2 ad2 Z/] => { type => 'leaf', value_type => 'string' } ] ], [ name => 'SubSlave', element => [ [qw/aa ab ac ad/] => { type => 'leaf', value_type => 'string' }, sub_slave => { type => 'node', config_class_name => 'SubSlave2', } ] ], [ name => 'X_base_class2', element => [ X => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ], class_description => 'rather dummy class to check include feature', ], [ name => 'X_base_class', include => 'X_base_class2', ], [ name => 'SlaveZ', element => [ [ 'Z', 'X-Y-Z' ] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, [qw/DX/] => { type => 'leaf', value_type => 'enum', default => 'Dv', choice => [qw/Av Bv Cv Dv/] }, ], include => 'X_base_class', include_after => 'Z', ], [ name => 'SlaveY', element => [ std_id => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'SlaveZ', }, sub_slave => { type => 'node', config_class_name => 'SubSlave', }, warp2 => { type => 'warped_node', follow => '! tree_macro', config_class_name => 'SubSlave', morph => 1, rules => [ mXY => { config_class_name => 'SubSlave2' }, XZ => { config_class_name => 'SubSlave2' } ] }, Y => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] }, ], include => 'X_base_class', ], [ name => 'Master', class_description => "Master description", level => [ [qw/lista hash_a tree_macro int_v/] => 'important' ], element => [ std_id => { type => 'hash', index_type => 'string', cargo_type => 'node', config_class_name => 'SlaveZ', }, [qw/lista listb listc/] => { type => 'list', cargo_type => 'leaf', cargo_args => { value_type => 'string' }, }, [qw/hash_a hash_b/] => { type => 'hash', index_type => 'string', cargo_type => 'leaf', cargo_args => { value_type => 'string' }, summary => "hash_* summary", }, ordered_hash => { type => 'hash', index_type => 'string', ordered => 1, cargo_type => 'leaf', cargo_args => { value_type => 'string' }, }, olist => { type => 'list', cargo_type => 'node', config_class_name => 'SlaveZ', }, tree_macro => { type => 'leaf', value_type => 'enum', choice => [qw/XY XZ mXY/], help => { XY => 'XY help', XZ => 'XZ help', mXY => 'mXY help', } }, warp => { type => 'warped_node', follow => '! tree_macro', config_class_name => 'SlaveY', morph => 1, rules => [ #XY => { config_class_name => 'SlaveY'}, mXY => { config_class_name => 'SlaveY' }, XZ => { config_class_name => 'SlaveZ' } ] }, 'slave_y' => { type => 'node', config_class_name => 'SlaveY', }, string_with_def => { type => 'leaf', value_type => 'string', default => 'yada yada' }, a_uniline => { type => 'leaf', value_type => 'uniline', default => 'yada yada' }, a_string => { type => 'leaf', value_type => 'string' }, a_string2 => { type => 'leaf', value_type => 'string' }, a_string_to_test_newline => { type => 'leaf', value_type => 'string' }, another_string => { type => 'leaf', mandatory => 1, value_type => 'string' }, hidden_string => { type => 'leaf', level => 'hidden', value_type => 'string', warp => { follow => '! tree_macro', rules => { XZ => { level => 'normal', } } }, }, int_v => { type => 'leaf', value_type => 'integer', default => '10', min => 5, max => 15 }, my_check_list => { type => 'check_list', refer_to => '- hash_a + ! hash_b', }, my_reference => { type => 'leaf', value_type => 'reference', refer_to => '- hash_a + ! hash_b', }, plain_object => { type => 'node', config_class_name => 'SubSlave2', } ], description => [ tree_macro => 'controls behavior of other elements' ] ], ]; # do not put 1; at the end or Model-> load will not work backend_multiple.t100644001750001750 616512676543661 17076 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 7; use Test::Memory::Cycle; use Config::Model; use File::Path; use File::Copy; use Test::Warn; use Test::Exception; use warnings; #no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new( legacy => 'ignore', ); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "compiled" ); # pseudo root where config files are written by config-model my $wr_root = 'wr_root/'; # cleanup before tests rmtree($wr_root); mkpath( $wr_root, { mode => 0755 } ); $model->create_config_class( 'read_config' => [ { 'auto_create' => '1', 'file' => 'control.pl', 'backend' => 'perl_file', 'config_dir' => 'debian' } ], 'name' => 'Test::Control', 'element' => [ 'source' => { 'type' => 'leaf', value_type => 'string', } ] ); $model->create_config_class( 'read_config' => [ { 'auto_create' => '1', 'file' => 'copyright.pl', 'backend' => 'perl_file', 'config_dir' => 'debian' } ], 'name' => 'Test::Copyright', 'element' => [ 'Format', { 'value_type' => 'uniline', 'type' => 'leaf', }, ] ); $model->create_config_class( 'read_config' => [ { 'auto_create' => '1', 'backend' => 'PlainFile', 'config_dir' => 'debian/source' } ], 'name' => 'Test::Source', 'element' => [ 'format', { 'value_type' => 'uniline', 'type' => 'leaf', } ] ); $model->create_config_class( 'name' => 'Test::Dpkg', 'element' => [ 'control', { 'type' => 'node', 'config_class_name' => 'Test::Control' }, 'copyright', { 'type' => 'node', 'config_class_name' => 'Test::Copyright' }, 'source', { 'type' => 'node', 'config_class_name' => 'Test::Source' } ] ); my $inst = $model->instance( root_class_name => 'Test::Dpkg', root_dir => $wr_root, ); my $root = $inst->config_root; $root->load( "control source=ctrl-source - copyright Format=copyright-format - source format=source-format" ); ok( 1, "loaded data" ); my $dump = $root->dump_tree; print $dump if $trace; $inst->write_back; #check written files foreach (qw!control.pl copyright.pl source/format!) { my $f = $wr_root . "debian/$_"; ok( -e $f, "check written file $f" ); } my $inst2 = $model->instance( root_class_name => 'Test::Dpkg', root_dir => $wr_root, instance_name => 'test2' ); my $root2 = $inst2->config_root; my $dump2 = $root2->dump_tree; is( $dump2, $dump, "check that inst2 is a copy of first instance" ); memory_cycle_ok($model); obj_tree_scanner.t100644001750001750 3207412676543661 17114 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More tests => 11; use Test::Memory::Cycle; use Config::Model; use Config::Model::ObjTreeScanner; use Test::Differences; use warnings; no warnings qw(once); use strict; use Data::Dumper; # use Config::Model::ObjTreeScanner; sub disp_node_content_hook { my ( $scanner, $data_r, $node, @element ) = @_; $$data_r .= "disp_node_content_hook " . $node->name . " element: @element\n"; } sub disp_node_content { my ( $scanner, $data_r, $node, @element ) = @_; $$data_r .= "disp_node_content " . $node->name . " element: @element\n"; map { $scanner->scan_element( $data_r, $node, $_ ) } @element; } sub disp_dispatch_node_sub_slave2 { my ( $scanner, $data_r, $node, @element ) = @_; $$data_r .= "disp_dispatch_node_sub_slave2 " . $node->name . " element: @element\n"; map { $scanner->scan_element( $data_r, $node, $_ ) } @element; } sub disp_node_elt { my ( $scanner, $data_r, $node, $element, $key, $next ) = @_; $$data_r .= "disp_node_elt " . $node->name . " element: $element"; $$data_r .= " key $key" if defined $key; $$data_r .= "\n"; $scanner->scan_node( $data_r, $next ); } sub disp_hash_hook { my ( $scanner, $data_r, $node, $element, @keys ) = @_; return unless @keys; $$data_r .= "disp_hash_hook " . $node->name . " element($element): @keys\n"; } sub disp_hash { my ( $scanner, $data_r, $node, $element, @keys ) = @_; return unless @keys; $$data_r .= "disp_hash " . $node->name . " element($element): @keys\n"; map { $scanner->scan_hash( $data_r, $node, $element, $_ ) } @keys; } sub disp_list_hook { my ( $scanner, $data_r, $node, $element, @keys ) = @_; return unless @keys; $$data_r .= "disp_list_hook " . $node->name . " element($element): @keys\n"; } sub disp_check_list { my ( $scanner, $data_r, $node, $element, @choices ) = @_; return unless @choices; $$data_r .= "disp_check_list " . $node->name . " element($element): " . join( ',', $node->fetch_element($element)->get_checked_list ) . " are set\n"; } sub disp_leaf { my ( $scanner, $data_r, $node, $element, $index ) = @_; my $value = $node->fetch_element($element); $value = $value->fetch_with_id($index) if defined $index; $$data_r .= "disp_leaf " . $node->name . " element $element "; $$data_r .= "value " . $value->fetch if defined $value->fetch; $$data_r .= "\n"; } sub disp_up { my ( $scanner, $data_r, $node ) = @_; $$data_r .= "disp_up " . $node->name . "\n"; } use Log::Log4perl qw(:easy); my $arg = shift || ''; my $test_only_model = shift || ''; my $do = shift; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } my $model = Config::Model->new( legacy => 'ignore' ); Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', model_file => 't/big_model.pm', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $step = 'std_id:ab X=Bv - std_id:bc X=Av - a_string="toto tata" ' . 'hash_a:X2=x hash_a:Y2=xy hash_b:X3=xy my_check_list=X2,X3'; ok( $root->load( step => $step ), "set up data in tree with '$step'" ); my $scan = Config::Model::ObjTreeScanner->new( #min_level => 'EXPERT', list_element_cb => \&disp_hash, check_list_element_cb => \&disp_check_list, hash_element_cb => \&disp_hash, node_element_cb => \&disp_node_elt, node_content_cb => \&disp_node_content, node_dispatch_cb => { SubSlave2 => \&disp_dispatch_node_sub_slave2, }, leaf_cb => \&disp_leaf, enum_value_cb => \&disp_leaf, integer_value_cb => \&disp_leaf, number_value_cb => \&disp_leaf, boolean_value_cb => \&disp_leaf, string_value_cb => \&disp_leaf, reference_value_cb => \&disp_leaf, node_content_hook => \&disp_node_content_hook, hash_element_hook => \&disp_hash_hook, list_element_hook => \&disp_list_hook, up_cb => \&disp_up ); ok( $scan, 'set up ObjTreeScanner' ); my $result = ''; $scan->scan_node( \$result, $root ); ok( 1, "performed scan" ); print $result if $trace; my $expect = << 'EOF' ; disp_node_content_hook Master element: std_id lista listb hash_a hash_b ordered_hash olist tree_macro warp slave_y string_with_def a_uniline a_string int_v my_check_list my_reference disp_node_content Master element: std_id lista listb hash_a hash_b ordered_hash olist tree_macro warp slave_y string_with_def a_uniline a_string int_v my_check_list my_reference disp_hash_hook Master element(std_id): ab bc disp_hash Master element(std_id): ab bc disp_node_elt Master element: std_id key ab disp_node_content_hook std_id:ab element: Z X DX disp_node_content std_id:ab element: Z X DX disp_leaf std_id:ab element Z disp_leaf std_id:ab element X value Bv disp_leaf std_id:ab element DX value Dv disp_up std_id:ab disp_node_elt Master element: std_id key bc disp_node_content_hook std_id:bc element: Z X DX disp_node_content std_id:bc element: Z X DX disp_leaf std_id:bc element Z disp_leaf std_id:bc element X value Av disp_leaf std_id:bc element DX value Dv disp_up std_id:bc disp_hash_hook Master element(hash_a): X2 Y2 disp_hash Master element(hash_a): X2 Y2 disp_leaf Master element hash_a value x disp_leaf Master element hash_a value xy disp_hash_hook Master element(hash_b): X3 disp_hash Master element(hash_b): X3 disp_leaf Master element hash_b value xy disp_leaf Master element tree_macro disp_node_elt Master element: warp disp_node_content_hook warp element: X std_id sub_slave warp2 Y disp_node_content warp element: X std_id sub_slave warp2 Y disp_leaf warp element X disp_node_elt warp element: sub_slave disp_node_content_hook warp sub_slave element: aa ab ac ad sub_slave disp_node_content warp sub_slave element: aa ab ac ad sub_slave disp_leaf warp sub_slave element aa disp_leaf warp sub_slave element ab disp_leaf warp sub_slave element ac disp_leaf warp sub_slave element ad disp_node_elt warp sub_slave element: sub_slave disp_node_content_hook warp sub_slave sub_slave element: aa2 ab2 ac2 ad2 Z disp_dispatch_node_sub_slave2 warp sub_slave sub_slave element: aa2 ab2 ac2 ad2 Z disp_leaf warp sub_slave sub_slave element aa2 disp_leaf warp sub_slave sub_slave element ab2 disp_leaf warp sub_slave sub_slave element ac2 disp_leaf warp sub_slave sub_slave element ad2 disp_leaf warp sub_slave sub_slave element Z disp_up warp sub_slave sub_slave disp_up warp sub_slave disp_node_elt warp element: warp2 disp_node_content_hook warp warp2 element: aa ab ac ad sub_slave disp_node_content warp warp2 element: aa ab ac ad sub_slave disp_leaf warp warp2 element aa disp_leaf warp warp2 element ab disp_leaf warp warp2 element ac disp_leaf warp warp2 element ad disp_node_elt warp warp2 element: sub_slave disp_node_content_hook warp warp2 sub_slave element: aa2 ab2 ac2 ad2 Z disp_dispatch_node_sub_slave2 warp warp2 sub_slave element: aa2 ab2 ac2 ad2 Z disp_leaf warp warp2 sub_slave element aa2 disp_leaf warp warp2 sub_slave element ab2 disp_leaf warp warp2 sub_slave element ac2 disp_leaf warp warp2 sub_slave element ad2 disp_leaf warp warp2 sub_slave element Z disp_up warp warp2 sub_slave disp_up warp warp2 disp_leaf warp element Y disp_up warp disp_node_elt Master element: slave_y disp_node_content_hook slave_y element: X std_id sub_slave warp2 Y disp_node_content slave_y element: X std_id sub_slave warp2 Y disp_leaf slave_y element X disp_node_elt slave_y element: sub_slave disp_node_content_hook slave_y sub_slave element: aa ab ac ad sub_slave disp_node_content slave_y sub_slave element: aa ab ac ad sub_slave disp_leaf slave_y sub_slave element aa disp_leaf slave_y sub_slave element ab disp_leaf slave_y sub_slave element ac disp_leaf slave_y sub_slave element ad disp_node_elt slave_y sub_slave element: sub_slave disp_node_content_hook slave_y sub_slave sub_slave element: aa2 ab2 ac2 ad2 Z disp_dispatch_node_sub_slave2 slave_y sub_slave sub_slave element: aa2 ab2 ac2 ad2 Z disp_leaf slave_y sub_slave sub_slave element aa2 disp_leaf slave_y sub_slave sub_slave element ab2 disp_leaf slave_y sub_slave sub_slave element ac2 disp_leaf slave_y sub_slave sub_slave element ad2 disp_leaf slave_y sub_slave sub_slave element Z disp_up slave_y sub_slave sub_slave disp_up slave_y sub_slave disp_node_elt slave_y element: warp2 disp_node_content_hook slave_y warp2 element: aa ab ac ad sub_slave disp_node_content slave_y warp2 element: aa ab ac ad sub_slave disp_leaf slave_y warp2 element aa disp_leaf slave_y warp2 element ab disp_leaf slave_y warp2 element ac disp_leaf slave_y warp2 element ad disp_node_elt slave_y warp2 element: sub_slave disp_node_content_hook slave_y warp2 sub_slave element: aa2 ab2 ac2 ad2 Z disp_dispatch_node_sub_slave2 slave_y warp2 sub_slave element: aa2 ab2 ac2 ad2 Z disp_leaf slave_y warp2 sub_slave element aa2 disp_leaf slave_y warp2 sub_slave element ab2 disp_leaf slave_y warp2 sub_slave element ac2 disp_leaf slave_y warp2 sub_slave element ad2 disp_leaf slave_y warp2 sub_slave element Z disp_up slave_y warp2 sub_slave disp_up slave_y warp2 disp_leaf slave_y element Y disp_up slave_y disp_leaf Master element string_with_def value yada yada disp_leaf Master element a_uniline value yada yada disp_leaf Master element a_string value toto tata disp_leaf Master element int_v value 10 disp_check_list Master element(my_check_list): X2,X3 are set disp_leaf Master element my_reference disp_up Master EOF $result =~ s/\s+\n/\n/g; eq_or_diff( [ split /\n/, $result ], [ split /\n/, $expect ], "check result" ); my $scan2 = Config::Model::ObjTreeScanner->new( fallback => 'all', leaf_cb => \&disp_leaf ); ok( $scan2, 'set up ObjTreeScanner with fallback' ); $result = ''; $scan2->scan_node( \$result, $root ); ok( 1, 'performed scan with fallback' ); print $result if $trace; $expect = << 'EOF' ; disp_leaf std_id:ab element Z disp_leaf std_id:ab element X value Bv disp_leaf std_id:ab element DX value Dv disp_leaf std_id:bc element Z disp_leaf std_id:bc element X value Av disp_leaf std_id:bc element DX value Dv disp_leaf Master element hash_a value x disp_leaf Master element hash_a value xy disp_leaf Master element hash_b value xy disp_leaf Master element tree_macro disp_leaf warp element X disp_leaf warp sub_slave element aa disp_leaf warp sub_slave element ab disp_leaf warp sub_slave element ac disp_leaf warp sub_slave element ad disp_leaf warp sub_slave sub_slave element aa2 disp_leaf warp sub_slave sub_slave element ab2 disp_leaf warp sub_slave sub_slave element ac2 disp_leaf warp sub_slave sub_slave element ad2 disp_leaf warp sub_slave sub_slave element Z disp_leaf warp warp2 element aa disp_leaf warp warp2 element ab disp_leaf warp warp2 element ac disp_leaf warp warp2 element ad disp_leaf warp warp2 sub_slave element aa2 disp_leaf warp warp2 sub_slave element ab2 disp_leaf warp warp2 sub_slave element ac2 disp_leaf warp warp2 sub_slave element ad2 disp_leaf warp warp2 sub_slave element Z disp_leaf warp element Y disp_leaf slave_y element X disp_leaf slave_y sub_slave element aa disp_leaf slave_y sub_slave element ab disp_leaf slave_y sub_slave element ac disp_leaf slave_y sub_slave element ad disp_leaf slave_y sub_slave sub_slave element aa2 disp_leaf slave_y sub_slave sub_slave element ab2 disp_leaf slave_y sub_slave sub_slave element ac2 disp_leaf slave_y sub_slave sub_slave element ad2 disp_leaf slave_y sub_slave sub_slave element Z disp_leaf slave_y warp2 element aa disp_leaf slave_y warp2 element ab disp_leaf slave_y warp2 element ac disp_leaf slave_y warp2 element ad disp_leaf slave_y warp2 sub_slave element aa2 disp_leaf slave_y warp2 sub_slave element ab2 disp_leaf slave_y warp2 sub_slave element ac2 disp_leaf slave_y warp2 sub_slave element ad2 disp_leaf slave_y warp2 sub_slave element Z disp_leaf slave_y element Y disp_leaf Master element string_with_def value yada yada disp_leaf Master element a_uniline value yada yada disp_leaf Master element a_string value toto tata disp_leaf Master element int_v value 10 disp_leaf Master element my_check_list value X2,X3 disp_leaf Master element my_reference EOF $result =~ s/\s+\n/\n/g; eq_or_diff( [ split /\n/, $result ], [ split /\n/, $expect ], "check result" ); # test dump of mandatory values my $model2 = Config::Model->new( legacy => 'ignore', ); $model2->create_config_class( name => "SomeRootClass", element => [ a_string => { type => 'leaf', mandatory => 1, value_type => 'string' }, ], ); my $inst2 = $model2->instance( root_class_name => 'SomeRootClass', instance_name => 'test', ); my $root2 = $inst2->config_root; eval { $root2->dump_tree( auto_vivify => 1, mode => 'full' ); }; ok( $@, "expected failure of dump with empty mandatory value" ); print "normal error:", $@, "\n" if $trace; memory_cycle_ok($model); multi_warp_value.t100644001750001750 1074012676543661 17165 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More tests => 63; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Storable qw/dclone/; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); my @m1 = qw/A1 B1/; my @m2 = qw/A2 B2 C2/; my @m3 = qw/A3 B3/; my @rules; foreach my $c1 (@m1) { foreach my $c2 (@m2) { foreach my $c3 (@m3) { push @rules, [ $c1, $c2, $c3 ], { default => "m$c1$c2$c3" }; } } } #use Data::Dumper; print Dumper \@rules ; # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); my $model_data = { name => 'Master', 'element' => [ macro1 => { type => 'leaf', value_type => 'enum', choice => \@m1 }, macro2 => { type => 'leaf', value_type => 'enum', choice => \@m2 }, macro3 => { type => 'leaf', value_type => 'enum', choice => \@m3 }, m1 => { type => 'leaf', value_type => 'string', 'warp' => { follow => [ '- macro1', ' - macro2', '- macro3' ], rules => \@rules } }, 'm2' => { type => 'leaf', value_type => 'string', default => 'unsatisfied', 'warp' => { follow => [ '- macro1', ' - macro2', '- macro3' ], 'rules' => [ [ 'A1', 'A2', 'A3' ] => { default => '3xA' }, [ 'B1', [ 'B2', 'C2' ], 'B3' ] => { default => '3x[BC]' }, ] }, }, 'm3' => { type => 'leaf', value_type => 'string', default => 'unsatisfied', 'warp' => { follow => '- macro2', 'rules' => [ [ 'B2', 'A2' ] => { default => 'A2 B2 rule' }, 'C2' => { default => 'C2 rule' }, ] }, }, 'm4' => { type => 'leaf', value_type => 'string', default => 'unsatisfied', 'warp' => { follow => { m1 => '- macro1', m2 => ' - macro2', m3 => '- macro3' }, 'rules' => [ '$m1 eq "A1" and $m2 eq "A2" and $m3 eq "A3"' => { default => '3xA' }, '($m1 eq "B1") and ($m2 eq "B2" or $m2 eq "C2") and ($m3 eq "B3")' => { default => '3x[BC]' }, ] }, }, ] }; my $copy = dclone $model_data ; $model->create_config_class(%$copy); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; use Config::Model::Warper; eq_or_diff( [ Config::Model::Warper::_dclone_key('foo') ], ['foo'], "Test _dclone_key (single key)" ); #use Devel::TraceCalls; #trace_calls {Class => "Config::Model::Value",}; #trace_calls {Class => "Config::Model::WarpedThing",}; foreach my $c1 (@m1) { ok( $root->load("macro1=$c1"), "Setting Root macro1 to $c1" ); foreach my $c2 (@m2) { ok( $root->load("macro2=$c2"), "Setting Root macro2 to $c2" ); foreach my $c3 (@m3) { ok( $root->load("macro3=$c3"), "Setting Root macro3 to $c3" ); my $vm1 = $root->grab_value('m1'); is( $vm1, "m$c1$c2$c3", "Reading Root slot m1: $vm1" ); my $index = "$c1$c2$c3"; my $m2_val = $index eq 'A1A2A3' ? '3xA' : $index =~ /B1[BC]2B3/ ? '3x[BC]' : 'unsatisfied'; is( $root->grab_value('m2'), $m2_val, "Reading Root slot m2" ); is( $root->grab_value('m4'), $m2_val, "Reading Root slot m4" ); } } } my @test = ( [ "macro2=A2", "A2 B2 rule" ], [ "macro2=C2", "C2 rule" ], [ "macro2=B2", "A2 B2 rule" ], ); foreach my $u_test (@test) { my ( $load, $exp ) = @$u_test; $root->load($load); is( $root->grab_value('m3'), $exp, "test m3 with $load" ); } memory_cycle_ok($model); test_yaml_model.pl100644001750001750 317612676543661 17124 0ustar00domidomi000000000000Config-Model-2.082/t# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # test model used by t/*.t my @backend_config = ( read_config => [{ backend => 'yaml', config_dir => '/yaml/', file => 'hosts.yml', auto_create => 1, full_dump => 0, }], ); [ { name => 'Host', element => [ [qw/ipaddr canonical alias/] => { type => 'leaf', value_type => 'uniline', }, dummy => {qw/type leaf value_type uniline default toto/}, ] }, { name => 'Hosts', @backend_config, element => [ record => { type => 'list', cargo => { type => 'node', config_class_name => 'Host', }, }, ] }, { name => 'SingleHashElement', @backend_config, element => [ record => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'Host', }, }, ] }, { name => 'TwoElements', include => 'SingleHashElement', @backend_config, element => [ foo => { type => 'leaf', value_type => 'uniline', } ] } ]; fstab000755001750001750 012676543661 15711 5ustar00domidomi000000000000Config-Model-2.082/examplesREADME100644001750001750 146212676543661 16734 0ustar00domidomi000000000000Config-Model-2.082/examples/fstabThis directory contains a configuration model example for the /etc/fstab file. FstabModel.pm contains the configuration model (as explained in Config::Model(3pm) and Config::Model::Node(3pm). fstab_test.pl will: - read the fstab file - store the configuration information in the config tree constructed from the model. - extract a report from the model - print on STDOUT a minimal fstab file - print on STDOUT a fstab file with comments extracted from the help provided by the fstab model The goal of this example is to be (relatively) easy to understand, not to be complete. Note that you need to compile the module (perl Makefile.PL && make) to run the example, but you don't need to install the module. Feel free to send me any modifications or enhancement of this example. (mailto: ddumont at cpan.org)backend_plainfile.t100644001750001750 517312676543661 17204 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More ; use Test::Memory::Cycle; use Config::Model; use File::Path; use File::Copy; use Data::Dumper; use IO::File; use warnings; no warnings qw(once); use strict; use vars qw/$model/; $model = Config::Model->new(); my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "compiled" ); my $subdir = 'plain/'; $model->create_config_class( name => "WithPlainFile", element => [ [qw/source new/] => {qw/type leaf value_type uniline/}, clean => { qw/type list/, cargo => {qw/type leaf value_type uniline/} }, ], read_config => [ { backend => 'plain_file', config_dir => $subdir, }, ], ); # pseudo root where config files are written by config-model my $wr_root = 'wr_root/'; # cleanup before tests rmtree($wr_root); mkpath( $wr_root . $subdir, { mode => 0755 } ); my $fh = IO::File->new; $fh->open( $wr_root . $subdir . 'source', ">" ); $fh->print("2.0\n"); $fh->close; ok( 1, "wrote source file" ); $fh->open( $wr_root . $subdir . 'clean', ">" ); $fh->print("foo\n*/*/bar\n"); $fh->close; ok( 1, "wrote clean file" ); my $inst = $model->instance( root_class_name => 'WithPlainFile', root_dir => $wr_root, ); ok( $inst, "Created instance" ); my $root = $inst->config_root; is( $root->grab_value("source"), "2.0", "got correct source value" ); is( $root->grab_value("clean:0"), "foo", "got clean 0" ); is( $root->grab_value("clean:1"), "*/*/bar", "got clean 1" ); my $load = qq[source="3.0 (quilt)"\nnew="new stuff" clean:2="baz*"\n]; $root->load($load); $inst->write_back; ok( 1, "plain file write back done" ); my $new_file = $wr_root . 'plain/new'; ok( -e $new_file, "check that config file $new_file was written" ); is($root->grab('source')->backend_support_annotation(), 0, "check backend annotation support"); # create another instance to read the yaml that was just written my $i2_plain = $model->instance( instance_name => 'inst2', root_class_name => 'WithPlainFile', root_dir => $wr_root, ); ok( $i2_plain, "Created 2nd instance" ); my $i2_root = $i2_plain->config_root; my $p2_dump = $i2_root->dump_tree; is( $p2_dump, $root->dump_tree, "compare original data with 2nd instance data" ); memory_cycle_ok($model, "memory cycles"); done_testing; value_simple_warp.t100644001750001750 1112612676543661 17323 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use Data::Dumper; BEGIN { plan tests => 24; } use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); my @rules = ( F => { choice => [qw/A B C F F2/], default => 'F' }, G => { choice => [qw/A B C G G2/], default => 'G' } ); my @args = ( value_type => 'enum', mandatory => 1, choice => [qw/A B C/] ); my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => "Master", element => [ enum => { type => 'leaf', class => 'Config::Model::Value', value_type => 'enum', choice => [qw/F G H/], default => undef }, wrong_syntax_rule => { type => 'leaf', class => 'Config::Model::Value', warp => { follow => '- enum', rules => [ F => [ default => 'F' ] ] }, @args }, warped_object => { type => 'leaf', class => 'Config::Model::Value', @args, warp => { follow => '- enum', rules => \@rules } }, recursive_warped_object => { type => 'leaf', class => 'Config::Model::Value', @args, warp => { follow => '- warped_object', rules => \@rules } }, [qw/w2 w3/] => { type => 'leaf', class => 'Config::Model::Value', @args, warp => { follow => '- enum', rules => \@rules }, }, ], # dummy class ); # check model content my $canonical_model = $model->get_element_model( 'Master', 'warped_object' ); is_deeply( $canonical_model->{warp}, { 'follow' => { 'f1' => '- enum' }, 'rules' => [ '$f1 eq \'F\'', { 'default' => 'F', 'choice' => [ 'A', 'B', 'C', 'F', 'F2' ] }, '$f1 eq \'G\'', { 'default' => 'G', 'choice' => [ 'A', 'B', 'C', 'G', 'G2' ] } ] }, "check munged warp arguments" ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my ( $w1, $w2, $w3, $bad_w, $rec_wo, $t ); eval { $bad_w = $root->fetch_element('wrong_syntax_rule'); }; ok( $@, "set up warped object with wrong rules syntax" ); print "normal error:\n", $@, "\n" if $trace; eval { $t = $bad_w->fetch; }; ok( $@, "wrong rules semantic warped object blows up" ); print "normal error:\n", $@, "\n" if $trace; ok( $w1 = $root->fetch_element('warped_object'), "set up warped object" ); eval { my $str = $w1->fetch; }; ok( $@, "try to read warped object while warp master is undef" ); print "normal error:\n", $@, "\n" if $trace; my $warp_master = $root->fetch_element('enum'); is( $warp_master->store('F'), 1, "store F in warp master" ); is( $w1->fetch, 'F', "read warped object default value" ); is( $w1->store('F2'), 1, "store F2 in warped object" ); is( $w1->fetch, 'F2', "and read" ); ok( $rec_wo = $root->fetch_element('recursive_warped_object'), "set up recursive_warped_object" ); eval { my $str = $rec_wo->fetch; }; ok( $@, "try to read recursive warped object while its warp master is F2" ); print "normal error:\n", $@, "\n" if $trace; eval { $t = $rec_wo->fetch; }; ok( $@, "recursive_warped_object blows up" ); print "normal error:\n", $@, "\n" if $trace; is( $w1->store('F'), 1, "store F in warped object" ); is( $rec_wo->fetch, 'F', "read recursive_warped_object: default value was set by warp master" ); $warp_master->store('G'); is( $w1->fetch, 'G', "warp 'enum' so that F2 value is clobbered (outside new choice)" ); $w1->store('A'); $warp_master->store('F'); is( $w1->fetch, 'A', "set value valid for both warp, warp w1 to G and test that the value is still ok" ); $w2 = $root->fetch_element('w2'); $w3 = $root->fetch_element('w3'); is( $w2->fetch, 'F', "test unset value for w2 after setting warp master" ); is( $w3->fetch, 'F', "idem for w3" ); $warp_master->store('G'); is( $w1->fetch, 'A', "set warp master to G and test unset value for w1 ... 2 and w3" ); is( $w2->fetch, 'G', "... and w2 ..." ); is( $w3->fetch, 'G', "... and w3" ); memory_cycle_ok($model); multi_warp_object.t100644001750001750 1002612676543661 17314 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings; use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => 'SlaveY', 'element' => [ [qw/X Y/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] } ] ); $model->create_config_class( name => 'SlaveZ', element => [ [qw/X Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] } ] ); $model->create_config_class( name => 'Master', #level => [bar => 'hidden'], 'element' => [ macro1 => { type => 'leaf', value_type => 'enum', choice => [qw/A B/] }, macro2 => { type => 'leaf', value_type => 'enum', choice => [qw/C D/] }, 'bar' => { type => 'hash', index_type => 'string', level => 'hidden', # goes normal when both m1 and m2 are defined 'warp' => { follow => { m1 => '! macro1', m2 => '- macro2' }, 'rules' => [ '$m1 eq "A" and $m2 eq "D"' => { level => 'normal' }, '$m1 and $m2' => { level => 'normal', }, # '$m1 eq "A" and $m2 eq "C"' => { level => 'normal', }, # '$m1 eq "B" and $m2 eq "C"' => { level => 'normal', }, # '$m1 eq "B" and $m2 eq "D"' => { level => 'normal', }, ] }, cargo => { type => 'warped_node', follow => [ '! macro1', '- macro2' ], morph => 1, 'rules' => [ [qw/A C/] => { 'config_class_name' => 'SlaveY' }, [qw/A D/] => { 'config_class_name' => 'SlaveY' }, [qw/B C/] => { 'config_class_name' => 'SlaveZ' }, [qw/B D/] => { 'config_class_name' => 'SlaveZ' }, ] } } ] ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; ok( $root, "Created Root" ); is( $root->is_element_available( name => 'bar' ), 0, 'check element bar for beginner user (not available because macro* are undef)' ); is( $root->is_element_available( name => 'bar' ), 0, 'check element bar for advanced user (not available because macro* are undef)' ); ok( $root->load('macro1=A'), 'set macro1 to A' ); is( $root->is_element_available( name => 'bar' ), 0, 'check element bar for beginner user (not available because macro2 is undef)' ); is( $root->is_element_available( name => 'bar' ), 0, 'check element bar for advanced user (not available because macro2 is undef)' ); eval { $root->load('bar:1 X=Av') }; ok( $@, "writing to slave->bar (fails tree_macro is undef)" ); print "normal error:\n", $@, "\n" if $trace; ok( $root->load('macro2=C'), 'set macro2 to C' ); is( $root->is_element_available( name => 'bar' ), 1, 'check element bar' ); $root->load( step => 'bar:1 X=Av' ); is( $root->grab('bar:1')->config_class_name, 'SlaveY', 'check bar:1 config class name' ); ok( $root->load('macro2=D'), 'set macro2 to D' ); is( $root->grab('bar:1')->config_class_name, 'SlaveY', 'check bar:1 config class name (is SlaveY)' ); ok( $root->load('macro1=B'), 'set macro1 to B' ); is( $root->grab('bar:1')->config_class_name, 'SlaveZ', 'check bar:1 config class name (is now SlaveZ)' ); is( $root->is_element_available( name => 'bar' ), 1, 'check element bar' ); memory_cycle_ok($model); done_testing; hash_id_of_values.t100644001750001750 3717012676543661 17256 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More ; use Test::Memory::Cycle; use Config::Model; use Test::Exception; use Test::Warn; use Test::Differences; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); # new parameter style my @element = ( # Value constructor args are passed in their specific array ref cargo => { type => 'leaf', value_type => 'string', class => 'Config::Model::Value', }, ); # minimal set up to get things working my $model = Config::Model->new( ); $model->create_config_class( name => "Master", element => [ plain_hash => { type => 'hash', index_type => 'integer', cargo => { type => 'leaf', value_type => 'string' }, }, bounded_hash => { type => 'hash', class => 'Config::Model::HashId', # default index_type => 'integer', # hash boundaries min => 1, max => 123, max_nb => 2, @element }, hash_with_auto_created_id => { type => 'hash', index_type => 'string', auto_create_keys => ['yada'], @element }, hash_with_several_auto_created_id => { type => 'hash', index_type => 'string', auto_create_keys => [qw/x y z/], @element }, [qw/hash_with_default_id hash_with_default_id_2/] => { type => 'hash', index_type => 'string', default_keys => ['yada'], @element }, hash_with_several_default_keys => { type => 'hash', index_type => 'string', default_keys => [qw/x y z/], @element }, hash_follower => { type => 'hash', index_type => 'string', @element, follow_keys_from => '- hash_with_several_auto_created_id', }, hash_with_allow => { type => 'hash', index_type => 'string', @element, allow_keys => [qw/foo bar baz/], }, hash_with_allow_from => { type => 'hash', index_type => 'string', @element, allow_keys_from => '- hash_with_several_auto_created_id', }, hash_with_allow_keys_matching => { type => 'hash', index_type => 'string', @element, allow_keys_matching => '^foo\d{2}$', }, hash_with_follow_keys_from => { type => 'hash', index_type => 'string', @element, follow_keys_from => '- hash_with_several_auto_created_id', }, hash_with_migrate_keys_from => { type => 'hash', index_type => 'string', @element, migrate_keys_from => '- hash_with_several_auto_created_id', }, hash_with_follow_keys_from_unknown => { type => 'hash', index_type => 'string', @element, follow_keys_from => '- unknown_hash', }, ordered_hash => { type => 'hash', index_type => 'string', @element, ordered => 1, }, hash_with_warn_if_key_match => { type => 'hash', index_type => 'string', @element, warn_if_key_match => 'foo', }, hash_with_warn_unless_key_match => { type => 'hash', index_type => 'string', @element, warn_unless_key_match => 'foo', }, hash_with_default_and_init => { type => 'hash', index_type => 'string', default_with_init => { 'def_1' => 'def_1 stuff', 'def_2' => 'def_2 stuff' }, @element }, hash_with_convert_lc => { type => 'hash', index_type => 'string', convert => 'lc', @element }, ], ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; $inst->initial_load_stop; is( $inst->needs_save, 0, "verify instance needs_save status after creation" ); my $b = $root->fetch_element('bounded_hash'); ok( $b, "bounded hash created" ); is( $b->get_cargo_type, 'leaf', 'check get_cargo_type' ); is( $b->get_cargo_info('value_type'), 'string', 'check get_cargo_info' ); is( $b->name, 'Master bounded_hash id', "check hash id name" ); my $b1 = $b->fetch_with_id(1); isa_ok( $b1, 'Config::Model::Value', "fetched element id 1" ); is( $inst->needs_save, 0, "verify instance needs_save status after element creation" ); is( $b1->store('foo'), 1, "Storing in id 1" ); is( $inst->needs_save, 1, "verify instance needs_save status after storing into element" ); is( $b->fetch_with_id(2)->store('bar'), 1, "Storing in id 2" ); is( $inst->needs_save, 2, "verify instance needs_save status after storing into another element" ); print scalar $inst->list_changes, "\n" if $trace; eval { $b->fetch_with_id('')->store('foo'); }; ok( $@, "empty index error" ); print "normal error: ", $@ if $trace; eval { $b->fetch_with_id(0)->store('foo'); }; ok( $@, "min error" ); print "normal error: ", $@ if $trace; eval { $b->fetch_with_id(124)->store('foo'); }; ok( $@, "max error" ); print "normal error: ", $@ if $trace; eval { $b->fetch_with_id(40)->store('foo'); }; ok( $@, "max nb error" ); print "normal error: ", $@ if $trace; is( $inst->needs_save, 2, "verify instance needs_save status after store errors" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; ok( $b->delete(2), "delete id 2" ); is( $b->exists(2), '', "deleted id does not exist" ); is( $inst->needs_save, 1, "verify instance needs_save status after delete" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; is( $b->index_type, 'integer', "reading value_type" ); is( $b->max_index, 123, "reading max boundary" ); my $ac = $root->fetch_element('hash_with_auto_created_id'); ok( $ac, "created hash_with_auto_created_id" ); eq_or_diff( [ $ac->fetch_all_indexes ], ['yada'], "check auto-created id" ); ok( $ac->exists('yada'), "...idem" ); $ac->fetch_with_id('foo')->store(3); ok( $ac->exists('yada'), "...idem after creating another id" ); eq_or_diff( [ $ac->fetch_all_indexes ], [ 'foo', 'yada' ], "check the 2 ids" ); my $dk = $root->fetch_element('hash_with_default_id'); ok( $dk, "created hash_with_default_id ..." ); eq_or_diff( [ $dk->fetch_all_indexes ], ['yada'], "check default id" ); ok( $dk->exists('yada'), "...and test default id on empty hash" ); my $dk2 = $root->fetch_element('hash_with_default_id_2'); ok( $dk2, "created hash_with_default_id_2 ..." ); ok( $dk2->fetch_with_id('foo')->store(3), "... store a value..." ); eq_or_diff( [ $dk2->fetch_all_indexes ], ['foo'], "...check existing id..." ); is( $dk2->exists('yada'), '', "...and test that default id is not provided" ); my $dk3 = $root->fetch_element('hash_with_several_default_keys'); ok( $dk3, "created hash_with_several_default_keys ..." ); eq_or_diff( [ sort $dk3->fetch_all_indexes ], [qw/x y z/], "...check default id" ); my $ac2 = $root->fetch_element('hash_with_several_auto_created_id'); ok( $ac2, "created hash_with_several_auto_created_id ..." ); ok( $ac2->fetch_with_id('foo')->store(3), "... store a value..." ); eq_or_diff( [ sort $ac2->fetch_all_indexes ], [qw/foo x y z/], "...check id..." ); my $follower = $root->fetch_element('hash_follower'); eq_or_diff( [ sort $follower->fetch_all_indexes ], [qw/foo x y z/], "check follower id" ); eval { $follower->fetch_with_id('zoo')->store('zoo'); }; ok( $@, "forbidden index error (not in followed object)" ); print "normal error: ", $@ if $trace; my $allow = $root->fetch_element('hash_with_allow'); ok( $allow, "created hash_with_allow ..." ); ok( $allow->fetch_with_id('foo')->store(3), "... store a value..." ); eval { $allow->fetch_with_id('zoo')->store('zoo'); }; ok( $@, "not allowed index error" ); print "normal error: ", $@ if $trace; my $allow_from = $root->fetch_element('hash_with_allow_from'); ok( $allow_from, "created hash_with_allow ..." ); ok( $allow_from->fetch_with_id('foo')->store(3), "... store a value..." ); eval { $allow_from->fetch_with_id('zoo')->store('zoo'); }; ok( $@, "not allowed index error" ); print "normal error: ", $@ if $trace; print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; my $ph = $root->fetch_element('plain_hash'); $ph->fetch_with_id(2)->store('baz'); ok( $ph->copy( 2, 3 ), "value copy" ); is( $ph->fetch_with_id(3)->fetch, $ph->fetch_with_id(2)->fetch, "compare copied value" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; my $hwfkf = $root->fetch_element('hash_with_follow_keys_from'); ok( $hwfkf, "created hash_with_follow_keys_from ..." ); eq_or_diff( [ $hwfkf->get_default_keys ], [qw/foo x y z/], 'check default keys of hash_with_follow_keys_from' ); my $hwfkfu = $root->fetch_element('hash_with_follow_keys_from_unknown'); ok( $hwfkfu, "created hash_with_follow_keys_from_unknown ..." ); eval { $hwfkfu->get_default_keys; }; ok( $@, "failed to get keys from hash_with_follow_keys_from_unknown" ); print "normal error: $@" if $trace; my $oh = $root->fetch_element('ordered_hash'); ok( $oh, "created ordered_hash ..." ); $oh->fetch_with_id('z')->store('1z'); $oh->fetch_with_id('x')->store('2x'); $oh->fetch_with_id('a')->store('3a'); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/z x a/], "check index order of ordered_hash" ); $inst->clear_changes; $oh->swap(qw/z x/); is( $inst->needs_save, 1, "verify instance needs_save status after swap" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; eq_or_diff( [ $oh->fetch_all_indexes ], [qw/x z a/], "check index order of ordered_hash after swap(z x)" ); $oh->swap(qw/a z/); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/x a z/], "check index order of ordered_hash after swap(a z)" ); $inst->clear_changes; $oh->move_up(qw/a/); is( $inst->needs_save, 1, "verify instance needs_save status after move_up" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a x z/], "check index order of ordered_hash after move_up(a)" ); $oh->move_down(qw/x/); is( $inst->needs_save, 1, "verify instance needs_save status after move_down" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a z x/], "check index order of ordered_hash after move_down(x)" ); is( $oh->fetch_with_id('x')->fetch, '2x', "Check copied value" ); $oh->copy(qw/x d/); is( $inst->needs_save, 1, "verify instance needs_save status after copy" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a z x d/], "check index order of ordered_hash after copy(x d)" ); is( $oh->fetch_with_id('d')->fetch, '2x', "Check copied value" ); $oh->copy(qw/a e/); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a z x d e/], "check index order of ordered_hash after copy(a e)" ); is( $oh->fetch_with_id('e')->fetch, '3a', "Check copied value" ); $inst->clear_changes; $oh->move_after('d'); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/d a z x e/], "check index order of ordered_hash after move_after(d)" ); is( $inst->needs_save, 1, "verify instance needs_save status after move_after" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; $oh->move_after( 'd', 'z' ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a z d x e/], "check index order of ordered_hash after move_after(d z)" ); is( $inst->needs_save, 1, "verify instance needs_save status after move_after" ); print scalar $inst->list_changes, "\n" if $trace; $inst->clear_changes; $oh->move_after( 'd', 'e' ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a z x e d/], "check index order of ordered_hash after move_after(d e)" ); $inst->clear_changes; $oh->clear; is( $inst->needs_save, 1, "verify instance needs_save status after clear" ); eq_or_diff([$inst->list_changes],['ordered_hash: cleared all entries'],"check change message after clear"); eq_or_diff( [ $oh->fetch_all_indexes ], [], "check index order of ordered_hash after clear" ); $oh->load_data( [qw/a va b vb c vc d vd e ve/] ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a b c d e/], "check index order of ordered_hash after clear" ); $oh->clear; $oh->load_data( { __order => [qw/a b c d e/], qw/a va b vb c vc d vd e ve/ } ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a b c d e/], "check index order of ordered_hash loaded with hash and __order" ); $oh->move( 'e', 'e2' ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a b c d e2/], "check index order of ordered_hash after move(e e2)" ); my $v = $oh->fetch_with_id('e2')->fetch; is( $v, 've', "Check moved value" ); $oh->move( 'd', 'e2' ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a b c e2/], "check index order of ordered_hash after move(d e2)" ); $v = $oh->fetch_with_id('e2')->fetch; is( $v, 'vd', "Check moved value" ); $oh->move( 'b', 'd' ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/a d c e2/], "check index order of ordered_hash after move(b d)" ); $v = $oh->fetch_with_id('d')->fetch; is( $v, 'vb', "Check moved value" ); $oh->move( 'c', 'a' ); eq_or_diff( [ $oh->fetch_all_indexes ], [qw/d a e2/], "check index order of ordered_hash after move(c a)" ); $v = $oh->fetch_with_id('a')->fetch; is( $v, 'vc', "Check moved value" ); my $hwakm = $root->fetch_element('hash_with_allow_keys_matching'); throws_ok { $hwakm->fetch_with_id('bar2'); } 'Config::Model::Exception::WrongValue', "check not matching key"; ok( $hwakm->fetch_with_id('foo22'), "check matching key" ); # test warnings with keys my $hwwikm = $root->fetch_element('hash_with_warn_if_key_match'); warning_like { $hwwikm->fetch_with_id('foo2'); } qr/key 'foo2' should not match/, "warn if matching key"; warning_like { $hwwikm->fetch_with_id("foo2 multi\nline\nid"); } qr/key 'foo2 multi\[\.\.\.\]' should not match/, "warn if matching multi_line key"; my $hwwukm = $root->fetch_element('hash_with_warn_unless_key_match'); warning_like { $hwwukm->fetch_with_id('bar2'); } qr/key 'bar2' should match foo/, "warn unless matching key"; # test key migration my $hwmkf = $root->fetch_element('hash_with_migrate_keys_from'); my @to_migrate = $root->fetch_element('hash_with_several_auto_created_id')->fetch_all_indexes; eq_or_diff( [ $hwmkf->fetch_all_indexes ], \@to_migrate, "check ids of hash_with_migrate_keys_from" ); my $hwdai = $root->fetch_element('hash_with_default_and_init'); # calling fetch_all_indexes will trigger the creation of the default_with_init keys foreach ( $hwdai->fetch_all_indexes ) { is( $hwdai->fetch_with_id($_)->fetch, "$_ stuff", "check default_with_init with $_" ); } # test convert lc my $hwclc = $root->fetch_element('hash_with_convert_lc'); $hwclc->fetch_with_id('Debian')->store('DebV'); $hwclc->fetch_with_id('Grip')->store('GripV'); eq_or_diff( [ $hwclc->fetch_all_indexes ], [qw/debian grip/], "check converted ids" ); memory_cycle_ok( $model, "check memory cycles" ); done_testing; load_model_snippets.t100644001750001750 1102112676543661 17623 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Memory::Cycle; use Test::Differences; use Config::Model; use Data::Dumper; use IO::File; use File::Path; use Log::Log4perl qw(:easy :levels); BEGIN { plan tests => 8; } use strict; use strict; my $arg = shift || ''; my ( $log, $show ) = (0) x 2; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "Compilation done" ); # pseudo root where config files are written by config-model my $wr_root = 'wr_root'; # cleanup before tests rmtree($wr_root); mkpath( $wr_root, { mode => 0755 } ); my $file = "$wr_root/Master.pl"; my $fh = IO::File->new( $file, '>' ) or die "can't open write $file:$!"; my $str = << 'EOF' ; [ { name => "Master", accept => [ '.*' => { type => 'leaf', value_type => 'uniline', } ], element => [ one => { type => 'leaf', value_type => 'string', }, fs_vfstype => { type => 'leaf', value_type => 'enum', choice => [qw/auto ext2 ext3/], }, fs_mntopts => { type => 'warped_node', follow => { 'f1' => '- fs_vfstype' }, rules => [ '$f1 eq \'auto\'', { 'config_class_name' => 'Fstab::CommonOptions' }, '$f1 eq \'ext2\'', { 'config_class_name' => 'Fstab::Ext2FsOpt' }, '$f1 eq \'ext3\'', { 'config_class_name' => 'Fstab::Ext3FsOpt' }, ], } ] } ]; EOF $fh->print($str); $fh->close; $file = "$wr_root/Two.pl"; $fh = IO::File->new( $file, '>' ) or die "can't open write $file:$!"; $str = << 'EOF' ; [{ name => "Two", element => [ two => { type => 'leaf', value_type => 'string', }, ] }] ; EOF $fh->print($str); $fh->close; my $snippet_dir = "$wr_root/Master.d"; mkpath( $snippet_dir, { mode => 0755 } ); $file = "$snippet_dir/Three.pl"; $fh = IO::File->new( $file, '>' ) or die "can't open write $file:$!"; $str = << 'EOF' ; { name => "Master", include => 'Two', include_after => 'fs_mntopts', accept => [ '.*' => { description => "catchall" }, 'ip.*' => { type => 'leaf', value_type => 'uniline', } ], element => [ three => { type => 'leaf', value_type => 'string', }, fs_vfstype => { choice => [qw/ext4/], }, fs_mntopts => { rules => [ q!$f1 eq 'ext4'!, { 'config_class_name' => 'Fstab::Ext4FsOpt' }, ], }, ] }; EOF $fh->print($str); $fh->close; # minimal set up to get things working my $model = Config::Model->new( model_dir => $wr_root, ); # use Tk::ObjScanner; Tk::ObjScanner::scan_object($model) ; my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; my $augmented_model = $model->get_model('Master'); print Dumper ($augmented_model) if $trace; my @elt = $root->get_element_name(); print "element list: @elt\n" if $trace; eq_or_diff( \@elt, [qw/one fs_vfstype two three/], "check augmented class" ); my $fstype = $root->fetch_element('fs_vfstype'); my @fs_choices = $fstype->get_choice; eq_or_diff( \@fs_choices, [qw/auto ext2 ext3 ext4/], "check augmented choices" ); eq_or_diff( $augmented_model->{element}{fs_mntopts}{rules}, [ '$f1 eq \'auto\'', { 'config_class_name' => 'Fstab::CommonOptions' }, '$f1 eq \'ext2\'', { 'config_class_name' => 'Fstab::Ext2FsOpt' }, '$f1 eq \'ext3\'', { 'config_class_name' => 'Fstab::Ext3FsOpt' }, '$f1 eq \'ext4\'', { 'config_class_name' => 'Fstab::Ext4FsOpt' } ], "test augmented rules" ); eq_or_diff( $augmented_model->{accept_list}, [ '.*', 'ip.*' ], "test accept_list" ); is( $augmented_model->{accept}{'.*'}{description}, 'catchall', "test augmented rules" ); memory_cycle_ok($model); Model000755001750001750 012676543661 16007 5ustar00domidomi000000000000Config-Model-2.082/lib/ConfigNode.pm100644001750001750 14672112676543661 17445 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Node; $Config::Model::Node::VERSION = '2.082'; use Mouse; with "Config::Model::Role::NodeLoader"; use Carp; use 5.010; use Config::Model::Exception; use Config::Model::Loader; use Config::Model::Dumper; use Config::Model::DumpAsData; use Config::Model::Report; use Config::Model::TreeSearcher; use Config::Model::Describe; use Config::Model::BackendMgr; use Log::Log4perl qw(get_logger :levels); use Storable qw/dclone/; use List::MoreUtils qw(insert_after_string); extends qw/Config::Model::AnyThing/; use vars qw(@status @level %default_property); *status = *Config::Model::status; *level = *Config::Model::level; *default_property = *Config::Model::default_property; my %legal_properties = ( status => {qw/obsolete 1 deprecated 1 standard 1/}, level => {qw/important 1 normal 1 hidden 1/}, ); my $logger = get_logger("Tree::Node"); my $fix_logger = get_logger("Anything::Fix"); my $change_logger = get_logger("ChangeTracker"); # Here are the legal element types my %create_sub_for = ( node => \&create_node, leaf => \&create_leaf, hash => \&create_id, list => \&create_id, check_list => \&create_id, warped_node => \&create_warped_node, ); # Node internal documentation # # Since the class holds a significant number of element, here's its # main structure. # # $self # = ( # config_model : Weak reference to Config::Model object # config_class_name # model : model of the config class # instance : Weak reference to Config::Model::Instance object # element_name : Name of the element containing this node # (undef for root node). # parent : weak reference of parent node (undef for root node) # element : actual storage of configuration elements # ) ; has initialized => ( is => 'rw', isa => 'Bool', default => 0 ); has config_class_name => ( is => 'ro', isa => 'Str', required => 1 ); has [qw/config_file element_name/] => ( is => 'ro', isa => 'Maybe[Str]', required => 0 ); has instance => ( is => 'ro', isa => 'Config::Model::Instance', weak_ref => 1, required => 1 ); has config_model => ( is => 'ro', isa => 'Config::Model', weak_ref => 1, lazy => 1, builder => '_config_model' ); sub _config_model { my $self = shift; my $p = $self->instance->config_model; } has skip_read => ( is => 'ro', isa => 'Bool' ); has check => ( is => 'ro', isa => 'Str', default => 'yes' ); has model => ( is => 'rw', isa => 'HashRef' ); has needs_save => ( is => 'rw', isa => 'Bool', default => 0 ); has backend_mgr => ( is => 'ro', isa => 'Maybe[Config::Model::BackendMgr]' ); # attribute is defined in Config::Model::Anythin sub _backend_support_annotation { my $self = shift; return $self->backend_mgr ? $self->backend_mgr->support_annotation : $self->parent ? $self->parent->backend_support_annotation : undef ; # no backend at all. test only } sub BUILD { my $self = shift; my $read_check = $self->instance->read_check; my $req_check = $self->check; my $check = $req_check eq 'no' || $read_check eq 'no' ? 'no' : $req_check eq 'skip' || $read_check eq 'skip' ? 'skip' : 'yes'; my $caller_class = defined $self->parent ? $self->parent->name : 'user'; my $class_name = $self->config_class_name; $logger->info("New $class_name requested by $caller_class"); # get_model returns a cloned data structure $self->model( $self->config_model->get_model($class_name) ); $self->{original_model} = dclone($self->model); $self->check_properties; return $self; } ## Create_* methods are all internal and should not be used directly sub create_element { my $self = shift; my %args = @_ > 1 ? @_ : ( name => shift ); my $element_name = $args{name}; my $check = $args{check} || 'yes'; my $element_info = $self->{model}{element}{$element_name}; if ( not defined $element_info ) { if ( $check eq 'yes' ) { Config::Model::Exception::UnknownElement->throw( object => $self, function => 'create_element', where => $self->location || 'configuration root', element => $element_name, ); } else { return; # just skip when check is no or skip } } Config::Model::Exception::Model->throw( error => "element '$element_name' error: " . "passed information is not a hash ref", object => $self ) unless ref($element_info) eq 'HASH'; Config::Model::Exception::Model->throw( error => "create element '$element_name' error: " . "missing 'type' parameter", object => $self ) unless defined $element_info->{type}; my $method = $create_sub_for{ $element_info->{type} }; croak $self->{config_class_name}, " error: unknown element type $element_info->{type}, expected ", join(' ', sort keys %create_sub_for) unless defined $method; $self->$method( $element_name, $check ); } sub create_node { my ( $self, $element_name, $check ) = @_; my $element_info = dclone( $self->{model}{element}{$element_name} ); my $config_class_name = $element_info->{config_class_name}; Config::Model::Exception::Model->throw( error => "create node '$element_name' error: " . "missing config class name parameter", object => $self ) unless defined $element_info->{config_class_name}; my @args = ( config_class_name => $config_class_name, instance => $self->{instance}, element_name => $element_name, check => $check, parent => $self, container => $self, ); $self->{element}{$element_name} = $self->load_node(@args); } sub create_warped_node { my ( $self, $element_name, $check ) = @_; my $element_info = dclone( $self->{model}{element}{$element_name} ); my @args = ( instance => $self->{instance}, element_name => $element_name, parent => $self, check => $check, container => $self, ); require Config::Model::WarpedNode; $self->{element}{$element_name} = Config::Model::WarpedNode->new( %$element_info, @args ); } sub create_leaf { my ( $self, $element_name, $check ) = @_; my $element_info = dclone( $self->{model}{element}{$element_name} ); delete $element_info->{type}; my $leaf_class = delete $element_info->{class} || 'Config::Model::Value'; if ( not defined *{ $leaf_class . '::' } ) { my $file = $leaf_class . '.pm'; $file =~ s!::!/!g; require $file; } $element_info->{container} = $element_info->{parent} = $self; $element_info->{element_name} = $element_name; $element_info->{instance} = $self->{instance}; $self->{element}{$element_name} = $leaf_class->new(%$element_info); } my %id_class_hash = ( hash => 'HashId', list => 'ListId', check_list => 'CheckList', ); sub create_id { my ( $self, $element_name, $check ) = @_; my $element_info = dclone( $self->{model}{element}{$element_name} ); my $type = delete $element_info->{type}; Config::Model::Exception::Model->throw( error => "create $type element '$element_name' error" . ": missing 'type' parameter", object => $self ) unless defined $type; croak "Undefined id_class for type '$type'" unless defined $id_class_hash{$type}; my $id_class = delete $element_info->{class} || 'Config::Model::' . $id_class_hash{$type}; if ( not defined *{ $id_class . '::' } ) { my $file = $id_class . '.pm'; $file =~ s!::!/!g; require $file; } $element_info->{container} = $element_info->{parent} = $self; $element_info->{element_name} = $element_name; $element_info->{instance} = $self->{instance}; $self->{element}{$element_name} = $id_class->new(%$element_info); } # check validity of level and status declaration. sub check_properties { my $self = shift; # a model should no longer contain attributes attached to # an element (like description, level ...). There are copied here # because Node needs them as hash or lists foreach my $bad (qw/description summary level status/) { die $self->config_class_name, ": illegal '$bad' parameter in model ", "(Should be handled by Config::Model directly)" if defined $self->{model}{$bad}; } foreach my $elt_name ( @{ $self->{model}{element_list} } ) { foreach my $prop (qw/summary description/) { my $info_to_move = delete $self->{model}{element}{$elt_name}{$prop}; $self->{$prop}{$elt_name} = $info_to_move if defined $info_to_move; } foreach my $prop ( keys %legal_properties ) { my $prop_v = delete $self->{model}{element}{$elt_name}{$prop} // $Config::Model::default_property{$prop} ; $self->{$prop}{$elt_name} = $prop_v; croak "Config class $self->{config_class_name} error: ", "Unknown $prop: '$prop_v'. Expected ", join( " or ", keys %{ $self->{$prop} } ) unless defined $legal_properties{$prop}{$prop_v}; } } } sub init { my $self = shift; return if $self->{initialized}; $self->{initialized} = 1; # avoid recursions my $model = $self->{model}; return unless defined $model->{read_config} or defined $model->{write_config}; my $initial_load_backup = $self->instance->initial_load; $self->instance->initial_load_start; $self->{backend_mgr} ||= Config::Model::BackendMgr->new( # config_dir spec given by application info config_dir => $self->instance->config_dir, node => $self, ); if ( defined $model->{read_config} and not $self->skip_read ) { $self->read_config_data( check => $self->check ); } # use read_config data if write_config is missing $model->{write_config} ||= dclone $model->{read_config} if defined $model->{read_config}; if ( $model->{write_config} ) { # setup auto_write, write_config_dir is obsolete $self->backend_mgr->auto_write_init( write_config => $model->{write_config}, write_config_dir => $model->{write_config_dir}, ); } $self->instance->initial_load($initial_load_backup); } sub read_config_data { my ( $self, %args ) = @_; my $model = $self->{model}; if ( $self->location and $args{config_file} ) { die "read_config_data: cannot override config_file in non root node (", $self->location, ")\n"; } # setup auto_read, read_config_dir is obsolete # may use an overridden config file $self->backend_mgr->read_config_data( read_config => $model->{read_config}, check => $args{check}, read_config_dir => $model->{read_config_dir}, config_file => $args{config_file} || $self->{config_file}, auto_create => $args{auto_create} || $self->instance->auto_create, ); } sub notify_change { my $self = shift; my %args = @_; $change_logger->debug( "called for ", $self->name, " from ", join( ' ', caller ), " with ", join( ' ', %args ) ) if $change_logger->is_debug; return if $self->instance->initial_load and not $args{really}; $logger->debug( "called while needs_write is ", $self->needs_save, " for ", $self->name ) if $logger->is_debug; if ( defined $self->backend_mgr ) { $self->needs_save(1); # will trigger a save in config_file $self->SUPER::notify_change( %args, needs_save => 0 ); } else { # save config_file will be done by a node above $self->SUPER::notify_change( %args, needs_save => 1 ); } } sub write_back { my ( $self, %args ) = @_; my $force_write = delete $args{force} || 0; if ( $self->location and $args{config_file} ) { die "write_back: cannot override config_file in non root node (", $self->location, ")\n"; } $self->backend_mgr->write_back(%args) if $self->needs_save or $force_write; } sub is_auto_write_for_type { my $self = shift; return 0 unless defined $self->backend_mgr; return $self->backend_mgr->is_auto_write_for_type(@_); } sub name { my $self = shift; return $self->location() || $self->config_class_name; } sub get_type { return 'node'; } sub get_cargo_type { return 'node'; } # always true. this method is required so that WarpedNode and Node # have a similar API. sub is_accessible { return 1; } # should I autovivify this element: NO sub has_element { my $self = shift; my %args = ( @_ > 1 ) ? @_ : ( name => shift ); my $name = $args{name}; my $type = $args{type}; if ( not defined $name ) { Config::Model::Exception::Internal->throw( object => $self, info => "has_element: missing element name", ); } $self->accept_element($name); return 0 unless defined $self->{model}{element}{$name}; return 1 unless defined $type; return $self->{model}{element}{$name}{type} eq $type ? 1 : 0; } # should I autovivify this element: NO sub find_element { my ( $self, $name, %args ) = @_; croak "find_element: missing element name" unless defined $name; # should be the case if people are using cme edit return $name if defined $self->{model}{element}{$name}; # look for a close element playing with cases; if ( defined $args{case} and $args{case} eq 'any' ) { foreach my $elt ( keys %{ $self->{model}{element} } ) { return $elt if lc($elt) eq lc($name); } } # now look if the element can be accepted $self->accept_element($name); return $name if defined $self->{model}{element}{$name}; return; } sub element_model { my $self = shift; croak "element_model: missing element name" unless @_; return $self->{model}{element}{ $_[0] }; } sub element_type { my $self = shift; croak "element_type: missing element name" unless @_; my $element_info = $self->{model}{element}{ $_[0] }; Config::Model::Exception::UnknownElement->throw( object => $self, function => 'element_type', where => $self->location || 'configuration root', element => $_[0], ) unless defined $element_info; return $element_info->{type}; } sub get_element_name { my $self = shift; my %args = @_; if (delete $args{for}) { carp "get_element_name arg 'for' is deprecated"; } my $type = $args{type}; # optional my $cargo_type = $args{cargo_type}; # optional $self->init; my @result; my $info = $self->{model}; my @element_list = @{ $self->{model}{element_list} }; # 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 (@element_list) { # create element if they don't exist, this enables warp stuff # to kick in $self->create_element( name => $elt, check => $args{check} || 'yes' ) unless defined $self->{element}{$elt}; next if $self->{level}{$elt} eq 'hidden'; my $status = $self->{status}{$elt} || $default_property{status}; next if ( $status eq 'deprecated' or $status eq 'obsolete' ); my $elt_type = $self->{element}{$elt}->get_type; my $elt_cargo = $self->{element}{$elt}->get_cargo_type; if ( ( not defined $type or $type eq $elt_type ) and ( not defined $cargo_type or $cargo_type eq $elt_cargo ) ) { push @result, $elt; } } $logger->debug("get_element_name: got @result"); return wantarray ? @result : join( ' ', @result ); } sub children { my $self = shift; return $self->get_element_name; } sub next_element { my $self = shift; my %args = @_; my $element = $args{name}; my @elements = @{ $self->{model}{element_list} }; @elements = reverse @elements if $args{reverse}; # if element is empty, start from first element my $found_elt = ( defined $element and $element ) ? 0 : 1; while ( my $name = shift @elements ) { if ($found_elt) { return $name if $self->is_element_available( name => $name, status => $args{status} ); } $found_elt = 1 if defined $element and $element eq $name; } croak "next_element: element $element is unknown. Expected @elements" unless $found_elt; return; } sub previous_element { my $self = shift; $self->next_element( @_, reverse => 1 ); } sub get_element_property { my $self = shift; my %args = @_; my ( $prop, $elt ) = $self->check_property_args( 'get_element_property', %args ); return $self->{$prop}{$elt} || $default_property{$prop}; } sub set_element_property { my $self = shift; my %args = @_; my ( $prop, $elt ) = $self->check_property_args( 'set_element_property', %args ); my $new_value = $args{value} || croak "set_element_property:: missing 'value' parameter"; $logger->debug( "Node ", $self->name, ": set $elt property $prop to $new_value" ); return $self->{$prop}{$elt} = $new_value; } sub reset_element_property { my $self = shift; my %args = @_; my ( $prop, $elt ) = $self->check_property_args( 'reset_element_property', %args ); my $original_value = $self->{config_model}->get_element_property( class => $self->{config_class_name}, %args ); $logger->debug( "Node ", $self->name, ": reset $elt property $prop to $original_value" ); return $self->{$prop}{$elt} = $original_value; } # internal: called by the property methods to check their arguments sub check_property_args { my $self = shift; my $method_name = shift; my %args = @_; my $elt = $args{element} || croak "$method_name: missing 'element' parameter"; my $prop = $args{property} || croak "$method_name: missing 'property' parameter"; my $prop_values = $legal_properties{$prop}; confess "Unknown property in $method_name: $prop, expected status or ", "level" unless defined $prop_values; return ( $prop, $elt ); } sub fetch_element { my $self = shift; my %args = @_ > 1 ? @_ : ( name => shift ); my $element_name = $args{name}; Config::Model::Exception::Internal->throw( error => "fetch_element: missing name" ) unless defined $element_name; my $check = $self->_check_check( $args{check} ); my $accept_hidden = $args{accept_hidden} || 0; $self->init(); my $model = $self->{model}; # retrieve element (and auto-vivify if needed) if ( not defined $self->{element}{$element_name} ) { # We also need to check if element name is matched by any of 'accept' parameters $self->accept_element($element_name); $self->create_element( name => $element_name, check => $check ) or return; } # check level my $element_level = $self->get_element_property( property => 'level', element => $element_name ); if ( $element_level eq 'hidden' and not $accept_hidden ) { return 0 if ( $check eq 'no' or $check eq 'skip' ); Config::Model::Exception::UnavailableElement->throw( object => $self, element => $element_name, info => 'hidden element', ); } # check status if ( $self->{status}{$element_name} eq 'obsolete' ) { # obsolete is a status not very different from a missing # item. The only difference is that user will get more # information return 0 if ( $check eq 'no' or $check eq 'skip' ); Config::Model::Exception::ObsoleteElement->throw( object => $self, element => $element_name, ); } if ( $self->{status}{$element_name} eq 'deprecated' and $check ne 'no' ) { # FIXME elaborate more ? or include parameter description ?? warn "Element '$element_name' of node '", $self->name, "' is deprecated\n"; # this will also force a rewrite of the file even if no other # semantic change was done $self->notify_change( note => 'dropping deprecated parameter', path => $self->location . ' ' . $element_name, really => 1, ); } return $self->fetch_element_no_check($element_name); } sub fetch_element_no_check { my ( $self, $element_name ) = @_; return $self->{element}{$element_name}; } sub fetch_element_value { my $self = shift; my %args = @_ > 1 ? @_ : ( name => $_[0] ); my $element_name = $args{name}; my $check = $self->_check_check( $args{check} ); if ( $self->element_type($element_name) ne 'leaf' ) { Config::Model::Exception::WrongType->throw( object => $self->fetch_element($element_name), function => 'fetch_element_value', got_type => $self->element_type($element_name), expected_type => 'leaf', ); } return $self->fetch_element(%args)->fetch( check => $check ); } sub store_element_value { my $self = shift; my %args = @_ > 2 ? @_ : ( name => $_[0], value => $_[1] ); return $self->fetch_element(%args)->store(%args); } sub is_element_available { my $self = shift; my ( $elt_name, $status ) = ( undef, 'deprecated' ); if ( @_ == 1 ) { $elt_name = shift; } else { my %args = @_; $elt_name = $args{name}; $status = $args{status} if defined $args{status}; } croak "is_element_available: missing name parameter" unless defined $elt_name; # force the warp to be done (if possible) so the catalog name # is updated my $element = $self->fetch_element( name => $elt_name, check => 'no', accept_hidden => 1 ); my $element_level = $self->get_element_property( property => 'level', element => $elt_name ); if ( $element_level eq 'hidden' ) { $logger->trace("element $elt_name is level hidden -> return 0"); return 0; } my $element_status = $self->get_element_property( property => 'status', element => $elt_name ); if ( $element_status ne 'standard' and $element_status ne $status ) { $logger->trace("element $elt_name is status $element_status -> return 0"); return 0; } return 1; } sub accept_element { my ( $self, $name ) = @_; my $model_data = $self->{model}{element}; return $model_data->{$name} if defined $model_data->{$name}; return unless defined $self->{model}{accept}; eval {require Text::Levenshtein::Damerau} ; my $has_tld = ! $@ ; foreach my $accept_regexp ( @{ $self->{model}{accept_list} } ) { next unless $name =~ /^$accept_regexp$/; my $element_list = $self->{original_model}{element_list} ; if ($has_tld and $element_list and @$element_list) { my $tld = Text::Levenshtein::Damerau->new($name); my $tld_arg = {list => $element_list }; my $dist = $tld->dld_best_distance($tld_arg); if ($dist < 3) { my $best = $tld->dld_best_match($tld_arg); warn "Warning: $name is confusingly close to $best (edit distance is $dist). Is there a typo ?\n"; } } my $acc = $self->{model}{accept}{$accept_regexp}; return $self->reset_accepted_element_model( $name, $acc ); } return; } sub accept_regexp { my ($self) = @_; return @{ $self->{model}{accept_list} || [] }; } sub reset_accepted_element_model { my ( $self, $element_name, $accept_model ) = @_; my $model = dclone $accept_model ; delete $model->{name_match}; my $accept_after = delete $model->{accept_after}; foreach my $info_to_move (qw/description summary/) { my $moved_data = delete $model->{$info_to_move}; next unless defined $moved_data; $self->{$info_to_move}{$element_name} = $moved_data; } foreach my $info_to_move (qw/level status/) { $self->reset_element_property( element => $element_name, property => $info_to_move ); } $self->{model}{element}{$element_name} = $model; #add to element list... if ($accept_after) { insert_after_string( $accept_after, $element_name, @{ $self->{model}{element_list} } ); } else { push @{ $self->{model}{element_list} }, $element_name; } return ($model); } sub element_exists { my $self = shift; my $element_name = shift; return defined $self->{model}{element}{$element_name} ? 1 : 0; } sub is_element_defined { my $self = shift; return defined $self->{element}{ $_[0] }; } sub get { my $self = shift; my %args = @_ > 1 ? @_ : ( path => $_[0] ); my $path = delete $args{path}; my $get_obj = delete $args{get_obj} || 0; $path =~ s!^/!!; return $self unless length($path); my ( $item, $new_path ) = split m!/!, $path, 2; $logger->debug("get: path $path, item $item"); my $elt = $self->fetch_element( name => $item, %args ); return unless defined $elt; return $elt if ( ( $elt->get_type ne 'leaf' or $get_obj ) and not defined $new_path ); return $elt->get( path => $new_path, get_obj => $get_obj, %args ); } sub set { my $self = shift; my $path = shift; $path =~ s!^/!!; my ( $item, $new_path ) = split m!/!, $path, 2; if ( $item =~ /([\w\-]+)\[(\d+)\]/ ) { return $self->fetch_element($1)->fetch_with_id($2)->set( $new_path, @_ ); } else { return $self->fetch_element($item)->set( $new_path, @_ ); } } sub load { my $self = shift; my $loader = Config::Model::Loader->new; my %args = @_ eq 1 ? ( step => $_[0] ) : @_; if ( defined $args{step} ) { $loader->load( node => $self, %args ); } else { Config::Model::Exception::Load->throw( object => $self, message => "load called with no 'step' parameter", ); } } sub load_data { my $self = shift; my %args = @_ > 1 ? @_ : ( data => shift ); my $raw_perl_data = delete $args{data}; my $check = $self->_check_check( $args{check} ); if ( not defined $raw_perl_data or ( ref($raw_perl_data) ne 'HASH' #and not $raw_perl_data->isa( 'HASH' ) ) ) { Config::Model::Exception::LoadData->throw( object => $self, message => "load_data called with non hash ref arg", wrong_data => $raw_perl_data, ) if $check eq 'yes'; return; } my $perl_data = dclone $raw_perl_data ; $logger->info( "Node load_data (", $self->location, ") will load elt ", join( ' ', keys %$perl_data ) ); # data must be loaded according to the element order defined by # the model. This will not load not yet accepted parameters foreach my $elt ( @{ $self->{model}{element_list} } ) { $logger->trace("check element $elt"); next unless defined $perl_data->{$elt}; if ( $self->is_element_available( name => $elt ) or $check eq 'no' ) { if ( $logger->is_trace ) { my $v = defined $perl_data->{$elt} ? $perl_data->{$elt} : ''; $logger->trace("Node load_data for element $elt -> $v"); } my $obj = $self->fetch_element( name => $elt, check => $check ); if ($obj) { $obj->load_data( %args, data => delete $perl_data->{$elt} ); } elsif ( defined $obj ) { # skip hidden elements and trash corresponding data $logger->trace("Node load_data drop element $elt"); delete $perl_data->{$elt}; } } elsif ( $check eq 'skip' ) { $logger->trace("Node load_data skips element $elt"); } else { Config::Model::Exception::LoadData->throw( message => "load_data: tried to load hidden " . "element '$elt' with", wrong_data => $perl_data->{$elt}, object => $self, ); } } # Load elements matched by accept parameter if ( defined $self->{model}{accept} ) { # Now, $perl_data contains all elements not yet parsed # sort is required to have a predictable order of accepted elements foreach my $elt ( sort keys %$perl_data ) { #load value #TODO: annotations my $obj = $self->fetch_element( name => $elt, check => $check ); next unless $obj; # in cas of known but unavailable elements $logger->debug("Node load_data: accepting element $elt"); $obj->load_data( %args, data => delete $perl_data->{$elt} ) if defined $obj; } } if ( %$perl_data and $check eq 'yes' ) { Config::Model::Exception::LoadData->throw( message => "load_data: unknown elements (expected " . join( ' ', @{ $self->{model}{element_list} } ) . ") ", wrong_data => $perl_data, object => $self, ); } } # TBD explain full_dump sub dump_tree { my $self = shift; $self->init; my $dumper = Config::Model::Dumper->new; $dumper->dump_tree( node => $self, @_ ); } sub migrate { my $self = shift; $self->init; Config::Model::Dumper->new->dump_tree( node => $self, mode => 'full', @_ ); return $self->needs_save; } sub dump_annotations_as_pod { my $self = shift; $self->init; my $dumper = Config::Model::DumpAsData->new; $dumper->dump_annotations_as_pod( node => $self, @_ ); } sub describe { my $self = shift; $self->init; my $descriptor = Config::Model::Describe->new; $descriptor->describe( node => $self, @_ ); } sub report { my $self = shift; $self->init; my $reporter = Config::Model::Report->new; $reporter->report( node => $self ); } sub audit { my $self = shift; $self->init; my $reporter = Config::Model::Report->new; $reporter->report( node => $self, audit => 1 ); } sub copy_from { my $self = shift; my %args = @_ > 1 ? @_ : ( from => shift ); my $from = $args{from} || croak "copy_from: missing from argument"; my $check = $args{check} || 'yes'; $logger->debug( "node " . $self->location . " copy from " . $from->location ); my $dump = $from->dump_tree( check => 'no' ); $self->load( step => $dump, check => $check ); } sub get_help { my $self = shift; my $help; if ( scalar @_ > 1 ) { my ( $tag, $elt_name ) = @_; if ( $tag !~ /summary|description/ ) { croak "get_help: wrong argument $tag, expected ", "'description' or 'summary'"; } $help = $self->{$tag}{$elt_name}; } elsif (@_) { $help = $self->{description}{ $_[0] }; } else { $help = $self->{model}{class_description}; } return defined $help ? $help : ''; } sub tree_searcher { my $self = shift; return Config::Model::TreeSearcher->new( node => $self, @_ ); } sub apply_fixes { my $self = shift; my $filter = shift || '.'; # define leaf call back my $fix_leaf = sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; $leaf_object->apply_fixes if $element_name =~ /$filter/; }; my $fix_hash = sub { my ( $scanner, $data_r, $node, $element, @keys ) = @_; return unless @keys; # leaves must be fixed before the hash, hence the # calls to scan_hash before apply_fixes map { $scanner->scan_hash( $data_r, $node, $element, $_ ) } @keys; $node->fetch_element($element)->apply_fixes if $element =~ /$filter/; }; my $fix_list = sub { my ( $scanner, $data_r, $node, $element, @keys ) = @_; return unless @keys; map { $scanner->scan_list( $data_r, $node, $element, $_ ) } @keys; $node->fetch_element($element)->apply_fixes if $element =~ /$filter/; }; my $scan = Config::Model::ObjTreeScanner->new( hash_element_cb => $fix_hash, list_element_cb => $fix_list, leaf_cb => $fix_leaf, check => 'no', ); $fix_logger->debug( "apply fix started from ", $self->name ); $scan->scan_node( undef, $self ); $fix_logger->debug("apply fix done"); } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Class for configuration tree node __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Node - Class for configuration tree node =head1 VERSION version 2.082 =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => 'OneConfigClass', class_description => "OneConfigClass detailed description", element => [ [qw/X Y Z/] => { type => 'leaf', value_type => 'enum', choice => [qw/Av Bv Cv/] } ], status => [ X => 'deprecated' ], description => [ X => 'X-ray description (can be long)' ], summary => [ X => 'X-ray' ], accept => [ 'ip.*' => { type => 'leaf', value_type => 'uniline', summary => 'ip address', } ] ); my $instance = $model->instance (root_class_name => 'OneConfigClass'); my $root = $instance->config_root ; # X is not shown below because of its deprecated status print $root->describe,"\n" ; # name value type comment # Y [undef] enum choice: Av Bv Cv # Z [undef] enum choice: Av Bv Cv # add some data $root->load( step => 'Y=Av' ); # add some accepted element, ipA and ipB are created on the fly $root->load( step => q!ipA=192.168.1.0 ipB=192.168.1.1"! ); # show also ip* element created in the last "load" call print $root->describe,"\n" ; # name value type comment # Y Av enum choice: Av Bv Cv # Z [undef] enum choice: Av Bv Cv # ipA 192.168.1.0 uniline # ipB 192.168.1.1 uniline =head1 DESCRIPTION This class provides the nodes of a configuration tree. When created, a node object will get a set of rules that will define its properties within the configuration tree. Each node contain a set of elements. An element can contain: =over =item * A leaf element implemented with L. A leaf can be plain (unconstrained value) or be strongly typed (values are checked against a set of rules). =item * Another node. =item * A collection of items: a list element, implemented with L. Each item can be another node or a leaf. =item * A collection of identified items: a hash element, implemented with L. Each item can be another node or a leaf. =back =head1 Configuration class declaration A class declaration is made of the following parameters: =over =item B Mandatory C parameter. This config class name can be used by a node element in another configuration class. =item B Optional C parameter. This description will be used when generating user interfaces. =item B Optional C to specify a Perl class to override the default implementation (L). This Perl Class B inherit L. Use with care. =item B Mandatory C of elements of the configuration class : element => [ foo => { type = 'leaf', ... }, bar => { type = 'leaf', ... } ] Element names can be grouped to save typing: element => [ [qw/foo bar/] => { type = 'leaf', ... } ] See below for details on element declaration. =item B Optional C of the elements whose level are different from default value (C). Possible values are C, C or C. The level is used to set how configuration data is presented to the user in browsing mode. C elements will be shown to the user no matter what. C elements will be explained with the I notion. level => [ [qw/X Y/] => 'important' ] =item B Optional C of the elements whose status are different from default value (C). Possible values are C, C or C. Using a deprecated element will issue a warning. Using an obsolete element will raise an exception (See L. status => [ [qw/X Y/] => 'obsolete' ] =item B Optional C of element description. These descriptions will be used when generating user interfaces. =item B Optional C of element summary. These descriptions will be used when generating user interfaces or as comment when writing configuration files. =item B =item B =item B Parameters used to load on demand configuration data. See L for details. =item B Optional list of criteria (i.e. a regular expression to match ) to accept unknown elements. Each criteria will have a list of specification that will enable C to create a model snippet for the unknown element. Example: accept => [ 'list.*' => { type => 'list', cargo => { type => 'leaf', value_type => 'string', }, }, 'str.*' => { type => 'leaf', value_type => 'uniline' }, ] All C parameters can be used in specifying accepted elements. If L is installed, a warning will be issued if an accepted element is too close to an existing element. The parameter C to specify where to insert the accepted element. This will not change much the behavior of the tree, but will help generate more usable user interfaces. Example: element => [ 'Bug' => { type => 'leaf', value_type => 'uniline' } , ] accept => [ 'Bug-.*' => { value_type => 'uniline', type => 'leaf' accept_after => 'Bug' , } ] The model snippet above will ensure that C will be shown right after C. =for html

For more information, see this blog.

=back =head1 Element declaration =head2 Element type Each element is declared with a list ref that contains all necessary information: element => [ foo => { ... } ] This most important information from this hash ref is the mandatory B parameter. The I type can be: =over 8 =item C The element is a simple node of a tree instantiated from a configuration class (declared with L). See L. =item C The element is a node whose properties (mostly C) can be changed (warped) according to the values of one or more leaf elements in the configuration tree. See L for details. =item C The element is a scalar value. See L =item C The element is a collection of nodes or values (default). Each element of this collection is identified by a string (Just like a regular hash, except that you can set up constraint of the keys). See L =item C The element is a collection of nodes or values (default). Each element of this collection is identified by an integer (Just like a regular perl array, except that you can set up constraint of the keys). See L =item C The element is a collection of values which are unique in the check_list. See L. =item C Override the default class for leaf, list and hash elements. The override class be inherit L for leaf element, L for hash element and L for list element. =back =head2 Node element When declaring a C element, you must also provide a C parameter. For instance: $model ->create_config_class ( name => "ClassWithOneNode", element => [ the_node => { type => 'node', config_class_name => 'AnotherClass', }, ] ) ; =head2 Leaf element When declaring a C element, you must also provide a C parameter. See L for more details. =head2 Hash element When declaring a C element, you must also provide a C parameter. You can also provide a C parameter set to C or C (default). See L and L for more details. =head2 List element You can also provide a C parameter set to C or C (default). See L and L for more details. =head1 Constructor The C constructor accepts the following parameters: =over =item config_file Specify configuration file to be used by backend. This parameter may override a file declared in the model. Note that this parameter is not propagated in children nodes. =back =head1 Introspection methods =head2 name Returns the location of the node, or its config class name (for root node). =head2 get_type Returns C. =head2 config_model Returns the B configuration model (L object). =head2 model Returns the configuration model of this node (data structure). =head2 config_class_name Returns the configuration class name of this node. =head2 instance Returns the instance object containing this node. Inherited from L =head2 has_element ( name => element_name, [ type => searched_type ] ) Returns 1 if the class model has the element declared or if the element name is matched by the optional C parameter. If C is specified, the element name must also match the type. =head2 find_element ( element_name , [ case => any ]) Returns $name if the class model has the element declared or if the element name is matched by the optional C parameter. If case is set to any, has_element will return the element name who match the passed name in a case-insensitive manner. Returns empty if no matching element is found. =head2 model_searcher () Returns an object dedicated to search an element in the configuration model (respecting privilege level). This method returns a L object. See L for details on how to handle a search. This method is inherited from L. =head2 element_model ( element_name ) Returns model of the element. =head2 element_type ( element_name ) Returns the type (e.g. leaf, hash, list, checklist or node) of the element. =head2 element_name() Returns the element name that contain this object. Inherited from L =head2 index_value() See L =head2 parent() See L =head2 root() See L =head2 location() See L =head2 backend_support_annotation Returns 1 if at least one of the backends attached to self or a parent node support to read and write annotations (aka comments) in the configuration file. =head1 Element property management =head2 get_element_name ( ... ) Return all elements names available. Optional parameters are: =over =item * B: Returns only element of requested type (e.g. C, C, C,...). By default return elements of any type. =item * B: Returns only element which contain requested type. E.g. if C is called with C<< cargo_type => leaf >>, C will return simple leaf elements, but also hash or list element that contain L object. By default return elements of any type. =item * B: C, C or C =back Returns an array in array context, and a string (e.g. C) in scalar context. =head2 children Like get_element_name without parameters. Returns the list of elements. This method is polymorphic for all non-leaf objects of the configuration tree. =head2 next_element ( ... ) This method provides a way to iterate through the elements of a node. Mandatory parameter is C. Optional parameter: C. Returns the next element name for status (default C). Returns undef if no next element is available. =head2 previous_element ( name => element_name ) This method provides a way to iterate through the elements of a node. Returns the previous element name. Returns undef if no previous element is available. =head2 get_element_property ( element => ..., property => ... ) Retrieve a property of an element. I.e. for a model : status => [ X => 'deprecated' ] element => [ X => { ... } ] This call will return C: $node->get_element_property ( element => 'X', property => 'status' ) =head2 set_element_property ( element => ..., property => ... ) Set a property of an element. =head2 reset_element_property ( element => ... ) Reset a property of an element according to the original model. =head1 Information management =head2 fetch_element ( name => .. , [ check => ..] ) Fetch and returns an element from a node. check can be set to yes, no or skip. When check is C or C, can return C when the element is unknown, or 0 if the element is not available (hidden). =head2 fetch_element_value ( name => ... [ check => ...] ) Fetch and returns the I of a leaf element from a node. =head2 store_element_value ( name, value ) Store a I in a leaf element from a node. Can be invoked with named parameters (name, value, check) =head2 is_element_available( name => ..., ) Returns 1 if the element C is available and if the element is not "hidden". Returns 0 otherwise. As a syntactic sugar, this method can be called with only one parameter: is_element_available( 'element_name' ) ; =head2 accept_element( name ) Checks and returns the appropriate model of an acceptable element (be it explicitly declared, or part of an C declaration). Returns undef if the element cannot be accepted. =head2 accept_regexp( name ) Returns the list of regular expressions used to check for acceptable parameters. Useful for diagnostics. =head2 element_exists( element_name ) Returns 1 if the element is known in the model. =head2 is_element_defined( element_name ) Returns 1 if the element is defined. =head2 grab(...) See L. =head2 grab_value(...) See L. =head2 grab_root() See L. =head2 get( path => ..., mode => ... , check => ... , get_obj => 1|0, autoadd => 1|0) Get a value from a directory like path. If C is 1, C will return leaf object instead of returning their value. =head2 set( path , value) Set a value from a directory like path. =head1 data modification =head2 migrate Force a read of the configuration and perform all changes regarding deprecated elements or values. Return 1 if data needs to be saved. =head2 apply_fixes Scan the tree from this node and apply fixes that are attached to warning specifications. See C or C in L. =head2 load ( step => string [ ... ]) Load configuration data from the string into the node and its siblings. This string follows the syntax defined in L. See L for details on parameters. This method can also be called with a single parameter: $node->load("some data:to be=loaded"); =head2 load_data ( data => hash_ref, [ check => $check, ... ]) Load configuration data with a hash ref. The hash ref key must match the available elements of the node (or accepted element). The hash ref structure must match the structure of the configuration model. Use C<< check => skip >> to make data loading more tolerant: bad data will be discarded. C can be called with a single hash ref parameter. =head2 needs_save return 1 if one of the elements of the node's sub-tree has been modified. =head1 Serialization =head2 dump_tree ( ... ) Dumps the configuration data of the node and its siblings into a string. See L for parameter details. This string follows the syntax defined in L. The string produced by C can be passed to C. =head2 dump_annotations_as_pod ( ... ) Dumps the configuration annotations of the node and its siblings into a string. See L for parameter details. =head2 describe ( [ element => ... ] ) Provides a description of the node elements or of one element. =head2 report () Provides a text report on the content of the configuration below this node. =head2 audit () Provides a text audit on the content of the configuration below this node. This audit will show only value different from their default value. =head2 copy_from ( from => another_node_object, [ check => ... ] ) Copy configuration data from another node into this node and its siblings. The copy can be made in a I mode where invalid data is discarded with C<< check => skip >>. This method can be called with a single argument: C<< copy_from($another_node) >> =head1 Help management =head2 get_help ( [ [ description | summary ] => element_name ] ) If called without element, returns the description of the class (Stored in C attribute of a node declaration). If called with an element name, returns the description of the element (Stored in C attribute of a node declaration). If called with 2 argument, either return the C or the C of the element. Returns an empty string if no description was found. =head2 tree_searcher( type => ... ) Returns an object able to search the configuration tree. Parameters are : =over =item type Where to perform the search. It can be C, C, C, C, C, C or C. =back Typically, you will have to call C on this object. Returns a L object. =head2 Lazy load of node data As configuration model are getting bigger, the load time of a tree gets longer. The L class provides a way to load the configuration information only when needed. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut contrib000755001750001750 012676543661 14434 5ustar00domidomi000000000000Config-Model-2.082log4config-model100644001750001750 522412676543661 17653 0ustar00domidomi000000000000Config-Model-2.082/contrib# 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 recursive_warp_value.t100644001750001750 672612676543661 20033 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- # $Author$ # $Date$ # $Revision$ use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More tests => 21; use Test::Memory::Cycle; use Config::Model; use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN ); ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => 'Master', 'element' => [ macro => { type => 'leaf', value_type => 'enum', choice => [qw/A B C/] }, m1 => { type => 'leaf', value_type => 'string', warp => { follow => '- macro', rules => [ A => { default => 'm1_A' }, B => { default => 'm1_B' }, C => { default => 'm1_C' } ] } }, compute => { type => 'leaf', value_type => 'string', compute => [ 'macro is $m, my slot is &slot', 'm' => '! macro' ] }, # second level warp (kinda recursive and scary ...) m2a => { type => 'leaf', value_type => 'string', warp => { follow => '- m1', rules => [ m1_A => { default => 'm2a_A' }, m1_B => { default => 'm2a_B' }, m1_C => { default => 'm2a_C' } ] } }, # second level warp (kinda recursive and scary ...) m2b => { type => 'leaf', value_type => 'string', warp => { follow => '- m1', rules => [ m1_A => { default => 'm2b_A' }, m1_B => { default => 'm2b_B' }, m1_C => { default => 'm2b_C' } ] } }, e1 => { type => 'leaf', value_type => 'enum', 'warp' => { follow => '- macro', 'rules' => [ A => { choice => [qw/e1_A e1_B/], default => 'e1_A' }, B => { choice => [qw/e1_B e1_C/], default => 'e1_B' }, C => { choice => [qw/e1_C e1_D/], default => 'e1_C' } ] } }, e2 => { type => 'leaf', value_type => 'string', warp => { follow => '- e1', rules => [ e1_A => { default => 'e2_A' }, e1_B => { default => 'e2_B' }, e1_C => { default => 'e2_C' } ] } }, ], ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; foreach my $mv (qw/A B C/) { ok( $root->fetch_element('macro')->store($mv), "Set macro to $mv" ); foreach my $element (qw/m1 m2a m2b/) { is( $root->fetch_element($element)->fetch(), $element . '_' . $mv, "Reading Master element $element" ); } foreach my $element (qw/e1 e2/) { is( $root->fetch_element($element)->fetch(), $element . '_' . $mv, "Reading Master element $element" ); } } memory_cycle_ok($model); Value.pm100644001750001750 23310012676543661 17620 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Value; $Config::Model::Value::VERSION = '2.082'; use 5.10.1; use Mouse; use Mouse::Util::TypeConstraints; use MouseX::StrictConstructor; use Parse::RecDescent 1.90.0; use Data::Dumper (); use Config::Model::Exception; use Config::Model::ValueComputer; use Config::Model::IdElementReference; use Config::Model::Warper; use Log::Log4perl qw(get_logger :levels); use Scalar::Util qw/weaken/; use Carp; use Storable qw/dclone/; use Path::Tiny; use List::MoreUtils qw(any) ; extends qw/Config::Model::AnyThing/; with "Config::Model::Role::WarpMaster"; my $logger = get_logger("Tree::Element::Value"); my $change_logger = get_logger("Anything::Change"); my $fix_logger = get_logger("Anything::Fix"); our $nowarning = 0; # global variable to silence warnings. Only used for tests enum ValueType => qw/boolean enum uniline string integer number reference file dir/; has fixes => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } ); has [qw/warp compute computed_refer_to backup migrate_from/] => ( is => 'rw', isa => 'Maybe[HashRef]' ); has compute_obj => ( is => 'ro', isa => 'Maybe[Config::Model::ValueComputer]', builder => '_build_compute_obj', lazy => 1 ); has [qw/write_as/] => ( is => 'rw', isa => 'Maybe[ArrayRef]' ); has [qw/refer_to _data replace_follow/] => ( is => 'rw', isa => 'Maybe[Str]' ); has value_type => ( is => 'rw', isa => 'ValueType' ); my @common_int_params = qw/min max mandatory /; has \@common_int_params => ( is => 'ro', isa => 'Maybe[Int]' ); my @common_hash_params = qw/replace assert warn_if_match warn_unless_match warn_if warn_unless help/; has \@common_hash_params => ( is => 'ro', isa => 'Maybe[HashRef]' ); my @common_list_params = qw/choice/; has \@common_list_params => ( is => 'ro', isa => 'Maybe[ArrayRef]' ); my @common_str_params = qw/default upstream_default convert match grammar warn/; has \@common_str_params => ( is => 'ro', isa => 'Maybe[Str]' ); my @warp_accessible_params = ( @common_int_params, @common_str_params, @common_list_params, @common_hash_params ); my @allowed_warp_params = ( @warp_accessible_params, qw/level help/ ); my @backup_list = ( @allowed_warp_params, qw/migrate_from/ ); has compute_is_upstream_default => ( is => 'ro', isa => 'Bool', lazy => 1, builder => '_compute_is_upstream_default' ); sub _compute_is_upstream_default { my $self = shift; return 0 unless defined $self->compute; return $self->compute_obj->use_as_upstream_default; } has compute_is_default => ( is => 'ro', isa => 'Bool', lazy => 1, builder => '_compute_is_default' ); sub _compute_is_default { my $self = shift; return 0 unless defined $self->compute; return !$self->compute_obj->use_as_upstream_default; } has error_list => ( is => 'ro', isa => 'ArrayRef', default => sub { [] }, traits => ['Array'], handles => { add_error => 'push', clear_errors => 'clear', error_msg => [ join => "\n" ], has_error => 'count', all_errors => 'elements', is_ok => 'is_empty' } ); has warning_list => ( is => 'ro', isa => 'ArrayRef', default => sub { [] }, traits => ['Array'], handles => { add_warning => 'push', clear_warnings => 'clear', warning_msg => [ join => "\n\t" ], has_warning => 'count', all_warnings => 'elements', } ); # as some information must be backed up even though they are not # attributes, we cannot move below code in BUILD. around BUILDARGS => sub { my $orig = shift; my $class = shift; my %args = @_; my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @backup_list; return $class->$orig( backup => dclone( \%h ), @_ ); }; sub BUILD { my $self = shift; $self->set_properties(); # set will use backup data # used when self is a warped slave if ( my $warp_info = $self->warp ) { $self->{warper} = Config::Model::Warper->new( warped_object => $self, %$warp_info, allowed => \@allowed_warp_params ); } $self->_init; return $self; } override 'needs_check' => sub { my $self = shift; if ($self->instance->layered) { # don't check value and don't store value in layered mode return 0; } elsif (@_) { return super(); } else { # some items like idElementReference are too complex to propagate # a change notification back to the value using them. So an error or # warning must always be rechecked. return ($self->value_type eq 'reference' or super()) ; } }; sub notify_change { my $self = shift; my %args = @_; my $check_done = $args{check_done} || 0; return if $self->instance->initial_load and not $args{really}; $change_logger->debug( "called while needs_check is ", $self->needs_check, " for ", $self->name, " with ", join( ' ', %args ) ) if $change_logger->is_debug; $self->needs_check(1) unless $check_done; { no warnings 'uninitialized'; croak "needless change with $args{new}" if defined $args{old} and defined $args{new} and $args{old} eq $args{new}; } $self->SUPER::notify_change( %args, value_type => $self->value_type ); # notify all warped or computed objects that depends on me foreach my $s ( $self->get_depend_slave ) { $change_logger->debug( "calling notify_change on slave ", $s->name ) if $change_logger->is_debug; $s->notify_change( note => 'master triggered changed' ); } } # internal method sub set_default { my ( $self, $arg_ref ) = @_; if ( exists $arg_ref->{built_in} ) { $arg_ref->{upstream_default} = delete $arg_ref->{built_in}; warn $self->name, " warning: deprecated built_in parameter, ", "use upstream_default\n"; } if ( defined $arg_ref->{default} and defined $arg_ref->{upstream_default} ) { Config::Model::Exception::Model->throw( object => $self, error => "Cannot specify both 'upstream_default' and " . "'default' parameters", ); } foreach my $item (qw/upstream_default default/) { my $def = delete $arg_ref->{$item}; next unless defined $def; $self->transform_boolean( \$def ) if $self->value_type eq 'boolean'; # will check default value $self->check_value( value => $def ); Config::Model::Exception::Model->throw( object => $self, error => "Wrong $item value\n\t" . $self->error_msg ) if $self->has_error; $logger->debug( "Set $item value for ", $self->name, "" ); $self->{$item} = $def; } } # set up relation between objects required by the compute constructor # parameters sub _build_compute_obj { my $self = shift; $logger->debug("called"); my $c_info = $self->compute; return unless $c_info; my @compute_data; foreach ( keys %$c_info ) { push @compute_data, $_, $c_info->{$_} if defined $c_info->{$_}; } my $ret = Config::Model::ValueComputer->new( @compute_data, value_object => $self, value_type => $self->{value_type}, ); # resolve any recursive variables before registration my $v = $ret->compute_variables; $self->register_in_other_value($v); $logger->debug("done"); return $ret; } sub register_in_other_value { my $self = shift; my $var = shift; # register compute or refer_to dependency. This info may be used # by other tools foreach my $path ( values %$var ) { if ( defined $path and not ref $path ) { # 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); } } } # internal sub perform_compute { my $self = shift; $logger->debug("called"); my $result = $self->compute_obj->compute; # check if the computed result fits with the constraints of the # Value object my $ok = $self->check_fetched_value($result); if ( not $ok ) { my $error = $self->error_msg . "\n\t" . $self->compute_info; Config::Model::Exception::WrongValue->throw( object => $self, error => "computed value error:\n\t" . $error ); } $logger->debug("done"); return $ok ? $result : undef; } # internal, used to generate error messages sub compute_info { my $self = shift; $self->compute_obj->compute_info; } sub set_migrate_from { my ( $self, $arg_ref ) = @_; my $mig_ref = delete $arg_ref->{migrate_from}; if ( ref($mig_ref) eq 'HASH' ) { $self->migrate_from($mig_ref); } else { Config::Model::Exception::Model->throw( object => $self, error => "migrate_from value must be a hash ref not $mig_ref" ); } my @migrate_data; foreach (qw/formula variables replace use_eval undef_is/) { push @migrate_data, $_, $mig_ref->{$_} if defined $mig_ref->{$_}; } $self->{_migrate_from} = Config::Model::ValueComputer->new( @migrate_data, value_object => $self, value_type => $self->{value_type} ); # resolve any recursive variables before registration my $v = $self->{_migrate_from}->compute_variables; } # FIXME: should it be used only once ??? sub migrate_value { my $self = shift; return undef if $self->{migration_done}; return undef if $self->instance->initial_load; $self->{migration_done} = 1; # avoid warning when reading deprecated values my $result = $self->{_migrate_from}->compute( check => 'no' ); return undef unless defined $result; # check if the migrated result fits with the constraints of the # Value object my $ok = $self->check_value( value => $result ); #print "check result: $ok\n"; if ( not $ok ) { my $error = $self->error_msg . "\n\t" . $self->{_migrate_from}->compute_info; Config::Model::Exception::WrongValue->throw( object => $self, error => "migrated value error:\n\t" . $error ); } # old value is always undef when this method is called $self->notify_change( note => 'migrated value', new => $result ) if length($result); # skip empty value (i.e. '') $self->{data} = $result; return $ok ? $result : undef; } sub setup_enum_choice { my $self = shift; my @choice = ref $_[0] ? @{ $_[0] } : @_; $logger->debug( $self->name, " setup_enum_choice with '", join( "','", @choice ), "'" ); $self->{choice} = \@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}; map { $self->{choice_hash}{$_} = 1; } @choice; # delete the current value if it does not fit in the new # choice map { my $lv = $self->{$_}; delete $self->{$_} if ( defined $lv and not defined $self->{choice_hash}{$lv} ); } qw/data preset/; } sub setup_match_regexp { my ( $self, $what, $ref ) = @_; my $str = $self->{$what} = delete $ref->{$what}; return unless defined $str; my $vt = $self->{value_type}; if ( $vt ne 'uniline' and $vt ne 'string' ) { Config::Model::Exception::Model->throw( object => $self, error => "Can't use $what regexp with $vt, " . "expected 'uniline' or 'string'" ); } $logger->debug( $self->name, " setup $what regexp with '$str'" ); $self->{ $what . '_regexp' } = eval { qr/$str/; }; if ($@) { Config::Model::Exception::Model->throw( object => $self, error => "Unvalid $what regexp for '$str': $@" ); } } sub check_validation_regexp { my ( $self, $what, $ref ) = @_; my $regexp_info = delete $ref->{$what}; return unless defined $regexp_info; $self->{$what} = $regexp_info; my $vt = $self->{value_type}; if ( $vt ne 'uniline' and $vt ne 'string' ) { Config::Model::Exception::Model->throw( object => $self, error => "Can't use $what regexp with $vt, " . "expected 'uniline' or 'string'" ); } if ( not ref $regexp_info and $what ne 'warn' ) { warn $self->name, ": deprecated $what style. Use a hash ref\n"; } my $h = ref $regexp_info ? $regexp_info : { $regexp_info => '' }; # just check the regexp. values are checked later in &check_value foreach my $regexp ( keys %$h ) { $logger->debug( $self->name, " hash $what regexp with '$regexp'" ); eval { qr/$regexp/; }; if ($@) { Config::Model::Exception::Model->throw( object => $self, error => "Unvalid $what regexp '$regexp': $@" ); } my $v = $h->{$regexp}; Config::Model::Exception::Model->throw( object => $self, error => "value of $what regexp '$regexp' is not a hash ref but '$v'" ) unless ref $v eq 'HASH'; } } sub setup_grammar_check { my ( $self, $ref ) = @_; my $str = $self->{grammar} = delete $ref->{grammar}; return unless defined $str; my $vt = $self->{value_type}; if ( $vt ne 'uniline' and $vt ne 'string' ) { Config::Model::Exception::Model->throw( object => $self, error => "Can't use match regexp with $vt, " . "expected 'uniline' or 'string'" ); } my @lines = split /\n/, $str; chomp @lines; if ( $lines[0] !~ /^check:/ ) { $lines[0] = 'check: ' . $lines[0] . ' /\s*\Z/ '; } my $actual_grammar = join( "\n", @lines ) . "\n"; $logger->debug( $self->name, " setup_grammar_check with '$actual_grammar'" ); eval { $self->{validation_parser} = Parse::RecDescent->new($actual_grammar); }; if ($@) { Config::Model::Exception::Model->throw( object => $self, error => "Unvalid grammar for '$str': $@" ); } } # warning : call to 'set' are not cumulative. Default value are always # restored. Lest keeping track of what was modified with 'set' is # too confusing. sub set_properties { my $self = shift; # cleanup all parameters that are handled by warp map( delete $self->{$_}, @allowed_warp_params ); # merge data passed to the constructor with data passed to set_properties my %args = ( %{ $self->{backup} }, @_ ); # these are handled by Node or Warper map { delete $args{$_} } qw/level/; my $logger = $logger; if ( $logger->is_debug ) { $logger->debug( "Leaf '" . $self->name . "' set_properties called with '", join( "','", sort keys %args ), "'" ); } if ( defined $args{value_type} and $args{value_type} eq 'reference' and not defined $self->{refer_to} and not defined $self->{computed_refer_to} ) { Config::Model::Exception::Model->throw( object => $self, error => "Missing 'refer_to' or 'computed_refer_to' " . "parameter with 'reference' value_type " ); } map { $self->{$_} = delete $args{$_} if defined $args{$_} } qw/min max mandatory replace warn replace_follow assert warn_if warn_unless write_as/; $self->set_help( \%args ); $self->set_value_type( \%args ); $self->set_default( \%args ); $self->set_convert( \%args ) if defined $args{convert}; $self->setup_match_regexp( match => \%args ) if defined $args{match}; foreach (qw/warn_if_match warn_unless_match/) { $self->check_validation_regexp( $_ => \%args ) if defined $args{$_}; } $self->setup_grammar_check( \%args ) if defined $args{grammar}; # cannot be warped $self->set_migrate_from( \%args ) if defined $args{migrate_from}; Config::Model::Exception::Model->throw( object => $self, error => "write_as is allowed only with boolean values" ) if defined $self->{write_as} and $self->{value_type} ne 'boolean'; Config::Model::Exception::Model->throw( object => $self, error => "Unexpected parameters: " . join( ' ', each %args ) ) if scalar keys %args; if ( $self->has_warped_slaves ) { my $value = $self->_fetch_no_check; $self->trigger_warp($value); } # when properties are changed, a check is required to validate new constraints $self->needs_check(1); return $self; } # simple but may be overridden sub set_help { my ( $self, $args ) = @_; return unless defined $args->{help}; $self->{help} = delete $args->{help}; } # this code is somewhat dead as warping value_type is no longer supported # but it may come back. sub set_value_type { my ( $self, $arg_ref ) = @_; my $value_type = delete $arg_ref->{value_type} || $self->value_type; Config::Model::Exception::Model->throw( object => $self, error => "Value set: undefined value_type" ) unless defined $value_type; $self->{value_type} = $value_type; if ( $value_type eq 'boolean' ) { # convert any value to boolean $self->{data} = $self->{data} ? 1 : 0 if defined $self->{data}; $self->{preset} = $self->{preset} ? 1 : 0 if defined $self->{preset}; $self->{layered} = $self->{layered} ? 1 : 0 if defined $self->{layered}; } elsif ($value_type eq 'reference' or $value_type eq 'enum' ) { my $choice = delete $arg_ref->{choice}; $self->setup_enum_choice($choice) if defined $choice; } elsif (any {$value_type eq $_} qw/string integer number uniline file dir/ ) { Config::Model::Exception::Model->throw( object => $self, error => "'choice' parameter forbidden with type " . $value_type ) if defined $arg_ref->{choice}; } else { my $msg = "Unexpected value type : '$value_type' " . "expected 'boolean', 'enum', 'uniline', 'string' or 'integer'." . "Value type can also be set up with a warp relation"; Config::Model::Exception::Model->throw( object => $self, error => $msg ) unless defined $self->{warp}; } } 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, ); # refer_to registration is done for all element that are used as # variable for complex reference (ie '- $foo' , {foo => '- bar'} ) $self->register_in_other_value( $self->{computed_refer_to}{variables} ); } else { croak "value's submit_to_refer_to: undefined refer_to or computed_refer_to"; } } sub setup_reference_choice { my $self = shift; $self->setup_enum_choice(@_); } sub reference_object { my $self = shift; return $self->{ref_object}; } sub built_in { carp "warning: built_in sub is deprecated, use upstream_default"; goto &upstream_default; } ## FIXME::what about id ?? sub name { my $self = shift; my $name = $self->{parent}->name . ' ' . $self->{element_name}; $name .= ':' . $self->{index_value} if defined $self->{index_value}; return $name; } sub get_type { return 'leaf'; } sub get_cargo_type { return 'leaf'; } sub can_store { my $self = shift; return not defined $self->compute || $self->compute_obj->allow_user_override; } sub get_default_choice { my $self = shift; return @{ $self->{backup}{choice} || [] }; } sub get_choice { my $self = shift; # just in case the reference_object has been changed if ( defined $self->{refer_to} or defined $self->{computed_refer_to} ) { $self->{ref_object}->get_choice_from_refered_to; } return @{ $self->{choice} || [] }; } 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; } # construct an error message for enum types sub enum_error { my ( $self, $value ) = @_; my @error; if ( not defined $self->{choice} ) { push @error, "$self->{value_type} type has no defined choice", $self->warp_error; return @error; } my @choice = map( "'$_'", $self->get_choice ); my $var = $self->{value_type}; my $str_value = defined $value ? $value : ''; push @error, "$self->{value_type} type does not know '$value'. Expected " . join( " or ", @choice ); push @error, "Expected list is given by '" . join( "', '", @{ $self->{refered_to_path} } ) . "'" if $var eq 'reference' && defined $self->{refered_to_path}; push @error, $self->warp_error if $self->{warp}; return @error; } sub check_value { my $self = shift; croak "check_value needs a value to check" unless @_ > 1; my %args = @_; my $value = $args{value}; my $quiet = $args{quiet} || 0; my $check = $args{check} || 'yes'; my $apply_fix = $args{fix} || 0; my $mode = $args{mode} || 'backend'; my $cb = delete $args{callback}; carp "callback parameter is deprecated" if defined $cb; #croak "Cannot specify a value with fix = 1" if $apply_fix and exists $args{value} ; if ( $logger->is_debug ) { no warnings 'uninitialized'; my $v = defined $value ? $value : ''; my $loc = $self->location; my $msg = "called from " . join( ' ', caller ) . " with value '$v' mode $mode check $check on '$loc'"; $logger->debug($msg); } # need to keep track to update GUI $self->{nb_of_fixes} = 0; # reset before check my @error; my @warn; my $vt = $self->value_type ; if ( not defined $value ) { # accept with no other check } elsif ( not defined $vt ) { push @error, "Undefined value_type"; } elsif (( $vt =~ /integer/ and $value =~ /^-?\d+$/ ) or ( $vt =~ /number/ and $value =~ /^-?\d+(\.\d+)?$/ ) ) { # correct number or integer. check min max push @error, "value $value > max limit $self->{max}" if defined $self->{max} and $value > $self->{max}; push @error, "value $value < min limit $self->{min}" if defined $self->{min} and $value < $self->{min}; } elsif ( $vt =~ /integer/ and $value =~ /^-?\d+(\.\d+)?$/ ) { push @error, "Type $vt: value $value is a number " . "but not an integer"; } elsif ( $vt eq 'file' or $vt eq 'dir' ) { if (defined $value) { my $path = path($value); if ($path->exists) { my $check = 'is_'.$vt ; push @warn, "$value is not a $vt" if not path($value)->$check; } else { push @warn, "$vt $value does not exists" ; } } } elsif ( $vt eq 'reference' ) { # just in case the reference_object has been changed if ( defined $self->{refer_to} or defined $self->{computed_refer_to} ) { $self->{ref_object}->get_choice_from_refered_to; } if ( length($value) and defined $self->{choice_hash} and not defined $self->{choice_hash}{$value} ) { push @error, ( $quiet ? 'reference error' : $self->enum_error($value) ); } } elsif ( $vt eq 'enum' ) { if ( length($value) and defined $self->{choice_hash} and not defined $self->{choice_hash}{$value} ) { push @error, ( $quiet ? 'enum error' : $self->enum_error($value) ); } } elsif ( $vt eq 'boolean' ) { push @error, "boolean error: '$value' is not '1' or '0'" unless $value =~ /^[01]$/; } elsif ($vt =~ /integer/ or $vt =~ /number/ ) { push @error, "Value '$value' is not of type " . $vt; } elsif ( $vt eq 'uniline' ) { push @error, '"uniline" value must not contain embedded newlines (\n)' if $value =~ /\n/; } elsif ( $vt eq 'string' ) { # accepted, no more check } else { my $choice_msg = ''; $choice_msg .= ", choice " . join( " ", $self->get_choice ) . ")" if defined $self->{choice}; my $msg = "Cannot check value_type '$vt' (value '$value'$choice_msg)"; Config::Model::Exception::Model->throw( object => $self, message => $msg ); } # a value may be mandatory and have a default value with layers if ( $self->{mandatory} and $check eq 'yes' and ( $mode =~ /backend|user/ ) and ( not defined $value or not length($value) ) and ( not defined $self->{layered} or not length($self->{layered})) ) { # check only "empty" mode. my $msg = "Undefined mandatory value."; $msg .= $self->warp_error if defined $self->{warped_attribute}{default}; push @error, $msg; } if ( defined $self->{match_regexp} and defined $value ) { push @error, "value '$value' does not match regexp " . $self->{match} unless $value =~ $self->{match_regexp}; } if ( $mode ne 'custom' ) { if ( $self->{warn_if_match} ) { my $test_sub = sub { my ( $v, $r ) = @_; $v =~ /$r/ ? 0 : 1; }; $self->run_regexp_set_on_value( \$value, $apply_fix, \@warn, 'not ', $test_sub, $self->{warn_if_match} ); } if ( $self->{warn_unless_match} ) { my $test_sub = sub { my ( $v, $r ) = @_; $v =~ /$r/ ? 1 : 0; }; $self->run_regexp_set_on_value( \$value, $apply_fix, \@warn, '', $test_sub, $self->{warn_unless_match} ); } $self->run_code_set_on_value( \$value, $apply_fix, \@error, "assert failure", $self->{assert} ) if $self->{assert}; $self->run_code_set_on_value( \$value, $apply_fix, \@warn, "warn_unless code check returned false", $self->{warn_unless} ) if $self->{warn_unless}; $self->run_code_set_on_value( \$value, $apply_fix, \@warn, "warn_if code check returned true", $self->{warn_if}, 1 ) if $self->{warn_if}; } # unconditional warn push @warn, $self->{warn} if defined $value and $self->{warn}; if ( defined $self->{validation_parser} and defined $value ) { my $prd = $self->{validation_parser}; my ( $err_msg, $warn_msg ) = ( '', '' ); my $prd_check = $prd->check( $value, 1, $self, \$err_msg, \$warn_msg ); my $prd_result = defined $prd_check ? 1 : 0; $logger->debug( "grammar check on $value returned ", defined $prd_check ? $prd_check : '' ); push @error, $err_msg || "value '$value' does not match grammar from model" unless $prd_result; push @warn, $warn_msg if $warn_msg; } $logger->debug( "check_value returns ", scalar @error, " errors and ", scalar @warn, " warnings" ); $self->clear_errors; $self->clear_warnings; $self->add_error(@error) if @error; $self->add_warning(@warn) if @warn; $args{value} = $value; # may be updated by apply_fix $logger->debug("done"); $cb->( %args, ok => not @error ) if $cb; my $ok = not @error; return wantarray ? ($ok, $value) : $ok; } sub run_code_on_value { my ( $self, $value_r, $apply_fix, $array, $label, $sub, $msg, $fix ) = @_; $logger->info( $self->location . ": run_code_on_value called (apply_fix $apply_fix)" ); my $ret = $sub->($$value_r); if ( $logger->is_debug ) { my $str = defined $ret ? $ret : ''; $logger->debug("run_code_on_value sub returned '$str'"); } unless ($ret) { $logger->debug("run_code_on_value sub returned false"); push @$array, $msg unless $apply_fix; $self->{nb_of_fixes}++ if ( defined $fix and not $apply_fix ); $self->apply_fix( $fix, $value_r ) if ( defined $fix and $apply_fix ); } } sub run_code_set_on_value { my ( $self, $value_r, $apply_fix, $array, $msg, $w_info, $invert ) = @_; foreach my $label ( sort keys %$w_info ) { my $code = $w_info->{$label}{code}; my $msg = $w_info->{$label}{msg} || $msg; $logger->trace("eval'ed code is: '$code'"); my $fix = $w_info->{$label}{fix}; $msg =~ s/\$_/$$value_r/g if defined $$value_r; $msg .= " (this can be fixed with 'cme fix' command)" if $fix; my $sub = sub { local $_ = shift; no warnings "uninitialized"; my $ret = eval($code); if ($@) { Config::Model::Exception::Model->throw( object => $self, message => "Eval of code failed : $@" ); } return $invert ^ $ret; }; $self->run_code_on_value( $value_r, $apply_fix, $array, $label, $sub, $msg, $fix ); } } sub run_regexp_set_on_value { my ( $self, $value_r, $apply_fix, $array, $msg, $test_sub, $w_info ) = @_; # no need to check default or computed values return unless defined $$value_r; foreach my $rxp ( keys %$w_info ) { # $_[0] is set to $$value_r when $sub is called my $sub = sub { $test_sub->( $_[0], $rxp ) }; my $msg = $w_info->{$rxp}{msg} || "value '$$value_r' should $msg" . "match regexp $rxp"; my $fix = $w_info->{$rxp}{fix}; $self->run_code_on_value( $value_r, $apply_fix, $array, 'regexp', $sub, $msg, $fix ); } } sub has_fixes { my $self = shift; return $self->{nb_of_fixes}; } sub apply_fixes { my $self = shift; if ( $logger->is_debug ) { $fix_logger->debug( "called for " . $self->location ); } my ( $old, $new ); my $i = 0; do { $old = $self->{nb_of_fixes} // 0; $self->check_value( value => $self->_fetch_no_check, fix => 1 ); $new = $self->{nb_of_fixes}; $self->check_value( value => $self->_fetch_no_check ); # if fix fails, try and check_fix call each other until this limit is found if ( $i++ > 20 ) { Config::Model::Exception::Model->throw( object => $self, error => "Too many fix loops: check code used to fix value or the check" ); } } while ( $self->{nb_of_fixes} and $old > $new ); } # internal: called by check when a fix is required sub apply_fix { my ( $self, $fix, $value_r ) = @_; local $_ = $$value_r; # used inside $fix sub ref if ( $fix_logger->is_debug ) { my $str = $fix; $str =~ s/\n/ /g; $fix_logger->info( $self->location . ": Applying fix '$str'" ); } eval($fix); if ($@) { Config::Model::Exception::Model->throw( object => $self, message => "Eval of fix $fix failed : $@" ); } no warnings "uninitialized"; if ( $_ ne $$value_r ) { $self->_store_fix( $$value_r, $_ ); } else { $fix_logger->info( $self->location . ": fix did not change value '$$value_r'" ); } } sub _store_fix { my ( $self, $old, $new ) = @_; $self->{data} = $new; if ( $fix_logger->is_trace ) { $fix_logger->trace( "fix change: '" . ( $old // '' ) . "' -> '" . ( $new // '' ) . "'" ); } my %args = ( old => $old // $self->_fetch_std, new => $new // $self->_fetch_std, note => 'applied fix' ) ; no warnings "uninitialized"; # in case $old is the default value and $new is undef $self->notify_change( %args ) if $args{old} ne $args{new}; } # read checks should be blocking sub check { goto &check_fetched_value; } sub check_fetched_value { my $self = shift; if ( $logger->is_debug ) { no warnings 'uninitialized'; $logger->debug( "called for " . $self->location . " from " . join( ' ', caller ), " with @_" ); } my %args = @_ == 0 ? ( value => $self->{data} ) : @_ == 1 ? ( value => $_[0] ) : @_; my $value = exists $args{value} ? $args{value} : $self->{data}; my $silent = $args{silent} || 0; my $check = $args{check} || 'yes'; if ( $self->needs_check ) { $self->check_value(%args); my $err_count = $self->has_error; my $warn_count = $self->has_warning; $logger->debug("done with $err_count errors and $warn_count warnings"); $self->needs_check(0) unless $err_count or $warn_count; } else { $logger->debug("is not needed"); } # old_warn is used to avoid warning the user several times for the # same reason. We take care to clean up this hash each time this routine # is run my $old_warn = $self->{old_warning_hash} || {}; my %warn_h; if ( $self->has_warning and not $nowarning and not $silent ) { foreach my $w ( $self->all_warnings ) { $warn_h{$w} = 1; next if $old_warn->{$w}; my $str = defined $value ? "'$value'" : ''; warn "Warning in '" . $self->location_short . "' value $str: $w\n"; } } $self->{old_warning_hash} = \%warn_h; return wantarray ? $self->all_errors : $self->is_ok; } sub store { my $self = shift; my %args = @_ == 1 ? ( value => $_[0] ) : @_ == 3 ? ( 'value', @_ ) : @_; my $check = $self->_check_check( $args{check} ); my $silent = $args{silent} || 0; my $str = $args{value} // ''; $logger->debug( "called with '$str' on ", $self->composite_name ) if $logger->is_debug; # store with check skip makes sense when force loading data: bad value # is discarded, partially consistent values are stored so the user may # salvage them before next save check discard them # $self->{data} represents what written in the file my $old_value = $self->{data}; my $incoming_value = $args{value}; $self->transform_boolean( \$incoming_value ) if $self->value_type eq 'boolean'; my $value = $self->transform_value( value => $incoming_value, check => $check ); no warnings qw/uninitialized/; if ($self->instance->initial_load) { # may send more than one notification if ( $incoming_value ne $value ) { # data was transformed by model $self->notify_change(really => 1, old => $incoming_value , new => $value, note =>"initial value changed by model"); } if (defined $old_value and $old_value ne $value) { $self->notify_change(really => 1, old => $old_value , new => $value, note =>"conflicting initial values"); } if (defined $old_value and $old_value eq $value) { $self->notify_change(really => 1, note =>"removed redundant initial value"); } } if ( defined $old_value and $value eq $old_value ) { $logger->info( "skip storage of ", $self->composite_name, " unchanged value: $value" ) if $logger->is_debug; return 1; } use warnings qw/uninitialized/; $self->needs_check(1); # always when storing a value my ($ok, $fixed_value) = $self->check_stored_value( value => $value, check => $check, silent => $silent, ); $self->_store( %args, ok => $ok, value => $value, check => $check ); my $user_cb = $args{callback} ; $user_cb->(%args) if $user_cb; return $ok; } # # New subroutine "_store_value" extracted - Wed Jan 16 18:46:22 2013. # sub _store_value { my $self = shift; my $value = shift; my $notify_change = shift // 1; if ( $self->instance->layered ) { $self->{layered} = $value; } elsif ( $self->instance->preset ) { $self->notify_change( check_done => 1, old => $self->{data}, new => $value ) if $notify_change; $self->{preset} = $value; } else { no warnings 'uninitialized'; my $old = $self->{data} // $self->_fetch_std; my $new = $value // $self->_fetch_std; $self->notify_change( check_done => 1, old => $old, new => $new ) if $notify_change and ( $old ne $new ); $self->{data} = $value; # may be undef } return $value; } # this method is overriden in layered Value sub _store { my $self = shift; my %args = @_; my ( $value, $check, $silent, $notify_change, $ok ) = @args{qw/value check silent notify_change ok/}; if ( $logger->is_debug ) { my $i = $self->instance; my $msg = "value store $value, ok '$ok', check is $check"; map { $msg .= " $_" if $i->$_() } qw/layered preset/; $logger->debug($msg); } my $old_value = $self->_fetch_no_check; # FIXME: storing wrong value does not make sense # we let store the value even if wrong when check is disabled if ( $ok or $check eq 'no' ) { $self->instance->cancel_error( $self->location ); $self->_store_value( $value, $notify_change ); } else { $self->instance->add_error( $self->location ); if ($check eq 'skip') { no warnings 'uninitialized'; my $msg = "Warning: ".$self->location." skipping value $value because of the following errors:\n" . $self->error_msg . "\n\n"; if (not $silent and $msg) { # fuse UI exits when a warning is issued. No other need to advertise this option print $msg if $args{say_dont_warn}; warn $msg unless $args{say_dont_warn}; } } else { Config::Model::Exception::WrongValue->throw( object => $self, error => $self->error_msg ); } } if ( $ok and defined $value and $self->has_warped_slaves and ( not defined $old_value or $value ne $old_value ) and not( $self->instance->layered or $self->instance->preset ) ) { $self->trigger_warp($value); } $logger->debug( "_store done on ", $self->composite_name ) if $logger->is_debug; } # # New subroutine "transform_boolean" extracted - Thu Sep 19 18:58:21 2013. # sub transform_boolean { my $self = shift; my $v_ref = shift; return unless defined $$v_ref; if ( my $wa = $self->{write_as} ) { my $i = 0; map { $$v_ref = $i if ( $wa->[$i] eq $$v_ref ); $i++ } @$wa; } # convert yes no to 1 or 0 $$v_ref = 1 if ( $$v_ref =~ /^y/i or $$v_ref =~ /true/i ); $$v_ref = 0 if ( $$v_ref =~ /^n/i or $$v_ref =~ /false/i ); } # internal. return ( undef, value) # May return an undef value if actual store should be skipped sub transform_value { my $self = shift; my %args = @_ > 1 ? @_ : ( value => $_[0] ); my $value = $args{value}; my $check = $args{check} || 'yes'; my $inst = $self->instance; $self->warp if ($self->{warp} and defined $self->{warp_info} and @{ $self->{warp_info}{computed_master} } ); if ( defined $self->compute_obj and not $self->compute_obj->allow_user_override ) { my $msg = 'assignment to a computed value is forbidden unless ' . 'compute -> allow_override is set.'; Config::Model::Exception::Model->throw( object => $self, message => $msg ) if $check eq 'yes'; return; } if ( defined $self->{refer_to} or defined $self->{computed_refer_to} ) { $self->{ref_object}->get_choice_from_refered_to; } $value = $self->{convert_sub}($value) if ( defined $self->{convert_sub} and defined $value ); if ( defined $self->{replace} ) { if ( defined $self->{replace}{$value} ) { $logger->debug("store replacing value $value with $self->{replace}{$value}"); $value = $self->{replace}{$value}; } else { foreach my $k ( keys %{ $self->{replace} } ) { if ( $value =~ /^$k$/ ) { $logger->debug( "store replacing value $value (matched /$k/) with $self->{replace}{$k}"); $value = $self->{replace}{$k}; last; } } } } # using default or computed value is normally done on fetch. Except that an undefined # value cannot be stored in a mandatory value. Storing undef is used when resetting a # value to default. If a value is mandatory, we must store the default (or best equivalent) # instead if ( ( not defined $value or not length($value) ) and $self->mandatory ) { delete $self->{data}; # avoiding recycling the old stored value $value = $self->_fetch_no_check; } return $value; } sub check_stored_value { my $self = shift; my %args = @_; my ($ok, $fixed_value) = $self->check_value( %args ); my ( $value, $check, $silent ) = @args{qw/value check silent/}; $self->needs_check(0) unless $self->has_error or $self->has_warning; # old_warn is used to avoid warning the user several times for the # same reason. We take care to clean up this hash each time this routine # is run my $old_warn = $self->{old_warning_hash} || {}; my %warn_h; if ( $self->has_warning and not $nowarning and not $silent ) { foreach my $w ( $self->all_warnings ) { $warn_h{$w} = 1; next if $old_warn->{$w}; my $str = defined $value ? "'$value'" : ''; warn "Warning in '" . $self->location_short . "' value $str: $w\n"; } } $self->{old_warning_hash} = \%warn_h; return wantarray ? ($ok,$fixed_value) : $ok; } # print a hopefully helpful error message when value_type is not # defined sub _value_type_error { my $self = shift; Config::Model::Exception::Model->throw( object => $self, message => 'value_type is undefined' ) unless defined $self->{warp}; my $str = "Item " . $self->{element_name} . " is not available. " . $self->warp_error; Config::Model::Exception::User->throw( object => $self, message => $str ); } sub load_data { my $self = shift; my %args = @_ > 1 ? @_ : ( data => shift ); my $data = delete $args{data} // delete $args{value}; if ( ref $data ) { Config::Model::Exception::LoadData->throw( object => $self, message => "load_data called with non scalar arg", wrong_data => $data, ); } else { if ( $logger->is_info ) { $logger->info( "Value load_data (", $self->location, ") will store value $data" ); } $self->store(%args, value => $data); } } sub fetch_custom { my $self = shift; return $self->fetch(mode => 'custom'); } sub fetch_standard { my $self = shift; return $self->fetch(mode => 'standard'); } sub _init { my $self = shift; # trigger loop #$self->{warper} -> trigger if defined $self->{warper} ; # if ($self->{warp} and defined $self->{warp_info} # and @{$self->{warp_info}{computed_master}}); if ( defined $self->{refer_to} or defined $self->{computed_refer_to} ) { $self->submit_to_refer_to; $self->{ref_object}->get_choice_from_refered_to; } } # returns something that needs to be written to config file # unless overridden by user data sub _fetch_std { my ( $self, $check ) = @_; #$self->_init ; my $inst = $self->instance; if ( not defined $self->{value_type} and $check eq 'yes' ) { $self->_value_type_error; } # get stored value or computed value or default value my $std_value; eval { $std_value = defined $self->{preset} ? $self->{preset} : $self->compute_is_default ? $self->perform_compute : $self->{default}; }; my $e = $@;; if ( ref($e) and $e->isa('Config::Model::Exception::User') ) { if ( $check eq 'yes' ) { $e->rethrow; } $std_value = undef; } elsif ( ref($e) ) { $e->rethrow ; } elsif ($e) { die $e; } return $std_value; } my %old_mode = ( built_in => 'upstream_default', non_built_in => 'non_upstream_default', ); my %accept_mode = map { ( $_ => 1 ) } qw/custom standard preset default upstream_default layered non_upstream_default allow_undef user backend/; sub _fetch { my ( $self, $mode, $check ) = @_; $logger->debug( "called for " . $self->location ) if $logger->is_debug; # always call to perform submit_to_warp my $pref = $self->_fetch_std( $check ); my $data = $self->{data}; if ( defined $pref and not $self->{notified_change_for_default} and not defined $data ) { $self->{notified_change_for_default} = 1; my $info = defined $self->{preset} ? 'preset' : $self->compute_is_default ? 'computed' : 'default'; $self->notify_change( old => undef, new => $pref, note => "use $info value" ); } my $known_upstream = defined $self->{layered} ? $self->{layered} : $self->compute_is_upstream_default ? $self->perform_compute : $self->{upstream_default}; my $std = defined $pref ? $pref : $known_upstream; if ( not defined $data and defined $self->{_migrate_from} ) { $data = $self->migrate_value; } 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 ( $mode and not defined $accept_mode{$mode} ) { croak "fetch_no_check: expected ", join( ' or ', keys %accept_mode ), " parameter, not $mode"; } if ( $mode eq 'custom' ) { no warnings "uninitialized"; my $cust; $cust = $data if $data ne $pref and $data ne $self->{upstream_default} and $data ne $self->{layered}; $logger->debug( "done in custom mode for " . $self->location ) if $logger->is_debug; return $cust; } if ( $mode eq 'non_upstream_default' ) { no warnings "uninitialized"; my $nbu = defined $data && $data ne $self->{upstream_default} ? $data : defined $pref && $pref ne $self->{upstream_default} ? $pref : undef; $logger->debug( "done in non_upstream_default mode for " . $self->location ) if $logger->is_debug; return $nbu; } my $res = $mode eq 'preset' ? $self->{preset} : $mode eq 'default' ? $self->{default} : $mode eq 'standard' ? $std : $mode eq 'layered' ? $self->{layered} : $mode eq 'upstream_default' ? $self->{upstream_default} : $mode eq 'user' ? defined $data ? $data : $std : $mode eq 'allow_undef' ? defined $data ? $data : $std : $mode eq 'backend' ? defined $data ? $data : $pref : die "unexpected mode $mode "; $logger->debug( "done in '$mode' mode for " . $self->location . " -> " . ( $res // '' ) ) if $logger->is_debug; return $res; } sub fetch_no_check { my $self = shift; carp "fetch_no_check is deprecated. Use fetch (check => 'no')"; $self->fetch( check => 'no' ); } # likewise but without any warp, etc related check sub _fetch_no_check { my $self = shift; return defined $self->{data} ? $self->{data} : defined $self->{preset} ? $self->{preset} : defined $self->{compute} ? $self->perform_compute : defined $self->{_migrate_from} ? $self->migrate_value : $self->{default}; } sub fetch { my $self = shift; my %args = @_ > 1 ? @_ : ( mode => $_[0] ); my $mode = $args{mode} || 'backend'; my $silent = $args{silent} || 0; my $check = $self->_check_check( $args{check} ); if ( $logger->is_debug ) { $logger->debug( "called for " . $self->location . " check $check mode $mode" . " needs_check " . $self->needs_check ); } my $inst = $self->instance; my $value = $self->_fetch( $mode, $check ); if ( $logger->is_debug ) { $logger->debug( "_fetch returns " . ( defined $value ? $value : '' ) ); } if ( $mode and not defined $accept_mode{$mode} ) { croak "fetch: expected ", not scalar join( ' or ', keys %accept_mode ), " parameter, not $mode"; } if ( defined $self->{replace_follow} and defined $value ) { my $rep = $self->grab_value( step => $self->{replace_follow} . qq!:"$value"!, mode => 'loose', autoadd => 0, ); # store replaced value to trigger notify_change if ( defined $rep and $rep ne $value ) { $value = $self->_store_value($rep); } } # check and subsequent storage of fixes instruction must be done only # in user or custom mode. (because fixes are cleaned up during check and using # mode may not trigger the warnings. Hence confusion afterwards) my $ok = 1; $ok = $self->check( value => $value, silent => $silent, mode => $mode ) if $mode =~ /backend|custom|user/; $logger->debug( "$mode fetch (almost) done for " . $self->location ) if $logger->is_debug; # check validity (all modes) if ( $ok or $check eq 'no' ) { return $self->map_write_as($value); } elsif ( $check eq 'skip' ) { my $msg = $self->error_msg; my $str = $value // ''; warn "Warning: fetch [".$self->name,"] skipping value $str because of the following errors:\n$msg\n\n" if not $silent and $msg; return undef; } Config::Model::Exception::WrongValue->throw( object => $self, error => $self->error_msg ); return; } sub map_write_as { my ( $self, $v ) = @_; return unless defined $v; return $v unless $self->{write_as}; return $v unless $self->value_type eq 'boolean'; return $self->{write_as}[$v]; } sub user_value { return shift->{data}; } sub fetch_preset { my $self = shift; return $self->map_write_as( $self->{preset} ); } sub clear { my $self = shift; $self->store(undef); } sub clear_preset { my $self = shift; delete $self->{preset}; return defined $self->{layered} || defined $self->{data}; } sub fetch_layered { my $self = shift; return $self->map_write_as( $self->{layered} ); } sub clear_layered { my $self = shift; delete $self->{layered}; return defined $self->{preset} || defined $self->{data}; } sub get { my $self = shift; my %args = @_ > 1 ? @_ : ( path => $_[0] ); my $path = delete $args{path}; if ($path) { Config::Model::Exception::User->throw( object => $self, message => "get() called with a value with non-empty path: '$path'" ); } return $self->fetch(%args); } sub set { my $self = shift; my $path = shift; if ($path) { Config::Model::Exception::User->throw( object => $self, message => "set() called with a value with non-empty path: '$path'" ); } return $self->store(@_); } #These methods are important when this leaf value is used as a warp #master, or a variable in a compute formula. # register a dependency, This information may be used by external # tools sub register_dependency { my $self = shift; my $slave = shift; unshift @{ $self->{depend_on_me} }, $slave; # weaken only applies to the passed reference, and there's no way # to duplicate a weak ref. Only a strong ref is created. weaken( $self->{depend_on_me}[0] ); } sub get_depend_slave { my $self = shift; my @result = (); push @result, @{ $self->{depend_on_me} } if defined $self->{depend_on_me}; push @result, $self->get_warped_slaves; # needs to clean up weak ref to object that were destroyed return grep { defined $_ } @result; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Strongly typed configuration value __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Value - Strongly typed configuration value =head1 VERSION version 2.082 =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', description => 'foobar', } , country => { type => 'leaf', value_type => 'enum', choice => [qw/France US/], description => 'big countries', } , ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put data $root->load( step => 'foo=FOO country=US' ); print $root->report ; # foo = FOO # DESCRIPTION: foobar # # country = US # DESCRIPTION: big countries =head1 DESCRIPTION This class provides a way to specify configuration value with the following properties: =over =item * Strongly typed scalar: the value can either be an enumerated type, a boolean, a number, an integer or a string =item * default parameter: a value can have a default value specified during the construction. This default value will be written in the target configuration file. (C parameter) =item * upstream default parameter: specifies a default value that will be used by the application when no information is provided in the configuration file. This upstream_default value will not written in the configuration files. Only the C method will return the builtin value. This parameter was previously referred as C value. This may be used for audit purpose. (C parameter) =item * mandatory value: reading a mandatory value will raise an exception if the value is not specified and has no default value. =item * dynamic change of property: A slave value can be registered to another master value so that the properties of the slave value can change according to the value of the master value. For instance, paper size value can be 'letter' for country 'US' and 'A4' for country 'France'. =item * A reference to the Id of a hash of list element. In other word, the value is an enumerated type where the possible values (choice) is defined by the existing keys of a has element somewhere in the tree. See L. =back =head1 Default values There are several kind of default values. They depend on where these values are defined (or found). From the lowest default level to the "highest": =over =item * C: The value is known in the application, but is not written in the configuration file. =item * C: The value is known by the application through another mean (e.g. an included configuration file), but is not written in the configuration file. =item * C: The value is known by the model, but not by the application. This value must be written in the configuration file. =item * C: The value is computed from other configuration elements. This value must be written in the configuration file. =item * C: The value is not known by the model or by the application. But it can be found by an automatic program and stored while the configuration L is in L =back Then there is the value entered by the user. This will override all kind of "default" value. The L function will return the "highest" level of default value, but will not return a custom value, i.e. a value entered by the user. =head1 Constructor Value object should not be created directly. =head1 Value model declaration A leaf element must be declared with the following parameters: =over =item value_type Either C, C, C, C, C, C, C, C. Mandatory. See L. =item default Specify the default value (optional) =item upstream_default Specify a built in default value (optional). I.e a value known by the application which does not need to be written in the configuration file. =item write_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']>. =item compute Will compute a value according to a formula and other values. By default a computed value cannot be set. See L for computed value declaration. =item migrate_from This is a special parameter to cater for smooth configuration upgrade. This parameter can be used to copy the value of a deprecated parameter to its replacement. See L for details. =item convert => [uc | lc ] When stored, the value will be converted to uppercase (uc) or lowercase (lc). =item min Specify the minimum value (optional, only for integer, number) =item max Specify the maximum value (optional, only for integer, number) =item mandatory Set to 1 if the configuration value B be set by the configuration user (default: 0) =item choice Array ref of the possible value of an enum. Example : choice => [ qw/foo bar/] =item match Perl regular expression. The value will be match with the regex to assert its validity. Example C<< match => '^foo' >> means that the parameter value must begin with "foo". Valid only for C or C values. =item warn_if_match Hash ref. Keys are made of Perl regular expression. The value can specify a warning message (leave empty or undefined for default warning message) and instructions to fix the value. A warning will be issued when the value match the passed regular expression. Valid only for C or C values. The fix instructions will be evaluated when L is called. C<$_> will contain the value to fix. C<$_> will be stored as the new value once the instructions are done. C<$self> will contain the value object. Use with care. In the example below, any value matching 'foo' will be converted in uppercase: warn_if_match => { 'foo' => { fix => 'uc;', msg => 'value $_ contains foo' }, 'BAR' => { fix =>'lc;', msg => 'value $_ contains BAR' } }, The tests will be done in alphabetical order. In the example above, C test will be done before C test. C<$_> will be substituted with the bad value when the message is generated. =item warn_unless_match Hash ref like above. A warning will be issued when the value does not match the passed regular expression. Valid only for C or C values. =item warn String. Issue a warning to user with the specified string any time a value is set or read. =item warn_if A bit like C. The hash key is not a regexp but a label to help users. The hash ref contains some Perl code that is evaluated to perform the test. A warning will be issued if the code returns true. C<$_> will contains the value to check. C<$self> will contain the C object. The example below will warn if value contaims a number: warn_if => { warn_test => { code => 'defined $_ && /\d/;', msg => 'value $_ should not have numbers', fix => 's/\d//g;' } }, =item warn_unless Like C, but issue a warning when the C returns false. The example below will warn unless the value points to an existing directory: warn_unless => { 'dir' => { code => '-d', msg => 'missing dir', fix => "system(mkdir $_);" } } =item assert Like C. Except that returned value will trigger an error if false: assert => { test_nb => { code => 'defined $_ && /\d/;', msg => 'should not have numbers', fix => 's/\d//g;' } }, =item grammar Setup a L grammar to perform validation. If the grammar does not start with a "check" rule (i.e does not start with "check: "), the first line of the grammar will be modified to add "check" rule and set up this rules so the entire value must match the passed grammar. I.e. the grammar: token (oper token)(s?) oper: 'and' | 'or' token: 'Apache' | 'CC-BY' | 'Perl' will be changed to check: token (oper token)(s?) /^\Z/ {$return = 1;} oper: 'and' | 'or' token: 'Apache' | 'CC-BY' | 'Perl' The rule is called with Value object and a string reference. So, in the actions you may need to define, you can call the value object as C<$arg[0]>, store error message in C<${$arg[1]}}> and store warnings in C<${$arg[2]}}>. =item replace Hash ref. Used for enum to substitute one value with another. This parameter must be used to enable user to upgrade a configuration with obsolete values. For instance, if the value C is obsolete and replaced by C, you will need to declare: replace => { foo => 'foo_better' } The hash key can also be a regular expression for wider range replacement. The regexp must match the whole value: replace => ( 'foo.*' => 'better_foo' } In this case, a value will be replaced by C if the C regexp matches. =item replace_follow Path specifying a hash of value element in the configuration tree. The hash if used in a way similar to the C parameter. In this case, the replacement is not coded in the model but specified by the configuration. =item refer_to Specify a path to an id element used as a reference. See L for details. =item computed_refer_to Specify a path to an id element used as a computed reference. See L for details. =item warp See section below: L. =item help You may provide detailed description on possible values with a hash ref. Example: help => { oui => "French for 'yes'", non => "French for 'no'"} =back =head2 Value types This modules can check several value types: =over =item C Accepts values C<1> or C<0>, C or C, C or C. The value read back is always C<1> or C<0>. =item C Enum choices must be specified by the C parameter. =item C Enable positive or negative integer =item C The value can be a decimal number =item C A one line string. I.e without "\n" in it. =item C Actually, no check is performed with this type. =item C Like an C where the possible values (aka choice) is defined by another location if the configuration tree. See L. =item C A file name or path. A warning will be issued if the file does not exists (or is a directory) =item C A directory name or path. A warning will be issued if the directory does not exists (or is a plain file) =back =head1 Warp: dynamic value configuration The Warp functionality enable a C object to change its properties (i.e. default value or its type) dynamically according to the value of another C object locate elsewhere in the configuration tree. (See L for an explanation on warp mechanism). For instance if you declare 2 C element this way: $model ->create_config_class ( name => "TV_config_class", element => [ country => { type => 'leaf', value_type => 'enum', choice => [qw/US Europe Japan/] } , tv_standard => { # this example is getting old... type => 'leaf', value_type => 'enum', choice => [ qw/PAL NTSC SECAM/ ] warp => { follow => { # this points to the warp master c => '- country' }, rules => { '$c eq "US"' => { default => 'NTSC' }, '$c eq "France"' => { default => 'SECAM' }, '$c eq "Japan"' => { default => 'NTSC' }, '$c eq "Europe"' => { default => 'PAL' }, } } } , ] ); Setting C element to C will mean that C has a default value set to C by the warp mechanism. Likewise, the warp mechanism enables you to dynamically change the possible values of an enum element: state => { type => 'leaf', value_type => 'enum', # example is admittedly silly warp => { follow => { c => '- country' }, rules => { '$c eq "US"' => { choice => ['Kansas', 'Texas' ] }, '$c eq "Europe"' => { choice => ['France', 'Spain' ] }, '$c eq "Japan"' => { choice => ['Honshu', 'Hokkaido' ] } } } } =head2 Cascaded warping Warping value can be cascaded: C can be warped by C which can be warped by C. But this feature should be avoided since it can lead to a model very hard to debug. Bear in mind that: =over =item * Warp loop are not detected and will end up in "deep recursion subroutine" failures. =item * If you declare "diamond" shaped warp dependencies, the results will depend on the order of the warp algorithm and can be unpredictable. =item * The keys declared in the warp rules (C, C and C in the example above) cannot be checked at start time against the warp master C. So a wrong warp rule key will be silently ignored during start up and will fail at run time. =back =head1 Value Reference To set up an enumerated value where the possible choice depends on the key of a L object, you must: =over =item * Set C to C. =item * Specify the C or C parameter. See L. =back In this case, a C object is created to handle the relation between this value object and the referred Id. See L for details. =head1 Introspection methods The following methods returns the current value of the parameter of the value object (as declared in the model unless they were warped): =over =item min =item max =item mandatory =item choice =item convert =item value_type =item default =item upstream_default =item index_value =item element_name =back =head2 name() Returns the object name. =head2 get_type Returns C. =head2 can_store() Returns true if the value object can be assigned to. Return 0 for a read-only value (i.e. a computed value with no override allowed). =head2 get_choice() Query legal values (only for enum types). Return an array (possibly empty). =head2 get_help ( [ on_value ] ) Returns the help strings passed to the constructor. With C parameter, returns the help string dedicated to the passed value or undef. Without parameter returns a hash ref that contains all the help strings. =head2 error_msg Returns the error messages of this object (if any) =head2 warning_msg Returns warning concerning this value. Returns a list in list context and a string in scalar context. =head2 check_value ( value ) Check the consistency of the value. C also accepts named parameters: =over 4 =item value =item quiet When non null, check will not try to get extra information from the tree. This is required in some cases to avoid loops in check, get_info, get_warp_info, re-check ... =back In scalar context, return 0 or 1. In array context, return an empty array when no error was found. In case of errors, returns an array of error strings that should be shown to the user. =head2 has_fixes Returns the number of fixes that can be applied to the current value. =head2 apply_fixes Applies the fixes to suppress the current warnings. =head2 check( [ value => foo ] ) Like L. Will also display warnings on STDOUT unless C parameter is set to 1. In this case,user is expected to retrieve them with L. Without C argument, this method will check the value currently stored. =head1 Information management =head2 store( $value ) Can be called as C<< value => ..., check => yes|no|skip ), silent => 0|1 >> Store value in leaf element. C parameter can be used to skip validation check (default ies 'yes'). C cane be used to suppress warnings. Optional C is now deprecated. =head2 clear Clear the stored value. Further read will return the default value (or computed or migrated value). =head2 load_data( $value ) Load scalar data. Data is forwarded to L. Called with C or C $value )> or with the same parameters are C method. =head2 fetch_custom Returns the stored value if this value is different from a standard setting or built in setting. In other words, returns undef if the stored value is identical to the default value or the computed value or the built in value. =head2 fetch_standard Returns the standard value as defined by the configuration model. The standard value can be either a preset value, a layered value, a computed value, a default value or a built-in default value. =head2 fetch(...) Check and fetch value from leaf element. The method can have one parameter (the fetch mode) or several pairs: =over 4 =item mode Whether to fetch default, custom, etc value. See below for details =item check Whether to check if the value is valid or not before returning it. Default is 'yes'. Possible value are =over 4 =item yes Perform check and raise an exception for bad values =item skip Perform check and return undef for bad values. A warning is issued when a bad value is skipped. Set C to C to avoid warnings. =item no Do not check and return values even if bad =back =item silent When set to 1, warning are not displayed on STDOUT. User is expected to read warnings with L method. =back According to the C parameter, this method will return either: =over =item empty mode parameter (default) Value entered by user or default value if the value is different from upstream_default or layered value. Typically this value will be written in a configuration file. =item backend Alias for default mode. =item custom The value entered by the user (if different from built in, preset, computed or default value) =item user The value most useful to user: the value that will be used by the application. =item preset The value entered in preset mode =item standard The preset or computed or default or built in value. =item default The default value (defined by the configuration model) =item layered The value found in included files (treated in layered mode: values specified there are handled as upstream default values). E.g. like in multistrap config. =item upstream_default The upstream_default value. (defined by the configuration model) =item non_upstream_default The custom or preset or computed or default value. Will return undef if either of this value is identical to the upstream_default value. This feature is useful to reduce data to write in configuration file. =item allow_undef This mode will accept to return undef for mandatory values. Normally, trying to fetch an undefined mandatory value leads to an exception. =back =head2 user_value Returns the value entered by the user. Does not use the default or computed value. Returns undef unless a value was actually stored. =head2 fetch_preset Returns the value entered in preset mode. Does not use the default or computed value. Returns undef unless a value was actually stored in preset mode. =head2 clear_preset Delete the preset value. (Even out of preset mode). Returns true if other data are still stored in the value (layered or user data). Returns false otherwise. =head2 fetch_layered Returns the value entered in layered mode. Does not use the default or computed value. Returns undef unless a value was actually stored in layered mode. =head2 clear_layered Delete the layered value. (Even out of layered mode). Returns true if other data are still stored in the value (layered or user data). Returns false otherwise. =head2 get( path => ..., mode => ... , check => ... ) Get a value from a directory like path. =head2 set( path , value ) Set a value from a directory like path. =head1 Examples =head2 Number with min and max values bounded_number => { type => 'leaf', value_type => 'number', min => 1, max => 4, }, =head2 Mandatory value mandatory_string => { type => 'leaf', value_type => 'string', mandatory => 1, }, mandatory_boolean => { type => 'leaf', value_type => 'boolean', mandatory => 1, }, =head2 Enum with help associated with each value Note that the help specification is optional. enum_with_help => { type => 'leaf', value_type => 'enum', choice => [qw/a b c/], help => { a => 'a help' } }, =head2 Migrate old obsolete enum value Legacy values C, C and C are replaced with C, C and C. with_replace => { type => 'leaf', value_type => 'enum', choice => [qw/a b c/], replace => { a1 => 'a', c1 => 'c', 'foo/.*' => 'foo', }, }, =head2 Enforce value to match a regexp An exception will be triggered if the value does not match the C regular expression. match => { type => 'leaf', value_type => 'string', match => '^foo\d{2}$', }, =head2 Enforce value to match a L grammar match_with_parse_recdescent => { type => 'leaf', value_type => 'string', grammar => q{ token (oper token)(s?) oper: 'and' | 'or' token: 'Apache' | 'CC-BY' | 'Perl' }, }, =head2 Issue a warning if a value matches a regexp Issue a warning if the string contains upper case letters. Propose a fix that translate all capital letters to lower case. warn_if_capital => { type => 'leaf', value_type => 'string', warn_if_match => { '/A-Z/' => { fix => '$_ = lc;' } }, }, A specific warning can be specified: warn_if_capital => { type => 'leaf', value_type => 'string', warn_if_match => { '/A-Z/' => { fix => '$_ = lc;', mesg => 'NO UPPER CASE PLEASE' } }, }, =head2 Issue a warning if a value does NOT match a regexp warn_unless => { type => 'leaf', value_type => 'string', warn_unless_match => { foo => { msg => '', fix => '$_ = "foo".$_;' } }, }, =head2 Always issue a warning always_warn => { type => 'leaf', value_type => 'string', warn => 'Always warn whenever used', }, =head2 Computed values See L. =head1 Upgrade Upgrade is a special case when the configuration of an application has changed. Some parameters can be removed and replaced by another one. To avoid trouble on the application user side, Config::Model offers a possibility to handle the migration of configuration data through a special declaration in the configuration model. This declaration must: =over =item * Declare the deprecated parameter with a C set to C =item * Declare the new parameter with the instructions to load the semantic content from the deprecated parameter. These instructions are declared in the C parameters (which is similar to the C parameter) =back Here an example where a URL parameter is changed to a set of 2 parameters (host and path): 'old_url' => { type => 'leaf', value_type => 'uniline', status => 'deprecated', }, 'host' => { type => 'leaf', value_type => 'uniline', # the formula must end with '$1' so the result of the capture is used # as the host value migrate_from => { formula => '$old =~ m!http://([\w\.]+)!; $1 ;', variables => { old => '- old_url' }, use_eval => 1, }, }, 'path' => { type => 'leaf', value_type => 'uniline', migrate_from => { formula => '$old =~ m!http://[\w\.]+(/.*)!; $1 ;', variables => { old => '- old_url' }, use_eval => 1, }, }, =head1 EXCEPTION HANDLING When an error is encountered, this module may throw the following exceptions: Config::Model::Exception::Model Config::Model::Exception::Formula Config::Model::Exception::WrongValue Config::Model::Exception::WarpError See L for more details. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut AnyId.pm100644001750001750 12026112676543661 17553 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::AnyId; $Config::Model::AnyId::VERSION = '2.082'; use 5.010; use Mouse; with "Config::Model::Role::NodeLoader"; 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; extends qw/Config::Model::AnyThing/; my $logger = get_logger("Tree::Element::Id"); 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 { {}; } ); # 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 => 'Maybe[ArrayRef]' ); 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' ); has content_warning_hash => ( is => 'rw', isa => 'HashRef', default => sub { {}; } ); 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; my $p = $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 { my $self = shift; # mega cleanup map( delete $self->{$_}, @allowed_warp_params ); my %args = ( %{ $self->{backup} }, @_ ); # these are handled by Node or Warper map { delete $args{$_} } qw/level/; $logger->debug( $self->name, " set_properties called with @_" ); map { $self->{$_} = delete $args{$_} if defined $args{$_} } @common_params; $self->set_convert( \%args ) if defined $args{convert}; 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; } sub create_default_with_init { my $self = shift; return unless defined $self->{default_with_init}; my $h = $self->{default_with_init}; foreach my $def_key ( keys %$h ) { my $v_obj = $self->fetch_with_id($def_key); if ( $v_obj->get_type eq 'leaf' ) { $v_obj->store( $h->{$def_key} ); } else { $v_obj->load( $h->{$def_key} ); } } } sub max { my $self = shift; carp $self->name, ": max param is deprecated, use max_index\n"; $self->max_index; } sub min { my $self = shift; carp $self->name, ": min param is deprecated, use min_index\n"; $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 mesage sub safe_typed_grab { my $self = shift; my %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 { my $self = shift; my %args = @_; my $warp_info = delete $args{warp}; map { $self->{$_} = delete $args{$_} if defined $args{$_} } qw/index_class index_type morph ordered/; $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; $logger->debug( $self->location . ": apply_fixes called" ); $self->check_content( fix => 1 ); } sub has_fixes { my $self = shift; return $self->{nb_of_content_fixes}; } 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 %check_content_dispatch = map { ( $_ => 'check_' . $_ ); } qw/duplicates/; my %mode_move = ( layered => { preset => 1, normal => 1 }, preset => { normal => 1 }, normal => {}, ); sub notify_change { my $self = shift; my %args = @_; $change_logger->debug( "called for ", $self->name, " from ", join( ' ', caller ), " with ", join( ' ', %args ) ) if $change_logger->is_debug; # $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_check(1); $self->SUPER::notify_change(%args); } sub check { my $self = shift; $self->check_content(@_); } # check globally the list or hash sub check_content { my $self = shift; my %args = @_ > 1 ? @_ : ( index => $_[0] ); my $silent = $args{silent} || 0; my $apply_fix = $args{fix} || 0; Config::Model::Exception::Internal->throw( object => $self, error => "check method: index or key should not be defined" ) if defined $args{index}; if ( $self->needs_check ) { # need to keep track to update GUI $self->{nb_of_content_fixes} = 0; # reset before check my @error; my @warn; foreach my $key_check_name ( keys %check_content_dispatch ) { next unless $self->{$key_check_name}; my $method = $check_content_dispatch{$key_check_name}; $self->$method( \@error, \@warn, $apply_fix ); } my $nb = $self->fetch_size; push @error, "Too many instances ($nb) limit $self->{max_nb}, " if defined $self->{max_nb} and $nb > $self->{max_nb}; map { warn( "Warning in '" . $self->location_short . "': $_\n" ) } @warn unless $silent; $self->{content_warning_list} = \@warn; $self->{content_error_list} = \@error; $self->needs_check(0); return scalar @error ? 0 : 1; } else { $logger->debug( $self->location, " has not changed, actual check skipped" ) if $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 { my $self = shift; my %args = @_ > 1 ? @_ : ( index => $_[0] ); my $idx = $args{index}; my $silent = $args{silent} || 0; my $check = $args{check} || 'yes'; my $apply_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 instances ($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, "Instance ids are '" . join( ',', @a ) . "'", $self->warp_error; } $self->{idx_error_list} = \@error; if (@warn) { $self->{warning_hash}{$idx} = \@warn; map { warn( "Warning in '" . $self->location_short . "': $_\n" ) } @warn unless $silent; } else { delete $self->{warning_hash}{$idx}; } 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->name . "'. Expected '" . join( "', '", $followed->fetch_all_indexes ) . "'"; } #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; } #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/; } #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 ) . "'"; } 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/; } 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/; } sub check_duplicates { my ( $self, $error, $warn, $apply_fix ) = @_; my $dup = $self->{duplicates}; return if $dup eq 'allow'; $logger->debug("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"); map { $self->remove($_) } reverse @to_delete; } 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->{nb_of_content_fixes} += scalar @issues; } elsif ( $dup eq 'suppress' ) { $logger->debug("suppressing duplicates @issues"); map { $self->remove($_) } reverse @to_delete; } else { die "Internal error: duplicates is $dup"; } } sub fetch_with_id { my $self = shift; my %args = @_ > 1 ? @_ : ( index => shift ); my $check = $self->_check_check( $args{check} ); my $idx = $args{index}; $logger->debug( $self->name, " called for idx $idx" ) if $logger->is_debug; $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' ) { $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 { my $self = shift; my %args = @_ > 1 ? @_ : ( path => $_[0] ); 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->debug("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 { my $self = shift; my $path = shift; $path =~ s!^/!!; my ( $item, $new_path ) = split m!/!, $path, 2; return $self->fetch_with_id($item)->set( $new_path, @_ ); } sub copy { my ( $self, $from, $to ) = @_; 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" ); $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 ); $target->copy_from($from_obj); } else { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{idx_error_list} } ), object => $self ); } } sub fetch_all { my $self = shift; my @keys = $self->fetch_all_indexes; return map { $self->fetch_with_id($_); } @keys; } sub fetch_all_values { my $self = shift; my %args = @_ > 1 ? @_ : ( mode => shift ); my $mode = $args{mode}; my $check = $self->_check_check( $args{check} ); my @keys = $self->fetch_all_indexes; if ( $self->{cargo}{type} eq 'leaf' ) { my $ok = $check eq 'no' ? 1 : $self->check_content(); if ( $ok or $check eq 'no' ) { return grep { defined $_ } map { $self->fetch_with_id($_)->fetch( check => $check, mode => $mode ); } @keys; } else { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{content_error_list} } ), object => $self ); } } else { my $info = "current keys are '" . join( "', '", @keys ) . "'."; if ( $self->{cargo}{type} eq 'node' ) { $info .= "config class is " . $self->fetch_with_id( $keys[0] )->config_class_name; } Config::Model::Exception::WrongType->throw( object => $self, function => 'fetch_all_values', got_type => $self->{cargo}{type}, expected_type => 'leaf', info => $info, ); } } 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; } # 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 ); } sub defined { my ( $self, $idx ) = @_; return $self->_defined($idx); } sub exists { my ( $self, $idx ) = @_; return $self->_exists($idx); } sub delete { my ( $self, $idx ) = @_; delete $self->{warning_hash}{$idx}; my $ret = $self->_delete($idx); $self->notify_change( note => "deleted entry $idx" ); return $ret; } sub clear { my ($self) = @_; $self->{warning_hash} = {}; $self->_clear; $self->clear_data_mode; $self->notify_change( note => "cleared all entries" ); } sub clear_values { my ($self) = @_; warn "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 map { $self->fetch_with_id($_)->store(undef) } $self->fetch_all_indexes; $self->notify_change( note => "cleared all values" ); } sub warning_msg { my ( $self, $idx ) = @_; if ( defined $idx ) { return $self->{warning_hash}{$idx}; } elsif ( scalar %{ $self->{content_warning_hash} } or @{ $self->{content_warning_list} } ) { my @list = @{ $self->{content_warning_list} }; push @list, map ( "key $_: " . $self->{content_warning_hash}{$_}, keys %{ $self->{content_warning_hash} } ); return join( "\n", @list ); } } sub has_warning { my $self = shift; return @{ $self->{content_warning_list} } + keys %{ $self->{content_warning_hash} }; } sub error_msg { my $self = shift; my @list; map { push @list, @{ $self->{$_} } if $self->{$_}; } qw/idx_error_list content_error_list/; return unless @list; return wantarray ? @list : join( "\n\t", @list ); } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Base class for hash or list element __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::AnyId - Base class for hash or list element =head1 VERSION version 2.082 =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 $step = '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( step => $step ); # 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 type> (See L). =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 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 hash you're creating will always have 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 >> will initialize the list with 4 undef elements. (valid only for list elements) =item convert => [uc | lc ] The hash key will be 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 will mean that C can only accept one instance of C. Setting C to C will mean that C will accept two instances of C. 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 will never remove items that were previously auto created. For instance, if a tied hash is created with C<< auto_create => [a,b,c] >>, the hash contains C<(a,b,c)>. Then if a warp is applied with C<< auto_create_keys => [c,d,e] >>, the hash will contain 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 will be raised if a warp leads to a number of items greater than the max_nb constraint. =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( < 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. Will return undef if the requested info was 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 will return 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 ( 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 will be 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( path, value ) Set a value with a directory like path. =head2 copy ( 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_all_values( 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 will return 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 =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 ( index ) Returns true if the value held at C is defined. =head2 exists ( 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 delete ( 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 ( [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 =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Lister.pm100644001750001750 653012676543661 17753 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Lister; $Config::Model::Lister::VERSION = '2.082'; 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\-]+)! ); $appli_info{$appli}{_file} = $file; open( F, $file ) || die "Can't open file $file:$!"; while () { 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; } } } 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__ =pod =encoding UTF-8 =head1 NAME Config::Model::Lister - List available models and applications =head1 VERSION version 2.082 =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. =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Report.pm100644001750001750 1236212676543661 20004 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Report; $Config::Model::Report::VERSION = '2.082'; use Carp; use strict; use warnings; use Config::Model::Exception; use Config::Model::ObjTreeScanner; use Text::Wrap; sub new { bless {}, shift; } sub report { my $self = shift; my %args = @_; my $audit = delete $args{audit} || 0; my $node = delete $args{node} || croak "dump_tree: missing 'node' parameter"; my $std_cb = sub { my ( $scanner, $data_r, $obj, $element, $index, $value_obj ) = @_; # if element is a collection, get the value pointed by $index $value_obj = $obj->fetch_element($element)->fetch_with_id($index) if defined $index; # get value or only customized value my $value = $audit ? $value_obj->fetch_custom : $value_obj->fetch; $value = '"' . $value . '"' if defined $value and $value =~ /\s/; if ( defined $value ) { my $name = defined $index ? " $element:$index" : $element; push @$data_r, $obj->location . " $name = $value"; my $desc = $obj->get_help($element); if ( defined $desc and $desc ) { push @$data_r, wrap( "\t", "\t\t", "DESCRIPTION: $desc" ); } my $effect = $value_obj->get_help($value); if ( defined $effect and $effect ) { push @$data_r, wrap( "\t", "\t\t", "SELECTED: $effect" ); } push @$data_r, ''; # to get empty line in report } }; my @scan_args = ( fallback => 'all', auto_vivify => 0, leaf_cb => $std_cb, ); my @left = keys %args; croak "Report: unknown parameter:@left" if @left; # perform the scan my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args); my @ret; $view_scanner->scan_node( \@ret, $node ); return join( "\n", @ret ); } 1; # ABSTRACT: Reports data from config tree __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Report - Reports data from config tree =head1 VERSION version 2.082 =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' }, ], description => [ foo => 'some foo explanation', bar => 'some bar explanation', ] ); $model->create_config_class( name => "MyClass", element => [ [qw/foo bar/] => { type => 'leaf', value_type => 'string' }, my_enum => { type => 'leaf', value_type => 'enum', choice => [qw/A B C/], help => { A => 'first letter', B => 'second letter', C => 'third letter', }, description => 'some letters', }, 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 $step = 'foo=FOO my_enum=B hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( step => $step ); print $root->report ; # foo = FOO # # my_enum = B # DESCRIPTION: some letters # SELECTED: second letter # # hash_of_nodes:en foo = hello # DESCRIPTION: some foo explanation # # hash_of_nodes:fr foo = bonjour # DESCRIPTION: some foo explanation =head1 DESCRIPTION This module is used directly by L to provide a human readable report of the configuration. This report includes the configuration values and (if provided by the model) the description of the configuration item and their effect. A C will show C configuration items. An C will show only configuration items which are different from their default value. =head1 CONSTRUCTOR =head2 new ( ) No parameter. The constructor should be used only by L. =head1 Methods =head2 report Returns a string containing the configuration values and (if provided by the model) the description of the configuration item and their effect. Parameters are: =over =item audit Set to 1 to report only configuration data different from default values. Default is 0. =item node Reference to the L object that is dumped. All nodes and leaves attached to this node are also dumped. =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut HashId.pm100644001750001750 3702712676543661 17676 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::HashId; $Config::Model::HashId::VERSION = '2.082'; use Mouse; use Config::Model::Exception; use Carp; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger("Tree::Element::Id::Hash"); extends qw/Config::Model::AnyId/; 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 => 'ArrayRef', default => sub { []; } ); has [qw/morph ordered/] => ( is => 'ro', isa => 'Bool' ); sub BUILD { my $self = shift; # 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 { my $self = shift; $self->SUPER::set_properties(@_); 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->debug( "set_properties: ", $self->name, " deleting id $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_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 ); } map { $self->_store( $_, undef ) unless $self->_defined($_) } $followed->fetch_all_indexes; } 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); } } } sub get_type { my $self = shift; return 'hash'; } # important: return the actual size (not taking into account auto-created stuff) sub fetch_size { my $self = shift; return scalar keys %{ $self->{data} }; } sub _fetch_all_indexes { my $self = shift; return $self->{ordered} ? @{ $self->{list} } : sort keys %{ $self->{data} }; } # fetch without any check sub _fetch_with_id { my ( $self, $key ) = @_; my $i = $self->instance; return $self->{data}{$key}; } # store without any check sub _store { my ( $self, $key, $value ) = @_; push @{ $self->{list} }, $key unless exists $self->{data}{$key}; return $self->{data}{$key} = $value; } sub _exists { my ( $self, $key ) = @_; return exists $self->{data}{$key}; } sub _defined { my ( $self, $key ) = @_; return defined $self->{data}{$key} ? 1 : 0; } #internal sub auto_create_elements { my $self = shift; my $auto_p = $self->auto_create_keys; return unless defined $auto_p; # create empty slots map { $self->_store( $_, undef ) unless exists $self->{data}{$_}; } ( ref $auto_p ? @$auto_p : ($auto_p) ); } # internal sub create_default { my $self = shift; 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; } sub _delete { my ( $self, $key ) = @_; # remove key in ordered list @{ $self->{list} } = grep { $_ ne $key } @{ $self->{list} }; return delete $self->{data}{$key}; } sub remove { my $self = shift; $self->delete(@_); } sub _clear { my ($self) = @_; $self->{list} = []; $self->{data} = {}; } sub sort { my $self = shift; if ($self->ordered) { $self->_sort; } else { Config::Model::Exception::User->throw( object => $self, message => "cannot call sort on non ordered hash" ); } } # hash only method sub firstkey { my $self = shift; $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 { my $self = shift; $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 { my $self = shift; my ( $key1, $key2 ) = @_; foreach my $k (@_) { 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'" ); } sub move { my $self = shift; my ( $from, $to ) = @_; Config::Model::Exception::User->throw( object => $self, message => "move: unknow key $from" ) unless exists $self->{data}{$from}; my $ok = $self->check_idx($to); if ($ok) { # this may clobber the old content of $self->{data}{$to} $self->{data}{$to} = delete $self->{data}{$from}; delete $self->{warning_hash}{$from}; # update index_value attribute in moved objects $self->{data}{$to}->index_value($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 ); my ( $to_idx, $from_idx ); my $idx = 0; my $list = $self->{list}; map { $to_idx = $idx if $list->[$idx] eq $to; $from_idx = $idx if $list->[$idx] eq $from; $idx++; } @$list; if ( defined $to_idx ) { # Since $to is clobbered, $from takes its place in the list $list->[$from_idx] = $to; # and the $from entry is removed from the list splice @$list, $to_idx, 1; } else { # $to is moved in the place of from in the list $list->[$from_idx] = $to; } } else { Config::Model::Exception::WrongValue->throw( error => join( "\n\t", @{ $self->{error} } ), object => $self ); } } sub move_after { my $self = shift; my ( $key_to_move, $ref_key ) = @_; if ( not $self->ordered ) { $logger->warn("called move_after on unordered hash"); return; } foreach my $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 ); } sub move_up { my $self = shift; my ($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 } sub move_down { my $self = shift; my ($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 } sub load_data { my $self = shift; my %args = @_ > 1 ? @_ : ( data => shift ); my $data = delete $args{data}; my $check = $self->_check_check( $args{check} ); if ( ref($data) eq 'HASH' ) { my @load_keys; my $from = ''; my $order_key = '__'.$self->element_name.'_order'; if ( $self->{ordered} and (defined $data->{$order_key} or defined $data->{__order} )) { @load_keys = @{ delete $data->{$order_key} or delete $data->{__order} }; $from = ' with '.$order_key; } elsif ( $self->{ordered} ) { $logger->warn( "HashId " . $self->location . ": loading ordered " . "hash from hash ref without special key '__order'. Element " . "order is not defined" ); $from = ' without '.$order_key; } @load_keys = sort keys %$data unless @load_keys; $logger->info( "HashId load_data (" . $self->location . ") will load idx @load_keys from hash ref" . $from ); foreach my $elt (@load_keys) { my $obj = $self->fetch_with_id($elt); $obj->load_data( %args, data => $data->{$elt} ); } } elsif ( ref($data) eq 'ARRAY' ) { $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); $obj->load_data( %args, data => $data->[ $idx++ ] ); } } 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, ); } } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Handle hash element for configuration model __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::HashId - Handle hash element for configuration model =head1 VERSION version 2.082 =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 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 ( key1 , key2 ) Swap the order of the 2 keys. Ignored for non ordered hash. =head2 move ( key1 , key2 ) Rename key1 in key2. =head2 move_after ( 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 ( key ) Move the key up in a ordered hash. Attempt to move up the first key of an ordered hash will be ignored. Ignored for non ordered hash. =head2 move_down ( key ) Move the key down in a ordered hash. Attempt to move up the last key of an ordered hash will be ignored. Ignored for non ordered hash. =head2 load_data ( data => ( hash_ref | array_ref ) [ , check => ... , ... ]) Load check_list 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' } load_data can also be called with a single ref parameter. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Dumper.pm100644001750001750 2534412676543661 17771 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Dumper; $Config::Model::Dumper::VERSION = '2.082'; use Carp; use strict; use warnings; use Config::Model::Exception; use Config::Model::ObjTreeScanner; 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 ( $mode and $mode !~ /full|preset|custom/ ) { croak "dump_tree: unexpected 'mode' value: $mode"; } 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 ? '' : $mode eq 'full' ? '' : $mode ? $mode : 'custom'; 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__ =pod =encoding UTF-8 =head1 NAME Config::Model::Dumper - Serialize data of config tree =head1 VERSION version 2.082 =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 $step = 'baz:fr=bonjour baz:hr="dobar dan"'; $root->load( step => $step ) ; # 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. The other mode is C mode where all all data, including default values, are dumped. 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 will contain 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 ( full | preset | custom ) C will dump all configuration data including default values. C will dump only value entered in preset mode. 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. =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 =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut ListId.pm100644001750001750 3662312676543661 17727 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::ListId; $Config::Model::ListId::VERSION = '2.082'; use 5.10.1; use Mouse; use Config::Model::Exception; use Log::Log4perl qw(get_logger :levels); use Carp; extends qw/Config::Model::AnyId/; my $logger = get_logger("Tree::Element::Id::List"); 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} ) { warn $self->name, "Using migrate_keys_from with list element is deprecated.", " Use migrate_values_from\n"; } # 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->debug( "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' ); map { $self->_store( $_, undef ) unless $self->_defined($_) } $followed->fetch_all_indexes; } } sub get_type { my $self = shift; return 'list'; } # 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; my $regex = qr/^( (?: " (?: \\" | [^"] )*? " ) | [^,]+ ) /x; while ( length($string) ) { #print "string: $string\n"; $string =~ s/$regex// or last; my $tmp = $1; #print "tmp: $tmp\n"; $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); } sub store_set { my $self = shift; my @v = @_; my $r = shift; my %args = ( check => 'yes' ); if ( ref $r eq 'ARRAY' ) { @v = @$r; %args = @_; # note that $r was shifted out of @_ } my @comments = @{ $args{comment} || [] }; my $idx = 0; foreach (@v) { if ( defined $_ ) { my $v_obj = $self->fetch_with_id( $idx++ ); $v_obj->store( %args, value => $_ ); $v_obj->annotation( shift @comments ) if @comments; } else { $self->{data}[$idx] = undef; # detruit l'objet pas bon! } } # and delete unused items my $ref = $self->{data}; while (scalar @$ref > $idx) { $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 { my $self = shift; $self->_assert_leaf_cargo; $self->_sort_data( sub { $_[0]->fetch cmp $_[1]->fetch; } ); 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 ); $self->notify_change(note => "removed idx $idx"); 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; $self->clear; 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++ ); $obj->load_data( %args, data => $item ); } } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Handle list element for configuration model __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::ListId - Handle list element for configuration model =head1 VERSION version 2.082 =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(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> will yield 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 ( from_index, to_index, [ check => 'no' ) Move an element within the list. C can be 'yes' 'no' 'skip' =head2 push( value1, [ value2 ... ] ) push some values at the end of the list. =head2 push_x ( 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( value1, [ value2 ... ] ) unshift some values at the end of the list. =head2 insert_at( idx, value1, [ value2 ... ] ) unshift some values at index idx in the list. =head2 insert_before( ( val | qr/stuff/ ) , value1, [ value2 ... ] ) unshift some values before value equal to C or before value matching C. =head2 insort( value1, [ value2 ... ] ) Insert C value on C list so that existing alphanumeric order is preserved. Will yield unpexpected results if call 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 ( C , C ) Swap 2 elements within the array =head2 remove ( C ) Remove an element from the list. Equivalent to C =head2 load_data ( 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 will be split to load the array. For instance $elt->load_data( data => 'foo,bar', split_reg => qr(,) ) ; will load C< [ 'foo','bar']> in C<$elt> =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Loader.pm100644001750001750 10325112676543661 17755 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Loader; $Config::Model::Loader::VERSION = '2.082'; use Carp; use strict; use warnings; use 5.10.1; use Config::Model::Exception; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger("Loader"); ## load stuff, similar to grab, but used to set items in the tree ## starting from this node sub new { bless {}, shift; } sub load { my $self = shift; my %args = @_; my $node = delete $args{node}; croak "load error: missing 'node' parameter" unless defined $node; my $step = delete $args{step}; croak "load error: missing 'step' parameter" unless defined $step; 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 $step ? join( ' ', @$step ) : $step; # do a split on ' ' but take quoted string into account my @command = ( $huge_string =~ 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 )+ # can have several parts in one command ) # end of *one* command /gx # 'g' means that all commands are fed into @command array ); #"asdf ; #print "command is ",join('+',@command),"\n" ; my $current_node = $node; my $ret; do { $ret = $self->_load( $current_node, $check, \@command, 1 ); $logger->debug("_load returned $ret"); # found '!' command if ( $ret eq 'root' ) { $logger->debug("Setting current_node to root node"); $current_node = $current_node->root; } } 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; 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 braces | ( /[^/]+/ # regexp | (?: $quoted_string | [^#=\.<>]+ # non action chars )+ ) )? )? (?: (=~|.=|[=<>]) # apply regexp or assign or append ( (?: $quoted_string | [^#\s] # or non whitespace )+ # many ) )? (?: \# # optional annotation ( (?: $quoted_string | [^\s] # or non whitespace )+ # many ) )? !gx ); return wantarray ? @command : \@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->debug("_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("_load: Executing cmd '$msg' on node $node_name"); } next if $cmd =~ /^\s*$/; if ( $cmd eq '!' ) { $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 '-' ) { $logger->debug("_load: going up"); return 'up'; } if ( $cmd =~ m!^/([\w-]+)! ) { my $search = $1; if ($node->has_element($search)) { $logger->debug("_load: search found node with element $search"); $cmd =~ s!^/!! ; } else { $logger->debug("_load: searching node with element $search, going up"); unshift @$cmdref, $cmd; return 'up'; } } my @instructions = _split_cmd($cmd); my ( $element_name, $action, $function_param, $id, $subaction, $value, $note ) = @instructions; if ( $logger->is_debug ) { my @disp = map { defined $_ ? "'$_'" : '' } @instructions; $logger->debug("_load instructions: @disp"); } 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 ) { $node->annotation($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 ); $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 _load_note { my ( $self, $target_obj, $note, $instructions, $cmdref ) = @_; unquote($note); # apply note on target object if ( defined $note ) { if ( defined $target_obj ) { $target_obj->annotation($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 ) = @_; my $element_name = shift @$inst; my $note = pop @$inst; my $element = $node->fetch_element($element_name); $self->_load_note( $element, $note, $inst, $cmdref ); my @left = grep { defined $_ } @$inst; if (@left) { Config::Model::Exception::Load->throw( command => $inst, error => "Don't know what to do with '@left' " . "for node element " . $element->element_name ); } $logger->info( "Opening node element ", $element->name ); return $self->_load( $element, $check, $cmdref ); } sub unquote { map { 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 ); return 'ok'; } if ( defined $subaction and $subaction eq '=' ) { $logger->debug("_load_check_list: set whole list"); # valid for check_list or list $logger->info( "Setting check_list element ", $element->name, " with value ", $value ); $element->load( $value, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref ); 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; }, ':.push' => sub { $_[1]->push( @_[ 4 .. $#_ ] ); }, ':.unshift' => sub { $_[1]->unshift( @_[ 4 .. $#_ ] ); }, ':.insert_at' => sub { $_[1]->insert_at( @_[ 4 .. $#_ ] ); }, ':.insort' => sub { $_[1]->insort( @_[ 4 .. $#_ ] ); }, ':.insert_before' => \&_insert_before, }, 'hash_*' => { ':.sort' => sub { $_[1]->sort; }, ':@' => sub { $_[1]->sort; }, ':.copy' => sub { $_[1]->copy( $_[4], $_[5] ); }, }, leaf => { ':-=' => \&_remove_by_value, ':-~' => \&_remove_matched_value, ':=~' => \&_substitute_value, }, fallback => { ':-' => \&_remove_by_id, '~' => \&_remove_by_id, } ); my @equiv = qw/:@ :.sort :< :.push :> :.unshift/; while (@equiv) { my ( $to, $from ) = splice @equiv, 0, 2; $dispatch_action{list_leaf}{$to} = $dispatch_action{list_leaf}{$from}; } sub _insert_before { my ( $self, $element, $check, $inst, $before_str, @values ) = @_; my $before = $before_str =~ m!^/! ? eval "qr$before_str" : $before_str; $element->insert_before( $before, @values ); } sub _remove_by_id { my ( $self, $element, $check, $inst, $id ) = @_; $logger->debug("_remove_by_id: removing id $id"); $element->remove($id); return 'ok'; } sub _remove_by_value { my ( $self, $element, $check, $inst, $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, $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, $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 _load_list { my ( $self, $node, $check, $inst, $cmdref ) = @_; 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 ); return 'ok'; } if ( defined $action and $action eq ':=' and $cargo_type eq 'leaf' ) { $logger->debug("_load_list: set whole list with ':=' action"); # valid for check_list or list $logger->info( "Setting $elt_type element ", $element->name, " with '$id'" ); $element->load( $id, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref ); 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 $logger->info( "Setting $elt_type element ", $element->name, " with '$value'" ); $element->load( $value, check => $check ); $self->_load_note( $element, $note, $inst, $cmdref ); return 'ok'; } unquote( $id, $value, $note ); if ( defined $action ) { my $dispatch = $dispatch_action{ 'list_' . $cargo_type }{$action} || $dispatch_action{ 'list_*'}{$action} || $dispatch_action{$cargo_type}{$action} || $dispatch_action{'fallback'}{$action}; if ($dispatch) { $dispatch->( $self, $element, $check, $inst, @f_args ); 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 " . "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 ); if ( $cargo_type =~ /node/ ) { # remove possible leading or trailing quote $logger->debug("_load_list: calling _load on node id $id"); 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"); $self->_load_value( $obj, $check, $subaction, $value ) 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 ) = @_; 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 ) { $self->_load_note( $element, $note, $inst, $cmdref ); return 'ok'; } if ( not defined $action ) { Config::Model::Exception::Load->throw( object => $element, command => join( '', map { $_ || '' } @$inst ), error => "Missing assignment on " . "element type: hash, cargo_type: $cargo_type" ); } if ( $action eq ':~' ) { my @keys = $element->fetch_all_indexes; my $ret = 'ok'; $id =~ s!^/|/$!!g if $id; my @loop_on = $id ? grep { /$id/ } @keys : @keys; if ($logger->is_debug) { my $str = $id ? " with regex /$id/" : ''; $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 $logger->debug("_load_hash: loop on id $loop_id"); my $sub_elt = $element->fetch_with_id($loop_id); 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 ); } 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 ( defined $action ) { my $dispatch = $dispatch_action{ 'hash_' . $cargo_type }{$action} || $dispatch_action{ 'hash_*'}{$action} || $dispatch_action{$cargo_type}{$action} || $dispatch_action{'fallback'}{$action}; if ($dispatch) { # todo missing arguments $dispatch->( $self, $element, $check, $inst, @f_args ); return 'ok'; } } my $obj = $element->fetch_with_id( index => $id, check => $check ); $self->_load_note( $obj, $note, $inst, $cmdref ); if ( $action eq ':' and $cargo_type =~ /node/ ) { # remove possible leading or trailing quote $logger->debug("_load_hash: calling _load on node $id"); 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/ ) { $logger->debug("_load_hash: calling _load_value on leaf $id"); $self->_load_value( $obj, $check, $subaction, $value ) and return 'ok'; } elsif ( $action eq ':' and defined $note ) { # action was just to store annotation return 'ok'; } elsif ($action) { Config::Model::Exception::Load->throw( object => $element, command => join( '', grep { defined $_ } @$inst ), error => "Hash assignment with '$action' on unexpected " . "cargo_type: $cargo_type" ); } } sub _load_leaf { my ( $self, $node, $check, $inst, $cmdref ) = @_; 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 ); if ( defined $action and $element->isa('Config::Model::Value')) { if ($action eq '~') { $logger->debug("_load_leaf: action '$action' deleting value"); $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 ); 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 _load_value { my ( $self, $element, $check, $subaction, $value, $inst ) = @_; $logger->debug("_load_value: action '$subaction' value '$value' check $check"); if ( $subaction eq '=' and $element->isa('Config::Model::Value') ) { $element->store( value => $value, check => $check ); } elsif ( $subaction eq '.=' and $element->isa('Config::Model::Value') ) { my $orig = $element->fetch( check => $check ); $element->store( value => $orig . $value, check => $check ); } elsif ( $subaction eq '=~' and $element->isa('Config::Model::Value') ) { my $orig = $element->fetch( check => $check ); if ( defined $orig ) { eval("\$orig =~ $value;"); if ($@) { Config::Model::Exception::Load->throw( object => $element, command => $inst, error => "Failed regexp '$value' on " . "element '" . $element->name . "' : $@" ); } $element->store( value => $orig, check => $check ); } } else { return undef; } $logger->debug("_load_value: done returns ok"); return 'ok'; } 1; # ABSTRACT: Load serialized data into config tree __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Loader - Load serialized data into config tree =head1 VERSION version 2.082 =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 $step = '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( step => $step ); print $root->describe,"\n" ; # name value type comment # foo FOO string # bar [undef] string # hash_of_nodes node hash keys: "en" "fr" # lista foo,bar,baz list # listb foo,baz list # delete some data $root->load( step => 'lista~2' ); print $root->describe(element => 'lista'),"\n" ; # name value type comment # lista foo,bar list # append some data $root->load( step => q!hash_of_nodes:en foo.=" world"! ); print $root->grab('hash_of_nodes:en')->describe(element => 'foo'),"\n" ; # name value type comment # foo "hello world" string =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 ( ) No parameter. The constructor should be used only by L. =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> will be replaced by real C<\n> (LF in Unix). =item 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 will try 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:-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:-=yy Remove the element whose value is C. For list or hash of leaves. Will not complain if the value to delete is not found. =item xxx:-~/yy/ Remove the element whose value matches C. For list or hash of leaves. Will not complain if no value were deleted. =item 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:=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 =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> will be replaced by real C<\n> (LF in Unix). Literal C<\\> will be 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. If your patten needs white spaces, you will need to surround the pattern with 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 Will append C value to current values (valid for C elements). =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 double quotes. E.g.: a_string="\"foo\" and \"bar\"" =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 node node ref of the root of the tree (of sub-root) to start the load from. =item step A string or an array ref containing the steps to load. See above for a description of the string. =item check Whether to check values while loading. Either C (default), C or C. Loading with C will discard bad values. =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut TermUI.pm100644001750001750 2252112676543661 17674 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::TermUI; $Config::Model::TermUI::VERSION = '2.082'; use Carp; use strict; use warnings; use Term::ReadLine; use base qw/Config::Model::SimpleUI/; my $completion_sub = sub { my ( $self, $text, $line, $start ) = @_; my @choice = $self->{current_node}->get_element_name; my @ret = grep( /^$text/, @choice ); return @ret; }; my $leaf_completion_sub = sub { my ( $self, $text, $line, $start ) = @_; my @choice = $self->{current_node}->get_element_name( cargo_type => 'leaf' ); my @ret = grep( /^$text/, @choice ); return @ret; }; # BUG: When doing autocompletion on a hash element with an index # containing white space (i.e. something like std_id:"abc def", # readline's completion insists on adding a white space after : # i.e. the run command tries 'std_id: "abd def"' . This fails. The # problem probably revolves around setting a readline variable like # rl_completer_word_break_characters, but I do not know which one. my $cd_completion_sub = sub { my ( $self, $text, $line, $start ) = @_; #print "text '$text' line '$line' start $start\n"; #print " cd comp param is ",join('+',@_),"\n"; # we know that text begins with 'cd ' my $cmd = $line; $cmd =~ s/cd\s+//; # convert usual cd_ism ( '..' '/foo') to grab syntax ( '-' '! foo') #$text =~ s(^/) (! ); $cmd =~ s(^\.\.$)(-)g; #$text =~ s(/) ( )g; my $new_item; while ( not defined $new_item ) { # grab in tolerant mode #print "Grabbing $cmd\n"; eval { $new_item = $self->{current_node}->grab( step => $cmd, type => 'node', mode => 'strict', autoadd => 0 ); }; chop $cmd; } #print "Grab got ",$new_item->location,"\n"; my @choice = length($line) > 3 ? () : ( '!', '-' ); my $new_type = $new_item->get_type; my @cargo = $new_item->get_element_name( cargo_type => 'node' ); foreach my $elt_name (@cargo) { if ( $new_item->element_type($elt_name) =~ /hash|list/ ) { push @choice, "$elt_name:"; foreach my $idx ( $new_item->fetch_element($elt_name)->fetch_all_indexes ) { # my ($idx) = ($raw_idx =~ /([^\n]{1,40})/ ); # $idx .= '...' unless $raw_idx eq $idx ; push @choice, "$elt_name:" . ($idx =~ /[^\w._-]/ ? qq("$idx") : $idx ). ' '; } } else { push @choice, "$elt_name "; } } # filter possible choices according to input my @ret = grep( /^$text/, @choice ); #print "->choice +",join('+',@ret),"+ text:'$text'<-\n"; return @ret; }; my %completion_dispatch = ( cd => $cd_completion_sub, desc => $completion_sub, ll => $completion_sub, ls => $completion_sub, clear => $completion_sub, set => $leaf_completion_sub, delete => $leaf_completion_sub, reset => $completion_sub, ); sub completion { my ( $self, $text, $line, $start ) = @_; #print " comp param is +$text+$line+$start+\n"; my $space_idx = index $line, ' '; my ( $main, $cmd ) = split m/\s+/, $line, 2; # /; #warn " comp main cmd is '$main' (space_idx $space_idx)\n"; if ( $space_idx > 0 and defined $completion_dispatch{$main} ) { my $i = $self->{current_node}->instance; return $completion_dispatch{$main}->( $self, $text, $line, $start ); } elsif ( not $cmd ) { return grep ( /^$text/, $self->simple_ui_commands() ); } return (); } sub new { my $type = shift; my %args = @_; my $self = {}; foreach my $p (qw/root title prompt/) { $self->{$p} = delete $args{$p} or croak "WizardHelper->new: Missing $p parameter"; } $self->{current_node} = $self->{root}; my $term = new Term::ReadLine $self->{title}; my $sub_ref = sub { $self->completion(@_); }; my $word_break_string = "\\\t\n' `\@\$><;|&{("; if ( $term->ReadLine eq "Term::ReadLine::Gnu" ) { # See Term::ReadLine::Gnu / Custom Completion my $attribs = $term->Attribs; $attribs->{completion_function} = $sub_ref; $attribs->{completer_word_break_characters} = $word_break_string; } elsif ( $term->ReadLine eq "Term::ReadLine::Perl" ) { no warnings "once"; $readline::rl_completion_function = $sub_ref; &readline::rl_set( rl_completer_word_break_characters => $word_break_string ); # &readline::rl_set('TcshCompleteMode', 'On'); } $self->{term} = $term; foreach my $p (qw//) { $self->{$p} = delete $args{$p} if defined $args{$p}; } bless $self, $type; } sub run_loop { my $self = shift; my $term = $self->{term}; my $OUT = $term->OUT || \*STDOUT; my $user_cmd; while ( defined( $user_cmd = $term->readline( $self->prompt ) ) ) { last if $user_cmd eq 'exit' or $user_cmd eq 'quit'; #print $OUT "cmd: $user_cmd\n"; my $res = $self->run($user_cmd); print $OUT $res, "\n" if defined $res and $res; ## $term->addhistory($_) if defined $_ && /\S/; } print "\n"; my $instance = $self->{root}->instance; if ( $instance->c_count ) { my @changes = $instance->say_changes; if (@changes) { $user_cmd = $term->readline("write back data before exit ? (Y/n)"); $instance->write_back unless $user_cmd =~ /n/i; print "\n"; } } } 1; # ABSTRACT: Provides Config::Model UI with Term::ReadLine __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::TermUI - Provides Config::Model UI with Term::ReadLine =head1 VERSION version 2.082 =head1 SYNOPSIS use Config::Model; use Config::Model::TermUI ; # 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 $step = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( step => $step ); my $ui = Config::Model::TermUI->new( root => $root , title => 'My class ui', prompt => 'class ui', ); # engage in user interaction $ui -> run_loop ; print $root->dump_tree ; Once the synopsis above has been saved in C, you can achieve the same interactions as with C. Except that you can use TAB completion: class ui:$ ls foo bar hash_of_nodes class ui:$ ll hash_of_nodes name value type comment hash_of_nodes node hash keys: "en" "fr" class ui:$ cd hash_of_nodes:en class ui: hash_of_nodes:en $ ll name value type comment foo hello string bar [undef] string class ui: hash_of_nodes:en $ set bar=bonjour class ui: hash_of_nodes:en $ ll name value type comment foo hello string bar bonjour string class ui: hash_of_nodes:en $ ^D At the end, the test script will dump the configuration tree. The modified C value can be found in there: foo=FOO hash_of_nodes:en foo=hello bar=bonjour - hash_of_nodes:fr foo=bonjour - - =head1 DESCRIPTION This module provides a helper to construct pure ASCII user interface on top of L. To get better interaction you must install either L or L. Depending on your installation, either L or L. See L to override default choice. =head1 USER COMMAND SYNTAX See L. =head1 CONSTRUCTOR =head2 parameters =over =item root Root node of the configuration tree =item title UI title =item prompt UI prompt. The prompt will be completed with the location of the current node. =back =head1 Methods =head2 run_loop() Engage in user interaction until user enters '^D' (CTRL-D). =head1 BUGS =over =item * Auto-completion is not complete. =item * Auto-completion provides wrong choice when you try to C in a hash where the index contains a white space. I.e. the correct command is C instead of C as proposed by auto completion. =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Warper.pm100644001750001750 6413312676543661 17774 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Warper; $Config::Model::Warper::VERSION = '2.082'; use Mouse; use Log::Log4perl qw(get_logger :levels); use Data::Dumper; use Storable qw/dclone/; use Config::Model::Exception; use Carp; has 'follow' => ( is => 'ro', isa => 'HashRef[Str]', required => 1 ); has 'rules' => ( is => 'ro', isa => 'ArrayRef', required => 1 ); has 'warped_object' => ( is => 'ro', isa => 'Config::Model::AnyThing', handles => ['notify_change'], weak_ref => 1, required => 1 ); has '_values' => ( traits => ['Hash'], is => 'ro', isa => 'HashRef[HashRef | Str | Undef ]', default => sub { {} }, handles => { _set_value => 'set', _get_value => 'get', _value_keys => 'keys', }, ); sub _get_value_gist { my $self = shift; my $warper_name = shift; my $item = $self->_get_value($warper_name); return ref($item) eq 'HASH' ? join(',', each %$item) : $item; } has _computed_masters => ( is => 'rw', isa => 'HashRef', init_arg => undef ); has [qw/_warped_nodes _registered_values/] => ( is => 'rw', isa => 'HashRef', init_arg => undef, default => sub { {} }, ); has allowed => ( is => 'rw', isa => 'ArrayRef' ); has morph => ( is => 'ro', isa => 'Bool' ); my $logger = get_logger("Warper"); # create the object, check args, but don't do anything else sub BUILD { my $self = shift; $logger->debug( "Warper new: created for " . $self->name ); $self->check_warp_args; $self->register_to_all_warp_masters; $self->refresh_values_from_master; $self->do_warp; } # should be called only at startup sub register_to_all_warp_masters { my $self = shift; my $follow = $self->follow; # now, follow is only { w1 => 'warp1', w2 => 'warp2'} foreach my $warper_name ( keys %$follow ) { $self->register_to_one_warp_master($warper_name); } } sub register_to_one_warp_master { my $self = shift; my $warper_name = shift || die "register_to_one_warp_master: missing warper_name"; my $follow = $self->follow; my $warper_path = $follow->{$warper_name}; $logger->debug( "Warper register_to_one_warp_master: '", $self->name, "' follows '$warper_name'" ); # need to register also to all warped_nodes found on the path my @command = ($warper_path); my $warper; my $warped_node; my $obj = $self->warped_object; my $reg_values = $self->_registered_values; return if defined $reg_values->{$warper_name}; while (@command) { # may return undef object ( $obj, @command ) = $obj->grab( step => \@command, mode => 'step_by_step', grab_non_available => 1, ); if ( not defined $obj ) { $logger->debug("Warper register_to_one_warp_master: aborted steps. Left '@command'"); last; } my $obj_loc = $obj->location; $logger->debug("Warper register_to_one_warp_master: step to master $obj_loc"); if ( $obj->isa('Config::Model::Value') or $obj->isa('Config::Model::CheckList')) { $warper = $obj; if ( defined $warped_node ) { # keep obj ref to be able to unregister later on $self->_warped_nodes->{$warped_node}{$warper_name} = $obj; } last; } if ( $obj->isa('Config::Model::WarpedNode') ) { $logger->debug("Warper register_to_one_warp_master: register to warped_node $obj_loc"); if ( defined $warped_node ) { # keep obj ref to be able to unregister later on $self->_warped_nodes->{$warped_node}{$warper_name} = $obj; } $warped_node = $obj_loc; $obj->register( $self, $warper_name ); } } if ( defined $warper and scalar @command ) { Config::Model::Exception::Model->throw( object => $self->warped_object, error => "Some steps are left (@command) from warper path $warper_path", ); } $logger->debug( "Warper register_to_one_warp_master:", $self->name, " is warped by $warper_name => '$warper_path' location in tree is: '", defined $warper ? $warper->name : 'unknown', "'" ); return unless defined $warper; Config::Model::Exception::Model->throw( object => $self->warped_object, error => "warper $warper_name => '$warper_path' is not a leaf" ) unless $warper->isa('Config::Model::Value') or $obj->isa('Config::Model::CheckList'); # warp will register this value object in another value object # (the warper). When the warper gets a new value, it will # modify the warped object according to the data passed by the # user. my $type = $warper->register( $self, $warper_name ); $reg_values->{$warper_name} = $warper; # store current warp master value if ( $type eq 'computed' ) { $self->_computed_masters->{$warper_name} = $warper; } } sub refresh_affected_registrations { my ( $self, $warped_node_location ) = @_; my $wnref = $self->_warped_nodes; $logger->debug( "Warper refresh_affected_registrations: called on", $self->name, " from $warped_node_location'" ); #return unless defined $wnref ; # remove and unregister obj affected by this warped node my $ref = delete $wnref->{$warped_node_location}; foreach my $warper_name ( keys %$ref ) { $logger->debug( "Warper refresh_affected_registrations: ", $self->name, " unregisters from $warper_name'" ); delete $self->_registered_values->{$warper_name}; $ref->{$warper_name}->unregister( $self->name ); } $self->register_to_all_warp_masters; #map { $self->register_to_one_warp_master($_) } keys %$ref; } # should be called only at startup sub refresh_values_from_master { my $self = shift; # should get new value from warp master my $follow = $self->follow; # now, follow is only { w1 => 'warp1', w2 => 'warp2'} # should try to get values only for unregister or computed warp masters foreach my $warper_name ( keys %$follow ) { my $warper_path = $follow->{$warper_name}; $logger->debug( "Warper trigger: ", $self->name, " following $warper_name" ); # warper can itself be warped out (part of a warped out node). # not just 'not available'. my $warper = $self->warped_object->grab( step => $warper_path, mode => 'loose', ); if ( defined $warper and $warper->get_type eq 'leaf' ) { # read the warp master values, so I can warp myself just after. my $warper_value = $warper->fetch('allow_undef'); my $str = $warper_value // ''; $logger->debug( "Warper: '$warper_name' value is: '$str'" ); $self->_set_value( $warper_name => $warper_value ); } elsif ( defined $warper and $warper->get_type eq 'check_list' ) { if ($logger->is_debug) { my $warper_value = $warper->fetch(); $logger->debug( "Warper: '$warper_name' checked values are: '$warper_value'" ); } # store checked values are data structure, not as string $self->_set_value( $warper_name => scalar $warper->get_checked_list_as_hash() ); } elsif ( defined $warper ) { Config::Model::Exception::Model->throw( error => "warp error: warp 'follow' parameter " . "does not point to a leaf element", object => $self->warped_object ); } else { # consider that the warp master value is undef $self->_set_value( $warper_name, '' ); $logger->debug("Warper: '$warper_name' is not available"); } } } sub name { my $self = shift; return "Warper of " . $self->warped_object->name; } # And I'm going to warp them ... sub warp_them { my $self = shift; # retrieve current value if not provided my $value = @_ ? $_[0] : $self->fetch_no_check; foreach my $ref ( @{ $self->{warp_these_objects} } ) { my ( $warped, $warp_index ) = @$ref; next unless defined $warped; # $warped is a weak ref and may vanish # pure warp of object $logger->debug( "Warper ", $self->name, " warp_them: (value ", ( defined $value ? $value : 'undefined' ), ") warping '", $warped->name, "'" ); $warped->warp( $value, $warp_index ); } } sub check_warp_args { my $self = shift; # check that rules element are array ref and store them for # error checking my $rules_ref = $self->rules; my @rules = ref $rules_ref eq 'HASH' ? %$rules_ref : ref $rules_ref eq 'ARRAY' ? @$rules_ref : Config::Model::Exception::Model->throw( error => "warp error: warp 'rules' parameter " . "is not a ref ($rules_ref)", object => $self->warped_object ); my $allowed = $self->allowed; for ( my $r_idx = 0 ; $r_idx < $#rules ; $r_idx += 2 ) { my $key_set = $rules[$r_idx]; my @keys = ref($key_set) ? @$key_set : ($key_set); my $v = $rules[ $r_idx + 1 ]; Config::Model::Exception::Model->throw( object => $self->warped_object, error => "rules value for @keys is not a hash ref ($v)" ) unless ref($v) eq 'HASH'; foreach my $pkey ( keys %$v ) { Config::Model::Exception::Model->throw( object => $self->warped_object, error => "Warp rules error for '@keys': '$pkey' " . "parameter is not allowed, " . "expected '" . join( "' or '", @$allowed ) . "'" ) unless grep( $pkey eq $_, @$allowed ); } } } sub _dclone_key { return map { ref $_ ? [@$_] : $_ } @_; } # Internal. This method will change element properties (like level) according to the warp effect. # For instance, if a warp rule make a node no longer available in a model, its level must change to # 'hidden' sub set_parent_element_property { my ( $self, $arg_ref ) = @_; my $warped_object = $self->warped_object; my @properties = qw/level/; if ( defined $warped_object->index_value ) { $logger->debug("Warper set_parent_element_property: called on hash or list, aborted"); return; } my $parent = $warped_object->parent; my $elt_name = $warped_object->element_name; foreach my $property_name (@properties) { my $v = $arg_ref->{$property_name}; if ( defined $v ) { $logger->debug( "Warper set_parent_element_property: set '", $parent->name, " $elt_name' $property_name with $v" ); $parent->set_element_property( property => $property_name, element => $elt_name, value => $v, ); } else { # reset ensures that property is reset to known state by default $logger->debug("Warper set_parent_element_property: reset $property_name"); $parent->reset_element_property( property => $property_name, element => $elt_name, ); } } } # try to actually warp (change properties) of a warped object. sub trigger { my $self = shift; my %old_value_set = %{ $self->_values }; if (@_) { my ( $value, $warp_name ) = @_; $logger->debug( "Warper: trigger called on ", $self->name, " with value '", defined $value ? $value : '', "' name $warp_name" ); $self->_set_value( $warp_name => $value || '' ); } # read warp master values that are computed my $cm = $self->_computed_masters; foreach my $name ( keys %$cm ) { $self->_set_value( $name => $cm->{$name}->fetch ); } # check if new values are different from old values my $same = 1; foreach my $name ( $self->_value_keys ) { my $old = $old_value_set{$name}; my $new = $self->_get_value_gist($name); $same = 0 if ( $old ? 1 : 0 xor $new ? 1 : 0 ) or ( $old and $new and $new ne $old ); } if ($same) { no warnings "uninitialized"; if ( $logger->is_debug ) { $logger->debug( "Warper: warp skipped because no change in value set ", "(old: '", join( "' '", %old_value_set ), "' new: '", join( "' '", %{ $self->_values() } ), "')" ); } return; } $self->do_warp; } # undef values are changed to '' so compute_bool no longer returns # undef. It returns either 1 or 0 sub compute_bool { my $self = shift; my $expr = shift; $logger->debug("Warper compute_bool: called for '$expr'"); # my $warp_value_set = $self->_values ; $logger->debug( "Warper compute_bool: data:\n", Data::Dumper->Dump( [ $self->_values ], ['data'] ) ); # checklist: $stuff.is_set(&index) # get_value of a checklist gives { 'val1' => 1, 'val2' => 0,...} $expr =~ s/(\$\w+)\.is_set\(([&$"'\w]+)\)/$1.'->{'.$2.'}'/eg; $expr =~ s/&(\w+)/\$warped_obj->$1/g; my @init_code; my %eval_data ; foreach my $warper_name ( $self->_value_keys ) { $eval_data{$warper_name} = $self->_get_value($warper_name) ; push @init_code, "my \$$warper_name = \$eval_data{'$warper_name'} ;"; } my $perl_code = join( "\n", @init_code, $expr ); $logger->debug("Warper compute_bool: eval code '$perl_code'"); my $ret; { my $warped_obj = $self->warped_object ; no warnings "uninitialized"; $ret = eval($perl_code); } if ($@) { Config::Model::Exception::Model->throw( object => $self->warped_object, error => "Warp boolean expression failed:\n$@" . "eval'ed code is: \n$perl_code" ); } $logger->debug( "compute_bool: eval result: ", ( $ret ? 'true' : 'false' ) ); return $ret; } sub do_warp { my $self = shift; my $warp_value_set = $self->_values; my $rules = dclone( $self->rules ); my %rule_hash = @$rules; # try all boolean expression with warp_value_set to get the # correct rule my $found_rule = {}; my $found_bool = ''; # this variable may be used later in error message foreach my $bool_expr (@$rules) { next if ref($bool_expr); # it's a rule not a bool expr my $res = $self->compute_bool($bool_expr); next unless $res; $found_bool = $bool_expr; $found_rule = $rule_hash{$bool_expr} || {}; $logger->debug( "do_warp found rule for '$bool_expr':\n", Data::Dumper->Dump( [$found_rule], ['found_rule'] ) ); last; } if ( $logger->is_info ) { my @warp_str = map { defined $_ ? $_ : 'undef' } keys %$warp_value_set; $logger->info( "do_warp: warp called from '$found_bool' on '", $self->warped_object->name, "' with elements '", join( "','", @warp_str ), "', warp rule is ", ( scalar %$found_rule ? "" : 'not ' ), "found" ); } $logger->debug( "do_warp: call set_parent_element_property on '", $self->name, "' with ", Data::Dumper->Dump( [$found_rule], ['found_rule'] ) ); $self->set_parent_element_property($found_rule); $logger->debug( "do_warp: call set_properties on '", $self->warped_object->name, "' with ", Data::Dumper->Dump( [$found_rule], ['found_rule'] ) ); eval { $self->warped_object->set_properties(%$found_rule); }; if ($@) { my @warp_str = map { defined $_ ? $_ : 'undef' } keys %$warp_value_set; my $e = $@; my $msg = ref $e ? $e->as_string : $e; Config::Model::Exception::Model->throw( object => $self->warped_object, error => "Warp failed when following '" . join( "','", @warp_str ) . "' from \"$found_bool\". Check model rules:\n\t" . $msg ); } } # Usually a warp error occurs when the item is not actually available # or when a setting is wrong. Then guiding the user toward a warp # master value that has a rule attached to it is a good idea. # But sometime, the user wants to remove and item. In this case it # must be warped out by setting a warp master value that has not rule # attached. This case is indicated when $want_remove is set to 1 sub warp_error { my ($self) = @_; return '' unless defined $self->{warp}; my $follow = $self->{warp}{follow}; my @rules = @{ $self->{warp}{rules} }; # follow is either ['warp1','warp2',...] # or { warp1 => {....} , ...} or 'warp' my @warper_paths = ref($follow) eq 'ARRAY' ? @$follow : ref($follow) eq 'HASH' ? values %$follow : ($follow); my $str = "You may solve the problem by modifying " . ( @warper_paths > 1 ? "one or more of " : '' ) . "the following configuration parameters:\n"; my $expected_error = 'Config::Model::Exception::UnavailableElement'; foreach my $warper_path (@warper_paths) { my $warper_value; my $warper; # try eval { $warper = $self->get_warper_object($warper_path); $warper_value = $warper->fetch; }; my $e = $@; # catch if ( ref($e) eq $expected_error ) { $str .= "\t'$warper_path' which is unavailable\n"; next; } $warper_value = 'undef' unless defined $warper_value; my @choice = defined $warper->choice ? @{ $warper->choice } : $warper->{value_type} eq 'boolean' ? ( 0, 1 ) : (); my @try = sort grep { $_ ne $warper_value } @choice; $str .= "\t'" . $warper->location . "': Try "; my $a = $warper->{value_type} =~ /^[aeiou]/ ? 'an' : 'a'; $str .= @try ? "'" . join( "' or '", @try ) . "' instead of " : "$a $warper->{value_type} value different from "; $str .= "'$warper_value'\n"; if ( defined $warper->{compute} ) { $str .= "\n\tHowever, '" . $warper->name . "' " . $warper->compute_info . "\n"; } } $str .= "Warp parameters:\n" . Data::Dumper->Dump( [ $self->{warp} ], ['warp'] ) if $logger->is_debug; return $str; } __PACKAGE__->meta->make_immutable; # ABSTRACT: Warp tree properties 1; __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Warper - Warp tree properties =head1 VERSION version 2.082 =head1 SYNOPSIS # internal class =head1 DESCRIPTION Depending on the value of a warp master (In fact a L or a L object), this class will change the properties of a node (L), a hash (L), a list (L), a checklist (L) or another value. =head1 Warper and warped Warping an object means that the properties of the object will be changed depending on the value of another object. The changed object is referred as the I object. The other object that holds the important value is referred as the I or the I object. You can also set up several warp master for one warped object. This means that the properties of the warped object will be changed according to a combination of values of the warp masters. =head1 Warp arguments Warp arguments are passed in a hash ref whose keys are C and and C: =head2 Warp follow argument L leading to the C or L warp master. E.g.: follow => '! tree_macro' In case of several warp master, C will be set to an array ref of several L: follow => [ '! macro1', '- macro2' ] You can also use named parameters: follow => { m1 => '! macro1', m2 => '- macro2' } Note: By design C argument of warper module is a plain path to keep warp mechanism (relatively) simple. C argument of L has more features and is documented L =head2 Warp rules argument String, hash ref or array ref that specify the warped object property changes. These rules specifies the actual property changes for the warped object depending on the value(s) of the warp master(s). E.g. for a simple case (rules is a hash ref) : follow => '! macro1' , rules => { A => { }, B => { } } In case of similar effects, you can use named parameters and a boolean expression to specify the effect. The first match will be applied. In this case, rules is a list ref: follow => { m => '! macro1' } , rules => [ '$m eq "A"' => { }, '$m eq "B" or $m eq"C "' => { } ] In case of several warp masters, C must use named parameters, and rules must use boolean expression: follow => { m1 => '! macro1', m2 => '- macro2' } , rules => [ '$m1 eq "A" && $m2 eq "C"' => { }, '$m1 eq "A" && $m2 eq "D"' => { }, '$m1 eq "B" && $m2 eq "C"' => { }, '$m1 eq "B" && $m2 eq "D"' => { }, ] Of course some combinations of warp master values can have the same effect: follow => { m1 => '! macro1', m2 => '- macro2' } , rules => [ '$m1 eq "A" && $m2 eq "C"' => { }, '$m1 eq "A" && $m2 eq "D"' => { }, '$m1 eq "B" && $m2 eq "C"' => { }, '$m1 eq "B" && $m2 eq "D"' => { }, ] In this case, you can use different boolean expression to save typing: follow => { m1 => '! macro1', m2 => '- macro2' } , rules => [ '$m1 eq "A" && $m2 eq "C"' => { }, '$m1 eq "A" && $m2 eq "D"' => { }, '$m1 eq "B" && ( $m2 eq "C" or $m2 eq "D") ' => { }, ] Note that the boolean expression will be sanitized and used in a Perl eval, so you can use most Perl syntax and regular expressions. Function (like C<&foo>) will be called like C<< $self->foo >> before evaluation of the boolean expression. The rules must be declared with a slightly different way when a check_list is used as a warp master: a check_list has not a simple value. The rule must check whether a value is checked or not amongs all the possible items of a check list. For example, let's say that C<$cl> in the rule below point to a check list whose items are C and C. The rule must verify if the item is set or not: rules => [ '$cl.is_set(A)' => { }, '$cl.is_set(B)' => { }, # can be combined '$cl.is_set(B) and $cl.is_set(A)' => { }, ], With this feature, you can control with a check list whether some element must be shown or not (assuming C and C classes are declared): element => [ # warp master my_check_list => { type => 'check_list', choice => ['has_foo','has_bar'] }, # controlled element that show up only when has_foo is set foo => { type => 'warped_node', level => 'hidden', config_class_name => 'FooClass', follow => { selected => '- my_check_list' }, 'rules' => [ '$selected.is_set(has_foo)' => { level => 'normal' } ] }, # controlled element that show up only when has_bar is set bar => { type => 'warped_node', level => 'hidden', config_class_name => 'BarClass', follow => { selected => '- my_check_list' }, 'rules' => [ '$selected.is_set(has_bar)' => { level => 'normal' } ] } ] =head1 Methods =head2 warp_error() This method returns a string describing: =over =item * The location(s) of the warp master =item * The current value(s) of the warp master(s) =item * The other values accepted by the warp master that can be tried (if the warp master is an enumerated type) =back =head1 How does this work ? =over =item Registration =over =item * When a warped object is created, the constructor will register to the warp masters. The warp master are found by using the special string passed to the C parameter. As explained in L, the string provides the location of the warp master in the configuration tree using a symbolic form. =item * Then the warped object retrieve the value(s) of the warp master(s) =item * Then the warped object warps itself using the above value(s). Depending on these value(s), the properties of the warped object will be modified. =back =item Master update =over =item * When a warp master value is updated, the warp master will call I its warped object and pass them the new master value. =item * Then each warped object will modify its properties according to the new warp master value. =back =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut FuseUI.pm100644001750001750 2614012676543661 17670 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::FuseUI; $Config::Model::FuseUI::VERSION = '2.082'; # 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->debug("FuseUI getdir called with $name"); my $obj = get_object($name); return -EINVAL() unless ( ref $obj and $obj->can('children') ); my @c = ( '..', '.', $obj->children ); map { s(/)($dir_char_mockup)g } @c; $logger->debug( "FuseUI getdir return @c , wantarray is " . ( wantarray ? 1 : 0 ) ); return ( @c, 0 ); } my %files; 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->debug("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 { my @c = $obj->children; map { s(/)($dir_char_mockup)g } @c; $size = @c; } my $mode; if ( $type eq 'leaf' or $type eq 'check_list' ) { $mode = S_IFREG | 0644; } else { $mode = S_IFDIR | 0755; } 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->debug("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->debug("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); if ( not defined $v ) { return -EINVAL() if $off > 0; return ''; } 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->debug("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->debug( "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_debug ) { my $str = $buf; $str =~ s/\n/\\n/g; $logger->debug("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->debug("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->debug("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__ =pod =encoding UTF-8 =head1 NAME Config::Model::FuseUI - Fuse virtual file interface for Config::Model =head1 VERSION version 2.082 =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( 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, the call will return after forking a process that will perform the mount. Debug parameter is passed to Fuse system to get Fuse traces. =head2 fuse_mount Mount the fuse file system. This method will block until the file system is unmounted (with C command) =head1 SEE ALSO L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut warped_node_collateral.t100644001750001750 1017112676543661 20275 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More tests => 14; use Test::Exception; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy); use strict; my ( $log, $show ) = (0) x 3; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; $show = 1 if $arg =~ /s/; Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $arg =~ /l/ ? $DEBUG : $WARN ); } ok( 1, "Compilation done" ); # minimal set up to get things working my $model = Config::Model->new( legacy => 'ignore', ); $model->create_config_class( name => 'CommonOptions', element => [ atime => { value_type => 'boolean', type => 'leaf' }, ], ); $model->create_config_class( name => 'NoneOptions', element => [ bind => { value_type => 'boolean', type => 'leaf', }, ], ); $model->create_config_class( name => 'Master', element => [ fs_vfstype => { value_type => 'enum', type => 'leaf', choice => [ 'auto', 'none', ] }, fs_mntopts => { follow => { fst => '- fs_vfstype' }, type => 'warped_node', rules => [ '$fst eq \'auto\'', { config_class_name => 'Fstab::CommonOptions' }, '$fst eq \'none\'', { config_class_name => 'Fstab::NoneOptions' }, ], }, fs_passno => { value_type => 'integer', default => 0, type => 'leaf', warp => { follow => { fstyp => '- fs_vfstype', isbound => '- fs_mntopts bind', }, rules => [ '$fstyp eq "none" and $isbound' => { max => 0, } ] } }, type => { type => 'leaf', value_type => 'enum', choice => [qw/node warped_node hash list leaf check_list/], mandatory => 1, }, cargo => { type => 'warped_node', level => 'hidden', follow => { 't' => '- type' }, 'rules' => [ '$t eq "list" or $t eq "hash"' => { level => 'normal', config_class_name => 'CommonOptions', }, ], }, ] ); ok( 1, "compiled" ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); $inst->initial_load_stop; my $root = $inst->config_root; my $pass = $root->fetch_element('fs_passno'); is( $pass->fetch, '0', "check pass nb at 0" ); $pass->store(2); is( $pass->fetch, '2', "check pass nb at 2" ); $root->load('fs_vfstype=none'); is( $pass->fetch, '2', "check pass nb at 2 after setting fs_vfstype" ); $root->load('fs_mntopts bind=1'); throws_ok { $pass->fetch; } 'Config::Model::Exception::WrongValue', "check that setting bind detects and error with passno"; # fix issue $root->load('fs_mntopts bind=1 - fs_passno=0 fs_mntopts bind=0'); is( $pass->fetch, '0', "check pass nb at 2 after setting bind" ); # warp out bind $root->load('fs_vfstype=auto'); throws_ok { $root->load('fs_mntopts bind=1'); } 'Config::Model::Exception::UnknownElement', "check that setting bind was warped out"; # fix issue $root->load('fs_vfstype=none fs_mntopts bind=0 - fs_passno=3'); is( $pass->fetch, '3', "check pass nb at 3 " ); # break again $root->load('fs_mntopts bind=1'); throws_ok { $pass->fetch; } 'Config::Model::Exception::WrongValue', "check that setting bind detects and error with passno again"; $root->load('fs_passno=0 fs_mntopts bind=1'); is( $pass->fetch, '0', "check pass nb at 2 after setting bind" ); ok( $root->load('type=hash cargo atime=1'), "check warping in of a node" ); memory_cycle_ok($model); fstab.sample100644001750001750 202112676543661 20346 0ustar00domidomi000000000000Config-Model-2.082/examples/fstab# /etc/fstab: static file system information. # # proc /proc proc defaults 0 0 /dev/sda1 / ext3 defaults,errors=remount-ro 0 1 /dev/sda9 /home ext3 defaults 0 2 /dev/sda8 /tmp ext3 defaults 0 2 /dev/sda5 /usr ext3 defaults 0 2 /dev/sda6 /var ext3 defaults 0 2 /dev/sda7 none swap sw 0 0 /dev/hdc /media/cdrom0 iso9660 ro,user,noauto 0 0 /dev/fd0 /media/floppy0 vfat rw,user,noauto 0 0 /dev/sdb2 /mnt/gros ext3 defaults 0 0 /dev/sdb3 /mnt/big ext3 defaults 0 0 /dev/sdc1 /media/usb0 auto rw,user,noauto 0 0 /dev/hdc /media/cdrom auto user,noauto 0 0 http://foo.bar/baz/ /home/domi/dav davfs user,noauto 0 0 test_ini_backend_model.pl100644001750001750 1110212676543661 20414 0ustar00domidomi000000000000Config-Model-2.082/t# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # test model used by t/*.t [ { read_config => [ { backend => 'IniFile', config_dir => '/etc/', file => 'test.ini', auto_create => 1, }, ], name => 'IniTest', element => [ [qw/foo bar/] => { type => 'list', cargo => { type => 'leaf', value_type => 'uniline', } }, [qw/baz/] => { qw/type leaf value_type uniline/, }, [qw/class1 class2/] => { type => 'node', config_class_name => 'IniTest::Class' } ] }, { read_config => [ { backend => 'IniFile', config_dir => '/etc/', file => 'test.ini', auto_create => 1, comment_delimiter => ';', }, ], name => 'IniTest2', element => [ [qw/foo bar/] => { type => 'list', cargo => { type => 'leaf', value_type => 'uniline', } }, [qw/baz/] => { qw/type leaf value_type uniline/, }, [qw/class1 class2/] => { type => 'node', config_class_name => 'IniTest::Class' } ] }, { name => 'IniTest::Class', element => [ [qw/lista listb/] => { type => 'list', cargo => { type => 'leaf', value_type => 'uniline', }, }, ] }, { name => 'AutoIni', read_config => [ { backend => 'IniFile', config_dir => '/etc/', file => 'test.ini', auto_create => 1, }, ], accept => [ 'class.*' => { 'type' => 'node', 'config_class_name' => 'AutoIniClass' }, '.*' => { 'type' => 'list', cargo => {qw/type leaf value_type uniline/}, } ], }, { name => 'AutoIniClass', accept => [ '.*' => { 'type' => 'list', cargo => {qw/type leaf value_type uniline/}, } ], }, { name => "MyClass", element => [ [qw/foo bar/] => { 'type' => 'list', cargo => {qw/type leaf value_type uniline/}, }, [qw/baz/] => { qw/type leaf value_type uniline/, }, 'any_ini_class' => { type => 'hash', index_type => 'string', cargo => { type => 'node', config_class_name => 'AutoIniClass' }, }, ], read_config => [ { backend => 'IniFile', config_dir => '/etc/', file => 'test.ini', store_class_in_hash => 'any_ini_class', auto_create => 1, } ], }, { name => 'IniCheck', read_config => [ { backend => 'IniFile', file => 'test.ini', auto_create => 1, }, ], element => [ [qw/foo bar/] => { type => 'check_list', choice => [qw/foo1 foo2 bar1/], }, [qw/baz/] => { qw/type leaf value_type uniline/, }, [qw/class1 class2/] => { type => 'node', config_class_name => 'IniCheckList::Class' } ] }, { name => 'IniCheckList::Class', element => [ [qw/lista/] => { type => 'check_list', choice => [qw/lista1 lista2 lista3 nolist/], }, ] }, ]; fstab_test.pl100644001750001750 2005312676543661 20564 0ustar00domidomi000000000000Config-Model-2.082/examples/fstab# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # # Copyright (c) 2005-2011 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 use strict ; use warnings ; # this line is necessary to run the example without installing # Config::Model use lib ('../../lib') ; use Config::Model ; use Getopt::Long ; use Text::Wrap ; use File::Path ; use vars qw/$model/ ; my $use_etc = 0; GetOptions ("use_etc" => \$use_etc); my $fstab_file = $use_etc ? '/etc/fstab' : 'fstab.sample' ; $model = Config::Model -> new(model_dir => 'lib/Config/Model/models') ; my $instance = $model -> instance( root_class_name => 'MyFstab', instance_name => 'test', ) ; my $root= $instance -> config_root ; print " The first part of this example program will read a sample fstab file. You can run this program with -use_etc to load /etc/fstab. Just bear in mind that the Fstab model provided in this example is far from being complete and may fail to read your file. "; sub stop { print "Hit to continue\n"; my $read = ; } stop() ; open(FSTAB, $fstab_file) || die "Can't open $fstab_file:$!"; my %opt_r_translate = ( ro => 'rw=0', rw => 'rw=1', bsddf => 'statfs_behavior=bsddf', minixdf => 'statfs_behavior=minixdf', ) ; while () { s/#.*//; next if /^\s*$/; my ($device,$mount_point,$type,$options, $dump, $pass) = split; my ($dev_name) = ($device =~ /(\w+)$/) ; my $label = $type eq 'swap' ? "swap-on-$dev_name" : $mount_point; my $fs_obj = $root->fetch_element('fs')->fetch_with_id($label) ; my $load_line = "fs_vfstype=$type fs_spec=$device fs_file=$mount_point " ."fs_freq=$dump fs_passno=$pass" ; #print "loading with '$load_line'\n"; $fs_obj->load($load_line) ; # now load options #print "fs_type $type options is $options\n"; my @options = split /,/,$options ; map { $_ = $opt_r_translate{$_} if defined $opt_r_translate{$_}; s/no(.*)/$1=0/ ; $_ .= '=1' unless /=/ ; } @options ; #print "load @options\n"; $fs_obj->fetch_element('fs_mntopts')->load (\@options) ; } print " ok. I could read $fstab_file. The second part of this program will produce a report that shows the settings contained in $fstab_file and shows the on-line help provided with Fstab model (feel free to modify the model (Fstab.pm) to provide more help). "; stop ; print $root->report() ; print " The third part of this program will produce a minimal fstab file without any comment: "; stop ; # now write back a valid fstab file sub produce_fstab { my $with_help = shift || 0 ; my %opt_w_translate = ( rw => { 0 => 'ro', 1 => 'rw' }, statfs_behavior => { bsddf => 'bsddf', minixdf => 'minixdf'}, user => { 0 => '' , 1 => 'user'}, user_xattr => { 0 => '' , 1 => 'user_xattr'}, sw => { 0 => '' , 1 => 'sw'}, defaults => { 0 => '' , 1 => 'defaults'}, auto => { 0 => 'noauto' , 1 => 'auto'}, ); my @new_fstab ; foreach my $fs_obj ($root->fetch_element('fs')->fetch_all) { my $opt_container = $fs_obj->fetch_element('fs_mntopts'); my $fs_type = $fs_obj->fetch_element_value('fs_vfstype'); if ($with_help) { my $fs_help = $fs_obj->fetch_element('fs_vfstype') ->get_help($fs_type); push @new_fstab, "# fs label: ".$fs_obj->index_value , wrap("# '$fs_type' file system: ", '# ', $fs_help) if $fs_help; } my @opt_arg; foreach my $opt_name ($opt_container -> get_element_name) { my $opt_value = $opt_container->fetch_element_value($opt_name) ; next unless defined $opt_value; my $show_value = '';; if (defined $opt_w_translate{$opt_name} && defined $opt_w_translate{$opt_name}{$opt_value} ) { $show_value = $opt_w_translate{$opt_name}{$opt_value} ; } elsif (defined $opt_w_translate{$opt_name}) { $show_value = $opt_value ; } else { $show_value = "$opt_name=$opt_value" ; } if ($with_help) { my $opt_help = $opt_container->fetch_element($opt_name) -> get_help($opt_value) ; push @new_fstab, wrap("# * option '$show_value' effect: ", '# ', $opt_help) if $opt_help; } push @opt_arg, $show_value if $show_value ; } push @new_fstab, sprintf("%-10s %-20s %-15s %-15s %d %d", $fs_obj->fetch_element_value('fs_spec'), $fs_obj->fetch_element_value('fs_file'), $fs_type , join(',',@opt_arg), $fs_obj->fetch_element_value('fs_freq'), $fs_obj->fetch_element_value('fs_passno'), ) ; push @new_fstab, "" if $with_help ; } return @new_fstab } print join ("\n",produce_fstab()),"\n"; print " To help newbie admin to understand their configuration files, this program can also produce a fstab file with the help and descriptions provided in fstab model. "; stop ; print join ("\n",produce_fstab(1)),"\n"; print " Now you can enter in an interactive shell to explore or modify the fstab data (do not fear to play in the pseudo-shell provided by this program as the modified data will not be written back to /etc/fstab). Exit the pseudo-shell by typing CTRL-D. The first command you might want to type is 'help'. You can also hit TAB twice to get the list of available commands. " ; stop ; my $store = sub { my $dir = shift ; mkpath ($dir,0, 0755) unless -d $dir ; open(FILE,"> $dir/fstab") || die "Cannot open $dir/fstab: $!"; print FILE join ("\n",produce_fstab()),"\n"; close FILE ; return "Written $dir/fstab"; }; require Config::Model::TermUI; my $term_ui = Config::Model::TermUI -> new( root => $root , title => $fstab_file.' configuration', prompt => ' >', store_sub => $store, ); # engage in user interaction $term_ui -> run_loop ; eval {require Config::Model::TkUI} ; if ($@) { print " If you want to try the Perl/Tk graphical interface, you must install Config::Model::TkUI and re-run this test. " ; } else { print " Now you can enter in a Tk graphical interface to check fstab data. Like before, data are not written back to /etc/fstab, so feel free to experiment " ; stop ; use Log::Log4perl qw(:easy) ; Log::Log4perl->easy_init($WARN); require Tk; require Tk::ErrorDialog; Tk->import ; my $mw = MainWindow-> new ; $mw->withdraw ; $mw->ConfigModelUI (-root => $root,) ; &MainLoop ; # Tk's } eval {require Config::Model::CursesUI} ; if ($@) { print " If you want to try the curses interface, you must install Config::Model::CursesUI and re-run this test. " ; } else { my $err_file = '/tmp/config-model-error.log' ; print " Now you can enter in a curses interface to check fstab data. Like before, data are not written back to /etc/fstab, so feel free to experiment In case of error, check $err_file " ; stop ; open (FH,"> $err_file") || die "Can't open $err_file: $!" ; open STDERR, ">&FH"; my $dialog = Config::Model::CursesUI-> new ( permission => 'advanced', ) ; # engage in user interaction # eval is required to trap the exit done in Curses eval{ $dialog->start( $model ) } ; close FH ; } print "\n$0 done. Feel free to send feedback to the author ", "(ddumont at cpan dot org)\n\n"; SimpleUI.pm100644001750001750 2710412676543661 20220 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::SimpleUI; $Config::Model::SimpleUI::VERSION = '2.082'; use Carp; use 5.010; use strict; use warnings; my $syntax = ' cd cd , cd - , cd ! -> jump into node set elt=value, elt:key=value -> set a value clear elt -> clear value or list or hash delete elt:key -> delete a value from a list or hash element delete elt -> like reset, delete a value (set to undef) display elt elt:key -> display a value ls -> show elements of current node ll -> show elements of current node and their value tree -> show configuration tree from current node help -> show available command desc[ription] -> show class desc of current node desc -> show desc of element from current node desc -> show effect of value (for enum) changes -> list unsaved changes fix -> fix most warnings (called on all elements) save -> save current changes exit -> exit shell '; my $desc_sub = sub { my $self = shift; my $obj = $self->{current_node}; my $res = ''; if (@_) { my $item; while ( $item = shift ) { if ( $obj->isa('Config::Model::Node') ) { my $type = $obj->element_type($item); my $elt = $obj->fetch_element($item); $res .= "element $item (type $type): " . $obj->get_help($item) . "\n"; if ( $type eq 'leaf' and $elt->value_type eq 'enum' ) { $res .= " possible values: " . join( ', ', $elt->get_choice ) . "\n"; } } } } else { $res = $obj->get_help(); } return $res; }; my $ll_sub = sub { my $self = shift; my $elt = shift ; my $obj = $self->{current_node}; my $res ; if (defined $elt and $elt =~ /\*/) { $elt =~ s/\*/.*/g; $res = $obj->describe( pattern => qr/^$elt$/, check => 'no' ); } else { $res = $obj->describe( element => $elt, check => 'no' ); } return $res; }; my $cd_sub = sub { my $self = shift; my @cmds = @_; # convert usual cd_ism ( .. /foo) to grab syntax ( - ! foo) #map { s(^/) (! ); # s(\.\.)(-)g; # s(/) ( )g; # } @cmds ; my $new_node = $self->{current_node}->grab("@cmds"); my $type = $new_node->get_type; my $name = $new_node->element_name; if ( defined $new_node && $type eq 'node' ) { $self->{current_node} = $new_node; } elsif ( defined $new_node && $type eq 'list' ) { print "Can't cd in a $type, please add an index (e.g. $name:0)\n"; } elsif ( defined $new_node && $type eq 'hash' ) { print "Can't cd in a $type, please add an index (e.g. $name:foo)\n"; } elsif ( defined $new_node && $type eq 'leaf' ) { print "Can't cd in a $type\n"; } else { print "Cannot find @_\n"; } return ""; }; my %run_dispatch = ( help => sub { return $syntax; }, set => sub { my $self = shift; my $cmd = shift; if ($cmd) { $cmd =~ s/\s*([=:])\s*/$1/; $self->{current_node}->load($cmd); } else { say "No command given."; } return ""; }, display => sub { my $self = shift; say "Nothing to display" unless @_; return $self->{current_node}->grab_value(@_); }, ls => sub { my $self = shift; my $pattern = shift || '*'; $pattern =~ s/\*/.*/g; my $i = $self->{current_node}->instance; my @res = grep {/^$pattern$/} $self->{current_node}->get_element_name; return join( ' ', @res ); }, tree => sub { my $self = shift; my $i = $self->{current_node}->instance; my @res = $self->{current_node}->dump_tree( full_dump => 1 ); return join( ' ', @res ); }, delete => sub { my $self = shift; if ($_[0]) { my ( $elt_name, $key ) = split /\s*:\s*/, $_[0]; my $elt = $self->{current_node}->fetch_element($elt_name); if ( length($key) ) { $elt->delete($key); } else { $elt->store(undef); } } else { say "delete what ?"; } return ''; }, clear => sub { my ( $self, $elt_name ) = @_; if ($elt_name) { $self->{current_node}->fetch_element($elt_name)->clear(); } else { say "Expected element name for clear command. I.e. one of ", join(' ',$self->{current_node}->get_element_name); } return ''; }, fix => sub { my ( $self ) = @_; return $self->{root}->instance->apply_fixes; }, save => sub { my ($self) = @_; $self->{root}->instance->write_back(); return "done"; }, changes => sub { my ( $self ) = @_; return $self->{root}->instance->list_changes; }, ll => $ll_sub, cd => $cd_sub, description => $desc_sub, desc => $desc_sub, ); $run_dispatch{reset} = $run_dispatch{clear}; $run_dispatch{dump} = $run_dispatch{tree}; sub simple_ui_commands { return sort keys %run_dispatch; } sub new { my $type = shift; my %args = @_; my $self = {}; foreach my $p (qw/root title prompt/) { $self->{$p} = delete $args{$p} or croak "SimpleUI->new: Missing $p parameter"; } $self->{current_node} = $self->{root}; bless $self, $type; } sub run_loop { my $self = shift; my $user_cmd; print $self->prompt; while ( defined( $user_cmd = ) ) { chomp $user_cmd; last if $user_cmd eq 'exit' or $user_cmd eq 'quit'; my $res = $self->run($user_cmd); print $res, "\n" if defined $res; print $self->prompt; } print "\n"; my $instance = $self->{root}->instance; if ( $instance->c_count ) { my @changes = $instance->say_changes; if (@changes) { print "write back data before exit ? (Y/n)"; $user_cmd = ; $instance->write_back unless $user_cmd =~ /n/i; print "\n"; } } } sub prompt { my $self = shift; my $ret = $self->{prompt} . ':'; my $loc = $self->{current_node}->location_short; $ret .= " $loc " if $loc; return $ret . '$ '; } sub run { my ( $self, $user_cmd ) = @_; return '' unless $user_cmd =~ /\w/; $user_cmd =~ s/^\s+//; my ( $action, $args ) = split( m/\s+/, $user_cmd, 2 ); $args =~ s/\s+$//g if defined $args; #cleanup if ( defined $run_dispatch{$action} ) { my $res = eval { $run_dispatch{$action}->( $self, $args ); }; print $@ if $@; return $res; } else { return "Unexpected command '$action'"; } } sub list_cd_path { my $self = shift; my $c_node = $self->{current_node}; my @result; foreach my $elt_name ( $c_node->get_element_name ) { my $t = $c_node->element_type($elt_name); if ( $t eq 'list' or $t eq 'hash' ) { push @result, map { "$elt_name:$_" } $c_node->fetch_element($elt_name)->fetch_all_indexes; } else { push @result, $elt_name; } } return \@result; } 1; #ABSTRACT: Simple interface for Config::Model __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::SimpleUI - Simple interface for Config::Model =head1 VERSION version 2.082 =head1 SYNOPSIS use Config::Model; use Config::Model::SimpleUI ; # 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 $step = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( step => $step ); my $ui = Config::Model::SimpleUI->new( root => $root , title => 'My class ui', prompt => 'class ui', ); # engage in user interaction $ui -> run_loop ; print $root->dump_tree ; Once the synopsis above has been saved in C, you can do: $ perl my_test.pl class ui:$ ls foo bar hash_of_nodes class ui:$ ll hash_of_nodes name value type comment hash_of_nodes node hash keys: "en" "fr" class ui:$ cd hash_of_nodes:en class ui: hash_of_nodes:en $ ll name value type comment foo hello string bar [undef] string class ui: hash_of_nodes:en $ set bar=bonjour class ui: hash_of_nodes:en $ ll name value type comment foo hello string bar bonjour string class ui: hash_of_nodes:en $ ^D At the end, the test script will dump the configuration tree. The modified C value can be found in there: foo=FOO hash_of_nodes:en foo=hello bar=bonjour - hash_of_nodes:fr foo=bonjour - - =head1 DESCRIPTION This module provides a pure ASCII user interface using STDIN and STDOUT. =head1 USER COMMAND SYNTAX =over =item cd ... Jump into node or value element. You can use C<< cd >>, C<< cd >> or C to go up one node or C to go to configuration root. =item set elt=value Set a leaf value. =item set elt:key=value Set a leaf value locate in a hash or list element. =item clear elt Clear leaf value (set to C) or removed all elements of hash or list. =item delete elt Delete leaf value. =item delete elt:key Delete a list or hash element =item display node_name elt:key Display a value =item ls | ls foo* Show elements of current node. Can be used with a shell pattern. =item ll | ll foo* Describe elements of current node. Can be used with a shell pattern. =item tree Show configuration tree from current node. =item help Show available commands. =item desc[ription] Show class description of current node. =item desc(elt) Show description of element from current node. =item desc(value) Show effect of value (for enum) =item changes Show unsaved changes =item fix Fix most warnings by calling L on instance. =item exit Exit shell =back =head1 CONSTRUCTOR =head2 parameters =over =item root Root node of the configuration tree =item title UI title =item prompt UI prompt. The prompt will be completed with the location of the current node. =back =head1 Methods =head2 run_loop() Engage in user interaction until user enters '^D' (CTRL-D). =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Iterator.pm100644001750001750 3124412676543661 20322 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Iterator; $Config::Model::Iterator::VERSION = '2.082'; use Carp; use strict; use warnings; use Config::Model::ObjTreeScanner; use Log::Log4perl qw(get_logger :levels); use Config::Model::Exception; my $logger = get_logger("Wizard::Helper"); sub new { my $type = shift; my %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} ); } sub bail_out { my $self = shift; $self->{bail_out} = 1; } # 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}; } } # 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 { my ( $self, $scanner, $data_r, $node, $element ) = splice @_, 0, 5; my @keys = sort @_; 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 ( $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}; } } # 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"; } } sub go_forward { my $self = shift; $logger->info("Going forward") if $self->{forward} == -1; $self->{forward} = 1; } sub go_backward { my $self = shift; $logger->info("Going backward") if $self->{forward} == 1; $self->{forward} = -1; } 1; # ABSTRACT: Iterates forward or backward a configuration tree __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Iterator - Iterates forward or backward a configuration tree =head1 VERSION version 2.082 =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 will stop and call 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 will be 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 will be 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 will return when the scan is completely done. =head2 bail_out When called, a variable is set so that all call_backs will return 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, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut AnyThing.pm100644001750001750 6122212676543661 20251 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::AnyThing; $Config::Model::AnyThing::VERSION = '2.082'; 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/] ); # 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}; $change_logger->debug( "called for ", $self->name, " from ", join( ' ', caller ), " with ", join( ' ', %args ) ) if $change_logger->is_debug; # 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->debug("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; $self->{annotation} = join( "\n", grep ( defined $_, @_ ) ) if @_ and not $self->instance->preset and not $self->instance->layered; return $self->{annotation} || ''; } sub clear_annotation { my $self = shift; $self->{annotation} = ''; } 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->debug("load_pod_annotation: '$path' -> '$note'"); $self->grab( step => $path )->annotation($note); } } } ## Navigation # accept commands like # item:b -> go down a node, create a new node if necessary # - climbs up # ! climbs up to the top # Now return an object and not a value ! sub grab { my $self = shift; my ( $step, $mode, $autoadd, $type, $grab_non_available, $check ) = ( undef, 'strict', 1, undef, 0, 'yes' ); my %args = @_ > 1 ? @_ : ( step => $_[0] ); $step = delete $args{step}; $mode = delete $args{mode} if defined $args{mode}; $autoadd = delete $args{autoadd} if defined $args{autoadd}; $grab_non_available = delete $args{grab_non_available} if defined $args{grab_non_available}; $type = delete $args{type}; # node, leaf or undef $check = $self->_check_check( delete $args{check} ); if ( defined $args{strict} ) { carp "grab: deprecated parameter 'strict'. Use mode"; $mode = delete $args{strict} ? 'strict' : 'adaptative'; } Config::Model::Exception::User->throw( object => $self, message => "grab: unexpected parameter: " . join( ' ', keys %args ) ) if %args; Config::Model::Exception::Internal->throw( error => "grab: step parameter must be a string " . "or an array ref" ) unless ref $step eq 'ARRAY' || not ref $step; # accept commands, grep remove empty items left by spurious spaces my $huge_string = ref $step ? join( ' ', @$step ) : $step; my @command = ( $huge_string =~ 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 )+ # can have several parts in one command ) # end of *one* command /gx ); my @saved = @command; $logger->debug( "grab: executing '", join( "' '", @command ), "' on object '", $self->name, "'" ); my @found = ($self); COMMAND: while (@command) { last if $mode eq 'step_by_step' and @saved > @command; my $cmd = shift @command; my $obj = $found[-1]; $logger->debug( "grab: executing cmd '$cmd' on object '", $obj->name, "($obj)'" ); if ( $cmd eq '!' ) { push @found, $obj->grab_root(); next; } if ( $cmd =~ /^!([\w:]*)/ ) { my $ancestor = $obj->grab_ancestor($1); if ( defined $ancestor ) { push @found, $ancestor; next; } else { Config::Model::Exception::AncestorClass->throw( object => $obj, info => "grab called from '" . $self->name . "' with steps '@saved' looking for class $1" ) if $mode eq 'strict'; return; } } if ( $cmd =~ /^\?(\w[\w-]*)/ ) { push @found, $obj->grab_ancestor_with_element_named($1); $cmd =~ s/^\?//; #remove the go up part unshift @command, $cmd; next; } if ( $cmd eq '-' ) { if ( defined $obj->parent ) { push @found, $obj->parent; next; } else { $logger->debug( "grab: ", $obj->name, " has no parent" ); return $mode eq 'adaptative' ? $obj : undef; } } unless ( $obj->isa('Config::Model::Node') or $obj->isa('Config::Model::WarpedNode') ) { Config::Model::Exception::Model->throw( object => $obj, message => "Cannot apply command '$cmd' on leaf item" . " (full command is '@saved')" ); } my ( $name, $action, $arg ) = ( $cmd =~ /(\w[\-\w]*)(?:(:)((?:"[^\"]*")|(?:[\w:\/\.\-\+]+)))?/ ); if ( defined $arg and $arg =~ /^"/ and $arg =~ /"$/ ) { $arg =~ s/^"//; # remove leading quote $arg =~ s/"$//; # remove trailing quote } { no warnings "uninitialized"; $logger->debug("grab: cmd '$cmd' -> name '$name', action '$action', arg '$arg'"); } unless ( $obj->has_element($name) ) { if ( $mode eq 'step_by_step' ) { return wantarray ? ( undef, @command ) : undef; } elsif ( $mode eq 'loose' ) { return; } elsif ( $mode eq 'adaptative' ) { last; } else { Config::Model::Exception::UnknownElement->throw( object => $obj, element => $name, function => 'grab', info => "grab called from '" . $self->name . "' with steps '@saved'" ); } } unless ( $grab_non_available or $obj->is_element_available( name => $name, ) ) { if ( $mode eq 'step_by_step' ) { return wantarray ? ( undef, @command ) : undef; } elsif ( $mode eq 'loose' ) { return; } elsif ( $mode eq 'adaptative' ) { last; } else { Config::Model::Exception::UnavailableElement->throw( object => $obj, element => $name, function => 'grab', info => "grab called from '" . $self->name . "' with steps '@saved'" ); } } my $next_obj = $obj->fetch_element( name => $name, check => $check, accept_hidden => $grab_non_available ); # create list or hash element only if autoadd is true if ( defined $action and $autoadd == 0 and not $next_obj->exists($arg) ) { return if $mode eq 'loose'; Config::Model::Exception::UnknownId->throw( object => $obj->fetch_element($name), element => $name, id => $arg, function => 'grab' ) unless $mode eq 'adaptative'; last; } if ( defined $action and not $next_obj->isa('Config::Model::AnyId') ) { return if $mode eq 'loose'; Config::Model::Exception::Model->throw( object => $obj, message => "Cannot apply command '$cmd' on non hash or non list item" . " (full command is '@saved'). item is '" . $next_obj->name . "'" ); last; } # action can only be : $next_obj = $next_obj->fetch_with_id($arg) if defined $action; push @found, $next_obj; } # check element type if ( defined $type ) { my @allowed = ref $type ? @$type : ($type); while ( @found and not grep {$found[-1]->get_type eq $_} @allowed ) { Config::Model::Exception::WrongType->throw( object => $found[-1], function => 'grab', got_type => $found[-1]->get_type, expected_type => $type, info => "requested with step '$step'" ) if $mode ne 'adaptative'; pop @found; } } my $return = $found[-1]; $logger->debug( "grab: returning object '", $return->name, "($return)'" ); return wantarray ? ( $return, @command ) : $return; } sub grab_value { my $self = shift; my %args = scalar @_ == 1 ? ( step => $_[0] ) : @_; my $obj = $self->grab(%args); # Pb: may return a node. add another option to grab ?? # to get undef value when needed? return if ( $args{mode} and $args{mode} eq 'loose' and not defined $obj ); Config::Model::Exception::User->throw( object => $self, message => "grab_value: cannot get value of non-leaf or check_list " . "item with '" . join( "' '", @_ ) . "'. item is $obj" ) unless ref $obj and ( $obj->isa("Config::Model::Value") or $obj->isa("Config::Model::CheckList") ); my $value = $obj->fetch; if ( $logger->is_debug ) { my $str = defined $value ? $value : ''; $logger->debug( "grab_value: returning value $str of object '", $obj->name ); } return $value; } sub grab_annotation { my $self = shift; my @args = scalar @_ == 1 ? ( step => $_[0] ) : @_; my $obj = $self->grab(@args); return $obj->annotation; } sub grab_root { my $self = shift; return defined $self->parent ? $self->parent->grab_root : $self; } sub grab_ancestor { my $self = shift; my $class = shift || die "grab_ancestor: missing ancestor class"; return $self if $self->get_type eq 'node' and $self->config_class_name eq $class; return $self->{parent}->grab_ancestor($class) if defined $self->{parent}; return; } #internal. Used by grab with '?xxx' steps sub grab_ancestor_with_element_named { my ( $self, $search, $type ) = @_; my $obj = $self; while (1) { $logger->debug( "grab_ancestor_with_element_named: executing cmd '?$search' on object " . $obj->name ); my $obj_element_name = $obj->element_name; if ( $obj->isa('Config::Model::Node') and $obj->has_element( name => $search, type => $type ) ) { # object contains the search element, we need to grab the # searched object (i.e. the '?foo' part is done return $obj; } elsif ( defined $obj->parent ) { # going up $obj = $obj->parent; } else { # there's no more up to go to... Config::Model::Exception::Model->throw( object => $self, error => "Error: cannot grab '?$search'" . "from " . $self->name ); } } } 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 $dumper = Config::Model::DumpAsData->new; $dumper->dump_as_data( node => $self, @_ ); } # 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->debug( "dummy has_fixes called on " . $self->name ); return 0; } sub has_warning { my $self = shift; $logger->debug( "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__ =pod =encoding UTF-8 =head1 NAME Config::Model::AnyThing - Base class for configuration tree item =head1 VERSION version 2.082 =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_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( [ 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 ( 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 grab(...) Grab an object from the configuration tree. Parameters are: =over =item C A string indicating the steps to follow in the tree to find the required item. (mandatory) =item C When set to C, C will throw an exception if no object is found using the passed string. When set to C, the object found at last will be returned. For instance, for the step C, only the object held by C will be returned. When set to C, grab will return undef in case of problem. (default is C) =item C Either C, C, C or C or an array ref containing these values. Returns only an object of requested type. Depending on C value, C will either throw an exception or return the last found object of requested type. (optional, default to C, which means any type of object) Examples: $root->grep(step => 'foo:2 bar', type => 'leaf') $root->grep(step => 'foo:2 bar', type => ['leaf','check_list']) =item C When set to 1, C or C configuration element are created when requested by the passed steps. (default is 1). =item grab_non_available When set to 1, grab will return an object even if this one is not available. I.e. even if this element was warped out. (default is 0). =back The C parameters is made of the following items separated by spaces: =over 8 =item - Go up one node =item ! Go to the root node. =item !Foo Go up the configuration tree until the C configuration class is found. Raise an exception if no C class is found when root node is reached. =item xxx Go down using C element. =item xxx:yy Go down using C element and id C (valid for hash or list elements) =item ?xxx Go up the tree until a node containing element C is found. Then go down the tree like item C. If C, go up the tree the same way. But no check is done to see if id C actually exists or not. Only the element C is considered when going up the tree. =back =head2 grab_value(...) Like L, but will return the value of a leaf or check_list object, not just the leaf object. Will raise an exception if following the steps ends on anything but a leaf or a check_list. =head2 grab_annotation(...) Like L, but will return the annotation of an object. =head2 grab_root() Returns the root of the configuration tree. =head2 grab_ancestor( Foo ) Go up the configuration tree until the C configuration class is found. Returns the found node or undef. =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 of 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( string ) Forwarded to L. =head2 model_searcher () Returns an object dedicated to search an element in the configuration model (respecting privilege level). 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 =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Describe.pm100644001750001750 1766012676543661 20257 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Describe; $Config::Model::Describe::VERSION = '2.082'; use Carp; use strict; use warnings; use Config::Model::Exception; use Config::Model::ObjTreeScanner; 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 $my_content_cb = sub { my ( $scanner, $data_ref, $node, @element ) = @_; # filter elements according to pattern my @scan = $pattern ? grep { $_ =~ $pattern } @element : @element; map { $scanner->scan_element( $data_ref, $node, $_ ) } @scan; }; my $std_cb = sub { my ( $scanner, $data_r, $obj, $element, $index, $value_obj ) = @_; my $value = $value_obj->fetch( check => $check ); $value = '"' . $value . '"' if defined $value and $value =~ /\s/; #print "DEBUG: std_cb on $element, idx $index, value $value\n"; my $name = defined $index ? "$element:$index" : $element; $value = defined $value ? $value : '[undef]'; my $type = $value_obj->value_type; my @comment; push @comment, "choice: " . join( ' ', @{ $value_obj->choice } ) if $type eq 'enum'; push @comment, 'mandatory' if $value_obj->mandatory; push @$data_r, [ $name, $value, $type, 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; 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 { push @$data_r, [ $element, join( ',', $list_obj->fetch_all_values( check => 'no' ) ), 'list', '' ]; } }; my $check_list_element_cb = sub { my ( $scanner, $data_r, $obj, $element, @choices ) = @_; my $list_obj = $obj->fetch_element($element); push @$data_r, [ $element, join( ',', $list_obj->get_checked_list ), 'check_list', '' ]; }; 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; 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, "<$class_name>", 'node hash', $show_str ]; } elsif (@keys) { map { $scanner->scan_hash( $data_r, $obj, $element, $_ ) } @keys; } else { push @$data_r, [ $element, "[empty hash]", 'value hash', "" ]; } }; 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, "<$class_name>", 'node', '' ]; #$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 $format = "%-12s %-12s %-12s %-35s\n"; my @ret = [qw/name value type comment/]; 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 ); } return join '', map { sprintf( $format, @$_ ) } @ret; } 1; # ABSTRACT: Provide a description of a node element __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Describe - Provide a description of a node element =head1 VERSION version 2.082 =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 $step = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( step => $step ); print $root->describe ; ### prints # name value type comment # foo FOO string # bar [undef] string # 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 value type comment fs_spec [undef] string mandatory fs_vfstype [undef] enum choice: auto davfs ext2 ext3 swap proc iso9660 vfat ignore, mandatory fs_file [undef] string mandatory fs_freq 0 boolean fs_passno 0 integer 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/ ) =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Instance.pm100644001750001750 5126412676543661 20301 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Instance; $Config::Model::Instance::VERSION = '2.082'; #use Scalar::Util qw(weaken) ; use 5.10.1; use Mouse; use Mouse::Util::TypeConstraints; use MouseX::StrictConstructor; with "Config::Model::Role::NodeLoader"; use Text::Diff; use File::Path; use Log::Log4perl qw(get_logger :levels); use Config::Model::Annotation; 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 FATAL => qw(all); use warnings::register; use Carp qw/carp croak confess cluck/; my $logger = get_logger("Instance"); my $change_logger = get_logger("Anything::Change"); 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', ); 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', }, ); # 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) has [qw/preset layered/] => ( is => 'ro', isa => 'Bool', default => 0, ); has changes => ( is => 'ro', isa => 'ArrayRef', traits => ['Array'], default => sub { [] }, handles => { add_change => 'push', c_count => 'count', #needs_save => 'count' , clear_changes => 'clear', } ); sub needs_save { my $self = shift; my $arg = shift; if ( defined $arg ) { if ($arg) { carp "replace needs_save(1) call with add_change"; $self->add_change(); # may not work } else { carp "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 users requires to write all configuration tree in their # backend storage. has _write_back => ( is => 'ro', isa => 'ArrayRef', traits => ['Array'], handles => { register_write_back => 'push', count_write_back => 'count', # mostly for tests }, default => sub { [] }, ); # used for auto_read auto_write feature has [qw/name application root_dir backend backup/] => ( is => 'ro', isa => 'Maybe[Str]', ); has read_root_dir => ( is => 'ro', isa => 'Str', lazy_build => 1, ); sub _build_read_root_dir { my $self = shift; my $root_dir = $self->root_dir // ''; # cleanup paths $root_dir .= '/' if $root_dir and $root_dir !~ m!/$! ; return $root_dir; } # config_file cannot be a Path::Tiny object: it may be a file name # relative to a directory only known by a backend (e.g. a patch in # debian/patches directory) has config_file => (is => 'ro', isa => 'Maybe[Str]'); has config_dir => (is => 'ro', isa => 'Maybe[Str]'); has skip_read => ( is => 'ro', isa => 'Bool', default => 0 ); has tree => ( is => 'ro', isa => 'Config::Model::Node', builder => 'reset_config', reader => 'config_root', handles => [qw/apply_fixes/], ); sub reset_config { my $self = shift; return $self->load_node ( config_class_name => $self->{root_class_name}, instance => $self, container => $self, skip_read => $self->skip_read, check => $self->read_check, 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 ) = @_; $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); foreach my $k (@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 load { my $self = shift; my $loader = Config::Model::Loader->new; my %args = @_ eq 1 ? ( step => $_[0] ) : @_; $loader->load( node => $self->{tree}, %args ); } sub search_element { my $self = shift; $self->{tree}->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->read_root_dir; } sub write_directory { my $self = shift; carp "write_directory is deprecated"; return $self->read_root_dir; } sub write_root_dir { my $self = shift; return $self->read_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 list_changes { my $self = shift; my $l = $self->changes; my @all; foreach my $c (@$l) { my $path = $c->{path} ; $path .= ': ' if $path; my $vt = $c->{value_type} || ''; my ( $o, $n ) = map { $_ // ''; } ( $c->{old}, $c->{new} ); if ( $vt eq 'string' and ( $o =~ /\n/ or $n =~ /\n/ ) ) { # append \n if needed so diff works as expected map { $_ .= "\n" unless /\n$/; } ( $o, $n ); my $diff = diff \$o, \$n; push @all, $path . ( $c->{note} ? " # $c->{note}" : '' ) . "\n" . $diff; } elsif ( defined $c->{old} or defined $c->{new} ) { map { s/\n.*/.../s; } ( $o, $n ); push @all, $path."'$o' -> '$n'" . ( $c->{note} ? " # $c->{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; say "\n", join( "\n- ", "Changes applied to " . ($self->application // $self->name) . " configuration:", @changes ), "\n" if @changes; return @changes; } sub write_back { my $self = shift; my %args = scalar @_ > 1 ? @_ : scalar @_ == 1 ? ( config_dir => $_[0] ) : (); my $force_backend = delete $args{backend} || $self->{backend}; my $force_write = delete $args{force} || 0; foreach ( keys %args ) { if (/^(root|config_dir)$/) { $args{$_} ||= ''; $args{$_} .= '/' if $args{$_} and $args{$_} !~ m(/$); } elsif ( not /^config_file$/ ) { croak "write_back: wrong parameters $_"; } } croak "write_back: no subs registered in instance $self->{name}. cannot save data\n" unless @{ $self->{_write_back} }; foreach my $path ( @{ $self->{_write_back} } ) { $logger->info("write_back called on node $path"); my $node = $self->config_root->grab( step => $path, type => 'node' ); $node->write_back( %args, config_file => $self->{config_file}, backend => $force_backend, force => $force_write, backup => $self->backup, ); } $self->clear_changes; } sub update { my ($self, %args) = @_; my @msgs ; my $hook = sub { my ($scanner, $data_ref,$node,@element_list) = @_; if ($node->can('update')) { say "Calling update on ",$node->name, ' ',$node->config_class_name, " $node" unless $args{quiet}; push (@msgs, $node->update(%args)) } ; }; my $root = $self->config_root ; Config::Model::ObjTreeScanner->new( node_content_hook => $hook, leaf_cb => sub { } )->scan_node( \@msgs, $root ); return @msgs; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Instance of configuration tree __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Instance - Instance of configuration tree =head1 VERSION version 2.082 =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: 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: =over =item root_dir Pseudo root directory where to read I write configuration files. Configuration directory specified in model or with C option is appended to this root directory =item config_dir Directory to read or write configuration file. This parameter must be supplied if not provided by the configuration model. =item backend Specify which backend to use. See L for details =item skip_read When set, configuration files will not be read when creating configuration tree. =item check 'yes', 'skip' or 'no' =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 will be 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 will be 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 will be discarded (equivalent to C 'no'> ). =head1 METHODS =head2 name() Returns the instance name. =head2 config_root() Returns the root object of the configuration tree. =head2 read_check() Returns how to check read files. =head2 show_message( 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_stop () Stop initial_load mode. Instance is built with initial_load as 1. Read backend will clear this value once the first read is done. =head2 initial_load () Get initial_load mode =head2 data( kind, [data] ) The data method provide a way to store some arbitrary data in the instance object. =head2 load( "..." ) Load configuration tree with configuration data. See L for more details =head2 searcher ( ) Returns an object dedicated to search an element in the configuration model (respecting privilege level). This method returns a L object. See L for details on how to handle a search. =head2 wizard_helper ( ... ) Deprecated. Call L instead. =head2 iterator This method returns a L object. See L for details. Arguments are explained in L L. =head2 =head1 Auto read and write feature 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() Get the preferred backend method for this instance (as passed to the constructor). =head2 root_dir() Returns root directory where configuration data is read from or written to. =head2 register_write_back ( node_location ) Register a node path that will be 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 ( ... ) Try to run all subroutines registered with C to write the configuration information until one succeeds (returns true). (See L for details). You can specify here a pseudo root directory or another config directory to write configuration data back with C and C parameters. This will override the model specifications. You can force to use a backend by specifying C<< backend => xxx >>. For instance, C<< backend => 'augeas' >> or C<< backend => 'custom' >>. You can force to use all backend to write the files by specifying C<< backend => 'all' >>. C will croak if no write call-back are known. =head2 apply_fixes Scan the tree and apply fixes that are attached to warning specifications. See C or C in L. =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 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 the list of changes. =head2 has_warning Returns the number of warning found in the elements of this configuration instance. =head2 update( quiet => (0|1), %args ) Try to run update command on all nodes of the configuration tree. Node without C method are ignored. C will C a message otherwise (unless C is true). =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut hash_with_data_migration.t100644001750001750 602112676543661 20603 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Warn; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy :levels); BEGIN { plan tests => 11; } use strict; my $arg = shift || ''; my $log = 0; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } my $model = Config::Model->new(); Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "compiled" ); # minimal set up to get things working $model->create_config_class( name => "Master", element => [ plain_hash => { type => 'hash', status => 'deprecated', index_type => 'string', ordered => 1, cargo => { type => 'leaf', value_type => 'string' }, }, hash_with_data_migration => { type => 'hash', index_type => 'string', migrate_values_from => '- plain_hash', ordered => 1, cargo => { type => 'leaf', value_type => 'string', }, }, hash2_with_data_migration => { type => 'hash', index_type => 'string', migrate_values_from => '- hash_with_data_migration', ordered => 1, cargo => { type => 'leaf', value_type => 'string', }, }, ] ); ok( 1, "config classes created" ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; # emulate start of file read $inst->initial_load_start; # emulate config file load $root->load( step => "plain_hash:k1=foo plain_hash:k2=bar", check => 'no' ); ok( 1, "set up plain hash" ); my $hwdm = $root->fetch_element('hash_with_data_migration'); ok( $hwdm, "create hash_with_data_migration element" ); $hwdm->fetch_with_id('new')->store('baz0'); # check data prior to migration eq_or_diff( [ $hwdm->fetch_all_values ], ['baz0'], "hash data before migration" ); # emulate end of file read $inst->initial_load_stop; # test data migration stuff eq_or_diff( [ $hwdm->fetch_all_indexes ], [qw/new k1 k2/], "hash keys after migration" ); eq_or_diff( [ $hwdm->fetch_all_values ], [qw/baz0 foo bar/], "hash data after migration " ); my $hwdm2 = $root->fetch_element('hash2_with_data_migration'); ok( $hwdm2, "create hash2_with_data_migration element" ); eq_or_diff( [ $hwdm2->fetch_all_values ], [qw/baz0 foo bar/], "hash data after 2nd migration " ); memory_cycle_ok( $model, "test memory cycles" ); Exception.pm100644001750001750 3317612676543661 20475 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Exception; $Config::Model::Exception::VERSION = '2.082'; use warnings; use strict; use Data::Dumper; use Mouse; use 5.10.1; use Carp; @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 => ''); # 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(@_); $self->rethrow; } sub rethrow { my $self = shift; die $self; } sub full_msg_and_trace { my $msg = shift->full_message; $msg .= "Exception thrown ".longmess if $trace; return $msg; } 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; $Config::Model::Exception::Any::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception'; package Config::Model::Exception::ModelDeclaration; $Config::Model::Exception::ModelDeclaration::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::Fatal'; sub _desc {'configuration model declaration error' } package Config::Model::Exception::User ; $Config::Model::Exception::User::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::Any'; sub _desc {'user error' } ## old classes below package Config::Model::Exception::Syntax; $Config::Model::Exception::Syntax::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::Any'; sub _desc { 'syntax error' } has [qw/parsed_file parsed_line/] => (is => 'rw', isa => 'Str'); 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; $Config::Model::Exception::LoadData::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'Load data structure (perl) error' }; has wrong_data => (is => 'rw', isa => 'Ref'); 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 .= "(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 .= Data::Dumper->Dump( [ $self->wrong_data ], ['wrong data'] ); return $msg; } package Config::Model::Exception::Model; $Config::Model::Exception::Model::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::Fatal'; sub _desc { 'configuration model error'} sub full_message { my $self = shift; my $obj = $self->object; 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' ); $msg = "In config class '" . $obj->parent->config_class_name . "', element '$element' (level $level) "; } $msg .= "has a " . $self->description; $msg .= ":\n\t" . $self->error_or_msg . "\n"; return $msg; } package Config::Model::Exception::Load; $Config::Model::Exception::Load::VERSION = '2.082'; 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; $Config::Model::Exception::UnavailableElement::VERSION = '2.082'; 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; $Config::Model::Exception::AncestorClass::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'unknown ancestor class'} package Config::Model::Exception::ObsoleteElement; $Config::Model::Exception::ObsoleteElement::VERSION = '2.082'; 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($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; $Config::Model::Exception::UnknownElement::VERSION = '2.082'; use Carp; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'unknown element' } has [qw/element function where/] => (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 .= "In " . $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 . "'."; $msg .= " Either your file has an error or $class_name model is lagging behind. " . "In the latter case, please submit a bug report or fix the model. 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) { $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/master check no accept_hidden 1/ )->warp_error; } } $msg .= "\t" . $self->info . "\n" if ( defined $self->info ); return $msg; } package Config::Model::Exception::WarpError; $Config::Model::Exception::WarpError::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'warp error'} package Config::Model::Exception::Fatal; $Config::Model::Exception::Fatal::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::Any'; sub _desc { 'fatal error' } package Config::Model::Exception::UnknownId; $Config::Model::Exception::UnknownId::VERSION = '2.082'; 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; $Config::Model::Exception::WrongValue::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'wrong value'}; package Config::Model::Exception::WrongType; $Config::Model::Exception::WrongType::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'wrong element type' }; has [qw/function got_type expected_type/] => (is => 'rw', isa => 'Str'); sub full_message { my $self = shift; my $obj = $self->object; my $msg = ''; $msg .= "In function " . $self->function . ": " if defined $self->function; $msg .= $self->description . " for element '" . $obj->location . "'\n\tgot type '" . $self->got_type . "', expected '" . $self->expected_type . "' " . $self->info . "\n"; return $msg; } package Config::Model::Exception::ConfigFile; $Config::Model::Exception::ConfigFile::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::User'; sub _desc { 'error in configuration file' } package Config::Model::Exception::ConfigFile::Missing; $Config::Model::Exception::ConfigFile::Missing::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::ConfigFile'; sub _desc { 'missing configuration file'} has tried_files => (is => 'rw', isa => 'ArrayRef'); sub full_message { my $self = shift; my $msg = "Error: cannot find configuration file " . join (' or ', @{ $self->tried_files }); return $msg . "\n"; } package Config::Model::Exception::Formula; $Config::Model::Exception::Formula::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::Model'; sub _desc { 'error in computation formula of the configuration model'} package Config::Model::Exception::Internal; $Config::Model::Exception::Internal::VERSION = '2.082'; use Mouse; extends 'Config::Model::Exception::Fatal'; sub _desc { 'internal error' } 1; # ABSTRACT: Exception mechanism for configuration model __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Exception - Exception mechanism for configuration model =head1 VERSION version 2.082 =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 will be 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 will 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 =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut CheckList.pm100644001750001750 7352012676543661 20405 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::CheckList; $Config::Model::CheckList::VERSION = '2.082'; 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"; my $logger = get_logger("Tree::Element::CheckList"); 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_refered_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 map( delete $self->{$_}, @allowed_warp_params ); if ( $logger->is_debug() ) { my %h = @_; my $keys = join( ',', keys %h ); $logger->debug("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 map { delete $args{$_} } qw/level/; $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} ) { warn $self->name, ": default param is deprecated, use default_list\n"; $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->debug("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}; map { $self->{choice_hash}{$_} = 1; } @choice; $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 ); # notify 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->notify_change( note => 'checklist master triggered changed' ); } } # 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_refered_to; } my @changed; map { push @changed, $_ if $self->store( $_, 1, $check ) } @list; $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 ) { $changed = 1; $self->{$data_name}{$choice} = $value; } if ( $self->{ordered} and $value ) { my $ord = $self->{ordered_data}; push @$ord, $choice unless scalar grep { $choice eq $_ } @$ord; } } 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 ); } 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 uncheck { 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_refered_to; } my @changed; map { push @changed, $_ if $self->store( $_, 0, $check ) } @list; $self->notify_change( note => "uncheck @changed" ) unless $self->instance->initial_load; } my %accept_mode = map { ( $_ => 1 ) } qw/custom standard preset default layered upstream_default user/; 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 ( $mode and not defined $accept_mode{$mode} ) { croak "is_checked: expected ", join( ' or ', keys %accept_mode ), "parameter, not $mode"; } 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 $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 'user' ? $user_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_refered_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 clear { my $self = shift; map { $self->clear_item($_) } $self->get_choice; # also triggers notify changes } 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 ( $mode and not defined $accept_mode{$mode} ) { croak "get_checked_list_as_hash: expected ", join( ' or ', keys %accept_mode ), " parameter, not $mode"; } 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 = shift; my $path = shift; my $list = shift; if ($path) { Config::Model::Exception::User->throw( object => $self, message => "set() called with a value with non-empty path: '$path'" ); } return $self->set_checked_list( split /,/, $list ); } sub load { my ( $self, $string ) = @_; my @set = split /,/, $string; foreach (@set) { s/^"|"$//g; s/\\"/"/g; } $self->set_checked_list(@set); } sub store_set { goto &set_checked_list } sub set_checked_list { my $self = shift; $logger->debug("called with @_"); my %set = map { $_ => 1 } @_; my @changed; foreach my $c ( $self->get_choice ) { push @changed, $c if $self->store( $c, $set{$c} // 0 ); } $self->{ordered_data} = [@_]; # copy 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 = ref $_[0] ? %{ $_[0] } : @_; foreach my $c ( $self->get_choice ) { if ( defined $check{$c} ) { $self->store( $c, $check{$c} ); } else { $self->clear_item($c); } } } sub load_data { my $self = shift; my %args = @_ > 1 ? @_ : ( data => shift ); my $data = $args{data}; my $check = $self->_check_check( $args{check} ); if ( ref($data) eq 'ARRAY' ) { $self->set_checked_list(@$data); } elsif ( ref($data) eq 'HASH' ) { $self->set_checked_list_as_hash($data); } elsif ( not ref($data) ) { $self->set_checked_list($data); } 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__ =pod =encoding UTF-8 =head1 NAME Config::Model::CheckList - Handle check list element =head1 VERSION version 2.082 =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model->create_config_class( name => "MyClass", element => [ # type check_list will use 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( step => '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 simple 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 will be 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( 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 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 (choice_value) Return the help string on this choice value =head2 clear Reset the check list (can also be called as C) =head2 clear_item (choice_value) Reset an element of the checklist. =head2 get_checked_list_as_hash ( [ custom | preset | standard | default ] ) 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 will return all items set by the user, or items set in preset mode or checked by default. With a parameter, this method will return either: =over =item custom The list entered by the user =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 list set that will be active in the application. (ie. set by user or by layered data or preset or default) =back =head2 get_checked_list ( < mode > ) Returns a list (or a list ref) of all checked items (i.e. all items set to 1). =head2 fetch ( < mode > ) Returns a string listing the checked items (i.e. "A,B,C") =head2 get( path [, < mode> ] ) Get a value from a directory like path. =head2 set( path , values ) 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 checked items. Example : C<< $leaf->set('','A,C,Z') ; >> =head2 set_checked_list ( item1, item2, ..) Set all passed items to checked (1). All other available items in the check list are set to 0. Example: # set cl to A=0 B=1 C=0 D=1 $cl->set_checked_list('B','D') =head2 set_checked_list_as_hash () Set check_list items. Missing items in the given list of parameters are cleared (i.e. set to undef). =head2 load_data ( ref ) Load check_list as an array or hash ref. Array is forwarded to L , and hash is forwarded to L. =head1 Ordered checklist methods All the methods below are valid only for ordered checklists. =head1 swap ( choice_a, choice_b) Swap the 2 given choice in the list. Both choice must be already set. =head1 move_up ( choice ) Move the choice up in the checklist. =head1 move_down ( 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 =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut array_with_data_migration.t100644001750001750 547412676543661 21011 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More; use Test::Exception; use Test::Warn; use Test::Differences; use Test::Memory::Cycle; use Config::Model; use Log::Log4perl qw(:easy :levels); BEGIN { plan tests => 11; } use strict; my $arg = shift || ''; my $log = 0; my $trace = $arg =~ /t/ ? 1 : 0; $log = 1 if $arg =~ /l/; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } my $model = Config::Model->new(); Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "compiled" ); # minimal set up to get things working $model->create_config_class( name => "Master", element => [ plain_list => { type => 'list', status => 'deprecated', cargo => { type => 'leaf', value_type => 'string' }, }, list_with_data_migration => { type => 'list', migrate_values_from => '- plain_list', cargo => { type => 'leaf', value_type => 'string', }, }, list2_with_data_migration => { type => 'list', migrate_values_from => '- list_with_data_migration', cargo => { type => 'leaf', value_type => 'string', }, }, ] ); ok( 1, "config classes created" ); my $inst = $model->instance( root_class_name => 'Master', instance_name => 'test1' ); ok( $inst, "created dummy instance" ); my $root = $inst->config_root; # emulate start of file read $inst->initial_load_start; # emulate config file load my $pl = $root->fetch_element( name => 'plain_list', check => 'no' ); $pl->push(qw/foo bar/); my @old = $pl->fetch_all_values; ok( 1, "set up plain list" ); my $lwdm = $root->fetch_element('list_with_data_migration'); ok( $lwdm, "create list_with_data_migration element" ); $lwdm->fetch_with_id(0)->store('baz0'); # check data prior to migration eq_or_diff( [ $lwdm->fetch_all_values ], ['baz0'], "list data before migration" ); # emulate end of file read $inst->initial_load_stop; # test data migration stuff eq_or_diff( [ $lwdm->fetch_all_indexes ], [ 0 .. 2 ], "list size after migration" ); eq_or_diff( [ $lwdm->fetch_all_values ], [ baz0 => @old ], "list data migration (@old)" ); my $lwdm2 = $root->fetch_element('list2_with_data_migration'); ok( $lwdm2, "create list2_with_data_migration element" ); eq_or_diff( [ $lwdm2->fetch_all_values ], [ baz0 => @old ], "list2 data migration (@old)" ); memory_cycle_ok( $model, "test memory cycles" ); Annotation.pm100644001750001750 1545612676543661 20652 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Annotation; $Config::Model::Annotation::VERSION = '2.082'; use Mouse; use English; use File::Path; use IO::File; use Data::Dumper; #use Log::Log4perl qw(get_logger :levels); use Config::Model::Exception; use Config::Model::Node; use Config::Model::ObjTreeScanner; #use strict ; use Carp; #use warnings FATAL => qw(all); 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 => 'Str', lazy => 1, builder => '_set_file' ); has 'dir' => ( is => 'ro', isa => 'Str', lazy => 1, builder => '_set_dir' ); has 'root_dir' => ( is => 'ro', isa => 'Str|Undef', default => '' ); sub _set_file { my $self = shift; return $self->dir . $self->config_class_name . '-note.pl'; } sub _set_dir { my $self = shift; my $dir = $self->root_dir ? $self->root_dir : $EUID ? "/var/lib/" : "~/."; $dir .= "config-model/"; return $dir; } #sub new { # my $proto = shift ; # my $class = ref($proto) || $proto ; # my $instance = shift ; # # my $self # = { # instance => $instance , # }; # # bless $self, $class; # #} # sub save { my $self = shift; my $dir = $self->dir; mkpath( $dir, { mode => 0755, verbose => 0 } ) unless -d $dir; my $h = $self->get_annotation_hash; my $data = Dumper($h); my $io = IO::File->new( $self->file, 'w', 0644 ) || croak "Can't open $dir" . $self->file . ": $!"; print $io $data; $io->close; } 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 -e $f; 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__ =pod =encoding UTF-8 =head1 NAME Config::Model::Annotation - Read and write configuration annotations =head1 VERSION version 2.082 =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 $step = 'baz:fr=bonjour#french baz:hr="dobar dan"#croatian'; $root->load( step => $step ) ; # 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) Depending on the effective id of the process, the annotation will be 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 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut DumpAsData.pm100644001750001750 2545712676543661 20525 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::DumpAsData; $Config::Model::DumpAsData::VERSION = '2.082'; 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 $fetch_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}; $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} // 1; $fetch_mode //= 'non_upstream_default' if $full; $fetch_mode //= 'custom'; my $std_cb = sub { my ( $scanner, $data_r, $obj, $element, $index, $value_obj ) = @_; $$data_r = $value_obj->fetch(mode => $fetch_mode); }; 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 ) = @_; # 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 $h{$k} = $v if defined $v; push @res , $k, $v if defined $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__ =pod =encoding UTF-8 =head1 NAME Config::Model::DumpAsData - Dump configuration content as a perl data structure =head1 VERSION version 2.082 =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 $step = 'baz:fr=bonjour baz:hr="dobar dan"'; $root->load( step => $step ) ; 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 will be stored in an array ref. Note that undefined values are skipped for list element. I.e. if a list element contains C<('a',undef,'b')>, the data structure will contain 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 will be used by the application. (default is yes) 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. =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' } =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 =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut WarpedNode.pm100644001750001750 3577312676543661 20574 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::WarpedNode; $Config::Model::WarpedNode::VERSION = '2.082'; use Mouse; with "Config::Model::Role::NodeLoader"; use Carp qw(cluck croak); use Config::Model::Exception; use Config::Model::Warper; use Data::Dumper (); use Log::Log4perl qw(get_logger :levels); use Storable qw/dclone/; use Scalar::Util qw/weaken/; extends qw/Config::Model::AnyThing/; my $logger = get_logger("Tree::Node::Warped"); # don't authorize to warp 'morph' parameter as it may lead to # difficult maintenance # status is not warpable either as an obsolete parameter must stay # obsolete my @allowed_warp_params = qw/config_class_name level/; has [qw/backup follow/] => ( is => 'rw', isa => 'HashRef', default => sub { {}; } ); has [qw/rules/] => ( is => 'rw', isa => 'ArrayRef', required => 1 ); has [qw/warp help/] => ( is => 'rw', isa => 'Maybe[HashRef]' ); has morph => ( is => 'ro', isa => 'Bool', default => 0 ); has warper => ( is => 'rw', isa => 'Config::Model::Warper' ); my @backup_list = @allowed_warp_params; around BUILDARGS => sub { my $orig = shift; my $class = shift; my %args = @_; my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @backup_list; return $class->$orig( backup => dclone( \%h ), @_ ); }; sub BUILD { my $self = shift; # WarpedNode will register this object in a Value object (the # warper). When the warper gets a new value, it will modify the # WarpedNode according to the data passed by the user. my $w = Config::Model::Warper->new( warped_object => $self, rules => $self->rules, follow => $self->follow, allowed => \@allowed_warp_params ); $self->warper($w); return $self; } sub config_model { my $self = shift; return $self->parent->config_model; } # Forward selected methods (See man perltootc) foreach my $method ( qw/fetch_element config_class_name copy_from get_element_name has_element is_element_available element_type load fetch_element_value get_type get_cargo_type dump_tree describe get_help children get set accept_regexp/ ) { # to register new methods in package no strict "refs"; *$method = sub { my $self = shift; # return undef if no class was warped in $self->check or return undef; return $self->{data}->$method(@_); }; } sub name { my $self = shift; return $self->location; } sub is_accessible { my $self = shift; return defined $self->{data} ? 1 : 0; } sub get_actual_node { my $self = shift; $self->check; return $self->{data}; # might be undef } sub check { my $self = shift; my $check = shift || 'yes '; # must croak if element is not available if ( not defined $self->{data} ) { # a node can be retrieved either for a store operation or for # a fetch. if ( $check eq 'yes' ) { Config::Model::Exception::User->throw( object => $self, message => "Object '$self->{element_name}' is not accessible.\n\t" . $self->warp_error ); } else { return 0; } } return 1; } sub set_properties { my $self = shift; my %args = ( %{ $self->backup }, @_ ); # mega cleanup map( delete $self->{$_}, @allowed_warp_params ); $logger->debug( $self->name . " set_properties called with ", Data::Dumper->Dump( [ \%args ], ['set_properties_args'] ) ); my $config_class_name = delete $args{config_class_name}; my $node_class = delete $args{class} || 'Config::Model::Node'; my @prop_args = ( qw/property level element/, $self->element_name ); my $original_level = $self->config_model->get_element_property( class => $self->parent->config_class_name, @prop_args, ); my $next_level = defined $args{level} ? $args{level} : defined $config_class_name ? $original_level : 'hidden'; $self->parent->set_element_property( @prop_args, value => $next_level ) unless defined $self->index_value; unless ( defined $config_class_name ) { $self->clear; return; } my @args; ( $config_class_name, @args ) = @$config_class_name if ref $config_class_name; # check if some action is needed (ie. create or morph node) return if defined $self->{config_class_name} and $self->{config_class_name} eq $config_class_name; my $old_object = $self->{data}; my $old_config_class_name = $self->{config_class_name}; # create a new object from scratch my $new_object = $self->create_node( $config_class_name, @args ); $self->{config_class_name} = $config_class_name; $self->{data} = $new_object; if ( defined $old_object and $self->{morph} ) { # there an old object that we need to translate $logger->debug( "WarpedNode: morphing ", $old_object->name, " to ", $new_object->name ) if $logger->is_debug; $new_object->copy_from( from => $old_object, check => 'skip' ); } # bringing a new object does not really modify the content of the config tree. # only changes underneath will change the tree. And these changes below will trigger # their own change notif. SO there's no need to call notify_change when transitioning # from an undef object into a real object. On the other hand, warping out an object will # NOT trigger notify_changes from below. So notify_change must be called if ( defined $old_object ) { my $from = $old_config_class_name // ''; my $to = $config_class_name // ''; $self->notify_change( note => "warped node from $from to $to" ); } # need to call trigger on all registered objects only after all is setup $self->trigger_warp; } sub create_node { my $self = shift; my $config_class_name = shift; my @args = ( config_class_name => $config_class_name, instance => $self->{instance}, element_name => $self->{element_name}, parent => $self->parent, container => $self->container, ); push @args, index_value => $self->index_value if defined $self->index_value; return $self->load_node(@args); } sub clear { my $self = shift; delete $self->{data}; } sub load_data { my $self = shift; my %args = @_ > 1 ? @_ : ( data => shift ); my $data = $args{data}; my $check = $self->_check_check( $args{check} ); if ( ref($data) ne 'HASH' ) { Config::Model::Exception::LoadData->throw( object => $self, message => "load_data called with non hash ref arg", wrong_data => $data, ); } $self->get_actual_node->load_data(%args); } sub is_auto_write_for_type { my $self = shift; $self->get_actual_node->is_auto_write_for_type(@_); } # register warper that goes through this path when looking for warp master value sub register { my ( $self, $warped, $w_idx ) = @_; $logger->debug( "WarpedNode: " . $self->name, " registered " . $warped->name ); # weaken only applies to the passed reference, and there's no way # to duplicate a weak ref. Only a strong ref is created. See # qw(weaken) module for weaken() my @tmp = ( $warped, $w_idx ); weaken( $tmp[0] ); push @{ $self->{warp_these_objects} }, \@tmp; } sub trigger_warp { my $self = shift; # warp_these_objects is modified by the calls below, so this copy # must be done before the loop my @list = @{ $self->{warp_these_objects} || [] }; foreach my $ref (@list) { my ( $warped, $warp_index ) = @$ref; next unless defined $warped; # $warped is a weak ref and may vanish # pure warp of object $logger->debug( "node trigger_warp: from '", $self->name, "' warping '", $warped->name, "'" ); # FIXME: this does not trigger new registration (or removal thereof)... $warped->refresh_affected_registrations( $self->location ); #$warped->refresh_values_from_master ; $warped->do_warp; $logger->debug( "node trigger_warp: from '", $self->name, "' warping '", $warped->name, "' done" ); } } # FIXME: should we un-register ??? 1; # ABSTRACT: Node that change config class properties __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::WarpedNode - Node that change config class properties =head1 VERSION version 2.082 =head1 SYNOPSIS use Config::Model; my $model = Config::Model->new; foreach (qw/X Y/) { $model->create_config_class( name => "Class$_", element => [ foo => {qw/type leaf value_type string/} ] ); } $model->create_config_class( name => "MyClass", element => [ master_switch => { type => 'leaf', value_type => 'enum', choice => [qw/cX cY/] }, 'a_warped_node' => { type => 'warped_node', follow => { ms => '! master_switch' }, rules => [ '$ms eq "cX"' => { config_class_name => 'ClassX' }, '$ms eq "cY"' => { config_class_name => 'ClassY' }, ] }, ], ); my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; print "Visible elements: ",join(' ',$root->get_element_name),"\n" ; # Visible elements: master_switch $root->load( step => 'master_switch=cX' ); print "Visible elements: ",join(' ',$root->get_element_name),"\n" ; # Visible elements: master_switch a_warped_node my $node = $root->grab('a_warped_node') ; print "a_warped_node class: ",$node->config_class_name,"\n" ; # a_warped_node class: ClassX $root->load( step => 'master_switch=cY' ); print "a_warped_node class: ",$node->config_class_name,"\n" ; # a_warped_node class: ClassY =head1 DESCRIPTION This class provides a way to change dynamically the configuration class (or some other properties) of a node. The changes are done according to the model declaration. This declaration will specify one (or several) leaf in the configuration tree that will trigger the actual property change of the warped node. This leaf is also referred as I. When the warp master(s) value(s) changes, C will create an instance of the new class required by the warp master. If the morph parameter is set, the values held by the old object are (if possible) copied to the new instance of the object using L method. Warped node can alter the following properties: config_class_name level =head1 Constructor C should not be created directly. =head1 Warped node model declaration =head2 Parameter overview A warped node must be declared with the following parameters: =over =item type Always set to C. =item follow L leading to the C warp master. See L for details. =item morph boolean. If 1, C will try to recursively copy the value from the old object to the new object using L. When a copy is not possible, undef values will be assigned to object elements. =item rules Hash or array ref that specify the property change rules according to the warp master(s) value(s). See L for details on how to specify the warp master values (or combination of values). =back =head2 Effect declaration For a warped node, the effects are declared with these parameters: =over 8 =item B When requested by the warp master,the C will create a new object of the type specified by this parameter: XZ => { config_class_name => 'SlaveZ' } If you pass an array ref, the array will contain the class name and constructor arguments : XY => { config_class_name => ['SlaveY', foo => 'bar' ], }, =item B Specify a Perl class to implement the above config class. This Perl Class B inherit L. =back =head1 Forwarded methods The following methods are forwarded to contained node: fetch_element config_class_name get_element_name has_element is_element_available element_type load fetch_element_value get_type get_cargo_type describe =head1 Methods =head2 name Return the name of the node (even if warped out). =head2 is_accessible Returns true if the node hidden behind this warped node is accessible, i.e. the warp master have values so a node was warped in. =head2 get_actual_node Returns the node object hidden behind the warped node. Croaks if the node is not accessible. =head2 load_data ( hash_ref ) Load configuration data with a hash ref. The hash ref key must match the available elements of the node carried by the warped node. =head1 EXAMPLE $model ->create_config_class ( element => [ tree_macro => { type => 'leaf', value_type => 'enum', choice => [qw/XX XY XZ ZZ/] }, bar => { type => 'warped_node', follow => '! tree_macro', morph => 1, rules => [ XX => { config_class_name => [ 'ClassX', 'foo' ,'bar' ]} XY => { config_class_name => 'ClassY'}, XZ => { config_class_name => 'ClassZ'} ] } ] ); In the example above we see that: =over =item * The 'bar' slot can refer to a C, C or C object. =item * The warper object is the C attribute of the root of the object tree. =item * When C is set to C, C will not be available. Trying to access bar will raise an exception. =item * When C is changed from C to C, C will refer to a brand new C object constructed with C<< ClassX->new(foo => 'bar') >> =item * Then, if C is changed from C to C, C will refer to a brand new C object. But in this case, the object will be initialized with most if not all the attributes of C. This copy will be done whenever C is changed. =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut BackendMgr.pm100644001750001750 11703712676543661 20553 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::BackendMgr; $Config::Model::BackendMgr::VERSION = '2.082'; use Mouse; use Carp; use 5.10.1; use Config::Model::Exception; use Data::Dumper; use File::Path; use File::Copy; use File::HomeDir; use IO::File; use Storable qw/dclone/; use Scalar::Util qw/weaken/; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger('BackendMgr'); # used only for tests my $__test_home = ''; sub _set_test_home { $__test_home = shift; } # 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 'backend' => ( is => 'rw', isa => 'HashRef[Config::Model::Backend::Any]', traits => ['Hash'], default => sub { {} }, handles => { set_backend => 'set', get_backend => 'get' } ); # Configuration directory where to read and write files. This value # does not override the configuration directory specified in the model # data passed to read and write functions. has config_dir => ( is => 'ro', isa => 'Maybe[Str]', required => 0 ); has support_annotation => ( is => 'ro', isa => 'Bool', default => 0, ); sub get_tuned_config_dir { my ($self, %args) = @_; my $dir = $args{os_config_dir}{$^O} || $args{config_dir} || $self->config_dir || ''; if ( $dir =~ /^~/ ) { my $home = $__test_home || File::HomeDir->my_home; $dir =~ s/^~/$home/; } $dir .= '/' if $dir and $dir !~ m(/$); return $dir; } sub get_cfg_dir_path { my $self = shift; my %args = @_; my $w = $args{write} || 0; my $dir = $self->get_tuned_config_dir(%args); $dir = $args{root} . $dir; if ( not -d $dir and $w and $args{auto_create} ) { $logger->info("creating directory $dir"); mkpath( $dir, 0, 0755 ); } unless ( -d $dir ) { $logger->info( "auto_" . ( $w ? 'write' : 'read' ) . " $args{backend} no directory $dir" ); return ( 0, $dir ); } $logger->debug( "dir: " . $dir // '' ); return ( 1, $dir ); } 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 and $cfo eq '-' and $w == 0 ) { $logger->trace("auto_read: $args{backend} override target file is STDIN"); return ( 1, '-' ); } if ( defined $cfo ) { my $override = $args{root} . $args{config_file}; $logger->trace( "auto_" . ( $w ? 'write' : 'read' ) . " $args{backend} override target file is $override" ); return ( 1, $args{root} . $args{config_file} ); } Config::Model::Exception::Model->throw( error => "backend error: empty 'config_dir' parameter (and no config_file override)", object => $self->node ) unless $args{config_dir} or $self->config_dir; my ( $dir_ok, $dir ) = $self->get_cfg_dir_path(%args); if ( defined $args{file} ) { my $file = $args{file}; $file =~ s/&index/$self->node->index_value/eg; my $res = $dir . $file; $logger->trace("get_cfg_file_path: returns $res"); return ( $dir_ok, $res ); } if ( not defined $args{suffix} ) { $logger->trace("get_cfg_file_path: returns undef (no suffix, no file argument)"); return (0); } my $i = $self->node->instance; my $name = $dir . $i->name; # append ":foo bar" if not root object my $loc = $self->node->location; # not very good if ($loc) { if ( ( $w and not -d $name and $args{auto_create} ) ) { $logger->info( "get_cfg_file_path: auto_write create subdirectory ", "$name (location $loc)" ); mkpath( $name, 0, 0755 ); } $name .= '/' . $loc; } $name .= $args{suffix}; $logger->trace( "get_cfg_file_path: auto_" . ( $w ? 'write' : 'read' ) . " $args{backend} target file is $name" ); return ( 1, $name ); } sub open_read_file { my $self = shift; my %args = @_; my ( $file_ok, $file_path ) = $self->get_cfg_file_path(%args); if ( $file_ok and $file_path eq '-' ) { my $io = IO::Handle->new(); if ( $io->fdopen( fileno(STDIN), "r" ) ) { return ( 1, '-', $io ); } else { return ( 0, '-' ); } } # not very clean return ( 0, $file_path ) if $args{backend} =~ /_file$/ and ( not $file_ok or not -r $file_path ); my $fh = new IO::File; if ( $file_ok and -e $file_path ) { $logger->debug("open_read_file: open $file_path for read"); $fh->open($file_path); $fh->binmode(":utf8"); # store a backup in memory in case there's a problem $self->file_backup( [ $fh->getlines ] ); $fh->seek( 0, 0 ); # go back to beginning of file return ( 1, $file_path, $fh ); } else { return ( 0, $file_path ); } } # called at configuration node creation # # New subroutine "load_backend_class" extracted - Thu Aug 12 18:32:37 2010. # sub load_backend_class { my $backend = shift; my $function = shift; $logger->debug("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 ( 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 ( keys %c ) { $logger->debug("load_backend_class: looking to load class $c"); foreach my $prefix (@INC) { my $realfilename = "$prefix/$c{$c}"; $class_to_load = $c if -f $realfilename; } } return unless defined $class_to_load; my $file_to_load = $c{$class_to_load}; $logger->debug("load_backend_class: loading class $class_to_load, $file_to_load"); eval { require $file_to_load; }; if ($@) { die "Could not parse $file_to_load: $@\n"; } return $class_to_load; } sub read_config_data { my ( $self, %args ) = @_; { no warnings 'uninitialized'; $logger->debug( "called with ", join( ' ', %args ) ); } my $readlist_orig = delete $args{read_config}; my $check = delete $args{check}; my $r_dir = delete $args{read_config_dir}; 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; # r_dir is obsolete if ( defined $r_dir ) { die $self->node->config_class_name, " : read_config_dir is obsolete\n"; } my $readlist = dclone $readlist_orig ; my $instance = $self->node->instance(); # root override is passed by the instance my $root_dir = $instance->read_root_dir || ''; croak "readlist must be array or hash ref\n" unless ref $readlist; my @list = ref $readlist eq 'ARRAY' ? @$readlist : ($readlist); my $pref_backend = $instance->backend || ''; my $read_done = 0; my $auto_create = 0; my @tried; foreach my $read (@list) { warn $self->config_class_name, " deprecated 'syntax' parameter in backend\n" if defined $read->{syntax}; my $backend = delete $read->{backend} || delete $read->{syntax} || 'custom'; if ( $backend =~ /^(perl|ini|cds)$/ ) { warn $self->config_class_name, " deprecated backend $backend. Should be '$ {backend}_file'\n"; $backend .= "_file"; } next if ( $pref_backend and $backend ne $pref_backend ); if ( defined $read->{allow_empty} ) { warn "backend $backend: allow_empty is deprecated. Use auto_create"; $auto_create ||= delete $read->{allow_empty}; } $auto_create ||= delete $read->{auto_create} if defined $read->{auto_create}; if ( $read->{default_layer} ) { $self->read_config_sub_layer( $read, $root_dir, $config_file_override, $check, $backend ); } my ( $res, $file ) = $self->try_read_backend( $read, $root_dir, $config_file_override, $check, $backend ); push @tried, $file; if ($res) { $read_done = 1; last; } } Config::Model::Exception::ConfigFile::Missing->throw( tried_files => \@tried, object => $self->node, ) unless $read_done or $auto_create_override or $auto_create; } sub read_config_sub_layer { my ( $self, $read, $root_dir, $config_file_override, $check, $backend ) = @_; my $layered_config = delete $read->{default_layer}; my $layered_read = dclone $read ; map { my $lc = delete $layered_config->{$_}; $layered_read->{$_} = $lc if $lc; } qw/file config_dir os_config_dir/; Config::Model::Exception::Model->throw( error => "backend error: unexpected default_layer parameters: " . join( ' ', 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 $read = shift; my $root_dir = shift; my $config_file_override = shift; my $check = shift; my $backend = shift; my $read_dir = $self->get_tuned_config_dir(%$read); my @read_args = ( %$read, root => $root_dir, config_dir => $read_dir, backend => $backend, check => $check, config_file => $config_file_override ); my ( $file_ok, $res, $fh, $file_path ); if ( $backend eq 'custom' ) { my $c = my $file = delete $read->{class}; $file =~ s!::!/!g; my $f = delete $read->{function} || 'read'; require $file . '.pm' unless $c->can($f); no strict 'refs'; $logger->info("Read with custom backend $ {c}::$f in dir $read_dir"); ( $file_ok, $file_path, $fh ) = $self->open_read_file(@read_args); eval { $res = &{ $c . '::' . $f }( @read_args, file_path => $file_path, io_handle => $fh, object => $self->node ); }; } elsif ( $backend eq 'perl_file' ) { ( $file_ok, $file_path, $fh ) = $self->open_read_file( @read_args, suffix => '.pl' ); return ( 0, $file_path ) unless $file_ok; eval { $res = $self->read_perl( @read_args, file_path => $file_path, io_handle => $fh ); }; } elsif ( $backend eq 'cds_file' ) { ( $file_ok, $file_path, $fh ) = $self->open_read_file( @read_args, suffix => '.cds' ); return ( 0, $file_path ) unless $file_ok; eval { $res = $self->read_cds_file( @read_args, file_path => $file_path, io_handle => $fh, ); }; } else { # try to load a specific Backend class my $f = delete $read->{function} || 'read'; my $c = load_backend_class( $backend, $f ); return ( 0, 'unknown' ) unless defined $c; no strict 'refs'; my $backend_obj = $c->new( node => $self->node, name => $backend ); $self->set_backend( $backend => $backend_obj ); my $suffix; $suffix = $backend_obj->suffix if $backend_obj->can('suffix'); ( $file_ok, $file_path, $fh ) = $self->open_read_file( @read_args, suffix => $suffix ); if ($logger->is_info) { my $fp = defined $file_path ? " on $file_path":'' ; $logger->info( "Read with $backend " . $c . "::$f".$fp); } eval { $res = $backend_obj->$f( @read_args, file_path => $file_path, io_handle => $fh, object => $self->node, ); }; # only backend based on C::M::Backend::Any can support annotations if ($backend_obj->can('annotation')) { $self->{support_annotation} ||= $backend_obj->annotation ; } } # catch eval errors done in the if-then-else block before my $e = $@; if ( ref($e) and $e->isa('Config::Model::Exception::Syntax') ) { $e->parsed_file( $file_path) unless $e->parsed_file; $e->rethrow; } elsif ( ref $e ) { $e->rethrow ; } elsif ( $e ) { die "Backend error: $e"; } return ( $res, $file_path ); } sub auto_write_init { my ( $self, %args ) = @_; my $wrlist_orig = delete $args{write_config}; my $w_dir = delete $args{write_config_dir}; weaken($self); # avoid leak: $self is stored in write_back closure croak "auto_write_init: unexpected args " . join( ' ', keys %args ) . "\n" if %args; # w_dir is obsolete if ( defined $w_dir ) { die $self->config_class_name, " : write_config_dir is obsolete\n"; } my $wrlist = dclone $wrlist_orig ; my $instance = $self->node->instance(); # root override is passed by the instance my $root_dir = $instance->write_root_dir || ''; my @array = ref $wrlist eq 'ARRAY' ? @$wrlist : ($wrlist); # ensure that one auto_create specified applies to all wr backends my $auto_create = 0; foreach my $write (@array) { $auto_create ||= delete $write->{auto_create} if defined $write->{auto_create}; } # provide a proper write back function foreach my $write (@array) { warn $self->config_class_name, " deprecated 'syntax' parameter in auto_write\n" if defined $write->{syntax}; my $backend = delete $write->{backend} || delete $write->{syntax} || 'custom'; if ( $backend =~ /^(perl|ini|cds)$/ ) { warn $self->config_class_name, " deprecated backend $backend. Should be '$ {backend}_file'\n"; $backend .= "_file"; } my $write_dir = $self->get_tuned_config_dir(%$write); $logger->debug( "auto_write_init creating write cb ($backend) for ", $self->node->name ); my @wr_args = ( %$write, # model data auto_create => $auto_create, backend => $backend, config_dir => $write_dir, # override from instance write => 1, # for get_cfg_file_path root => $root_dir, # override from instance ); my $wb; if ( $backend eq 'custom' ) { my $c = my $file = $write->{class}; $file =~ s!::!/!g; my $f = $write->{function} || 'write'; require $file . '.pm' unless $c->can($f); $wb = sub { no strict 'refs'; $logger->debug( "write cb ($backend) called for ", $self->node->name ); my ( $file_ok, $file_path, $fh ) = $self->open_file_to_write( $backend, @wr_args, @_ ) unless ( $c->can('skip_open') and $c->skip_open ); my $res; $res = eval { # override needed for "save as" button &{ $c . '::' . $f }( @wr_args, io_handle => $fh, file_path => $file_path, conf_dir => $write_dir, # legacy FIXME object => $self->node, @_ # override from user ); }; $logger->warn( "write backend $c" . '::' . "$f failed: $@" ) if $@; $self->close_file_to_write( $@, $fh, $file_path ); return defined $res ? $res : $@ ? 0 : 1; }; $self->{auto_write}{custom} = 1; } elsif ( $backend eq 'perl_file' ) { $wb = sub { $logger->debug( "write cb ($backend) called for ", $self->node->name ); my ( $file_ok, $file_path, $fh ) = $self->open_file_to_write( $backend, suffix => '.pl', @wr_args, @_ ); my $res; $res = eval { $self->write_perl( @wr_args, io_handle => $fh, file_path => $file_path, @_ ); }; $self->close_file_to_write( $@, $fh, $file_path ); $logger->warn("write backend $backend failed: $@") if $@; return defined $res ? $res : $@ ? 0 : 1; }; $self->{auto_write}{perl_file} = 1; } elsif ( $backend eq 'cds_file' ) { $wb = sub { $logger->debug( "write cb ($backend) called for ", $self->node->name ); my ( $file_ok, $file_path, $fh ) = $self->open_file_to_write( $backend, suffix => '.cds', @wr_args, @_ ); my $res; $res = eval { $self->write_cds_file( @wr_args, io_handle => $fh, file_path => $file_path, @_ ); }; $logger->warn("write backend $backend failed: $@") if $@; $self->close_file_to_write( $@, $fh, $file_path ); return defined $res ? $res : $@ ? 0 : 1; }; $self->{auto_write}{cds_file} = 1; } else { my $f = $write->{function} || 'write'; my $c = load_backend_class( $backend, $f ); $wb = sub { no strict 'refs'; $logger->debug( "write cb ($backend) called for ", $self->node->name ); my $backend_obj = $self->get_backend($backend) || $c->new( node => $self->node, name => $backend ); my $suffix = $backend_obj->suffix if $backend_obj->can('suffix'); my ( $file_ok, $file_path, $fh ) = $self->open_file_to_write( $backend, suffix => $suffix, @wr_args, @_ ) unless ( $c->can('skip_open') and $c->skip_open ); my $res = eval { # override needed for "save as" button $backend_obj->$f( @wr_args, io_handle => $fh, file_path => $file_path, object => $self->node, @_ # override from user ); }; $logger->warn( "write backend $backend $c" . '::' . "$f failed: $@" ) if $@; $self->close_file_to_write( $@, $fh, $file_path ); if (defined $res and $res == 2) { unlink($file_path); return 1; } return defined $res ? $res : $@ ? 0 : 1; }; } # FIXME: enhance write back mechanism so that different backend *and* different nodse # work as expected $logger->debug( "registering write $backend in node " . $self->node->name ); push @{ $self->{write_back} }, [ $backend, $wb ]; $instance->register_write_back( $self->node->location ); } } sub write_back { my $self = shift; my %args = @_; my $force_backend = delete $args{backend} || ''; croak "write_back: no subs registered in node", $self->node->location, ". cannot save data\n" unless @{ $self->{write_back} }; my @backends = @{ $self->{write_back} }; $logger->debug( "write_back called on node '", $self->node->name, "' for ", scalar @backends, " backends" ); my $dir = $args{config_dir}; mkpath( $dir, 0, 0755 ) if $dir and not -d $dir; foreach my $wb_info (@backends) { my ( $backend, $wb ) = @$wb_info; if ( not $force_backend or $force_backend eq $backend or $force_backend eq 'all' ) { # exit when write is successfull my $res = $wb->(%args); $logger->info( "write_back called with $backend backend, result is ", defined $res ? $res : '' ); last if ( $res and not $force_backend ); } } $logger->debug( "write_back on node '", $self->node->name, "' done" ); } sub open_file_to_write { my ( $self, $backend, %args ) = @_; my $backup = delete $args{backup}; my $do_backup = defined $backup; $backup ||= 'old'; # use old only if defined $backup = '.' . $backup unless $backup =~ /^\./; my ( $file_ok, $file_path ) = $self->get_cfg_file_path(%args); if ( $file_ok and $file_path eq '-' ) { my $io = IO::Handle->new(); if ( $io->fdopen( fileno(STDOUT), "w" ) ) { return ( 1, '-', $io ); } else { return ( 0, '-' ); } } elsif ($file_ok) { if ( $do_backup and -r $file_path ) { copy( $file_path, $file_path . $backup ) or die "Backup copy failed: $!"; } $logger->debug("$backend backend opened file $file_path to write"); my $fh = new IO::File; $fh->open("> $file_path") || die "Cannot open $file_path:$!"; $fh->binmode(':utf8'); return ( $file_ok, $file_path, $fh ); } else { return ( 0, $file_path ); } } sub close_file_to_write { my ( $self, $error, $fh, $file_path ) = @_; return unless defined $file_path; if ($error) { # restore backup and display error my $data = $self->file_backup; $logger->debug( "Error during write, restoring backup in $file_path with " . scalar @$data . " lines" ); $fh->seek( 0, 0 ); # go back to beginning of file $fh->print(@$data); $fh->close; $error->rethrow if ref($error); die $error; } $fh->close; # check file size and remove empty files unlink($file_path) if -z $file_path; } sub is_auto_write_for_type { my $self = shift; my $type = shift; return $self->{auto_write}{$type} || 0; } sub read_cds_file { my $self = shift; my %args = @_; my $file_path = $args{file_path}; $logger->info("Read cds data from $file_path"); $self->node->load( step => [ $args{io_handle}->getlines ] ); return 1; } sub write_cds_file { my $self = shift; my %args = @_; 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} ); $args{io_handle}->print($dump); return 1; } sub read_perl { my $self = shift; my %args = @_; my $file_path = $args{file_path}; $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_perl { my $self = shift; my %args = @_; 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{io_handle}->print( $dumper->Dump, ";\n" ); return 1; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Load configuration node on demand __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::BackendMgr - Load configuration node on demand =head1 VERSION version 2.082 =head1 SYNOPSIS # Use BackendMgr to write data in perl data file 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", # read_config spec is used by Config::Model::BackendMgr read_config => [ { backend => 'perl_file', config_dir => '/tmp/', file => 'my_class.pl', 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->node->instance( root_class_name => 'MyClass' ); my $root = $inst->config_root; # put data my $step = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( step => $step ); $inst->write_back; # now look at file /tmp/my_class.pl =head1 DESCRIPTION This class provides a way to specify how to load or store configuration data within the model (instead of writing dedicated perl code). With these specifications, all the configuration information is read during creation of a node. =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 C: =over =item cds_file 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. See L. =item IniFile INI files (written with L. See limitations in L. =item perl_file Perl data structure (perl) in a file. See L for details on the data structure. =item custom Any format when the user provides a dedicated class and function to read and load the configuration tree. =back After loading the data, the object registers itself to the instance. Then the user can call the C method on the instance (See L) to store all configuration information back. =head2 Built-in backend C, C and C backend must be specified with mandatory C parameter. For instance: read_config => { backend => 'cds_file' , config_dir => '/etc/cfg_dir', file => 'cfg_file.cds', #optional }, If C is not specified, a file name will be constructed with C<< . >> where suffix is C or C or C. =head2 Plugin backend classes A plugin backend class can also be specified with: read_config => [ { backend => 'foo' , config_dir => '/etc/cfg_dir' file => 'foo.conf', # optional } ] In this case, this class will try to load C. (The class name is constructed with C) C can also have custom parameters that will passed verbatim to C methods: read_config => [ { backend => 'foo' , config_dir => '/etc/cfg_dir', my_param => 'my_value', } ] This C class must inherit L and is expected to provide the following methods: =over =item new Mandatory parameters: node => ref_to_config_model_node C must return the newly created object =item read with parameters: %custom_parameters, # model data root => $root_dir, # mostly used for tests config_dir => $read_dir, # path below root file_path => $full_name, # full file name (root+path+file) io_handle => $io_file # IO::File object check => [ yes|no|skip] Must return 1 if the read was successful, 0 otherwise. Following the C example above, C<%custom_parameters> will contain C< ( 'my_param' , 'my_value' ) >, so C will also be called with C, C, C, C B C<< my_param => 'my_value' >>. =item write with parameters: %$write, # model data auto_create => $auto_create, # from model backend => $backend, # backend name config_dir => $write_dir, # override from instance io_handle => $fh, # IO::File object write => 1, # always check => [ yes|no|skip] , root => $root_dir, backup => [ undef || '' || suffix ] # backup strategy required by user Must return 1 if the write was successful, 0 otherwise If C is defined, the backup has already been done while opening the config file. If C is not defined, there's not enough information in the model to read the configuration file and create the backup. Your write() method will have to do the backup requested by user. =back =head2 Custom backend Custom backend is provided to be backward compatible but should not be used for new project. Using a plugin backend as described above is preferred. Custom backend must be specified with a class name that will features the methods used to write and read the configuration files: read_config => [ { backend => 'custom' , class => 'MyRead', config_dir => '/etc/foo', # optional file => 'foo.conf', # optional } ] C backend parameters are: =over =item class Specify the class that contain the read method =item config_dir Specify configuration directory. This parameter is optional as the directory can be hardcoded in the custom class. C beginning with 'C<~>' will be munged so C<~> is replaced by C<< File::HomeDir->my_data >>. See L for details. =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 file optional. Configuration file. This parameter may not apply if the configuration is stored in several files. By default, the instance name is used as configuration file name. =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 function Function name that will be called back to read the file. See L for details. (default is 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: read_config => [ { backend => 'cds_file', config_dir => '/etc/my_cfg/' } , { backend => 'custom', class => 'Bar' , auto_create => 1 }, ], This feature is necessary to create a configuration from scratch When set in write backend, missing directory and files will be created with current umask. Default is false. =back Write specification is similar to read_specification. Except that the default value for C is C. Here's an example: write_config => [ { backend => 'cds_file', config_dir => '/etc/my_cfg/' } , { backend => 'custom', class => 'Bar' , function => 'my_write', }, ], =head1 Limitations depending on storage Some storage system will limit the structure of the model you can map to the file. =head2 Ini files limitation 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 Configuration class with auto read or auto write =head2 read specification A configuration class will be declared with optional C parameter: read_config => [ { backend => 'cds_file', config_dir => '/etc/my_cfg/' } , { backend => 'custom', class => 'Bar' }, ], The read backends will be tried in the specified order: =over =item * First the C file whose name depend on the parameters used in model creation and instance creation: C<< /.cds >> The syntax of the C file is described in L. =item * A callback to C. See L for details. =back When a read operation is successful, the remaining read methods will be skipped. =head2 write specification A configuration class will be declared with optional C parameters (along with C parameter): write_config => [ { backend => 'cds_file', config_dir => '/etc/my_cfg/', auto_create => 1, }, { backend => 'custom', class => 'NewFormat' } ], By default, the specifications are tried in order, until the first succeeds. When required by the user, all configuration information is written back using B the write specifications. See L for details. The write class declared with C backend must provide a call-back. See L for details. =head2 read write directory 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. =head2 read callback Read callback function will be called with these parameters: object => $obj, # Config::Model::Node object root => './my_test', # fake root directory, used for tests config_dir => /etc/foo', # absolute path file => 'foo.conf', # file name file_path => './my_test/etc/foo/foo.conf' io_handle => $io # IO::File object with binmode :utf8 check => [yes|no|skip] The L object is undef if the file cannot be read. The callback must return 0 on failure and 1 on successful read. =head2 write callback Write callback function will be called with these parameters: object => $obj, # Config::Model::Node object root => './my_test', # fake root directory, used for tests config_dir => /etc/foo', # absolute path file => 'foo.conf', # file name file_path => './my_test/etc/foo/foo.conf' io_handle => $io # IO::File object opened in write mode # with binmode :utf8 auto_create => 1 # create dir as needed check => [yes|no|skip] The L object is undef if the file cannot be written to. The callback must return 0 on failure and 1 on successful write. Configuration file will be deleted if callback returns 2. =head1 CAVEATS When both C and C are specified, this class will write-open the configuration file (and thus clobber it) before calling the C call-back and pass the file handle with C parameter. C should use this handle to write data in the target configuration file. If this behavior causes problem (e.g. with augeas backend), the solution is either to: =over =item * Set C to undef or an empty string in the C specification. =item * Create a C function in your backend class that returns C<1> =back =head1 EXAMPLES In the example below, only a C file is written. But, both custom format and C file are tried for read. This is also an example of a graceful migration from a customized format to a C format. read_config => [ { backend => 'cds_file', config_dir => '/etc/my_cfg/' } , { backend => 'custom', class => 'Bar' }, ], write_config => [{ backend => 'cds_file', config_dir => '/etc/my_cfg/' }], You can choose also to read and write only customized files: read_config => [{ backend => 'custom', class => 'Bar'}], Or to read and write only C files : read_config => [{ backend => 'cds_file'}] , You can also specify more parameters that must be passed to your custom class: read_config => [{ backend => 'custom', class => 'Bar', config_dir => '/etc/foo'}], To migrate from an old format to a new format: read_config => [ { backend => 'custom', class => 'OldFormat', function => 'old_read' } , { backend => 'custom', class => 'NewFormat', function => 'new_read' } ], write_config => [ { backend => 'custom', class => 'NewFormat' } ], If C is missing, the data provided by C will be used. For instance: read_config => [ { backend => 'custom', class => 'Bar', config_dir => '/etc/foo' } ], In this case, configuration data will be read by C in directory C and will be written back there by C. =head1 Methods =head2 write_back ( ... ) Try to run all subroutines registered by L write the configuration information until one succeeds (returns true). You can specify here a pseudo root directory or another config directory to write configuration data back with C and C parameters. This will override the model specifications. You can force to use a backend by specifying C<< backend => xxx >>. For instance, C<< backend => 'perl_file' >> or C<< backend => 'custom' >>. You can force to use all backend to write the files by specifying C<< backend => 'all' >>. You can force a specific config file to write with C<< config_file => 'foo/bar.conf' >> C will croak if no write call-back are known for this node. =head2 support_annotation Returns 1 if at least one of the backends support to 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 =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Backend000755001750001750 012676543661 17336 5ustar00domidomi000000000000Config-Model-2.082/lib/Config/ModelAny.pm100644001750001750 2166512676543661 20615 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Backend# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::Any; $Config::Model::Backend::Any::VERSION = '2.082'; use Carp; use strict; use warnings; use Config::Model::Exception; use Mouse; use File::Path; use Log::Log4perl qw(get_logger :levels); my $logger = get_logger("Backend"); has 'name' => ( is => 'ro', default => 'unknown', ); has 'annotation' => ( is => 'ro', isa => 'Bool', default => 0 ); has 'node' => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1, required => 1, handles => ['show_message', 'instance'], ); sub suffix { my $self = shift; $logger->info( "Internal warning: suffix called for backend $self->{name}.This method can be overloaded" ); return undef; } 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 my @global_comments; while ( defined( my $l = shift @$lines ) ) { next if $l =~ /^$cc$cc/; # 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\s?/, $l, 2; push @global_comments, $comment if defined $comment; if ( $l =~ /^\s*$/ or $data ) { if (@global_comments) { $self->node->annotation(@global_comments); $logger->debug("Setting global comment with @global_comments"); } # put back any data and comment unshift @$lines, $l unless $l =~ /^\s*$/; # stop global comment at first blank or non comment line last; } } } sub associates_comments_with_data { my $self = shift; my $lines = shift; my $cc = shift; # comment character my @result; my @comments; foreach my $l (@$lines) { next if $l =~ /^$cc$cc/; # remove comments added by Config::Model chomp $l; my ( $data, $comment ) = split /\s*$cc\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->debug("associates_comments_with_data: '$note' with '$data'"); push @result, [ $data, $note ]; @comments = (); } } return wantarray ? @result : \@result; } sub write_global_comment { my ( $self, $ioh, $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) { map { $res .= "$cc $_\n" } split /\n/, $global_note; $res .= "\n"; } $ioh->print($res) if defined $ioh; return $res; } sub write_data_and_comments { my ( $self, $ioh, $cc, @data_and_comments ) = @_; my $res = ''; while (@data_and_comments) { my ( $d, $c ) = splice @data_and_comments, 0, 2; if ($c) { map { $res .= "$cc $_\n" } split /\n/, $c; } $res .= "$d\n" if defined $d; } $ioh->print($res) if defined $ioh; return $res; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Virtual class for other backends __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::Any - Virtual class for other backends =head1 VERSION version 2.082 =head1 SYNOPSIS package Config::Model::Backend::Foo ; use Mouse ; extends 'Config::Model::Backend::Any'; # optional sub suffix { return '.foo'; } # mandatory 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' # io_handle => $io # IO::File object # check => yes|no|skip return 0 unless defined $args{io_handle} ; # or die? foreach ($args{io_handle}->getlines) { chomp ; s/#.*// ; next unless /\S/; # skip blank line # $data is 'foo=bar' which is compatible with load $self->node->load(step => $_, check => $args{check} ) ; } return 1 ; } # mandatory sub write { 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' # io_handle => $io # IO::File object # check => yes|no|skip my $ioh = $args{io_handle} ; foreach my $elt ($self->node->get_element_name) { my $obj = $self->node->fetch_element($elt) ; my $v = $self->node->grab_value($elt) ; # write value $ioh->print(qq!$elt="$v"\n!) if defined $v ; $ioh->print("\n") if defined $v ; } return 1; } no Mouse ; __PACKAGE__->meta->make_immutable ; =head1 DESCRIPTION This L class is to be inherited by other backend plugin classes See L and L for more details on the method that must be provided by any backend classes. =head1 CONSTRUCTOR =head2 new ( node => $node_obj, name => backend_name ) The constructor should be used only by L. =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 suffix Suffix of the configuration file. This method returns C =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( string ) Show a message to STDOUT (unless overridden). Delegated to L. =head2 read_global_comments( lines , comment_char) 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. The first parameter (C) is an array ref containing file lines. =head2 associates_comments_with_data ( lines , comment_char) This method will extract 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: # Foo comments foo= 1 Baz = 0 # Baz comments will return ( [ 'foo= 1', 'Foo comments' ] , [ 'Baz = 0' , 'Baz comments' ] ) =head2 write_global_comments( io_handle , comment_char) Write global comments from configuration root annotation into the io_handle (if defined). Returns the string written to the io_handle. =head2 write_data_and_comments( io_handle , comment_char , data1, comment1, data2, comment2 ...) Write data and comments in the C (if defined). Comments are written before the data. Returns the string written to the io_handle. If a data is undef, the comment will be written on its own line. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut system.d000755001750001750 012676543661 17555 5ustar00domidomi000000000000Config-Model-2.082/lib/Config/Modelfstab100644001750001750 1612676543661 20674 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/system.dmodel = Fstab TreeSearcher.pm100644001750001750 1410712676543661 21104 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::TreeSearcher; $Config::Model::TreeSearcher::VERSION = '2.082'; use Mouse; use Mouse::Util::TypeConstraints; use Log::Log4perl qw(get_logger :levels); use Config::Model::Exception; use Config::Model::ObjTreeScanner; use Carp; my @search_types = qw/element value key summary description help/; enum( 'SearchType' => [ @search_types, 'all' ] ); # clean up namespace to avoid clash between MUTC keywords and # my functions # See http://www.nntp.perl.org/group/perl.moose/2010/10/msg1935.html no Mouse::Util::TypeConstraints; has 'node' => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1, required => 1 ); has 'type' => ( is => 'ro', isa => 'SearchType' ); has '_type_hash' => ( is => 'rw', isa => 'HashRef[Bool]', builder => '_build_type_hash', lazy => 1, ); my $logger = get_logger("TreeSearcher"); sub _build_type_hash { my $self = shift; my $t = $self->type; my $def = $t eq 'all' ? 1 : 0; my %res = map { $_ => $def; } @search_types; $res{$t} = 1 unless $t eq 'all'; return \%res; } sub search { my $self = shift; my $string = shift; # string to search, can be a regexp $logger->debug( "TreeSearcher: creating scanner for " . $self->node->name ); my $reg = qr/$string/i; my @scanner_args; my $need_search = $self->_build_type_hash; push @scanner_args, leaf_cb => sub { my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_; my $loc = $leaf_object->location; $logger->debug("TreeSearcher: scanning leaf $loc"); my $v = $leaf_object->fetch( check => 'no' ); if ( $need_search->{value} and defined $v and $v =~ $reg ) { $data_ref->($loc); } if ( $need_search->{help} ) { my $help_ref = $leaf_object->get_help; $data_ref->($loc) if grep { $_ =~ $reg; } values %$help_ref; } }; push @scanner_args, hash_element_cb => sub { my ( $scanner, $data_ref, $node, $element_name, @keys ) = @_; my $loc = $node->location; $loc .= ' ' if $loc; $loc .= $element_name; $logger->debug("TreeSearcher: scanning hash $loc"); foreach my $k (@keys) { if ( $need_search->{key} and $k =~ $reg ) { my $hloc = $node->fetch_element($element_name)->fetch_with_id($k)->location; $data_ref->($hloc); } $scanner->scan_hash( $data_ref, $node, $element_name, $k ); } }; push @scanner_args, node_content_cb => sub { my ( $scanner, $data_ref, $node, @element ) = @_; my $loc = $node->location; $logger->debug("TreeSearcher: scanning node $loc"); foreach my $e (@element) { my $store = 0; map { $store = 1 if $need_search->{$_} and $node->get_help( $_ => $e ) =~ $reg } qw/description summary/; $store = 1 if $need_search->{element} and $e =~ $reg; $data_ref->( $loc ? $loc . ' ' . $e : $e ) if $store; $scanner->scan_element( $data_ref, $node, $e ); } }; my $scan = Config::Model::ObjTreeScanner->new( @scanner_args, ); # use hash to avoid duplication of path my @loc; my $store_sub = sub { my $p = shift; return if @loc and $loc[$#loc] eq $p; $logger->debug("TreeSearcher: storing location '$p'"); push @loc, $p; }; $scan->scan_node( $store_sub, $self->node ); return @loc; } __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Search tree for match in value, description... __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::TreeSearcher - Search tree for match in value, description... =head1 VERSION version 2.082 =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 ; my $step = 'baz:fr=bonjour baz:hr="dobar dan" foo="journalled"'; $root->load( step => $step ) ; my @result = $root->tree_searcher(type => 'value')->search('jour'); print join("\n",@result),"\n" ; # print # baz:fr # foo =head1 DESCRIPTION This class provides a way to search the content of a configuration tree. Given a keyword or a pattern, the search method will scan the tree to find a value, a description or anything that match the given pattern (or keyword). =head1 Constructor =head2 new (type => [ value | description ... ] ) Creates a new searcher object. The C parameter can be: =over =item element =item value =item key =item summary =item description =item help =item all Search in all the items above =back =head1 Methods =head2 search(keyword) Search the keyword or pattern in the tree. The search is done in a case insensitive manner. Returns a list of path pointing to the matching tree element. See L for details on the path syntax. =head1 BUGS Creating a class with just one search method may be overkill. OTOH, it may be extended later to provide iterative search. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Json.pm100644001750001750 1157312676543661 20774 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Backend# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::Json; $Config::Model::Backend::Json::VERSION = '2.082'; 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 suffix { return '.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' # io_handle => $io # IO::File object # check => yes|no|skip return 0 unless defined $args{io_handle}; # no file to read # load Json file my $json = join( '', $args{io_handle}->getlines ); # 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' # io_handle => $io # IO::File object # check => yes|no|skip croak "Undefined file handle to write" unless defined $args{io_handle}; my $perl_data = $self->{node}->dump_as_data( full_dump => $args{full_dump} ); my $json = to_json( $perl_data, { pretty => 1 } ); $args{io_handle}->print($json); return 1; } 1; # ABSTRACT: Read and write config as a JSON data structure __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::Json - Read and write config as a JSON data structure =head1 VERSION version 2.082 =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', }, }, ], read_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 $step = 'foo=yada bar="bla bla" baz:en=hello baz:fr=bonjour baz:hr="dobar dan"'; $root->load( step => $step ) ; $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 will contain C<'a','b'>. =head1 CONSTRUCTOR =head2 new ( node => $node_obj, name => 'Json' ) ; Inherited from L. The constructor will be called by L. =head2 read ( io_handle => ... ) 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 this case, C will return 0. When a file is read, C will return 1. =head2 write ( io_handle => ... ) Of all parameters passed to this write call-back, only C is used. This parameter must be L object already opened for write. C will return 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Yaml.pm100644001750001750 1422212676543661 20757 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Backend# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::Yaml; $Config::Model::Backend::Yaml::VERSION = '2.082'; 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 YAML::Any; my $logger = get_logger("Backend::Yaml"); sub suffix { return '.yml'; } sub single_element { my $self = shift; my @elts = $self->node->children; return undef if @elts != 1; my $obj = $self->node->fetch_element($elts[0]); my $type = $obj->get_type; return $type =~ /^(list|hash)$/ ? $obj : undef ; } 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' # io_handle => $io # IO::File object # check => yes|no|skip return 0 unless defined $args{io_handle}; # no file to read # load yaml file my $yaml = join( '', $args{io_handle}->getlines ); # convert to perl data my $perl_data = Load $yaml ; if ( not defined $perl_data ) { $logger->warn("No data found in YAML file $args{file_path}"); return 1; } my $target = $self->single_element // $self->node ; # load perl data in tree $target->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' # io_handle => $io # IO::File object # check => yes|no|skip croak "Undefined file handle to write" unless defined $args{io_handle}; my $target = $self->single_element // $self->node ; my $perl_data = $target->dump_as_data( full_dump => $args{full_dump} // 0); my $size = ref($perl_data) eq 'HASH' ? scalar keys %$perl_data : ref($perl_data) eq 'ARRAY' ? scalar @$perl_data : $perl_data ; return 2 unless $size ; my $yaml = Dump $perl_data ; $args{io_handle}->print($yaml); return 1; } 1; # ABSTRACT: Read and write config as a YAML data structure __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::Yaml - Read and write config as a YAML data structure =head1 VERSION version 2.082 =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', }, }, ], read_config => [ { backend => 'yaml' , config_dir => '/tmp', file => 'foo.yml', auto_create => 1, } ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; my $step = 'foo=yada bar="bla bla" baz:en=hello baz:fr=bonjour baz:hr="dobar dan"'; $root->load( step => $step ) ; $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 YAML 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 will contain C<'a','b'>. =item * YAML file is not created (and may be deleted) when no data is to be written. =back =head2 Class with only one hash element If the root node contains a single hash or list element, only the content of this hash will be written in YAML file. For example, if a class contains: element => [ baz => { type => 'hash', index_type => 'string' , cargo => { type => 'leaf', value_type => 'string', }, }, If the configuration is loaded with: $root->load("baz:one=un baz:two=deux") Then the written YAML file will B show C: --- one: un two: deux Likewise, a YAML file for a class with a single list C element would be written with: --- - un - deux =head1 CONSTRUCTOR =head2 new ( node => $node_obj, name => 'yaml' ) ; Inherited from L. The constructor will be called by L. =head2 read ( io_handle => ... ) 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 this case, C will return 0. When a file is read, C will return 1. =head2 write ( io_handle => ... ) Of all parameters passed to this write call-back, only C is used. This parameter must be L object already opened for write. C will return 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut models000755001750001750 012676543661 17272 5ustar00domidomi000000000000Config-Model-2.082/lib/Config/ModelFstab.pl100644001750001750 242712676543661 21033 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'class_description' => 'static information about the filesystems. fstab contains descriptive information about the various file systems. ', 'read_config' => [ { 'file' => 'fstab', 'backend' => 'Fstab', 'config_dir' => '/etc' } ], 'name' => 'Fstab', 'copyright' => [ '2010,2011 Dominique Dumont' ], 'author' => [ 'Dominique Dumont' ], 'license' => 'LGPL2', 'element' => [ 'fs', { 'cargo' => { 'type' => 'node', 'config_class_name' => 'Fstab::FsLine' }, 'summary' => 'specification of one file system', 'type' => 'hash', 'description' => 'Each "fs" element contain the information about one filesystem. Each filesystem is referred in this model by a label constructed by the fstab parser. This label cannot be stored in the fstab file, so if you create a new file system, the label you will choose may not be stored and will be re-created by the fstab parser', 'index_type' => 'string' } ] } ] ; popcon100644001750001750 1712676543661 21074 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/system.dmodel = PopCon backend_ini_with_section_map.t100644001750001750 1453012676543661 21451 0ustar00domidomi000000000000Config-Model-2.082/t# -*- cperl -*- use ExtUtils::testlib; use Test::More; use Test::Memory::Cycle; use Config::Model; use File::Path; use File::Copy; use Data::Dumper; use Log::Log4perl qw(:easy); use Test::Differences; use Test::File::Contents; use warnings; no warnings qw(once); use strict; my $arg = shift || ''; my $trace = $arg =~ /t/ ? 1 : 0; my $log = $arg =~ /l/ ? 1 : 0; my $home = $ENV{HOME} || ""; my $log4perl_user_conf_file = "$home/.log4config-model"; if ( $log and -e $log4perl_user_conf_file ) { Log::Log4perl::init($log4perl_user_conf_file); } else { Log::Log4perl->easy_init( $log ? $WARN : $ERROR ); } Config::Model::Exception::Any->Trace(1) if $arg =~ /e/; ok( 1, "compiled" ); # pseudo root where config files are written by config-model my $wr_root = 'wr_root/'; my $head = << 'EOH'; ## This file was written by cme command. ## You can run 'cme edit ' to modify this file. ## Run 'cme list' to get the list of applications available on your system ## You may also modify the content of this file with your favorite editor. EOH my @below_data = split /\n/, << 'EOD2' ; [Low] foo=bar [Section1] source=1 [Section2] source=2 packages=g++-4.2-arm-linux-gnu linux-libc-dev-arm-cross [Empty] EOD2 my $w_file_below = join( "\n", $head, '', map { lc } @below_data[ 3 .. 9, 0 .. 2 ] ); # set_up data my @general_data = split /\n/, << 'EOD1' ; [General] foo=bar [Section1] source=1 [Section2] source=2 packages=g++-4.2-arm-linux-gnu linux-libc-dev-arm-cross [Empty] EOD1 my $w_file_general = join( "\n", $head, map { lc } @general_data[ 0 .. 9 ] ); # change delimiter comments my %test_setup = ( SectionMapTop => [ \@general_data, 'general', $w_file_general ], SectionMap => [ \@below_data, 'below', $w_file_below ], ); my $model = Config::Model->new(); $model->create_config_class( 'name' => 'Section', 'element' => [ 'source', { 'value_type' => 'uniline', 'type' => 'leaf' }, 'packages', { 'cargo' => { 'value_type' => 'uniline', 'type' => 'leaf' }, 'type' => 'list' }, ], ); $model->create_config_class( 'name' => 'Below', 'element' => [ foo => { qw/type leaf value_type uniline/, }, ], ); $model->create_config_class( name => 'SectionMapTop', 'read_config' => [ { 'section_map' => { 'general' => '!' }, 'backend' => 'ini_file', 'split_list_value' => '\\s+', 'join_list_value' => ' ', 'store_class_in_hash' => 'sections', force_lc_section => 1, } ], element => [ 'sections', { 'cargo' => { 'type' => 'node', 'config_class_name' => 'Section' }, 'type' => 'hash', 'index_type' => 'string' }, foo => { qw/type leaf value_type uniline/, }, ] ); $model->create_config_class( name => 'SectionMap', 'read_config' => [ { 'section_map' => { 'low' => 'below' }, 'backend' => 'ini_file', 'split_list_value' => '\\s+', 'join_list_value' => ' ', 'store_class_in_hash' => 'sections', force_lc_section => 1, } ], element => [ 'sections', { 'cargo' => { 'type' => 'node', 'config_class_name' => 'Section' }, 'type' => 'hash', 'index_type' => 'string' }, below => { qw/type node config_class_name Below/, }, foo => { qw/type leaf value_type uniline/, }, ] ); # cleanup before tests rmtree($wr_root); foreach my $test_class ( sort keys %test_setup ) { my @orig = @{ $test_setup{$test_class}[0] }; my $test_path = $test_setup{$test_class}[1]; my $written_file = $test_setup{$test_class}[2]; ok( 1, "Starting $test_class tests in $test_path dir" ); my $test1 = 'ini1'; my $wr_dir = "$wr_root/$test_path/$test1"; my $conf_file = "/etc/test.ini"; my $abs_conf_file = "$wr_dir$conf_file"; mkpath( $wr_dir . '/etc', { mode => 0755 } ) || die "can't mkpath: $!"; open( CONF, "> $abs_conf_file" ) || die "can't open $abs_conf_file: $!"; print CONF map { "$_\n" } @orig; close CONF; my $i_test = $model->instance( instance_name => $test_path, root_class_name => $test_class, root_dir => $wr_dir, config_file => $conf_file, ); ok( $i_test, "Created $test_class instance" ); my $i_root = $i_test->config_root; my $orig = $i_root->dump_tree; print $orig if $trace; is( $i_root->needs_save, 0, "check data does not need to be saved" ); is( $i_root->grab_value("sections:section2 packages:0"), "g++-4.2-arm-linux-gnu", "check auto-split 1/2" ); is( $i_root->grab_value("sections:section2 packages:1"), "linux-libc-dev-arm-cross", "check auto-split 2/2" ); # force write back $i_root->needs_save(1); $i_test->write_back( config_file => $conf_file ); ok( 1, "IniFile write back done" ); my $ini_file = $wr_dir . '/etc/test.ini'; ok( -e $ini_file, "check that config file $ini_file was written" ); file_contents_eq_or_diff $ini_file, $written_file, "check file $ini_file content"; # create another instance to read the IniFile that was just written my $wr_dir2 = "$wr_root/$test_path/ini2"; mkpath( $wr_dir2 . '/etc', { mode => 0755 } ) || die "can't mkpath: $!"; copy( $wr_dir . '/etc/test.ini', $wr_dir2 . '/etc/' ) or die "can't copy from test1 to test2: $!"; my $i2_test = $model->instance( instance_name => $test_path . '2', root_class_name => $test_class, root_dir => $wr_dir2, config_file => $conf_file, ); ok( $i2_test, "Created instance" ); my $i2_root = $i2_test->config_root; my $p2_dump = $i2_root->dump_tree; $i_root->load('sections~empty'); my $orig_fixed = $i_root->dump_tree; eq_or_diff( [ split /\n/, $p2_dump ], [ split /\n/, $orig_fixed ], "compare original data with 2nd instance data" ); } memory_cycle_ok($model); done_testing; ValueComputer.pm100644001750001750 7363312676543661 21334 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::ValueComputer; $Config::Model::ValueComputer::VERSION = '2.082'; use Mouse; use MouseX::StrictConstructor; # use Scalar::Util qw(weaken) ; use Carp; use Parse::RecDescent 1.90.0; use Data::Dumper (); use Log::Log4perl qw(get_logger :levels); use vars qw($compute_grammar $compute_parser); my $logger = get_logger("ValueComputer"); # allow_override is intercepted and handled by Value object has formula => ( is => 'ro', isa => 'Str', required => 1 ); has value_type => ( is => 'ro', isa => 'Str', required => 1 ); # value_object is mostly used for error messages has value_object => ( is => 'ro', isa => 'Config::Model::AnyThing', required => 1, weak_ref => 1 ); has variables => ( is => 'ro', isa => 'HashRef', default => sub { {} } ); has replace => ( is => 'ro', isa => 'HashRef', default => sub { {} } ); has [qw/use_eval allow_override use_as_upstream_default/] => ( is => 'ro', isa => 'Bool', default => 0 ); has allow_user_override => ( is => 'ro', isa => 'Bool', lazy => 1, builder => sub { my $self = shift; return $self->allow_override || $self->use_as_upstream_default; } ); has need_quote => ( is => 'ro', isa => 'Bool', builder => '_need_quote', lazy => 1 ); sub _need_quote { my $self = shift; my $need_quote = 0; $need_quote = 1 if $self->{use_eval} and $self->{value_type} !~ /(integer|number|boolean)/; return $need_quote; } has undef_is => ( is => 'ro', isa => 'Maybe[Str]' ); has undef_replacement => ( is => 'ro', isa => 'Maybe[Str]', builder => '_build_undef_replacement', lazy => 1 ); sub _build_undef_replacement { my $self = shift; my $sui = $self->undef_is; my $need_quote = $self->need_quote; return $need_quote && defined $sui && $sui eq "''" ? "''" : $need_quote && defined $sui ? "'$sui'" : defined $sui && $sui eq "''" ? '' : defined $sui ? $sui : undef; } sub BUILD { my $self = shift; # create parser if needed $compute_parser ||= Parse::RecDescent->new($compute_grammar); $logger->debug("called with formula: $self->{formula}"); # must make a first pass at computation to subsitute index and # element values. leaves $xxx outside of &index or &element untouched my $result_r = $compute_parser->pre_compute( $self->{formula}, 1, $self->{value_object}, $self->{variables}, $self->{replace}, 'yes', $self->need_quote, ); $logger->debug("pre_formula: $$result_r"); $self->{pre_formula} = $$result_r; } sub compute { my $self = shift; my %args = @_; my $check = $args{check} || 'yes'; my $pre_formula = $self->{pre_formula}; $logger->debug("called with pre_formula: $pre_formula"); my $variables = $self->compute_variables( check => $check ); die "internal error" unless defined $variables; my $result; my @parser_args = ( $self->{value_object}, $variables, $self->{replace}, $check, $self->{need_quote}, $self->undef_replacement ); if ( $self->{use_eval} or $self->{value_type} =~ /(integer|number|boolean)/ ) { $logger->debug("will use eval"); my $all_defined = 1; my @init; foreach my $key ( sort keys %$variables ) { # no need to get variable if not used in formula; next unless index( $pre_formula, $key ) > 0; my $vr = _value_from_object( $key, @parser_args ); my $v = $$vr; $v = $self->undef_replacement unless defined $v; $logger->debug( "compute: var $key -> ", ( defined $v ? $v : '' ) ); if ( defined $v ) { push @init, "my \$$key = $v ;\n"; } else { $all_defined = 0; } } if ($all_defined) { my $formula = join( '', @init ) . $pre_formula; $logger->debug("compute: evaluating '$formula'"); $result = eval $formula; if ($@) { Config::Model::Exception::Formula->throw( object => $self->{value_object}, error => "Eval of formula '$formula' failed:\n$@" . "Make sure that your element is indeed " . "'$self->{value_type}'" ); } } } else { $logger->debug("calling parser with compute on pre_formula $pre_formula"); my $formula_r = $compute_parser->compute( $pre_formula, 1, @parser_args ); $result = $$formula_r; #$result = $self->{computed_formula} = $formula; } $logger->debug( "compute result is '" . ( defined $result ? $result : '' ) . "'" ); return $result; } sub compute_info { my $self = shift; my %args = @_; my $check = $args{check} || 'yes'; $logger->debug("compute_info called with $self->{formula}"); my $orig_variables = $self->{variables}; my $variables = $self->compute_variables; my $str = "value is computed from '$self->{formula}'"; return $str unless defined $variables; #print Dumper $variables ; if (%$variables) { $str .= ", where "; foreach my $k ( sort keys %$variables ) { my $u_val = $variables->{$k}; if ( ref($u_val) ) { map { $str .= "\n\t\t'\$$k" . "{$_} is converted to '$orig_variables->{$k}{$_}'"; } sort keys %$u_val; } else { my $val; if ( defined $u_val ) { my $obj = eval { $self->{value_object}->grab($u_val) }; if ($@) { my $e = $@; my $msg = ref($e) ? $e->full_message : $e; Config::Model::Exception::Model->throw( object => $self, error => "Compute variable:\n" . $msg ); } $val = $obj->get_type eq 'node' ? '' : $obj->get_type eq 'hash' ? '' : $obj->get_type eq 'list' ? '' : $obj->fetch( check => $check ); } $str .= "\n\t\t'$k' from path '$orig_variables->{$k}' is "; $str .= defined $val ? "'$val'" : 'undef'; } } } #$str .= " (evaluated as '$self->{computed_formula}')" # if $self->{formula} ne $self->{computed_formula} ; return $str; } # internal. resolves variables that contains $foo or &bar # returns a hash of variable names -> variable path sub compute_variables { my $self = shift; my %args = @_; my $check = $args{check} || 'yes'; # a shallow copy should be enough as we don't allow # replace in replacement rules my %variables = %{ $self->{variables} }; $logger->debug( "called on variables '", join( "', '", sort keys %variables ), "'" ) if $logger->is_debug; # apply a compute on all variables until no $var is left my $var_left = scalar( keys %variables ) + 1; while ($var_left) { my $old_var_left = $var_left; foreach my $key ( keys %variables ) { my $value = $variables{$key}; # value may be undef next unless defined $value; #next if ref($value); # skip replacement rules $logger->debug("key '$key', value '$value', left $var_left"); next unless $value =~ /\$|&/; my $pre_res_r = $compute_parser->pre_compute( $value, 1, $self->{value_object}, \%variables, $self->{replace}, $check ); $logger->debug("key '$key', pre res '$$pre_res_r', left $var_left\n"); $variables{$key} = $$pre_res_r; $logger->debug( "variable after pre_compute: ", join( " ", keys %variables ) ) if $logger->is_debug; if ( $$pre_res_r =~ /\$/ ) { ; # variables needs to be evaluated my $res_ref = $compute_parser->compute( $$pre_res_r, 1, $self->{value_object}, \%variables, $self->{replace}, $check ); #return undef unless defined $res ; $variables{$key} = $$res_ref; $logger->debug( "variable after compute: ", join( " ", keys %variables ) ) if $logger->is_debug; } { no warnings "uninitialized"; $logger->debug("result $key -> '$variables{$key}' left '$var_left'"); } } my @var_left = grep { defined $variables{$_} && $variables{$_} =~ /[\$&]/ } sort keys %variables; $var_left = @var_left; Config::Model::Exception::Formula->throw( object => $self->{value_object}, error => "Can't resolve user variable: '" . join( "','", @var_left ) . "'" ) unless ( $var_left < $old_var_left ); } $logger->debug("done"); return \%variables; } sub _pre_replace { my ( $replace_h, $pre_value ) = @_; $logger->debug("value: _pre_replace called with value '$pre_value'"); my $result = exists $replace_h->{$pre_value} ? $replace_h->{$pre_value} : '$replace{' . $pre_value . '}'; return \$result; } sub _replace { my ( $replace_h, $value, $value_object, $variables, $replace, $check, $need_quote, $undef_is ) = @_; if ( $logger->is_debug ) { my $str = defined $value ? $value : ''; $logger->debug("value: _replace called with value '$str'"); } my $result; if ( defined $value and $value =~ /\$/ ) { # must keep original variable $result = '$replace{' . $value . '}'; } elsif ( defined $value ) { my $r = $replace_h->{$value}; $result = defined $r ? $r : $undef_is; } return \$result; } sub _function_on_object { my ( $up, $function, $return, $value_object, $variables_h, $replace_h, $check, $need_quote ) = @_; $logger->debug("handling &$function($up) "); # get now the object refered $up =~ s/-(\d+)/'- ' x $1/e; my $target = eval { $value_object->grab( step => $up, check => $check ) }; if ($@) { my $e = $@; my $msg = $e ? $e->full_message : ''; Config::Model::Exception::Model->throw( object => $value_object, error => "Compute function argument '$up':\n" . $msg ); } if ( $function eq 'element' ) { my $result = $target->element_name; Config::Model::Exception::Model->throw( object => $value_object, error => "'", $target->name, "' has no element name" ) unless defined $result; $return = \$result; } elsif ( $function eq 'index' ) { my $result = $target->index_value; Config::Model::Exception::Formula->throw( object => $value_object, error => "'", $target->name, "' has no index value" ) unless defined $result; $return = \$result; } else { Config::Model::Exception::Formula->throw( object => $value_object, error => "Unknown computation function &$function, " . "expected &element(...) or &index(...)" ); } # print "\&foo(...) result = ",$$return," \n"; # make sure that result of function is quoted (avoid bareword errors) $$return = '"' . $$return . '"' if $need_quote; $logger->debug("&$function(...) returns $$return"); return $return; } sub _function_alone { my ( $f_name, $return, $value_object, $variables_h, $replace_h, $check, $need_quote ) = @_; $logger->debug("_function_alone: handling $f_name"); my $method_name = $f_name eq 'element' ? 'element_name' : $f_name eq 'index' ? 'index_value' : $f_name eq 'location' ? 'location' : undef; Config::Model::Exception::Formula->throw( object => $value_object, error => "Unknown computation function &$f_name, " . "expected &element or &index" ) unless defined $method_name; my $result = $value_object->$method_name(); my $vt = $value_object->value_type; if ( $vt =~ /^integer|number|boolean$/ ) { $result = '"' . $result . '"'; } $return = \$result; Config::Model::Exception::Formula->throw( object => $value_object, error => "Missing $f_name attribute (method '$method_name' on " . ref($value_object) . ")\n" ) unless defined $result; return $return; } sub _compute { my ( $value_ref, $return, $value_object, $variables_h, $replace_h, $check, $need_quote, $undef_is ) = @_; my @values = map { $$_ } @{$value_ref}; if ( $logger->is_debug ) { my @display = map { defined $_ ? $_ : '' } @values; $logger->debug( "_compute called with values '", join( "','", @display ) ); } my $result = ''; # return undef if one value is undef foreach my $v (@values) { if ( defined $v or defined $undef_is ) { $result .= defined $v ? $v : $undef_is; } else { $result = undef; last; } } return \$result; } sub _value_from_object { my ( $name, $value_object, $variables_h, $replace_h, $check, $need_quote ) = @_; $logger->warn("Warning: No variable definition found for \$$name") unless exists $variables_h->{$name}; # $path can be a ref for test purpose, or can be undef if path is computed from another value my $path = $variables_h->{$name}; my $my_res; if ( $logger->is_debug ) { my $str = defined $path ? $path : ''; $logger->debug("replace \$$name with path $str..."); } if ( defined $path and $path =~ /[\$&]/ ) { $logger->trace("skip name $name path '$path'"); $my_res = "\$$name"; # restore name that contain '$var' } elsif ( defined $path ) { $logger->trace("fetching var object '$name' with '$path'"); $my_res = eval { $value_object->grab_value( step => $path, check => $check ); }; if ($@) { my $e = $@; my $msg = $e ? $e->full_message : ''; Config::Model::Exception::Model->throw( object => $value_object, error => "Compute argument '$name', error with '$path':\n" . $msg ); } $logger->trace( "fetched var object '$name' with '$path', result '", defined $my_res ? $my_res : 'undef', "'" ); } # my_res stays undef if $path if not defined # quote result if asked when calling compute my $quote = $need_quote || 0; if ($quote && $my_res) { $my_res =~ s/'/\\'/g; $my_res = "'$my_res'"; } return \$my_res; # So I can return undef ... or a ref to undef } $compute_grammar = << 'END_OF_GRAMMAR' ; { # This grammar is compatible with Parse::RecDescent < 1.90 or >= 1.90 use strict; use warnings ; } # computed value may return undef even if parsing is done right. To # avoid getting problems with Parse::RecDescent (where undef means # that the parsing did not match), we will always return a scalar # reference to the actual returned value # @arg is value_object, $variables_h, $replace_h, $check,$need_quote pre_compute: pre_value[@arg](s) { # print "pre-compute on @{$item[-1]}\n"; my $str = join ( '', map { $$_ } @{ $item[-1] } ) ; $return = \$str; } pre_value: '$replace' '{' /\s*/ pre_value[@arg] /\s*/ '}' { $return = Config::Model::ValueComputer::_pre_replace($arg[2], ${ $item{pre_value} } ) ; } | function '(' /\s*/ up /\s*/ ')' { $return = Config::Model::ValueComputer::_function_on_object($item{up},$item{function},$return,@arg ) ; } | '&' /\w+/ func_param(?) { $return = Config::Model::ValueComputer::_function_alone($item[3],$return,@arg ) ; } | /\$( |\d+|_|!|&|@|{\^[A-Z]+})/ { my $result = $item[-1] ; $return = \$result ; } | object { # print "pre_value handling \$foo\n"; my $object = $item{object}; my $result ="\$".$object ; $return = \$result ; } | /[^\$&]*/ { # print "pre_value copying '$item[-1]'\n"; my $result = $item[-1] ; $return = \$result ; } func_param: /\(\s*\)/ up: /-?\d*/ compute: value[@arg](s) { # if one value is undef, return undef; Config::Model::ValueComputer::_compute($item[-1],$return,@arg ) ; } value: '$replace' '{' /\s*/ value_to_replace[@arg] /\s*/ '}' { $return = Config::Model::ValueComputer::_replace($arg[2], ${ $item{value_to_replace} },@arg ) ; } | /\$(\d+|_)\b/ { my $result = $item[-1] ; $return = \$result ; } | object { $return = Config::Model::ValueComputer::_value_from_object($item{object},@arg ) ; 1; } | /[^\$]*/ { my $result = $item[-1] ; $return = \$result ; } value_to_replace: object { $return = Config::Model::ValueComputer::_value_from_object($item{object},@arg ) ; 1; } | /[\w\-\.+]*/ { my $result = $item[-1] ; $return = \$result ; } object: /\$/ /[a-zA-Z]\w*/ function: '&' /\w+/ END_OF_GRAMMAR __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Provides configuration value computation __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::ValueComputer - Provides configuration value computation =head1 VERSION version 2.082 =head1 SYNOPSIS use Config::Model; # define configuration tree object my $model = Config::Model->new; $model ->create_config_class ( name => "MyClass", element => [ [qw/av bv/] => {type => 'leaf', value_type => 'integer', }, compute_int => { type => 'leaf', value_type => 'integer', compute => { formula => '$a + $b', variables => { a => '- av', b => '- bv'} }, }, ], ) ; my $inst = $model->instance(root_class_name => 'MyClass' ); my $root = $inst->config_root ; # put data $root->load( step => 'av=33 bv=9' ); print "Computed value is ",$root->grab_value('compute_int'),"\n"; # Computed value is 42 =head1 DESCRIPTION This class provides a way to compute a configuration value. This computation uses a formula and some other configuration values from the configuration tree. The computed value can be overridden, in other words, the computed value can be used as a default value. =head1 Computed value declaration A computed value must be declared in a 'leaf' element. The leaf element must have a C argument pointing to a hash ref. This array ref contains: =over =item * A string formula that use variables and replace function. =item * A set of variable and their relative location in the tree (using the notation explained in L =item * An optional set of replace rules. =item * An optional parameter to force a Perl eval of a string. =back B: A variable must point to a valid location in the configuration tree. Even when C<&index()> or C<$replace{}> is used. After substitution of these functions, the string is used as a path (See L) starting from the computed value. Hence the path must begin with C to go back to root node, or C<-> to go up a level. =head2 Compute formula The first element of the C array ref must be a string that contains the computation algorithm (i.e. a formula for arithmetic computation for integer values or a string template for string values). This string or formula should contain variables (like C<$foo> or C<$bar>). Note that these variables are not interpolated by Perl. For instance: 'My cat has $nb legs' '$m * $c**2' This string or formula may also contain: =over =item * The index value of the current object : C<&index> or C<&index()>. =item * The index value of a parent object: C<&index(-)>. Ancestor index value can be retrieved with C<&index(-2)> or C<&index(-3)>. =item * The element name of the current object: C<&element> or C<&element()>. =item * The element name of a parent object: C<&element(-)>. Likewise, ancestor element name can be retrieved with C<&element(-2)> or C<&element(-3)>. =item * The full location (path) of the current object: C<&location> or C<&location()>. =back For instance, you could have this template string: 'my element is &element, my index is &index' . 'upper element is &element(-), upper index is &index(-)', If you need to perform more complex operations than substitution, like extraction with regular expressions, you can force an eval done by Perl with C<< use_eval => 1 >>. In this case, the result of the eval will be used as the computed value. For instance: # extract host from url compute => { formula => '$old =~ m!http://[\w\.]+(?::\d+)?(/.*)!; $1 ;', variables => { old => '- url' } , use_eval => 1 , }, # capitalize compute => { formula => 'uc($old)', variables => { old => '- small_caps' } , use_eval => 1 } =head2 Compute variables The following arguments will be a set of C<< key => value >> to define the variables used in the formula. The key is a variable name used in the computation string. The value is a string that will be used to get the correct Value object. In this numeric example, C default value is C: element => [ av => { type => 'leaf', value_type => 'integer' }, bv => { type => 'leaf', value_type => 'integer' }, result => { type => 'leaf', value_type => 'integer', compute => { formula => '$a + $b' , variables => { a => '- av', b => '- bv' }, } } In this string example, the default value of the C element is actually a string made of "C" and the value of the "C" element of the object located 2 nodes above: comp => { type => 'leaf', value_type => 'string', compute => { formula => '"macro is $m"' , variables => { m => '- - macro' } } } =head2 Compute replace Sometime, using the value of a tree leaf is not enough and you need to substitute a replacement for any value you can get. This replacement can be done using a hash like notation within the formula using the C<%replace> hash. For instance, if you want to display a summary of a config, you can do : compute_with_replace => { formula => '$replace{$who} is the $replace{$what} of $replace{$country}', variables => { who => '! who' , what => '! what' , country => '- country', }, replace => { chief => 'president', America => 'USA' }, =head2 Complex formula C<&index>, C<&element>, and replace can be combined. But the argument of C<&element> or C<&index> can only be a value object specification (I.e. something like 'C<- - foo>'), it cannot be a value replacement of another C<&element> or C<&index>. I.e. C<&element($foo)> is ok, but C<&element(&index($foo))> is not allowed. =head2 computed variable Compute variables can themselves be computed : compute => { formula => 'get_element is $replace{$s}, indirect value is \'$v\'', variables => { 's' => '! $where', where => '! where_is_element', v => '! $replace{$s}', } replace => { m_value_element => 'm_value', compute_element => 'compute' } } Be sure not to specify a loop when doing recursive computation. =head2 compute override In some case, a computed value must be interpreted as a default value and the user must be able to override this computed default value. In this case, you must use C<< allow_override => 1 >> with the compute parameter: computed_value_with_override => { type => 'leaf', value_type => 'string', compute => { formula => '"macro is $m"' , variables => { m => '- - macro' } , allow_override => 1, } } This computed default value will be written to the configuration file. This default value may be already known by the application so the computed value should B be written to the configuration file. The computed value is interesting because it cab be shown to the user. In this case, use the C parameter: compute_known_upstream => { type => 'leaf', value_type => 'string', compute => { formula => '"macro is $m"' , variables => { m => '- - macro' } , use_as_upstream_default => 1, } } C implies C. =head2 Undefined variables You may need to compute value where one of the variables (i.e. other configuration parameter) is undefined. By default, any formula will yield an undefined value if one variable is undefined. You may change this behavior with C parameter. Depending on your formula and whether C is true or not, you may specify a "fallback" value that will be used in your formula. The most useful will probably be: undef_is => "''", # for string values undef_is => 0 , # for integers, boolean values Example: Source => { value_type => 'string', mandatory => 1, migrate_from => { use_eval => 1, formula => '$old || $older ;', undef_is => "''", variables => { older => '- Original-Source-Location', old => '- Upstream-Source' } }, type => 'leaf', }, [qw/Upstream-Source Original-Source-Location/] => { value_type => 'string', status => 'deprecated', type => 'leaf' } =head1 Examples =head2 String substitution [qw/sav sbv/] => { type => 'leaf', value_type => 'string', }, compute_string => { type => 'leaf', value_type => 'string', compute => { formula => 'meet $a and $b', variables => { '- sav', b => '- sbv' } }, }, =head2 Computation with on-the-fly replacement compute_with_replace => { type => 'leaf', value_type => 'string', compute => { formula => '$replace{$who} is the $replace{$what} of $replace{$country}', variables => { who => '! who', what => '! what', country => '- country', }, replace => { chief => 'president', America => 'USA' }, }, }, =head2 Extract data from a value using a Perl regexp Extract the host name from an URL: url => { type => 'leaf', value_type => 'uniline' }, extract_host_from_url => { type => 'leaf', value_type => 'uniline', compute => { formula => '$old =~ m!http://([\w\.]+)!; $1 ;', variables => { old => '- url' }, use_eval => 1, }, }, =head2 simple copy hash example Copying a hash may not be useful, but the using C<&index()> in a variable can be. Here's an example where the hashes contain leaves. The model is set up so that the content of C is copied into C hash: copy_from => { 'type' => 'hash', 'index_type' => 'string', 'cargo' => { 'config_class_name' => 'From', 'type' => 'node' }, }, copy_to => { 'type' => 'hash', 'index_type' => 'string', 'cargo' => { 'type' => 'leaf', 'value_type' => 'uniline', 'compute' => { 'formula' => '$copied', 'variables' => { 'copied' => '- copy_from:&index()' } }, }, }, Hash copy is also possible when the hash contains node. Here's an example where the data to be copied is stored within a node. The main class has 2 hash elements: copy_from => { 'type' => 'hash', 'index_type' => 'string', 'cargo' => { 'config_class_name' => 'From', 'type' => 'node' }, }, copy_to => { 'type' => 'hash', 'index_type' => 'string', 'cargo' => { 'config_class_name' => 'To', 'type' => 'node' }, }, The Class to copy from is quite simple: 'name' => 'From', 'element' => [ name => { 'type' => 'leaf', 'value_type' => 'uniline', } ] Here the class to copy to: 'name' => 'To', 'element' => [ name => { 'type' => 'leaf', 'value_type' => 'uniline', 'compute' => { 'formula' => '$copied', 'variables' => { 'copied' => '! copy_from:&index(-) name' } }, } ] =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut SearchElement.pm100644001750001750 3540112676543661 21247 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::SearchElement; $Config::Model::SearchElement::VERSION = '2.082'; use Log::Log4perl qw(get_logger :levels); use Carp; use strict; use warnings; use Config::Model::Exception; my $logger = get_logger("Model::Searcher"); sub new { my $type = shift; my %args = @_; my $self = {}; foreach my $p (qw/model node/) { $self->{$p} = delete $args{$p} or croak "Searcher->new: Missing $p parameter"; } bless $self, $type; $self->{privilege} = $args{privilege} || 'master'; my $root_class = $self->{node}->config_class_name; $self->{data} = $self->_sniff_class( $root_class, $self->{privilege}, {} ); return $self; } # to verify the data structure returned by search_element, you can used # either Data::Dumper or Tk::ObjScanner (both are available on CPAN) sub _sniff_class { my ( $self, $class, $privilege, $found_ref ) = @_; my @lines; my %h; my $model = $self->{model}; my $c_model = $model->get_model($class); $logger->debug("sniffing config class $class"); croak "Recursive config class $class detected, aborting..." if defined $found_ref->{$class}; $found_ref->{$class} = 1; my @elements = $model->get_element_name( class => $class, ); foreach my $element (@elements) { my $element_model = $c_model->{element}{$element}; my $element_type = $element_model->{type}; my $cargo = $element_model->{cargo}; my $c_type = defined $cargo ? $cargo->{type} : ''; my $cfg_class_name = defined $cargo ? $cargo->{config_class_name} : $element_model->{config_class_name}; my %local_found = %$found_ref; if ( $element_type =~ /(warped_)?node/ or $c_type =~ /(warped_)?node/ ) { my $tmp = $element_type eq 'node' || $c_type eq 'node' ? $self->_sniff_class( $cfg_class_name, $privilege, \%local_found ) : $self->_sniff_warped_node( $element_model, $privilege, \%local_found ); # merge all tmp in %h map { $h{$_}{next_step}{$element} = $tmp->{$_}; } keys %$tmp; } else { $h{$element}{next_step}{$element} = ''; } } $logger->debug("done sniffing config class $class"); return \%h; } sub _sniff_warped_node { my ( $self, $element_model, $privilege, $found_ref ) = @_; my %warp_tmp; my $ref = $element_model->{rules}; my @rules = ref $ref eq 'HASH' ? %$ref : @$ref; for ( my $r_idx = 0 ; $r_idx < $#rules ; $r_idx += 2 ) { my $res = $rules[ $r_idx + 1 ]{config_class_name}; my $sub_class = ref $res ? $res->[0] : $res; # sniff all classes mentionned in warped node rules my %local_found = %$found_ref; my $tmp = $self->_sniff_class( $sub_class, $privilege, \%local_found ); # merge all tmp in %warp_tmp map { $warp_tmp{$_}{next_class}{$sub_class} = $tmp->{$_}; } keys %$tmp; } return \%warp_tmp; } sub get_searchable_elements { my $self = shift; sort keys %{ $self->{data} }; } sub prepare { my $self = shift; my %args = @_; foreach my $p (qw/element/) { $self->{$p} = delete $args{$p} or croak "Searcher->prepare: Missing $p parameter"; } $self->reset; # initialize the search engine unless ( defined $self->{search_tree} ) { my $searched = $self->{element}; my $root_class = $self->{node}->config_class_name; Config::Model::Exception::User->throw( message => "Searcher cannot find element '$searched' " . "from $root_class. Found only " . join( ' ', sort keys %{ $self->{data} } ) ); } return $self; } sub reset { my $self = shift; my $searched = $self->{element}; $self->{search_tree} = $self->{data}{$searched}; $self->{current}{object} = $self->{node}; $self->{current}{element_name} = 'Root'; $self->{current}{element_type} = 'node'; } sub searched { return shift->{element}; } sub next_step { my $self = shift; my $current_obj = $self->{current}{object}; my @result; if ( $current_obj->get_type =~ /list|hash/ ) { @result = $current_obj->fetch_all_indexes; } else { my $next_step = $self->{search_tree}{next_step}; @result = ref $next_step ? sort keys %$next_step : defined $next_step ? die "next_step error" : (); } #my $name = $self->{current}{element_name} ; #print "From $name, next_step is @result\n"; return wantarray ? @result : \@result; } sub next_choice { my $self = shift; my $result; while (1) { $result = $self->next_step; $logger->debug("next_choice: result is @$result"); return $result if scalar @$result != 1; $self->choose(@$result); } } # TBD if choice is an id, Node is a hash... sub choose { my $self = shift; my $choice = shift; #print "choose $choice from node\n"; my $obj = $self->{current}{object}; if ( $obj->get_type =~ /hash|list/ ) { $self->choose_from_id_element($choice); } else { $self->choose_from_node($choice); } } sub choose_from_id_element { my $self = shift; my $choice = shift; #print "choose $choice from id\n"; my $id_obj = $self->{current}{object}; my $class = $id_obj->config_class_name; # the following line may trigger an exception for warped out # elements my $next_node = $id_obj->fetch_with_id($choice); $self->{current}{object} = $next_node; return $next_node; } sub choose_from_node { my $self = shift; my $choice = shift; #print "choose $choice from node\n"; my $next = $self->{search_tree}{next_step}; my $node = $self->{current}{object}; my $node_class = $node->config_class_name; if ( ref($next) and not defined $next->{$choice} ) { Config::Model::Exception::User->throw( message => "Searcher: wrong choice '$choice' " . "from $node_class. expected " . join( ' ', sort keys %$next ) ); } # the following line may trigger an exception for warped out # elements my $next_node = $node->fetch_element($choice); # $next is a scalar for leaf element of a ref for node element if ( $next->{$choice} ) { my $data = $next->{$choice}; # gobble next_class for warped_node element if ( defined $data->{next_class} ) { my $chosen_class = $next_node->config_class_name; $data = $data->{next_class}{$chosen_class}; unless ( defined $data ) { Config::Model::Exception::User->throw( message => "Searcher: choice '$choice' " . "from $node_class leads to a warped out node: " . $next_node->warp_error ); } } $self->{search_tree} = $data; } else { $self->{search_tree} = { next_step => undef }; $next_node = $node->fetch_element($choice); } $self->{current}{object} = $next_node; $self->{current}{element_type} = $node->element_type($choice); $self->{current}{element_name} = $choice; return $next_node; } sub current_object { my $self = shift; return $self->{current}{object}; } sub auto_choose { my $self = shift; my $elt_cb = shift || croak "auto_choose: missing element call back"; my $id_cb = shift || croak "auto_choose: missing id call back"; my $object = $self->{current}{object}; while (1) { my $next_step = $self->next_step; if ( scalar @$next_step == 0 ) { # found target return $self->{current}{object}; } my $next_choice = ( scalar @$next_step == 1 ) ? $next_step->[0] : $elt_cb->( $object, @$next_step ); $self->_auto_choose_elt( $next_choice, $id_cb ); } } sub _auto_choose_elt { my $self = shift; my $next_choice = shift; my $id_cb = shift; $self->choose($next_choice); my $elt_type = $self->{current}{element_type}; if ( $elt_type =~ /list|hash/ ) { my $object = $self->{current}{object}; my @choice = $object->fetch_all_indexes(); my $id = @choice == 1 ? $choice[0] : $id_cb->( $object, @choice ); $self->{current}{object} = $object->fetch_with_id($id); } } 1; # ABSTRACT: Search an element in a configuration model __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::SearchElement - Search an element in a configuration model =head1 VERSION version 2.082 =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 $step = 'foo=FOO hash_of_nodes:fr foo=bonjour - hash_of_nodes:en foo=hello '; $root->load( step => $step ); # create searcher for manual search my $searcher = $root->searcher(); # looking for foo element in the tree $searcher -> prepare (element => 'foo') ; my @next = $searcher->next_step() ; print "next possible steps: @next\n"; # next possible steps: foo hash_of_nodes # Looking for foo below hash_of_nodes $searcher->choose('hash_of_nodes') ; @next = $searcher->next_step() ; print "next possible steps: @next\n"; # next possible steps: en fr # Looking for foo below fr $searcher->choose('fr') ; @next = $searcher->next_step() ; print "next possible steps: @next\n"; # next possible steps: foo # last step $searcher->choose('foo') ; my $target = $searcher->current_object; print "Found '",$target->location,"'\n"; # Found 'hash_of_nodes:fr foo' # automatic search setup my $element_call_back = sub { return 'hash_of_nodes' ;} ; my $id_call_back = sub { return 'en' ;} ; $searcher->reset ; $target = $searcher->auto_choose($element_call_back, $id_call_back) ; print "Automatic search found '",$target->location,"'\n"; # Automatic search found 'hash_of_nodes:en foo' =head1 DESCRIPTION This modules provides a way to search for a configuration element in a configuration tree by exploring the configuration model. For instance, suppose that you have a xorg.conf model and you know that you need to tune the C parameter, but you don't remember where is this parameter in the configuration tree. This module will guide you through the tree to the(s) node(s) that contain this parameter. This class should be invaluable to construct interactive user interfaces. This module provides 2 search modes: =over =item * A manual search where you are guided step by step to the element you're looking for. At each step, the module will return you the possible paths to choose from. The user will have to choose the correct path from the available paths. Most of the time, only one possibility will be returned, so the user choice should be straightforward. In other case (more that one choice), the user will have to decide the next step. =item * An automatic search where you provide call-back that will resolve the ambiguities in case of multiple paths. =back =head1 CONSTRUCTOR The constructor should be used only by L. =head1 Methods =head2 get_searchable_elements Return the list of elements found in model that can be searched in the configuration tree. =head2 prepare(element => ...) Prepare the searcher to look for the element passed in the argument. Returns the searcher object (i.e. $self). =head2 reset Re-initialize the search engine to redo the search from start =head2 searched Returns the searched element name. =head1 Manual search =head2 next_step() Returns an array (or a ref depending on context) containing the next possible step to find the element you're looking for. The array ref can contain 1 or more elements. If the array ref is empty, you can get the target element with L. =head2 next_choice() Returns an array ref containing the next non-obvious choice to find the element you're looking for. If the array ref is empty, you can get the target element with L. =head2 choose( ) Tell the search engine your choice. The chosen element name must be one of the possibilities given by L. =head2 current_object() Returns the object where the search engine is. It can be a L, a L, a L, or a L. =head1 Automatic search =head2 auto_choose ( element_callback, id_call_back) Finds the searched element with minimal user interaction. C will be called when the search engine finds a node where more than one element can lead to the searched item. C will be called when the search engine finds a hash element or a list element which contain B or B elements. In this case the call-back will have return an id that will be used by the search engine to get the target element. Both call-back arguments will be: =over =item * The current object (as returned by L) =item * A list of possible choices =back For instances, your callback will be : my $id_cb = sub { my ($object,@choices) = @_ ; .... return $choice[1] ; } Both call-back are expected to return a scalar value that is either: =over =item * An element name =item * An id valid for the list or hash element returned by L. =back =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Fstab.pm100644001750001750 1452012676543661 21115 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Backend# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::Fstab; $Config::Model::Backend::Fstab::VERSION = '2.082'; use Mouse; use Carp; use Log::Log4perl qw(get_logger :levels); extends 'Config::Model::Backend::Any'; my $logger = get_logger("Backend::Fstab"); sub suffix { return ''; } 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' # io_handle => $io # IO::File object # check => yes|no|skip return 0 unless defined $args{io_handle}; # no file to read my $check = $args{check} || 'yes'; my @lines = $args{io_handle}->getlines; # 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->debug("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 = split /,/, $options; map { $_ = $opt_r_translate{$_} if defined $opt_r_translate{$_}; s/no(.*)/$1=0/; $_ .= '=1' unless /=/; } @options; $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' # io_handle => $io # IO::File object # check => yes|no|skip my $ioh = $args{io_handle}; my $node = $args{object}; croak "Undefined file handle to write" unless defined $ioh; $self->write_global_comment( $ioh, '#' ); # 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/ ), ); $self->write_data_and_comments( $ioh, '#', $d, $line_obj->annotation ); } 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__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::Fstab - Read and write config from fstab file =head1 VERSION version 2.082 =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 will be 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 ( node => $node_obj, name => 'fstab' ) ; Inherited from L. The constructor will be called by L. =head2 read ( io_handle => ... ) 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 this case, C will return 0. When a file is read, C will return 1. =head2 write ( io_handle => ... ) Of all parameters passed to this write call-back, only C is used. This parameter must be L object already opened for write. C will return 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Fstab.pod100644001750001750 210212676543661 21170 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models# PODNAME: Config::Model::models::Fstab # ABSTRACT: Configuration class Fstab =head1 NAME Config::Model::models::Fstab - Configuration class Fstab =head1 DESCRIPTION Configuration classes used by L static information about the filesystems. fstab contains descriptive information about the various file systems. =head1 Elements =head2 fs - specification of one file system Each "fs" element contain the information about one filesystem. Each filesystem is referred in this model by a label constructed by the fstab parser. This label cannot be stored in the fstab file, so if you create a new file system, the label you will choose may not be stored and will be re-created by the fstab parser. I<< Optional. Type hash of node of class L . >> =head1 SEE ALSO =over =item * L =item * L =back =head1 AUTHOR =over =item Dominique Dumont =back =head1 COPYRIGHT =over =item 2010,2011 Dominique Dumont =back =head1 LICENSE =over =item LGPL2 =back =cut PopCon.pl100644001750001750 755312676543661 21177 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'read_config' => [ { 'file' => 'popularity-contest.conf', 'backend' => 'ShellVar', 'config_dir' => '/etc' } ], 'name' => 'PopCon', 'copyright' => [ '2010,2011 Dominique Dumont' ], 'author' => [ 'Dominique Dumont' ], 'license' => 'LGPL2', 'element' => [ 'PARTICIPATE', { 'value_type' => 'boolean', 'upstream_default' => '0', 'type' => 'leaf', 'description' => 'If you don\'t want to participate in the contest, say "no" and we won\'t send messages.', 'write_as' => [ 'no', 'yes' ] }, 'ENCRYPT', { 'value_type' => 'enum', 'summary' => 'support for encrypted submissions', 'help' => { 'yes' => 'try to encrypt and fail if gpg is not available', 'maybe' => 'encrypt if gpg is available' }, 'upstream_default' => 'no', 'type' => 'leaf', 'description' => 'encrypt popcon submission. Eventually, this feature wil be enabled by default.', 'choice' => [ 'no', 'maybe', 'yes' ] }, 'MAILTO', { 'value_type' => 'uniline', 'summary' => 'survey e-mail', 'upstream_default' => 'survey@popcon.debian.org', 'type' => 'leaf', 'description' => 'Specifies the address to e-mail statistics to each week.' }, 'MAILFROM', { 'value_type' => 'uniline', 'summary' => 'forged sender email address', 'type' => 'leaf', '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.' }, 'SUBMITURLS', { 'value_type' => 'uniline', 'summary' => 'list of urls to submit data to', 'upstream_default' => 'http://popcon.debian.org/cgi-bin/popcon.cgi', 'type' => 'leaf', 'description' => 'Space separated list of where to submit popularity-contest reports using http.' }, 'USEHTTP', { 'value_type' => 'boolean', 'upstream_default' => '1', 'type' => 'leaf', 'description' => 'enables http reporting. Set this to \'yes\' to enable it.', 'write_as' => [ 'no', 'yes' ] }, 'HTTP_PROXY', { 'value_type' => 'uniline', 'type' => 'leaf', 'description' => 'Allows one to specify an HTTP proxy server, the syntax is "http://proxy:port". This overrides the environment variable http_proxy.' }, 'MY_HOSTID', { 'value_type' => 'uniline', 'type' => 'leaf', '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. ' }, 'DAY', { 'value_type' => 'integer', 'summary' => 'day of week', 'max' => '6', 'type' => 'leaf', 'description' => 'Only run on the given day, to spread the load on the server a bit. 0 is Sunday, 6 is Saturday. ' } ] } ] ; fstab-examples000755001750001750 012676543661 20716 5ustar00domidomi000000000000Config-Model-2.082/t/model_tests.dt0100644001750001750 216212676543661 21325 0ustar00domidomi000000000000Config-Model-2.082/t/model_tests.d/fstab-examples# /etc/fstab: static file system information. # # proc /proc proc defaults 0 0 # /dev/sda2 / ext3 errors=remount-ro 0 1 UUID=e255dac7-9cfb-42c8-ad1e-4dd1a8b962cb / ext3 errors=remount-ro 0 1 # /dev/sda4 /home ext3 defaults 0 2 UUID=18e71d5c-436a-4b88-aa16-308ebfa2eef8 /home ext3 defaults 1 2 # /dev/sda3 none swap sw 0 0 UUID=9988aeba-6937-4da3-8fd3-0fa696266137 none swap sw 0 0 gandalf:/home/ /mnt/gandalf-home nfs user,noauto,rw 0 2 gandalf:/mnt/video/ /mnt/video nfs user,noauto,rw 0 2 gandalf:/mnt/video3/ /mnt/video3 nfs user,noauto,rw 0 2 gandalf:/mnt/video4/ /mnt/video4 nfs user,noauto,rw 0 2 /dev /var/chroot/lenny-i386/dev none bind 0 2 /home /var/chroot/lenny-i386/home none bind 0 0 /tmp /var/chroot/lenny-i386/tmp none bind 1 0 /proc /var/chroot/lenny-i386/proc none bind 0 0 t1100644001750001750 322412676543661 21326 0ustar00domidomi000000000000Config-Model-2.082/t/model_tests.d/fstab-examples# /etc/fstab: static file system information. # # LABEL=root / ext3 defaults,relatime,errors=remount-ro 0 1 LABEL=home /home ext3 defaults,relatime 0 2 LABEL=video1 /mnt/video ext3 defaults,relatime 0 2 LABEL=video2 /mnt/video2 ext3 defaults,relatime 0 2 LABEL=video3 /mnt/video3 ext3 defaults,relatime 0 2 LABEL=video4 /mnt/video4 ext3 defaults,relatime 0 2 proc /proc proc defaults 0 0 # /dev/sdd2 none swap sw 0 0 UUID=5333e0e6-11d0-47a5-97af-44880a732e19 none swap sw 0 0 # 320GB usb disk (maxtor) LABEL=USB320 /mnt/usb-320gb ext3 rw,user,relatime,noauto 0 0 # 200GB Maxtor disk IEEE1394 through USB LABEL=Maxtor120 /mnt/maxtor120 ext3 rw,user,relatime,noauto 0 0 # 2To external disk (USB or e-sata) LABEL=ext-2To /mnt/ext-2To ext4 rw,user,relatime,noauto 0 0 # sysfs entry for powernowd (and others) #sysfs /sys sysfs defaults 0 0 # to enable usbmon debugfs /sys/kernel/debug debugfs defaults 0 2 /dev /var/chroot/testing-i386/dev none bind 0 0 /home /var/chroot/testing-i386/home none bind 0 0 /proc /var/chroot/testing-i386/proc none bind 0 0 /tmp /var/chroot/testing-i386/tmp none bind 0 0 ObjTreeScanner.pm100644001750001750 4677412676543661 21413 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::ObjTreeScanner; $Config::Model::ObjTreeScanner::VERSION = '2.082'; use strict; use Config::Model::Exception; use Scalar::Util qw/blessed/; use Carp::Assert::More; use Carp; use warnings; use Carp qw/croak confess cluck/; sub new { my $type = shift; my %args = @_; my $self = { auto_vivify => 1, check => 'yes' }; bless $self, $type; $self->{leaf_cb} = delete $args{leaf_cb} or croak __PACKAGE__, "->new: missing leaf_cb parameter"; # we may use leaf_cb $self->create_fallback( delete $args{fallback} || 'all' ); # get all call_backs my @value_cb = map { $_ . '_value_cb' } qw/boolean enum string uniline integer number reference/; foreach my $param ( qw/check node_element_cb hash_element_cb list_element_cb check_list_element_cb node_content_cb node_content_hook list_element_hook hash_element_hook auto_vivify up_cb/, @value_cb ) { $self->{$param} = $args{$param} if defined $args{$param}; delete $args{$param}; # may exists but be undefined croak __PACKAGE__, "->new: missing $param parameter" unless defined $self->{$param}; } if (delete $args{experience}) { carp "->new: experience parameter is deprecated"; } # this parameter is optional and does not need a fallback $self->{node_dispatch_cb} = delete $args{node_dispatch_cb} || {}; croak __PACKAGE__, "->new: node_dispatch_cb is not a hash ref" unless ref( $self->{node_dispatch_cb} ) eq 'HASH'; croak __PACKAGE__, "->new: unexpected check: $self->{check}" unless $self->{check} =~ /yes|no|skip/; croak __PACKAGE__, "->new: unexpected parameter: ", join( ' ', keys %args ) if scalar %args; return $self; } # internal sub create_fallback { my $self = shift; my $fallback = shift; map { $self->{$_} = sub { } } qw/node_content_hook hash_element_hook list_element_hook/; return if not defined $fallback or $fallback eq 'none'; my $done = 0; if ( $fallback eq 'node' or $fallback eq 'all' ) { $done++; my $node_content_cb = sub { my ( $scanner, $data_r, $node, @element ) = @_; map { $scanner->scan_element( $data_r, $node, $_ ) } @element; }; my $node_element_cb = sub { my ( $scanner, $data_r, $node, $element_name, $key, $next_node ) = @_; $scanner->scan_node( $data_r, $next_node ); }; my $hash_element_cb = sub { my ( $scanner, $data_r, $node, $element_name, @keys ) = @_; map { $scanner->scan_hash( $data_r, $node, $element_name, $_ ) } @keys; }; $self->{list_element_cb} = $hash_element_cb; $self->{hash_element_cb} = $hash_element_cb; $self->{node_element_cb} = $node_element_cb; $self->{node_content_cb} = $node_content_cb; $self->{up_cb} = sub { }; # do nothing } if ( $fallback eq 'leaf' or $fallback eq 'all' ) { $done++; my $l = $self->{string_value_cb} ||= $self->{leaf_cb}; $self->{check_list_element_cb} ||= $l; $self->{enum_value_cb} ||= $l; $self->{integer_value_cb} ||= $l; $self->{number_value_cb} ||= $l; $self->{boolean_value_cb} ||= $l; $self->{reference_value_cb} ||= $l; $self->{uniline_value_cb} ||= $l; } croak __PACKAGE__, "->new: Unexpected fallback value '$fallback'. ", "Expected 'node', 'leaf', 'all' or 'none'" if not $done; } sub scan_node { my ( $self, $data_r, $node ) = @_; #print "scan_node ",$node->name,"\n"; # get all elements according to catalog Config::Model::Exception::Internal->throw( error => "'$node' is not a Config::Model object" ) unless blessed($node) and $node->isa("Config::Model::AnyThing"); # skip exploration of warped out node if ( $node->isa('Config::Model::WarpedNode') ) { $node = $node->get_actual_node; return unless defined $node; } my $config_class = $node->config_class_name; my $node_dispatch_cb = $self->{node_dispatch_cb}{$config_class}; my $actual_cb = $node_dispatch_cb || $self->{node_content_cb}; my @element_list = $node->get_element_name( check => $self->{check} ); $self->{node_content_hook}->( $self, $data_r, $node, @element_list ); # we could add here a "last element" call-back, but it's not # very useful if the last element is a hash. $actual_cb->( $self, $data_r, $node, @element_list ); $self->{up_cb}->( $self, $data_r, $node ); } sub scan_element { my ( $self, $data_r, $node, $element_name ) = @_; my $element_type = $node->element_type($element_name); my $autov = $self->{auto_vivify}; #print "scan_element $element_name "; if ( $element_type eq 'hash' ) { #print "type hash\n"; my @keys = $self->get_keys( $node, $element_name ); # if hash element grab keys and perform callback $self->{hash_element_hook}->( $self, $data_r, $node, $element_name, @keys ); $self->{hash_element_cb}->( $self, $data_r, $node, $element_name, @keys ); } elsif ( $element_type eq 'list' ) { #print "type list\n"; my @keys = $self->get_keys( $node, $element_name ); $self->{list_element_hook}->( $self, $data_r, $node, $element_name, @keys ); $self->{list_element_cb}->( $self, $data_r, $node, $element_name, @keys ); } elsif ( $element_type eq 'check_list' ) { #print "type list\n"; my $cl_elt = $node->fetch_element( name => $element_name, check => $self->{check} ); $self->{check_list_element_cb}->( $self, $data_r, $node, $element_name, undef, $cl_elt ); } elsif ( $element_type eq 'node' ) { #print "type object\n"; # avoid auto-vivification my $next_obj = ( $autov or $node->is_element_defined($element_name) ) ? $node->fetch_element( name => $element_name, check => $self->{check} ) : undef; # if obj element, cb $self->{node_element_cb}->( $self, $data_r, $node, $element_name, undef, $next_obj ); } elsif ( $element_type eq 'warped_node' ) { #print "type warped\n"; my $next_obj = ( $autov or $node->is_element_defined($element_name) ) ? $node->fetch_element( name => $element_name, check => $self->{check} ) : undef; $self->{node_element_cb}->( $self, $data_r, $node, $element_name, undef, $next_obj ); } elsif ( $element_type eq 'leaf' ) { my $next_obj = $node->fetch_element( name => $element_name, check => $self->{check} ); my $type = $next_obj->value_type; return unless $type; my $cb_name = $type . '_value_cb'; my $cb = $self->{$cb_name}; croak "scan_element: No call_back specified for '$cb_name'" unless defined $cb; $cb->( $self, $data_r, $node, $element_name, undef, $next_obj ); } else { croak "Unexpected element_type: $element_type"; } } sub scan_hash { my ( $self, $data_r, $node, $element_name, $key ) = @_; assert_like( $node->element_type($element_name), qr/(hash|list)/ ); #print "scan_hash ",$node->name," element $element_name key $key "; my $item = $node->fetch_element( name => $element_name, check => $self->{check} ); my $cargo_type = $item->cargo_type($element_name); my $next_obj = $item->fetch_with_id( index => $key, check => $self->{check} ); if ( $cargo_type =~ /node$/ ) { #print "type object or warped\n"; $self->{node_element_cb}->( $self, $data_r, $node, $element_name, $key, $next_obj ); } elsif ( $cargo_type eq 'leaf' ) { my $cb_name = $next_obj->value_type . '_value_cb'; my $cb = $self->{$cb_name}; croak "scan_hash: No call_back specified for '$cb_name'" unless defined $cb; $cb->( $self, $data_r, $node, $element_name, $key, $next_obj ); } else { croak "Unexpected cargo_type: $cargo_type"; } } sub scan_list { goto &scan_hash; } sub get_keys { my ( $self, $node, $element_name ) = @_; my $element_type = $node->element_type($element_name); my $item = $node->fetch_element( name => $element_name, check => $self->{check} ); return $item->fetch_all_indexes if $element_type eq 'hash' || $element_type eq 'list'; Config::Model::Exception::Internal->throw( error => "called get_keys on non hash or non list" . " element $element_name", object => $node ); } 1; # ABSTRACT: Scan config tree and perform call-backs for each element or node __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::ObjTreeScanner - Scan config tree and perform call-backs for each element or node =head1 VERSION version 2.082 =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 $step = 'baz:fr=bonjour baz:hr="dobar dan"'; $root->load( step => $step ) ; # define leaf call back my $disp_leaf = sub { my ($scanner, $data_ref, $node,$element_name,$index, $leaf_object) = @_ ; $$data_ref .= "disp_leaf called for '". $leaf_object->name. "' value '".$leaf_object->fetch."'\n"; } ; # simple scanner, (print all values) my $scan = Config::Model::ObjTreeScanner-> new ( leaf_cb => $disp_leaf, # only mandatory parameter ) ; my $result = ''; $scan->scan_node(\$result, $root) ; print $result ; =head1 DESCRIPTION This module creates an object that will explore (depth first) a configuration tree. For each part of the configuration tree, ObjTreeScanner object will call one of the subroutine reference passed during construction. (a call-back or a hook) Call-back and hook routines will be called: =over =item * For each node containing elements (including root node) =item * For each element of a node. This element can be a list, hash, node or simple leaf element. =item * For each item contained in a node, hash or list. This item can be a simple leaf or another node. =back To continue the exploration, these call-backs must also call the scanner. (i.e. perform another call-back). In other words the user's subroutine and the scanner play a game of ping-pong until the tree is completely explored. Hooks routines are not required to resume the exploration, i.e. to call the scanner. This will be done after the hook routine has returned. The scanner provides a set of default callback for the nodes. This way, the user only have to provide call-backs for the leaves. The scan is started with a call to C. The first parameter of scan_node is a ref that is passed untouched to all call-back. This ref may be used to store whatever result you want. =head1 CONSTRUCTOR =head2 new ( ... ) One way or another, the ObjTreeScanner object must be able to find all callback for all the items of the tree. All the possible call-back and hooks are listed below: =over =item leaf callback: C is a catch-all generic callback. All other are specialized call-back : C, C, C, C, C, C, C =item node callback: C , C =item node hooks: C =item element callback: All these call-backs are called on the elements of a node: C, C, C, C, C. =item element hooks: C, C. =back The user may specify all of them by passing a sub ref to the constructor: $scan = Config::Model::ObjTreeScanner-> new ( list_element_cb => sub { ... }, ... ) Or use some default callback using the fallback parameter. Note that at least one callback must be provided: C. Optional parameter: =over =item fallback If set to C, the scanner will provide default call-back for node items. If set to C, the scanner will set all leaf callback (like enum_value_cb ...) to string_value_cb or to the mandatory leaf_cb value. "fallback" callback will not override callbacks provided by the user. If set to C , the scanner provides fallbacks for leaf and node. By default, all fallback are provided. =item auto_vivify Whether to create configuration objects while scanning (default is 1). =item check C, C or C. =back =head1 Callback prototypes =head2 Leaf callback C is called for each leaf of the tree. The leaf callback will be called with the following parameters: ($scanner, $data_ref,$node,$element_name,$index, $leaf_object) where: =over =item * C<$scanner> is the scanner object. =item * C<$data_ref> is a reference that is first passed to the first call of the scanner. Then C<$data_ref> is relayed through the various call-backs =item * C<$node> is the node that contain the leaf. =item * C<$element_name> is the element (or attribute) that contain the leaf. =item * C<$index> is the index (or hash key) used to get the leaf. This may be undefined if the element type is scalar. =item * C<$leaf_object> is a L object. =back =head2 List element callback C is called on all list element of a node, i.e. call on the list object itself and not in the elements contained in the list. ($scanner, $data_ref,$node,$element_name,@indexes) C<@indexes> is a list containing all the indexes of the list. Example: sub my_list_element_cb { my ($scanner, $data_ref,$node,$element_name,@idx) = @_ ; # custom code using $data_ref # resume exploration (if needed) map {$scanner->scan_list($data_ref,$node,$element_name,$_)} @idx ; # note: scan_list and scan_hash are equivalent } =head2 List element hook C: Works like the list element callback. Except that the calls to C are not required. This will be done once the hook returns. =head2 Check list element callback C: Like C, but called on a check_list element. ($scanner, $data_ref,$node,$element_name,@check_items) C<@check_items> is a list containing all the items of the check_list. =head2 Hash element callback C: Like C, but called on a hash element. ($scanner, $data_ref,$node,$element_name,@keys) C<@keys> is an list containing all the keys of the hash. Example: sub my_hash_element_cb { my ($scanner, $data_ref,$node,$element_name,@keys) = @_ ; # custom code using $data_ref # resume exploration map {$scanner->scan_hash($data_ref,$node,$element_name,$_)} @keys ; } =head2 Hash element hook C: Works like the hash element callback. Except that the calls to C are not required. This will be done once the hook returns. =head2 Node content callback C: This call-back is called foreach node (including root node). ($scanner, $data_ref,$node,@element_list) C<@element_list> contains all the element names of the node. Example: sub my_content_cb { my ($scanner, $data_ref,$node,@element) = @_ ; # custom code using $data_ref # resume exploration map {$scanner->scan_element($data_ref, $node,$_)} @element ; } =head2 Node content hook C: This hook is called foreach node (including root node). Works like the node content call-back. Except that the calls to C are not required. This will be done once the hook returns. =head2 Dispatch node callback C: Any callback specified in the hash will be called for each instance of the specified configuration class. (this may include the root node). For instance, if you have: node_dispach_cb => { ClassA => \&my_class_a_dispatch_cb, ClassB => \&my_class_b_dispatch_cb, } C<&my_class_a_dispatch_cb> will be called for each instance of C and C<&my_class_b_dispatch_cb> will be called for each instance of C. They will be called with the following parameters: ($scanner, $data_ref,$node,@element_list) C<@element_list> contains all the element names of the node. Example: sub my_class_a_dispatch_cb = { my ($scanner, $data_ref,$node,@element) = @_ ; # custom code using $data_ref # resume exploration map {$scanner->scan_element($data_ref, $node,$_)} @element ; } =head2 Node element callback C is called for each node contained within a node (i.e not with root node). This node can be held by a plain element or a hash element or a list element: ($scanner, $data_ref,$node,$element_name,$key, $contained_node) C<$key> may be undef if C<$contained_node> is not a part of a hash or a list. C<$element_name> and C<$key> specifies the element name and key of the the contained node you want to scan. (passed with C<$contained_node>) Note that C<$contained_node> may be undef if C is 0. Example: sub my_node_element_cb { my ($scanner, $data_ref,$node,$element_name,$key, $contained_node) = @_; # your custom code using $data_ref # explore next node $scanner->scan_node($data_ref,$contained_node); } =head1 METHODS =head2 scan_node ($data_r,$node) Explore the node and call either C (if the node class name matches the dispatch_node hash) B (e.g. xor) C passing all element names. After the first callback has returned, C will be called. =head2 scan_element($data_r,$node,$element_name) Explore the element and call either C, C, C or a leaf call-back (the leaf call-back called depends on the Value object properties: enum, string, integer and so on) =head2 scan_hash ($data_r,$node,$element_name,$key) Explore the hash member (or hash value) and call either C or a leaf call-back. =head2 scan_list ($data_r,$node,$element_name,$index) Just like C: Explore the list member and call either C or a leaf call-back. =head2 get_keys ($node, $element_name) Returns an list containing the sorted keys of a hash element or returns an list containing (0.. last_index) of an list element. Throws an exception if element is not an list or a hash element. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L,L,L, L, L, L, L =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut PopCon.pod100644001750001750 536712676543661 21347 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models# PODNAME: Config::Model::models::PopCon # ABSTRACT: Configuration class PopCon =head1 NAME Config::Model::models::PopCon - Configuration class PopCon =head1 DESCRIPTION Configuration classes used by L =head1 Elements =head2 PARTICIPATE If you don't want to participate in the contest, say "no" and we won't send messages.I<< Optional. Type boolean. upstream_default: '0'. >> =head2 ENCRYPT - support for encrypted submissions encrypt popcon submission. Eventually, this feature wil be enabled by default.I<< Optional. Type enum. choice: 'no', 'maybe', 'yes'. upstream_default: 'no'. >> Here are some explanations on the possible values: =over =item 'maybe' encrypt if gpg is available =item 'yes' try to encrypt and fail if gpg is not available =back =head2 MAILTO - survey e-mail Specifies the address to e-mail statistics to each week.I<< Optional. Type uniline. upstream_default: 'survey@popcon.debian.org'. >> =head2 MAILFROM - forged sender email address 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.I<< Optional. Type uniline. >> =head2 SUBMITURLS - list of urls to submit data to Space separated list of where to submit popularity-contest reports using http.I<< Optional. Type uniline. upstream_default: 'http://popcon.debian.org/cgi-bin/popcon.cgi'. >> =head2 USEHTTP enables http reporting. Set this to 'yes' to enable it.I<< Optional. Type boolean. upstream_default: '1'. >> =head2 HTTP_PROXY Allows one to specify an HTTP proxy server, the syntax is "http://proxy:port". This overrides the environment variable http_proxy.I<< Optional. Type uniline. >> =head2 MY_HOSTID 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. I<< Optional. Type uniline. >> =head2 DAY - day of week Only run on the given day, to spread the load on the server a bit. 0 is Sunday, 6 is Saturday. I<< Optional. Type integer. >> =head1 SEE ALSO =over =item * L =back =head1 AUTHOR =over =item Dominique Dumont =back =head1 COPYRIGHT =over =item 2010,2011 Dominique Dumont =back =head1 LICENSE =over =item LGPL2 =back =cut model_tests.d000755001750001750 012676543661 16003 5ustar00domidomi000000000000Config-Model-2.082/tlayer-test-conf.pl100644001750001750 273312676543661 21521 0ustar00domidomi000000000000Config-Model-2.082/t/model_tests.d# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use Config::Model::BackendMgr; # test loading layered config à la ssh_config $home_for_test = '/home/joe' ; Config::Model::BackendMgr::_set_test_home($home_for_test) ; $model->create_config_class( name => "LayeredClass", element => [ [qw/set_in_etc set_by_user set_in_both/] , { 'value_type' => 'uniline', 'type' => 'leaf', }, 'a_checklist' => { #'default_list' => [ qw/b c/ ], 'type' => 'check_list', 'choice' => [ 'a' .. 'g' ] }, ], 'read_config' => [ { 'backend' => 'perl_file', 'config_dir' => '~/foo', 'file' => 'config.pl', 'default_layer' => { 'config_dir' => '/etc', 'file' => 'foo-config.pl' } } ] ); $model_to_test = "LayeredClass" ; @tests = ( { # t0 name => 'mini', check => [ set_in_etc => {qw/mode layered value /, 'system value'}, set_in_both => {qw/mode layered value /, 'system value2'}, set_in_both => {qw/mode user value /, 'user value2'}, set_by_user => 'user value', a_checklist => {qw/mode layered value /,'c,e'}, a_checklist => 'f,g', a_checklist => {qw/mode user value /, 'c,f,g'}, ] }, ); 1; fstab-test-conf.pl100644001750001750 155712676543661 21507 0ustar00domidomi000000000000Config-Model-2.082/t/model_tests.d# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # $conf_file_name = "fstab" ; $conf_dir = "etc" ; $model_to_test = "Fstab" ; @tests = ( { # t0 check => { 'fs:/proc fs_spec', "proc" , 'fs:/proc fs_file', "/proc" , 'fs:/home fs_file', "/home", 'fs:/home fs_spec', "UUID=18e71d5c-436a-4b88-aa16-308ebfa2eef8", }, dump_errors => [ qr/value 2 > max limit 0/ => 'fs:"/var/chroot/lenny-i386/dev" fs_passno=0' , ], }, { #t1 check => { 'fs:root fs_spec', "LABEL=root" , 'fs:root fs_file', "/" , }, }, ); 1; popcon-examples000755001750001750 012676543661 21115 5ustar00domidomi000000000000Config-Model-2.082/t/model_tests.dt0100644001750001750 41712676543661 21505 0ustar00domidomi000000000000Config-Model-2.082/t/model_tests.d/popcon-examples# Config file for Debian's popularity-contest package. # # To change this file, use: # dpkg-reconfigure popularity-contest ## should be removed MY_HOSTID="aaaaaaaaaaaaaaaaaaaa" # we participate PARTICIPATE="yes" USEHTTP="yes" # always http ENCRYPT="yes" DAY="6" IniFile.pm100644001750001750 4713712676543661 21407 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Backend# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::IniFile; $Config::Model::Backend::IniFile::VERSION = '2.082'; 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/; my $logger = get_logger("Backend::IniFile"); sub suffix { return '.ini'; } sub annotation { return 1; } 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' # io_handle => $io # IO::File object # check => yes|no|skip return 0 unless defined $args{io_handle}; # 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 $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{io_handle}->getlines; # 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 =~ /\[(.*)\]/ ) { $section = $force_lc{section} ? lc($1) : $1; my $remap = $section_map->{$section} || ''; if ( $remap eq '!' ) { $section_ref = $ini_data; $comment_path = $section_path = ''; $logger->debug("step 1: found node [$section]"); } elsif ($remap) { $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*=\s*/, $vdata ); $name = lc($name) if $force_lc{key}; $val = lc($val) if $force_lc{value}; $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'; $item->annotation($v); } return 1; } sub load_data { my $self = shift; say "calling load_data on ". ref($self); $self->node->load_data(@_); } 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; } 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' # io_handle => $io # IO::File object # check => yes|no|skip my $ioh = $args{io_handle}; my $node = $args{object}; my $delimiter = $args{comment_delimiter} || '#'; croak "Undefined file handle to write" unless defined $ioh; $self->write_global_comment( $ioh, $delimiter ); # 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"); $self->write_data_and_comments( $ioh, $delimiter, "[$top_class_name]" ); } my $res = $self->_write(@_); $ioh->print($res); } sub _write_list{ my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $join_list = $args->{join_list_value}; my $delimiter = $args->{comment_delimiter} || '#'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; if ( $join_list ) { my @v = grep { length } $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( undef, $delimiter, "$elt=$v", $obj_note ); } } else { foreach my $item ( $obj->fetch_all('custom') ) { my $note = $item->annotation; my $v = $item->fetch; if ( length $v ) { $logger->debug("writing list elt $elt -> $v"); $res .= $self->write_data_and_comments( undef, $delimiter, "$elt=$v", $obj_note . $note ); } else { $logger->debug("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 $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( undef, $delimiter, "$elt=$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( undef, $delimiter, "$elt=$v", $obj_note ); } } return $res; } sub _write_leaf{ my ($self, $args, $node, $elt) = @_ ; my $res = ''; my $write_bool_as = $args->{write_boolean_as}; my $delimiter = $args->{comment_delimiter} || '#'; my $obj = $node->fetch_element($elt); my $obj_note = $obj->annotation; my $v = $obj->fetch; 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( undef, $delimiter, "$elt=$v", $obj_note ); } else { $logger->debug("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( undef, $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( undef, $delimiter, "[$c_name]", $obj_note ) . $subres; } return $res; } sub _write { my $self = shift; my %args = @_; my $node = $args{object}; my $delimiter = $args{comment_delimiter} || '#'; $logger->debug( "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->debug("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->debug("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->debug( "done on ", $node->name ); return $res; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config as a INI file __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::IniFile - Read and write config as a INI file =head1 VERSION version 2.082 =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' }, }, ], read_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 will contain: ## 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. if a list element contains C<('a',undef,'b')>, the data structure will contain C<'a','b'>. =head1 Comments This backend tries to read and write comments from configuration file. The comments are stored as annotation within the configuration tree. Bear in mind that comments extraction is based on best estimation as to which parameter the comment may apply. Wrong estimations are possible. =head1 CONSTRUCTOR =head2 new ( node => $node_obj, name => 'inifile' ) ; Inherited from L. The constructor will be called by L. =head1 Parameters Optional parameters declared in the model: =over =item comment_delimiter Change the character that starts comments in the INI file. Default is 'C<#>'. =item store_class_in_hash See L =item section_map Is a kind of exception of the above rule. See also L =item force_lc_section Boolean. When set, sections names are converted to lowercase. =item force_lc_key Idem for key name =item force_lc_value Idem for all values. =item 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. =item 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. =item 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. =item 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. =item 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']>. =back =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 will not use the same configuration class. The model will have 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 will have the same elements. For instance: foo = foo_v [ A ] bar = bar_v1 [ B ] bar = bar_v2 In this case, class C and class C will not use the same configuration class. The model will have 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: read_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: read_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: read_config => [ { backend => 'ini_file', store_class_in_hash => 'sections', section_map => { General => '!' }, } ], =head1 Methods =head2 read ( io_handle => ... ) 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 this case, C will return 0. When a file is read, C will return 1. =head2 write ( io_handle => ... ) Of all parameters passed to this write call-back, only C is used. This parameter must be L object already opened for write. C will return 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org); Krzysztof Tyszecki, (krzysztof.tyszecki at gmail dot com) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Role000755001750001750 012676543661 16710 5ustar00domidomi000000000000Config-Model-2.082/lib/Config/ModelWarpMaster.pm100644001750001750 1007712676543661 21520 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Role# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Role::WarpMaster; $Config::Model::Role::WarpMaster::VERSION = '2.082'; # ABSTRACT: register and trigger a warped element use Mouse::Role; use strict; use warnings; use Mouse::Util; use Log::Log4perl qw(get_logger :levels); use Scalar::Util qw/weaken/; my $logger = get_logger("Warper"); has 'warp_these_objects' => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef', default => sub { [] }, handles => { _slave_info => 'elements', _add_slave_info => 'push', _delete_slave => 'delete', has_warped_slaves => 'count', # find_slave_idx => 'first_index', not available in Mouse }, ); sub register { my ( $self, $warped, $warper_name ) = @_; my $w_name = $warped->name; $logger->debug( $self->get_type . ": " . $self->name, " registered $w_name ($warper_name)" ) if $logger->is_debug; # weaken only applies to the passed reference, and there's no way # to duplicate a weak ref. Only a strong ref is created. See # qw(weaken) module for weaken() my @tmp = ( $warped, $w_name, $warper_name ); weaken( $tmp[0] ); $self->_add_slave_info( \@tmp ); return defined $self->{compute} ? 'computed' : 'regular'; } sub unregister { my ( $self, $w_name ) = @_; $logger->debug( $self->get_type .": " . $self->name, " unregister $w_name" ) if $logger->is_debug; my $idx = 0; foreach my $info ($self->_slave_info) { last if $info->[0] eq $w_name ; $idx++; } $self->_delete_slave($idx); } # And I'm going to warp them ... sub trigger_warp { my $self = shift; my $value = shift; my $str_val = shift // $value // 'undefined'; foreach my $ref ( $self->_slave_info ) { my ( $warped, $w_name, $warp_index ) = @$ref; next unless defined $warped; # $warped is a weak ref and may vanish # pure warp of object if ($logger->is_debug) { $logger->debug("trigger_warp: ".$self->get_type." ", $self->name, " warps '$w_name' with value <$str_val> "); } $warped->trigger( $value, $warp_index ); } } sub get_warped_slaves { my $self = shift; # grep is used to clean up weak ref to object that were destroyed return grep { defined $_ } map { $_->[0] } $self->_slave_info; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Role::WarpMaster - register and trigger a warped element =head1 VERSION version 2.082 =head1 SYNOPSIS package Config::Model::Stuff; use Mouse; with Config::Model::Role::WarpMaster =head1 DESCRIPTION This role enable a configuration element to become a warp maser, i.e. a parameter whose value can change the features of the configuration tree (by controlling a warped_node) or the feature of various elements like leaf, hash ... =head1 METHODS =head2 register ( $warped_object, warper_name ) Register a new warped object. Called by an element which has a C parameter. This method is calling on the object pointed by C value. =head2 unregister ( warper_name ) Remove a warped object from the object controlled by this warp master. =head2 trigger_warp ( value, stringified_value ) Called by the object using this role when the value held by this object is changed (i.e. something like store was called). The passed value can be a plain scalar (from a value object) or a hash (from a check_list object). The stringified_value is a string shown in debug log. -head2 has_warped_slaves Return the number of object controlled by this master. =head2 get_warped_slaves Return a list of object controlled by this master. =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut NodeLoader.pm100644001750001750 343412676543661 21426 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Role# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Role::NodeLoader; $Config::Model::Role::NodeLoader::VERSION = '2.082'; # ABSTRACT: Load Node element in configuration tree use Mouse::Role; use strict; use warnings; use Mouse::Util; use Log::Log4perl qw(get_logger :levels); my $load_logger = get_logger("TreeLoad"); sub load_node { my ($self, %params) = @_ ; my $config_class_name = $params{config_class_name}; my $config_class = $self->config_model->get_model($config_class_name) ; my $node_class = $config_class->{class} || 'Config::Model::Node'; $load_logger->info("Loading $config_class_name ". $self->location . " with $node_class"); Mouse::Util::load_class($node_class); return $node_class->new(%params) ; } __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Role::NodeLoader - Load Node element in configuration tree =head1 VERSION version 2.082 =head1 SYNOPSIS $self->load_node( config_class_name => "...", %other_args); =head1 DESCRIPTION Role used to load a node element using L (default behavior). If the config class overrides the default implementation, ( C parameter ), the override class is loaded and used to create the node. =head1 METHODS =head2 load_node Creates a node object using all the named parameters passed to load_node. One of these parameter must be C =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut popcon-test-conf.pl100644001750001750 57112676543661 21661 0ustar00domidomi000000000000Config-Model-2.082/t/model_tests.d# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # $conf_file_name = "popularity-contest.conf" ; $conf_dir = "etc" ; $model_to_test = "PopCon" ; @tests = ( { # t0 check => { } }, ); 1; add-ext4-workshop.txt100644001750001750 676012676543661 22107 0ustar00domidomi000000000000Config-Model-2.082/examples/fstabPractical workshop for Config::Model ------------------------------------------- Objevtive of this workshop: - improve fstab model (MyFstab class) to support ext4 - open file fstab/MyFstab.pl with favorite text editor This file contains a Perl data structure which describes the MyFstab configuration class. Note that no backend are specified. Read and write are handled in test script (old demo) - open model graphical editor $ config-model-edit -model MyFstab - Open class Fs -> element -> fs -> type cargo -> config_class_name What do these parameters (type and cargo) mean? Which class is to be explored next to better understand the structure of /etc/fstab configuration? - explore next class (MyFstab::FsLine) MyFstab::FsLine -> element -> fs_vfstype -> type value_type choice What are there choices ? How are these choices connected with fstab(5) man page ? - In MyFstab::FsLine, what is the element representing the mount options ? - explore this element: note the type: what does this mean ? open follow item: f1 is a variable name. The value of this variable is extracted from the tree using the path shown. open rules: * formula ($f1 eq 'ext3') is a test condition related to ext3 * When this condition is satisfied, the parameters associated with this formula are applied. Look for applied parameter - create new MyFstab::Ext4FsOpt open class mentioned by the rule above with edit (or right-click) select ext3 class click on keep replace 3 by 4 click copy - open ext4 class -> element - open mkfs.ext4 man page * Note that ext4 features all ext3 and ext2 options * look for 'extended_options' in this man page. These are 3 integer and 2 booleans parameters - Arrange Ext4 to offer all ext3 options open MyFstab::Ext4Options -> include set include to MyFstab::Ext3FsOpt - create these elements: * open/edit Ext4options->element select journalling-mode click 'remove selected' type 'stride' in entry click add, repeat for other elements * open/edit stride In type drop-down box, select 'leaf' in value_type box, select integer cut'n'paste description from man page, paste on 'description' item in tree, in right part of window, click edit , cleanup, store (in tree) * open/edit Ext4options->element select stride enter stripe-width -> copy open/edit stripe-width -> description, click delete cut'n'paste man page in value field, cleanup, store - Now it's time to offer the relevant choice open/edit class MyFstab::Fsline element fs_fstype choice enter 'ext4' in entry beside 'push item'. click 'push item' - And enter the relevant rules in fs_mntopts open/edit class MyFstab::Fsline element fs_mntopts rules select copy ext3 entry in ext4 (if modif does not show up (bug) -> close and open tree) - In menu bar, click Model-> test open fs -> empty, which is normal -> no fstab file is read if problem with Model->test, run 'config-edit -model MyFstab -model_dir lib/Config/Model/models' - add a new file system to test ext4 * add a new label (suggests mount point): home * open label * set fs_spec to /dev/sda1 * set fs_file to /home * fs_vfstype to ext4 Note the new available mount options, including the stripe parameter (for ext4) and journalling_mode (ext3) Remember: it's a demo, there's no code to write back fstab.. yet ShellVar.pm100644001750001750 1221512676543661 21575 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Backend# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::ShellVar; $Config::Model::Backend::ShellVar::VERSION = '2.082'; use Carp; use Mouse; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); extends 'Config::Model::Backend::Any'; my $logger = get_logger("Backend::ShellVar"); sub suffix { return '.conf'; } 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' # io_handle => $io # IO::File object # check => yes|no|skip return 0 unless defined $args{io_handle}; # no file to read my $check = $args{check} || 'yes'; my @lines = $args{io_handle}->getlines; # 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; $data =~ s/\s*=\s*/=/; # make reader quite tolerant my $load = qq!$data!; $load .= qq!#"$c"! if $c; $logger->debug("Loading:$load\n"); $self->node->load( step => $load, 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' # io_handle => $io # IO::File object # check => yes|no|skip my $ioh = $args{io_handle}; my $node = $args{object}; croak "Undefined file handle to write" unless defined $ioh; my @to_write; # Using Config::Model::ObjTreeScanner would be overkill foreach my $elt ( $node->get_element_name ) { 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) { $self->write_global_comment( $ioh, '#' ); map { $self->write_data_and_comments( $ioh, '#', @$_ ); } @to_write; } return 1; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config as a C data structure __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::ShellVar - Read and write config as a C data structure =head1 VERSION version 2.082 =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/} ], read_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 will contain C<'a','b'>. =head1 CONSTRUCTOR =head2 new ( node => $node_obj, name => 'shellvar' ) ; Inherited from L. The constructor will be called by L. =head2 read ( io_handle => ... ) 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 this case, C will return 0. When a file is read, C will return 1. =head2 write ( io_handle => ... ) Of all parameters passed to this write call-back, only C is used. This parameter must be L object already opened for write. C will return 1. =head1 AUTHOR Dominique Dumont, (ddumont at cpan dot org) =head1 SEE ALSO L, L, L, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut PlainFile.pm100644001750001750 1533112676543661 21722 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Backend# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Backend::PlainFile; $Config::Model::Backend::PlainFile::VERSION = '2.082'; use Carp; use Mouse; use Config::Model::Exception; use File::Path; use Log::Log4perl qw(get_logger :levels); extends 'Config::Model::Backend::Any'; my $logger = get_logger("Backend::PlainFile"); sub suffix { return ''; } sub annotation { return 0; } sub skip_open { 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' # io_handle => $io # IO::File object # check => yes|no|skip my $check = $args{check} || 'yes'; my $dir = $args{config_dir}; my $node = $args{object}; $logger->debug( "called on node", $node->name ); # read data from leaf element from the node foreach my $elt ( $node->get_element_name() ) { my $file = $args{root} . $dir . $elt; $logger->trace("looking for plainfile $file"); my $obj = $args{object}->fetch_element( name => $elt ); 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 skiped $type $elt"); } } return 1; } # # New subroutine "open_for_read" extracted - Thu Jul 21 13:36:52 2011. # sub open_for_read { my ( $self, $file, $elt ) = @_; return unless -e $file; my $fh = new IO::File; $fh->open($file) or die "Cannot open $file:$!"; $fh->binmode(":utf8"); $logger->trace("found file $file for element $elt"); return ($fh); } # # New subroutine "read_leaf" extracted - Thu Jul 21 12:58:06 2011. # sub read_leaf { my ( $self, $obj, $elt, $check, $file, $args ) = @_; my $fh = $self->open_for_read( $file, $elt ) or return; my $v = join( '', $fh->getlines ); chomp $v unless $obj->value_type eq 'string'; $obj->store( value => $v, check => $check ); } # # New subroutine "read_list" extracted - Thu Jul 21 12:58:36 2011. # sub read_list { my ( $self, $obj, $elt, $check, $file, $args ) = @_; my $fh = $self->open_for_read( $file, $elt ) or return; my @v = $fh->getlines; chomp @v; $obj->store_set(@v); } # # New subroutine "read_hash" extracted - Thu Jul 21 12:58:50 2011. # sub read_hash { my ( $self, $obj, $elt, $check, $file, $args ) = @_; $logger->debug("PlainFile read skipped hash $elt"); } 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 read # file => 'foo.conf', # file name # file_path => './my_test/etc/foo/foo.conf' # io_handle => $io # IO::File object # check => yes|no|skip my $check = $args{check} || 'yes'; my $dir = $args{root} . $args{config_dir}; mkpath( $dir, { mode => 0755 } ) unless -d $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 $file = $dir . $elt; my $obj = $args{object}->fetch_element( name => $elt ); my $type = $obj->get_type; my @v; if ( $type eq 'leaf' ) { $v[0] = $obj->fetch( check => $args{check} ); $v[0] .= "\n" unless $obj->value_type eq 'string'; } elsif ( $type eq 'list' ) { @v = map { "$_\n" } $obj->fetch_all_values; } else { $logger->debug("PlainFile write skipped $type $elt"); } if (@v) { $logger->trace("PlainFile write opening $file to write"); my $fh = new IO::File; $fh->open( $file, '>' ) or die "Cannot open $file:$!"; $fh->binmode(":utf8"); $fh->print(@v); $fh->close; } } return 1; } no Mouse; __PACKAGE__->meta->make_immutable; 1; # ABSTRACT: Read and write config as plain file __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Backend::PlainFile - Read and write config as plain file =head1 VERSION version 2.082 =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/ }, ], read_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 will contain 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. This module supports currently only leaf and list elements. In the case of C element, each line of the file is a value of the list. =head1 Methods =head2 read_leaf (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 (obj,elt,check,file,args); Like L for list elements. =head2 write ( ) C will write 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, =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Multistrap.pl100644001750001750 1255512676543661 22163 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'class_description' => 'Class for multistrap configuration files. Note that multistrap is based on INI where section and keys are case insensitive. Hence all sections and keys are converted to lower case and written back as lower case. Most values (but not all) are also case-insensitive. These values will also be written back as lowercase.', 'accept' => [ '\\w+', { 'value_type' => 'uniline', 'warn' => 'Handling unknown parameter as uniline value.', 'type' => 'leaf' } ], 'read_config' => [ { 'force_lc_section' => '1', 'join_list_value' => ' ', 'backend' => 'ini_file', 'force_lc_key' => '1', 'auto_create' => '1', 'section_map' => { 'general' => '!' }, 'split_list_value' => '\\s+', 'write_boolean_as' => [ 'false', 'true' ], 'store_class_in_hash' => 'sections' } ], 'name' => 'Multistrap', 'element' => [ 'include', { 'convert' => 'lc', 'value_type' => 'uniline', 'summary' => 'Include file for cascaded configuration', 'class' => 'Config::Model::Value::LayeredInclude', 'type' => 'leaf', 'description' => 'To support multiple variants of a basic (common) configuration, "multistrap" allows configuration files to include other (more general) configuration files. i.e. the most detailed / specific configuration file is specified on the command line and that file includes another file which is shared by other configurations.' }, 'arch', { 'value_type' => 'enum', 'type' => 'leaf', 'choice' => [ 'alpha', 'arm', 'armel', 'powerpc' ] }, 'directory', { 'value_type' => 'uniline', 'summary' => 'target directory', 'type' => 'leaf', 'description' => 'top level directory where the bootstrap will be created' }, 'aptsources', { 'cargo' => { 'convert' => 'lc', 'value_type' => 'reference', 'type' => 'leaf', 'refer_to' => '- sections' }, 'duplicates' => 'forbid', 'type' => 'list', 'description' => 'aptsources is a list of sections to be used in the /etc/apt/sources.list.d/multistrap.sources.list of the target. Order is not important.' }, 'bootstrap', { 'cargo' => { 'convert' => 'lc', 'value_type' => 'reference', 'type' => 'leaf', 'refer_to' => '- sections' }, 'duplicates' => 'forbid', 'type' => 'list', 'description' => 'the bootstrap option determines which repository is used to calculate the list of Priority: required packages and which packages go into the rootfs. The order of sections is not important.' }, 'debootstrap', { 'cargo' => { 'convert' => 'lc', 'value_type' => 'reference', 'type' => 'leaf', 'refer_to' => '- sections' }, 'status' => 'deprecated', 'duplicates' => 'forbid', 'type' => 'list', 'description' => 'Replaced by bootstrap parameter' }, 'omitrequired', { 'value_type' => 'boolean', 'type' => 'leaf' }, 'addimportant', { 'value_type' => 'boolean', 'type' => 'leaf' }, 'configscript', { 'convert' => 'lc', 'value_type' => 'uniline', 'type' => 'leaf' }, 'setupscript', { 'convert' => 'lc', 'value_type' => 'uniline', 'type' => 'leaf' }, 'cleanup', { 'value_type' => 'boolean', 'type' => 'leaf', 'description' => 'remove apt cache data, downloaded Packages files and the apt package cache.' }, 'noauth', { 'value_type' => 'boolean', 'type' => 'leaf', 'description' => 'allow the use of unauthenticated repositories' }, 'explicitsuite', { 'value_type' => 'boolean', 'upstream_default' => '0', 'type' => 'leaf', 'description' => 'whether to add the /suite to be explicit about where apt needs to look for packages.' }, 'unpack', { 'convert' => 'lc', 'value_type' => 'boolean', 'summary' => 'extract all downloaded archives', 'upstream_default' => '1', 'migrate_from' => { 'formula' => '$old', 'variables' => { 'old' => '- forceunpack' } }, 'type' => 'leaf' }, 'sections', { 'convert' => 'lc', 'cargo' => { 'type' => 'node', 'config_class_name' => 'Multistrap::Section' }, 'type' => 'hash', 'index_type' => 'string' }, 'forceunpack', { 'convert' => 'lc', 'value_type' => 'boolean', 'summary' => 'extract all downloaded archives', 'status' => 'deprecated', 'upstream_default' => '1', 'type' => 'leaf', 'description' => 'deprecated. Replaced by unpack' } ] } ] ; Utils000755001750001750 012676543661 17107 5ustar00domidomi000000000000Config-Model-2.082/lib/Config/ModelGenClassPod.pm100644001750001750 432412676543661 21752 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Utils# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Utils::GenClassPod; $Config::Model::Utils::GenClassPod::VERSION = '2.082'; # ABSTRACT: generate pod documentation from configuration models use strict; use warnings; use 5.010; use parent qw(Exporter); our @EXPORT = qw(gen_class_pod); use lib qw/lib/; use Path::Tiny ; use Config::Model ; # to generate doc sub gen_class_pod { my $cm = Config::Model -> new(model_dir => "lib/Config/Model/models") ; my @models = @_ ? @_ : map { /model\s*=\s*([\w:-]+)/; $1; } grep { /^\s*model/; } map { $_->lines; } map { $_->children; } path ("lib/Config/Model/")->children(qr/\.d$/); foreach my $model (@models) { # this test avoid generating doc several times (generate_doc scan docs for # classes referenced by the model with config_class_name parameter) if (not $cm->model_exists($model)) { print "Checking doc for model $model\n"; $cm->load($model) ; $cm->generate_doc ($model,'lib') ; } } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Utils::GenClassPod - generate pod documentation from configuration models =head1 VERSION version 2.082 =head1 SYNOPSIS use Config::Model::Utils::GenClassPod; gen_class_pod; # or gen_class_pod('Foo','Bar',...) =head1 DESCRIPTION This module provides a single exported function: C. This function will scan C<./lib/Config/Model/models/*.d> and generate pod documentation for each file found there using L You can also pass one or more class names. C will write the documentation for each passed class and all other classes used by the passed classes. =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut IdElementReference.pm100644001750001750 2534512676543661 22223 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::IdElementReference; $Config::Model::IdElementReference::VERSION = '2.082'; 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_refered_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->debug("path: @path"); my $refered_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 = $refered_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__ =pod =encoding UTF-8 =head1 NAME Config::Model::IdElementReference - Refer to id element(s) and extract keys =head1 VERSION version 2.082 =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 $step = '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( step => $step ); 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 will be 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 refered_to hash element or the values of the refered_to 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 refered_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 =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut Multistrap.pod100644001750001750 560312676543661 22306 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models# PODNAME: Config::Model::models::Multistrap # ABSTRACT: Configuration class Multistrap =head1 NAME Config::Model::models::Multistrap - Configuration class Multistrap =head1 DESCRIPTION Configuration classes used by L Class for multistrap configuration files. Note that multistrap is based on INI where section and keys are case insensitive. Hence all sections and keys are converted to lower case and written back as lower case. Most values (but not all) are also case-insensitive. These values will also be written back as lowercase. =head1 Elements =head2 include - Include file for cascaded configuration To support multiple variants of a basic (common) configuration, "multistrap" allows configuration files to include other (more general) configuration files. i.e. the most detailed / specific configuration file is specified on the command line and that file includes another file which is shared by other configurations.I<< Optional. Type uniline. >> =head2 arch I<< Optional. Type enum. choice: 'alpha', 'arm', 'armel', 'powerpc'. >> =head2 directory - target directory top level directory where the bootstrap will be created. I<< Optional. Type uniline. >> =head2 aptsources aptsources is a list of sections to be used in the /etc/apt/sources.list.d/multistrap.sources.list of the target. Order is not important.I<< Optional. Type list of reference. >> =head2 bootstrap the bootstrap option determines which repository is used to calculate the list of Priority: required packages and which packages go into the rootfs. The order of sections is not important.I<< Optional. Type list of reference. >> =head2 debootstrap Replaced by bootstrap parameter. B I<< Optional. Type list of reference. >> =head2 omitrequired I<< Optional. Type boolean. >> =head2 addimportant I<< Optional. Type boolean. >> =head2 configscript I<< Optional. Type uniline. >> =head2 setupscript I<< Optional. Type uniline. >> =head2 cleanup remove apt cache data, downloaded Packages files and the apt package cache.I<< Optional. Type boolean. >> =head2 noauth allow the use of unauthenticated repositories. I<< Optional. Type boolean. >> =head2 explicitsuite whether to add the /suite to be explicit about where apt needs to look for packages.I<< Optional. Type boolean. upstream_default: '0'. >> =head2 unpack - extract all downloaded archives I<< Optional. Type boolean. upstream_default: '1'. >> Note: unpack is migrated with 'C<$old>' and with $old => "C<- forceunpack>" =head2 sections I<< Optional. Type hash of node of class L . >> =head2 forceunpack - extract all downloaded archives deprecated. Replaced by unpack. B I<< Optional. Type boolean. upstream_default: '1'. >> =head1 SEE ALSO =over =item * L =item * L =back =cut bash_completion.cme_multistrap100644001750001750 54212676543661 22675 0ustar00domidomi000000000000Config-Model-2.082/contrib# cme(1) completion for multistrap model # # # This file is part of Config-Model # # This software is Copyright (c) 2014 by Dominique Dumont # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # _cme_multistrap() { COMPREPLY=( $( compgen -o filenames -G "$cur*" -W '~~ -' -- $cur ) ) } Fstab000755001750001750 012676543661 20331 5ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/modelsFsLine.pl100644001750001750 1256512676543661 22237 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models/Fstab# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'class_description' => 'data of one /etc/fstab line', 'name' => 'Fstab::FsLine', 'copyright' => [ '2010,2011 Dominique Dumont' ], 'author' => [ 'Dominique Dumont' ], 'license' => 'LGPL2', 'element' => [ 'fs_spec', { 'value_type' => 'uniline', 'warp' => { 'follow' => { 'f1' => '- fs_vfstype' }, 'rules' => [ '$f1 eq \'proc\'', { 'default' => 'proc' } ] }, 'mandatory' => 1, 'type' => 'leaf', 'description' => 'block special device or remote filesystem to be mounted' }, 'fs_file', { 'value_type' => 'uniline', 'warp' => { 'follow' => { 'f1' => '- fs_vfstype' }, 'rules' => [ '$f1 eq \'proc\'', { 'default' => '/proc' }, '$f1 eq \'swap\'', { 'default' => 'none' } ] }, 'mandatory' => 1, 'type' => 'leaf', 'description' => 'mount point for the filesystem' }, 'fs_vfstype', { 'value_type' => 'enum', 'help' => { 'proc' => 'Kernel info through a special file system', 'auto' => 'file system type is probed by the kernel when mounting the device', 'vfat' => 'Older Windows file system often used on removable media', 'ext3' => 'Common Linux file system with journaling ', 'usbfs' => 'USB pseudo file system. Gives a file system view of kernel data related to usb', 'iso9660' => 'CD-ROM or DVD file system', 'ignore' => 'unused disk partition', 'ext2' => 'Common Linux file system.', 'davfs' => 'WebDav access' }, 'mandatory' => 1, 'type' => 'leaf', 'description' => 'file system type', 'choice' => [ 'auto', 'davfs', 'ext2', 'ext3', 'ext4', 'swap', 'proc', 'iso9660', 'vfat', 'usbfs', 'ignore', 'nfs', 'nfs4', 'none', 'ignore', 'debugfs' ] }, 'fs_mntopts', { 'follow' => { 'f1' => '- fs_vfstype' }, 'type' => 'warped_node', 'rules' => [ '$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 \'ext2\'', { 'config_class_name' => 'Fstab::Ext2FsOpt' }, '$f1 eq \'ext3\'', { 'config_class_name' => 'Fstab::Ext3FsOpt' }, '$f1 eq \'ext4\'', { 'config_class_name' => 'Fstab::Ext4FsOpt' }, '$f1 eq \'usbfs\'', { 'config_class_name' => 'Fstab::UsbFsOptions' }, '$f1 eq \'davfs\'', { 'config_class_name' => 'Fstab::CommonOptions' }, '$f1 eq \'iso9660\'', { 'config_class_name' => 'Fstab::Iso9660_Opt' }, '$f1 eq \'nfs\'', { 'config_class_name' => 'Fstab::CommonOptions' }, '$f1 eq \'nfs4\'', { 'config_class_name' => 'Fstab::CommonOptions' }, '$f1 eq \'none\'', { 'config_class_name' => 'Fstab::NoneOptions' }, '$f1 eq \'debugfs\'', { 'config_class_name' => 'Fstab::CommonOptions' } ], 'description' => 'mount options associated with the filesystem' }, 'fs_freq', { 'value_type' => 'enum', 'warp' => { 'follow' => { 'isbound' => '- fs_mntopts bind', 'fstyp' => '- fs_vfstype' }, 'rules' => [ '$fstyp eq "none" and $isbound', { 'choice' => [ '0' ] } ] }, 'default' => '0', 'type' => 'leaf', 'description' => 'Specifies if the file system needs to be dumped', 'choice' => [ '0', '1' ] }, 'fs_passno', { 'value_type' => 'integer', 'summary' => 'fsck pass number', 'warp' => { 'follow' => { 'isbound' => '- fs_mntopts bind', 'fstyp' => '- fs_vfstype' }, 'rules' => [ '$fstyp eq "none" and $isbound', { 'max' => '0' } ] }, 'default' => 0, 'type' => 'leaf', 'description' => 'used by the fsck(8) program to determine the order in which filesystem checks are done at reboot time' } ] } ] ; multistrap-test-conf.pl100644001750001750 360412676543661 22607 0ustar00domidomi000000000000Config-Model-2.082/t/model_tests.d# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # $model_to_test = "Multistrap"; $from_scratch_file = <<'EOF' , ## This file was written by cme command. ## You can run 'cme edit multistrap' to modify this file. ## You may also modify the content of this file with your favorite editor. [general] include=/usr/share/multistrap/crosschroot.conf EOF @tests = ( { name => 'arm', config_file => '/home/foo/my_arm.conf', check => { 'sections:toolchains packages:0' ,'g++-4.2-arm-linux-gnu', 'sections:toolchains packages:1', 'linux-libc-dev-arm-cross', }, load_warnings => undef , # some weird warnings pop up in Perl smoke tests with perl 5.15.9 }, { name => 'from_scratch', config_file => '/home/foo/my_arm.conf', load => "include=/usr/share/multistrap/crosschroot.conf" , check => { # values brought by included file 'sections:debian packages:0', {qw/mode layered value dpkg-dev/}, 'sections:base packages:0', {qw/mode layered value gcc-4.2-base/}, 'sections:toolchains packages:0', undef, 'sections:toolchains packages:1', undef, }, file_check_sub => sub { my $r = shift ; # this file was created after the load instructions above unshift @$r, "/home/foo/my_arm.conf"; }, file_content => { "/home/foo/my_arm.conf" => $from_scratch_file , } }, { name => 'igep0020', config_file => '/home/foo/strap-igep0020.conf', load_check => 'skip', load_warnings => [ qr/deprecated/, (qr/deprecated/, qr/skipping/) x2 ] }, ); 1; FsLine.pod100644001750001750 360412676543661 22360 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models/Fstab# PODNAME: Config::Model::models::Fstab::FsLine # ABSTRACT: Configuration class Fstab::FsLine =head1 NAME Config::Model::models::Fstab::FsLine - Configuration class Fstab::FsLine =head1 DESCRIPTION Configuration classes used by L data of one /etc/fstab line =head1 Elements =head2 fs_spec block special device or remote filesystem to be mounted. I<< Mandatory. Type uniline. >> =head2 fs_file mount point for the filesystem. I<< Mandatory. Type uniline. >> =head2 fs_vfstype file system type. I<< Mandatory. Type enum. choice: 'auto', 'davfs', 'ext2', 'ext3', 'ext4', 'swap', 'proc', 'iso9660', 'vfat', 'usbfs', 'ignore', 'nfs', 'nfs4', 'none', 'ignore', 'debugfs'. >> Here are some explanations on the possible values: =over =item 'auto' file system type is probed by the kernel when mounting the device =item 'davfs' WebDav access =item 'ext2' Common Linux file system. =item 'ext3' Common Linux file system with journaling =item 'ignore' unused disk partition =item 'iso9660' CD-ROM or DVD file system =item 'proc' Kernel info through a special file system =item 'usbfs' USB pseudo file system. Gives a file system view of kernel data related to usb =item 'vfat' Older Windows file system often used on removable media =back =head2 fs_mntopts mount options associated with the filesystem. I<< Optional. Type warped_node. >> =head2 fs_freq Specifies if the file system needs to be dumped. I<< Optional. Type enum. choice: '0', '1'. default: '0'. >> =head2 fs_passno - fsck pass number used by the fsck(8) program to determine the order in which filesystem checks are done at reboot time. I<< Optional. Type integer. default: '0'. >> =head1 SEE ALSO =over =item * L =back =head1 AUTHOR =over =item Dominique Dumont =back =head1 COPYRIGHT =over =item 2010,2011 Dominique Dumont =back =head1 LICENSE =over =item LGPL2 =back =cut Value000755001750001750 012676543661 17063 5ustar00domidomi000000000000Config-Model-2.082/lib/Config/ModelLayeredInclude.pm100644001750001750 1012312676543661 22467 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Value# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # package Config::Model::Value::LayeredInclude; $Config::Model::Value::LayeredInclude::VERSION = '2.082'; use 5.010; use strict; use warnings; use Log::Log4perl qw(get_logger :levels); use base qw/Config::Model::Value/; my $logger = get_logger("Tree::Element::Value::LayeredInclude"); # should we clear all layered value when include value is changed ? # If yes, beware of recursive includes. Clear should only be done once. sub _store { my $self = shift; my %args = @_; my ( $value, $check, $silent, $notify_change, $ok, $callback ) = @args{qw/value check silent notify_change ok callback/}; my $old_value = $self->_fetch_no_check; $self->SUPER::_store(%args); { no warnings 'uninitialized'; return $value if $value eq $old_value; } my $i = $self->instance; my $already_in_layered = $i->layered; # layered stuff here if ( not $already_in_layered ) { $i->layered_clear; $i->layered_start; } { no warnings 'uninitialized'; $logger->debug("Loading layered config from $value (old_data is $old_value)"); } # load included file in layered mode $self->root->read_config_data( # check => 'no', config_file => $value, auto_create => 0, # included file must exist ); if ( not $already_in_layered ) { $i->layered_stop; } # test if already in layered mode -> if no, clear layered, $logger->debug("Done loading layered config from $value"); return $value; } sub _check_value { my $self = shift; my %args = @_ > 1 ? @_ : ( value => $_[0] ); my $value = $args{value}; my $quiet = $args{quiet} || 0; my $check = $args{check} || 'yes'; my $apply_fix = $args{fix} || 0; my $mode = $args{mode} || ''; $self->SUPER::check_value(@_); # need to test that prest config file is present as the model # may not enforce it (when read_config auto_create is 1) my $layered_file = $self->instance->read_root_dir; $layered_file .= $value; my $err = $self->{error_list}; if ( not -r $layered_file ) { push @$err, "cannot read include file $$layered_file"; } return wantarray ? @$err : scalar @$err ? 0 : 1; } 1; # ABSTRACT: Include a sub layer configuration __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Value::LayeredInclude - Include a sub layer configuration =head1 VERSION version 2.082 =head1 SYNOPSIS # in a model declaration: 'element' => [ 'include' => { 'class' => 'Config::Model::Value::LayeredInclude', # usual Config::Model::Value parameters 'type' => 'leaf', 'value_type' => 'uniline', 'convert' => 'lc', 'summary' => 'Include file for cascaded configuration', 'description' => 'To support multiple variants of ...' }, ] =head1 DESCRIPTION This class inherits from L. It overrides L<_store> to trigger a refresh of layered value when value is actually changed. I.e. changing this value will reload the refered configuration file and use its values as default value. This class was designed to cope with L configuration. =head2 CAUTION A configuration file can support 2 kinds of include: =over =item * Layered include which sets default values like multistrap or ssh. These includes are read-only. =item * Real includes like C. In this cases modified configuration items can be written to included files. =back This class works only with the first type =head1 AUTHOR Copyright 2011,2013 Dominique Dumont =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut application.d000755001750001750 012676543661 20534 5ustar00domidomi000000000000Config-Model-2.082/lib/Config/Modelmultistrap100644001750001750 5312676543661 22761 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/application.dmodel = Multistrap require_config_file = 1 backend-json-test-conf.pl100644001750001750 231312676543661 22735 0ustar00domidomi000000000000Config-Model-2.082/t/model_tests.d# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use Config::Model::BackendMgr; # test shellvar backend $conf_dir = '/etc'; $conf_file_name = 'hosts.json'; $model->create_config_class( name => 'Host', element => [ [qw/ipaddr canonical alias/] => { type => 'leaf', value_type => 'uniline', }, dummy => {qw/type leaf value_type uniline default toto/}, ] ); $model->create_config_class( name => 'Hosts', read_config => [ { backend => 'json', config_dir => '/etc/', file => 'hosts.json', }, ], element => [ record => { type => 'list', cargo => { type => 'node', config_class_name => 'Host', }, }, ] ); $model_to_test = "Hosts"; @tests = ( { name => 'basic', check => [ 'record:0 ipaddr' => '127.0.0.1', 'record:1 canonical' => 'bilbo' ] }, ); 1; Ext4FsOpt.pl100644001750001750 164212676543661 22631 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models/Fstab# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'name' => 'Fstab::Ext4FsOpt', 'include' => [ 'Fstab::Ext2FsOpt' ], 'copyright' => [ '2010,2011 Dominique Dumont' ], 'author' => [ 'Dominique Dumont' ], 'license' => 'LGPL2', 'element' => [ 'lazy_itable_init', { 'value_type' => 'boolean', 'upstream_default' => '1', 'type' => 'leaf', 'description' => "If enabled and the uninit_bg feature is enabled, the inode table will not be fully initialized by mke2fs. This speeds up filesystem initialization noticeably, but it requires the kernel to finish initializing the filesystem in the background when the filesystem is first mounted." } ] } ] ; Ext3FsOpt.pl100644001750001750 325012676543661 22625 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models/Fstab# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'class_description' => 'Options for ext4 file systems. Please contact author (domi.dumont at cpan.org) if options are missing.', 'name' => 'Fstab::Ext3FsOpt', 'include' => [ 'Fstab::Ext2FsOpt' ], 'copyright' => [ '2010,2011 Dominique Dumont' ], 'author' => [ 'Dominique Dumont' ], 'license' => 'LGPL2', 'element' => [ 'journalling_mode', { 'value_type' => 'enum', 'help' => { 'ordered' => 'This is the default mode. All data is forced directly out to the main file system prior to its metadata being committed to the journal.', 'writeback' => 'Data ordering is not preserved - data may be writteninto the main file system after its metadata has been committed to the journal. This is rumoured to be the highest-throughput option. It guarantees internal file system integrity, however it can allow old data to appear in files after a crash and journal recovery.', 'journal' => 'All data is committed into the journal prior to being written into the main file system. ' }, 'type' => 'leaf', 'description' => 'Specifies the journalling mode for file data. Metadata is always journaled. To use modes other than ordered on the root file system, pass the mode to the kernel as boot parameter, e.g. rootflags=data=journal.', 'choice' => [ 'journal', 'ordered', 'writeback' ] } ] } ] ; Ext2FsOpt.pl100644001750001750 235112676543661 22625 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models/Fstab# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'accept' => [ '.*', { 'value_type' => 'uniline', 'type' => 'leaf', 'description' => 'unknown parameter' } ], 'name' => 'Fstab::Ext2FsOpt', 'include' => [ 'Fstab::CommonOptions' ], 'copyright' => [ '2010,2011 Dominique Dumont' ], 'author' => [ 'Dominique Dumont' ], 'license' => 'LGPL2', 'element' => [ 'acl', { 'value_type' => 'boolean', 'type' => 'leaf' }, 'user_xattr', { 'value_type' => 'boolean', 'type' => 'leaf', 'description' => 'Support "user." extended attributes ' }, 'statfs_behavior', { 'value_type' => 'enum', 'type' => 'leaf', 'choice' => [ 'bsddf', 'minixdf' ] }, 'errors', { 'value_type' => 'enum', 'type' => 'leaf', 'choice' => [ 'continue', 'remount-ro', 'panic' ] } ] } ] ; backend-json-examples000755001750001750 012676543661 22155 5ustar00domidomi000000000000Config-Model-2.082/t/model_tests.dbasic100644001750001750 25212676543661 23300 0ustar00domidomi000000000000Config-Model-2.082/t/model_tests.d/backend-json-examples{ "record": [ { "ipaddr": "127.0.0.1", "canonical": "localhost", "alias": "localhost" }, { "ipaddr": "192.168.0.1", "canonical": "bilbo" } ] } Iso9660_Opt.pl100644001750001750 124212676543661 22726 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models/Fstab# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'name' => 'Fstab::Iso9660_Opt', 'include' => [ 'Fstab::CommonOptions' ], 'copyright' => [ '2010,2011 Dominique Dumont' ], 'author' => [ 'Dominique Dumont' ], 'license' => 'LGPL2', 'element' => [ 'rock', { 'value_type' => 'boolean', 'type' => 'leaf' }, 'joliet', { 'value_type' => 'boolean', 'type' => 'leaf' } ] } ] ; SwapOptions.pl100644001750001750 106712676543661 23320 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models/Fstab# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'class_description' => 'Swap options', 'name' => 'Fstab::SwapOptions', 'copyright' => [ '2010,2011 Dominique Dumont' ], 'author' => [ 'Dominique Dumont' ], 'license' => 'LGPL2', 'element' => [ 'sw', { 'value_type' => 'boolean', 'type' => 'leaf' } ] } ] ; NoneOptions.pl100644001750001750 113212676543661 23276 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models/Fstab# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'class_description' => 'Options for special file system like \'bind\'', 'name' => 'Fstab::NoneOptions', 'copyright' => [ '2010,2011 Dominique Dumont' ], 'author' => [ 'Dominique Dumont' ], 'license' => 'LGPL2', 'element' => [ 'bind', { 'value_type' => 'boolean', 'type' => 'leaf' } ] } ] ; UsbFsOptions.pl100644001750001750 324612676543661 23431 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models/Fstab# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'class_description' => 'usbfs options', 'name' => 'Fstab::UsbFsOptions', 'include' => [ 'Fstab::CommonOptions' ], 'copyright' => [ '2010,2011 Dominique Dumont' ], 'author' => [ 'Dominique Dumont' ], 'license' => 'LGPL2', 'element' => [ 'devuid', { 'value_type' => 'integer', 'upstream_default' => '0', 'type' => 'leaf' }, 'devgid', { 'value_type' => 'integer', 'upstream_default' => '0', 'type' => 'leaf' }, 'busuid', { 'value_type' => 'integer', 'upstream_default' => '0', 'type' => 'leaf' }, 'budgid', { 'value_type' => 'integer', 'upstream_default' => '0', 'type' => 'leaf' }, 'listuid', { 'value_type' => 'integer', 'upstream_default' => '0', 'type' => 'leaf' }, 'listgid', { 'value_type' => 'integer', 'upstream_default' => '0', 'type' => 'leaf' }, 'devmode', { 'value_type' => 'integer', 'upstream_default' => '0644', 'type' => 'leaf' }, 'busmode', { 'value_type' => 'integer', 'upstream_default' => '0555', 'type' => 'leaf' }, 'listmode', { 'value_type' => 'integer', 'upstream_default' => '0444', 'type' => 'leaf' } ] } ] ; Multistrap000755001750001750 012676543661 21436 5ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/modelsSection.pl100644001750001750 222012676543661 23533 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models/Multistrap# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'accept' => [ '\\w+', { 'value_type' => 'uniline', 'warn' => 'Handling unknown parameter as unlinie value.', 'type' => 'leaf' } ], 'name' => 'Multistrap::Section', 'element' => [ 'packages', { 'cargo' => { 'value_type' => 'uniline', 'type' => 'leaf' }, 'type' => 'list' }, 'components', { 'cargo' => { 'value_type' => 'uniline', 'type' => 'leaf' }, 'type' => 'list' }, 'source', { 'value_type' => 'uniline', 'type' => 'leaf' }, 'keyring', { 'value_type' => 'uniline', 'type' => 'leaf' }, 'suite', { 'value_type' => 'uniline', 'type' => 'leaf' }, 'omitdebsrc', { 'value_type' => 'boolean', 'type' => 'leaf' } ] } ] ; backend-shellvar-test-conf.pl100644001750001750 164512676543661 23613 0ustar00domidomi000000000000Config-Model-2.082/t/model_tests.d# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # use Config::Model::BackendMgr; # test shellvar backend $home_for_test = '/home/joe'; $conf_file_name = 'foo.conf'; $conf_dir = '/etc'; $model->create_config_class( name => "Shelly", element => [ [qw/foo bar/], { 'value_type' => 'uniline', 'type' => 'leaf', }, ], 'read_config' => [ { backend => 'ShellVar', config_dir => '/etc', file => 'foo.conf', } ] ); $model_to_test = "Shelly"; @tests = ( { # mini (test for Debian #719256) name => 'debian-719256', check => [ foo => 'ok', bar => "with space" ] }, ); 1; CommonOptions.pl100644001750001750 346612676543661 23643 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models/Fstab# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'class_description' => 'options valid for all types of file systems.', 'name' => 'Fstab::CommonOptions', 'copyright' => [ '2010,2011 Dominique Dumont' ], 'author' => [ 'Dominique Dumont' ], 'license' => 'LGPL2', 'element' => [ 'async', { 'value_type' => 'boolean', 'type' => 'leaf' }, 'atime', { 'value_type' => 'boolean', 'type' => 'leaf' }, 'auto', { 'value_type' => 'boolean', 'type' => 'leaf' }, 'dev', { 'value_type' => 'boolean', 'type' => 'leaf' }, 'exec', { 'value_type' => 'boolean', 'type' => 'leaf' }, 'group', { 'value_type' => 'boolean', 'type' => 'leaf' }, 'mand', { 'value_type' => 'boolean', 'type' => 'leaf' }, 'user', { 'value_type' => 'boolean', 'help' => { '1' => 'user can mount the file system', '0' => 'Only root can mount the file system' }, 'type' => 'leaf' }, 'defaults', { 'value_type' => 'boolean', 'help' => { '1' => 'option equivalent to rw, suid, dev, exec, auto, nouser, and async' }, 'type' => 'leaf' }, 'rw', { 'value_type' => 'boolean', 'help' => { '0' => 'read-only file system' }, 'type' => 'leaf' }, 'relatime', { 'value_type' => 'boolean', 'type' => 'leaf' } ] } ] ; Section.pod100644001750001750 123112676543661 23703 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/models/Multistrap# PODNAME: Config::Model::models::Multistrap::Section # ABSTRACT: Configuration class Multistrap::Section =head1 NAME Config::Model::models::Multistrap::Section - Configuration class Multistrap::Section =head1 DESCRIPTION Configuration classes used by L =head1 Elements =head2 packages I<< Optional. Type list of uniline. >> =head2 components I<< Optional. Type list of uniline. >> =head2 source I<< Optional. Type uniline. >> =head2 keyring I<< Optional. Type uniline. >> =head2 suite I<< Optional. Type uniline. >> =head2 omitdebsrc I<< Optional. Type boolean. >> =head1 SEE ALSO =over =item * L =back =cut Cookbook000755001750001750 012676543661 17555 5ustar00domidomi000000000000Config-Model-2.082/lib/Config/ModelCreateModelFromDoc.pod100644001750001750 2210012676543661 24072 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Cookbook# PODNAME: Config::Model::Cookbook::CreateModelFromDoc # ABSTRACT: Create a configuration model from application documentation __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Cookbook::CreateModelFromDoc - Create a configuration model from application documentation =head1 VERSION version 2.082 =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: config-model-edit -model 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. Config::Model 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 at config-model-users at lists dot sourceforge dot net. =head1 AUTHORS Dominique Dumont =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut models000755001750001750 012676543661 22207 5ustar00domidomi000000000000Config-Model-2.082/examples/fstab/lib/Config/ModelMyFstab.pl100644001750001750 227612676543661 24260 0ustar00domidomi000000000000Config-Model-2.082/examples/fstab/lib/Config/Model/models# # This file is part of Config-Model # # This software is Copyright (c) 2005-2016 by Dominique Dumont. # # This is free software, licensed under: # # The GNU Lesser General Public License, Version 2.1, February 1999 # [ { 'class_description' => 'static information about the filesystems', 'name' => 'MyFstab', 'element' => [ 'fs', { 'cargo' => { 'type' => 'node', 'config_class_name' => 'MyFstab::FsLine' }, 'type' => 'hash', 'description' => 'Each "fs" element contain the information about one filesystem. Each filesystem is referred in this model by a label constructed by the fstab parser. This label cannot be stored in the fstab file, so if you create a new file system, the label you will choose may not be stored and will be re-created by the fstab parser', 'index_type' => 'string' } ] } ] ; Manual000755001750001750 012676543661 17224 5ustar00domidomi000000000000Config-Model-2.082/lib/Config/ModelModelCreationAdvanced.pod100644001750001750 2117312676543661 24267 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Manual# PODNAME: Config::Model::Manual::ModelCreationAdvanced # ABSTRACT: Creating a model with advanced features __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Manual::ModelCreationAdvanced - Creating a model with advanced features =head1 VERSION version 2.082 =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 will be 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 will look 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 will disappear from the GUI and some other options will 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 will be 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 will trigger 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 will provide 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 will use 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 =head1 AUTHOR Dominique Dumont =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2005-2016 by Dominique Dumont. This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 =cut ModelCreationIntroduction.pod100644001750001750 6266212676543661 25253 0ustar00domidomi000000000000Config-Model-2.082/lib/Config/Model/Manual# PODNAME: Config::Model::Manual::ModelCreationIntroduction # ABSTRACT: Introduction to model creation with Config::Model __END__ =pod =encoding UTF-8 =head1 NAME Config::Model::Manual::ModelCreationIntroduction - Introduction to model creation with Config::Model =head1 VERSION version 2.082 =head1 Introduction This page describes how to write a simple configuration model. Creation of more complex models are described in L. A tutorial is available in L. Note that this document will show 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 will be 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 will use the configuration file =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 Some will 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 will 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 In terms of models, the model will be 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 will lead 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 will be 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 will be: { 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 configuration classes that will be required, you will have to 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 will also have to find several valid examples. These examples be used as non-regression tests and verify that the documentation was understood. =head1 Model declaration =head2 Configuration class declaration 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 Configuration class declaration (easier way) Since writing a data structure is not fun (even with Perl), you are encouraged to use the model editor provided by L from L module. You will get this type of GUI shown on the right with the command C =head2 Common attributes for all elements This first set of attributes will help 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 will be shown to the user no matter what. hidden elements will be explained with the warp notion. =item * C: is C, C or C (default). Using a deprecated element will issue a warning. Using an obsolete element will raise an exception. =back See L for details. =head2 Simple leaf elements Simple leaf elements will be used most often for configuration files. A leaf element will represent 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 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 will have to 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 will use C if this parameter is left blank in C file. Thus the model of this element will be : 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 repositories must be stored as a hash where the key will be I or I and the associated value will 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 will be stored this way in the configuration tree: root |--distrib(debian)=http://ftp.fr.debian.org/debian `--distrib(multimedia)=http://www.debian-multimedia.org The model will need 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